# HG changeset patch # User cvs # Date 1186992232 -7200 # Node ID e45d5e7c476e1a219226a0b90d0aa1fa6c21cf7c # Parent d3e9274cbc4ee12b01fac393c9a6b6b602b32cf4 Import from CVS: tag r20-4b2 diff -r d3e9274cbc4e -r e45d5e7c476e CHANGES-beta --- a/CHANGES-beta Mon Aug 13 10:02:48 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 10:03:52 2007 +0200 @@ -1,4 +1,70 @@ -*- indented-text -*- +to 20.4 beta2 "Alpine" +-- hm--html-mode has been packaged +-- viper has been packaged +-- ediff has been packaged +-- EFS has been packaged +-- Mailcrypt has been packaged +-- VM has been packaged +-- Mule updates, elimination of dead languages courtesy of MORIOKA Tomohiko +-- Phase one of graphics conversion to ImageMagic courtesy of William Perry +-- Miscellaneous menu hacking courtesy of Kyle Jones +-- Reorganization of Lisp type & type bits courtesy of Kyle Jones +-- reftex.el 3.7 courtesy of Carsten Dominik +-- Norwegian tutorial update courtesy of Stig Bjorlykkee +-- ediff & viper updates courtesy of Michael Kifer +-- Canna & Wnn integrated with LEIM courtesy of Stephen Turnbull +-- Berkeley DB 2.x support courtesy of Andreas Jaegar +-- tm has been packaged +-- calendar has been packaged +-- Build tweak: finder-inf is not aggressively rebuilt +-- New versions of TUTORIAL: +-- Croatian - Hrvoje Niksic +-- French - Didier Verna +-- German - Adrian Aichner +-- Norwegian - Stig Bjorlykke +-- Japanese, Korean, Thai - Imported from Emacs 20.1 +-- Disable puresize statistics unless --debug is in effect +-- about.el hacking +-- New command line options -no-packages, -vanilla +-- psgml has been packaged +-- Move lisp types into lrecords for portability courtesy of Kyle Jones +-- yow.el has been packaged +-- xmine.el has been packaged +-- tetris.el has been packaged +-- hanoi.el has been packaged +-- hide-copyleft.el has been packaged +-- flow-ctrl.el has been packaged +-- find-gc.el has been packaged +-- detached-minibuf.el has been packaged +-- crontab.el has been packaged +-- browse-cltl2.el has been packaged +-- studly.el has been packaged +-- spook.el has been packaged +-- mpuz.el has been packaged +-- life.el has been packaged +-- gomoku.el has been packaged +-- flame.el has been packaged +-- dunnet.el has been packaged +-- doctor.el has been packaged +-- dissociate.el has been packaged +-- decipher.el has been packaged +-- cookie1.el has been packaged +-- conx.el has been packaged +-- blackbox.el has been packaged +-- NeXTify.el has been packaged +-- Support for conses and vectors to be lrecords +-- autoloads found in User packages loaded at start up +-- reftex.el update courtesy of Carsten Dominik +-- crisp.el-1.21 courtesy of Gary Foster +-- lazy-shot.el update from Jan Vroonhof +-- XEmacs/BETA logo courtesy of Mark Borges & Didier Verna +-- Oliver Graf OffiX patches +-- Mule patches from MORIOKA Tomohiko +-- xemacs-build-report-1.33 courtesy of Adrian Aichner +-- Hrvoje Niksic updates +-- Miscellaneous bug fixes + to 20.4 beta1 "Century" -- Version fork, package work will be carried on in this branch -- Miscellaneous bug fixes diff -r d3e9274cbc4e -r e45d5e7c476e ChangeLog --- a/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ b/ChangeLog Mon Aug 13 10:03:52 2007 +0200 @@ -1,3 +1,137 @@ +1997-10-31 SL Baur + + * XEmacs 20.4-beta2 + +1997-10-30 SL Baur + + * configure.in (xetest): Eliminate tests for PNG, JPEG, + TIFF(broken) and replace with test for ImageMagick. + +1997-10-30 Kyle Jones + + * etc/Emacs.ad: Added *XlwMenu*highlightForeground entry. + Added *XlwMenu*titleForeground entry. + + * lwlib/xlwmenu.h: Added string macro declarations for + titleForeground and highlightForeground properties. + + * lwlib/xlwmenuP.h: Added struct fields for title and + highlight colors. + + * lwlib/xlwmenu.c: Added initialization and usage code + for the new titleForeground and highlightForeground + properties. + +1997-10-29 MORIOKA Tomohiko + + * etc/HELLO: Add Czech. + + * etc/HELLO: Delete Amharic, Thai and Tigrigna. + +1997-10-28 SL Baur + + * XEmacs 20.3-beta94 is released. + +1997-10-28 Andreas Jaeger + + * configure.in: Correct last patch for berkdb. + +1997-10-28 SL Baur + + * XEmacs 20.3-beta93 is released. + +1997-10-27 Martin Buchholz + + * lib-src/make-path.c: + * lib-src/digest-doc.c: + * lib-src/gnuslib.c: Always include config.h before system headers + * configure.in: Improve AIX configure support + - NON_GNU_CC defaults to `xlc' + - CFLAGS defaults to "-O3 -qstrict -qlibansi -qinfo -qro + -qmaxmem=20000" + - check for sin instead of sqrt in -lm to avoid xlc internal error + - Detect -li18n for use with Motif + - Move weird AIX static linking flags from s&m files to configure.in + - use #pragma instead of -ma flag to avoid compiler warnings + +1997-10-25 Kyle Jones + + * lwlib/xlwmenu.c: Use XtRDimension in place of + XmRHorizontalDimension in shadowThickness resource + declaration. + + * lwlib/xlwmenu.c (label_button_draw): Use the button_gc + color as the foreground for selected entries. + + * lwlib/xlwmenu.c (push_button_draw): Use the button_gc + color as the foreground for selected entries. + + * lwlib/xlwmenu.c (toggle_decoration_height): Force + height to be minimum of 2x the shadow thickness. + +1997-10-24 Andreas Jaeger + + * configure.in: Don't choke on Berkeley DB 2.x. + +1997-10-24 SL Baur + + * XEmacs 20.3-beta92 is released. + +1997-10-21 SL Baur + + * Makefile.in (lisp/utils/finder-inf.el): Don't force rebuild if + it already exists (use `make finder' to force rebuild). + +1997-10-18 SL Baur + + * XEmacs 20.3-beta91 is released. + +1997-10-16 Hrvoje Niksic + + * etc/NEWS: document changed package load semantics. + +1997-10-15 Olivier Galibert + + * configure.in: Removed -Olimit=2000 from cc for IRIX. + +1997-10-12 Karl M. Hegbloom + + * configure.in (null_string): Added AC_SUBST(infodir_user_defined) + and removed backquoted echo statement from the infopath report line. + +1997-10-15 Olivier Galibert + + * configure.in: Added detection of the declaration of the timezone + variable in system files. Defines HAVE_TIMEZONE_DECL if yes. + + +1997-10-15 Olivier Galibert + + * config.h.in: Add HAVE_TIMEZONE_DECL for detection of declaration + of the timezone variable in system headers. + + * systime.h: Use HAVE_TIMEZONE_DECL. + +1997-10-14 SL Baur + + * configure.in (all_widgets): Don't allow configuration of + --with-mule if Mule lisp hasn't been installed. + +1997-10-13 SL Baur + + * configure.in: Remove `site-lisp' from list of directories to + make symbolic links for. + + * XEmacs 20.3-beta90 is released. + +1997-10-12 Glynn Clements + + * info/dir: Cosmetic changes to info/dir + +1997-10-13 Hrvoje Niksic + + * etc/NEWS: Updates + 1997-10-12 SL Baur * XEmacs 20.4-beta1 is released. @@ -22,7 +156,7 @@ and lockdir * '' added a line to the report for infopath and lockdir - * NEWS: Draft entry for the info changes. + * etc/NEWS: Draft entry for the info changes. 1997-10-10 Karl M. Hegbloom diff -r d3e9274cbc4e -r e45d5e7c476e Makefile.in --- a/Makefile.in Mon Aug 13 10:02:48 2007 +0200 +++ b/Makefile.in Mon Aug 13 10:03:52 2007 +0200 @@ -272,7 +272,7 @@ ${blddir}/src/xemacs -batch -q -no-site-file \ -l finder -f finder-compile-keywords ) -lisp/utils/finder-inf.el: FRC.lisp.utils.finder-inf.el +lisp/utils/finder-inf.el: @(cd lisp/utils; \ ${blddir}/src/xemacs -batch -q -no-site-file \ -l finder -f finder-compile-keywords ) diff -r d3e9274cbc4e -r e45d5e7c476e PROBLEMS --- a/PROBLEMS Mon Aug 13 10:02:48 2007 +0200 +++ b/PROBLEMS Mon Aug 13 10:03:52 2007 +0200 @@ -82,9 +82,6 @@ This error message has been observed with lesstif-0.75a. It does not appear to cause any harm. -### Does this happen in any of the more recent versions of -Lesstif/XEmacs? - ** Linking with -rpath on IRIX. Darrell Kindred writes: @@ -106,7 +103,10 @@ or --site-runtime-libraries, you must use --use-gcc=no, or configure will fail. -### Is this valid in 20.3? +** On Irix 6.3, the SGI ld quits with segmentation fault when linking temacs + +This occurs if you use the SGI linker version 7.1. Installing the +patch SG0001872 fixes this problem. ** On Irix 5.x and 6.x, the dumped XEmacs (xemacs) core dumps when executed on another machine, or after newer SGI IRIX patches have been installed. @@ -170,8 +170,6 @@ remember the patch numbers. I think potential XEmacs builders on HP should be warned about this. -### Fixed in 20.3? - ** I don't have `xmkmf' and `imake' on my HP. You can get these standard X tools by anonymous FTP to hpcvaaz.cv.hp.com. @@ -191,8 +189,6 @@ Compiler fixes in Irix 6.0.1 should eliminate this problem. -### Fixed in 20.3? - ** Native cc on SCO OpenServer 5 is now OK. Icc may still throw you a curve. Here is what Robert Lipe says: @@ -257,7 +253,8 @@ the emacstrs.sco is a suitable candidate for /usr/lib/keyboard/strings to take advantage of the keyboard map in emacskeys.sco. -### Is this valid in 20.3? +Note: Much of the above entry is probably not valid for XEmacs 20.3 +and later. ** Under some versions of OSF XEmacs runs fine if built without optimization but will crash randomly if built with optimization. @@ -829,7 +826,8 @@ delayed until mid-june ;-). I think this problem will be an FAQ soon after the release otherwise. -### Is this valid for 20.3? +Note: The above entry is probably not valid for XEmacs 20.3 and +later. ** When Emacs tries to ring the bell, you get an error like @@ -909,16 +907,12 @@ if it builds with the motif dialogs [boom!] you're a dead man. -### Does this apply to 20.3? - ** Beware of the default image & graphics library on Irix Richard Cognot writes: You *have* to compile your own jpeg lib. The one delivered with SGI systems is a C++ lib, which apparently XEmacs cannot cope with. -### Does this apply to 20.3? - ** Slow startup on Linux. People using systems based on the Linux kernel sometimes report that diff -r d3e9274cbc4e -r e45d5e7c476e configure --- a/configure Mon Aug 13 10:02:48 2007 +0200 +++ b/configure Mon Aug 13 10:03:52 2007 +0200 @@ -244,7 +244,6 @@ energize_version='' native_sound_lib='' use_assertions="yes" -with_gif="" with_toolbars="" with_tty="" use_union_type="no" @@ -309,7 +308,7 @@ --with-toolbars=no Don't compile with any toolbar support. --with-session=no Compile without realized leader window which will keep the WM_COMMAND property. Required for proper - session-management. (ON by default for testing) + session-management. --with-menubars=TYPE Use TYPE menubars (lucid, motif, or no). The Lucid widgets emulate Motif (mostly) but are faster. *WARNING* The Motif menubar is currently broken. @@ -331,13 +330,11 @@ --with-xface (*) Compile with support for X-Face mail header conversion. Requires the compface library. Get it from the XEmacs FTP site. ---with-jpeg (*) Compile with support for JPEG image conversion. - Requires libjpeg from the Independent JPEG Group. +--with-imagick (*) Compile with support for ImageMagick image conversion. + Requires ImageMagick from wizards.dupont.com and + libraries for whatever image types you wish to have + supported. Get it from the XEmacs FTP site. ---with-png (*) Compile with support for PNG image conversion. - Requires libpng. Get it from the XEmacs FTP site. ---with-tiff (*) Compile with support for TIFF image conversion - (not yet implemented). TTY options: @@ -533,12 +530,9 @@ with_cde | \ with_offix | \ with_gpm | \ - with_gif | \ with_xpm | \ with_xface | \ - with_jpeg | \ - with_png | \ - with_tiff | \ + with_imagick | \ with_session | \ with_xmu | \ with_quantify | \ @@ -874,7 +868,7 @@ esac echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6 -echo "configure:878: checking whether ln -s works" >&5 +echo "configure:872: checking whether ln -s works" >&5 rm -f conftestdata if ln -s X conftestdata 2>/dev/null @@ -892,7 +886,7 @@ fi -for dir in lisp etc man info site-lisp; do +for dir in lisp etc man info; do if test ! -d "$dir" ; then echo Making symbolic link to "$srcdir/$dir" ${LN_S} "$srcdir/$dir" "$dir" @@ -1051,7 +1045,7 @@ echo "checking "the configuration name"" 1>&6 -echo "configure:1055: checking "the configuration name"" >&5 +echo "configure:1049: checking "the configuration name"" >&5 internal_configuration=`echo $configuration | sed 's/-\(energize\|workshop\)//'` if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else exit $? @@ -1297,7 +1291,7 @@ m68*-sgi-iris3.6* | m68*-sgi-iris*) machine=irist opsys=iris3-6 ;; mips-sgi-irix3.* ) opsys=irix3-3 ;; mips-sgi-irix4.* ) opsys=irix4-0 ;; - mips-sgi-irix6* ) opsys=irix6-0 NON_GNU_CC="cc -Olimit 2000" ;; + mips-sgi-irix6* ) opsys=irix6-0 ;; mips-sgi-irix5.1* ) opsys=irix5-1 ;; mips-sgi-irix5.2* ) opsys=irix5-2 ;; mips-sgi-irix5.* ) opsys=irix5-3 ;; @@ -1451,6 +1445,8 @@ esac fi +case "$opsys" in aix*) NON_GNU_CC=xlc ;; esac + stack_trace_eye_catcher=`echo xemacs_${version}_${canonical} | sed 'y/.-/__/'` { test "$extra_verbose" = "yes" && cat << EOF Defining STACK_TRACE_EYE_CATCHER = $stack_trace_eye_catcher @@ -1505,7 +1501,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1509: checking for $ac_word" >&5 +echo "configure:1505: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1531,7 +1527,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1535: checking for $ac_word" >&5 +echo "configure:1531: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1576,7 +1572,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1580: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1576: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1588,11 +1584,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1592: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1612,19 +1608,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1616: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1612: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1621: checking whether we are using GNU C" >&5 +echo "configure:1617: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1624: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1638,7 +1634,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1642: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1638: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1667,7 +1663,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1671: checking for $ac_word" >&5 +echo "configure:1667: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1693,7 +1689,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1697: checking for $ac_word" >&5 +echo "configure:1693: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1738,7 +1734,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1742: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1738: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1750,11 +1746,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1754: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1774,19 +1770,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1778: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1774: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1783: checking whether we are using GNU C" >&5 +echo "configure:1779: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1786: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1800,7 +1796,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1804: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1800: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1829,7 +1825,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1833: checking for $ac_word" >&5 +echo "configure:1829: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1855,7 +1851,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1859: checking for $ac_word" >&5 +echo "configure:1855: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1900,7 +1896,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1904: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1900: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1912,11 +1908,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1916: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1936,19 +1932,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1940: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1936: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1945: checking whether we are using GNU C" >&5 +echo "configure:1941: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1948: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1962,7 +1958,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1966: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1962: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1995,7 +1991,7 @@ test -n "$NON_GNU_CPP" -a "$GCC" != "yes" -a -z "$CPP" && CPP="$NON_GNU_CPP" echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:1999: checking how to run the C preprocessor" >&5 +echo "configure:1995: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -2008,13 +2004,13 @@ # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2018: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2014: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2025,13 +2021,13 @@ rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2035: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2031: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2054,9 +2050,9 @@ echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:2058: checking for AIX" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&6 -echo "configure:2087: checking whether we are using SunPro C" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2096: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* __sunpro_c=yes else @@ -2322,16 +2318,17 @@ sol2 ) CFLAGS="-v -xO4" ;; sunos4* ) CFLAGS="-xO2";; esac + elif test "$CC" = "xlc"; then + CFLAGS="-O3 -qstrict -qnoansialias -qlibansi -qinfo -qro -qmaxmem=20000" else - CFLAGS="-O" # The only POSIX-approved flag - fi + CFLAGS="-O" ; fi fi if test "$GCC" = "yes"; then ld_switch_system_tmp="$ld_switch_system"; ld_switch_system="" for arg in $ld_switch_system_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) ld_switch_system="$ld_switch_system $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_switch_system="$ld_switch_system $arg" ;; -Xlinker* ) ;; * ) ld_switch_system="$ld_switch_system -Xlinker $arg" ;; esac @@ -2339,7 +2336,7 @@ ld_switch_machine_tmp="$ld_switch_machine"; ld_switch_machine="" for arg in $ld_switch_machine_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) ld_switch_machine="$ld_switch_machine $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_switch_machine="$ld_switch_machine $arg" ;; -Xlinker* ) ;; * ) ld_switch_machine="$ld_switch_machine -Xlinker $arg" ;; esac @@ -2347,7 +2344,7 @@ LDFLAGS_tmp="$LDFLAGS"; LDFLAGS="" for arg in $LDFLAGS_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) LDFLAGS="$LDFLAGS $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) LDFLAGS="$LDFLAGS $arg" ;; -Xlinker* ) ;; * ) LDFLAGS="$LDFLAGS -Xlinker $arg" ;; esac @@ -2355,7 +2352,7 @@ ld_call_shared_tmp="$ld_call_shared"; ld_call_shared="" for arg in $ld_call_shared_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) ld_call_shared="$ld_call_shared $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_call_shared="$ld_call_shared $arg" ;; -Xlinker* ) ;; * ) ld_call_shared="$ld_call_shared -Xlinker $arg" ;; esac @@ -2373,7 +2370,7 @@ fi echo $ac_n "checking for dynodump""... $ac_c" 1>&6 -echo "configure:2377: checking for dynodump" >&5 +echo "configure:2374: checking for dynodump" >&5 if test "$unexec" != "unexsol2.o"; then echo "$ac_t""no" 1>&6 else @@ -2397,8 +2394,21 @@ fi - -test -n "$ld_text_start_addr" && start_flags="-T $ld_text_start_addr -e __start" +if test "$unexec" = "unexaix.o"; then + start_flags="-Wl,-bnso,-bnodelcsect" + test "$GCC" = "yes" && start_flags="-B/bin/ ${aixflags}" + for f in "/lib/syscalls.exp" "$srcdir/src/m/ibmrs6000.inp"; do + if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; fi + done + for f in "/usr/lpp/X11/bin/smt.exp" "/usr/bin/X11/smt.exp"; do + if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; break; fi + done +elif test -n "$ld_text_start_addr"; then + start_flags="-T $ld_text_start_addr -e __start" +fi + + + if test "$ordinary_link" = "no" -a "$GCC" = "yes"; then test -z "$linker" && linker='$(CC) -nostdlib' @@ -2444,19 +2454,19 @@ if test "$add_runtime_path" = "yes"; then echo $ac_n "checking "for runtime libraries flag"""... $ac_c" 1>&6 -echo "configure:2448: checking "for runtime libraries flag"" >&5 +echo "configure:2458: checking "for runtime libraries flag"" >&5 dash_r="" for try_dash_r in "-R" "-R " "-rpath "; do xe_check_libs="${try_dash_r}/no/such/file-or-directory" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2470: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* dash_r="$try_dash_r" else @@ -2554,7 +2564,7 @@ # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2558: checking for $ac_word" >&5 +echo "configure:2568: checking for $ac_word" >&5 if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. @@ -2607,7 +2617,7 @@ # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:2611: checking for a BSD compatible install" >&5 +echo "configure:2621: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" @@ -2658,7 +2668,7 @@ # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2662: checking for $ac_word" >&5 +echo "configure:2672: checking for $ac_word" >&5 if test -n "$YACC"; then ac_cv_prog_YACC="$YACC" # Let the user override the test. @@ -2689,15 +2699,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2693: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2701: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2711: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2730,15 +2740,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2734: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2742: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2752: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2771,15 +2781,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2775: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2783: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2793: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2809,10 +2819,10 @@ done echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6 -echo "configure:2813: checking for sys/wait.h that is POSIX.1 compatible" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2828,7 +2838,7 @@ s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } EOF -if { (eval echo configure:2832: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2842: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_sys_wait_h=yes else @@ -2852,10 +2862,10 @@ fi echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:2856: checking for ANSI C header files" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2863,7 +2873,7 @@ #include EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2867: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2877: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2880,7 +2890,7 @@ if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2898,7 +2908,7 @@ if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2916,7 +2926,7 @@ if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -2927,7 +2937,7 @@ exit (0); } EOF -if { (eval echo configure:2931: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:2941: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then : else @@ -2952,10 +2962,10 @@ fi echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:2956: checking whether time.h and sys/time.h may both be included" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2964,7 +2974,7 @@ struct tm *tp; ; return 0; } EOF -if { (eval echo configure:2968: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2978: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_time=yes else @@ -2988,10 +2998,10 @@ fi echo $ac_n "checking for sys_siglist declaration in signal.h or unistd.h""... $ac_c" 1>&6 -echo "configure:2992: checking for sys_siglist declaration in signal.h or unistd.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3003,7 +3013,7 @@ char *msg = *(sys_siglist + 1); ; return 0; } EOF -if { (eval echo configure:3007: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3017: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_decl_sys_siglist=yes else @@ -3028,9 +3038,9 @@ echo $ac_n "checking for struct utimbuf""... $ac_c" 1>&6 -echo "configure:3032: checking for struct utimbuf" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < @@ -3049,7 +3059,7 @@ static struct utimbuf x; x.actime = x.modtime; ; return 0; } EOF -if { (eval echo configure:3053: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3063: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -3069,10 +3079,10 @@ rm -f conftest* echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:3073: checking return type of signal handlers" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3089,7 +3099,7 @@ int i; ; return 0; } EOF -if { (eval echo configure:3093: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3103: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_type_signal=void else @@ -3111,10 +3121,10 @@ echo $ac_n "checking for size_t""... $ac_c" 1>&6 -echo "configure:3115: checking for size_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3145,10 +3155,10 @@ fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:3149: checking for pid_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3179,10 +3189,10 @@ fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:3183: checking for uid_t in sys/types.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF @@ -3218,10 +3228,10 @@ fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:3222: checking for mode_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3252,10 +3262,10 @@ fi echo $ac_n "checking for off_t""... $ac_c" 1>&6 -echo "configure:3256: checking for off_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3287,9 +3297,9 @@ echo $ac_n "checking for struct timeval""... $ac_c" 1>&6 -echo "configure:3291: checking for struct timeval" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < @@ -3305,7 +3315,7 @@ static struct timeval x; x.tv_sec = x.tv_usec; ; return 0; } EOF -if { (eval echo configure:3309: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3319: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 HAVE_TIMEVAL=yes @@ -3327,10 +3337,10 @@ rm -f conftest* echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 -echo "configure:3331: checking whether struct tm is in sys/time.h or time.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3338,7 +3348,7 @@ struct tm *tp; tp->tm_sec; ; return 0; } EOF -if { (eval echo configure:3342: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3352: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm=time.h else @@ -3362,10 +3372,10 @@ fi echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 -echo "configure:3366: checking for tm_zone in struct tm" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include <$ac_cv_struct_tm> @@ -3373,7 +3383,7 @@ struct tm tm; tm.tm_zone; ; return 0; } EOF -if { (eval echo configure:3377: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3387: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm_zone=yes else @@ -3396,10 +3406,10 @@ else echo $ac_n "checking for tzname""... $ac_c" 1>&6 -echo "configure:3400: checking for tzname" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #ifndef tzname /* For SGI. */ @@ -3409,7 +3419,7 @@ atoi(*tzname); ; return 0; } EOF -if { (eval echo configure:3413: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3423: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_var_tzname=yes else @@ -3435,10 +3445,10 @@ echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:3439: checking for working const" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3501: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_const=yes else @@ -3512,7 +3522,7 @@ echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:3516: checking whether ${MAKE-make} sets \${MAKE}" >&5 +echo "configure:3526: checking whether ${MAKE-make} sets \${MAKE}" >&5 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` cat > conftestmake <<\EOF @@ -3537,12 +3547,12 @@ echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 -echo "configure:3541: checking whether byte ordering is bigendian" >&5 +echo "configure:3551: checking whether byte ordering is bigendian" >&5 ac_cv_c_bigendian=unknown # See if sys/param.h defines the BYTE_ORDER macro. cat > conftest.$ac_ext < #include @@ -3553,11 +3563,11 @@ #endif ; return 0; } EOF -if { (eval echo configure:3557: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3567: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* # It does; now see whether it defined to BIG_ENDIAN or not. cat > conftest.$ac_ext < #include @@ -3568,7 +3578,7 @@ #endif ; return 0; } EOF -if { (eval echo configure:3572: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3582: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_bigendian=yes else @@ -3585,7 +3595,7 @@ rm -f conftest* if test $ac_cv_c_bigendian = unknown; then cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_bigendian=no else @@ -3624,10 +3634,10 @@ echo $ac_n "checking size of short""... $ac_c" 1>&6 -echo "configure:3628: checking size of short" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3638,7 +3648,7 @@ exit(0); } EOF -if { (eval echo configure:3642: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3652: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_short=`cat conftestval` else @@ -3665,10 +3675,10 @@ exit 1 fi echo $ac_n "checking size of int""... $ac_c" 1>&6 -echo "configure:3669: checking size of int" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3679,7 +3689,7 @@ exit(0); } EOF -if { (eval echo configure:3683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3693: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_int=`cat conftestval` else @@ -3700,10 +3710,10 @@ echo $ac_n "checking size of long""... $ac_c" 1>&6 -echo "configure:3704: checking size of long" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3714,7 +3724,7 @@ exit(0); } EOF -if { (eval echo configure:3718: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3728: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_long=`cat conftestval` else @@ -3735,10 +3745,10 @@ echo $ac_n "checking size of long long""... $ac_c" 1>&6 -echo "configure:3739: checking size of long long" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3749,7 +3759,7 @@ exit(0); } EOF -if { (eval echo configure:3753: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_long_long=`cat conftestval` else @@ -3770,10 +3780,10 @@ echo $ac_n "checking size of void *""... $ac_c" 1>&6 -echo "configure:3774: checking size of void *" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3784,7 +3794,7 @@ exit(0); } EOF -if { (eval echo configure:3788: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_void_p=`cat conftestval` else @@ -3806,7 +3816,7 @@ echo $ac_n "checking for long file names""... $ac_c" 1>&6 -echo "configure:3810: checking for long file names" >&5 +echo "configure:3820: checking for long file names" >&5 ac_cv_sys_long_file_names=yes # Test for long file names in all the places we know might matter: @@ -3852,24 +3862,24 @@ -echo $ac_n "checking for sqrt in -lm""... $ac_c" 1>&6 -echo "configure:3857: checking for sqrt in -lm" >&5 -ac_lib_var=`echo m'_'sqrt | sed 'y%./+-%__p_%'` +echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6 +echo "configure:3867: checking for sin in -lm" >&5 +ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'` xe_check_libs=" -lm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3883: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3911,7 +3921,7 @@ echo "checking type of mail spool file locking" 1>&6 -echo "configure:3915: checking type of mail spool file locking" >&5 +echo "configure:3925: checking type of mail spool file locking" >&5 test -z "$mail_locking" -a "$mail_use_flock" = "yes" && mail_locking=flock test -z "$mail_locking" -a "$mail_use_lockf" = "yes" && mail_locking=lockf if test "$mail_locking" = "lockf"; then { test "$extra_verbose" = "yes" && cat << \EOF @@ -3935,12 +3945,12 @@ echo $ac_n "checking for kstat_open in -lkstat""... $ac_c" 1>&6 -echo "configure:3939: checking for kstat_open in -lkstat" >&5 +echo "configure:3949: checking for kstat_open in -lkstat" >&5 ac_lib_var=`echo kstat'_'kstat_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lkstat " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3965: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3985,12 +3995,12 @@ echo $ac_n "checking for kvm_read in -lkvm""... $ac_c" 1>&6 -echo "configure:3989: checking for kvm_read in -lkvm" >&5 +echo "configure:3999: checking for kvm_read in -lkvm" >&5 ac_lib_var=`echo kvm'_'kvm_read | sed 'y%./+-%__p_%'` xe_check_libs=" -lkvm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4015: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4035,12 +4045,12 @@ echo $ac_n "checking for cma_open in -lpthreads""... $ac_c" 1>&6 -echo "configure:4039: checking for cma_open in -lpthreads" >&5 +echo "configure:4049: checking for cma_open in -lpthreads" >&5 ac_lib_var=`echo pthreads'_'cma_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lpthreads " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4065: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4087,7 +4097,7 @@ fi echo $ac_n "checking whether the -xildoff compiler flag is required""... $ac_c" 1>&6 -echo "configure:4091: checking whether the -xildoff compiler flag is required" >&5 +echo "configure:4101: checking whether the -xildoff compiler flag is required" >&5 if ${CC-cc} '-###' -xildon no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then if ${CC-cc} '-###' -xildoff no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then echo "$ac_t""no" 1>&6; @@ -4098,7 +4108,7 @@ if test "$opsys" = "sol2" && test "$OS_RELEASE" -ge 56; then echo $ac_n "checking for \"-z ignore\" linker flag""... $ac_c" 1>&6 -echo "configure:4102: checking for \"-z ignore\" linker flag" >&5 +echo "configure:4112: checking for \"-z ignore\" linker flag" >&5 case "`ld -h 2>&1`" in *-z\ ignore\|record* ) echo "$ac_t""yes" 1>&6 ld_switch_site="-z ignore $ld_switch_site" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-z ignore\" to \$ld_switch_site"; fi ;; @@ -4108,7 +4118,7 @@ echo "checking "for specified window system"" 1>&6 -echo "configure:4112: checking "for specified window system"" >&5 +echo "configure:4122: checking "for specified window system"" >&5 if test "$with_x11" != "no"; then test "$x_includes $x_libraries" != "NONE NONE" && \ @@ -4138,7 +4148,7 @@ # Uses ac_ vars as temps to allow command line to override cache and checks. # --without-x overrides everything else, but does not touch the cache. echo $ac_n "checking for X""... $ac_c" 1>&6 -echo "configure:4142: checking for X" >&5 +echo "configure:4152: checking for X" >&5 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then @@ -4198,12 +4208,12 @@ # First, try using that file with no special directory specified. cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:4207: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:4217: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -4272,14 +4282,14 @@ ac_save_LIBS="$LIBS" LIBS="-l$x_direct_test_library $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4293: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* LIBS="$ac_save_LIBS" # We can link X programs with no special library path. @@ -4388,17 +4398,17 @@ case "`(uname -sr) 2>/dev/null`" in "SunOS 5"*) echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6 -echo "configure:4392: checking whether -R must be followed by a space" >&5 +echo "configure:4402: checking whether -R must be followed by a space" >&5 ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4412: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_nospace=yes else @@ -4414,14 +4424,14 @@ else LIBS="$ac_xsave_LIBS -R $x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4435: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_space=yes else @@ -4457,12 +4467,12 @@ else echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6 -echo "configure:4461: checking for dnet_ntoa in -ldnet" >&5 +echo "configure:4471: checking for dnet_ntoa in -ldnet" >&5 ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4487: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4497,12 +4507,12 @@ if test $ac_cv_lib_dnet_dnet_ntoa = no; then echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6 -echo "configure:4501: checking for dnet_ntoa in -ldnet_stub" >&5 +echo "configure:4511: checking for dnet_ntoa in -ldnet_stub" >&5 ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet_stub " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4527: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4542,10 +4552,10 @@ # The nsl library prevents programs from opening the X display # on Irix 5.2, according to dickey@clark.net. echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6 -echo "configure:4546: checking for gethostbyname" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4582: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_gethostbyname=yes" else @@ -4589,12 +4599,12 @@ if test $ac_cv_func_gethostbyname = no; then echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6 -echo "configure:4593: checking for gethostbyname in -lnsl" >&5 +echo "configure:4603: checking for gethostbyname in -lnsl" >&5 ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'` xe_check_libs=" -lnsl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4619: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4635,10 +4645,10 @@ # -lsocket must be given before -lnsl if both are needed. # We assume that if connect needs -lnsl, so does gethostbyname. echo $ac_n "checking for connect""... $ac_c" 1>&6 -echo "configure:4639: checking for connect" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_connect=yes" else @@ -4684,12 +4694,12 @@ xe_msg_checking="for connect in -lsocket" test -n "$X_EXTRA_LIBS" && xe_msg_checking="$xe_msg_checking using extra libs $X_EXTRA_LIBS" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:4688: checking "$xe_msg_checking"" >&5 +echo "configure:4698: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocket $X_EXTRA_LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4714: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4724,10 +4734,10 @@ # gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX. echo $ac_n "checking for remove""... $ac_c" 1>&6 -echo "configure:4728: checking for remove" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4764: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_remove=yes" else @@ -4771,12 +4781,12 @@ if test $ac_cv_func_remove = no; then echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6 -echo "configure:4775: checking for remove in -lposix" >&5 +echo "configure:4785: checking for remove in -lposix" >&5 ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'` xe_check_libs=" -lposix " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4801: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4811,10 +4821,10 @@ # BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay. echo $ac_n "checking for shmat""... $ac_c" 1>&6 -echo "configure:4815: checking for shmat" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4851: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_shmat=yes" else @@ -4858,12 +4868,12 @@ if test $ac_cv_func_shmat = no; then echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6 -echo "configure:4862: checking for shmat in -lipc" >&5 +echo "configure:4872: checking for shmat in -lipc" >&5 ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'` xe_check_libs=" -lipc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4888: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4908,12 +4918,12 @@ # --interran@uluru.Stanford.EDU, kb@cs.umb.edu. echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6 -echo "configure:4912: checking for IceConnectionNumber in -lICE" >&5 +echo "configure:4922: checking for IceConnectionNumber in -lICE" >&5 ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'` xe_check_libs=" -lICE " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4938: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5057,7 +5067,7 @@ fi echo "checking for X defines extracted by xmkmf" 1>&6 -echo "configure:5061: checking for X defines extracted by xmkmf" >&5 +echo "configure:5071: checking for X defines extracted by xmkmf" >&5 rm -fr conftestdir if mkdir conftestdir; then cd conftestdir @@ -5089,15 +5099,15 @@ ac_safe=`echo "X11/Intrinsic.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Intrinsic.h""... $ac_c" 1>&6 -echo "configure:5093: checking for X11/Intrinsic.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5101: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5111: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5121,12 +5131,12 @@ echo $ac_n "checking for XOpenDisplay in -lX11""... $ac_c" 1>&6 -echo "configure:5125: checking for XOpenDisplay in -lX11" >&5 +echo "configure:5135: checking for XOpenDisplay in -lX11" >&5 ac_lib_var=`echo X11'_'XOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5151: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5162,12 +5172,12 @@ xe_msg_checking="for XGetFontProperty in -lX11" test -n "-b i486-linuxaout" && xe_msg_checking="$xe_msg_checking using extra libs -b i486-linuxaout" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:5166: checking "$xe_msg_checking"" >&5 +echo "configure:5176: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo X11'_'XGetFontProperty | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 -b i486-linuxaout" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5192: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5205,12 +5215,12 @@ echo $ac_n "checking for XShapeSelectInput in -lXext""... $ac_c" 1>&6 -echo "configure:5209: checking for XShapeSelectInput in -lXext" >&5 +echo "configure:5219: checking for XShapeSelectInput in -lXext" >&5 ac_lib_var=`echo Xext'_'XShapeSelectInput | sed 'y%./+-%__p_%'` xe_check_libs=" -lXext " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5235: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5244,12 +5254,12 @@ echo $ac_n "checking for XtOpenDisplay in -lXt""... $ac_c" 1>&6 -echo "configure:5248: checking for XtOpenDisplay in -lXt" >&5 +echo "configure:5258: checking for XtOpenDisplay in -lXt" >&5 ac_lib_var=`echo Xt'_'XtOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lXt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5274: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5283,14 +5293,14 @@ echo $ac_n "checking the version of X11 being used""... $ac_c" 1>&6 -echo "configure:5287: checking the version of X11 being used" >&5 +echo "configure:5297: checking the version of X11 being used" >&5 cat > conftest.$ac_ext < main(int c, char* v[]) { return c>1 ? XlibSpecificationRelease : 0; } EOF -if { (eval echo configure:5294: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5304: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; x11_release=$? else @@ -5314,15 +5324,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:5318: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5326: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5336: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5353,7 +5363,7 @@ echo $ac_n "checking for XFree86""... $ac_c" 1>&6 -echo "configure:5357: checking for XFree86" >&5 +echo "configure:5367: checking for XFree86" >&5 if test -d "/usr/X386/include" -o \ -f "/etc/XF86Config" -o \ -f "/etc/X11/XF86Config" -o \ @@ -5373,12 +5383,12 @@ test -z "$with_xmu" && { echo $ac_n "checking for XmuReadBitmapDataFromFile in -lXmu""... $ac_c" 1>&6 -echo "configure:5377: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 +echo "configure:5387: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 ac_lib_var=`echo Xmu'_'XmuReadBitmapDataFromFile | sed 'y%./+-%__p_%'` xe_check_libs=" -lXmu " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5403: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5428,19 +5438,19 @@ echo $ac_n "checking for main in -lXbsd""... $ac_c" 1>&6 -echo "configure:5432: checking for main in -lXbsd" >&5 +echo "configure:5442: checking for main in -lXbsd" >&5 ac_lib_var=`echo Xbsd'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lXbsd " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5454: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5470,7 +5480,7 @@ fi for feature in tooltalk cde offix session \ menubars scrollbars toolbars dialogs xim xmu \ - tiff png jpeg gif xface xpm + imagick xface xpm do if eval "test -n \"\$with_${feature}\" -a \"\$with_${feature}\" != no" ; then echo "configure: warning: --with-$feature ignored: Not valid without X support" 1>&2 @@ -5494,7 +5504,7 @@ esac echo "checking for session-management option" 1>&6 -echo "configure:5498: checking for session-management option" >&5; +echo "configure:5508: checking for session-management option" >&5; if test "$with_session" != "no"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SESSION @@ -5509,15 +5519,15 @@ test -z "$with_xauth" && test "$window_system" = "none" && with_xauth=no test -z "$with_xauth" && { ac_safe=`echo "X11/Xauth.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xauth.h""... $ac_c" 1>&6 -echo "configure:5513: checking for X11/Xauth.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5521: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5531: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5540,12 +5550,12 @@ } test -z "$with_xauth" && { echo $ac_n "checking for XauGetAuthByAddr in -lXau""... $ac_c" 1>&6 -echo "configure:5544: checking for XauGetAuthByAddr in -lXau" >&5 +echo "configure:5554: checking for XauGetAuthByAddr in -lXau" >&5 ac_lib_var=`echo Xau'_'XauGetAuthByAddr | sed 'y%./+-%__p_%'` xe_check_libs=" -lXau " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5570: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5596,76 +5606,7 @@ OFFIX_O="" -test -z "$with_offix" && { ac_safe=`echo "OffiX/DragAndDrop.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for OffiX/DragAndDrop.h""... $ac_c" 1>&6 -echo "configure:5602: checking for OffiX/DragAndDrop.h" >&5 - -cat > conftest.$ac_ext < -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5610: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_offix=no -fi - } -test -z "$with_offix" && { -echo $ac_n "checking for DndInitialize in -lDnd""... $ac_c" 1>&6 -echo "configure:5633: checking for DndInitialize in -lDnd" >&5 -ac_lib_var=`echo Dnd'_'DndInitialize | sed 'y%./+-%__p_%'` - -xe_check_libs=" -lDnd " -cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_offix=no -fi - - } +test "$window_system" != "x11" && with_offix=no test -z "$with_offix" && with_offix=yes if test "$with_offix" = "yes"; then { test "$extra_verbose" = "yes" && cat << \EOF @@ -5685,15 +5626,15 @@ for dir in "" "Tt/" "desktop/" ; do ac_safe=`echo "${dir}tt_c.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}tt_c.h""... $ac_c" 1>&6 -echo "configure:5689: checking for ${dir}tt_c.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5697: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5638: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5722,12 +5663,12 @@ xe_msg_checking="for tt_message_create in -ltt" test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:5726: checking "$xe_msg_checking"" >&5 +echo "configure:5667: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo tt'_'tt_message_create | sed 'y%./+-%__p_%'` xe_check_libs=" -ltt $extra_libs" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5787,15 +5728,15 @@ test -z "$with_cde" && { ac_safe=`echo "Dt/Dt.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Dt/Dt.h""... $ac_c" 1>&6 -echo "configure:5791: checking for Dt/Dt.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5799: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5740: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5818,12 +5759,12 @@ } test -z "$with_cde" && { echo $ac_n "checking for DtDndDragStart in -lDtSvc""... $ac_c" 1>&6 -echo "configure:5822: checking for DtDndDragStart in -lDtSvc" >&5 +echo "configure:5763: checking for DtDndDragStart in -lDtSvc" >&5 ac_lib_var=`echo DtSvc'_'DtDndDragStart | sed 'y%./+-%__p_%'` xe_check_libs=" -lDtSvc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5779: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5881,19 +5822,19 @@ echo $ac_n "checking for main in -lenergize""... $ac_c" 1>&6 -echo "configure:5885: checking for main in -lenergize" >&5 +echo "configure:5826: checking for main in -lenergize" >&5 ac_lib_var=`echo energize'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lenergize " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5838: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5925,19 +5866,19 @@ if test -z "$energize_version"; then echo $ac_n "checking for main in -lconn""... $ac_c" 1>&6 -echo "configure:5929: checking for main in -lconn" >&5 +echo "configure:5870: checking for main in -lconn" >&5 ac_lib_var=`echo conn'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lconn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5882: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5970,15 +5911,15 @@ fi ac_safe=`echo "editorconn.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for editorconn.h""... $ac_c" 1>&6 -echo "configure:5974: checking for editorconn.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5982: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5923: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6022,27 +5963,12 @@ if test "$with_x11" = "yes"; then echo "checking for X11 graphics libraries" 1>&6 -echo "configure:6026: checking for X11 graphics libraries" >&5 - test -z "$with_gif" && with_gif=yes; - if test "$with_gif" = "yes"; then - { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_GIF -EOF -cat >> confdefs.h <<\EOF -#define HAVE_GIF 1 -EOF -} - - extra_objs="$extra_objs dgif_lib.o gif_err.o gifalloc.o" && if test "$extra_verbose" = "yes"; then - echo " xemacs will be linked with \"dgif_lib.o gif_err.o gifalloc.o\"" - fi - fi - +echo "configure:5967: checking for X11 graphics libraries" >&5 echo $ac_n "checking for Xpm - no older than 3.4f""... $ac_c" 1>&6 -echo "configure:6043: checking for Xpm - no older than 3.4f" >&5 +echo "configure:5969: checking for Xpm - no older than 3.4f" >&5 xe_check_libs=-lXpm test -z "$with_xpm" && { cat > conftest.$ac_ext < int main(int c, char **v) { @@ -6052,7 +5978,7 @@ 0 ; } EOF -if { (eval echo configure:6056: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5982: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; xpm_status=$?; if test "$xpm_status" = "0"; then with_xpm=yes; else with_xpm=no; fi; @@ -6090,15 +6016,15 @@ test -z "$with_xface" && { ac_safe=`echo "compface.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for compface.h""... $ac_c" 1>&6 -echo "configure:6094: checking for compface.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6102: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6028: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6121,12 +6047,12 @@ } test -z "$with_xface" && { echo $ac_n "checking for UnGenFace in -lcompface""... $ac_c" 1>&6 -echo "configure:6125: checking for UnGenFace in -lcompface" >&5 +echo "configure:6051: checking for UnGenFace in -lcompface" >&5 ac_lib_var=`echo compface'_'UnGenFace | sed 'y%./+-%__p_%'` xe_check_libs=" -lcompface " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6067: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6171,100 +6097,17 @@ libs_x="-lcompface $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lcompface\" to \$libs_x"; fi fi - test -z "$with_jpeg" && { ac_safe=`echo "jpeglib.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for jpeglib.h""... $ac_c" 1>&6 -echo "configure:6177: checking for jpeglib.h" >&5 - -cat > conftest.$ac_ext < + test -z "$with_imagick" && { ac_safe=`echo "magick.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for magick.h""... $ac_c" 1>&6 +echo "configure:6103: checking for magick.h" >&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6185: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_jpeg=no -fi - } - test -z "$with_jpeg" && { -echo $ac_n "checking for jpeg_destroy_decompress in -ljpeg""... $ac_c" 1>&6 -echo "configure:6208: checking for jpeg_destroy_decompress in -ljpeg" >&5 -ac_lib_var=`echo jpeg'_'jpeg_destroy_decompress | sed 'y%./+-%__p_%'` - -xe_check_libs=" -ljpeg " -cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_jpeg=no -fi - - } - test -z "$with_jpeg" && with_jpeg=yes - if test "$with_jpeg" = "yes"; then - { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_JPEG -EOF -cat >> confdefs.h <<\EOF -#define HAVE_JPEG 1 -EOF -} - - libs_x="-ljpeg $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-ljpeg\" to \$libs_x"; fi - fi - - test -z "$with_png" && { ac_safe=`echo "png.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for png.h""... $ac_c" 1>&6 -echo "configure:6260: checking for png.h" >&5 - -cat > conftest.$ac_ext < -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6268: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6111: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6282,78 +6125,28 @@ : else echo "$ac_t""no" 1>&6 -with_png=no +with_imagick=no fi } - test -z "$with_png" && { echo $ac_n "checking for pow""... $ac_c" 1>&6 -echo "configure:6290: checking for pow" >&5 - -cat > conftest.$ac_ext < -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char pow(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_pow) || defined (__stub___pow) -choke me -#else -pow(); -#endif - -; return 0; } -EOF -if { (eval echo configure:6316: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_pow=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_pow=no" -fi -rm -f conftest* - -if eval "test \"`echo '$ac_cv_func_'pow`\" = yes"; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_png=no -fi - } - if test "$with_png" != "no"; then - for extra_libs in "" "-lz" "-lgz"; do - -xe_msg_checking="for png_read_image in -lpng" -test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" -echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6341: checking "$xe_msg_checking"" >&5 -ac_lib_var=`echo png'_'png_read_image | sed 'y%./+-%__p_%'` - -xe_check_libs=" -lpng $extra_libs" -cat > conftest.$ac_ext <&6 +echo "configure:6134: checking for MogrifyImage in -lMagick" >&5 +ac_lib_var=`echo Magick'_'MogrifyImage | sed 'y%./+-%__p_%'` + +xe_check_libs=" -lMagick " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6150: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6367,94 +6160,34 @@ if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then echo "$ac_t""yes" 1>&6 - png_libs="-lpng $extra_libs" with_png=yes; break -else - echo "$ac_t""no" 1>&6 -: -fi - - - done - fi - test -z "$with_png" && with_png=no - if test "$with_png" = "yes"; then + : +else + echo "$ac_t""no" 1>&6 +with_imagick=no +fi + + } + test -z "$with_imagick" && with_imagick=yes + if test "$with_imagick" = "yes"; then { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_PNG -EOF -cat >> confdefs.h <<\EOF -#define HAVE_PNG 1 -EOF -} - - libs_x="$png_libs $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"$png_libs\" to \$libs_x"; fi - fi - - if test "$with_tiff" != no; then - for extra_libs in "" "-lz" "-lgz"; do - -xe_msg_checking="for TIFFReadScanline in -ltiff" -test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" -echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6399: checking "$xe_msg_checking"" >&5 -ac_lib_var=`echo tiff'_'TIFFReadScanline | sed 'y%./+-%__p_%'` - -xe_check_libs=" -ltiff $extra_libs" -cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - tiff_libs="-ltiff $extra_libs" with_tiff=yes; break -else - echo "$ac_t""no" 1>&6 -: -fi - - - done - fi - test -z "$with_tiff" && with_tiff=no - if test "$with_tiff" = "yes"; then - { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_TIFF -EOF -cat >> confdefs.h <<\EOF -#define HAVE_TIFF 1 -EOF -} - - libs_x="$tiff_libs $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"$tiff_libs\" to \$libs_x"; fi + Defining HAVE_IMAGEMAGICK +EOF +cat >> confdefs.h <<\EOF +#define HAVE_IMAGEMAGICK 1 +EOF +} + + libs_x="-lMagick $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lMagick\" to \$libs_x"; fi fi echo $ac_n "checking for XawScrollbarSetThumb in -lXaw""... $ac_c" 1>&6 -echo "configure:6453: checking for XawScrollbarSetThumb in -lXaw" >&5 +echo "configure:6186: checking for XawScrollbarSetThumb in -lXaw" >&5 ac_lib_var=`echo Xaw'_'XawScrollbarSetThumb | sed 'y%./+-%__p_%'` xe_check_libs=" -lXaw " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6202: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6489,15 +6222,15 @@ if test "$have_xaw" = "yes"; then ac_safe=`echo "X11/Xaw/Reports.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xaw/Reports.h""... $ac_c" 1>&6 -echo "configure:6493: checking for X11/Xaw/Reports.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6501: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6234: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6523,15 +6256,15 @@ ac_safe=`echo "Xm/Xm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Xm/Xm.h""... $ac_c" 1>&6 -echo "configure:6527: checking for Xm/Xm.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6535: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6268: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6548,12 +6281,12 @@ echo "$ac_t""yes" 1>&6 echo $ac_n "checking for XmStringFree in -lXm""... $ac_c" 1>&6 -echo "configure:6552: checking for XmStringFree in -lXm" >&5 +echo "configure:6285: checking for XmStringFree in -lXm" >&5 ac_lib_var=`echo Xm'_'XmStringFree | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6301: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6811,9 +6544,16 @@ test -z "$with_mule" && with_mule=no +if test "$with_mule" = "yes" && test ! -d "$srcdir/lisp/mule"; then + echo "Attempt to Build with Mule without Mule/Lisp" + echo "Please install the XEmacs/Mule tarball or" + echo "rerun configure with --with-mule=no" + exit 1 +fi + if test "$with_mule" = "yes" ; then echo "checking for Mule-related features" 1>&6 -echo "configure:6817: checking for Mule-related features" >&5 +echo "configure:6557: checking for Mule-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining MULE EOF @@ -6830,15 +6570,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:6834: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6842: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6582: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6869,12 +6609,12 @@ echo $ac_n "checking for strerror in -lintl""... $ac_c" 1>&6 -echo "configure:6873: checking for strerror in -lintl" >&5 +echo "configure:6613: checking for strerror in -lintl" >&5 ac_lib_var=`echo intl'_'strerror | sed 'y%./+-%__p_%'` xe_check_libs=" -lintl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6629: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6918,19 +6658,19 @@ echo "checking for Mule input methods" 1>&6 -echo "configure:6922: checking for Mule input methods" >&5 +echo "configure:6662: checking for Mule input methods" >&5 test -z "$with_xim" -a "$opsys" != "sol2" && with_xim=no case "$with_xim" in "" | "yes" ) echo "checking for XIM" 1>&6 -echo "configure:6926: checking for XIM" >&5 +echo "configure:6666: checking for XIM" >&5 echo $ac_n "checking for XmImMbLookupString in -lXm""... $ac_c" 1>&6 -echo "configure:6929: checking for XmImMbLookupString in -lXm" >&5 +echo "configure:6669: checking for XmImMbLookupString in -lXm" >&5 ac_lib_var=`echo Xm'_'XmImMbLookupString | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6685: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7004,15 +6744,15 @@ fi else case "$with_xfs" in "yes" ) echo "checking for XFontSet" 1>&6 -echo "configure:7008: checking for XFontSet" >&5 +echo "configure:6748: checking for XFontSet" >&5 echo $ac_n "checking for XmbDrawString in -lX11""... $ac_c" 1>&6 -echo "configure:7011: checking for XmbDrawString in -lX11" >&5 +echo "configure:6751: checking for XmbDrawString in -lX11" >&5 ac_lib_var=`echo X11'_'XmbDrawString | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6767: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7062,15 +6802,15 @@ test "$with_wnn6" = "yes" && with_wnn=yes # wnn6 implies wnn support test -z "$with_wnn" && { ac_safe=`echo "wnn/jllib.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for wnn/jllib.h""... $ac_c" 1>&6 -echo "configure:7066: checking for wnn/jllib.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7074: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6814: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7095,10 +6835,10 @@ for ac_func in crypt do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7099: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6865: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7150,12 +6890,12 @@ test "$ac_cv_func_crypt" != "yes" && { echo $ac_n "checking for crypt in -lcrypt""... $ac_c" 1>&6 -echo "configure:7154: checking for crypt in -lcrypt" >&5 +echo "configure:6894: checking for crypt in -lcrypt" >&5 ac_lib_var=`echo crypt'_'crypt | sed 'y%./+-%__p_%'` xe_check_libs=" -lcrypt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6910: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7200,12 +6940,12 @@ fi test -z "$with_wnn" && { echo $ac_n "checking for jl_dic_list_e in -lwnn""... $ac_c" 1>&6 -echo "configure:7204: checking for jl_dic_list_e in -lwnn" >&5 +echo "configure:6944: checking for jl_dic_list_e in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6960: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7253,12 +6993,12 @@ fi echo $ac_n "checking for jl_fi_dic_list in -lwnn""... $ac_c" 1>&6 -echo "configure:7257: checking for jl_fi_dic_list in -lwnn" >&5 +echo "configure:6997: checking for jl_fi_dic_list in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_fi_dic_list | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7013: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7301,15 +7041,15 @@ test -z "$with_canna" && { ac_safe=`echo "canna/RK.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for canna/RK.h""... $ac_c" 1>&6 -echo "configure:7305: checking for canna/RK.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7313: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7053: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7332,12 +7072,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for RkBgnBun in -lRKC""... $ac_c" 1>&6 -echo "configure:7336: checking for RkBgnBun in -lRKC" >&5 +echo "configure:7076: checking for RkBgnBun in -lRKC" >&5 ac_lib_var=`echo RKC'_'RkBgnBun | sed 'y%./+-%__p_%'` xe_check_libs=" -lRKC " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7092: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7371,12 +7111,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for jrKanjiControl in -lcanna""... $ac_c" 1>&6 -echo "configure:7375: checking for jrKanjiControl in -lcanna" >&5 +echo "configure:7115: checking for jrKanjiControl in -lcanna" >&5 ac_lib_var=`echo canna'_'jrKanjiControl | sed 'y%./+-%__p_%'` xe_check_libs=" -lcanna " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7131: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7434,6 +7174,44 @@ if test "$need_motif" = "yes" ; then libs_x="-lXm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXm\" to \$libs_x"; fi + +echo $ac_n "checking for layout_object_getvalue in -li18n""... $ac_c" 1>&6 +echo "configure:7180: checking for layout_object_getvalue in -li18n" >&5 +ac_lib_var=`echo i18n'_'layout_object_getvalue | sed 'y%./+-%__p_%'` + +xe_check_libs=" -li18n " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + libs_x="-li18n $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-li18n\" to \$libs_x"; fi +else + echo "$ac_t""no" 1>&6 +fi + + if test "$add_runtime_path" = "yes" -a -n "$dash_r"; then ld_switch_site=`echo '' $ld_switch_site | sed -e 's:^ ::' -e "s/$dash_r[^ ]*//g"` @@ -7487,10 +7265,10 @@ for ac_func in acosh asinh atanh cbrt closedir dup2 eaccess fmod fpathconf frexp ftime gethostname getpagesize gettimeofday getcwd getwd logb lrand48 matherr mkdir mktime perror poll random rename res_init rint rmdir select setitimer setpgid setlocale setsid sigblock sighold sigprocmask strcasecmp strerror tzset ulimit usleep utimes waitpid do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7491: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7295: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7550,10 +7328,10 @@ for ac_func in realpath do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7554: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7358: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7609,16 +7387,16 @@ esac echo $ac_n "checking whether netdb declares h_errno""... $ac_c" 1>&6 -echo "configure:7613: checking whether netdb declares h_errno" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < int main() { return h_errno; ; return 0; } EOF -if { (eval echo configure:7622: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7400: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -7638,16 +7416,16 @@ rm -f conftest* echo $ac_n "checking for sigsetjmp""... $ac_c" 1>&6 -echo "configure:7642: checking for sigsetjmp" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < int main() { sigjmp_buf bar; sigsetjmp (bar, 0); ; return 0; } EOF -if { (eval echo configure:7651: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7429: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -7667,11 +7445,11 @@ rm -f conftest* echo $ac_n "checking whether localtime caches TZ""... $ac_c" 1>&6 -echo "configure:7671: checking whether localtime caches TZ" >&5 +echo "configure:7449: checking whether localtime caches TZ" >&5 if test "$ac_cv_func_tzset" = "yes"; then cat > conftest.$ac_ext < #if STDC_HEADERS @@ -7706,7 +7484,7 @@ exit (0); } EOF -if { (eval echo configure:7710: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7488: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then emacs_cv_localtime_cache=no else @@ -7735,9 +7513,9 @@ if test "$HAVE_TIMEVAL" = "yes"; then echo $ac_n "checking whether gettimeofday cannot accept two arguments""... $ac_c" 1>&6 -echo "configure:7739: checking whether gettimeofday cannot accept two arguments" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7541: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""no" 1>&6 else @@ -7779,21 +7557,64 @@ rm -f conftest* fi +echo $ac_n "checking whether the timezone variable is already declared""... $ac_c" 1>&6 +echo "configure:7562: checking whether the timezone variable is already declared" >&5 +cat > conftest.$ac_ext < +#include +#else +#ifdef HAVE_SYS_TIME_H +#include +#else +#include +#endif +#endif + +int main() { + + timezone = 0; + +; return 0; } +EOF +if { (eval echo configure:7584: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + echo "$ac_t""yes" 1>&6 + { test "$extra_verbose" = "yes" && cat << \EOF + Defining HAVE_TIMEZONE_DECL +EOF +cat >> confdefs.h <<\EOF +#define HAVE_TIMEZONE_DECL 1 +EOF +} + +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + echo $ac_n "checking for inline""... $ac_c" 1>&6 -echo "configure:7785: checking for inline" >&5 +echo "configure:7606: checking for inline" >&5 ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7618: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_inline=$ac_kw; break else @@ -7843,17 +7664,17 @@ # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! echo $ac_n "checking for working alloca.h""... $ac_c" 1>&6 -echo "configure:7847: checking for working alloca.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < int main() { char *p = alloca(2 * sizeof(int)); ; return 0; } EOF -if { (eval echo configure:7857: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7678: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_header_alloca_h=yes else @@ -7877,10 +7698,10 @@ fi echo $ac_n "checking for alloca""... $ac_c" 1>&6 -echo "configure:7881: checking for alloca" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7728: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_func_alloca_works=yes else @@ -7942,10 +7763,10 @@ echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6 -echo "configure:7946: checking whether alloca needs Cray hooks" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&6 -echo "configure:7973: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7820: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8025,10 +7846,10 @@ fi echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6 -echo "configure:8029: checking stack direction for C alloca" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7872: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_stack_direction=1 else @@ -8075,15 +7896,15 @@ ac_safe=`echo "vfork.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for vfork.h""... $ac_c" 1>&6 -echo "configure:8079: checking for vfork.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8087: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7908: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8111,10 +7932,10 @@ fi echo $ac_n "checking for working vfork""... $ac_c" 1>&6 -echo "configure:8115: checking for working vfork" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < @@ -8209,7 +8030,7 @@ } } EOF -if { (eval echo configure:8213: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8034: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_vfork_works=yes else @@ -8234,10 +8055,10 @@ echo $ac_n "checking for working strcoll""... $ac_c" 1>&6 -echo "configure:8238: checking for working strcoll" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main () @@ -8247,7 +8068,7 @@ strcoll ("123", "456") >= 0); } EOF -if { (eval echo configure:8251: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_strcoll_works=yes else @@ -8274,10 +8095,10 @@ for ac_func in getpgrp do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8278: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8125: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8328,10 +8149,10 @@ done echo $ac_n "checking whether getpgrp takes no argument""... $ac_c" 1>&6 -echo "configure:8332: checking whether getpgrp takes no argument" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8211: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_getpgrp_void=yes else @@ -8412,10 +8233,10 @@ echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:8416: checking for working mmap" >&5 +echo "configure:8237: checking for working mmap" >&5 case "$opsys" in ultrix* ) have_mmap=no ;; *) cat > conftest.$ac_ext < #include @@ -8448,7 +8269,7 @@ return 1; } EOF -if { (eval echo configure:8452: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8273: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then have_mmap=yes else @@ -8482,15 +8303,15 @@ ac_safe=`echo "termios.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termios.h""... $ac_c" 1>&6 -echo "configure:8486: checking for termios.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8494: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8315: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8533,15 +8354,15 @@ echo "$ac_t""no" 1>&6 ac_safe=`echo "termio.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termio.h""... $ac_c" 1>&6 -echo "configure:8537: checking for termio.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8545: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8366: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8573,10 +8394,10 @@ echo $ac_n "checking for socket""... $ac_c" 1>&6 -echo "configure:8577: checking for socket" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8424: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_socket=yes" else @@ -8614,15 +8435,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "netinet/in.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for netinet/in.h""... $ac_c" 1>&6 -echo "configure:8618: checking for netinet/in.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8626: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8447: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8639,15 +8460,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "arpa/inet.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for arpa/inet.h""... $ac_c" 1>&6 -echo "configure:8643: checking for arpa/inet.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8651: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8472: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8672,9 +8493,9 @@ } echo $ac_n "checking "for sun_len member in struct sockaddr_un"""... $ac_c" 1>&6 -echo "configure:8676: checking "for sun_len member in struct sockaddr_un"" >&5 +echo "configure:8497: checking "for sun_len member in struct sockaddr_un"" >&5 cat > conftest.$ac_ext < @@ -8685,7 +8506,7 @@ static struct sockaddr_un x; x.sun_len = 1; ; return 0; } EOF -if { (eval echo configure:8689: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8510: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SOCKADDR_SUN_LEN @@ -8716,10 +8537,10 @@ echo $ac_n "checking for msgget""... $ac_c" 1>&6 -echo "configure:8720: checking for msgget" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8567: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_msgget=yes" else @@ -8757,15 +8578,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/ipc.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/ipc.h""... $ac_c" 1>&6 -echo "configure:8761: checking for sys/ipc.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8769: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8590: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8782,15 +8603,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/msg.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/msg.h""... $ac_c" 1>&6 -echo "configure:8786: checking for sys/msg.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8794: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8615: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8828,15 +8649,15 @@ ac_safe=`echo "dirent.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for dirent.h""... $ac_c" 1>&6 -echo "configure:8832: checking for dirent.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8840: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8661: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8863,15 +8684,15 @@ echo "$ac_t""no" 1>&6 ac_safe=`echo "sys/dir.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/dir.h""... $ac_c" 1>&6 -echo "configure:8867: checking for sys/dir.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8875: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8696: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8904,15 +8725,15 @@ ac_safe=`echo "nlist.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for nlist.h""... $ac_c" 1>&6 -echo "configure:8908: checking for nlist.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8916: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8737: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8940,20 +8761,9 @@ fi -for f in "/usr/lpp/X11/bin/smt.exp" "/usr/bin/X11/smt.exp" ; do - if test -r $f; then { test "$extra_verbose" = "yes" && cat << EOF - Defining AIX_SMT_EXP = "-bI:$f" -EOF -cat >> confdefs.h <&6 -echo "configure:8957: checking "for sound support"" >&5 +echo "configure:8767: checking "for sound support"" >&5 case "$with_sound" in native | both ) with_native_sound=yes;; nas | no ) with_native_sound=no;; @@ -8964,15 +8774,15 @@ if test -n "$native_sound_lib"; then ac_safe=`echo "multimedia/audio_device.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for multimedia/audio_device.h""... $ac_c" 1>&6 -echo "configure:8968: checking for multimedia/audio_device.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8976: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8786: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9020,12 +8830,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for ALopenport in -laudio""... $ac_c" 1>&6 -echo "configure:9024: checking for ALopenport in -laudio" >&5 +echo "configure:8834: checking for ALopenport in -laudio" >&5 ac_lib_var=`echo audio'_'ALopenport | sed 'y%./+-%__p_%'` xe_check_libs=" -laudio " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8850: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9067,12 +8877,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for AOpenAudio in -lAlib""... $ac_c" 1>&6 -echo "configure:9071: checking for AOpenAudio in -lAlib" >&5 +echo "configure:8881: checking for AOpenAudio in -lAlib" >&5 ac_lib_var=`echo Alib'_'AOpenAudio | sed 'y%./+-%__p_%'` xe_check_libs=" -lAlib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8897: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9121,15 +8931,15 @@ for dir in "machine" "sys" "linux"; do ac_safe=`echo "${dir}/soundcard.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}/soundcard.h""... $ac_c" 1>&6 -echo "configure:9125: checking for ${dir}/soundcard.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9133: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8943: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9199,7 +9009,7 @@ fi libs_x="-laudio $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-laudio\" to \$libs_x"; fi cat > conftest.$ac_ext < EOF @@ -9226,7 +9036,7 @@ if test "$with_tty" = "yes" ; then echo "checking for TTY-related features" 1>&6 -echo "configure:9230: checking for TTY-related features" >&5 +echo "configure:9040: checking for TTY-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_TTY EOF @@ -9242,12 +9052,12 @@ if test -z "$with_ncurses"; then echo $ac_n "checking for tgetent in -lncurses""... $ac_c" 1>&6 -echo "configure:9246: checking for tgetent in -lncurses" >&5 +echo "configure:9056: checking for tgetent in -lncurses" >&5 ac_lib_var=`echo ncurses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lncurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9291,15 +9101,15 @@ ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:9295: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9303: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9113: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9321,15 +9131,15 @@ ac_safe=`echo "ncurses/term.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/term.h""... $ac_c" 1>&6 -echo "configure:9325: checking for ncurses/term.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9333: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9143: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9359,15 +9169,15 @@ c_switch_site="$c_switch_site -I/usr/include/ncurses" ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:9363: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9371: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9181: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9402,12 +9212,12 @@ for lib in curses termlib termcap; do echo $ac_n "checking for tgetent in -l$lib""... $ac_c" 1>&6 -echo "configure:9406: checking for tgetent in -l$lib" >&5 +echo "configure:9216: checking for tgetent in -l$lib" >&5 ac_lib_var=`echo $lib'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -l$lib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9449,12 +9259,12 @@ else echo $ac_n "checking for tgetent in -lcurses""... $ac_c" 1>&6 -echo "configure:9453: checking for tgetent in -lcurses" >&5 +echo "configure:9263: checking for tgetent in -lcurses" >&5 ac_lib_var=`echo curses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lcurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9279: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9483,12 +9293,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for tgetent in -ltermcap""... $ac_c" 1>&6 -echo "configure:9487: checking for tgetent in -ltermcap" >&5 +echo "configure:9297: checking for tgetent in -ltermcap" >&5 ac_lib_var=`echo termcap'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -ltermcap " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9313: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9547,15 +9357,15 @@ test -z "$with_gpm" && { ac_safe=`echo "gpm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for gpm.h""... $ac_c" 1>&6 -echo "configure:9551: checking for gpm.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9559: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9369: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9578,12 +9388,12 @@ } test -z "$with_gpm" && { echo $ac_n "checking for Gpm_Open in -lgpm""... $ac_c" 1>&6 -echo "configure:9582: checking for Gpm_Open in -lgpm" >&5 +echo "configure:9392: checking for Gpm_Open in -lgpm" >&5 ac_lib_var=`echo gpm'_'Gpm_Open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgpm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9408: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9643,17 +9453,17 @@ echo "checking for database support" 1>&6 -echo "configure:9647: checking for database support" >&5 +echo "configure:9457: checking for database support" >&5 if test "$with_database_gnudbm" != "no"; then echo $ac_n "checking for dbm_open in -lgdbm""... $ac_c" 1>&6 -echo "configure:9652: checking for dbm_open in -lgdbm" >&5 +echo "configure:9462: checking for dbm_open in -lgdbm" >&5 ac_lib_var=`echo gdbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9478: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9686,10 +9496,10 @@ if test "$with_database_gnudbm" != "yes"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9690: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9526: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9748,10 +9558,10 @@ if test "$with_database_dbm" != "no"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9752: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9588: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9795,12 +9605,12 @@ if test "$need_libdbm" != "no"; then echo $ac_n "checking for dbm_open in -ldbm""... $ac_c" 1>&6 -echo "configure:9799: checking for dbm_open in -ldbm" >&5 +echo "configure:9609: checking for dbm_open in -ldbm" >&5 ac_lib_var=`echo dbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -ldbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9625: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9848,10 +9658,10 @@ if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for dbopen""... $ac_c" 1>&6 -echo "configure:9852: checking for dbopen" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9688: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbopen=yes" else @@ -9895,12 +9705,12 @@ if test "$need_libdb" != "no"; then echo $ac_n "checking for dbopen in -ldb""... $ac_c" 1>&6 -echo "configure:9899: checking for dbopen in -ldb" >&5 +echo "configure:9709: checking for dbopen in -ldb" >&5 ac_lib_var=`echo db'_'dbopen | sed 'y%./+-%__p_%'` xe_check_libs=" -ldb " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9725: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9935,7 +9745,7 @@ if test "$with_database_berkdb" = "yes"; then for path in "db/db.h" "db.h"; do cat > conftest.$ac_ext < -#ifdef DB_VERSION_MAJOR -#if DB_VERSION_MAJOR > 1 -choke me; -#endif -#endif int main() { ; return 0; } EOF -if { (eval echo configure:9962: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:9767: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* db_h_path="$path"; break else @@ -10010,12 +9815,12 @@ if test "$with_socks" = "yes"; then echo $ac_n "checking for SOCKSinit in -lsocks""... $ac_c" 1>&6 -echo "configure:10014: checking for SOCKSinit in -lsocks" >&5 +echo "configure:9819: checking for SOCKSinit in -lsocks" >&5 ac_lib_var=`echo socks'_'SOCKSinit | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocks " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9835: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10234,6 +10039,7 @@ + RECURSIVE_MAKE="\$(MAKE) \$(MFLAGS) CC='\$(CC)' CFLAGS='\$(CFLAGS)' LDFLAGS='\$(LDFLAGS)' CPPFLAGS='\$(CPPFLAGS)'" @@ -10256,6 +10062,11 @@ } + +T="" +for W in $ac_configure_args; do if test -z "$T"; then T="$W"; else T="$T $W"; fi; done +ac_configure_args="$T" + { test "$extra_verbose" = "yes" && cat << EOF Defining EMACS_CONFIGURATION = "$canonical" EOF @@ -10265,10 +10076,10 @@ } { test "$extra_verbose" = "yes" && cat << EOF - Defining EMACS_CONFIG_OPTIONS = "${ac_configure_args}" + Defining EMACS_CONFIG_OPTIONS = "$ac_configure_args" EOF cat >> confdefs.h < +#include +#else +#ifdef HAVE_SYS_TIME_H +#include +#else +#include +#endif +#endif + ], + [ + timezone = 0; +], + [AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_TIMEZONE_DECL)], + [AC_MSG_RESULT(no)]) + + AC_C_INLINE if test "$ac_cv_c_inline" != "no"; then @@ -3013,11 +3022,6 @@ dnl Check for nlist.h AC_CHECK_HEADER(nlist.h, AC_DEFINE(NLIST_STRUCT), ) -dnl AIX export list -for f in "/usr/lpp/X11/bin/smt.exp" "/usr/bin/X11/smt.exp" ; do - if test -r $f; then AC_DEFINE_UNQUOTED(AIX_SMT_EXP, "-bI:$f") break; fi -done - dnl Check for sound of various sorts. dnl Autodetect native sound @@ -3251,11 +3255,6 @@ #endif #endif #include <$path> -#ifdef DB_VERSION_MAJOR -#if DB_VERSION_MAJOR > 1 -choke me; -#endif -#endif ],[], db_h_path="$path"; break) done test -z "$db_h_path" && with_database_berkdb=no @@ -3382,6 +3381,7 @@ AC_SUBST(infodir) AC_SUBST(infodir_user_defined) AC_SUBST(infopath) +AC_SUBST(infopath_user_defined) AC_SUBST(lispdir) AC_SUBST(lispdir_user_defined) AC_SUBST(sitelispdir) @@ -3431,8 +3431,9 @@ package_path=`echo $package_path | sed 'y/ /:/'` AC_DEFINE_UNQUOTED(PACKAGE_PATH, "$package_path") +XE_SPACE(ac_configure_args, $ac_configure_args) AC_DEFINE_UNQUOTED(EMACS_CONFIGURATION, "$canonical") -AC_DEFINE_UNQUOTED(EMACS_CONFIG_OPTIONS, "${ac_configure_args}") +AC_DEFINE_UNQUOTED(EMACS_CONFIG_OPTIONS, "$ac_configure_args") AC_DEFINE_UNQUOTED(config_machfile, "$machfile") AC_DEFINE_UNQUOTED(config_opsysfile, "$opsysfile") @@ -3522,7 +3523,6 @@ echo " No Xmu; substituting equivalent routines." fi -test "$with_gif" = yes && echo " Compiling in support for GIF image conversion." if test "$with_xpm" = yes; then echo " Compiling in support for XPM images." elif test "$with_x11" = yes; then @@ -3533,9 +3533,7 @@ echo " --------------------------------------------------------------------" fi test "$with_xface" = yes && echo " Compiling in support for X-Face message headers." -test "$with_jpeg" = yes && echo " Compiling in support for JPEG image conversion." -test "$with_png" = yes && echo " Compiling in support for PNG image conversion." -test "$with_tiff" = yes && echo " Compiling in support for TIFF image conversion (not implemented)." +test "$with_imagick" = yes && echo " Compiling in support for ImageMagick image conversion." case "$with_sound" in nas ) echo " Compiling in network sound (NAS) support." ;; @@ -3594,7 +3592,7 @@ test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication" test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host" echo " The \`Info-default-directory-list' will be initialized from:" -echo " INFOPATH=\"`echo $infopath`\"" +echo " INFOPATH=\"$infopath\"" test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects." test "$debug" = yes && echo " Compiling in extra code for debugging." test "$memory_usage_stats" = yes && echo " Compiling in code for checking XEmacs memory usage." diff -r d3e9274cbc4e -r e45d5e7c476e etc/Emacs.ad --- a/etc/Emacs.ad Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/Emacs.ad Mon Aug 13 10:03:52 2007 +0200 @@ -51,6 +51,8 @@ ! This is for buttons in the menubar. ! Yellow would be better, but that would map to white on monochrome. *menubar*buttonForeground: Blue +*XlwMenu*highlightForeground: Red +*XlwMenu*titleForeground: Maroon *XlwMenu*selectColor: ForestGreen *XmToggleButton*selectColor: ForestGreen diff -r d3e9274cbc4e -r e45d5e7c476e etc/GOATS --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/GOATS Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,18 @@ +Reference: http://www.ansi.okstate.edu/breeds/heading.htm + + Goats: (Capra hircus) + + [INLINE] The goat, along with sheep, were among the earliest + domesticated animals. Goat remains have been found at + archaeological sites in western Asia, such as Jericho, Choga, Mami, + Djeitun and Cayonu, which allows domestication of the goats to be + dated at between 6000 and 7000 B.C. + + [INLINE] However, unlike sheep, their ancestry is fairly clear. The + major contributor of modern goats is the Bezoar goat which is + distributed from the mountains of Asia Minor across the Middle East + to Sind. + Unlike sheep, goats easily revert to feral or wild condition given + a chance. In fact, the only domestic species which will return to a + wild state as rapidly as a goat is the domestic cat. + ________________________________________ diff -r d3e9274cbc4e -r e45d5e7c476e etc/HELLO --- a/etc/HELLO Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/HELLO Mon Aug 13 10:03:52 2007 +0200 @@ -2,9 +2,9 @@ Please correct this incomplete list and add more! --------------------------------------------------------- -Amharic ($(3"c!(B Arabic [2](38R(47d(3T!JSa(4W(3W[0](B Croatian Zdravo +Czech (,Bh(Besky) Dobr,B}(B den Danish (Dansk) Hej, Goddag English Hello Esperanto Saluton @@ -24,9 +24,6 @@ Russian (,L@caaZXY(B) ,L7T`PRabRcYbU(B! Spanish (Espa,Aq(Bol) ,A!(BHola! Swedish (Svenska) Hej, Goddag -Thai (,T@RIRd7B(B) ,TJ0GQ1J04U1$0CQ1:(B, ,TJ0GQ1J04U10$h1P(B -Tigrigna ($(3"8#r!N"^(B) $(3!Q!,!<"8(B -Turkish (T,A|(Brk,Ag(Be) Merhaba Vietnamese (Ti,1*(Bng Vi,1.(Bt) Ch,1`(Bo b,1U(Bn Japanese ($BF|K\8l(B) $B$3$s$K$A$O(B, (I:]FAJ(B, $BqV$(DiQ(B diff -r d3e9274cbc4e -r e45d5e7c476e etc/NEWS --- a/etc/NEWS Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/NEWS Mon Aug 13 10:03:52 2007 +0200 @@ -139,6 +139,26 @@ creating a new frame with `C-x 5 2' also raises and selects that frame. The behavior of window system frames is unchanged. +** Package starting changes. + +State of Emacs should never be changed with loading a package. The +following XEmacs packages that used to break this have been changed. + +*** Loading `paren' no longer enables paren-blinking. Use +`paren-set-mode' explicitly, or customize `paren-mode'. + +*** Loading `uniquify' no longer enables uniquify. Set +`uniquify-buffer-name-style' to a legal value. + +*** Loading `time' no longer enables display time. Invoke +`display-time' explicitly. + +*** Loading `jka-compr' no longer enables on-the-fly compression. Use +`toggle-auto-compression' instead. + +*** Loading `id-select' no longer enables its behaviour. Use +`id-select-install' instead. + ** Zmacs region is not deactivated when an error is signaled. The behavior of the zmacs region can now be controlled in the event of @@ -146,74 +166,15 @@ set to nil to revert to the old behaviour. As before, typing C-g deactivates the region. -** Info "dir" functionality merged from Emacs-19.34 - - ------------------ DRAFT ------------------ - -At the time it is dumped, XEmacs will initialize the value of -`Info-default-directory-list' from the value of the environment -variable INFOPATH, which it inherits from the Makefile. The Makefile -gets the value from `configure'. - - #### BETA Note: if the package startup stuff moves or changes, this - next paragraph may need fixing. - -At runtime, the XEmacs startup code will loop through that list and -collect all of the directories in it that satisfy `file-directory-p', -and then appends any site package info directories found... ?? How do -you want this worded? XXXXX !!!! (bright red bold DRAFT) - -When you start the info reader, `Info-directory-list' is initialized -from either the environment variable "INFOPATH", if it exists, or -`Info-default-directory-list'. The first directory in this list must -contain a "dir" file like the one supplied with XEmacs. Note that if -an INFOPATH variable is used, that only the directories in that path -will be searched; no package info paths will be appended, as `Info- -default-directory-list' will be ignored in that case. - -All of the directories on `Info-directory-list' will be searched for -"dir" files, which may be full fledged Info files containing subnodes -as well as menus. They are merged to become one Info directory, with -menus in like-named subnodes being coalesced from the several "dir" -files. - - BETA Note: I have not tested this very thouroughly. Does anyone out - there actually have a dir file with real `info' subnodes in it? I - will create one and try it as I learn how. - karlheg - -"localdir" files are looked for also, secondary to "dir"'s. A localdir -file should look like a section of the Info directory menu: - - | - |* Gnus:: The all seeing all knowing News and Mail - | interface for XEmacs. - |* Calc:: HP-48 alike Calculator that can do algebra - | - -The info reader will insert its contents into the main Info directory -either at the end of the (dir)Top node, beginning at and replacing a -line that looks like: - - | - |* Locals: - | - - BETA-Note: Coming soon... - - ... or, below a line that contains the exact text: - - | - |Locally installed XEmacs Packages - | - - ... by default. (This text is configurable--- see: - `M-x customize-variable Info-localdir-heading-regexp' - -The `Info-localdir-heading-regexp' may be underlined with *'s, ='s, or --'s, like any Info topic header. When `Info-fontify' is non-nil, the -underlineing characters will be elided and the topic heading itself -will be given a face, according to `Info-title-face-alist'. - +** Multiple Info `dir' functionality has been merged with GNU Emacs +19.34. + +XEmacs will now correctly merge all the `dir' files in +`Info-directory-list' (initialized from either `INFOPATH' +env. variable or `Info-default-directory-list'.) These files may be +full-fledged info files containing subnodes or menus. Previously +supported `localdir' files are looked for also, secondary to `dir's. +See the manual for details. ** Abbreviations can now contain non-word characters. @@ -230,8 +191,14 @@ current buffer and deletes the selected window. It asks for confirmation first. +** `ESC ESC ESC' (keyboard-escape-quit) will now correctly abort +recursive edits (as documented.) + ** arc-mode has a new function called `archive-quit' bound to q, which quits archive mode in the same fashion dired-quit works. + +** A `tetris' clone is now available within XEmacs, written by Glynn +Clements. Try it out with `M-x tetris'. ** The feature to teach the key bindings of extended commands now prints the message after the command finishes. After some time, the @@ -247,6 +214,15 @@ background pixmap, which means that background pixmaps no longer clash with zmacs-regions, or clickable buttons. +** Regexps can now contain additional Perl-like constructs. + +** Modifiers can be added to a keystroke by preceding it with a `C-x @ +' sequence where is one of letters `S', `c', `m', `a', `h', `s' +corresponding to shift, control, meta, alt, hyper, and super modifiers, +respectively. It is possible to add several modifiers by repeating this +sequence. This feature is especially useful on text terminals where it +allows one to enter keystrokes like, e.g., `M-home'. + ** Customize changes. *** Customize has undergone a massive speedup, and should now operate @@ -254,7 +230,7 @@ gripe. *** Many more packages have been modified to use the facility, so -almost all of XEmacs options can be examined through the Customize +almost all of XEmacs options can now be examined through the Customize groups. *** There is a new `browser' mode of traversing customizations, in @@ -278,23 +254,6 @@ In .emacs: Use (turn-on-pending-delete) not (load "pending-del") -** Package starting changes. - -*** Loading `paren' no longer enables paren-blinking. Use -`paren-set-mode' explicitly, or customize `paren-mode'. - -*** Loading `uniquify' no longer enables uniquify. Set -`uniquify-buffer-name-style' to a legal value. - -*** Loading `time' no longer enables display time. Invoke -`display-time' explicitly. - -*** Loading `jka-compr' no longer enables on-the-fly compression. Use -`toggle-auto-compression' instead. - -*** Loading `id-select' no longer enables its behaviour. Use -`id-select-install' instead. - ** XEmacs can now save the minibuffer histories from various minibuffers. To use this feature, add the line: @@ -313,6 +272,10 @@ Or `M-x customize RET add-log RET'. +** In ChangeLog mode, you can now press `C-c C-c' to save the file +and restore old window configuration, or `C-c C-k' to abandon the +changes. + ** The key `C-x m' no longer runs the `mail' command directly. Instead, it runs the command `compose-mail', which invokes the mail composition mechanism you have selected with the variable @@ -346,10 +309,10 @@ flexibility and features. *** Many new options and variables are now customizable. Try -`M-x customize-group RET gnuserv RET'. - -*** The `gnuattach' and `gnudoit' programs have been abandoned in -favor of `gnuclient', which now accepts the standard `-nw', +`M-x customize RET gnuserv RET'. + +*** The functionality of `gnuattach' and `gnudoit' programs is +provided by `gnuclient', which now accepts the standard `-nw', `-display', `-eval' and `-f' options. ** Etags changes. @@ -408,6 +371,71 @@ places one blank between a word end and an opening '(', and puts one space between a comma and the beginning of a word. +** New demand based locking implementation + +A faster, but experimental replacement for lazy-lock (called lazy-shot) is +provided. Like lazy-lock it provides demand based and idle time +font-lock-ing. However the lazy-lock versions that came with previous +versions slowed down XEmacs (possibly quite a lot). Lazy-shot solves +this problem by relying on new support from the C code part of XEmacs. +The support however is experimental and will cause some flashing as +parts of the buffer are colored. This likely to change in the future +as the C support is completed. + +The current lazy-shot implementation is mostly interface compatible +with lazy-lock v2.06 (the version shipped with XEmacs is v1.x). + +*** To enable: + 1. Despite the flashing, lazy-shot was deemed such an improvement by + the majority of beta testers that it is now the standard method + provided by the options menu. Alternatively add + + (add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) + + to '.emacs'. + 2. If you were using lazy-lock before, just replace all occurrences of + "lazy-lock" by "lazy-shot" in your '.emacs' file. + +*** To disable: + +If prefer to use lazy-lock in stead of lazy-shot, put + + (remove-hook 'font-lock-mode-hook 'turn-on-lazy-shot) + (add-hook 'font-lock-mode-hook 'turn-on-lazy-lock) + +at the END of `.emacs'. + +** RefTeX mode + +RefTeX mode is a new minor mode with special support for \label{}, \ref{} +and \cite{} macros in LaTeX documents. RefTeX distinguishes labels of +different environments (equation, figure, ...) and has full support for +multifile documents. To use it, select a buffer with a LaTeX document and +turn the mode on with M-x reftex-mode. Here are the main user commands: + +C-c ( reftex-label + Creates a label semi-automatically. RefTeX is context sensitive and + knows which kind of label is needed. + +C-c ) reftex-reference + Offers in a menu all labels in the document, along with context of the + label definition. The selected label is referenced as \ref{LABEL}. + +C-c [ reftex-citation + Prompts for a regular expression and displays a list of matching BibTeX + database entries. The selected entry is cited with a \cite{KEY} macro. + +C-c & reftex-view-crossref + Views the cross reference of a \ref{} or \cite{} command near point. + +C-c = reftex-toc + Shows a table of contents of the (multifile) document. From there you + can quickly jump to every section. + +Under X, RefTeX installs a "Ref" menu in the menu bar, with additional +commands. Full documentation and customization examples are in the file +reftex.el. You can use the finder to view this information: +C-h p --> tex --> reftex.el * Lisp and internal changes in XEmacs 20.3 @@ -420,6 +448,10 @@ was set up as the terminal's erase character at the time Emacs was started. +** It is now possible to attach the menubar accelerator keys to menu +entries. Look at the Lispref under Menus->Menu Accelerators for +details. + ** `insert-file-contents' can now read from a special file, as long as the arguments VISIT and REPLACE are nil. @@ -436,6 +468,12 @@ change properties of an extent at once, and is analogous to `set-frame-properties'. +** If a format field width is specified as `*', the field width is +now assumed to have been specified as an argument (as in C.) + + (format "%*s" 10 "abc") + => " abc" + ** The new macro `with-current-buffer' lets you evaluate an expression conveniently with a different current buffer. It looks like this: @@ -471,11 +509,56 @@ This makes it possible for a Lisp program to open a file whose name begins with ~. +** The regexp matcher has been extended to recognize the following +constructs, borrowed from Perl: + +*** Additional quantifiers. + +In addition to `*', `+' and `?', XEmacs now recognizes the following +quantifiers: + + \{n\} Match exactly n times + \{n,\} Match at least n times + \{n,m\} Match at least n but not more than m times + +*** Non-greedy quantifiers. + +Any of the standard quantifiers (`*', `+' and others) can now be +followed by an optional `?', which will make them become "non-greedy", +i.e. they will match as little text as possible. Note that the +meanings don't change, just the "gravity." + +*** Shy groups. + +The \(?: ... \) groups things like \( ... \), but doesn't record the +context for backreferences or future use. This is useful when you +need a lot of groups for the sake of priorities, but actually want to +record only one or two. + ** The new function `regexp-opt' returns an efficient regexp to match a string. The arguments are STRINGS and (optionally) PAREN. This function can be used where regexp matching or searching is intensively used and speed is important, e.g., in Font Lock mode. +** The featurep syntax has been extended to resemble the Common Lisp +one, as suggested by Erik Naggum. + +*** The `xemacs' feature is defined in XEmacs by default. + +*** The expression `#+fexp form' is equivalent to +(when (featurep fexp) form), only it is evaluated at read-time. Also, +`#-fexp form' is equivalent to (unless (featurep fexp) form). + +*** In addition to symbols, a FEXP can also be a number, or a logical +operator. Here are some examples: + ;; evaluates to non-nil on XEmacs: + (featurep 'xemacs) + ;; evaluates to non-nil on XEmacs 20.3 or later: + (featurep '(and xemacs 20.03)) + ;; evaluates to non-nil either on Emacs, or on XEmacs built without + ;; X support: + (featurep '(or emacs (and xemacs (not x)))) + * Changes in XEmacs 20.2 diff -r d3e9274cbc4e -r e45d5e7c476e etc/TUTORIAL --- a/etc/TUTORIAL Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/TUTORIAL Mon Aug 13 10:03:52 2007 +0200 @@ -313,11 +313,11 @@ top of the screen." So C-u 0 C-l means "redraw the screen, putting the current line at the top.") ->> Type Control-h k Control-f. +>> Type Control-x 2 See how this window shrinks, while a new one appears - to display documentation on the Control-f command. + to display contents of this buffer. ->> Type C-x 1 and see the documentation listing window disappear. +>> Type C-x 1 and see the new window disappear. * INSERTING AND DELETING @@ -762,10 +762,10 @@ area contains the bottom line of the screen. -* MODE LINE +* MODELINE ----------- -The line immediately above the echo area it is called the "mode line". +The line immediately above the echo area it is called the "modeline". The mode line says something like this: --**-XEmacs: TUTORIAL (Fundamental)--L670--58%---------------- @@ -820,7 +820,7 @@ >> Use C-u C-v once or more to bring this line near the top of screen. >> Type C-h m, to see how Text mode differs from Fundamental mode. ->> Type C-x 1 to remove the documentation from the screen. +>> Type q to remove the documentation from the screen. Major modes are called major because there are also minor modes. Minor modes are alternatives not to the major modes, just minor @@ -879,7 +879,7 @@ When you type C-s you'll notice that the string "I-search" appears as a prompt in the echo area. This tells you that Emacs is in what is called an incremental search waiting for you to type the thing that -you want to search for. terminates a search. +you want to search for. terminates a search. >> Now type C-s to start a search. SLOWLY, one letter at a time, type the word 'cursor', pausing after you type each @@ -890,10 +890,11 @@ >> Type to terminate the search. Did you see what happened? Emacs, in an incremental search, tries to -go to the occurrence of the string that you've typed out so far. To -go to the next occurrence of 'cursor' just type C-s again. If no such -occurrence exists Emacs beeps and tells you the search is currently -"failing", C-g would also terminate the search. +go to the occurrence of the string that you've typed out so far, +highlighting it for your convenience. To go to the next occurrence of +'cursor' just type C-s again. If no such occurrence exists Emacs +beeps and tells you the search is currently "failing", C-g would also +terminate the search. NOTE: On some systems, typing C-s will freeze the screen and you will see no further output from Emacs. This indicates that an operating @@ -1049,9 +1050,7 @@ This displays the documentation of the function, as well as its name, in an Emacs window. When you are finished reading the -output, type C-x 1 to get rid of the help text. You do not have -to do this right away. You can do some editing while referring -to the help text, and then type C-x 1. +output, type q to get rid of the help text. Here are some other useful C-h options: @@ -1062,21 +1061,16 @@ This prints all the information Emacs has about the function which implements the C-p command. - C-h a Command Apropos. Type in a keyword and Emacs will list - all the commands whose names contain that keyword. - These commands can all be invoked with Meta-x. - For some commands, Command Apropos will also list a one - or two character sequence which runs the same command. - ->> Type C-h a file. + C-h a Hyper Apropos. Type in a keyword and Emacs will list + all the functions and variables whose names contain + that keyword. The commands that can be invoked with + Meta-x, an asterisk will be displayed to the left. -This displays in another window a list of all M-x commands with "file" -in their names. You will see character-commands like C-x C-f listed -beside the corresponding command names such as find-file. +>> Type C-h a newline. ->> Type C-M-v to scroll the help window. Do this a few times. - ->> Type C-x 1 to delete the help window. +This displays a list of all functions and variables with "newline" in +their names. Press or click the middle mouse button to find +out more about a function or variable. Type `q' to exit hyper-apropos. * CONCLUSION @@ -1095,7 +1089,8 @@ This tutorial descends from a long line of Emacs tutorials starting with the one written by Stuart Cracraft for the original Emacs. -Ben Wing updated the tutorial for X Windows. +Ben Wing updated the tutorial for X Windows. Martin Buchholz and +Hrvoje Niksic added more corrections for XEmacs. This version of the tutorial, like GNU Emacs, is copyrighted, and comes with permission to distribute copies on certain conditions: diff -r d3e9274cbc4e -r e45d5e7c476e etc/TUTORIAL.de --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.de Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1150 @@ +Copyright (c) 1985, 1996 Free Software Foundation, Inc. See end for conditions. + +Du betrachtest das Emacs Tutorial. +Dies sind die einführenden Übungen für Emacs. + +Emacs-Befehle verwenden generell entweder die CONTROL- (manchmal mit +CTRL oder CTL beschriftet, auf deutschen Tastaturen auch oft mit STRG) +oder die META-Taste. Auf manchen Tastaturen ist die META-Taste mit +ALT, EDIT oder sonstwie (z.B. ist auf einer Sun Tastatur die +Raute-Taste links vom SPACE Balken die META-Taste) beschriftet. Statt +jedesmal META oder CONTROL auszuschreiben, wenn wir wollen daß Du die +Taste drückst, verwenden wir folgende Abkürzungen: + +C- bedeutet: Halte die CONTROL-Taste während der Betätigung der + -Taste gedrückt. Also bedeutet C-f: Halte die CONTROL + Taste, während Du den Buchstaben f drückst. +M- bedeutet: Halte die META-Taste während der Betätigung der + -Taste gedrückt. Falls es keine META-Taste gibt, tippe + zuerst ESC (die ESCAPE-Taste) und danach die -Taste. + +Wichtig: Tippe C-x C-c, um die Emacs-Sitzung zu beenden (zwei +Zeichen). Die ">>" am linken Seitenrand deuten auf Anweisungen, die +Du probieren solltest. so z.B: +<> +>> Tippe nun C-v (Betrachte nächste Seite) um die nächste Seite zu + betrachten. (Also, halte die CONTROL-Taste gedrückt während + Du v tippst.) + Von jetzt an tu das bitte jeweils nachdem Du eine Seite + vollständig gelesen hast. + +Bitte beachte die Überlappung von zwei Zeilen wenn Du vorwärts +blätterst; dies erlaubt es, den Text fließend weiter zu lesen. + +Zuerst solltest Du wissen, wie man sich im Text von Stelle zu Stelle +bewegt. Du weißt bereits, wie man sich mit C-v eine Seite +weiterbewegt. Um eine Seite zurück zu gehen, tippe M-v (halte die +META-Taste gedrückt und tippe v oder tippe v wenn Deine Tastatur +keine META-, EDIT- oder ALT-Taste besitzt). + +>> Versuche ein paar Mal M-v und C-v zu tippen. + + +* ZUSAMMENFASSUNG +----------------- + +Die folgenden Befehle sind nützlich um Text seitenweise zu betrachten: + + C-v Eine Seite vorwärts blättern + M-v Eine Seite zurück blättern + C-l Bewegt den Bildschirminhalt um den Textzeiger in die + Bildmitte und baut den Bildschirm neu auf. + (Dies ist CONTROL-, nicht CONTROL-1.) + +>> Finde den Textzeiger und merke Dir den Text der ihm nahe ist. + Nun tippe C-l. + Finde den Textzeiger abermals und achte darauf daß er sich, + relativ zum Text, nicht bewegt hat. + + +* EINFACHE TEXTZEIGER-STEUERUNG +------------------------------- + +Das Bewegen von Bildschirminhalt zum nächsten ist nützlich, aber wie +bewegt man sich an eine bestimmte Stelle im Text? + +Dazu gibt es mehrere Möglichkeiten. Die einfachste ist die Befehle +C-p, C-b, C-f und C-n zu verwenden. Jeder dieser Befehle bewegt den +Textzeiger um eine Zeile bzw. Spalte in eine bestimmte Richtung. +Hier ist eine Tabelle welche die Bewegungsrichtung der vier Befehle +zeigt: + + Vorherige Zeile, C-p + : + : + Rückwärts, C-b .... Jetzige Textzeiger-Position .... Vorwärts, C-f + : + : + Nächste Zeile, C-n + +>> Bewege den Textzeiger mittels C-n oder C-p auf die mittlere Zeile + der obigen Tabelle. Dann zentriere das Diagramm mittels C-l im + Bildschirmfenster. + +Auf Englisch kann man sich diese Befehle leicht einprägen: P für +previous, N für next, B für backward und F für forward. Dies sind die +einfachen Befehle zur Bewegung des Textzeigers. Da Du sie ständig +benutzen wirst, solltest Du sie jetzt erlernen. + +>> Verwende einige C-n's um den Textzeiger auf diese Zeile zu + bringen. + +>> Bewege Dich mit C-f's in die Zeile und dann hinauf mit C-p's. + Beobachte das Verhalten von C-p, wenn Du Dich mitten in einer Zeile + befindest. + +Jede Textzeile endet mit einem Newline-Zeichen, welches sie von der +nächsten trennt. Auch die letzte Zeile in Deiner Datei sollte ein +Newline am Ende besitzen (obschon Emacs dieses nicht benötigt). + +>> Versuche C-b am Beginn einer Zeile. Es sollte Dich zum Ende der + vorigen Zeile bringen. Dies deshalb, weil es Dich über das + Newline-Zeichen zurückbewegt. + +C-f kann sich, wie C-b, über ein Newline hinwegbewegen. + +>> Tippe einige C-b's um ein Gefühl für die Position des Textzeigers + zu bekommen. Dann verwende C-f um ans Ende der Zeile zu gelangen. + Nun versuche ein weiteres C-f um in die nächste Zeile zu gelangen. + +Wenn Du Dich am Anfang oder Ende aus dem Bildschirm bewegst, schiebt +sich der Text ins Blickfeld. Diesen Vorgang nennt man rollen oder +"scrolling". Er erlaubt Emacs den Textzeiger an die gewünschte +Stelle zu bringen, ohne ihn aus dem Bildschirmfenster zu bewegen. + +>> Versuche den Textzeiger mittels C-n aus dem Blickfeld zu bewegen + und beobachte was geschieht. + +Wenn Dir die zeichenweise Fortbewegung zu langsam ist, kannst Du +Dich Wort für Wort bewegen. M-f (META-f) geht ein Wort weiter und M-b +geht eins zurück. + +>> Tippe ein paar M-f's und M-b's. + +Wenn Du mitten in einem Wort bist, bringt Dich M-f an sein Ende. +Wenn Du auf Leerzeichen zwischen Worten stehst, bewegt Dich M-f zum +Ende des folgenden Wortes. M-b bewegt sich sinngemäß zurück. + +>> Versuche M-f und M-b einige Male, abgewechselt von C-f's und C-b's + so daß Du das Verhalten von M-f und M-b an verschiedenen Stellen + innerhalb und zwischen Wörtern beobachten kannst. + +Achte auf die Verwandtschaft von C-f und C-b auf der einen Seite und +M-f und M-b auf der anderen. Sehr oft werden META-Befehle für +Operationen mit Einheiten einer Sprache verwendet (Worte, Sätze, +Absätze), während CONTROL-Befehle unverändert mit den einfachen +Einheiten (Buchstaben, Zeilen, etc.) arbeiten. + +Diese Parallele ist auf Zeilen und Sätze anwendbar: C-a und C-e gehen +zum Anfang und Ende einer Zeile, M-a und M-e zum Anfang bzw. Ende +eines Satzes. + +>> Versuche ein paar C-a's und dann ein paar C-e's. + Versuche ein paar M-a's und dann ein paar M-e's. + +Schau wie mehrere C-a's nichts bewirken, mehrere M-a's sich aber Satz +für Satz weiterbewegen. Obwohl sich ihr Verhalten unterscheidet, +erscheint es natürlich. + +Die Stelle des Textzeigers im Text wird auch "Punkt" genannt. Der +Textzeiger auf dem Bildschirm zeigt an welchem Punkt im Text sich +dieser befindet. + +Hier ist eine Zusammenfassung der einfachen Befehle zur Bewegung des +Textzeigers, inklusive der Befehle zur wort- und satzweisen Bewegung: + + C-f Gehe ein Zeichen weiter + C-b Gehe ein Zeichen zurück + + M-f Gehe ein Wort weiter + M-b Gehe ein Wort zurück + + C-n Gehe zur nächsten Zeile + C-p Gehe zur vorherigen Zeile + + C-a Gehe an den Anfang der Zeile + C-e Gehe an das Ende der Zeile + + M-a Gehe zurück zum Anfang des Satzes + M-e Gehe weiter zum Ende des Satzes + +>> Übe jetzt alle diese Befehle einige Male. + Es sind die am häufigsten benutzten. + +Zwei weitere wichtige Befehle zur Bewegung im Text sind M-< (META +kleiner), welcher an den Anfang des gesamten Texts springt, und M-> +(META größer), welcher an das Textende hüpft. + +Auf einigen deutschen Tastaturen ist ">" über "<", Du mußt also +möglicherweise die Shift-Taste drücken, um ein > zu tippen. Auf +solchen Tastaturen mußt Du auch für M-> die Shift-Taste drücken; ohne +Shift-Taste würdest Du sonst M-< tippen. + +>> Versuche jetzt M-< um an den Beginn dieser einführenden Übungen zu + gelangen. + Dann verwende C-v wiederholt um hierher zurück zu kommen. + +>> Versuche jetzt M-> um ans Ende der Übungen zu springen. + Benutzte M-v widerholt um hierher zurück zu gelangen. + +Du kannst den Textzeiger auch mit den Pfeil-Tasten bewegen, falls +Deine Tastatur solche besitzt. Wir empfehlen das Erlernen von C-b, +C-f, C-n und C-p aus drei Gründen. Erstens funktionieren sie auf allen +Tastaturen. Zweitens wirst Du herausfinden, wenn Du einige Übung mit +Emacs bekommst, daß es schneller ist die CTRL-Tasten zu drücken als +die Pfeil-Tasten (weil Du Deine Hände nicht aus dem normalen +Fingersatz bringen mußt). Drittens: Hast Du die Versendung der CTRL +Befehle erst zu Deiner Gewohnheit gemacht, wird es ein Leichtes +weitere Bewegungs-Befehle zu erlernen. + +Die meisten Emacs-Befehle akzeptieren ein numerisches Argument; +meistens dient dieses als Wiederholzähler. Dieses Argument übergibt +man mit C-u, gefolgt von einer Zahl, bevor man den jeweiligen Befehl +eingibt. Steht Dir eine META- (oder EDIT- oder ALT)-Taste zur +Verfügung, so kannst Du dieses Argument auch wie folgt eingeben: Tippe +die Ziffern während Du die META-Taste gedrückt hältst. Wir empfehlen +das Erlernen der C-u Methode, da sie überall funktioniert. + + +z.B., C-u 8 C-f bewegt den Textzeiger um acht Zeichen weiter. + +>> Versuche C-n und C-p mit numerischem Argument um den Textzeiger + mit nur einem Befehl nahe an diese Zeile heranzubringen. + +Die meisten Befehle verwenden ein Argument als Wiederholzähler. Einige +ausgenommene Befehle verwenden es anders. C-v und M-v sind unter den +Ausnahmen. Mit Argument rollen sie den Text um eben soviele Zeilen, +anstelle von Bildschirmseiten. z.B. C-u 4 C-v rollt den +Bildschirminhalt um 4 Zeilen. + +>> Versuche C-u 8 C-v nun aus. + +Dies sollte den Bildschirminhalt um acht Zeilen nach oben gerollt +haben. Wenn Du ihn wieder zurückrollen willst, kannst Du M-v ein +entsprechendes Argument geben. + +Verwendest Du das X Window System, so befindet sich wahrscheinlich ein +rechteckiger Balken, Scrollbar oder Rollbalken genannt, rechts neben +dem Emacs-Fenster. Du kannst den Text auch durch Manipulieren dieses +Rollbalkens mit der Maus rollen. + +>> Versuche die mittlere Maustaste in der hervorgehobenen Fläche + innerhalb des Rollbalkens zu drücken. Dies sollte den Text mehr + oder weniger rollen, je nachdem wie hoch oder tief der Mauszeiger + auf dem Rollbalken positioniert ist. + +>> Bewege den Mauszeiger im Rollbalken etwa drei Zeilen unter das + obere Ende und drücke die linke Maus-Taste einige Male. + +* TEXTZEIGER STEUERUNG MIT EINEM X-TERMINAL +------------------------------------------- + +An einem X-Terminal wirst Du es wahrscheinlich einfacher finden die +Tasten des Tastenfeldes zur Textzeiger Steuerung zu gebrauchen. Die +Links, Rechts, Auf und Ab Pfeil Tasten steuern in die erwartete +Richtung; sie funktionieren exakt wie C-b, C-f, C-p und C-n, sind aber +leichter zu tippen und zu merken. Du kannst auch C-Links und C-Rechts +verwenden um wortweise zu springen. C-Auf und C-Ab bewegen den +Textzeiger blockweise (z.B. Absätze, wenn Du Text bearbeitest). +Die Tasten HOME (oder BEGIN, POS1) und END (oder ENDE) bringen Dich +zum Anfang oder Ende einer Zeile und C-HOME bzw. C-END bringen Dich +zum Anfang oder Ende der Datei. Hat Deine Tastatur PgUp (oder BILD +AUF) und PgDn (oder BILD AB) kannst Du diese wie M-v und C-v zum +seitenweisen Rollen verwenden. + +All diese Befehle nehmen numerische Argumente wie weiter oben +beschrieben. Du kannst diese Argumente mittels einer Abkürzung +eingeben: Drücke einfache die CONTROL- oder META-Taste während Du die +Ziffern tippst. z.B. um 12 Worte nach rechts zu gehen, tippe C-1 C-2 +C-Rechts. Beachte, daß dies ganz einfach, ohne Loslassen der +CONTROL-Taste, getippt werden kann. + +* WENN EMACS HÄNGT +------------------ + +Wenn Emacs auf Deine Befehle nicht mehr reagiert, kannst Du den +Befehle risikolos mit C-g unterbrechen. Mit C-g kann man Befehle +abbrechen, die zu lange dauern. + +Du kannst mit C-g auch ein numerisches Argument oder einen teilweise +eingegebenen Befehl, den Du nicht mehr ausführen willst, verwerfen. + +>> Tippe C-u 100 für ein numerisches Argument von 100, dann tippe + C-g. Nun tippe C-f. Es wird nur eine Bewegung um ein Zeichen + ausgeführt, da Du das Argument mit C-g verworfen hast. + +Hast Du fälschlich ein getippt, kannst Du es mit C-g loswerden. + + +* GESPERRTE BEFEHLE +------------------- + +Einige Emacs-Befehle sind "gesperrt", damit sie von Anfängern nicht +versehentlich benutzt werden können. + +Wenn Du einen der gesperrten Befehle tippst, zeigt Emacs die +Befehlsdokumentation und fragt um Bestätigung, daß der Befehl +tatsächlich ausgeführt werden soll. + +Wenn Du den Befehl wirklich probieren willst, tippe Space als Antwort +auf die Frage. Normalerweise, wenn Du den gesperrten Befehl nicht +ausführen willst, beantwortest Du die Frage mit "n". + +>> Tippe `C-x n p' (ein gesperrter Befehl), dann beantworte die Frage + mit n. + + +* FENSTER +--------- + +Emacs unterstützt mehrere Fenster, jedes mit unterschiedlichem Text. +Beachte, daß sich der Begriff "Fenster" in Emacs nicht auf +verschiedene, überlappende Fenster im Fenstersystem bezieht, sondern +auf verschiedene Teil-Fenster innerhalb eines X Fensters. (Emacs +unterstützt auch mehrere X-Fenster, oder "Rahmen" ("frames") in +Emacs-Terminologie. Dies wird später beschrieben.) + + C-x 1 Ein Fenster (d.h., Beende alle anderen Fenster). + +Dies ist CONTROL-x gefolgt von der Ziffer 1. C-x 1 erweitert das +Fenster mit dem Textzeiger, so daß es das ganze Emacs-Fenster +einnimmt. Alle anderen Fenster werden beendet. + +>> Bewege den Textzeiger auf diese Zeile und tippe C-u 0 C-l. + +(Denke daran, daß C-l den Bildschirminhalt neu aufbaut. Das +numerische Argument bedeutet: "Baue den Bildschirminhalt neu auf und +bewege die aktuelle Zeile ebensoviele Zeilen vom oberen +Bildschirmrand." C-u 0 C-l bedeutet also "Bau den Bildschirm, mit der +aktuellen Zeile ganz oben, neu auf.") + +>> Tippe CONTROL-x 2 + Beachte wie das Fenster schrumpft, während ein neues mit Teilen + derselben Datei erscheint. + +>> Tippe C-x 1 und sehe das neue Fenster verschwinden. + + +* EINFÜGEN UND LÖSCHEN +---------------------- + +Willst Du Text einfügen, so tippe ihn. Sichtbare Zeichen, wie A, +7, *, etc., werden von Emacs als Text betrachtet und unmittelbar +eingefügt. Tippe (die Rücklauf-Taste) um ein Newline +einzufügen. + +Mit kannst Du das zuletzt getippte Zeichen löschen. + ist eine Taste die möglicherweise mit "Del" oder "Entf" +beschriftet ist. In einigen Fällen dient die Backspace (Rückschritt) +Taste als , jedoch nicht immer! + +Allgemeiner ausgedrückt löscht das Zeichen unmittelbar vor +dem Textzeiger. + +>> Tu dies nun -- tippe einige Buchstaben, lösche sie dann durch + mehrmaliges Tippen von . Kein Grund zur Sorge diese Datei + zu verändern. Es ist Deine persönliche Kopie der "Einführenden + Übungen für Emacs". + +Wird eine Zeile zu lang für eine Bildschirm-Zeile, so wird die Zeile +auf der nächsten Bildschirm-Zeile fortgesetzt. Ein umgekehrter +Schrägstrich ("\") am rechten Rand zeigt an, daß die Zeile fortgesetzt +wird. + +>> Füge Text ein bis Du den rechten Rand erreichst und tippe weiter. + Du wirst bemerken, wie die Fortsetzungszeile erscheint. + +>> Verwende s bis die Zeile wieder auf eine Bildschirmzeile + paßt. Die Fortsetzungszeile verschwindet. + +Ein Newline-Zeichen kann wie jedes andere gelöscht werden. Das +Löschen des Newline-Zeichens fügt die umgebenden Zeilen zusammen. +Ist die entstehende Zeile zu lang für den Bildschirm, erscheint +wieder eine Fortsetzungszeile. + +>> Geh an den Anfang einer Zeile und tippe . Dies fügt die + Zeile an die vorhergehende an. + +>> Tippe um den Newline-Zeichen wieder einzufügen. + +Denke daran, daß die meisten Emacs-Befehle mittels eines Arguments +wiederholt werden können; Ein Textzeichen wird mittels Argument +mehrfach eingefügt. + +>> Versuch's einfach -- Tippe C-u 8 * um ******** einzufügen. + +Du hast jetzt die einfachsten Befehle zum Einfügen und Korrigieren von +Text gelernt. Du kannst auch ganze Worte oder Zeilen löschen. Hier +ist eine Zusammenfassung der Lösch-Befehle: + + Lösche das Zeichen vor dem Textzeiger + C-d Lösche das Zeichen nach dem Textzeiger + + M- Lösche das Wort vor dem Textzeiger + M-d Lösche das Wort nach dem Textzeiger + + C-k Lösche vom Textzeiger bis ans Zeilenende + M-k Lösche vom Textzeiger bis ans Satzende + +Beachte daß und C-d gegenüber M- und M-d die +Verwandtschaft von C-f und M-f fortsetzen ( ist zwar keine +CONTROL-Taste, aber das kümmert uns nicht). C-k und M-k verhalten +sich zueinander wie C-e und M-e zu Zeilen und Sätzen. + +Wenn Du mehr als ein Zeichen auf einmal löschst, speichert sie +Emacs, damit Du sie wieder abrufen kannst. Den gelöschten Text +zurückzuholen nennt man "yanking". Du kannst den gelöschten Text an +der selben oder an einer anderen Textstelle zurückholen. Der Text +kann mehrere Male zurückgeholt geholt werden um Mehrfachkopien +anzulegen. Der Zurückhol-Befehl ist C-y. + +Beachte daß der Unterschied zwischen Entfernen ("Killing") und Löschen +("Deleting") darin besteht, daß gelöschte Teile zurückgeholt werden +können, während dies für entfernte Teile nicht möglich ist. Allgemein +speichern Befehle die viel Text löschen diesen auch, während Befehle, +die nur einzelne Zeichen oder Leerzeilen entfernen, diese nicht +speichern. + +>> Gehe zum Beginn einer nicht leeren Zeile. + Dann lösche den gesamten Text der Zeile mit C-k. +>> Tippe C-k ein zweites Mal. Du wirst sehen, daß dies das folgende + Newline-Zeichen löscht. + +Beachte, daß ein einzelnes C-k den Inhalt einer Zeile löscht, ein +zweites die Zeile selbst, so daß sich nachfolgende Zeilen nach oben +bewegen. Ein numerisches Argument wird von C-k besonders behandelt: +Es löscht ebensoviele Zeilen mitsamt Inhalt. Dies ist keine einfache +Wiederholung. C-u 2 C-k löscht zwei Zeilen und deren Inhalt; zwei +aufeinanderfolgende C-k würden dies nicht tun. + +Um den zuletzt gelöschten Text beim Textzeiger zurückzuholen, tippe +C-y. + +>> Versuch's; Tippe C-y um den Text zurückzuholen. + +Denke so über C-y als ob Du etwas zurückholst, das man Dir genommen +hat. Beachte, daß bei aufeinanderfolgenden C-k's der gelöschte Text in +einem Stück gespeichert wird, so daß ein C-y alle Zeilen zurück bringt. + +>> Tu's jetzt, tippe C-k mehrere Male. + +Nun das Zurückholen des gelöschten Texts: + +>> Tippe C-y. Dann gehe einige Zeilen nach unten und tippe wieder C-y. + Jetzt siehst Du, wie man Text kopiert. + +Was machst Du, wenn Du Text zum Zurückholen hast, dann aber etwas +anderes löscht? C-y würde das zuletzt Gelöschte zurückbringen. Aber +der zuvor gelöschte Text ist nicht verloren. Du kannst Ihn mit M-y +zurückholen. Nachdem Du C-y getippt hast, kannst Du mit M-y den +zurückgeholten Text durch früher gelöschten Text ersetzten. Tippst Du +M-y wieder und wieder, holst Du früher und früher Gelöschtes zurück. +Hast Du den gewünschten Text erreicht, brauchst Du nichts weiter zu +tun um diesen zu behalten. Fahre mit mit Deiner Arbeit fort und laß +den zurückgeholten Text wo er ist. + +Verwendest Du M-y oft genug, kehrst Du an den Anfang zurück (der +letzte Löschvorgang). + +>> Lösche eine Zeile, bewege Dich im Text, lösche eine weitere Zeile. + Dann tippe C-y um die zuletzt gelöschte Zeile zurückzuholen. + Darauf verwende M-y und die zuerst gelöschte Zeile ersetzt den + zuvor zurückgeholten Text. Verwende weitere M-y's und sieh was + passiert. Fahre fort bis die zweite Zeile wiederkehrt und versuche + noch einige M-y's. + Wenn Du willst, kannst Du M-y positive und negative Argumente + geben. + + +* RÜCKGÄNGIG MACHEN +------------------- + +Veränderst Du Text und entscheidest Du dann, daß dies ein Fehler war, +kannst Du die Änderungen mit C-x u rückgängig machen. + +Üblicherweise macht C-x u die Änderungen des letzten Befehls +rückgängig; wenn Du C-x u mehrmals wiederholst, wird jeweils ein +weiterer Befehl rückgängig gemacht. + +Aber es gibt zwei Ausnahmen: Befehle, die keinen Text verändern, +zählen nicht (dies schließt Befehle zum Bewegen und Rollen des +Textzeigers ein) und selbsteinfügende Befehle werden üblicherweise in +Zwanziger-Gruppen behandelt. (Dies dient dazu, die Anzahl der C-x u's +zu reduzieren die Du tippen mußt um eingetippten Text rückgängig zu +machen.) + +>> Lösche diese Zeile mit C-k, dann tippe C-x u und sie sollte + wiedererscheinen. + +C-_ ist ein alternativer rückgängig (undo) Befehl; er funktioniert wie +C-x u, ist aber einfacher zu Wiederholen. Der Nachteil ist, daß C-_ +auf einigen Tastaturen nicht direkt getippt werden kann. Deshalb gibt +es C-x u. Auf einigen Tastaturen kann man C-_ als C-\ tippen. + +Ein numerisches Argument für C-_ oder C-x u dient als Wiederholwert. + + +* DATEIEN +--------- + +Um an einem Text bleibende Änderungen vorzunehmen, mußt Du ihn in +einer Datei speichern. Sonst gehen Deine Änderungen mit dem Beenden +von Emacs verloren. Du legst Deine Arbeit in einer Datei ab, indem Du +eine Datei "findest". (Man nennt dies auch das "Besuchen" +("visiting") einer Datei.) + +Das Finden einer Datei bedeutet, daß Du ihren Inhalt mit Emacs +betrachtest. In vielfacher Hinsicht ist es, als würdest Du die Datei +selbst bearbeiten. Jedoch sind Deine Änderungen nicht permanent bis +Du die Datei sicherst. Damit kannst Du verhindern halb-fertige +Dateien auf dem System abzulegen, wenn Du dies nicht willst. Sogar +beim Abspeichern hinterläßt Emacs die Originaldatei unter verändertem +Namen falls Du später entscheiden solltest, daß die Änderungen ein +Fehler waren. + +Nahe dem unteren Ende des Bildschirms siehst Du eine Zeile die mit +Bindestrichen beginnt und endet und den Text "Emacs: TUTORIAL" +enthält. Dieser Teil des Bildschirms zeigt immer den Namen der +besuchten Datei. Zur Zeit besuchst Du eine Datei namens "TUTORIAL", +welche Deine persönliche Kopie des Emacs Tutorials ist. Was immer für +eine Datei Du findest, ihr Name wird immer an dieser Stelle +erscheinen. + +Die Befehle zum Finden und Sichern von Dateien sind anders als die +bisher erlernten, da sie jeweils aus zwei Zeichen bestehen. Beide +beginnen mit dem Zeichen CONTROL-x. Es gibt eine ganze Reihe von +Befehlen, die mit CONTROL-x beginnen; viele haben mit Dateien, Buffern +und verwandten Dingen zu tun. Diese Befehle sind zwei, drei oder vier +Zeichen lang. + +Bei Befehlen zum Finden einer Datei mußt Du außerdem den Dateinamen +angeben. Wir sagen: "Der Befehl liest ein Argument vom Terminal." (In +diesem Fall ist das Argument der Dateiname). Nachdem Du folgenden +Befehl tippst + + C-x C-f Finde eine Datei + +bittet Dich Emacs, einen Dateinamen einzugeben. Der Dateiname den Du +tippst erscheint am unteren Ende des Emacs-Fensters. Diese unterste +Zeile wird Minibuffer genannt, wenn sie für diese Art Eingabe +verwendet wird. Du kannst die üblichen Emacs-Befehle zum +Bearbeiten des Dateinamens verwenden. + +Während Du den Dateinamen eingibst (oder bei jeder anderen +Minibuffer-Eingabe) kannst Du den Befehl mit C-g abbrechen. + +>> Tippe C-x C-f, dann tippe C-g. Dies beendet den Minibuffer und + bricht den C-x C-f Befehl ab, der den Minibuffer benutzte. Du wirst + also keine Datei finden. + +Wenn Du mit dem Bearbeiten des Dateinamens fertig bist, tippe +um die Eingabe zu beenden. Der C-x C-f Befehl beginnt seine Arbeit +und findet die Datei Deiner Wahl. Der Minibuffer verschwindet, wenn +der C-x C-f Befehl beendet ist. + +Nach kurzer Zeit erscheint der Inhalt der Datei auf dem Bildschirm und +Du kannst diesen bearbeiten. Wenn Du Deine Änderungen sichern willst, +tippe den Befehl + + C-x C-s Sichere die Datei + +Das kopiert den Text von Emacs in die Datei. Geschieht dies das erste +Mal so benennt Emacs die Originaldatei um, so daß sie nicht verloren +geht. Der neue Name entsteht durch Anhängen von "~" am Ende des +Originalnamens. + +Ist der Sicherungsvorgang beendet, gibt Emacs den Namen der Datei an. +Du solltest recht oft sichern, damit Du nicht viel Arbeit verlierst, +sollte das System abstürzen. + +>> Tippe C-x C-s um Deine Kopie des tutorials zu sichern. + Dies sollte "Wrote ...TUTORIAL" am Fuß des Bildschirms ausgeben. + +ACHTUNG: Auf manchen Systemen wird C-x C-s den Bildschirm anhalten und +Du wirst keine weitere Ausgabe von Emacs sehen. Dies bedeutet, daß +auf Deinem System eine Betriebssystemeigenschaft ("feature") namens +Flußsteuerung ("flow control") das C-s abfängt und nicht an Emacs +weitergibt. Tippe C-q, um den Effekt aufzuheben, so daß der Bildschirm +wieder reagiert. Schau dann unter "Spontaneous Entry to Incremental +Search" im Emacs Manual nach, um Hilfe im Umgang mit diesem "Vorzug" +("feature") zu bekommen. + +Du kannst eine existierende Datei finden, um sie zu betrachten. Du +kannst aber auch eine Datei "finden", die es noch nicht gibt. So +erstellt man eine neue Datei mit Emacs: finde die Datei, welche +anfänglich leer ist, dann tippe den Text für die Datei ein. Wenn Du +danach sicherst, wird Emacs die Datei tatsächlich anlegen und Deinen +eingetippten Text darin ablegen. Von da an arbeitest Du an einer +existierenden Datei. + + +* BUFFER +-------- + +Findest Du eine weitere Datei mit C-x C-f, bleibt die erste in Emacs +erhalten. Du kannst zu dieser mit C-x C-f zurückschalten. Auf diese +Art kannst Du eine erhebliche Anzahl von Dateien in Emacs verfügbar +haben. + +>> Erstelle eine Datei namens "foo" durch Eintippen von C-x C-f foo + . + Dann füge etwas Text ein, bearbeite ihn und sichere die Datei "foo" + mit C-x C-s. + Schließlich tippe C-x C-f TUTORIAL um zum Tutorial zurück + zu gelangen. + +Emacs hält den Text jeder Datei in einem Objekt namens "buffer". Das +Finden einer Datei legt in Emacs einen neuen Buffer an. Um eine Liste +aller Buffer in Deiner Emacs-Sitzung zu erhalten tippst Du + + C-x C-b Liste alle Buffer + +>> Probiere C-x C-b jetzt aus. + +Beachte, daß jeder Buffer einen Namen hat. Wenn der Buffer einer Datei +zugeordnet ist, wird auch der Dateiname angezeigt. Einige Buffer haben +keine Entsprechung im Dateisystem. So hat z.B. der Buffer namens +"*Buffer List*" keine zugeordnete Datei. Dieser Buffer enthält die +Liste der Buffer, die mit C-x C-b erstellt wurde. JEDER Text in Emacs +ist Teil irgendeines Buffers. + +>> Tippe C-x 1 um die Bufferliste loszuwerden. + +Wenn Du Änderungen in einer Datei vornimmst, dann eine andere findest, +so wird der Inhalt der ersten nicht gesichert. Die Änderungen bleiben +innerhalb von Emacs im zugeordneten Buffer erhalten. Das Bearbeiten +einer weiteren Datei hat keinen Einfluß auf den Buffer der ersten. +Dies ist sehr nützlich, man braucht aber auch eine angenehme +Möglichkeit, den Buffer der ersten Datei zu sichern. Es wäre lästig, +müßte man mit C-x C-f zur ersten Datei zurückgehen, um diese dann mit +C-x C-s zu sichern. Darum haben wir + + C-x s Sichere mehrere Buffer + +C-x s befragt Dich zu jedem Buffer, der ungesicherte Änderungen +enthält. Für jeden einzelnen wirst Du gefragt ob Du Ihn sichern +willst. + +>> Füge eine Text-Zeile ein, dann tippe C-x s. + Du wirst gefragt, ob Du den Buffer namens TUTORIAL speichern + willst. + +* VERWENDUNG DES MENÜS +---------------------- + +An einem X-Terminal wirst Du eine Menüleiste am oberen Ende des Emacs +Fensters bemerken. Mit der Menüleiste kannst Du die allgemeinsten +Emacs-Befehle, wie "Finde Datei" ("find file"), erreichen. Du wirst +dies anfänglich einfacher finden, da Du dir die notwendigen +Tastenkombinationen der Befehle nicht merken mußt. Bist Du einmal +mit Emacs vertraut, wird es ein Leichtes sein die Kommandos zu +benutzen, da jeder Menüeintrag, der einer Tastenkombination +entspricht, diese auch anzeigt. + +Beachte, daß es viele Menüeinträge ohne entsprechende Tastensequenz +gibt. So listet z.B. das Buffers-Menü die verfügbaren Buffer in +letzt-benutzter Reihenfolge. Du kannst zu jedem Buffer über den +Eintrag im Buffers-Menü gelangen. + +* VERWENDUNG DER MAUS +--------------------- + +Unter X Windows hat Emacs volle Maus-Unterstützung. Der Textzeiger +kann durch Drücken der linken Maustaste an der gewünschten Stelle des +Mauszeigers dorthin gesetzt werden. Text kann durch Ziehen des +Mauszeigers bei gedrückter linker Maustaste selektiert werden. +(Oder man klickt die linke Maustaste an der einen Stelle im Text und +verwendet SHIFT-Klick an der anderen um den dazwischenliegenden Text +zu selektieren.) + +Um selektierten Text zu löschen kannst Du C-w benutzen, oder den +Menüeintrag "Cut" im Edit-Menü verwenden. Beachte, daß diese +Methoden nicht gleichbedeutend sind: C-w sichert den Text nur +innerhalb von Emacs (ähnlich wie oben unter C-k beschrieben), während +Cut den Text auch im X Clipboard ablegt, von wo ihn andere Programme +abholen können. + +Verwende "Paste" im Edit-Menü um Text vom X Clipboard zurückzuholen. + +Die mittlere Maustaste wird häufig verwendet um sichtbare Objekte auf +dem Bildschirm auszuwählen. Wenn Du z.B. "Info" (die Online Emacs +Dokumentation) mit C-h i oder über das Help-Menü aufrufst, kannst Du +einer hervorgehobenen Verknüpfung durch Klicken der mittleren +Maustaste folgen. Ganz ähnlich, wenn Du einen Dateinamen eingibst +(z.B. wenn von "Find File" gefragt) und TAB tippst um die möglichen +Vervollständigungen zu erhalten, kannst Du mit der mittleren Maus die +gewünschte Vervollständigung wählen. + +Die rechte Maustaste zeigt ein Popup-Menü. Der Inhalt des Menüs +variiert abhängig vom gewählten Modus und zeigt für gewöhnlich einige +häufig benutzte Befehle, die so einfacher benutzt werden können. + +>> Drücke jetzt die rechte Maustaste. + +Du mußt die Taste gedrückt halten, damit das Menü nicht gleich wieder +verschwindet. + +* ERWEITERUNG DES BEFEHLSSATZES +------------------------------- + +Es gibt viel mehr Emacs-Befehle als man auf allen CONTROL- und +META-Zeichen unterbringen könnte. Emacs löst dieses Problem mit dem X +(eXtend) Befehl. Davon gibt es zwei Ausführungen: + + C-x Zeichenerweiterung eXtend. Gefolgt von einer + Tastaturkombination. + M-x Namenserweiterung eXtend. Gefolgt von einer + ausgeschriebenen Befehlsbezeichnung. + +Diese Befehle sind zwar im Allgemeinen nützlich, werden aber seltener +verwendet als die bereits erlernten Befehle. Zwei von ihnen hast Du +bereits kennengelernt: Die Befehle C-x C-f zum Finden und C-x C-s +zum Sichern von Dateien. Ein anderes Beispiel ist der Befehl zum Beenden +einer Emacs-Sitzung -- dieser Befehl ist C-x C-c. (Habe keine Angst, +ungesicherte Änderungen zu verlieren; C-x C-c bietet die Möglichkeit zum +Sichern einer jeden geänderten Datei bevor Emacs beendet wird.) + +Mit C-z kann man Emacs vorübergehend verlassen -- so daß Du später zur +gleichen Sitzung zurückkehren kannst. + +Auf Systemen, die dies unterstützen sendet C-z Emacs "in den +Hintergrund"; man kehrt zur Shell zurück, ohne daß der Emacs-Prozeß +beendet wird. In den gebräuchlichsten Shells kann man zu Emacs mit +`fg' oder `%emacs' zurückkehren. + +Auf Systemen, die dieses Aussetzen von Emacs nicht unterstützen, +startet C-z eine s.g. Sub-Shell von der aus Du Programme starten und +danach zu Emacs zurückkehren kannst; Emacs wird in diesem Fall nicht +wirklich verlassen. Der Shell-Befehl `exit' ist in diesem Fall der +üblichste um zu Emacs zurückzukehren. + +C-x C-c verwendet man unmittelbar bevor man das System verlassen will. +Es ist auch die richtige Methode um einen Emacs zu verlassen der für +E-mail-Programme, oder andere Erweiterungen, die das Aussetzen von +Emacs nicht korrekt handhaben können, benutzt wird. Normalerweise +ist es besser Emacs mit C-z auszusetzen statt ihn zu beenden, wenn +man das System nicht verlassen will,. + +Es gibt viele C-x-Befehle. Hier ist eine Liste der bereits erlernten: + + C-x C-f Finde Datei. + C-x C-s Sichere Datei. + C-x C-b Liste alle Buffer. + C-x C-c Beende Emacs. + C-x u Rückgängig machen (Undo). + +Namenserweiterte Befehle (eXtended commands) sind solche, die weniger +häufig oder nur in einem bestimmten Modus verwendet werden. Ein +Beispiel ist der Befehl replace-string, der einen Text durch einen +anderen ersetzt. Wenn Du M-x tippst, zeigt dies Emacs am unteren Ende +des Emacs-Fensters mit M-x an und Du solltest den Namen des Befehls +eintippen; in diesem Fall "replace-string". Tippe einfach +"repl s" und Emacs wird den Namen vervollständigen. Beende den +Befehlsnamen mit . + +Der replace-string Befehl braucht zwei Argumente -- den zu ersetzenden +Text und den Ersatz-Text. Jedes Argument muß mit beendet +werden. + +>> Gehe zur Leerzeile zwei Zeilen unter dieser. + Dann tippe M-x repl sveraendertgeaendert. + + Beachte wie diese Zeile sich veraendert hat: Du hast das Wort + v-e-r-a-e-n-d-e-r-t mit "geaendert" ersetzt wo immer es nach der + anfänglichen Textzeiger Position auftrat. + + +* AUTOMATISCHE SICHERUNG +------------------------ + +Wenn Du Änderungen in einer Datei vornimmst, diese aber noch nicht +gesichert hast, so können diese bei einem Computerabsturz verloren +gehen. Um Dich davor zu schützen, schreibt Emacs regelmäßig eine +Autosave-Datei für jede Datei, die Du bearbeitest. Autosave-Dateien +beginnen und enden mit "#"; wenn Deine Datei z.B. "hello.c" heißt, so +heißt die auto-save Datei "#hello.c#". Sicherst Du die Datei, so +löscht Emacs die entsprechende auto-save Datei. + +Nach einem Computerabsturz kannst Du die automatisch +gesicherten Änderungen nach dem normalen Finden der Datei (Deiner +Datei, nicht der Autosave-Datei) durch Eintippen von M-x +recover-file zurückholen. Wenn Du nach der Bestätigung +gefragt wirst, tippst Du yes um die Änderungen in der +Autosave-Datei wiederherzustellen. + + +* ECHO BEREICH +-------------- + +Wenn Emacs bemerkt, daß Du Befehle langsam tippst, werden Dir diese am +Fuß des Emacs-Fensters in der s.g. "echo area" angezeigt. Die echo +area nimmt die unterste Zeile im Emacs-Fenster ein. + + +* MODUSZEILE +------------ + +Die Zeile über der echo area wird "mode line" genannt. Die Moduszeile +zeigt etwa folgendes: + +--**-XEmacs: TUTORIAL (Fundamental)--L670--58%---------------- + +Diese Zeile gibt nützliche Information über den Zustand von Emacs und +dem Text, den Du bearbeitest. + +Du kennst bereits die Bedeutung des Dateinamens -- es ist die Datei, +die Du gefunden hast. -NN%-- zeigt Deine Position im Text; dies +bedeutet daß NN Prozent des Texts oberhalb des sichtbaren Bereiches +liegen. Bist Du am Beginn, so erscheint --Top-- anstelle von --00%--. +Bist Du am Ende des Texts, so erscheint --Bot--. Ist der gesamte Text +sichtbar, so erscheint --All--. + +Die Sterne nahe dem Beginn der Moduszeile bedeuten, daß der Text +verändert wurde. Unmittelbar nach dem Besuchen oder Sichern einer +Datei, zeigt dieser Bereich keine Sterne, sondern Bindestriche. + +Der Teil der Moduszeile innerhalb der Klammern gibt Auskunft über die +Bearbeitungs-Modi, die Du derzeit verwendest. Der Ausgangsmodus ist +Fundamental -- der, den Du jetzt gerade benutzt. Er ist ein Beispiel +für einen Hauptmodus ("major mode"). + +Emacs besitzt viele verschiedene Hauptmodi. Einige von ihnen sind zum +Bearbeiten von verschiedenen Computersprachen und/oder Textformaten, +wie z.B. Lisp-Modus, Text-Modus, etc., gedacht. Es ist immer nur ein +Hauptmodus aktiv und sein Name kann dort gefunden werden, wo jetzt +"Fundamental" steht. + +Jeder Hauptmodus ändert das Verhalten einiger Befehle. So gibt es +z.B. Befehle zum Erstellen von Kommentaren in Programmen und da diese +in jeder Programmiersprache unterschiedlich aussehen, muß jeder +Hauptmodus diese Kommentare entsprechend vorbereiten. Jeder +Hauptmodus trägt den Namen eines entsprechenden Erweiterungsbefehls, so +kann man ihn wählen. So ist z.B. M-x fundamental-mode der Befehl, um +in den Fundamental-Modus zu schalten. + +Wenn Du deutschen Text bearbeitest, wie in diesem Fall, solltest Du +wahrscheinlich den Text-Modus verwenden. + +>> Tippe M-x text-mode. + +Keine Sorge, keiner der bis jetzt erlernten Befehle ändert Emacs +grundlegend. Du kannst aber beobachten, daß M-f und M-b Gänsefüßchen +jetzt als Teil von Worten betrachten. Zuvor, im Fundamental-Modus, +haben M-f und M-b diese als Wort-Separatoren betrachtet. + +Hauptmodi machen im Allgemeinen kleine Änderungen wie diese: die +meisten Befehle erfüllen den selben Zweck, aber sie funktionieren +etwas anders. + +Um Dokumentation über den aktuellen Hauptmodus zu bekommen, kannst Du +immer C-h m verwenden. + +>> Verwende C-u C-v ein- oder mehrmals um diese Zeile ans obere Ende + des Emacs-Fensters zu bekommen. +>> Tippe C-h m um den Unterschied zwischen Text- und Fundamental-Modus + zu sehen. +>> Tippe C-x 1 um die Dokumentation wieder verschwinden zu lassen. + +Hauptmodi heißen so, weil es auch Untermodi gibt. Untermodi sind keine +Alternativen zu Hauptmodi, sondern bewirken kleine Veränderungen +derselben. Jeder Untermodus kann für sich allein, unabhängig von +allen Haupt- und Untermodi, ein und ausgeschaltet werden. Du kannst +also jederzeit keinen, einen, oder beliebig viele Untermodi verwenden. + +Ein sehr nützlicher Untermodus, speziell für deutschen Text, ist der +Automatische-Zeilenumbruch-Modus (auto fill). Ist dieser Modus aktiv, +bricht Emacs überlange Zeilen automatisch zwischen zwei Worten um. + +Du kannst den Modus mit M-x auto-fill-mode einschalten. Ist +der Modus aktiv, kannst Du ihn mit M-x auto-fill-mode wieder +ausschalten. Wir sagen der Befehl "toggelt" den Modus. + +>> Tippe jetzt M-x auto-fill-mode. Dann füge "asdf " + wiederholt ein, bis die Zeile, zu lang geworden, umgebrochen + wird. Du mußt die Leerzeichen einfügen, weil Auto Fill Zeilen nur an + diesen Zeichen umbricht. + +Die Umbruchspalte steht üblicherweise bei 70 Zeichen, aber Du kannst +dies mit dem C-x f Befehl ändern. Die gewünschte Umbruchspalte wird +als numerisches Argument übergeben. + +>> Tippe C-x f mit einem Argument von 20. (C-u 2 0 C-x f). + Danach tippe etwas Text, um zu sehen wie Emacs die Zeilen jetzt bis + Spalte 20 füllt. Dann setze den Zeilenumbruch zurück auf 70. + +Machst Du Änderungen mitten im Absatz, so wird der automatische Umbruch +diesen nicht für Dich auffüllen. Um den Absatz aufzufüllen, tippe M-q +(META-q) während der Textzeiger in diesem Absatz steht. + +>> Bewege den Textzeiger in den vorherigen Absatz und tippe M-q. + + +* SUCHEN +-------- + +Emacs kann nach Zeichenketten ("Strings", dies sind Gruppen von +zusammenhängenden Buchstaben oder Worten) entweder vorwärts oder +rückwärts durch den Text suchen. Suchen nach einem String ist ein +Befehl, der den Textzeiger bewegt; er bewegt den Textzeiger zur +nächsten Stelle an der ein bestimmter String vorkommt. + +Der Emacs Suchbefehl unterscheidet sich von denen der meisten anderen +Editoren, da er "inkrementell" ist. Dies bedeutet, daß das Suchen +während der Eingabe des Such-Strings passiert. + +Der Befehl um eine Suche auszulösen ist C-s für vorwärtiges und C-r +für rückwärtiges Suchen. ABER WARTE! Versuche die Befehle noch nicht. + +Wenn Du C-s tippt, wirst Du den String "I-search" in der echo area +bemerken. Dies bedeutet, daß Emacs im inkrementellen Suchmodus auf +Deine Eingabe wartet. bricht die Suche ab. + +>> Nun tippe C-s um die Suche einzuleiten. LANGSAM, Buchstabe für + Buchstabe, tippe das Wort 'Textzeiger', mit Pausen dazwischen, + damit Du beobachten kannst, was mit dem Textzeiger basiert. + Du hast jetzt einmal nach "Textzeiger" gesucht. +>> Tippe erneut C-s, um nach dem nächsten Vorkommen von "Textzeiger" + zu suchen. +>> Nun tippe viermal und schau wie sich der Textzeiger + bewegt. +>> Tippe zum Abbrechen der Suche. + +Hast Du gesehen was passiert? Emacs, in der inkrementellen Suche, +versucht zu dem String zu springen, den Du bisher getippt hast. Um +zum nächsten Auftreten von "Textzeiger" zu gelangen, tippst Du einfach +wieder C-s. Gibt es kein weiteres Vorkommen, so piepst Emacs und +zeigt die Suche als fehlgeschlagen an. C-g bricht die Suche auch ab. + +ACHTUNG: Auf manchen Systemen wird C-s den Bildschirm anhalten und Du +wirst keine weitere Ausgabe von Emacs sehen. Dies bedeutet, daß auf +Deinem System eine Betriebssystemeigenschaft ("feature") namens +Flußsteuerung ("flow control") das C-s abfängt und nicht an Emacs +weitergibt. Tippe C-q, um den Effekt aufzuheben, so daß der Bildschirm +wieder reagiert. Schau dann unter "Spontaneous Entry to Incremental +Search" im Emacs Manual nach, um Hilfe im Umgang mit diesem "Vorzug" +("feature") zu bekommen. + +Wenn Du in der Mitte einer inkrementellen Suche tippst, wirst +Du bemerken, wie der letzte Such-Buchstabe entfernt wird und die Suche +an die letzte Stelle der Suche zurück springt. Nehmen wir z.B. an, Du +hast "T" getippt, um nach dem ersten Auftreten von "T" zu suchen. Wenn +Du jetzt "e" tippst, springt der Textzeiger zum ersten Auftreten von +"Te". Tippe nun . Dies entfernt das "e" von Such-String und +der Textzeiger springt zurück zum ersten Vorkommen von "T". + +Wenn Du mitten in einer Suche ein CONTROL- oder META-Zeichen tippst +(mit wenigen Ausnahmen -- Buchstaben mit Sonderbedeutung bei der +Suche, so wie C-s und C-r), wird die Suche abgebrochen. + +C-s startet eine Suche NACH der aktuellen Textzeiger Position. Willst +Du etwas früher im Text finden, tippe stattdessen C-r. All das was +wir über C-s gesagt haben gilt auch für C-r, nur daß die Suchrichtung +umgedreht wird. + + +* MEHRERE FENSTER +----------------- + +Einer der netten Vorzüge von Emacs ist es, daß Du mehr als jeweils ein +Fenster am Bildschirm darstellen kannst. + +>> Bewege den Textzeiger auf diese Zeile und tippe C-u 0 C-l. + +>> Nun tippe C-x 2, was das Emacs-Fenster zweiteilen wird. + Beide Fenster zeigen dieses Tutorial. Der Textzeiger bleibt im + oberen Fenster. + +>> Tippe C-M-v um beide Fenster zu rollen. + (Hast Du keine echte META-Taste, tippe Esc C-v.) + +>> Tippe C-x o ("o" für "other" oder anderes) um den Textzeiger ins + andere (untere) Fenster zu bewegen. +>> Verwende C-v und M-v im unteren Fenster um dieses zu rollen. + Lies diese Anweisungen im oberen Fenster weiter. + +>> Tippe C-x o um wieder zurück ins obere Fenster zu gelangen. + Der Textzeiger im oberen Fenster ist noch immer wo er vorher war. + +Du kannst weiterhin mit C-x o zwischen den Fenstern umschalten. Jedes +Fenster hat seine eigene Textzeiger-Position, aber nur ein Fenster +zeigt diese auch an. Alle üblichen Bearbeitungs-Befehle beziehen sich +auf das Fenster mit dem Textzeiger. Wir nennen es das "selektierte +Fenster". + +Der Befehl C-M-v ist sehr hilfreich wenn Du in einem Fenster Text +bearbeitest und das andere als Referenz verwendest. Du kannst den +Textzeiger immer im oberen Fenster lassen, und Dich mit C-M-v durch +das andere Fenster bewegen. + +C-M-v ist ein Beispiel für einen CONTROL-META-Zeichen. Wenn Du eine +echte META-Taste hast, kannst Du sowohl CTRL als auch META gedrückt +halten, während Du v tippst. Es kommt nicht darauf an ob CTRL oder +META zuerst gedrückt wird, weil beide dazu dienen um den gedrückten +Buchstaben zu verändern. + +Hast Du keine echte META-Taste und Du verwendest stattdessen ESC, ist +die Reihenfolge nicht egal: zuerst tippst Du ESC, gefolgt von CTRL-v; +CTRL-ESC v wird nicht funktionieren. Dies ist so weil ESC ein +eigenständiges Zeichen ist und keine Modifikations-Taste. + +>> Tippe C-x 1 (im oberen Fenster) um das untere Fenster loszuwerden. + +(Hättest Du C-x 1 im unteren Fenster getippt, wäre das obere Fenster +verschwunden. Merke Dir den Befehl mit "Behalte nur ein Fenster -- +das aktuelle Fenster.") + +Du mußt nicht denselben Buffer in beiden Fenstern anzeigen. Wenn Du +C-x C-f zum Finden einer Datei in einem Fenster verwendest, verändert +sich das andere Fenster nicht. Du kannst in jedem Fenster unabhängig +eine Datei finden. + +Hier ist eine andere Möglichkeit zwei Fenster zum Anzeigen +verschiedener Dinge zu nutzen: + +>> Tippe C-x 4 C-f gefolgt vom Namen einer Deiner Dateien. + Beende mit . Schau wie die angegebene Datei im unteren + Fenster erscheint. Auch der Textzeiger folgt dorthin. + +>> Tippe C-x o um ins obere Fenster zurückzukehren und beende das + untere Fenster mit C-x 1. + + +* REKURSIVE BEARBEITUNGSEBENEN +------------------------------ + +Manchmal wirst Du in sogenannte rekursive Bearbeitungsebenen +gelangen. Dies wird durch eckige Klammern in der Moduszeile angezeigt, +welche den Namen des Hauptmodus umgeben. Du könntest +z.B. [(Fundamental)] anstelle von (Fundamental) sehen. + +Um aus der rekursiven Bearbeitungsebene zu gelangen, tippst Du ESC +ESC ESC. Dies ist ein allgemeiner Ausstiegs- oder "get out"-Befehl. +Du kannst ihn auch verwenden, um unnötige Fenster loszuwerden und um +aus dem Minibuffer zu gelangen. + +>> Tippe M-x um in den Minibuffer zu gelangen; dann ESC ESC ESC um + auszusteigen. + +Du kannst nicht mit C-g aus einer rekursiven Bearbeitungs-Ebene +gelangen. Dies deshalb, weil C-g zum Beenden von Befehlen und +Argumenten INNERHALB von rekursiven Bearbeitungs-Ebenen dient. + + +* WEITERFÜHRENDE HILFE +---------------------- + +In diesen einführenden Übungen haben wir versucht, gerade genug +Information zu liefern, damit Du beginnen kannst mit Emacs zu +arbeiten. Emacs ist so umfangreich, daß es unmöglich wäre, alles +hier zu erklären. Allerdings solltest Du versuchen, mehr über Emacs zu +lernen, da er so viele nützliche Vorzüge besitzt. Emacs bietet +Befehle zum Lesen der Emacs-Befehlsdokumentation. Diese Hilfe- oder +"help" Befehle beginnen alle mit dem Buchstaben CONTROL-h, den wir auch +das "Hilfe-Zeichen" nennen. + +Um die Hilfeeinrichtungen zu verwenden, tippe C-h, gefolgt von einem +Buchstaben der angibt, welche Art von Hilfe Du willst. Wenn Du Dich +WIRKLICH "verirrst", tippe C-h ? und Emacs wird Dir mitteilen, welche +Art von Hilfe zur Verfügung steht. Hast Du C-h getippt, willst aber +keine Hilfe mehr, dann tippe einfach C-g zum Abbrechen des Befehls. + +(Einige Administratoren verändern die Bedeutung von C-h. Sie sollten +dies wirklich nicht tun, beschwere Dich also beim System +Administrator. In der Zwischenzeit, wenn C-h keine Mitteilung +bezüglich Hilfe am Fuß des Emacs-Fensters anzeigt, versuche M-x help +RET zu tippen.) + +Die einfachste Hilfe-Einrichtung ist C-h c. Tippe C-h, ein c und +einen Befehls-Buchstaben oder eine Sequenz davon und Emacs gibt Dir +eine ganz kurze Beschreibung des Befehls. + +>> Tippe C-h c C-p. + Die Mitteilung sollte etwa wie folgt aussehen + + C-p runs the command previous-line + +Dies teils Dir den "Namen der Funktion" mit. Funktions-Namen werden +hauptsächlich zum Spezialisieren und Erweitern von Emacs verwendet. +Aber da die Funktions-Namen etwas darüber aussagen was der Befehl tut, +können Sie auch als sehr kurze Dokumentation dienen -- genug um Dich +an Befehle zu erinnern die Du bereits gelernt hast. + +Zeichenerweiterte Befehle so wie C-x C-s und (wenn Du keine META- oder +EDIT- oder ALT-Taste hast) v sind nach C-h c auch erlaubt. + +Um mehr Hilfe zu einem Befehl zu bekommen verwende C-h k anstelle von +C-h c. + +>> Tippe C-h k C-p. + +Dies zeigt die Dokumentation der Funktion, als auch ihren Namen, in +einem eigenen Emacs-Fenster. Wenn Du mit dem Lesen fertig bist, tippe +C-x 1 um den Hilfetext loszuwerden. Du mußt dies nicht gleich tun. +Du kannst etwas bearbeiten, das sich auf den Hilfetext bezieht und +dann C-x 1 tippen. + +Hier sind einige andere nützliche C-h Möglichkeiten: + + C-h f Beschreibe eine Funktion. Du tippst den Namen der + Funktion + +>> Versuche C-h f previous-line. + Dies gibt Dir all die Information die Emacs zu der Funktion hat, welche + C-p implementiert. + + C-h a Befehls-Apropos. Tippe ein Schlüsselwort und Emacs listet + alle Befehle die es enthalten. + Diese Befehle können alle mit M-x aufgerufen werden. + Für einige Befehle listet das Befehls-Apropos eine + Buchstaben-Sequenz, die den Befehl ausführt. + +>> Tippe C-h a file. + +Dies zeigt in einem anderen Fenster eine Liste aller M-x Befehle die +"file" in ihrem Namen haben. Du wirst Buchstaben-Sequenzen wie C-x +C-f mit dem entsprechenden Befehl, wie etwa find-file, aufgelistet +sehen. + +>> Tippe C-M-v um das Hilfe Fenster zu rollen. Mache dies ein paar mal. + +>> Tippe C-x 1 um das Fenster loszuwerden. + + +* ZUM SCHLUß +------------ + +Merke Dir, daß Du Emacs mit C-x C-c endgültig beendest. Um vorübergehend +in eine Shell auszusteigen, so daß Du später zurückkehren kannst, +verwende C-z. (Unter X ikonifiziert dies den aktuellen Emacs-Rahmen.) + +Dieses Tutorial sollte für Anfänger verständlich sein, hast Du etwas +Unklares gefunden, schiebe die Schuld nicht auf Dich - beschwere Dich! + + +ANFERTIGEN VON KOPIEN +--------------------- + +This tutorial descends from a long line of Emacs tutorials +starting with the one written by Stuart Cracraft for the original Emacs. +Ben Wing updated the tutorial for X Windows. + +This version of the tutorial, like GNU Emacs, is copyrighted, and +comes with permission to distribute copies on certain conditions: + +Copyright (c) 1985, 1996 Free Software Foundation + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +The conditions for copying Emacs itself are more complex, but in the +same spirit. Please read the file COPYING and then do give copies of +GNU Emacs to your friends. Help stamp out software obstructionism +("ownership") by using, writing, and sharing free software! diff -r d3e9274cbc4e -r e45d5e7c476e etc/TUTORIAL.fr --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.fr Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1085 @@ +Copyright (c) 1997, Didier Verna . +Se reporter à la fin du document pour les conditions. + +Vous lisez actuellement la version française du tutoriel d'Emacs. + +Cette version a été produite à partir de la version anglaise, qui est +Copyright (c) 1985, 1996 Free Software Foundation, Inc. + + + + Bienvenue dans le tutoriel d'Emacs en Français !! + + +La plupart des commandes d'Emacs utilisent la touche +(également notée ou ), ou la touche . Sur certains +claviers, la touche s'appelle , ou autre chose (sur +les claviers des stations Sun par exemple, il s'agit de la touche à +gauche de la barre espace, celle avec un petit losange). Si vous ne +disposez pas de la touche , il est possible d'utiliser la touche + à la place. Afin de décrire les combinaisons de touches +disponibles dans Emacs, les conventions suivantes sont utilisées: + + C- signifie maintenir la touche enfoncée tout en tapant + le caractère . Ainsi, C-f signifie «maintenir la touche + enfoncée, et taper 'f'». + M- signifie maintenir la touche enfoncée tout en tapant le + caractère . Si la touche n'est pas disponible, + tapez d'abord , relâchez la, puis tapez . + +NOTE IMPORTANTE: pour quitter Emacs, tapez C-x C-c (deux caractères). + +Quand vous trouvez les caractères >> au début d'une ligne, cette ligne +vous donne des directives pour essayer une commande. Par exemple, +<> +>> Maintenant, tapez C-v («view next screen») pour passer à l'écran + suivant. (Faites le vraiment! Maintenez la touche + enfoncée et tapez 'v'). À partir de maintenant, refaites la même + chose quand vous avez fini de lire tout l'écran. + +Remarquez que quand vous changez d'écran, les deux dernières lignes de +l'écran précédent sont conservées, ceci afin de conserver un minimum +de continuité dans la lecture. + +Une des premières choses à savoir dans Emacs est comment se déplacer +dans un texte. Vous savez déjà comment changer d'écran avec C-v. Pour +revenir d'un écran en arrière, tapez M-v (maintenez la touche +enfoncée tout en appuyant sur 'v', ou encore tapez -v si vous ne +disposez pas de , ou ). + +>> Essayez de taper M-v puis C-v un certain nombre de fois. + + +* RÉSUMÉ +-------- + +Les commandes suivantes sont utiles pour voir des écrans entiers: + + C-v Passer à l'écran suivant + M-v Revenir à l'écran précédent + C-l Effacer l'écran et tout retracer, en mettant la ligne + où se trouve le curseur au centre (C'est bien la + touche 'L', pas la touche 'un' + +>> Trouvez le curseur et rappelez vous bien du texte qui l'entoure. + Tapez C-l + Trouvez le curseur à nouveau, et remarquez qu'il s'agit bien du + même texte autour de lui. + + +* MOUVEMENTS DE BASE DU CURSEUR +------------------------------- + +Passer d'un écran à l'autre, c'est bien ... mais comment faire pour se +déplacer dans le texte d'un seul écran? + +Il existe plusieurs manières de faire. La plus simple est d'utiliser +les commandes C-p, C-b, C-f et C-n. Chacune de ces commandes déplace +le curseur d'une ligne ou d'une colonne dans une direction donnée, +comme illustré sur le diagramme suivant: + + + Ligne précédente, C-p + : + : + En arrière, C-b .... Position courante .... En avant, C-f + : + : + Ligne suivante, C-n + +>> Déplacez le curseur au centre de ce diagramme en utilisant C-n ou + C-p, puis placez le au centre de l'écran avec C-l. + + +Pour vous rappeler ces commandes, pensez à leur signification en +anglais (et oui, pas en français ...): F pour Forward, B pour +Backward, N pour Next, P pour Previous. Retenez bien ces commandes, +car vous vous en servirez très souvent. + +>> Amenez le curseur sur cette ligne avec quelques C-n. + +>> Déplacez vous sur la ligne avec des C-f, puis vers le haut avec des + C-p. Remarquez ce que fait C-p quand le curseur est au milieu de la + ligne. + +Chaque ligne de texte se termine avec un caractère nommé Newline, qui +sert à séparer les lignes entre elles. La dernière ligne du fichier +est censée avoir un tel caractère à la fin (bien qu'Emacs n'ait pas +particulièrement besoin de sa présence). + +>> Placez vous au début d'une ligne, et tapez C-b. Cela devrait vous + placer à la fin de la ligne précédente. En fait, on a juste reculé + d'un caractère, à travers le caractère Newline. + +C-f vous déplace à travers Newline, exactement comme C-b. + +>> Faites encore quelques C-b, pour bien sentir comment se déplace le + curseur, puis des C-f pour retourner à la fin de la ligne, et pour + finir encore un C-f pour aller au début de la ligne suivante. + +Si vous vous déplacez en dehors de l'écran, le texte se déplace de +manière à ce que la position du curseur redevienne visible. Cette +opération est appelée «scrolling». + +>> Déplacez le curseur jusqu'en bas de l'écran, et remarquez ce qu'il + se passe. + +Si vous trouvez que le déplacement caractère par caractère est trop +lent, vous pouvez vous déplacer mot par mot. M-f et M-b vous déplacent +respectivement d'un mot en avant et en arrière. + +>> Tapez quelques M-f et M-b. + +Si vous êtes au milieu d'un mot, M-f vous déplace à la fin du mot. +Si vous êtes entre deux mots, M-f vous déplace à la fin du mot +suivant. M-b produit le même comportement, en sens inverse. + +>> Mélangez quelques M-f et M-b avec quelques C-f et C-b pour bien +noter les différences de comportement suivant l'endroit où vous êtes. + +Remarquez le parallèle qui existe entre C-f et C-b d'un côté, et M-f +et M-b de l'autre. Très souvent, les commandes Meta agissent sur des +unités de langage (mots, phrases, paragraphes etc.) tandis que les +commandes Control agissent sur des unités plus primaires (caractères, +lignes etc.). + +Ce parallèle existe encore entre les lignes et les phrases: C-a et C-e +vous positionnent au début ou à la fin d'une ligne, tandis que M-a et +M-e vous déplacent au début ou à la fin d'une phrase. + +>> Tapez quelques C-a et quelques C-e. + Puis tapez quelques M-a et quelques M-e. + +Remarquez que plusieurs C-a ne font rien, mais que plusieurs M-a +n'arrêtent pas de vous faire remonter de phrase en phrase. + +La position du curseur sur dans le texte est aussi appelée le +«point». En d'autres termes, le curseur à l'écran se trouve où le +point est dans le texte. + +Voici un résumé des commandes simples de déplacement, y compris celles +relatives aux mots et aux phrases: + + C-f En avant d'un caractère + C-b En arrière d'un caractère + + M-f En avant d'un mot + M-b En arrière d'un mot + + C-n Ligne suivante + C-p Ligne précédente + + C-a Début de ligne + C-e Fin de ligne + + M-a Début de phrase + M-e Fin de phrase + +>> Entraînez vous un peu à la pratique de ces commandes. Elles sont + très souvent utilisées. + +Deux autres commandes importantes pour le déplacement sont M-< +(Meta-Inférieur) et M-> (Meta-Supérieur). Elles vous déplacent +respectivement au début et à la fin de tout le texte. + +Sur la plupart des terminaux, '<' se trouve au dessus de la +virgule. Il faut donc utiliser la touche pour l'obtenir, sans +quoi vous obtiendrez M-'virgule'. + +>> Tapez M-< pour retourner au début du texte. + Puis tapez plusieurs C-v pour revenir ici. + +>> Tapez M-> pour aller à la fin du texte. + Puis tapez plusieurs M-v pour revenir ici. + +Vous pouvez aussi déplacer le curseur avec les flèches, si votre +clavier en possède. Il est cependant préférable d'utiliser C-b C-f C-n +et C-p pour trois raisons: premièrement, ces commandes fonctionnent +sur tous les terminaux. Deuxièmement, quand vous vous serez habitué à +Emacs, vous découvrirez que ces touches sont plus rapides car vous +n'avez pas besoin de déplacer vos mains loin des lettres du +clavier. Enfin, quand vous aurez l'habitude d'utiliser la touche +, vous apprendrez plus facilement d'autres commandes de +déplacement plus complexes. + +La plupart des commandes d'Emacs acceptent un argument numérique, qui +sert souvent comme compteur de répétition. Pour donner un tel argument +à une fonction, tapez C-u puis les chiffres, et enfin entrez la +commande. Si vous disposez de la touche (ou ou ), vous +pouvez aussi tapez directement les chiffres tout en maintenant la +touche enfoncée. Il est préférable d'apprendre la méthode C-u car +elle fonctionne sur tous les terminaux. + +Par exemple, C-u 8 C-f vous déplace de huit caractères en avant. + +>> Essayez d'utiliser C-n avec un argument numérique pour vous + déplacer d'un seul coup sur une autre ligne. + +Certaines commandes n'interprètent pas leur argument numérique comme +un compteur de répétition. C'est le cas de C-v et M-v qui déplacent le +texte d'autant de lignes plutôt que d'écrans entiers. Par exemple, C-u +4 C-v déroulera l'écran de 4 lignes. + +>> Essayez C-u 8 C-v. + +Cela a du déplacer l'écran de 8 lignes. Pour faire la manoeuvre +inverse, donnez le même argument a M-v. + +Si vous travaillez sous X Window, il y a sans doute une scrollbar sur +le côté droit de la fenêtre d'Emacs. Vous pouvez aussi vous en servir +avec la souris pour déplacer le texte. + +>> Essayer de cliquer avec le deuxième bouton au dessus du bouton de + la scrollbar. Cela devrait dérouler le texte jusqu'à une position + déterminée par l'endroit où vous avez cliqué. + +>> Cliquez maintenant avec le premier bouton à quelques lignes du + sommet dans la scrollbar. + + +* CONTRôLE DU CURSEUR AVEC UN TERMINAL X +---------------------------------------- + +Si vous travaillez sur un terminal X, vous trouverez surement plus +facile d'utiliser les flèches du pavé numérique pour déplacer le +curseur. Les quatre flèches fonctionnent exactement comme C-f C-b C-n +et C-p mais sont plus faciles à retenir. Vous pouvez aussi les +combiner avec la touche pour vous déplacer par bloc (par +exemple par paragraphe dans un texte). Si votre pavé numérique dispose +de touches (ou ) et , elles vous déplaceront +respectivement en début et en fin de ligne. Combinées avec la touche +, elles vous déplaceront respectivement en début et en fin de +fichier. Si enfin votre pavé numérique dispose des touches et +, celles-ci vous déplaceront d'écran en écran comme C-v et M-v. + +Toutes ces commandes acceptent des arguments numériques comme décrit +précédemment. + + +* QUAND EMACS EST BLOQUÉ +------------------------ + +Si jamais Emacs ne répond plus à vos ordres, vous pouvez l'arrêter en +toute sécurité en tapant C-g. C-g peut aussi être utilisé pour stopper +une commande qui met trop de temps à s'exécuter. + +C-g sert également à annuler un argument numérique, ou une commande +que vous ne voulez plus mener à terme. + +>> Tapez C-u 1 0 0 pour produire un argument numérique de 100, puis + tapez C-g. + Maintenant, tapez C-f. Le curseur doit finalement ne bouger que + d'un seul caractère, puisque vous avez annulé l'argument. + +Si vous avez tapé un par erreur, vous pourrez toujours l'annuler +avec C-g. + + +* COMMANDES DÉSACTIVÉES +----------------------- + +Quelques commandes sont «désactivées» pour empêcher les nouveaux +utilisateurs de les appeler par accident. + +Si vous tapez une de ces commandes, Emacs ouvrira un message vous +disant quelle était cette commande, et vous demandant si vous voulez +vraiment poursuivre son exécution. + +Si vous souhaitez effectivement l'essayer, appuyez sur la barre +espace. Sinon, répondez à la question en tapant 'n'. + +>> Tapez `C-x n p' (commande désactivée), puis répondez par 'n'. + + +* FENÊTRES +---------- + +Emacs peut afficher plusieurs fenêtres, chacune avec un texte +différent. Le terme «fenêtre» signifie ici une zone particulière dans +la fenêtre d'Emacs; il ne s'agit pas de fenêtres pouvant se superposer +dans votre système de multifenétrage. Emacs peut aussi ouvrir +plusieurs fenêtres X (appelées «frames» en jargon Emacsien), mais ceci +est décrit ultérieurement. + +Pour l'instant, mieux vaut ne pas trop s'occuper de plusieurs fenêtres +simultanées, sauf peut-être pour savoir les éliminer toutes sauf +une. Ceci est effectué par la commande C-x 1 ('un', pas 'L'). Cette +commande tue toutes les fenêtres sauf celle dans laquelle vous vous +trouvez, et s'arrange pour que la fenêtre restante occupe toute la place. + +>> Amenez le curseur ici, puis tapez C-u 0 C-l. + +(Rappelez vous que C-l recentre le curseur au milieu de la +fenêtre. Avec un argument numérique, elle place la ligne courante à +autant de lignes du sommet de la fenêtre. Avec 0 comme argument, on +réaffiche donc le texte, en plaçant la ligne courante en haut.) + +>> Tapez Control-x 2 + Notez que cette fenêtre diminue (de moitié), et qu'une nouvelle + fenêtre apparaît (avec le même texte). + +>> Tapez C-x 1 pour faire à nouveau disparaître la deuxième fenêtre. + + +* INSÉRER ET EFFACER +-------------------- + +Pour insérer du texte, il suffit de le taper. Tous les caractères que +vous pouvez voir à l'écran (A, %, - etc.) sont considérés comme du +texte et sont insérés. Pour insérer le caractère Newline, tapez + (retour chariot). + +Vous pouvez effacer le dernier caractère que vous avez tapé avec la +touche parfois nommée «Del». La touche peut +quelques fois être utilisée de la même manière, mais pas tout le +temps! + +Plus généralement, efface le caractère situé juste avant le +curseur. + +>> Maintenant, tapez quelques caractères, puis effacez-les avec + . Ne vous inquiétez pas pour le contenu de ce tutoriel, ce + que vous avez à l'écran n'est que votre copie personnelle du + fichier, pas le fichier d'origine. + +Si une ligne de texte devient trop grande, elle se poursuit sur une +seconde ligne. Un «Backslash» ('\') situé tout à fait à droite de la +ligne indique que celle-ci continue sur la ligne suivante. + +>> Insérez des caractères jusqu'à ce que la ligne devienne trop + grande, et notez l'apparition du '\'. + +>> Utilisez pour effacer des caractères jusqu'à ce que la + ligne reprenne une taille raisonnable. Vous remarquerez que le '\' + disparaît. + +Le caractère Newline s'efface exactement comme les autres. L'effacer +revient à ne faire qu'une seule ligne à partir de deux. Si cette +nouvelle ligne est trop grande, le '\' apparaîtra a nouveau. + +>> Déplacez le curseur au début d'une ligne et tapez . Le +caractère Newline sera effacé et cette ligne sera ajoutée à la ligne +précédente. + +>> Tapez pour réinsérer le Newline que vous avez effacé. + +Rappelez-vous bien que la plupart des commandes acceptent un argument +numérique, y compris l'insertion de caractères: + +>> Tapez C-u 8 *, vous obtiendrez "********". + +Vous connaissez maintenant les commandes de base pour insérer du texte +et corriger des erreurs. Toujours grâce aux touches et +, vous pouvez aussi effacer du texte par mot ou par ligne: + + efface le caractère juste avant le curseur + C-d efface le caractère juste après le curseur + + M- supprime le mot juste avant le curseur + M-d supprime le mot juste après le curseur + + C-k supprime tout du curseur jusqu'à la fin de ligne + M-k supprime tout du curseur jusqu'à la fin de phrase + + +Quand vous supprimez plus d'un caractère à la fois, Emacs sauvegarde le +texte pour vous donner la possibilité de le réintroduire. L'opération +de réintroduction s'appelle le «yanking». Vous pouvez réintroduire le +texte à la même place ou ailleurs. Vous pouvez même le réintroduire +plusieurs fois, pourquoi pas à des endroits différents. La commande de +«yanking» est C-y. + +Notez bien la différence entre «effacer» et «supprimer». Un texte +«supprimé» est sauvegardé, tandis qu'un caractère «effacé» ne l'est +pas. De même, les commandes effaçant juste des blancs ou des lignes +vides ne sauvegardent rien. + +>> Placez le curseur au début d'une ligne non vide. + Tapez C-k pour supprimer le texte sur cette ligne. +>> Tapez C-k une deuxième fois. Vous remarquerez que cette fois-ci, la + ligne elle-même est supprimée (le caractère Newline). + +C-k traite son argument numérique de manière spéciale: il supprime +autant de lignes Y COMPRIS LE CARACTÈRE NEWLINE. Taper C-k deux fois +de suite ne produirait pas le même résultat. + +>> Pour récupérer le texte dernièrement supprimé, tapez C-y. Celui-ci + sera placé où se trouve le curseur. + +Notez également que si vous faites plusieurs C-k à la suite, tout les +morceaux supprimés seront concaténés, et un seul C-y suffira à tout +ramener. + +>> Faites-le. C-k plusieurs fois, puis C-y. + +>> Déplacez le curseur à un autre endroit puis tapez à nouveau C-y. + Voilà comment on copie du texte! + +C-y restaure le dernier morceau de texte à avoir été supprimé, mais +les suppressions précédentes ne sont pas perdues pour autant. Après +avoir tapé C-y, la commande M-y remplace le texte restauré par l'avant +dernière suppression. Tapez à nouveau M-y et vous obtiendrez +l'avant-avant dernière suppression et ainsi de suite. Quand vous avez +récupéré le texte que vous cherchiez, rien de plus à faire: continuez +simplement votre édition. + +Si vous tapez M-y assez longtemps, vous retomberez sur la suppression +la plus récente. + +>> Supprimez une ligne, déplacez vous et supprimez-en une autre. + Tapez C-y pour récupérer la dernière ligne. + Puis tapez M-y, ce qui restaurera la première ligne supprimée. + Tapez encore M-y pour voir ce qu'il se passe, et continuez jusqu'à + récupérer à nouveau la deuxième ligne. + Si ça vous amuse, donnez des arguments positifs et négatifs à M-y. + + +* ANNULATION +------------ + +Si vous changez du texte, et que finalement vous décidez que ce +n'était pas une bonne idée, vous pouvez annuler les changements grâce +à la commande C-x u. + +C-x u annule les changements produits par la dernière commande. Taper +C-x u plusieurs fois annule de plus en plus de commandes précédentes. + +Il existe cependant quelques exceptions: les commandes qui ne changent +pas le texte ne comptent pas (par exemple les commandes de +déplacement). Les commandes qui insèrent juste un caractère sont +souvent regroupées jusqu'à une vingtaine, ceci pour réduire le nombre +de C-x u à taper ensuite. + +>> Supprimez cette ligne avec C-k, puis tapez C-x u. Elle devrait + revenir ... + +Une alternative à C-x u est C-_. C-x u existe car c'est plus facile à +taper sur certains claviers. Sur d'autres vous pouvez également +obtenir C-_ en tapant C-/. + +Enfin, la commande d'annulation accepte les argument numériques. + + +* FICHIERS +---------- + +Pour sauver votre texte, vous avez besoin de le mettre dans un +fichier, sans quoi il disparaîtra quand vous quitterez Emacs. On dit +«trouver» un fichier («finding»), ou encore «visiter» un fichier +(«visiting»), ou bien «ouvrir». + +Visiter un fichier revient à voir son contenu dans Emacs. Si vous +modifiez le texte du fichier dans Emacs, ces changements ne deviennent +pas permanent, sauf si vous «sauvez» le fichier. Cela permet de ne pas +avoir des fichiers à moitié modifiés sur votre système, à moins que +vous ne le souhaitiez vraiment. D'autre part, quand Emacs «sauve» un +fichier, il commence par copier l'ancienne version sous un nouveau nom +afin que vous puissiez toujours revenir en arrière. + +Regardez en bas de la fenêtre d'Emacs. Vous trouverez une ligne +contenant des tirets '-', et la chaîne de caractères +«Emacs: TUTORIAL.FRANCAIS». Cela vous donne le nom du fichier que vous +êtes en train de visiter. En ce moment, vous visitez le fichier +«TUTORIAL.FRANCAIS» qui correspond au Tutoriel d'Emacs, version +française. Ceci est votre copie personnelle du fichier. Pour chaque +fichier que vous visitez, son nom apparaît exactement à cet endroit. + +La plupart des commandes relatives aux fichiers sont des commandes à +deux caractères, commençant par C-x. Il y a toute une série de +commandes commençant par C-x, beaucoup concernant les fichiers et les +buffers, et longues de 2 caractères ou plus. + +Une autre chose importante pour visiter un fichier est que vous devez +spécifier le nom du fichier à visiter. On dit que cette commande «lis +un argument depuis le terminal». Dans le cas présent, l'argument est +le nom du fichier. Après avoir tapé la commande + +C-x C-f («find») + +Emacs vous demande son nom. Le nom que vous tapez apparaît tout en bas +de la fenêtre. Quand cette ligne sert à entrer des données de cette +manière, on l'appelle «minibuffer». Les commandes d'édition ordinaires +peuvent être utilisées pour éditer le nom du fichier. + +Pendant que vous êtes en train de taper le nom du fichier, vous pouvez +annuler la commande grâce à C-g. + +>> Tapez C-x C-f puis C-g. Cela annule le minibuffer ainsi que la + commande C-x C-f. Vous n'allez finalement pas visiter de fichier. + +Quand le nom du fichier est correct, tapez . La commande +prendra alors effet et ira chercher le fichier. Après avoir terminé la +saisie du nom, le minibuffer disparaît. + +Au bout d'un petit moment, le contenu du fichier apparaît et vous +pouvez commencer votre édition. Quand vous êtes satisfait des +changements apportés au texte, tapez + +C-x C-s («save») + +Cette commande copie le texte contenu dans Emacs vers le fichier +lui-même. La première fois que vous le faites, Emacs sauvegarde la +version initiale du fichier sous un autre nom, en ajoutant un '~' à la +fin du nom. + +Quand la sauvegarde est terminée, Emacs affiche le nom du fichier dans +lequel on vient d'écrire. Il est fortement conseillé de sauver assez +souvent les fichiers pour éviter de tout perdre en cas de crash +système (non pas qu'Emacs ne puisse jamais crasher lui-même ...). + +>> Tapez C-x C-s pour sauver votre copie du tutoriel. + Vous devriez voir apparaître «Wrote ...TUTORIAL.FRANCAIS" tout en bas + de la fenêtre. + +NOTE: Sur certains systèmes, C-x C-s bloque l'écran et Emacs ne dit +plus rien. Cela signifie qu'une «fonctionnalité» système que l'on +appelle le «flow control» intercepte le C-s et l'empêche de parvenir à +Emacs. Pour débloquer la situation, tapez C-q. Reportez-vous dans ce +cas à la section «Spontaneous Entry to Incremental Search» du manuel +d'Emacs pour plus d'information sur cette ... «particularité». + +Vous pouvez visiter des fichiers existant, mais aussi des fichiers qui +n'existent pas. C'est en fait comme cela que l'on crée un nouveau +fichier dans Emacs. Initialement, le fichier sera inexistant, et la +première fois que vous demanderez à Emacs de le sauver, il créera +effectivement le fichier correspondant. + + +* BUFFERS +--------- + +Si vous ouvrez un nouveau fichier avec C-x C-f, le précédent reste +dans Emacs. Pour retravailler dessus, retapez simplement C-x C-f. De +cette manière, vous pouvez avoir un nombre important de fichiers +ouverts dans Emacs. + +>> Créez un fichier nommé «foo» en tapant C-x C-f foo. + Insérez un peu de texte puis sauvez-le en tapant C-x C-s. + Enfin, tapez C-x C-f TUTORIAL.FRANCAIS pour revenir ici. + +Emacs conserve le contenu de chaque fichier dans un objet appelé +«buffer». Visiter un fichier revient à créer un nouveau buffer et y +placer le contenu du fichier. Pour obtenir la liste des buffers qui +existent actuellement dans votre session Emacs, tapez la commande +suivante: + +>> Tapez C-x C-b pour obtenir la liste des buffers. + +Remarquez que chaque buffer a un nom, et qu'il peut aussi avoir un nom +de fichier dans le cas où un fichier lui est associé. Il extsite des +buffers non attachés à des fichiers, par exemple, le buffer nommé +«*Buffer List*». C'est le buffer qui a été créé par la commande C-x +C-b. Par contre, TOUT texte que vous pouvez voir dans Emacs appartient +à un buffer. + +>> Tapez C-x 1 pour faire disparaître le buffer contenant la liste des + buffers. + +Quand vous éditez un fichier, puis que vous en ouvrez un autre, le +fichier précédent n'a pas été sauvé. Tous les changements effectués +sont conservés dans le buffer associé au fichier, mais l'ouverture +et l'édition d'un nouveau fichier n'ont aucun effet sur le +premier. Vous constatez donc qu'il serait ennuyeux d'avoir à revenir +au premier fichier pour le sauver avec C-x C-s. Pour éviter ce +désagrément, il existe une autre commande: + + C-x s (Sauver certains buffers) + +C-x s vous demandera, pour chaque buffer contenant des modifications +non sauvegardées, si vous désirez le sauver ou non. + +>> Insérez une ligne de texte, puis tapez C-x s + Emacs vous demandera si vous désirez sauver le buffer nommé + TUTORIAL.FRANCAIS. + Répondez «oui» à la question en tapant 'y'. + + +* UTILISATION DES MENU +---------------------- + +Si vous travaillez sur un terminal X, vous avez déjà remarqué une +barre de menu en haut de la fenêtre d'Emacs. Cette barre de menu vous +permet d'accéder à la plupart des commandes d'Emacs comme celles +permettant d'ouvrir ou de sauver un fichier. L'utilisation de la barre +de menu vous semblera plus facile au début, puis quand vous serez +habitué à Emacs, il vous sera facile d'utiliser les commandes au +clavier, car chaque commande figurant dans un menu affiche également +son équivalent clavier sur le bouton. + +Remarquez qu'il existe des boutons n'ayant aucun équivalent +clavier. Par exemple, le menu «Buffers» donne la liste de tous les +buffers par ordre de plus récente utilisation. Vous pouvez passer d'un +buffer à l'autre en les sélectionnant par leur nom dans ce menu. + + +* UTILISATION DE LA SOURIS +-------------------------- + +Quand vous travaillez sous X, Emacs utilise pleinement la souris. Vous +pouvez vous positionner dans le texte en cliquant avec le bouton de +gauche à l'endroit souhaité, vous pouvez sélectionner du texte en +déplaçant la souris avec le bouton de gauche enfoncé, ou bien en +cliquant le bouton de gauche au début de la portion à sélectionner, +puis en Shift-cliquant à l'autre bout. + +Pour supprimer un morceau de texte, utilisez C-w ou le bouton «Cut» du +menu «Edit». Notez bien que ces deux commandes ne sont pas +équivalentes: C-w ne fait que supprimer le texte en le sauvegardant de +manière interne (comme C-k), mais «Cut» sauvegarde en plus le texte +dans le clipboard de X Window, où il pourra être accédé par d'autres +applications. + +Pour récupérer du texte en provenance d'autres applications, utilisez +«Paste» du menu «Edit». + +Le bouton du milieu sert principalement à choisir des objets visibles +dans les fenêtres d'Emacs. Par exemple, si vous entrez dans «Info» (le +système de documentation en ligne) en tapant C-h i ou en utilisant le +menu «Help», vous pourrez suivre un lien surligné en cliquant dessus +avec le bouton du milieu. De la même manière, si vous commencez à +taper un nom de fichier après avoir fait C-x C-f, et que vous appuyez +sur en cours de route, Emacs vous ouvrira une fenêtre avec +toutes les complétions possibles, et vous pourrez en sélectionner une +grâce au bouton du milieu. + +Le bouton droit fait apparaître un menu. Le contenu de ce menu varie +en fonction du mode dans lequel vous vous trouvez, et contient en +général quelques commandes fréquemment utilisées. + +>> Cliquez avec le bouton de droite pour voir le menu en question. + +Si vous relâchez le bouton, le menu disparaît. + + +* EXTENSION DE L'ENSEMBLE DES COMMANDES +--------------------------------------- + +Il existe bien plus de commandes dans Emacs que l'on ne pourrait en +associer aux touches et . Pour remédier à cela, Emacs +utilise la commande X (eXtension) qui se présente sous deux aspects: + + C-x Extension par caractère (suivit d'un caractère). + M-x Extension par nom (suivit d'un nom de commande). + +Ces commandes, bien que très utiles, sont utilisées moins souvent que +celles que vous avez déjà apprises. Vous en connaissez déjà deux: les +commandes relatives aux fichiers (C-x C-f et C-x C-s). Un autre +exemple est la commande pour quitter définitivement Emacs, C-x C-c (ne +vous inquiétez pas des éventuels changements qui seraient perdus, C-x +C-c vous propose de sauver ces changements avant de tuer Emacs). + +C-z est la commande qui vous permet de quitter Emacs «temporairement», +pour que vous puissiez y revenir plus tard. + +Sur les systèmes le permettant, C-z «suspend» Emacs, ce qui signifie +que l'on retourne au shell sans tuer Emacs. Dans la plupart des cas, +vous pouvez revenir à Emacs en tapant 'fg' ou '%emacs'. + +Sur les systèmes ne permettant pas la suspension de processus, cette +commande créé un sous-shell qui continue à exécuter Emacs, vous +donnant ainsi la possibilité de faire tourner d'autres programmes et +revenir à Emacs plus tard. Dans ce cas, la commande shell 'exit' est +la manière habituelle de retourner au sous-shell d'Emacs. + +Vous utiliserez C-x C-c quand le moment sera venu de vous déloguer ou +d'éteindre la machine. C'est aussi la bonne manière de sortir d'Emacs +si celui-ci a été lancé depuis un maileur ou tout autre utilitaire, +ceux-ci ne sachant pas forcément comment gérer les suspensions. Dans +des circonstances où vous ne vous déloguez pas, mieux vaut suspendre +par C-z au lieu de sortir véritablement d'Emacs. + +Il existe de nombreuses commandes sous C-x. Voici celles que vous avez +apprises jusque là: + + C-x C-f Visiter un fichier (Find File). + C-x C-s Sauver un fichier (Save File). + C-x C-b Lister les buffers (List buffers). + C-x C-c Quitter Emacs (Quit Emacs). + C-x u Annuler Opération (Undo). + +Les commandes étendues par nom sont des commandes utilisées très peu +souvent, ou disponibles seulement sous certains modes. Par exemple, la +commande «replace-string» substitue globalement une chaîne de +caractères par une autre. Si vous tapez M-x, Emacs vous affichera M-x +en bas de la fenêtre et vous pourrez alors taper le nom d'une +commande, ici replace-string. Tapez simplement 'repl s ' +et Emacs complétera le nom pour vous. Terminez le nom avec + +La commande replace-string requiert deux arguments: la chaîne à +remplacer et la chaîne de remplacement. Terminez chacune de ces +chaînes par . + +>> Déplacez le curseur sur la ligne blanche en dessous de ce + paragraphe, puis tapez + M-x replsRemarquezNotez. + + Remarquez comme cette ligne a changé: le mot R-e-m-a-r-q-u-e-z a + été remplacé par N-o-t-e-z partout où il est apparu après le + curseur. + + +* SAUVEGARDE AUTOMATIQUE +------------------------ + +Si votre système crashe alors que certaines modifications n'étaient +pas sauvées, vous perdez des donnés. Pour remédier à ce problème, +Emacs sauvegarde périodiquement tous vous fichiers, et cela de manière +automatique. Ce fichier de sauvegarde est appelé «auto save». Son nom +commence et se termine par un '#'. Par exemple, un fichier auto save +de 'hello.c' a pour nom '#hello.c#'. Quand vous sauvez le fichier de +manière normale, le fichier auto save est effacé. + +Si votre ordinateur crashe, vous pouvez restaurer la sauvegarde en +ouvrant le fichier normalement (le VRAI fichier, pas l'auto save), +puis en tapant M-x recover-file. Répondez 'yes' à la +question. + + +* ZONE D'ÉCHO +------------- + +Quand Emacs constate que vous tapez lentement, il vous montre ce que +vous avez tapez en bas de la fenêtre, dans la zone d'écho («echo +area»). Cette zone contient la dernière ligne de la fenêtre d'Emacs. + + +* LIGNE DE MODE +--------------- + +La ligne juste au dessus de la zone d'écho s'appelle ligne de mode +(«modeline»). Elle dit actuellement quelque chose comme ça: + +--**-XEmacs: TUTORIAL.FRANCAIS (Fundamental)--L752--67%--------- + +Cette ligne fournit des renseignements utiles sur le status d'Emacs et +le texte que vous éditez. + +Vous connaissez déjà la signification du nom de fichier: c'est celui +que vous êtes en train d'éditer. -xx%- indique le pourcentage de texte +situé au dessus du curseur. Si vous pouvez voir le début du fichier à +l'écran, --Top-- sera indiqué au lieu de --00%--. Si le bas du fichier +est visible, il y aura --Bot-- à la place. Si votre texte est tout +entier contenu dans la fenêtre, vous verrez --All--. + +Les étoiles '*' au début signifient que vous avez fait des changements +au texte. Quand vous ouvrez le fichier, ou après l'avoir sauvé, il n'y +aura plus d'étoiles, mais juste des tirets. + +La partie entre parenthèses vous indique dans quel mode d'édition vous +vous trouvez. Le défaut (que vous utilisez en ce moment) est le mode +«Fundamental». C'est un exemple de Mode Majeur («major mode»). + +Il existe de nombreux modes majeurs. Certains sont faits pour éditer +différents langages, différentes sortes de texte, du Lisp, du C etc. +Il ne peut y avoir qu'un mode majeur actif à la fois, et son nom se +trouve sur la ligne de mode (là ou vous voyez «Fundamental» en ce +moment). + +Chaque mode fait certaines commandes se comporter différemment. Par +exemple, la commande pour créer des commentaires dans un programme +tient compte des différents caractères de commentaire des +langages. Chaque mode majeur est le nom d'une commande étendue. Par +exemple la commande M-x fundamental-mode vous place en mode +fondamental. + +Si vous voulez éditer du texte en français, vous devriez plutôt +choisir le mode Text. + +>> Tapez M-x text-mode + +Pas d'inquiétude: les commandes que vous avez apprises jusqu'ici ne +sont pas radicalement différentes d'un mode à l'autre. Mais vous +pouvez constater par exemple que M-b et M-f traitent les apostrophes +comme faisant partie des mots. Auparavant, ces caractères étaient +considérés comme des séparateurs de mots. En général, les modes +majeurs ne changent que très peu le comportement des commandes +habituelles. + +Pour voir la documentation du mode majeur courant, tapez C-h m. + +>> Utilisez C-u C-v pour amener cette ligne vers le haut de l'écran. +>> Tapez C-h m, pour voir les différences entre les mode Fundamental + et Text. +>> Tapez 'q' pour faire disparaître la documentation. + +Les modes majeurs sont appelés «majeurs» parce qu'il y en a aussi des +«mineurs». Les modes mineurs n'altèrent que partiellement le +comportement de tel ou tel mode majeur. Ils peuvent être activés ou +désactivés indépendamment du mode majeur courant. Vous pouvez en +utiliser autant que possible en même temps. + +Un mode mineur très utile pour éditer du texte est le mode +«Auto Fill». Quand ce mode est activé, Emacs coupe lui-même les lignes +si vous tapez du texte trop long pour être contenu sur une seule. + +Pour activer ce mode, tapez M-x auto-fill-mode. Cette commande +sert à le désactiver ou à l'activer selon son status actuel; elle +intervertit son état d'activation. + +>> Tapez M-x auto-fill-mode. Insérez maintenant une quantité + de «aslidfhw» jusqu'à voir que votre ligne se divise + automatiquement en deux, à un endroit où il y avait un espace. + +La marge est en général à 70 caractères, mais vous pouvez la changer +grâce à la commande C-x f. Donner la marge requise comme argument +numérique. + +>> Tapez C-x f avec un argument de 20 (C-u 2 0 C-x f). + Tapez du texte jusqu'à ce que la ligne soit coupée, puis replacez + la marge à 70. + +Si vous faites des changements au milieu d'un paragraphe, le mode Auto +Fill ne recoupera pas les lignes tout seul. Pour réajuster les lignes +d'un tel paragraphe, tapez M-q avec le curseur n'importe où dans le +paragraphe. + +>> Déplacez le curseur dans le paragraphe précédent, et tapez M-q. + + +* RECHERCHE +----------- + +Emacs est capable de rechercher des chaînes de caractères aussi bien +en avant qu'en arrière dans un texte. Ces commandes sont en fait des +commandes de déplacement du curseur. Elles déplacent le curseur au +prochain (ou précédent) endroit ou la chaîne apparaît. + +La commande de recherche d'Emacs est un peu différente de celle des +autres éditeurs de texte dans la mesure où elle est incrémentale: la +recherche intervient au fur et à mesure que vous tapez la chaîne à +rechercher. + +Pour démarrer une recherche, tapez C-s (en avant) ou C-r (en +arrière). MAIS PAS TOUT DE SUITE !! Attendez un peu pour tester ... + +Après avoir tapé C-s, vous constaterez que la chaîne «I-search» +apparaît comme prompt dans la zone d'écho. Cela vous indique qu'Emacs +est en mode de recherche incrémentale, et qu'il attend que vous +entriez la chaîne à rechercher. termine la chaîne. + +>> Tapez C-s, et entrez LENTEMENT, une lettre à la fois, le mot + «curseur», en regardant bien ce qu'il se produit. + À ce stade, vous avez cherché le mot «curseur» une fois. +>> Tapez C-s à nouveau, pour chercher la prochaine occurrence du mot. +>> Maintenant, tapez quatre fois et regardez comment le + curseur se déplace. +>> Tapez pour terminer la recherche. + +En mode incrémental, Emacs recherche ce que vous avez tapé jusqu'ici, +en surlignant les occurrences trouvées. Si aucune (nouvelle) occurrence +n'existe, C-s produira un «bip», et la zone d'écho affichera +«failing». C-g terminerait aussi bien la recherche. + +NOTE: Sur certains systèmes, C-x C-s bloque l'écran et Emacs ne dit +plus rien. Cela signifie qu'une «fonctionnalité» système que l'on +appelle le «flow control» intercepte le C-s et l'empêche de parvenir à +Emacs. Pour débloquer la situation, tapez C-q. Reportez-vous dans ce +cas à la section «Spontaneous Entry to Incremental Search» du manuel +d'Emacs pour plus d'information sur cette ... «particularité». + +Si vous êtes au milieu d'une recherche incrémentale et que vous tapez +, vous constaterez que le dernier caractère de la chaîne est +effacé, et que Emacs retourne à l'occurrence précédente. Si d'autre +part vous tapez un caractère ou (mises à part +quelques exceptions comme les caractères spéciaux pour la recherche, +C-s et C-r), la recherche sera terminée. + +Rappelez vous que si C-s cherche une chaîne APRÈS le curseur, C-r la +recherche AVANT. Tout ce que nous venons de dire sur C-s s'applique à +C-r. + + +* FENÊTRES MULTIPLES +-------------------- + +Un des avantages d'Emacs est que vous pouvez afficher plusieurs +fenêtres à la fois sur l'écran. + +>> Déplacez le curseur sur cette ligne, et tapez C-u 0 C-l ('L' pas '1') + +>> Maintenant tapez C-x 2 pour obtenir deux fenêtres. + Les deux fenêtres affichent le tutoriel. Le curseur reste en haut. + +>> Tapez C-M-v (ou C-v) pour dérouler la fenêtre du bas. + +>> Tapez C-x o (o pour ôtre ...) pour placer le curseur dans la + fenêtre du bas. +>> Utilisez C-v et M-v pour dérouler la fenêtre. + Continuez de lire dans celle du haut. + +>> Tapez C-x o pour retourner dans la fenêtre du haut. + Le curseur est exactement à la même place que quand vous aviez + quitté cette fenêtre. + +Vous pouvez continuer d'utiliser C-x o pour passer d'une fenêtre à +l'autre. Chaque fenêtre a sa propre position du curseur, mais une +seule fenêtre a la fois contient réellement le curseur. Toutes les +commandes ordinaires d'édition prennent effet dans la fenêtre qui +contient le curseur. On dit que cette fenêtre est «sélectionnée». + +La commande C-M-v est très utile quand vous éditez un texte dans une +fenêtre et que vous vous servez d'une autre en guise de +référence. Vous pouvez avancer dans l'autre grâce à C-M-v. + +C-M-v (ou C-v si vous n'avez pas de touche ) est un +exemple de Control-Méta caractère. L'ordre dans lequel les touches + et sont enfoncées n'a pas d'importance. Ce sont juste +des modificateurs. Par contre, n'est pas un modificateur, donc +vous êtes obligés de taper d'abord , et C-v ensuite. + +>> Tapez C-x 1 dans la fenêtre du haut pour éliminer celle du bas. + +C-x 1 élimine en fait toutes les fenêtres non sélectionnées. + +Les fenêtres peuvent bien entendu contenir des buffers différents. Si +vous utilisez C-x C-f pour ouvrir un fichier dans l'une des fenêtres, +l'autre ne change pas. Elles sont totalement indépendantes. + +Voici une autre manière d'ouvrir un fichier dans l'autre fenêtre: + +>> Tapez C-x 4 C-f suivit du nom d'un fichier, puis . + Vous verrez le fichier apparaître dans l'autre fenêtre. Le curseur + ira également dans cette fenêtre. + +>> Tapez C-x o pour remonter à la fenêtre du haut, puis C-x 1 pour + éliminer celle du bas. + + +* NIVEAUX D'ÉDITION RÉCURSIFS +----------------------------- + +De temps en temps, vous vous trouverez dans ce qu'on appelle des +niveaux d'édition récursifs. Ceci est indiqué dans la ligne de mode +par des crochets autour des parenthèses qui englobent le nom du mode +majeur. Par exemple, vous pouvez voir [(Fundamental)] au lieu de +(Fundamental). + +Pour sortir d'un niveau récursif d'édition, tapez +. C'est un «siège éjectable» à usage multiple. Vous pouvez aussi +l'utiliser pour sortir du minibuffer ou éliminer des fenêtres +superflues. + +>> Tapez M-x pour vous rendre dans le minibuffer, puis tapez + pour en sortir. + +Il n'est pas possible d'utiliser C-g pour sortir d'un niveau récursif +d'édition. La raison en est que C-g sert à annuler des commandes au +sein même d'un niveau récursif d'édition. + + +* POUR OBTENIR PLUS D'AIDE +-------------------------- + +Dans ce tutoriel, nous avons essayé de vous fournir assez de +connaissance pour commencer à utiliser Emacs. Emacs est tellement +riche en possibilités qu'il serait impossible de tout dire +ici. Cependant, vous souhaiterez surement à un moment ou un autre +avoir plus de renseignements sur ses énormes possibilités. Emacs +comprend entre autres des commandes d'aide sur sa propre +utilisation. Toutes ces commandes d'aide commencent par le préfixe +C-h, le «caractère d'aide». + +Typiquement, vous tapez C-h, puis un caractère indiquant quelle aide +vous souhaitez obtenir. Si vous êtes VRAIMENT perdu, tapez C-h ? et +Emacs vous indiquera quelles sortes d'aide il peut vous fournir. Si +vous ne désirez finalement pas d'aide après avoir tapé C-h, tapez +simplement C-g. + +(Quelques sites redéfinissent la commande C-h. Cela ne devrait vraiment +pas être fait, donc allez vous plaindre à votre administrateur système. +Si C-h ne marche pas, tapez M-x help.) + +L'aide de base est C-h c. Tapez C-h c puis une commande (même une +séquence comme C-x f), et Emacs vous donnera une brève description de +la commande en question. + +>> Tapez C-h c C-p. + Le message doit ressembler à quelque chose comme + + C-p runs the command previous-line + +Cela vous donne le «nom de la fonction». Les noms de fonctions sont +principalement utilisés pour customiser Emacs, mais comme en général +ils sont choisi de manière à indiquer ce que fait la commande, ils +peuvent servir de courte documentation (au moins pour vous rappeler +les commandes que vous avez déjà apprises). + +Pour de plus amples informations sur les commandes, utilisez C-h k au +lieu de C-h c. + +>> Tapez C-h k C-p. + +Ceci affiche la documentation sur la fonction, ainsi que son nom dans +une autre fenêtre. Quand vous avez fini de lire, tapez 'q' pour +éliminer la fenêtre d'aide. + +Voici d'autres aides utiles: + + C-h f Décrire une fonction. Vous donnez son nom. + +>> Tapez C-h f previous-line. + Cela vous donne toute l'information dont Emacs dispose sur la + fonction appelée par la commande C-p. + + C-h a Hyper Apropos. Tapez un mot-clé et Emacs vous + affichera toutes les fonctions ou variables contenant + ce mot-clé. Les commandes que vous pouvez appeler + grâce à M-x ont un astérisque à gauche de leur nom. + +>> Tapez C-h a newline. + +Tapez pour effacer l'à-propos, ou cliquez avec le bouton du +milieu sur un nom pour obtenir l'aide sur cette fonction ou variable. + + +* CONCLUSION +------------ + +Rappelez-vous bien, pour quitter définitivement Emacs, tapez C-x +C-c. Pour quitter temporairement (et pour pouvoir revenir), tapez C-z +(sous X Windows, C-z iconifie la fenêtre). + +Ce tutoriel est fait pour être compréhensible par tout nouvel +utilisateur. Donc si quelque chose n'est pas clair, n'hésitez pas à +vous plaindre !! + +Si vous avez plus particulièrement des remarques à faire sur la +version française, vous pouvez aussi me contacter directement +(Didier Verna ). + + +COPIES / DISTRIBUTION +--------------------- + +Un peu d'histoire ... + +* Le premier tutoriel pour l'Emacs d'origine fut écrit par Stuart + Cracraft. +* Ben Wing l'a mis à jour pour X Windows. +* Martin Buchholz et Hrvoje Niksic y ont apporté des corrections pour + XEmacs. +* J'en (Didier Verna) ai fait une version française un beau jour de 1997. + +Cette version du tutoriel, tout comme Emacs, est copyrightée, et vous +est fournie avec la permission d'en distribuer des copies sous +certaines conditions (je laisse la notice du copyright en anglais): + +Copyright (c) 1997, Didier Verna. + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +Les conditions pour copier Emacs lui-même sont plus complexes, mais +dans le même état d'esprit. Vous êtes conviés à lire le fichier +COPYING et à distribuer Emacs à vos amis. Aidez-nous à tuer +l'obstructionnisme logiciel en utilisant, écrivant et partageant du +logiciel libre! + diff -r d3e9274cbc4e -r e45d5e7c476e etc/TUTORIAL.hr --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.hr Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1128 @@ +Copyright (c) 1985, 1996 Free Software Foundation, Inc. Uvjeti +kopiranja na kraju. + +Ovo su osnovne upute za Emacs. + +Opæenito, Emacsove naredbe sadr¾e tipku CONTROL (ponekad oznaèenu CTRL +ili CTL) ili tipku META. Na nekim tipkovnicama tipka META je oznaèena +kao ALT ili EDIT, ili ne¹to treæe (na primjer, na Sunovim tipkovnicama +karo znak lijevo od razmaknice je META). Ako nemate tipku META, +umjesto nje mo¾ete koristiti ESC. Da ne pi¹emo META ili CONTROL svaki +put kad mislimo na prefiksnu tipku, koristit æemo sljedeæe skraæenice: + + C- znaèi dr¾eæi tipku CONTROL, stisnite znak . Tako bi + C-f bilo: Dr¾eæi tipku CONTROL, napi¹ite f. + M- znaèi dr¾eæi tipku META, pritisnite . Ako nema tipke + META, pritisnite , otpustite ga, i napi¹ite znak + . + +Napomena: za izlazak iz Emacsa, utipkajte C-x C-c. (Dva znaka.) +Znakovi ">>" na lijevom rubu naznaèuju uputstva da poku¹ate koristiti +neku naredbu. Na primjer: +<> +>> Sad utipkajte C-v za pomak na sljedeæi ekran. + (samo naprijed, uèinite to tako da dr¾ite tipku control i + pritisnite 'v'). Od sad, ovo trebate napraviti kad god zavr¹ite + sa èitanjem stranice teksta. + +Uoèite dva reda koja se preklapaju kad se pomaknete s ekrana na ekran; +preklapanje osigurava kontinuitet koji vam olak¹ava èitanje teksta. + +Prva stvar koju trebate znati jest kako se micati s mjesta na mjesto u +tekstu. Veæ znate kako se pomaknuti ekran naprijed, pomoæu C-v. Da +biste se pomakli ekran natrag, pritisnite M-v (dr¾ite tipku META i +pritisnite v, ili upi¹ite v ako nemate tipke META, EDIT ili ALT). + +>> Poku¹ajte tipkati M-v, zatim C-v, nekoliko puta. + + +* SA®ETAK +--------- + +Sljedeæe naredbe su korisne za pregledavanje stranica teksta: + + C-v Pomièe stranicu naprijed + M-v Pomièe stranicu natrag + C-l Bri¹e ekran, i ponovno iscrtava sve, stavljajuæi tekst + pokraj kursora u sredinu. + (to je control-L, a ne control-1.) + +>> Naðite kursor, i pogledajte tekst pokraj njega. + Sada stisnite C-l. + Opet naðite kursor, i uoèite da se pokraj kursora nalazi isti + tekst. + + +* OSNOVE KONTROLE KURSORA +------------------------- + +Pomaci s ekrana na ekran su korisni, ali kako se pomaknuti na pojedino +mjesto u tekstu na ekranu? + +To mo¾ete uèiniti na nekoliko naèina. Najosnovniji naèin je +upotrijebiti naredbe C-p, C-b, C-f i C-n. Svaka od ovih naredbi +pomièe kursor jedan redak ili stupac u pojedinom smjeru. Evo tablice +koja pokazuje ove èetiri naredbe i smjerove u kojem pomièu. + + Prethodni red, C-p + (eng. previous line) + : + : + Natrag, C-b .... Trenutni polo¾aj kursora .... Naprijed, C-f + (eng. backward) : (eng. forward) + : + Sljedeæi red, C-n + (eng. next line) + +>> Pomaknite kursor do retka u sredini tablice koristeæi C-n i C-p. + Tada stisnite C-l da vidite cijelu tablicu u sredi¹tu ekrana. + +Ove su naredbe temeljene na engleskim mnemonicima: P za previous, N za +next, B za backward i F za forward. Ovo su osnovne naredbe za +pomicanje kursora, i s vremenom æete ih SVE koristiti, pa bi bilo vrlo +korisno da ih sada nauèite. + +>> Stisnite C-n nekoliko puta, tako da dovedete kursor do ovog retka. + +>> Pomaknite se na red s C-f-ovima, i onda gore do C-p-ova. + Uoèite ¹to C-p radi kad je kursor na sredini reda. + +Svaki red teksta zavr¹ava znakom Newline (novi red), èime ga se odvaja +od sljedeæeg reda. Zadnji red u datoteci bi trebao imati Newline na +kraju (ali Emacs to ne zahtijeva). + +>> Poku¹ajte stisnuti C-b na poèetku reda. Trebalo bi vas pomaknuti + na kraj prethodnog reda. To se dogaða zato ¹to ste se pomakli + unatrag, preko znaka Newline. + +C-f se mièe preko Newline-a, ba¹ kao i C-b. + +>> Pritisnite jo¹ nekoliko puta C-b, da steknete osjeæaj za kursor. + Tad sti¹æite C-f dok se ne vratite na kraj reda. + Zatim se jo¹ jednim C-f-om pomaknite na poèetak sljedeæeg reda. + +Kad se pomaknete preko gornjeg ili donjeg ruba ekrana, tekst iza ruba +se pomakne na ekran. Ovo se naziva "pomak" (eng. scrolling). Njime +Emacs mo¾e pomaknuti kursor na neko mjesto u tekstu bez uklanjanja +kursora s ekrana. + +>> Poku¹ajte pomaknuti kursor s donjeg ruba sa C-n, i pogledajte ¹to + se dogaða. + +Ako je micanje po znakovima presporo, mo¾ete se micati po rijeèima. +M-f (Meta-f) mièe rijeè naprijed, a M-b mièe rijeè natrag. + +>> Pritisnite nekoliko puta M-f i M-b. + +Kad se nalazite u sredini rijeèi, M-f pomièe na kraj rijeèi. Kad se +nalazite u praznom prostoru izmeðu rijeèi, M-f pomièe na kraj sljedeæe +rijeèi. M-b se pona¹a na isti naèin, ali u suprotnom smjeru. + +>> Pritisnite M-f i M-b nekoliko puta, izmije¹ano s C-f i C-b, tako da + mo¾ete promotriti kako se M-f i M-b pona¹aju na razlièitim mjestima + unutar i izmeðu rijeèi. + +Uoèite paralelu izmeðu C-f i C-b na jednoj strani, i M-f i M-b na +drugoj. Meta znakovi se èesto koriste za operacije vezane uz jedinice +definirane jezikom (rijeèi, reèenice, paragrafi), dok Control znakovi +rade na osnovnim jedinicama, neovisno o onome ¹to editirate (znakovi, +redovi, itd.) + +Analogija vrijedi i izmeðu redova i reèenica: C-a i C-e pomièu na +poèetak, odnosno na kraj reda, dok M-a i M-e pomièu na poèetak, odnosno +kraj reèenice. + +>> Isku¹ajte C-a nekoliko puta, potom C-e nekoliko puta. +>> Iskupajte M-a nekoliko puta, potom M-e nekoliko puta. + +Uoèite kako ponovljeni C-a ne rade ni¹ta, dok ponovljeni M-a +nastavljaju micati po reèenicama. Iako ovo nije sasvim analogno, +svaka se naredba doima prirodnom. + +Polo¾aj kursora u tekstu se takoðer naziva "toèka" (eng. point). +Drugaèije reèeno, kursor pokazuje na ekranu gdje se point nalazi u +tekstu. + +Evo sa¾etka jednostavnih operacija za micanje kursora, ukljuèujuæi i +naredbe za pomicanje preko rijeèi i reèenica: + + C-f Znak naprijed + C-b Znak natrag + + M-f Rijeè naprijed + M-b Rijeè natrag + + C-n Sljedeæi red + C-p Prethodni red + + C-a Poèetak reda + C-e Kraj reda + + M-a Poèetak reèenice + M-e Kraj reèenice + +>> Isku¹ajte sve ove naredbe jo¹ nekoliko puta, za vje¾bu. + To su najèe¹æe rabljene naredbe. + +Dvije druge va¾ne naredbe za pomicanje kursora su M-< (Meta Manje), +koja pomièe na poèetak cijelog teksta, i M-> (Meta Veæe), koja pomièe +na kraj cijelog teksta. + +Na veæini terminala, "<" je iznad zareza, tako da morate koristiti +tipku shift da biste ga utipkali. Na tim terminalima morate koristiti +tipku shift i da biste utipkali M-<; bez shifta, pisali biste M-zarez. + +>> Sada isku¹ajte M-<, da biste se pomaknuli na poèetak uputa. + Potom upotrijebite C-v nekoliko puta da se vratite ovamo. + +>> Sada isku¹ajte M->, pomaknuv¹i se na kraj uputa. + Potom upotrijebite M-v nekoliko puta da se vratite ovamo. + +Ako va¹ terminal ima kursorske tipke, mo¾ete kursor pomicati njima. +Preporuèujemo da nauèite C-b, C-f, C-n i C-p iz tri razloga. Prvo, +rade na svim vrstama terminala. Drugo, kad steknete rutinu kori¹tenja +Emacsa, primijetit æete da je tipkanje ovih CTRL znakova br¾e od +uporabe kursorskih tipki (jer ne morate odmicati prste od polo¾aja za +tipkanje). Treæe, jednom kad se naviknete koristiti CTRL znakovne +naredbe, lako æete nauèiti koristiti druge napredne naredbe za micanje +kursora. + +Veæina Emacsovih naredbi prihvaæa numerièki argument; za veæinu njih +ovo slu¾i kao brojaè ponavljanja. Brojaè ponavljanja zadajete tako da +utipkate C-u i potom znamenke prije nego ¹to utipkate naredbu. Ako +imate tipku META (ili EDIT ili ALT), postoji jo¹ jedan alternativan +naèin uno¹enja numerièkog argumenta: tipkajte znamenke dr¾eæi svo vrijeme +tipku META. Preporuèujemo uèenje metode pomoæu C-u, jer radi na svim +terminalima. + +Primjerice, C-u 8 C-f pomièe osam znakova naprijed. + +>> Poku¹ajte koristiti C-n ili C-p s numerièkim argumentom, tako da + pomaknete kursor na liniju blisku ovoj samo jednom naredbom. + +Veæina naredbi koristi numerièki argument kao brojaè ponavljanja. +Neke ga naredbe, izunimno, koriste drugaèije. C-v i M-v su meðu +iznimkama. Kad im se proslijedi argument, one pomaknu ekran gore ili +dolje, za toliko redova, a ne stranica. Na primjer, C-u 4 C-v pomièe +ekran za èetiri reda. + +>> Sada poku¹ajte upisati C-u 8 C-v. + +Ovo je trebalo pomaknuti ekran za 8 redova. Ako ga hoæete pomaknuti +natrag, mo¾ete dati isti argument M-v. + +Ako koristite X Window sistem, vjerojatno se na desnoj strani Emacsova +prozora nalazi pravokutno podruèje nazvano "vrpca za pomicanje" +(eng. scroll-bar). Mo¾ete pomicati tekst mi¹em povlaèeæi klizaè +unutar vrpce. + +>> Poku¹ajte pritisnuti srednju tipku mi¹a na vrh klizaèa unutar + scroll-bara. Ovo bi trebalo pomaknuti tekst do polo¾aja odreðenog + visinom toèke pritiska. + +>> Pomaknite mi¹a na toèku scroll-bara otprilike tri reda od vrha, i +pritisnite lijevu tipku mi¹a nekoliko puta. + + +* KONTROLA KURSORA NA X TERMINALU +--------------------------------- + +Ako imate X terminal, vjerojatno æe vam biti lak¹e koristiti tipke +kursorskog bloka. Lijeva, desna, gornja i donja strelica pomièu u +oèekivanom smjeru; one funkcioniraju jednako kao i C-b, C-f, C-p i +C-n, ali ih je lak¹e tipkati i zapamtiti. Takoðer mo¾ete koristiti +C-lijevo i C-desno za pomake po rijeèima, a C-gore i C-dolje za pomake +po blokovima (npr. paragrafima, ako editirate tekst). Ako imate tipke +oznaèene s HOME (ili BEGIN) i END, one æe vas pomaknuti na poèetak +odnosno kraj reda, a C-home i C-end æe vas pomaknuti na poèetak +odnosno kraj datoteke. Ako va¹a tipkovnica ima tipke PgUp i PgDn, +mo¾ete ih koristiti za pomicanje gore i dolje po stranicama, kao M-v i +C-v. + +Sve ove naredbe mogu primiti numerièke argumente, kao ¹to je gore +opisano. Mo¾ete taj argument unijeti kraæim putem: samo dr¾ite tipku +CONTROL ili META, i upi¹ite broj. Na primjer, za pomak 12 rijeèi +desno, tipkajte C-1 C-2 C-desno. Uoèite da je ovo jako lako utipkati, +jer ne morate otpu¹tati tipku CONTROL izmeðu pritisaka tipki. + + +* KAD EMACS BLOKIRA +------------------- + +Ako Emacs prestane odgovarati na va¹e naredbe, mo¾ete ga zaustaviti +utipkav¹i C-g. Mo¾ete koristiti C-g da zaustavite naredbu koja predugo +traje. + +Takoðer s C-g mo¾ete odbaciti numerièki argument, ili poèetak naredbe +koju ne ¾elite zavr¹iti. + +>> Upi¹ite C-u 100 da napravite numerièki argument 100, zatim stisnite C-g. + Sad upi¹ite C-f. Pomaknut æe se samo za jedan znak, jer ste + argument odbacili s C-g. + +Ako gre¹kom stisnete , mo¾ete ga se rije¹iti s C-g. + + +* ONEMOGUÆENE NAREDBE +--------------------- + +Neke Emacsove naredbe su "onemoguæene", tako da ih poèetnici ne mogu +pokrenuti gre¹kom. + +Ako utipkate jednu od onemoguæenih naredbi, Emacs æe vas porukom +obavijestiti koju ste naredbu poku¹ali pokrenuti, i pitati vas ¾elite +li je ipak izvr¹iti. + +Ako je zaista ¾elite isprobati, pritisnite razmaknicu kao odgovor na +pitanje. Inaèe, ako ne ¾elite izvr¹iti onemoguæenu naredbu, +odgovorite na pitanje s "n". + +>> Pritisnite `C-x n p' (¹to je onemoguæena naredba), + zatim na pitanje odgovorite s "n". + + +* PROZORI +--------- + +Emacs mo¾e imati nekoliko prozora, svaki s vlastitim tekstom. Uoèite +da se pojam "prozora" kako ga koristi Emacs ne odnosi na odvojene +preklapajuæe prozore windowing sustava, veæ na razdvojene dijelove +unutar jednog X prozora. (Emacs takoðer mo¾e prikazati vi¹e X +prozora, odnosno "okvira", u Emacsovoj terminologiji. To je opisano +kasnije.) + +Za sada je bolje ne ulaziti u tehnike kori¹tenja vi¹e prozora. Ono +¹to trebate znati jest kako se rije¹iti dodatnih prozora koji se mogu +javiti za prikaz pomoæi, ili kao izlaz nekih naredbi. +Jednostavno: + + C-x 1 Jedan prozor (tj. ubij sve druge prozore) + +To je Control-x praæen znamenkom 1. C-x 1 pro¹iruje prozor u kojem je +kursor, tako da on zauzme cijeli ekran. Pobri¹e, takoðer, i ostale +prozore. + +>> Pomaknite kursor na ovu liniju i upi¹ite C-u 0 C-l. + +(Sjetite se da C-l ponovno iscrtava ekran. Ako ovoj naredbi date +numerièki argument, on znaèi "iscrtaj ekran i smjesti trenutni red +toliko linija od vrha ekrana." Tako C-u 0 C-l znaèi "iscrtaj ekran, i +stavi trenutni red na vrh.") + +>> Pritisnite Control-x 2 + Uoèite kako se ovaj prozor smanjuje, dok se novi pojavljuje + prikazujuæi sadr¾aj ovog spremnika (buffera). + +>> Upi¹ite C-x 1 i gledajte kako novi prozor nestaje. + + +* UMETANJE I BRISANJE +--------------------- + +®elite li umetnuti tekst, samo ga utipkajte. Znakove koje vidite, kao +¹to su A, 7, *, itd. Emacs shvaæa kao tekst i umeæe trenutno. +Pritisnite (znak za novi red) da umetnete znak Newline. + +Zadnji znak koji ste umetnuli mo¾ete izbrisati pritisnuv¹i . + je tipka na tipkovnici koja mo¾e biti oznaèena kao "Del". U +nekim sluèajevima, tipka "Backspace" slu¾i kao , ali ne +uvijek! + +Opæenitije, bri¹e znak neposredno ispred trenutnog polo¾aja +kursora. + +>> Uèinite sljedeæe: utipkajte nekoliko znakova, zatim ih izbri¹ite + stisnuv¹i nekoliko puta. Ne brinite o promjeni ove + datoteke; neæete izmijeniti glavnu verziju uputa. Ovo je va¹a + osobna kopija. + +Kad red teksta postane prevelik za jedan red na ekranu, red se +"nastavlja" na drugi ekranski red. Obrnuta kosa crta ("\") na desnom +rubu ukazuje na red koji je nastavljen. + +>> Upisujte tekst dok ne doðete do desnog ruba, i nastavite pisati. + Vidjet æete kako se pojavljuje nastavljeni red. + +>> Tipkom bri¹ite tekst dok red teksta opet ne stane na red + ekrana. Kontinuacijski red tada nestaje. + +Mo¾ete izbrisati znak Newline kao i bilo koji drugi znak. Brisanje +znaka Newline izmeðu dva reda ih spaja u jedan red. Ako je novonastali +zajednièki red prevelik da stane na ekranski red, bit æe prikazan +kontinuacijskim redom. + +>> Pomaknite kursor na poèetak reda i pritisnite . Red æe se + spojiti s redom iznad. + +>> Pritisnite tako da ponovno umetnete Newline koji ste + izbrisali. + +Upamtite da se veæini Emacsovih naredbi mo¾e zadati brojaè +ponavljanja; ovo ukljuèuje znakove teksta. Ponavljanje znaka teksta +unosi ga nekoliko puta. + +>> Isku¹ajte sad -- upi¹ite C-u 8 * da upi¹ete ********. + +Sada ste nauèili najosnovnije naèine upisivanja u Emacs i ispravljanja +gre¹aka. Sada mo¾ete i brisati po rijeèima ili redovima. Evo sa¾etka +operacija brisanja: + + bri¹i znak neposredno pred kursorom + C-d bri¹i znak nakon kursora + + M- ubij rijeè prije kursora + M-d ubij rijeè poslije kursora + + C-k ubij od pozicije kursora do kraja reda + M-k ubij do kraja trenutne reèenice + +Uoèite da i C-d nasuprot M- i M-d pro¹iruju paralelu +zaèetu s C-f i M-f (dobro, ba¹ i nije kontrolni znak, ali +nemojmo brinuti o tome). C-k i M-k su na neki naèin slièni C-e i M-e, +po operaciji na redovima, odnosno reèenicama. + +Kad bri¹ete vi¹e od jednog znaka istovremeno, Emacs sprema izbrisani +tekst, tako da ga mo¾ete dobiti natrag. Vraæanje ubijenog teksta zove +se "dobavljanje" (eng. yanking). Mo¾ete dobaviti ubijeni tekst bilo +na isto mjesto gdje je bio ubijen, bilo na neko drugo mjesto u +tekstu. Mo¾ete dobaviti tekst nekoliko puta, èime æete dobiti +vi¹estruke kopije. Komanda za dobavljanje je C-y. + +Uoèite da je razlika izmeðu "ubijanja" i "brisanja" neèega u tome ¹to +se ubijeni tekst mo¾e dobaviti natrag, a izbrisani ne mo¾e. Opæenito, +naredbe koje uklanjaju puno teksta spreme izbrisani tekst, dok ga +naredbe koje bri¹u samo jedan znak ili samo prazne linije i razmake ne +spremaju. + +>> Pomaknite kursor na poèetak reda koji nije prazan. + Zatim pritisnite C-k da ubijete tekst u tom redu. +>> Stisnite C-k drugi put. Vidjet æete da ubija Newline koji prati + taj red. + +Uoèite da jedan C-k ubija sadr¾aj reda, dok drugi C-k ubija sam red, i +mièe sve druge redove prema gore. C-k tretira numerièki argument na +specijalan naèin: ubija toliko redova, i njihov sadr¾aj. Ovo nije +obièno ponavljanje. C-u 2 C-k ubija dva reda i njihove newline; +pritiskanje C-k dvaput ne bi dalo taj rezultat. + +Da povratite zadnji ubijeni tekst i stavite ga gdje je kursor +trenutno, pritisnite C-y. + +>> Poku¹ajte; pritisnite C-y da dobavite tekst. + +Gledajte na C-y kao da dobavljate natrag ne¹to ¹to vam je netko uzeo. +Uoèite da ako ponovite C-k nekoliko puta, sav tekst bit æe spremljen +zajedno, tako da æe ga C-y dobaviti odjednom. + +>> Uèinite to sad, pritisnite C-k nekoliko puta. + +Sad, da bi vratili ubijeni tekst: + +>> Stisnite C-y. Tad spustite kursor nekoliko linija ni¾e i opet + stisnite C-y. Sada vidite kako se kopira tekst. + +©to napraviti ako imate tekst koji ¾elite dobaviti, ali onda ubijete +ne¹to drugo? C-y bi dobavio zadnji tekst. Ali prethodni tekst nije +izgubljen. Mo¾ete ga povratiti koristeæi naredbu M-y. Nakon ¹to +pritisnete C-y i dobijete zadnje ubijeni tekst, pritiskanje M-y ga +zamjenjuje s prethodno ubijenim tekstom. Uzastopno pozivanje M-y +dobavlja sve ranije i ranije tekstove. Kad doðete do teksta koji ste +tra¾ili, ne morate uèiniti ni¹ta posebno da ga zadr¾ite. Samo +nastavite s editiranjem, ostaviv¹i dobavljeni tekst gdje jest. + +Ako pritisnete M-y dovoljno puta, vratit æete se na polaznu toèku +(zadnji ubijeni tekst). + +>> Ubijte jedan red, pomièite se po tekstu, ubijte drugi red. + Zatim pritisnite C-y da biste dobili natrag drugi ubijeni red. + Zatim napravite M-y pa æe taj tekst biti zamijenjen prvim ubijenim + redom. Napravite jo¹ par puta M-y i pogledajte ¹to dobivate. + Nastavite s M-y dok ne vratite drugi ubijeni red, a zatim M-y + pritisnite jo¹ par puta. Ako ¾elite, mo¾ete poku¹ati proslijediti + naredbi M-y pozitivne i negativne argumente. + + +* PONI©TENJE +------------ + +Ako napravite izmjenu u tekstu, pa se zatim predomislite, mo¾ete +poni¹titi (eng. "undo") promjenu naredbom undo, C-x u. + +Obièno, C-x u poni¹tava promjene koje su rezultat jedne naredbe; ako +ponovite C-x u nekoliko puta uzastopce, svako novo ponavljanje +poni¹tava uèinak jo¹ jedne naredbe. + +Ali, postoje dva izuzetka: naredbe koje ne mijenjaju tekst se ne +raèunaju (ovo ukljuèuje naredbe koje mièu kursor i pomièu tekst), a +samo-umeæuæi znakovi se obièno grupiraju u skupine od po 20 (da se +umanji broj C-x u koje morate stisnuti da biste poni¹tili unos +teksta). + +>> Ubijte ovu liniju s C-k, zatim utipkajte C-x u i trebala bi se + ponovno pojaviti. + +C-_ je alternativna naredba za poni¹tenje; ona radi isto kao C-x u, +ali ju je lak¹e utipkati nekoliko puta za redom. Mana C-_ je da na +nekim tipkovnicama nije oèigledno kako je utipkati. Zato ostavljamo i +C-x u. Na nekim terminalima mo¾ete dobiti C-_ kombinacijom CTRL i /. + +Numerièki argument naredbi C-_ ili C-x u slu¾i kao brojaè ponavljanja. + + +* DATOTEKE +---------- + +Da biste za stalno spremili izmjene na tekstu koji editirate, morate ga +spremiti u datoteku. Ako to ne uèinite, tekst æe nestati kada izaðete +iz Emacsa. Svoje izmjene stavljate u datoteku tako ¹to je prvo +"naðete" (ovo se jo¹ naziva i "posjeta" datoteci). + +Nala¾enje datoteke znaèi da vidite sadr¾aj datoteke unutar Emacsa. U +neku ruku, ovo je kao da editirate samu datoteku. Meðutim, izmjene +koje napravite koristeæi Emacs ne postaju trajne dok niste "snimili" +datoteku. Tako mo¾ete izbjeæi ostavljanje poluzavr¹ene datoteke u +sustavu, ako to ne ¾elite. Èak i kad snimate, Emacs ostavlja izvornu +datoteku pod promijenjenim imenom, za sluèaj da se kasnije +predomislite. + +Ako pogledate pri dnu ekrana, vidjet æete red koji poèinje i zavr¹ava +s crticama, i sadr¾i niz "XEmacs: TUTORIAL.hr". Ovaj dio ekrana +uvijek pokazuje naziv datoteke koju posjeæujete. U ovom trenutku vi +posjeæujete datoteku koja se zove "TUTORIAL", a koja je va¹a osobna +kopija Emacsovih uputa. Koju god datoteku na¹li, njen æe se naziv +pojaviti na tom istom mjestu. + +Naredbe za pronala¾enje i spremanje datoteka se razlikuju od drugih +naredbi koje ste dosad upoznali, po tome ¹to se sastoje od dva znaka. +Obje poèinju znakom Control-x; mnoge od njih rade s datotekama, +spremnicima i povezanim stvarima. Ove naredbe su dugaèke dva, tri ili +èetiri znaka. + +Jo¹ jedna stvar u vezi naredbe za nala¾enje datoteke je da morate reæi +koju datoteku ¾elite. Ka¾emo da naredba "èita argument s terminala" +(u ovom sluèaju, argument je naziv datoteke). Kad utipkate naredbu + + C-x C-f Naði datoteku + +Emacs tra¾i od vas da upi¹ete naziv datoteke. Naziv datoteke koji +upi¹ete pojavljuje se u donjem redu ekrana. Taj donji red naziva se +minispremnik (minibuffer) kad se koristi za tu vrstu unosa. Mo¾ete +koristiti uobièajene Emacsove naredbe da editirate naziv datoteke. + +Dok unosite naziv datoteke (ili za bilo kojeg unosa iz minispremnika), +mo¾ete otkazati naredbu pomoæu C-g. + +>> Upi¹ite C-x C-f, potom C-g. Ovo otkazuje minispremnik, a takoðer + otkazuje i naredbu C-x C-f koja je koristila minispremnik. Tako + nijedna datoteka neæe biti pronaðena. + +Kad zavr¹ite s upisom imena datoteke, stisnite za kraj. Tad +æe naredba C-x C-f otpoèeti svoj posao, i naæi datoteku koju ste +izabrali. Minispremnik nestaje kad naredba C-x C-f zavr¹i. + +Ubrzo æe se sadr¾aj datoteke pojaviti na ekranu, i moæi æete editirati +sadr¾aj. Kad po¾elite trajno saèuvati svoje izmjene, upi¹ite naredbu + + C-x C-s Spremi datoteku + +Ovo kopira tekst unutar Emacsa u datoteku na disku. Prvi put kad ovo +uèinite, Emacs æe preimenovati izvornu datoteku u novo ime, tako da je +ne izgubite. Novo se ime tvori dodavanjem znaka ~ na izvorno ime +datoteke. + +Kad snimanje zavr¹i, Emacs ispi¹e ime snimljene datoteke. Trebali +biste snimati relativno èesto, tako da ne izgubite puno ako sustav +padne. + +>> Upisav¹i C-x C-s, spremite svoju kopiju uputa. + Na dnu ekrana bi trebalo pisati "Wrote ...TUTORIAL.hr". + +Primjedba: Na nekim sustavima, tipkanje C-x C-s æe zamrznuti ekran, i +neæete vi¹e vidjeti Emacsov output. To znaèi da "prednost" +operativnog sustava zvana "kontrola toka" (eng. flow control) presreæe +C-s i ne da mu da doðe do Emacsa. Odmrznite sustav tipkom C-q. Tada +pogledajte odjeljak "Spontaneous Entry to Incremental Search" +Emacsovog manuala za savjet kako se nositi s ovom "predno¹æu". + +Mo¾ete naæi postojeæu datoteku, da je pogledate ili editirate. Mo¾ete +takoðer naæi i datoteku koja jo¹ ne postoji. Tako se stvaraju nove +datoteke Emacsom: naðite datoteku, koja æe ispoèetka biti prazna, i +poènite unositi tekst u datoteku. Kad zatra¾ite "snimanje" datoteke, +Emacs æe zaista stvoriti datoteku s tekstom koji ste unijeli. Od tad +pa nadalje, mo¾ete smatrati da editirate veæ postojeæu datoteku. + + +* SPREMNICI +----------- + +Ako naðete jo¹ jednu datoteku s C-x C-f, ona prva ostaje unutar +Emacsa. Mo¾ete se vratiti natrag na nju nalazeæi je opet s C-x C-f. +Ovako mo¾ete otvoriti prilièan broj datoteka unutar Emacsa. + +>> Stvorite datoteku imena "foo" tipkajuæi C-x C-f foo . + Tad unesite neki tekst, editirajte ga, i snimite "foo" utipkav¹i + C-x C-s. + Konaèno, upi¹ite C-x C-f TUTORIAL.hr da se vratite na + upute. + +Emacs pohranjuje tekst svake datoteke u objektu zvanom "spremnik" +(eng. buffer). Nala¾enje datoteke otvara novi spremnik unutar +Emacsa. Popis spremnika koji se nalaze u trenutnom pozivu Emacsa +mo¾ete dobiti sa + + C-x C-b Izlistaj spremnike + +>> Sada isku¹ajte C-x C-b. + +Uoèite kako svaki spremnik ima naziv, a mo¾e imati i ime datoteke koje +se odnosi na datoteku èiji sadr¾aj je u njemu. Neki spremnici ne +odgovaraju ni jednoj datoteci. Na primjer, spremnik "*Buffer List*" nema +ni jednu datoteku. To je spremnik koji sadr¾i spisak spremnika koji +je stvorila naredba C-x C-b. BILO KOJI tekst koji vidite u nekom +Emacsovom prozoru uvijek je dio nekog spremnika. + +>> Pritisnite C-x 1 da se rije¹ite spiska spremnika. + +Ako promijenite tekst jedne datoteke, zatim naðete drugu datoteku, ova +prva neæe biti snimljena. Njene promjene ostaju unutar Emacsa, u +spremniku te datoteke. Ovo je korisno, ali to i znaèi da je potreban +pogodan naèin snimanja datoteke prvog spremnika. Bilo bi nespretno +prebacivati se natrag u spremnik s C-x C-f samo zato da ga se snimi s +C-x C-s. Zato imamo + + C-x s Snimi neke spremnike. + +C-x s vas pita za svaki spremnik koji sadr¾i izmjene koje niste +snimili. Za svaki takav spremnik pita vas da li ga ¾elite snimiti. + +>> Upi¹ite red teksta, potom upi¹ite C-x s. + Pitat æe vas ¾elite li snimiti spremnik s nazivom TUTORIAL.hr. + Odgovorite potvrdno na pitanje, tipkajuæi "y". + + +* UPORABA IZBORNIKA +------------------- + +Ako ste na X terminalu, uoèit æete izbornik na vrhu Emacsovog prozora. +Mo¾ete koristiti izbornik za pristup svim uobièajenim Emacsovim +naredbama, kao ¹to su "find file". Ovo æe vam u poèetku biti lak¹e, +jer neæete morati pamtiti tipke za neku naredbu. Jednom kad vam rad u +Emacsu postane ugodan, lako æete poèeti koristiti naredbe s +tipkovnice, jer svaka stavka izbornika sadr¾i i odgovarajuæu tipku za +pokretanje naredbe. + +Uoèite da postoji puno stavki koje nemaju ekvivalent na tipkovnici. +Na primjer, izbornik "Buffers" prikazuje sve raspolo¾ive spremnike +redosljedom posljednje uporabe. Mo¾ete se prebaciti na bilo koji +spremnik tako da jednostavno izaberete njegov naziv u izborniku +"Buffers". + + +* UPORABA MI©A +-------------- + +Kad radite pod X-ima, Emacs je u potpunosti integriran s mi¹em. +Mo¾ete pozicionirati tekstualni kursor pritisnuv¹i lijevu tipku mi¹a +na ¾eljenom mjestu, mo¾ete izabrati tekst povlaèeæi lijevu tipku mi¹a +po ¾eljenom tekstu. (Ili, na drugi naèin, pritisnuti lijevu tipku +mi¹a s jedne strane, zatim se pomaknuti na drugu stranu, i koristiti +Shift i tipku mi¹a za izbor teksta.) + +Ako ¾elite ubiti izabrani tekst, mo¾ete pritisnuti C-w, ili izabrati +Cut u izborniku Edit. Uoèite da ovo dvoje *nije* isto: C-w samo +sprema tekst unutar Emacsa (slièno C-k, kako je opisano gore), dok Cut +radi ovo, i jo¹ sprema tekst u X clipboard, gdje do njega mogu +pristupiti ostale aplikacije. + +Tekst s X clipboarda mo¾ete dobiti koristeæi stavku Paste izbornika +Edit. + +Srednja tipka mi¹a se obièno koristi za izbor stvari koje su vidljive +na ekranu. Na primjer, ako uðete u Info (Emacsovu on-line +dokumentaciju) koristeæi C-h i ili izbornik Help, mo¾ete pratiti +osvijetljeni link pritisnuv¹i srednju tipku mi¹a na njemu. Slièno, +ako tipkate naziv datoteke (npr. na "Find File" promptu) i pritisnete +TAB da vidite moguænosti, mo¾ete stisnuti srednju tipku mi¹a na neku +od moguænosti, da je izaberete. + +Desna tipka mi¹a poziva "skoèni" izbornik. Sadr¾aj ovog izbornika +ovisi o modu u kojem se trenutno nalazite, i obièno sadr¾i nekoliko +èesto kori¹tenih naredbi, tako da se do njih lak¹e doðe. + +>> Sada pritisnite desnu tipku mi¹a. + +Morat æete dr¾ati tipku da zadr¾ite izbornik. + + +* PRO©IRENJE SKUPA NAREDBI +-------------------------- + +Emacsovih naredbi ima puno puno vi¹e nego ¹to bi ikad moglo stati na +sve kontrolne i meta znakove. Emacs ovo zaobilazi pro¹irenim +(eXtended) naredbama. One dolaze u dva oblika: + + C-x Pro¹iri znak. Praæena jednim znakom. + M-x Pro¹irena naredba s imenom. Praæena dugim imenom. + +Postoje naredbe koje jesu korisne, ali ih se rabi manje nego naredbe o +kojima smo dosad govorili. Veæ ste vidjeli dvije: naredbe s +datotekama C-x C-f za nala¾enje i C-x C-s za snimanje. Jo¹ jedan +primjer je naredba kojom se izlazi iz Emacsa -- to je naredba C-x +C-c. (ne brinite o gubljenju izmjena koje ste napravili; C-x C-c vam +nudi da snimite svaku izmijenjenu datoteku prije no ¹to izaðe iz +Emacsa). + +Naredbom C-z *privremeno* izlazite iz Emacsa -- tako da se mo¾ete +nakon nekog vremena opet vratiti u Emacs. + +Na sustavima koji to dozvoljavaju, C-z "suspendira" Emacs; to jest, +vraæa se u ljusku, ali ne uni¹tava Emacs. U veæini ljuski, mo¾ete +nastaviti rad Emacsa naredbom `fg', ili s `%emacs'. + +Na sustavima koji ne podr¾avaju suspendiranje, C-z stvara podljusku +koja radi pod Emacsom, tako da mo¾ete pokrenuti druge programe i +naknadno se vratiti u Emacs; ona neæe zaista "izaæi" iz Emacsa. U +ovom sluèaju, ljuskina naredba `exit' je uobièajen naèin povratka iz +podljuske u Emacs. + +Vrijeme za C-x C-c je onda kad se kanite odlogirati. Takoðer, to je +ispravna stvar kad je Emacs pozvan iz èitaèa po¹te, ili nekog drugog +programa, jer se oni ne moraju znati nositi sa suspendiranjem Emacsa. +U normalnim okolnostima, meðutim, ako se ne kanite odlogirati, bolje +je suspendirati Emacs s C-z nego izaæi iz njega. + +Postoji puno C-x naredbi. Evo spiska onih koje ste nauèili: + + C-x C-f Naði datoteku. + C-x C-s Snimi datoteku. + C-x C-b Popis spremnika. + C-x C-c Izaði iz Emacsa. + C-x u Poni¹ti zadnju naredbu. + +Imenovane pro¹irene naredbe su naredbe koje se jo¹ rjeðe koriste, ili +se koriste samo unutar stanovitih modova. Primjer je naredba +replace-string, koja globalno zamjenjuje jedan niz drugim. Kad +napi¹ete M-x, Emacs æe vam dati prompt na dnu ekrana, a vi trebate +samo napisati naziv naredbe. U ovom sluèaju, "replace-string". Samo +napi¹ite "repl s", i Emacs æe dovr¹iti ime. Zavr¹ite naziv +naredbe s . + +Naredba replace-string tra¾i dva argumenta -- niz koji se zamjenjuje, +i niz kojim æe se zamijeniti. Zavr¹ite svaki argument s . + +>> Pomaknite kursor na prazan red dva reda ispod ovoga. Zatim + napi¹ite M-x repl s promijenioizmijenio. + + Primijetite kako se ovaj red promijenio: zamijenili ste rijeè + p-r-o-m-i-j-e-n-i-o s "izmijenio" gdje god se ova pojavila, nakon + poèetnog polo¾aja kursora. + + +* AUTOMATSKO SNIMANJE +--------------------- + +Kada ste promijenili datoteku, ali je jo¹ niste snimili, va¹e bi +izmjene mogle biti izgubljene ako raèunalo padne. Da vas za¹titi od +ovoga, Emacs povremeno ispisuje "auto save" (automatsko snimanje) +datoteku za svaku datoteku koju editirate. Auto-save datoteka ima # +na poèetku i na kraju imena; na primjer, ako se va¹a datoteka zove +"hello.c", njezina æe se auto-save datoteka zvati "#hello.c#". Kad +snimite datoteku na normalan naèin, Emacs æe izbrisati njezinu +auto-save datoteku. + +Ako raèunalo padne, mo¾ete obnoviti svoje automatski spremljene +promjene tako ¹to normalno naðete datoteku, i napi¹ete +M-x recover file . Kad vas pita za potvrdu, upi¹ite +yes za nastavak i vratite automatski snimljene podatke. + + +* PROSTOR ZA PORUKE +------------------- + +Ako Emacs vidi da pi¹ete naredbe polako, pokazat æe vam ih na dnu +ekrana na mjestu koje se zove "prostor za poruke" (eng. echo area). +Prostor za poruke je na najni¾em redu ekrana. + + +* STATUSNI RED +-------------- + +Red odmah iznad prostora za poruke se zove "statusni red" +(eng. modeline). Statusni red izgleda otprilike ovako: + +--**-XEmacs: TUTORIAL.hr (Fundamental)--L670--58%---------------- + +Ovaj red pru¾a korisne informacije o statusu Emacsa i tekstu koji +editirate. + +Veæ znate ¹to je ime datoteke -- to je datoteka koju ste na¹li. +-NN%-- predstavlja va¹ trenutni polo¾aj u tekstu; to znaèi da je NN +postotaka teksta iznad vrha ekrana. Ako je vrh teksta na ekranu, +pisat æe --Top-- umjesto --00%--. Ako je kraj teksta na ekranu, pisat +æe --Bot--. Ako gledate u tako kratak tekst da sav stane na ekran, u +statusnoj liniji æe pisati --All--. + +Zvjezdice na poèetku znaèe da ste napravili izmjene na tekstu. +Neposredno po posjeti ili snimanju datoteke, taj dio statusne linije +nema zvjezdica, veæ samo crtice. + +Dio statusne linije u zagradama govori u kojem se modu editiranja +nalazite. Podrazumijeva se Fundamentalni mod, koji trenutno koristite. +On je primjer "glavnog moda". + +Emacs ima puno razlièitih glavnih modova. Neki od njih su predviðeni +za editiranje razlièitih jezika i/ili vrsta teksta, kao ¹to je Lisp +mod, tekst mod, itd. U bilo kojem trenutku jedan i samo jedan glavni +mod je aktivan, i njegovo se ime nalazi na statusnom redu, gdje sada +stoji "Fundamental". + +Svaki glavni mod èini da se nekoliko naredbi pona¹a razlièito. Na +primjer, postoje naredbe za stvaranje komentara u programu, a buduæi +da svaki programski jezik ima drugaèiju predod¾bu o tome kako komentar +izgleda, svaki glavni mod razlièito unosi komentare. Svaki glavni mod +je ime jedne pro¹irene naredbe, ¹to je i naèin kako se mo¾ete +prebaciti u taj mod. Na primjer, M-x fundamental-mode je naredba koja +vas prebacuje u Fundamental mod. + +Ako editirate tekst na hrvatskom, kao ¹to je ova datoteka, vjerojatno +biste trebali koristiti tekstualni mod. +>> Napi¹ite M-x text-mode. + +Ne brinite, nijedna od naredbi koje ste nauèili neæe promijeniti Emacs +na znaèajan naèin. Ali mo¾ete uoèiti da M-f i M-b sad tretiraju +apostrofe kao dio rijeèi. U fundamentalnom modu M-f i M-b su +tretirali apostrofe kao separatore rijeèi. + +Glavni modovi obièno rade suptilne izmjene poput navedene: veæina +naredbi rade "isti posao" u svakom glavnom modu, ali funkcioniraju s +malom razlikom. + +Da biste vidjeli dokumentaciju trenutnog glavnog moda, pritisnite +C-h m. + +>> Pritisnite jo¹ jednom C-u C-v da dovedete ovu liniju do vrha ekrana. +>> Utipkajte C-h m, da vidite kako se tekstualni mod razlikuje od + fundamentalnog moda. +>> Pritisnite q da uklonite dokumentaciju s ekrana. + +Glavni modovi se nazivaju glavnima, jer postoje jo¹ i sporedni +modovi. Sporedni su modovi nisu zamjena za glavne modove, veæ njihova +usputna modifikacija. Svaki sporedni mod mo¾e biti ukljuèen ili +iskljuèen za sebe, neovisno o ostalim sporednim modovima, i neovisno o +glavnom modu. Tako mo¾ete ne biti niti u jednom sporednom modu, ili u +jednom sporednom modu, ili u kombinaciji nekoliko sporednih modova. + +Jedan vrlo koristan sporedni mod, naroèito za editiranje hrvatskog +teksta, jest mod za automatsko popunjavanje (Auto Fill mode). Kad je +ovaj mod ukljuèen, Emacs automatski lomi linije izmeðu rijeèi kad god +umetanjem teksta stvorite red koji je pre¹irok. + +Mo¾ete ukljuèiti Auto Fill mod pisanjem M-x auto-fill-mode. +Kad je mod ukljuèen, iskljuèujete ga s M-x auto-fill-mode. +Kad je mod iskljuèen, ova ga naredba ukljuèuje, kad je ukljuèen, ona +ga iskljuèuje. + +>> Napi¹ite M-x auto-fill-mode sad. Potom umeæite tekst "asdf " + dok god se red ne razdvoji na dva dijela. Morate stavljati razmake + izmeðu, jer Auto Fill lomi redove samo na razmacima. + +Rub je obièno postavljen na 70 znakova, ali ga mo¾ete promijeniti +naredbom C-x f. Rub koji ¾elite postaviti pode¹avate numerièkim +argumentom. + +>> Utipkajte C-x f s argumentom 20. (C-u 2 0 C-x f). + Potom upi¹ite neki tekst, i gledajte kako Emacs lomi redove dulje + od 20 znakova. Tad postavite rub natrag na 70 ponovno + upotrijebiv¹i C-x f. + +Ako napravite promjene u sredini paragrafa, Auto Fill mod ga neæe +cijelog reformatirati. +Za preoblikovanje paragrafa, utipkajte M-q (Meta-q) s kursorom unutar +paragrafa. + +>> Pomaknite kursor na prethodni paragraf, i stisnite M-q. + + +* TRA®ENJE +---------- + +Emacs mo¾e tra¾iti nizove (grupe uzastopnih znakova ili rijeèi) bilo +prema naprijed ili prema natrag kroz tekst. Tra¾enje niza je naredba +kojom se pomièe kursor; ona æe pomaknuti kursor do sljedeæeg mjesta na +kom se niz pojavljuje. + +Emacsova naredba za tra¾enje se razlikuje od sliènih naredbi veæine +editora po tome ¹to je "postupna" (eng. incremental). To znaèi da se +pretra¾ivanje odvija dok upisujete niz koji tra¾ite. + +Naredba kojom poèinjete naredbu je C-s za tra¾enje prema naprijed, i +C-r za tra¾enje unatrag. ALI ÈEKAJTE! Nemojte ih odmah isprobati. + +Kad utipkate C-s, primijetit æete da se tekst "I-search" pojavljuje +kao prompt u prostoru za poruke. Ovo vam ka¾e da je Emacs u stanju +postupnog tra¾enja, i da èeka da upi¹ete ¹to ¾elite tra¾iti. + zaustavlja tra¾enje. + +>> Sad stisnite C-s da zapoènete pretra¾ivanje. POLAKO, znak po znak, + utipkajte rijeè `kursor', radeæi stanku izmeðu znakova da uoèite + ¹to se dogaða s kursorom. + Sad ste na¹li "kursor", jednom. +>> Stisnite C-s opet, da naðete sljedeæe pojavljivanje "kursora". +>> Sad stisnite èetiri puta, i gledajte kako se kursor + pomièe. +>> Stisnite da prekinete tra¾enje. + +Jeste li vidjeli ¹to se dogodilo? Za vrijeme inkrementalnog tra¾enja, +Emacs poku¹ava otiæi na mjesto gdje se pojavljuje niz kojeg ste do sad +utipkali, osvjetljavajuæi ga zbog preglednosti. Za odlazak na +sljedeæe mjesto gdje se "kursor" pojavljuje, samo opet stisnite C-s. +Ako ni jedno takvo mjesto ne postoji, Emacs æe se oglasiti zvuènim +signalom i reæi vam da pretraga niju uspjela ("failing"). Pretragu +mo¾ete prekinuti i pomoæu C-g. + + +PRIMJEDBA: Na nekim sustavima, tipkanje C-s æe smrznuti sustav i vi¹e +neæete vidjeti daljnji Emacsov output. To pokazuje da "prednost" +operativnog sustava zvana "kontrola toka" (eng. flow control) presreæe +C-s i ne da mu da doðe do Emacsa. Pritisak na C-q æe odmrznuti ekran. +Tad pogledajte odjeljak "Spontaneous Entry to Incremental Search" +Emacsovog manuala za savjet kako se nositi s ovom "predno¹æu". + +Ako za vrijeme postupnog tra¾enja pritisnete , uoèit æete +da je zadnji znak niza izbrisan i da se pretraga vratila na zadnje +mjesto. Na primjer, pretpostavimo da ste stisnuli "k" ne bi li na¹li +prvo pojavljivanje "k". Ako sad stisnete "u", kursor æe se pomaknuti +na mjesto prvog pojavljivanja "ku". Sad stisnite . Ovo æe +ukloniti "u" iz tra¾enog niza, i pomaknuti kursor natrag na prvu +pojavu "k". + +Ako ste usred tra¾enja i stisnete kontrolni ili meta znak (s nekoliko +iznimki -- znakova koji imaju posebno znaèenje pri tra¾enju, kao ¹to +su C-s i C-r), tra¾enje se zaustavlja. + +C-s zapoèinje pretragu koja tra¾i bilo koju pojavu tra¾enog niza NAKON +trenutnog polo¾aja kursora. Ako ¾elite tra¾iti ne¹to ¹to se +pojavljuje ranije u tekstu, stisnite C-r. Sve ¹to smo rekli za C-s +vrijedi i za C-r, jedino ¹to je smjer pretrage suprotan. + + +* VI©ESTRUKI PROZORI +-------------------- + +Jedna od lijepih stvari u Emacsu je ¹to mo¾ete prikazati vi¹e prozora +na ekranu istovremeno. + +>> Dovedite kursor do ovog reda i stisnite C-u 0 C-l. + +>> Sad stisnite C-x 2, ¹to razdvaja ekran na dva prozora. + Oba prozora prikazuju ove upute. Kursor ostaje u gornjem prozoru. + +>> Stisnite C-M-v da pomaknete donji prozor. + (Ako nemate pravu tipku Meta, stisnite ESC C-v.) + +>> Stisnite C-x o ("o" kao eng. "other", drugi) da pomaknete kursor u + donji prozor. +>> U donjem se prozoru pomièite s C-v i M-v. + Nastavite èitati ove upute u gornjem prozoru. + +>> Opet stisnite C-x o da pomaknete kursor natrag u gornji prozor. + Kursor u gornjem prozoru je upravo gdje je prije bio. + +Mo¾ete stalno koristiti C-x o za pomicanje meðu prozorima. Svaki +prozor ima vlastiti polo¾aj kursora, ali samo jedan prozor zapravo +prikazuje kursor. Sve uobièajene naredbe za editiranja djeluju na +prozoru u kojem je kursor. Taj prozor nazivamo "izabrani prozor" +(eng. selected window). + +Naredba C-M-v korisna je kad editirate tekst u jednom prozoru, a drugi +koristite za referencu. Tada mo¾ete dr¾ati kursor uvijek u prozoru +gdje editirate, a napredovati kroz onaj drugi s C-M-v. + +C-M-v je primjer CONTROL-META znaka. Ako imate pravu tipku META, +mo¾ete dobiti C-M-v dr¾eæi zajedno i CTRL i META, dok tipkate v. Nema +veze da li je CTRL ili META "prvi", jer obje ove tipke rade +mijenjajuæi znakove koji pi¹ete. + +Ako nemate pravu META tipku, a umjesto nje koristite ESC, tad je +poredak va¾an: morate stisnuti ESC praæen s CTRL-v; CTRL-ESC v neæe +raditi. Razlog za ovo je ¹to je ESC tipka za sebe, a ne modifikator. + +>> Pritisnite C-x 1 (u gornjem prozoru) da se rije¹ite donjeg + prozora. + +(Da ste stisnuli C-x 1 u donjem prozoru, rije¹ili biste se gornjeg. +Ovu naredbu mo¾ete shvatiti kao "Ostavi samo jedan prozor -- onaj u +kojem veæ jesam.") + +Ne morate prikazivati isti spremnik u oba prozora. Ako pritisnete C-x +C-f da naðete datoteku u jednom prozoru, drugi se prozor ne mijenja. +Mo¾ete naæi datoteku u svakom prozoru neovisno o drugima. + +Evo jo¹ jednog naèina da upotrijebite dva prozora za prikaz dvije +razlièite stvari: + +>> Utipkajte C-x 4 C-f, a zatim ime neke od va¹ih datoteka. + Zavr¹ite s . Uoèite da se navedena datoteka pojavila u + donjem prozoru, a takoðer i kursor. + +>> Pritisnite C-x o za povrat u gornji prozor, i C-x 1 da uklonite + donji. + + +* REKURZIVNE RAZINE EDITIRANJA +------------------------------ + +Ponekad æete po¾eljeti uæi u ono ¹to se zove "rekurzivna razina +editiranja" (eng. recursive editing level). Ovo je naznaèeno uglatim +zagradama u statusnom redu, koje okru¾uju okrugle zagrade oko naziva +moda. Na primjer, vidjeli biste [(Fundamental)] umjesto +(Fundamental). + +Za izlazak iz rekurzivnog editiranja, pritisnite ESC ESC ESC. To je +vi¹enamjenska naredba za "izlazak". Mo¾ete je koristiti i za +uklanjanje dodatnih prozora, kao i za izlazak iz minispremnika. + +>> Stisnite M-x za ulazak u minispremnik; potom utipkajte ESC ESC ESC + za izlaz. + +Iz rekurzivne razine editiranja ne mo¾ete izaæi s C-g. To je zato ¹to +se C-g koristi za otkazivanje naredbi i argumenata UNUTAR te razine +editiranja. + + +* DODATNA POMOÆ +--------------- + +U ovim smo uputama poku¹ali dati upravo toliko informacija da mo¾ete +poèeti koristiti Emacs. Toliko je toga prisutno u Emacsu da bi bilo +nemoguæe sve to ovdje objasniti. Meðutim, mo¾da po¾elite nauèiti vi¹e +o Emacsu, jer on ima jo¹ puno korisnih prednosti. Emacs ima naredbe +za èitanje dokumentacije o Emacsovim naredbama. Ove naredbe "pomoæi" +sve poèinju sa znakom Control-h, koji se zove "znak za pomoæ" +(eng. the Help character). + +Za kori¹tenje naredbi pomoæi, stisnite znak C-h, praæen znakom koji +ka¾e koju vrstu pomoæi ¾elite. Ako ste ZAISTA izgubljeni, stisnite +C-h ? i Emacs æe vam reæi koje vrste pomoæi mo¾e dati. Ako stisnete +C-h, ali se predomislite, samo pritisnite C-g za otkaz pomoæi. + +(Na nekim je sistemima promijenjeno znaèenje C-h. Ovo se zaista ne bi +smjelo raditi, pa se po¾alite sistemskom administratoru. U meðuvremenu, +ako C-h ne prikazuje poruku o pomoæi na dnu ekrana, poku¹ajte upisati +M-x help RET umjesto toga.) + +Osnovna naredba pomoæi je C-h c. Napi¹ite C-h, potom c, i znak ili +niz znakova, i Emacs æe pokazati vrlo kratak opis naredbe. + +>> Stisnite C-h c Control-p. + Poruka bi trebala biti poput: + + C-p runs the command previous-line + + (C-p pokreæe naredbu previous-line) + +Ovo vam ka¾e "ime funkcije". Imena funkcija se koriste uglavnom za +mijenjanje i pro¹irivanje Emacsa. Ali buduæi da se imena funkcija +biraju tako da pokazuju ¹to naredba radi, ona mogu poslu¾iti i kao +vrlo kratka dokumentacija -- dovoljna da vas podsjeti na naredbu koju +veæ znate. + +Vi¹e-znakovne naredbe kao ¹to su C-x C-s i (ako nemate tipku META, +EDIT ili ALT) v su takoðer dozvoljene nakon C-h c. + +Za vi¹e podataka o naredbi, pritisnite C-h k umjesto C-h c. + +>> Stisnite C-h k Control-p. + +Osim imena, sad vidite i dokumentaciju funkcije u Emacsovom prozoru. +Kad zavr¹ite s èitanjem ispisa, stisnite q da se rije¹ite teksta. + +Evo nekoliko korisnih moguænosti C-h: + + C-h f Opi¹i funkciju. Upi¹ete ime funkcije. + +>> Poku¹ajte stisnuti C-h f previous-line. + Ovo æe ispisati sve ¹to Emacs zna o funkciji koja implementira + naredbu C-p. + + C-h a Hiper Apropos. Upi¹ite rijeè, i Emacs æe popisati sve + funkcije i varijable èija imena sadr¾e rijeè. Naredbe + koje se mogu izvr¹iti s Meta-x bit æe oznaèene + zvjezdicom slijeva. + +>> Utipkajte C-h a newline. + +Ovo prikazuje hipertekstualni spisak svih funkcija i varijabli s +"newline" u imenima. Stisnite , ili pritisnite srednju tipku +mi¹a da saznate vi¹e o funkciji ili varijabli. Stisnite `q' za izlaz +iz hiper-aproposa. + + +* ZAKLJUÈAK +----------- + +Upamtite, za trajan izlaz iz Emacsa stisnite C-x C-c. Za privremeni +izlaz u ljusku upotrijebite C-z. (pod X-ima, ovo ikonizira trenutni +Emacsov okvir.) + +Ove upute su predviðene da budu razumljive svim novim korisnicima, pa +ako vam je ne¹to ovdje nejasno, nemojte sjediti i kriviti sebe - +¾alite se! + + +KOPIRANJE +--------- + +Ove upute potjeèu iz duge loze Emacsovih uputa, poèev¹i od onih koje +je napisao Stuart Cracraft za izvorni Emacs. Ben Wing je dopisao +poglavlje o X Windowsima. Martin Buchholz i Hrvoje Nik¹iæ su dodali +jo¹ ispravki vezanih uz XEmacs. + +Na Hrvatski preveo Hrvoje Nik¹iæ, uz dodatnu lekturu Denisa Pleiæa. + +Ova verzija uputa je, kao i GNU Emacs, pod autorskim pravima, i dolazi +s dozvolom redistribuiranja uz sljedeæe uvjete: + +(c) 1985, 1996 Free Software Foundation, sva prava zadr¾ana. + + Svakome je dozvoljeno praviti ili distribuirati nepromijenjene + kopije ovog dokumenta, na bilo kojem mediju, uz uvjet da su + saèuvane poruka o autorskim pravima i dozvolama, i da distributer + daje drugima prava za daljnju redistribuciju, kako ovdje pi¹e. + + Dozvoljena je distribucija izmijenjenih verzija ovog dokumenta ili + njegovih djelova, pod gore navedenim uvjetima, uz dodatni uvjet da + sadr¾i obavijest o zadnjoj promjeni. + +Uvjeti kopiranja samog Emacsa su slo¾eniji, ali u istom duhu. Molimo +vas da proèitate datoteku COPYING, i da podijelite kopije GNU Emacsa +svojim prijateljima. Pomozite nam zgaziti opstrukcionizam +("vlasni¹tvo") nad softverom koristeæi, pi¹uæi i dijeleæi slobodan +softver! + + +This tutorial descends from a long line of Emacs tutorials +starting with the one written by Stuart Cracraft for the original Emacs. +Ben Wing updated the tutorial for X Windows. Martin Buchholz and +Hrvoje Niksic added more corrections for XEmacs. + +This version of the tutorial, like GNU Emacs, is copyrighted, and +comes with permission to distribute copies on certain conditions: + +Copyright (c) 1985, 1996 Free Software Foundation + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +The conditions for copying Emacs itself are more complex, but in the +same spirit. Please read the file COPYING and then do give copies of +GNU Emacs to your friends. Help stamp out software obstructionism +("ownership") by using, writing, and sharing free software! diff -r d3e9274cbc4e -r e45d5e7c476e etc/TUTORIAL.jp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.jp Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,741 @@ + ============================== + $BF|K\8l(B GNUEMACS(Mule) $BF~LgJT(B + ============================== + +$BCm0U!'(B $B$3$NF~LgJT$O!"!V=,$&$h$j47$l$m!W$r%b%C%H!<$K:n@.$5$l$F$$$^(B + $B$9!#(B">>" $B$+$i;O$^$k9T$O!"$=$N;~2?$r$9$Y$-$+$r;X<($7$F$$$^$9!#(B + + + Mule $B$N%3%^%s%I$rF~NO$9$k$H$-$K$O!"0lHLE*$K%3%s%H%m!<%k!&%-! $B%3%s%H%m!<%k!&%-!<$r2!$7$?$^$^!"(B<$BJ8;z(B>$B%-!<$r2!$7$^$9!#Nc$($P!"(B + C-f $B$O!"%3%s%H%m!<%k!&%-!<$r2!$7$J$,$i(B f $B$N%-!<$r2!$9$3$H$r(B + $B0UL#$7$^$9!#(B +<> + >> $B$=$l$G$O!"(BC-v$B!J(BView Next Screen; $B $B%(%9%1!<%W!&%-!<$r2!$7$F$+$iN%$7!"$=$l$+$i(B<$BJ8;z(B>$B%-!<$r2!$7$^(B + $B$9!#(B + +$BCm0U!'(B <$BJ8;z(B>$B$O!"BgJ8;z$G$b>.J8;z$G$b%3%^%s%I$H$7$F$OF1$80UL#$K$J$j(B + $B$^$9!#%a%?%-!<$,;H$($k$J$i$P(B ESC <$BJ8;z(B> $B$NBe$o$j$K(B M-<$BJ8;z(B> + ($B%a%?%-!<$r2!$7$?$^$^(B<$BJ8;z(B>$B%-!<$r2!$9(B) $B$,;H$($^$9!#(B + +$B=EMW$G$9!'(B Emacs$B$r=*N;$5$;$?$$;~$O!"(BC-x C-c $B$r%?%$%W$7$^$9!#(BEmacs$B$r(Bcsh + $B$+$i5/F0$7$F$$$k>l9g!"%5%9%Z%s%I$9$k!J0l;~E*$K;_$a$k(B)$B$3$H$,(B + $B=PMh$^$9!#(BEmacs$B$r%5%9%Z%s%I$9$k$K$O!"(BC-z$B$r%?%$%W$7$^$9!#(B + + + $B$5$F!"$3$l$+$i$O!"0l2hLLJ,FI$_=*$($?$i!"(BC-v $B$rF~NO$7$F9T$C$F2<$5$$!#(B + + $BA0$N2hLL$H> ESC v $B$H(B C-v $B$r;H$C$F!"A08e$K0\F0$9$k$3$H$r2?2s$+;n$7$F$_$J$5$$!#(B + +$BMWLs(B +==== + $B%U%!%$%k$r2hLLKh$K8+$F9T$/$K$O!"$9!#$3$N$H$-!"85%+!<%=%k$N$"$C$?9T$,(B + $B2hLL$NCf1{$K$/$k$h$&$K$9$k(B + + >> $B:#%+!<%=%k$,$I$3$K$"$k$+!"$=$N6a$/$K$I$s$J%F%-%9%H$,=q$+$l$F$$$k(B + $B$+$r3P$($J$5$$!#(BC-l $B$r%?%$%W$7!"%+!<%=%k$,$I$3$K0\F0$7$?$+!"$=$N(B + $B6a$/$N%F%-%9%H$O$I$&$J$C$?$+$rD4$Y$F$_$J$5$$!#(B + +$B4pK\E*$J%+!<%=%k$N@)8f(B +====================== + + $B2hLLKh$N0\F0$O$G$-$k$h$&$K$J$j$^$7$?!#:#EY$O!"2hLL$NCf$G!"FCDj$N>l=j$K(B +$B0\F0$9$k$?$a$NJ}K!$r21$($^$7$g$&!#$3$l$K$O$$$/$D$+$N$d$jJ}$,$"$j$^$9!#0l$D(B +$B$NJ}K!$O!"A0(B(previous)$B$l!"(BC-p, C-n, C-f,C-b $B$K3d$jEv$F$i$l$F(B +$B$*$j!"8=:_$N>l=j$+$i?7$7$$>l=j$K%+!<%=%k$r0\F0$5$;$^$9!#?^$G=q$1$P!"(B + + + $BA0$N9T!$(BC-p + : + : + $B8e$NJ8;z!$(BC-b .... $B8=:_$N%+!<%=%k0LCV(B .... $B@h$NJ8;z!$(BC-f + : + : + $B$l!"(BPrevious, Next, Backward, Forward $B$NF,J8;z$K$J$C$F(B +$B$$$k$N$G!"21$($d$9$$$G$7$g$&!#$3$l$i$O!"4pK\E*$J%+!<%=%k0\F0%3%^%s%I$G$"$j!"(B +$B$$$D$G$b;H$&$b$N$G$9!#(B + + >> C-n $B$r2?2s$+%?%$%W$7!"!J:#!"$"$J$?$,FI$s$G$$$k!K$3$N9T$^$G%+!<%=(B + $B%k$r0\F0$5$;$J$5$$!#(B + + >> C-f $B$r;H$C$F9T$NCf$[$I$K0\F0$7!"(BC-p $B$G2?9T$+>e$K0\F0$7$F$_$J$5(B + $B$$!#%+!<%=%k$N0LCV$NJQ2=$KCm0U$7$J$5$$!#(B + + >> $B9T$N@hF,$G(B C-b $B$r%?%$%W$7$F$_$J$5$$!#%+!<%=%k$O$I$3$K0\F0$7$^$9$+(B + $B!)$5$i$K$b$&>/$7(B C-b $B$r%?%$%W$7!":#EY$O(B C-f $B$G9TKv$NJ}$KLa$j$J$5(B + $B$$!#%+!<%=%k$,9TKv$r1[$($k$H$I$&$J$j$^$9$+!)(B + + + $B2hLL$N@hF,$dKvHx$r1[$($F%+!<%=%k$r0\F0$5$;$h$&$H$9$k$H!"$=$NJ}8~$K$"$k(B +$B%F%-%9%H$,0\F0$7$FMh$F!"%+!<%=%k$O>o$K2hLLFb$K$"$k$h$&$K$5$l$^$9!#(B + + >> C-n $B$r;H$C$F!"%+!<%=%k$r2hLL$N2> ESC f $B$d(B ESC b $B$r2?2s$+%?%$%W$7$F$_$J$5$$!#(BC-f $B$d(B C-b $B$HJ;MQ$7$F(B + $B$_$J$5$$!#(B + + C-f $B$d(B C-b $B$KBP$9$k!"(BESC f $B$d(B ESC b $B$NN`;w@-$KCmL\$7$^$7$g$&!#B?$/$N(B +$B>l9g!"(BESC <$BJ8;z(B>$B$OJ8=q4X78$N=hM}$K;H$o$l!"0lJ}(BC-<$BJ8;z(B>$B$O$=$l$h$j$b$b$C$H4p(B +$BK\E*$JBP>]!JJ8;z$H$+9T$H$+!K$KBP$9$kA`:n$K;H$o$l$^$9!#(B + + C-a $B$H(B C-e $B$bCN$C$F$$$FJXMx$J%3%^%s%I$G$9!#(BC-a $B$O%+!<%=%k$r9T$N@hF,$K(B +$B0\F0$5$;!"(BC-e $B$O9T$NKvHx$K0\F0$5$;$^$9!#(B + + + >> C-a $B$r#22s!"$=$l$+$i(B C-e $B$r#22sF~NO$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I(B + $B$r#22s0J>e7+JV$7$F$b!"%+!<%=%k$O$=$l0J>e0\F0$7$J$$$3$H$KCm0U!#(B + + $B$"$HFs$D!"4JC1$J%+!<%=%k0\F0%3%^%s%I$,$"$j$^$9!#%U%!%$%k$N@hF,$K0\F0$9(B +$B$k(B ESC < $B$H!"%U%!%$%k$NKvHx$K0\F0$9$k(B ESC > $B$G$9!#(B + + $B%F%-%9%HCf$G%+!<%=%k$NB8:_$9$k0LCV$r!V%]%$%s%H!W$H8F$S$^$9!#8@$$$+$($l(B +$B$P!"%+!<%=%k$O!"%F%-%9%H$N$I$3$K%]%$%s%H$,$"$k$+$r2hLL>e$G<($7$F$$$k$N$G$9!#(B + + $B0J2<$KC1=c$J0\F0A`:n$K$D$$$FMWLs$7$^$9!#$3$N$J$+$K$O!"C18l$d9TC10L$G$N(B +$B0\F0%3%^%s%I$b4^$^$l$F$$$^$9!#(B + + C-f $B0lJ8;z@h$K?J$`(B + C-b $B0lJ8;z8e$KLa$k(B + + ESC f $B0lC18l@h$K?J$`(B + ESC b $B0lC18l8e$KLa$k(B + + C-n $B $B%U%!%$%k$N:G8e$K0\F0(B + + >> $B3F!9$N%3%^%s%I$r;n$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I$O!":G$b$7$P$7$P(B + $B;H$o$l$k$b$N$G$9!#:G8e$NFs$D$G$O!"$3$N>l=j$H$ON%$l$?$H$3$m$K0\F0(B + $B$9$k$N$G!"(B C-v $B$d(B ESC v $B$r;H$C$F$3$3$KLa$C$FMh$k$h$&$K$7$J$5$$!#(B + + Emacs$B$NB>$N%3%^%s%I$HF1MM$K!"$3$l$i$N%3%^%s%I$K$O!"7+$jJV$7$N2s?t$r;X(B +$BDj$9$k0z?t(B $B$rM?$($k$3$H$,$G$-$^$9!#$=$N$?$a$K$O!"%3%^%s%I$rF~NO$9$kA0$K!"(B +C-u$B$KB3$$$F7+$jJV$92s?t$rF~NO$7$^$9!#(B + + $BNc$($P!"(BC-u 8 C-f $B$H$9$k$H!"#8J8;zJ,@h$K0\F0$7$^$9!#(B + + >> C-n $B$"$k$$$O(B C-p $B$KE,Ev$J0z?t$r;XDj$7$F!"0l2s$N0\F0$G$J$k$Y$/$3(B + $B$N9T$N6a$/$KMh$k$h$&$K$7$F$_$J$5$$!#(B + + C-v $B$d(B ESC v $B$K$D$$$F$O>/$70c$$$^$9!#$3$N>l9g!";XDj$5$l$??t$N9T$@$12h(B +$BLL$r0\F0$9$k$3$H$K$J$j$^$9!#(B + + >> C-u 3 C-v $B$HF~NO$7$F$_$J$5$$!#(B + + $B85$KLa$k$K$O!"(BC-u 3 ESC v $B$r;H$($P$h$$$N$G$9!#(B + +$BCf;_%3%^%s%I(B +============ + + C-g $B$H$$$&%3%^%s%I$G!"F~NO$rI,MW$H$9$k$h$&$J%3%^%s%I$rCf;_$9$k$3$H$,(B +$B$G$-$^$9!#Nc$($P!"0z?t$rF~NO$7$F$$$kESCf$d!"#2$D0J>e$N%-!> C-u 100 $B$r%?%$%W$7$F0z?t$r#1#0#0$K@_Dj$7!"(BC-g $B$r%?%$%W$7$J$5$$!#(B + $B$=$N$"$H$G(B C-f $B$r%?%$%W$7$F$_$J$5$$!#2?J8;z0\F0$7$^$7$?$+!)$b$7(B + $B4V0c$C$F(B ESC $B$rF~NO$7$F$7$^$C$?;~$b!"(BC-g $B$rF~NO$9$l$PC$;$^(B + $B$9!#(B + +$B%(%i!<(B +====== + + $B;~$K$O!"(BEmacs$B$G5v$5$l$F$$$J$$A`:n$r$7$F$7$^$&$3$H$,$"$j$^$9!#Nc$($P!"(B +$B%3%^%s%I$NDj5A$5$l$F$$$J$$%3%s%H%m!<%k!&%-!<$rF~NO$7$F$7$^$C$?;~$K$O!"(BEmacs +$B$O%Y%k$rLD$i$7!"$5$i$K!"2hLL$N0lHV2<$K!"2?$,0-$+$C$?$+$rI=<($7$^$9!#(B + + Emacs$B$N%P!<%8%g%s$K$h$C$F$O!"$3$NF~LgJT$K=q$+$l$F$$$k$3$H$rl9g$,$"$jF@$^$9!#$=$NMM$J>l9g$K$O!"%(%i!<%a%C%;!<%8$,I=<($5$l$^$9$+$i!"(B +$B2?$+%+!<%=%k0\F0%-!<$r2!$7$F!"$=$N$l$KBP$7$F%F%-%9%H$r(B +$BI=<($9$k$3$H$,$G$-$^$9!#%X%k%W$d!"4v$D$+$N%3%^%s%I$+$i$N=PNO$rI=<($9$k$?$a(B +$B$K8=$l$?M>J,$J%&%#%s%I%&$r>C$9$?$a$K!"$N%&%#%s%I%&$r>C$7$F!"%+!<%=%k$N$"$k%&%#%s%I%&$r!"2hLLA4BN(B +$B$K9-$2$^$9!#(B + + >> $B%+!<%=%k$r$3$N9T$K;}$C$F$-$F!"(BC-u 0 C-l $B$H%?%$%W$7$^$9!#(B + + >> C-h k C-f $B$H%?%$%W$7$J$5$$!#?7$7$$%&%#%s%I%&$,(B C-f $B%3%^%s%I$N%I%-(B + $B%e%a%s%H$rI=<($9$k$?$a$K8=$l$k$HF1;~$K!"$3$N%&%#%s%I%&$,$I$N$h$&(B + $B$K=L$`$+$r4Q;!$7$J$5$$!#(B + + >> C-x 1$B$H%?%$%W$7$F!"%I%-%e%a%s%H$N8=$o$l$F$$$?%&%#%s%I%&$r>C$7$J$5(B + $B$$!#(B + +$BA^F~$H:o=|(B +========== + + $B%F%-%9%H$r%?%$%W$7$?$1$l$P!"C1$K$=$l$r%?%$%W$9$k$@$1$G9=$$$^$;$s!#L\$K(B +$B8+$($kJ8;z!J(B'A','7','*','$B$"(B'$B$J$I!K$O(BEmacs$B$K$h$C$F%F%-%9%H$G$"$k$H$_$J$5$l!"(B +$B$=$N$^$^A^F~$5$l$^$9!#9T$N=*$o$j$O2~9TJ8;z$GI=$5$l!"$3$l$rF~NO$9$k$K$O(B + $B$r%?%$%W$7$^$9!#(B + + $BD>A0$KF~NO$7$?J8;z$r:o=|$9$k$K$O!"(B $B$rF~NO$7$^$9!#(B $B$O!"(B +$B%-!<%\!<%I$G!V(BDelete$B!W$H=q$$$F$"$k%-!<$r2!$7$FF~NO$7$^$9!#!V(BDelete$B!W$N$+$o(B +$B$j$K!V(BRubout$B!W$H=q$$$F$"$k$+$bCN$l$^$;$s!#$h$j0lHLE*$K$O!"(B $B$O!"8=:_(B +$B%+!<%=%k$N$"$k0LCV$ND>A0$NJ8;z$r:o=|$7$^$9!#(B + + >> $BJ8;z$r$$$/$D$+%?%$%W$7!"$=$l$+$i$=$l$i$r(B $B$r;H$C$F:o=|$7(B + $B$J$5$$!#(B + + >> $B1&%^!<%8%s$r1[$($k$^$G%F%-%9%H$r%?%$%W$7$J$5$$!#%F%-%9%H$,0l9T$N(B + $BI}0J>e$KD9$/$J$k$H!"$=$N9T$O2hLL$+$i$O$_=P$7$F!V7QB3!W$5$l$^$9!#(B + $B1&C<$K$"$k(B'\'$B5-9f$O!"$=$N9T$,7QB3$5$l$F$$$k$3$H$rI=$7$F$$$^$9!#(B + Emacs$B$O!"8=:_JT=8Cf$N0LCV$,8+$($k$h$&$K9T$r%9%/%m!<%k$7$^$9!#2hLL(B + $B$N1&$"$k$$$O:8$NC<$K$"$k(B'\'$B5-9f$O!"$=$NJ}8~$K9T$,$^$@B3$$$F$$$k$3(B + $B$H$rI=$7$F$$$^$9!#(B + + $B$3$l$O!"J8>O$G@bL@$9$k$h$j> $B@h$[$IF~NO$7$?!"7QB3$5$l$?9T$N>e$K%+!<%=%k$r$b$C$F$$$-!"(BC-d $B$G%F(B + $B%-%9%H$r:o=|$7$F!"%F%-%9%H$,0l9T$K<}$^$k$h$&$K$7$F$_$J$5$$!#7QB3(B + $B$rI=$9(B'\'$B5-9f$O>C$($^$7$?$M!#(B + + >> $B%+!<%=%k$r9T$N@hF,$K0\F0$7!"(B $B$rF~NO$7$J$5$$!#$3$l$O$=$N9T(B + $B$ND>A0$N9T6g@Z$j$r:o=|$9$k$N$G!"$=$N9T$,A0$N9T$H$D$J$,$C$F$7$^$$(B + $B$^$9!#$D$J$,$C$?9T$,2hLL$NI}$h$jD9$/$J$k$H!"7QB3$NI=<($,$5$l$k$G(B + $B$7$g$&!#(B + + >> $B$r2!$7$F!"$b$&0lEY9T6g@Z$j$rA^F~$7$J$5$$!#(B + + Emacs$B$N$[$H$s$I$N%3%^%s%I$O!"7+$jJV$7$N2s?t$rM?$($k$3$H$,$G$-$^$9!#$3(B +$B$N$3$H$O!"J8;z$NA^F~$K$D$$$F$bEv$F$O$^$j$^$9!#(B + + >> C-u 8 * $B$HF~NO$7$F$_$J$5$$!#$I$&$J$j$^$7$?$+!#(B + + $BFs$D$N9T$N4V$K6uGr9T$r:n$j$?$$>l9g$K$O!"FsHVL\$N9T$N@hF,$K9T$-!"(BC-o $B$r(B +$BF~NO$7$^$9!#(B + + >> $BE,Ev$J9T$N@hF,$K9T$-!"$=$3$G(B C-o $B$rF~NO$7$F$_$J$5$$!#(B + + $B$3$l$G!"(BEmacs$B$G!"%F%-%9%H$rF~NO$7!"$^$?4V0c$$$r=$@5$9$k$b$C$H$b4pK\E*(B +$B$JJ}K!$r3X$s$@$3$H$K$J$j$^$9!#J8;z$HF1$8MM$K!"C18l$d9T$b:o=|$9$k$3$H$,$G$-(B +$B$^$9!#:o=|A`:n$K$D$$$FMWLs$9$k$H $B%+!<%=%k$ND>A0$NJ8;z$r:o=|(B + C-d $B%+!<%=%k$N$"$kJ8;z$r:o=|(B + + ESC $B%+!<%=%k$ND>A0$NC18l$r:o=|(B + ESC d $B%+!<%=%k0LCV0J9_$K$"$kC18l$r:o=|(B + + C-k $B%+!<%=%k0LCV$+$i9TKv$^$G$r:o=|(B + + $B2?$+$r:o=|$7$?8e$G!"$=$l$r85$KLa$7$?$/$J$k$3$H$,$"$j$^$9!#(BEmacs$B$O!"0l(B +$BJ8;z$h$j$bBg$-$$C10L$G:o=|$r9T$C$?;~$K$O!":o=|$7$?FbMF$rJ]B8$7$F$*$-$^$9!#(B +$B85$KLa$9$K$O!"(BC-y $B$r;H$$$^$9!#Cm0U$7$?$$$N$O!"(BC-y $B$r:o=|$r9T$C$?>l=j$@$1$G(B +$B$O$J$/!"$I$3$K$G$b=PMh$k$3$H$G$9!#(BC-y $B$O!"J]B8$5$l$?%F%-%9%H$r8=:_%+!<%=%k(B +$B$N$"$k>l=j$KA^F~$9$k$?$a$N%3%^%s%I$G$9$+$i!"$3$l$r;H$C$F%F%-%9%H$N0\F0$r9T(B +$B$&$3$H$,$G$-$^$9!#(B + + $B:o=|$r9T$&%3%^%s%I$K$O!"(B"Delete" $B%3%^%s%I$H!"(B"Kill" $B%3%^%s%I$H$,$"$j$^(B +$B$9!#(B"Kill" $B%3%^%s%I$G$O:o=|$5$l$?$b$N$OJ]B8$5$l$^$9$,!"(B"Delete" $B%3%^%s%I$G(B +$B$OJ]B8$5$l$^$;$s!#$?$@$7!"7+$jJV$72s?t$,M?$($i$l$k$H!"J]B8$5$l$^$9!#(B + + >> C-n $B$r#22s$[$I%?%$%W$7$F!"2hLL$NE,Ev$J>l=j$K0\F0$7$J$5$$!#$=$7$F!"(B + C-k $B$G!"$=$N9T$r:o=|$7$J$5$$!#(B + + $B0l2sL\$N(B C-k $B$G$=$N9T$NFbMF$,:o=|$5$l!"$b$&0lEY(B C-k $B$rF~NO$9$k$H!"$=$N(B +$B9T<+?H$,:o=|$5$l$^$9!#$b$7!"(BC-k $B$K7+$jJV$72s?t$r;XDj$7$?>l9g$K$O!"$=$N2s?t(B +$B$@$1$N9T$,!JFbMF$H9T<+?H$H$,F1;~$K!K:o=|$5$l$^$9!#(B + + $B:#:o=|$5$l$?%F%-%9%H$O!"J]B8$5$l$F$$$k$N$G!"$=$l$r> C-y $B$r;n$7$F$_$J$5$$!#(B + + C-k $B$r2?EY$bB3$1$F9T$&$H!":o=|$5$l$k%F%-%9%H$O!"$^$H$a$FJ]B8$5$l!"(BC-y +$B$G!"$=$NA4$F$,> C-k $B$r2?EY$b%?%$%W$7$F$_$J$5$$!#(B + + >> $B%F%-%9%H$r$N%F%-%9%H$r:o=|$9$k$H$I$&(B +$B$J$k$G$7$g$&$+!#(BC-y $B$O!"$b$C$H$b:G6a:o=|$5$l$?$b$N$r> $B9T$r:o=|$7!"%+!<%=%k$r0\F0$5$;!"JL$N9T$r:o=|$7$J$5$$!#(BC-y $B$r9T$&(B + $B$H!"#2HVL\$N9T$,F@$i$l$^$9!#(B + +$BC$7(B(UNDO) +============== + + $B$$$D$G$b!"%F%-%9%H$rJQ99$7$?$1$l$I$b!"$=$l$r$b$H$KLa$7$?$$$H$-$O(BC-x u +$B$GD>$j$^$9!#IaDL$O4V0c$($?%3%^%s%I$rL58z$K$9$kF/$-$r$7$^$9!#7+$jJV$7$F(BUNDO +$B$r9T$J$*$&$H$9$k;~$O!"2?EY$b$=$N%3%^%s%I$r9T$J$($P=PMh$k$h$&$K$J$C$F$$$^$9!#(B + + >> $B$3$N9T$r(BC-k$B$G>C$7$F2<$5$$!#$=$7$F!"(BC-x u$B$GLa$7$F2<$5$$!#(B + + C-_$B$O!"(BUNDO$B$r9T$J$&!"$b$&0l$D$N%3%^%s%I$G$9!#5!G=$O!"(BC-x u$B$HF1$8$G$9!#(B + + C-_$B$d(BC-x u$B$K(BUNDO$B$N2s?t$r!"M?$($k$3$H$,=PMh$^$9!#(B + + +$B%U%!%$%k(B +======== + + $B%F%-%9%H$X$NJQ99$r1J5WE*$K$9$k$?$a$K$O!"$=$l$r%U%!%$%k$KJ]B8$7$J$1$l$P(B +$B$J$j$^$;$s!#J]B8$5$l$J$$$H!"$[$I$3$7$?JQ99$O!"(BEmacs$B$r=*N;$9$k$HF1;~$K<:$o$l(B +$B$F$7$^$$$^$9!#(B + + $B$$$^8+$F$$$k%U%!%$%k$KBP$7$F!"$"$J$?$NJT=8$r9T$C$?$b$N$r=q$-9~$_$^$9!#(B +$B$$$^8+$F$$$k%U%!%$%k$H$O!"4JC1$K$$$($PJT=8$7$F$$$k%U%!%$%k<+BN$N$3$H$G$9!#(B + + $B$"$J$?$,%U%!%$%k$r%;!<%V!JJ]B8$9$k!K$9$k$^$G!":#$^$G$NJQ99$OJT=8$7$F$$(B +$B$k%U%!%$%k$K=q$-9~$^$l$k;v$O$"$j$^$;$s!#$=$l$O!"$"$J$?$,$=$N$h$&$K9T$$$?$/(B +$B$J$$$N$K!"ESCf$^$GJQ99$r2C$($?$b$N$,>!A0(B +$B$rJQ$($F%*%j%8%J%k$N%U%!%$%k$r;D$7$^$9!#(B + +$BHw9M(B: $B$^$?!"(BEmacs$B$OITB,$N;vBV$KBP$7!"0lDj$N%?%$%_%s%0$4$H$K<+F0E*(B + $B$KJT=8$7$F$$$k%U%!%$%k$NFbMF$rL>A0$rJQ$($?%U%!%$%k$K%;!<%V$7(B + $B$^$9!#$3$l$K$h$C$F!"K|0l$N>l9g$O9T$C$?$NJQ99$KBP$7:G>.8B$NHo(B + $B32$G:Q$`$h$&$K$J$C$F$$$^$9!#(B + + $B2hLL$N2<$NJ}$r8+$k$H!"$3$N$h$&$J46$8$G%b!<%I%i%$%s$,I=<($5$l$F$$$k$H;W(B +$B$$$^$9!#(B + + +($BNc(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- + + + $B$3$N(BEmacs$B%A%e!<%H%j%"%k$N%3%T!<$O(BMULE.tut$B$H8F$P$l$F$$$^$9!#%U%!%$%k$r(B +$B%U%!%$%s%I!J%U%!%$%k$r8+$D$1$F%P%C%U%!$KFI$_9~$`$3$H!K$9$k$H!"(BMULE.tut$B$NIt(B +$BJ,$KI=<($5$l$^$9!#Nc$($P!"(Bnew-file$B$H$$$&L>A0$N%U%!%$%k$r%U%!%$%s%I$7$?$J$i(B +$B$P!"(B"Mule: new-file"$B$H$$$&%b!<%I%i%$%s$K$J$k$G$7$g$&!#(B + +$BCm0U!'(B $B%b!<%I%i%$%s$K$D$$$F$O8e$[$I@bL@$7$^$9!#>/$7$*BT$A$r!#(B + + $B%U%!%$%k$r%U%!%$%s%I$7$?$j!"%;!<%V$7$?$j$9$k%3%^%s%I$O!"$3$l$^$G$N$b$N(B +$B$H$O0c$$!"#2$D$NJ8;z$+$i$J$C$F$$$^$9!#(BC-x $B$KB3$$$FF~NO$9$kJ8;z$,!"%U%!%$%k(B +$B$KBP$7$F9T$&A`:n$rI=$7$^$9!#(B + + $B$b$&0l$D$3$l$^$G$N$b$N$H0c$&E@$O!"%U%!%$%s%I$N;~!"%U%!%$%kL>$r(BEmacs$B$K(B +$BLd$o$l$^$9!#$3$N$3$H$r!"Cl9g$O%U%!%$%kL>$G$9!#(B + + C-x C-f $B%U%!%$%k$r8+$D$1$k!J%U%!%$%s%I$9$k!K(B + + Emacs$B$O%U%!%$%kL>$rJ9$$$F$-$^$9!#$=$l$O!"2hLL$N2<$N9T$K8=$l$^$9!#%U%!(B +$B%$%kL>$r;XDj$7$F$$$kItJ,$O!"%_%K%P%C%U%!$H8F$P$l$k$b$N$G$9!#%_%K%P%C%U%!$O(B +$B$3$NMM$J;H$o$lJ}$r$7$^$9!#%U%!%$%kL>$KB3$$$F!"%j%?!<%s%-!<$r2!$9$H!"%_%K%P(B +$B%C%U%!$KI=<($5$l$F$$$?FbMF$O$b$&I,MW$G$O$J$/$J$k$N$G>C$($F$7$^$$$^$9!#(B + + >> C-x C-f$B$H%?%$%W$7$?8e$K(BC-g$B$H%?%$%W$7$F2<$5$$!#%_%K%P%C%U%!$NFbMF(B + $B$rC$7!"$^$?!"(BC-x C-f$B%3%^%s%I$bC$7$^$9!#$H8@$&Lu$G!"2?$b(B + $B%U%!%$%k$r8+$D$1$k$h$&$J$3$H$O$7$^$;$s!#(B + + $B:#EY$O%U%!%$%k$r%;!<%V$7$F$_$^$7$g$&!#:#$^$G$NJQ99$rJ]B8$9$k$?$a$K$OA0$r$D$1$i$l$F;D$5$l$F$$$k$N$GFbMF$O<:$o$l$^$;$s!#$=(B +$B$N?7$7$$L>A0$O%*%j%8%J%k$N%U%!%$%k$NL>A0$K(B'~'$B$r$D$1$?$b$N$G$9!#(B + + $B%;!<%V$,=*$o$k$H!"(BEmacs$B$O%;!<%V$7$?%U%!%$%k$NL>A0$rI=<($7$^$9!#(B + + >> C-x C-s$B$H%?%$%W$7$F%A%e!<%H%j%"%k$N%3%T!<$r%;!<%V$7$F2<$5$$!#$=$N(B + $B;~!"2hLL$N2<$NJ}$K(B"Wrote ...../MULE.tut"$B$HI=<($5$l$^$9!#(B + + $B?7$7$$%U%!%$%k$r:n$k;~!"$"$?$+$b0JA0$+$i$"$C$?%U%!%$%k$r%U%!%$%s%I$9$k(B +$B$h$&$J%U%j$r$7$^$9!#$=$&$7$F!"$=$N%U%!%$%s%I$7$?%U%!%$%k$K%?%$%W$7$F$$$-$^(B +$B$9!#(B + + $B%U%!%$%k$r%;!<%V$7$h$&$H$7$?;~$K=i$a$F!"(BEmacs$B$O:#$^$GJT=8$7$F$$$?FbMF(B +$B$r%U%!%$%k$NCf$K=q$-9~$_$^$9!#(B + + +$B%P%C%U%!(B +======== + + $B$b$7!"#2HVL\$N%U%!%$%k$r(B C-x C-f $B$G> C-x C-b $B$H%?%$%W$7$J$5$$!#$=$l$>$l$N%P%C%U%!$,$I$N$h$&$KL>A0$r;}(B + $B$C$F$$$k$+!"$=$7$F!"$I$N$h$&$J%U%!%$%kL>$r$D$1$F$$$k$N$+4Q;!$7$J(B + $B$5$$!#(B + + $B%P%C%U%!$K$O%U%!%$%k$H0lCW$J$$$b$N$b$"$j$^$9!#$?$H$($P!"(B +"*Buffer List*" $B$H$$$&%U%!%$%k$O$"$j$^$;$s!#$3$l$O(B C-x C-b $B$K$h$C$F:n$i$l(B +$B$?%P%C%U%!%j%9%H$KBP$7$F$N%P%C%U%!$G$9!#(B + + $B$"$J$?$,8+$F$$$k(BEmacs$B%&%#%s%I%&Fb$K$"$k!"$I$s$J%F%-%9%H$G$b!"$$$:$l$+(B +$B$N%P%C%U%!Fb$K$"$j$^$9!#(B + + >> $B%P%C%U%!%j%9%H$r>C$9$?$a(B C-x 1 $B$H%?%$%W$7$J$5$$!#(B + + $B$b$7!"$"$k%U%!%$%k$N%F%-%9%H$KJQ99$r9T$J$C$F$+$i!"B>$N%U%!%$%k$rA0$K$h$k3HD%!#B3$1$F%3%^%s%I$NL>A0$rF~NO$7$^$9!#(B + + $B$3$l$i$O0lHL$K!"JXMx$@$1$l$I$b!"$3$l$^$G8+$F$-$?$b$N$[$IIQHK$K$OMQ$$$i(B +$B$l$J$$%3%^%s%I$N$?$a$N$b$N$G$9!#(BC-x C-f $B!J%U%!%$%s%I!K$d(B C-x C-s$B!J%;!<%V!K(B +$B$O$3$NCg4V$G$9!#B>$K!"(BC-x C-c$B!J%(%G%#%?$N=*N;!K$b$=$&$G$9!#(B + + C-z$B$O(BEmacs$B$rH4$1$k$N$KNI$/;H$o$l$kJ}K!$G$9!#(BEmacs$B$r=*N;$9$k$3$H$J$/!"(B +$B0lC6!"(Bcsh$B$N%l%Y%k$KLa$k$K$O0lHVNI$$J}K!$H8@$($k$G$7$g$&!#(BC-z$B$r9T$J$o$l$F$b(B +Emacs$B$O%9%H%C%W$7$F$$$k$@$1$G!"FbMF$,GK2u$5$l$k$H$$$&$3$H$O$"$j$^$;$s!#(B + +$BCm0U(B: $B$?$@$7(BX-window$B$G9T$J$C$F$$$k>l9g!"$b$7$/$O;HMQ$7$F$$$k%7%'%k(B + $B$,(Bsh$B$N;~$O!"$3$N8B$j$G$O$"$j$^$;$s!#(B + + + C-x $B%3%^%s%I$O!"$?$/$5$s$"$j$^$9!#$9$G$K3X$s$@$b$N$O0J2<$N$b$N$G$9!#(B + + C-x C-f $B%U%!%$%k$NJT=8!J(BFind$B!K(B + C-x C-s $B%U%!%$%k$NJ]B8!J(BSave$B!K(B + C-x C-b $B%P%C%U%!%j%9%H$NI=<((B + C-x C-c $B%(%G%#%?$r=*N;$9$k!#%U%!%$%k$NJ]B8$O!"<+F0E*$K$O9T$o$l$^$;(B + $B$s!#$7$+$7!"$b$7%U%!%$%k$,JQ99$5$l$F$$$l$P!"%U%!%$%k$NJ]B8(B + $B$r$9$k$N$+$I$&$+$rJ9$$$F$-$^$9!#J]B8$7$F=*N;$9$kIaDL$NJ}K!(B + $B$O!"(BC-x C-s C-x C-c $B$H$9$k$3$H$G$9!#(B + + $BL>A0$K$h$k3HD%%3%^%s%I$K$O!"$"$^$j;H$o$l$J$$$b$N$d!"FCDj$N%b!<%I$G$7$+(B +$B;H$o$J$$$b$N$J$I$,$"$j$^$9!#Nc$H$7$F!"(B"command-apropos" $B$r$H$j$"$2$^$9!#$3(B +$B$N%3%^%s%I$O%-!<%o!<%I$rF~NO$5$;!"$=$l$K%^%C%A$9$kA4$F$N%3%^%s%I$NL>A0$rI=(B +$B<($7$^$9!#(BESC x $B$H%?%$%W$9$k$H!"%9%/%j!<%s$N2<$K(B "M-x" $B$,I=<($5$l$^$9!#$3$l(B +$B$KBP$7$F!"A0!J:#$N>l9g!"(B"command-apropos"$B!K$rF~NO$7$^$9!#(B +"command-a" $B$^$GF~NO$7$?8e%9%Z!<%9$rF~$l$l$P!"8e$NItJ,$O<+F0E*$KJd$o$l$^$9!#(B +$B$3$N8e!"%-!<%o!<%I$rJ9$+$l$^$9$+$i!"CN$j$?$$J8;zNs$r%?%$%W$7$^$9!#$J$*!"%-!<(B +$B%o!<%I$rF~$l$J$$$H!"A4$F$N%3%^%s%I$,I=<($5$l$^$9!#(B + + >> ESC x $B$r%?%$%W$7!"B3$1$F!"(B"command-apropos" $B$"$k$$$O(B + "command-a" $B$H%?%$%W$7$^$9!#" + $B$H%?%$%W$7$^$9!#(B + + $B8=$l$?!V%&%#%s%I%&!W$r>C$9$K$O!"(BC-x 1 $B$H%?%$%W$7$^$9!#(B + +$B%b!<%I%i%$%s(B +============ + + $B$b$7$f$C$/$j$H%3%^%s%I$rBG$C$?$J$i$P!"2hLL$N2l=j$KBG$C$?$b$N$,I=<($5$l$^$9!#%(%3!<%(%j%"$O2hLL$N(B1$B$P$s2<$N9T$G$9!#$=$N(B +$B$9$0>e$N9T$O!"%b!<%I%i%$%s$H8F$P$l$F$$$^$9!#%b!<%I%i%$%s$O$3$s$JIw$KI=<($5(B +$B$l$F$$$k$G$7$g$&!#(B + + [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- + + +$BCm0U(B: NN%$B$N(BNN$B$O?t;z$,F~$C$F$$$^$9!#$"$J$?$,;H$C$F$$$k(BEmacs$B$N%b!<(B + $B%I%i%$%s$H0c$&$+$bCN$l$J$$$1$I!"92$F$J$$$h$&$K!#Nc$($P!";~4V(B + $B$d(Buptime$B$,I=<($5$l$F$$$k$N$O!"(Bdisplay-time$B$H$$$&5!G=$,F0$$$F(B + $B$$$k$+$i$G$9!#(B + + $B$3$N9T$K$h$C$FB?$/$NM-MQ$J>pJs$,F@$i$l$^$9!#(B + + + $B:#!"$"$J$?$,8+$F$$$k%U%!%$%kL>$rI=<($7$F$$$^$9!#(BNN%$B$O8=:_%9%/%j!<%s>e(B +$B$K%U%!%$%k$N0lHV>e$+$i2?%Q!<%;%s%HL\$,I=<($5$l$F$$$k$+$r<($7$F$$$^$9!#%U%!(B +$B%$%k$N0lHV:G=i$rI=<($7$F$$$k$J$i$P!"(B--Top--$B$HI=<($5$l$F$^$9!#%U%!%$%k$N0lHV(B +$B:G8e$rI=<($7$F$$$k$J$i$P!"(B--Bot--$B$HI=<($5$l$^$9!#2hLL$NCf$K%U%!%$%k$NA4$F$,(B +$BI=<($5$l$F$$$k$J$i$P!"(B--All--$B$HI=<($5$l$^$9!#(B + + $B%b!<%I%i%$%s$N>.3g8L$NCf$O!":#$I$s$J%b!<%I$KF~$C$F$$$k$+$r<($7$F$$$^$9!#(B +$B8=:_$O!"%G%U%)%k%H$N(BFundamental$B$KF~$C$F$$$^$9!#$3$l$b%a%8%c!<%b!<%I$N0lNc$G(B +$B$9!#(B + + Emacs$B$O(BLisp mode$B$d(BText mode$B$N$h$&$J$3$H$J$k%W%m%0%i%`8@8l$d%F%-%9%H$K(B +$BBP$7$F%(%G%#%C%H$r9T$&$?$a$N4v$D$+$N%a%8%c!<%b!<%I$r;}$C$F$$$^$9!#$I$s$J;~(B +$B$G$bI,$:$$$:$l$+$N%a%8%c!<%b!<%I$N>uBV$K$J$C$F$$$^$9!#(B + + $B$=$l$>$l$N%a%8%c!<%b!<%I$O4v$D$+$N%3%^%s%I$rA4$/0c$&?6$kIq$$$K$7$F$7$^(B +$B$$$^$9!#Nc$r>e$2$F$_$^$7$g$&!#%W%m%0%i%`$NCf$K%3%a%s%H$r:n$k%3%^%s%I$,$"$j(B +$B$^$9!#%3%a%s%H$r$I$NMM$J7A<0$K$9$k$+$O!"3F%W%m%0%i%`8@8l$K$h$C$F0c$$$^$9$,!"(B +$B$=$l$>$l$N%a%8%c!<%b!<%I$O!"$-$A$s$HF~$l$F$/$l$^$9!#(B + + $B$=$l$>$l$N%a%8%c!<%b!<%I$KF~$k$?$a$N%3%^%s%I$O%b!<%IL>$N3HD%$5$l$?$b$N(B +$B$K$J$C$F$$$^$9!#Nc$($P!"(BM-x fundamental-mode$B$O(BFundamental$B$KF~$k$?$a$N$b$N$G(B +$B$9!#(B + + $B$b$7!"1Q8l$r%(%G%#%C%H$9$k$J$i$P!"(BText mode$B$KF~$j$^$9!#(B + + >> M-x text-mode $B$H%?%$%W$7$J$5$$!#(B + + $B8=:_$N%a%8%c!<%b!<%I$K$D$$$F$N%I%-%e%a%s%H$r8+$?$$;~$O!"(BC-h m$B$H%?%$%W(B +$B$7$^$9!#(B + + >> C-h m $B$r;H$C$F(BText mode$B$H(BFundamental mode$B$N0c$$$rD4$Y$J$5$$!#(B + + >> C-x 1$B$G%I%-%e%a%s%H$r2hLL$+$i>C$7$J$5$$!#(B + + $B:8C<$N(B '[--]' $B$O8=:_$N%-!\$7$$@bL@$O(B +$B!V$?$^$4!W$N%^%K%e%"%k$rD4$Y$F2<$5$$!#(B + + $B$=$N$9$01&$K$O%3!<%IBN7O(B (coding-system) $B$K4X$9$k%U%i%0$N>uBV$,I=(B +$B<($5$l$F$$$^$9!#(BMule $B$O!"%U%!%$%kF~=PNO!"F~NO!"2hLL=PNO$K$D$$$F!"$=$l$>$lFH(B +$BN)$K%3!<%IBN7O$r;XDj$5$;$k$3$H$,=PMh$^$9$,!"DL>o$O%U%!%$%kMQ$N%3!<%IBN7O$N(B +$B%K!<%b%K%C%/$N$_I=<($7$F$$$^$9!#(B + + >> $B%b!<%I%i%$%s>e$K(B"J:","S:",$B$b$7$/$O(B "E:"$B$,I=<($5$l$F$$$k$+$I$&$+3N(B + $BG'$7$J$5$$!#(B + + $B:G=i$N0lJ8;z$,%3!<%IBN7O$N%K!<%b%K%C%/!"> C-x C-k t$B$r(B2$BEY9T$$$J$5$$!#(B + + $BF~NO%b!<%I$,(BJIS$B%3!<%I$N@_Dj$H$J$C$F$$$k;~!"$b$7$"$J$?$N;H$C$F$$$kC$B$b(BM-<$BJ8;z(B>$B$bF1$8F/$-$r$7$^$9!#:#$^$G$N@bL@$G(BESC +<$BJ8;z(B>$B$H9T$J$C$F$$$?$H$3$m$,!"(BM-<$BJ8;z(B>$B$H$J$j$^$9!#Cm0U$7$J$1$l$P$J$i$J$$$N(B +$B$O!"%7%U%H(BJIS$B$d(BEUC$B%3!<%I$N;~$O;HMQ$G$-$^$;$s!#(B + + $B%3!<%IBN7O$N$N@Z$jBX$($O!"3F!9$N%P%C%U%!$KBP$7$F$N$_M-8z$G$9!#$=$l$>$l(B +$B$N!"%3!<%IBN7O;XDj$K$D$$$F$O!"(BC-h a coding-system $B$G8+$k$3$H(B +$B$,=PMh$^$9!#(B + + >> C-h a coding-system $B$G=P$F$/$k%I%-%e%a%s%HCf$N!"(B + set-display-coding-system, set-file-coding-system, + set-process-coding-system $B$N@bL@$rFI$_$J$5$$!#(B + +$B8!:w(B +===== + + $BJ8;zNs$r!"%U%!%$%kFb$G!"A0J}Kt$O8eJ}$K!"C5$9;v$,$G$-$^$9!#8!:w$r;O$a$k(B +$B%3%^%s%I$O!"%+!<%=%k0LCV0J9_$r8!:w$9$k$J$i$P(B C-s$B!"%+!<%=%k0LCV0JA0$J$i$P(B +C-r $B$G$9!#(BC-s $B$r%?%$%W$9$k$H!"%(%3!<%(%j%"$K(B "I-search:"$B$H$$$&J8;zNs$,%W%m(B +$B%s%W%H$H$7$FI=<($5$l$^$9!#(BESC$B$r2!$9$H!"=*N;$G$-$^$9!#(B + + + >> C-s$B$G8!:w$,;O$^$j$^$9!#$=$l$+$i!"$f$C$/$j$H#1J8;z$:$D(B"cursor"$B$H$$(B + $B$&C18l$rF~NO$7$^$9!##1J8;zF~NO$9$k$4$H$K!"%+!<%=%k$O!"$I$s$JF0$-(B + $B$r$7$^$9$+(B? + + >> $B$b$EY(B C-s $B$r%?%$%W$9$k$H!"> $B$r#42sF~NO$7$F!"%+!<%=%k$NF0$-$r8+$J$5$$!#(B + + >> ESC$B$r2!$7$F!"=*N;$7$^$9!#(B + + $BC5$7$?$$J8;zNs$r%?%$%WCf$G$b!"%?%$%W$7$?J8;zItJ,$@$1$G!"8!:w$r;O$a$^$9!#(B +$B$B$rF~NO$9$k$H!"8!:wJ8;zNs$N#1HV8e$m$NJ8;z$,>C$($^$9!#(B +$B$=$7$F!"%+!<%=%k$O!"A02s$N0LCV$KLa$j$^$9!#$?$H$($P!"(B"cu"$B$H%?%$%W$7$F!":G=i(B +$B$N(B"cu"$B$N0LCV$K%+!<%=%k$,F0$$$?$H$7$^$9!#$3$3$G(B$B$rF~NO$9$k$H!"%5!<%A(B +$B%i%$%s$N(B'u'$B$,>C$(!"%+!<%=%k$O!"(B'u'$B$r%?%$%W$9$kA0$K!"%+!<%=%k$,$"$C$?(B'c'$B$N0L(B +$BCV$K!"0\F0$7$^$9!#(B + + $B8!:wuBV$K(B +$BF~$k$3$H$,$"$j$^$9!#%a%8%c!<%b!<%I$N>.3g8L(B'()'$B$N2s$j$rCf3g8L(B'[]'$B$G0O$s$@$b(B +$B$N$,%b!<%I%i%$%s>e$KI=<($5$l$^$9!#Nc$($P!"(B(Fundamental)$B$HI=<($5$l$kBe$o$j$K(B +[(Fundamental)]$B$N$h$&$K$J$j$^$9!#(B + +$BCm0U(B: $B$3$3$G$O%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k<+BN$K$D$$$F$O@bL@$7(B + $B$^$;$s!#(B + + $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1$G$k$?$a$K$O!"(BM-x top-level +$B$H%?%$%W$7$^$9!#(B + + >> $B;n$7$F$_$F2<$5$$!#%9%/%j!<%s$NDl$K(B"Back to top level"$B$HI=<($5$l$^(B + $B$9!#(B + + $BK\Ev$O!"$3$N;n$_$,9T$o$l$?;~$O!"$9$G$K%H%C%W%l%Y%k$K$$$?$N$G$9!#(BM-x +top-level$B$O!"2?$b1F6A$rM?$($F$$$^$;$s!#(B + + $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1=P$k$N$KBP$7$F$O(BC-g$B$O8z$-$^$;(B +$B$s!#(B + + +$B%X%k%W(B +====== + + Emacs$B$K$O!"$?$/$5$s$NLr$KN)$D5!G=$,$"$j!"$3$3$G!"$9$Y$F$r@bL@$9$k$3$H(B +$B$O!"IT2DG=$G$9!#$7$+$7!"$^$@CN$i$J$$B?$/$N5!G=$r3X$V$?$a$K$O!"(B$B$H8F$P(B +$B$l$k(B C-h $B$r%?%$%W$9$k$3$H$G!"$?$/$5$s$N>pJs$rC$9(B +$B$3$H$,$G$-$^$9!#(B + + $B:G$b4pK\E*$J$b$N$O!"(BC-h c $B$G$9!#$3$l$KB3$$$F%-!<$rF~NO$9$k$H!"$=$N%3%^(B +$B%s%I$K$D$$$F$NC;$$@bL@$rI=<($7$^$9!#(B + + >> C-h c C-p $B$H%?%$%W$7$F$_$J$5$$!#(B"C-p runs the command previous- + line"$B$N$h$&$J%a%C%;!<%8$,I=<($5$l$k$O$:$G$9!#(B + + $B8+$?$3$H$O$"$k$,!"3P$($F$O$$$J$$%3%^%s%I$b;W$$=P$;$k$N$G$9!#(BC-x C-s $B$N(B +$B$h$&$JJ#?t$G#1$D$N%3%^%s%I$b(BC-h c $B$N8e$m$KB3$1$i$l$^$9!#(B + + $B$b$C$H>\$7$/CN$j$?$+$C$?$i!"(Bc $B$NBe$o$j$K(B k $B$r;XDj$7$^$9!#(B + + >> C-h k C-p $B$H%?%$%W$7$F$_$J$5$$!#(B + + Emacs$B$N%&%#%s%I%&$K!"%3%^%s%I$NL>A0$H5!G=$,I=<($5$l$^$9!#FI$_=*$($?$i!"(B +C-x 1 $B$H%?%$%W$9$k$H!"H4$1$i$l$^$9!#(B + + $BB>$K$bLr$KN)$D%*%W%7%g%s$,$"$j$^$9!#(B + + C-h f $B%U%!%s%/%7%g%sL>$rF~NO$9$k$H!"%U%!%s%/%7%g%s$rI=<($7$^$9!#(B + + >> C-h f previous-line $B$r%?%$%W$7!"(B $B$r2!$7$J$5$$!#(BC-p $B%3%^%s(B + $B%I$rpJs$rI=<($7$^$9!#(B + + C-h a $B%-!<%o!<%I$rF~NO$9$k$H!"L>A0$K$=$N%-!<%o!<%I$r4^$`!"A4$F$N%3(B + $B%^%s%I$rI=<($7$^$9!#$3$l$i$N%3%^%s%I$O$9$Y$F(BESC x $B$G> C-h a file $B$H%?%$%W$7!"(B$B$r2!$7$J$5$$!#L>A0$K(B"file"$B$H$$$&J8(B + $B;z$r;}$DA4$F$N%3%^%s%I$rI=<($7$^$9!#$^$?!"(Bfind-file $B$d(B write-file + $B$H$$$&L>$N(B C-x C-f $B$d(B C-x C-w $B$N$h$&$J%3%^%s%I$bI=<($5$l$^$9!#(B + +$B$*$o$j$K(B +======== + +$BK:$l$:$K!'(B $B=*N;$9$k$K$O!"(BC-x C-c $B$H$7$^$9!#(B + + + $B$3$NF~LgJT$O!"$^$C$?$/$N=i?4o$KB?$/$N$3$H$,$G$-$k>l9g$K$OFC$K$=$&$G$7$g(B +$B$&!#$=$7$F!"(BEMACS $B$G$O!"O$O(BGMW + +Wnn + Nemacs$B$r;H$C$F=q$-$^$7$?!#$=$N$h$&$JAG@2$i$7$$%W%m%0%i%`$r:n$C$?J}!9(B +$B$X46M;R$5$s!"$I$&$b$"$j$,$H$&!#(B + + + + + +$B8mLu!"13!"$=$NB>!"$NJ8@U$O!"0J2<$Nn(B GNUEMACS(Mule) $(C@T9.Fm(B + ============================== + +$(CAV@G(B: $(C@L(B $(C@T9.Fm@:(B, "$(C9h?l1b:84Y(B $(C@Mn(B + $(C@V=@4O4Y(B. ">>" $(C7N:NEM(B $(C=C@[GO4B(B $(CG`@:(B, $(C1W(B $(C6'(B $(C9+>y@;(B $(CGX>_(B + $(CGO4B0!8&(B $(CAv=CGO0m(B $(C@V=@4O4Y(B. + + Mule $(C@G(B $(C8m7I>n8&(B $(C@T7BGR(B $(C6'?!4B(B, $(C@O9]@{@87N(B $(CD\F.7Q(B*$(CE0(B($(CE0(B*$(CEi?!(B, +CTRL $(C6G4B(B, CTL $(C6s0m(B $(C=a@V4Y(B)$(C3*(B $(C8^E8(B*$(CE0(B($(C:8Ek(B, $(C@L=:DI@LGA(B*$(CE08&(B $(C;g?kGQ4Y(B)$(C0!(B +$(C;g?k5K4O4Y(B. $(C1W7!<-(B, CONTROL $(C@L6s5g0!(B META $(C6s0m(B $(C>24B(B $(C4k=E?!(B, $(C4Y@=0z00@:(B +$(C1bH#8&(B $(C;g?kGO4B(B $(C0M@87N(B $(CGU4O4Y(B. + +C-<$(C9.@Z(B> $(CD\F.7Q(B*$(CE08&(B $(C4)8%C$(B, <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. $(C?98&(B $(C5i8i(B, + C-f $(C4B(B, $(CD\F.7Q(B*$(CE08&(B $(C4)8#8i<-(B f $(CE08&(B $(C4)8#4B(B $(C0M@;(B + $(C@G9LGU4O4Y(B. +<> + >> $(C1W7/8i(B, C-v (View Next Screen; $(C4Y@=@G(B $(CH-8i@;(B $(C:;4Y(B) $(C8&(B $(CE8@LGA(B + $(CGO?)(B $(C:8< $(C@L=:DI@LGA(B*$(CE08&(B $(C4)8#0m3*<-(B, $(C1W(B $(C5Z(B <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. + +$(CAV@G(B: <$(C9.@Z(B>$(C4B(B, $(C4k9.@Z3*(B $(Cn7N<-4B(B $(C00@:(B $(C@G9L0!(B + $(C5K4O4Y(B. $(C8^E8E08&(B $(C;g?kGR(B $(C $(C4k=E?!(B M- + <$(C9.@Z(B> ($(C8^E8E08&(B $(C4)8%C$(B<$(C9.@Z(B>$(CE08&(B $(C4)8%4Y(B) $(C8&(B $(C;g?kGR(B $(C7a=CE00m(B $(C=M@;(B $(C6'4B(B, C-x C-c $(C8&(B $(CE8@LGAGU4O4Y(B. + Emacs$(C8&(B csh$(C7N:NEM(B $(C1b5?GO0m(B $(C@V4B(B $(C0f?l(B, $(C<-=:Ff5eGO4B(B($(C@O=C(B + $(C@{@87N(B $(CA_4\GQ4Y(B)$(CGR(B $(Cz@88i(B, C-v $(C8&(B $(C@T7BGO?)(B $(CAV<U@G(B $(CH-8i0z(B $(C4Y@=(B $(CH-8i?!4B(B, $(CG%=C5G4B(B $(C3;?k?!(B $(C8nG`@G(B $(C9.@L(B $(CA_:95G0m(B +$(C@V=@4O4Y(B. $(CG%=C5G0m(B $(C@V4B(B $(C3;?k@L(B $(C?,n(B $(C@V4B(B $(C0M@;(B $(C>K(B $(CK(B $(CGJ?d0!(B $(C@V=@4O4Y(B. C-v +$(C?!(B $(C@GGO?)(B $(C>U@87N(B $(CAxG`GO4B(B $(C0M@:(B $(C@L9L(B $(C>K>R=@4O4Y(B. $(C?x7!@G(B $(C@Z8.7N(B $(C5G59>F(B +$(C0!4B5%4B(B, ESC v $(C8&(B $(CE8@LGAGU4O4Y(B. + + >> ESC v $(C?M(B C-v $(C8&(B $(C;g?kGO?)(B, $(C@|HD7N(B $(C@L5?GO4B(B $(C0M@;(B $(C8n9x(B $(C=C55GO?)(B + $(C:8<`(B +==== + $(CH-@O@;(B $(CH-8i4\@'7N(B $(C:80m(B $(C0!4B5%4B(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-v $(C>U@87N(B $(CGQ(B $(CH-8i:P(B $(CAxG`GQ4Y(B + ESC v $(C5Z7N(B $(CGQ(B $(CH-8i:P(B $(C5G59>F0#4Y(B + C-l $(CH-8i@;(B $(C4Y=C>44Y(B. $(C@L(B $(C6'(B, $(C?x7!(B $(CD?<-0!(B $(C@V>z4x(B $(CG`@L(B + $(CH-8i@G(B $(CA_>S?!(B $(C?@557O(B $(CGQ4Y(B + + >> $(CAv1](B $(CD?<-0!(B $(C>n5p?!(B $(C@V4B0!(B, $(C1W(B $(C1YC3?!(B $(C>n62(B $(CEX=:F.0!(B $(C=aA.(B $(C@V4B(B + $(C0!8&(B $(C1b>oGO<n5p7N(B $(C@L5?GO?44B(B + $(C0!(B, $(C1W(B $(C1YC3@G(B $(CEX=:F.4B(B $(C>n6;0T(B $(C5G>z4B0!8&(B $(CA6;gGO?)(B $(C:8<n(B +====================== + + $(CH-8i4\@'@G(B $(C@L5?@:(B $(CGR(B $(Cz=@4O4Y(B. $(C@LA&4B(B, $(CH-8i(B $(C3;?!<-(B, $(CF/(B +$(CA$@G(B $(C@eU(B(forward)$(C5Z(B(backward)$(C7N(B +$(C@L5?GO4B(B $(C8m7I>n8&(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. $(C@L5i@G(B $(C8m7I>n4B(B $(C0"0"(B, C-p, C-n, +C-f, C-b $(C?!(B $(CGR4g5G>n(B $(C@V0m(B, $(CGv@g@G(B $(C@en(B $(C@V@89G7N(B, $(C?\?l1b(B $(C=,?o(B $(C0M@T4O4Y(B. $(C@L5i@:(B, $(C1b:;@{@N(B $(CD?<-@L5?(B $(C8m7I>n@L0m(B +, $(C@ZAV(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. + + >> C-n $(C@;(B $(C8nH8A$55(B $(CE8@LGAGO0m(B, ($(CAv1](B, $(C4g=E@L(B $(C@P0m(B $(C@V4B(B) $(C@L(B $(CG`1n(B + $(CAv(B $(CD?<-8&(B $(C@L5?=CE0<> C-f $(C8&(B $(C;g?kGO?)(B $(CG`@G(B $(CA_0#A$557N(B $(C@L5?GO0m(B, C-p $(C@87N(B $(C8nG`A$55(B + $(C@'7N(B $(C@L5?GO?)(B $(C:8<> $(CG`@G(B $(C<15N?!<-(B C-b $(C8&(B $(CE8@LGAGO?)(B $(C:8<n5p7N(B $(C@L5?GU(B + $(C4O1n(B? $(C4Y=C(B $(CA61](B $(C4u(B C-b $(C8&(B $(CE8@LGAGO0m(B, $(C@L9x@:(B C-f $(C7N(B $(CG`3!(B $(CBJ(B + $(C@87N(B $(C5G59>F0!<n6;0T(B $(C5K4O1n(B? + + + $(CH-8i@G(B $(C<15N3*(B $(C8;9L8&(B $(C3Q>n<-(B $(CD?<-8&(B $(C@L5?=CE07A0m(B $(CGO8i(B, $(C1W(B $(C9fGb?!(B +$(C@V4B(B $(CEX=:F.0!(B $(C@L5?GO?)(B $(C?@0m(B, $(CD?<-4B(B $(CGW;s(B $(CH-8i3;?!(B $(C@V557O(B $(C5K4O4Y(B. + + >> C-n $(C@;(B $(C;g?kGO?)(B, $(CD?<-8&(B $(CH-8i@G(B $(CGO4\:84Y(B $(C9X@87N(B $(C@L5?=CDQ(B $(C:8<<(B + $(C?d(B. $(C9+>y@L(B $(C@O>n334O1n(B? $(CD?<-@G(B $(C@'D!4B(B $(C>n6;0T(B $(C:/GO?4=@4O1n(B? + + $(CGQ9.@Z(B $(C4\@'@G(B $(C@L5?@87N4B(B $(C9x0E7S4Y0m(B $(C;}0"5G8i(B, $(C4\>n4\@'7N(B $(C@L5?GR(B +$(Cn:P(B $(C>U@87N(B $(CAxG`GO0m(B, ESC b $(C7N(B $(CGQ(B $(C4\>n:P(B +$(C@L@|@87N(B $(C5G59>F0)4O4Y(B. + +$(CAV@G(B: $(C@O:;>n?!(B $(C4kGX<-4B(B, $(C4\>n@G(B $(C2w4B(B $(C4\@'@;(B $(C@N=DGR(B $(Cx=@4O(B + $(C4Y88(B, $(C@G;g@{@N(B $(C9.@}@;(B $(C4\>n@G(B $(C2w4B(B $(C4\@'7N<-(B $(CGO0m(B $(C@V=@4O(B + $(C4Y(B. + + >> ESC f $(C3*(B ESC b $(C8&(B $(C8nH8A$55(B $(CE8@LGAGO?)(B $(C:8<$(C4B(B $(C9.<-0|0h@G(B $(CC38.?!(B $(C;g?k5G0m(B, $(CGQFm(B C-<$(C9.@Z(B>$(C4B(B $(C1W0M(B +$(C:84Y55(B $(C4u?m(B $(C1b:;@{@N(B $(C4k;s(B($(C9.@Z6s5g0!(B $(CG`@L6s5g0!(B)$(C?!(B $(C4kGQ(B $(CA6@[?!(B $(C;g?k5K(B +$(C4O4Y(B. + + C-a $(C?M(B C-e $(C55(B $(C>K0m(B $(C@V@88i(B $(CFm8.GQ(B $(C8m7I>n@T4O4Y(B. C-a $(C4B(B $(CD?<-8&(B $(CG`@G(B +$(C<15N7N(B $(C@L5?=CE00m(B, C-e $(C4B(B $(CG`@G(B $(C3!@87N(B $(C@L5?=CE54O4Y(B. + + >> C-a $(C8&(B 2$(CH8(B, $(C1W8.0m3*<-(B C-e $(C8&(B 2$(CH8(B $(C@T7BGO?)(B $(C:8<n8&(B 2$(CH8@L;s(B $(C9]:9GO4u6s55(B, $(CD?<-4B(B $(C1W(B $(C@L;s(B $(C@L5?GOAv(B $(C>J4B(B $(C0M(B + $(C?!(B $(CAV@G(B. + + $(C5N0!Av(B $(C4u(B, $(C0#4\GQ(B $(CD?<-(B $(C@L5?(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C<15N7N(B $(C@L5?(B +$(CGO4B(B ESC < $(C?M(B, $(CH-@O@G(B $(C3!@87N(B $(C@L5?GO4B(B ESC > $(C@T4O4Y(B. + + $(CEX=:F.(B $(C3;?!<-(B, $(CD?<-0!(B $(CA8@gGO4B(B $(C@'D!8&(B "$(CFw@NF.(B"$(C6s0m(B $(C:N8(4O4Y(B. $(C9Y2Y(B +$(C>n(B $(C8;GO8i(B, $(CD?<-4B(B, $(CEX=:F.@G(B $(C>n5p?!(B $(C@V4B0!8&(B $(CH-8i@'?!(B $(C3*E83;0m(B $(C@V4B(B $(C0M(B +$(C@T4O4Y(B. + + $(C>F7!?!(B $(C4\`GU4O4Y(B. $(C@L(B $(CA_?!4B(B, $(C4\>n3*(B $(CG`(B +$(C4\@'7N@G(B $(C@L5?8m7I>n55(B $(CFwGT5G>n(B $(C@V=@4O4Y(B. + + C-f $(CGQ(B $(C9.@Z(B $(C>U@87N(B $(CAxG`GQ4Y(B + C-b $(CGQ(B $(C9.@Z(B $(C5Z7N(B $(C5G59>F0#4Y(B + + ESC f $(CGQ(B $(C4\>n(B $(C>U@87N(B $(CAxG`GQ4Y(B + ESC b $(CGQ(B $(C4\>n(B $(C5Z7N(B $(C5G59>F0#4Y(B + + C-n $(C4Y@=(B $(CG`@87N(B $(C@L5?(B + C-p $(C@L@|(B $(CG`@87N(B $(C@L5?(B + + ESC ] $(C4\6t@G(B $(C3!@87N(B $(C@L5?(B + ESC [ $(C4\6t@G(B $(C<15N7N(B $(C@L5?(B + + C-a $(CG`@G(B $(CCVCJ7N(B $(C@L5?(B + C-e $(CG`@G(B $(CCVHD7N(B $(C@L5?(B + + ESC < $(CH-@O@G(B $(CCVCJ7N(B $(C@L5?(B + ESC > $(CH-@O@G(B $(CCVHD7N(B $(C@L5?(B + + >> $(C0"0"@G(B $(C8m7I>n8&(B $(C=C55GO?)(B $(C:8<n4B(B, $(C0!@e(B $(C@ZAV(B + $(C;g?k5G4B(B $(C0M@T4O4Y(B. $(CCVHD@G(B $(C5N0!Av4B(B, $(C@L(B $(C@enAx(B $(C0w@8(B + $(C7N(B $(C@L5?GO1b(B $(C6'9.?!(B, C-v $(C3*(B ESC v $(C8&(B $(C;g?kGO?)(B $(C?)1b7N(B $(C5G59>F(B + $(C?@557O(B $(CGO<n?!4B(B, $(C9]:9H8n8&(B $(C@T7BGO1b(B $(C@|?!(B, C-u +$(C?!(B $(C@L>n<-(B $(C9]:9GO4B(B $(CH8U@87N(B $(C@L5?GU4O4Y(B. + + >> C-n $(CH$@:(B C-p $(C?!(B $(C@{4gGQ(B $(C@N> C-u 3 C-v $(C6s0m(B $(C@T7BGO?)(B $(C:8<F0!4B5%4B(B, C-u 3 ESC v $(C8&(B $(C;g?kGO8i(B $(C5K4O4Y(B. + +$(CA_Av8m7I>n(B +========== + + C-g $(C6s4B(B $(C8m7I>n@L8g(B, $(C@T7B@;(B $(CGJ?d7N(B $(CGO4B(B $(C0M0z(B $(C00@:(B $(C8m7I>n8&(B $(CA_AvGR(B +$(Cn8&(B $(CGQC"(B $(C@T7BGO0m(B $(C@V4B(B $(C55A_?!(B, $(C1W0M@;(B $(CA_AvGO0m(B $(C=M(B +$(C@88i(B, C-g $(C8&;g?kGO8i(B $(C5K4O4Y(B. + + >> C-u 100 $(C8&(B $(CE8@LGAGO?)(B $(C@N`(B, $(C@_8xGO?)(B ESC $(C8&(B $(C@T7BGX(B $(C9v7H@;(B $(C6'55(B, C-g $(C8&(B $(C@T7BGO(B + $(C8i(B $(CCkJ4B(B $(CA6@[@;(B $(CGX9v8.4B(B $(C@{@L(B $(C@V=@4O(B +$(C4Y(B. $(C?98&(B $(C5i8i(B, $(C8m7I>n0!(B $(CA$@G5G>n(B $(C@VAv(B $(C>J4B(B $(CD\F.7Q(B*$(CE08&(B $(C@T7BGX(B $(C9v80(B $(C6'(B +$(C?!4B(B, Emacs$(C4B(B $(C:'@;(B $(C?o8.0m(B, $(C1W8.0m(B, $(CH-8i@G(B $(CA&@O(B $(C9X?!(B, $(C9+>y@L(B $(C3*;&4B(B $(C0!(B +$(C8&(B $(CG%=CGU4O4Y(B. + + Emacs $(C9vA/?!(B $(C5{6s<-4B(B, $(C@L(B $(C@T9.Fm?!(B $(C>2?)A.(B $(C@V4B(B $(C0M@;(B $(C=GG`GR(B $(Cx(B +$(C4B(B $(C0f?l0!(B $(C@V@;(B $(Cn4@(B $(C0M@N0!(B $(C@L5?E08&(B $(C4)8#0m(B, $(C1W(B $(C4Y@=@G(B $(C:N:P@87N(B $(CAxG`GO?)(B $(CAV<n7N:NEM@G(B $(CCb7B@;(B $(CG%=CGO1b(B $(C@'GO(B +$(C?)(B $(C3*E83-(B $(C?):P@G(B $(C@)55?l8&(B $(CAv?l1b(B $(C@'GO?)(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C>K(B $(CGJ?d0!(B $(C@V=@(B +$(C4O4Y(B. + + C-x 1 $(C@)55?l8&(B 1$(C037N(B $(CGQ4Y(B. + + C-x 1 $(C4B(B, $(C4Y8%(B $(C@)55?l8&(B $(CAv?l0m(B, $(CD?<-0!(B $(C@V4B(B $(C@)55?l8&(B, $(CH-8i@|C<7N(B +$(CH.@eGU4O4Y(B. + + >> $(CD?<-8&(B $(C@L(B $(CG`?!(B $(C0.0m(B $(C?M<-(B, C-u 0 C-l $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + >> C-h k C-f $(C6s0m(B $(CE8@LGAGO<n@G(B $(C55(B + $(CE%8UF.8&(B $(CG%=CGO1b(B $(C@'GO?)(B $(C3*E8320z(B $(C5?=C?!(B, $(C@L(B $(C@)55?l0!(B $(C>n6;0T(B + $(CAY>n5e4B0!(B $(C0|B{GO<> C-x 1$(C@L6s0m(B $(CE8@LGAGO0m(B, $(C55E%8UF.0!(B $(C3*E8354x(B $(C@)55?l8&(B $(CAv?l<<(B + $(C?d(B. + +$(C;p@T0z(B $(C;hA&(B +=========== + + $(CEX=:F.8&(B $(CE8@LGAGO0m(B $(C=M@88i(B, $(C4\ $(C@;(B $(CE8@LGAGU4O4Y(B. + + $(CAw@|?!(B $(C@T7BGQ(B $(C9.@Z8&(B $(C;hA&GO4B5%4B(B, $(C8&(B $(C@T7BGU4O4Y(B. + $(C4B(B,$(CE0:85e?!<-(B "Delete"$(C6s0m(B $(C=a@V4B(B $(CE08&(B $(C4-7/<-(B $(C@T7BGU4O4Y(B. +"Delete" $(C4k=E?!(B"Rubout"$(C6s0m(B $(C=a@V@;(B $(CAv55(B $(C8p8(4O4Y(B. $(C:84Y(B $(C@O9]@{@87N(B, + $(C4B(B, $(CGv@gD?<-0!(B $(C@V4B(B $(C@'D!@G(B $(CAw@|@G(B $(C9.@Z8&(B $(C;hA&GU4O4Y(B. + + >> $(C9.@Z8&(B $(C8n03A$55(B $(CE8@LGAGO0m(B, $(C1W8.0m3*<-(B $(C1W0M@;(B $(C8&(B $(C;g(B + $(C?kGO?)(B $(C;hA&GO<> $(C?@8%BJ86Ax@;(B $(C3Q@;(B $(C6'1nAv(B $(CEX=:F.8&(B $(CE8@LGAGO<nA.3*?M(B + "$(C0hFAw(B $(C@L>nAv0m(B $(C@V4B(B $(C0M@;(B $(C3*E83;0m(B + $(C@V=@4O4Y(B. + + $(C@L0M@:(B, $(C1[7N(B $(C<38mGO4B(B $(C0M:84Y(B $(C=GA&7N(B $(CGX:84B(B $(CFm@L(B $(C@_(B $(C>K(B $(C> $(CA61]@|(B $(C@T7BGQ(B, $(C0hn0!557O(B $(CGX:8<> $(CD?<-8&(B $(CG`@G(B $(C<15N7N(B $(C@L5?GO0m(B, $(C8&(B $(C@T7BGO<U@G(B $(CG`0z(B + $(C@L>nA.(B $(C9v834O4Y(B. $(C@L>nAx(B $(CG`@L(B $(CH-8i@G(B $(CFx:84Y(B $(C1f0T(B $(C5G8i(B, $(C0h> $(C8&(B $(C4)8#0m(B, $(CGQ9x(B $(C4u(B $(CG`4\6tAv@=@;(B $(C;p@TGO<n4B(B, $(C9]:9(B $(CH8> C-u 8 * $(C6s0m(B $(C@T7BGO?)(B $(C:8<n6;0T(B $(C5G>z=@4O1n(B? + + $(C5N03@G(B $(CG`(B $(C;g@L?!(B $(C0x9iG`@;(B $(C885i0m(B $(C=M@:(B $(C0f?l?!4B(B, $(C5N9xB0(B $(CG`@G(B $(C<15N(B +$(C7N(B $(C0!<-(B, C-o $(C8&(B $(C@T7BGU4O4Y(B. + + >> $(C@{4gHw(B $(CG`@G(B $(C<15N?!(B $(C0!<-(B, $(C0E1b<-(B C-o $(C8&(B $(C@T7BGO?)(B $(C:8<z=@4O4Y(B. $(C9.@Z?M(B $(C00@L(B, $(C4\>n3*(B $(CG`55(B +$(C;hA&GR(B $(C`GO8i(B $(C4Y@=0z(B $(C00=@4O4Y(B. + + $(CD?<-Aw@|@G(B $(C9.@Z8&(B $(C;hA&(B + C-d $(CD?<-0!(B $(C@V4B(B $(C9.@Z8&(B $(C;hA&(B + + ESC $(CD?<-Aw@|@G(B $(C4\>n8&(B $(C;hA&(B + ESC d $(CD?<-@'D!(B $(C@LHD?!(B $(C@V4B(B $(C4\>n8&(B $(C;hA&(B + + C-k $(CD?<-@'D!7N:NEM(B $(CG`3!1nAv8&(B $(C;hA&(B + + $(C9+>y@N0!8&(B $(C;hA&GQ(B $(CHD?!(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'0!(B $(C@V=@4O(B +$(C4Y(B. Emacs$(C4B(B, $(CGQ9.@Z:84Y(B $(CE+(B $(C4\@'7N(B $(C;hA&8&(B $(CG`GQ(B $(C6'?!4B(B, $(C;hA&GQ(B $(C3;?k@;(B +$(C:8A8GO?)(B $(C5S4O4Y(B. $(C?x7!4k7N(B $(C5G598.4B5%4B(B, C-y $(C8&(B $(C;g?kGU4O4Y(B. $(CAV@GGX>_(B +$(CGO4B(B $(C0M@:(B, C-y $(C8&(B $(C;hA&8&(B $(CG`GQ(B $(C@eF4O6s(B, $(C>n5p?!<-6s55(B $(CGR(B $(Cn@L9G7N(B, $(C@L0M@;(B $(C;g?kGO?)(B $(CEX=:F.8&(B $(C@L5?GR(B $(Cn?!4B(B, "Delete" $(C8m7I>n?M(B, "Kill" $(C8m7I>n0!(B $(C@V=@(B +$(C4O4Y(B. "Kill" $(C8m7I>n?!<-4B(B $(C;hA&5H(B $(C0M@:(B $(C:8A85GAv88(B, "Delete"$(C?!<-4B(B $(C:8A8(B +$(C5GAv(B $(C>J=@4O4Y(B. $(C4\(B, $(C9]:9H8nAv8i(B, $(C:8A85K4O4Y(B. + + >> C-n $(C@;(B 2$(CH8(B $(CA$55(B $(CE8@LGAGO0m(B, $(CH-8i@G(B $(C@{4gGQ(B $(C@e`(B, C-k $(C?!(B $(C9]:9H8(B $(C> C-y $(C8&(B $(C=CGhGO?)(B $(C:8<n(B $(C:8A85G(B +$(C0m(B, C-y$(C7N(B, $(C1W(B $(C@|:N0!(B $(C2t3;>nA}4O4Y(B. + + >> C-k $(C8&(B $(C8n9x(B $(CE8@LGAGO?)(B $(C:8<> $(CEX=:F.8&(B $(C2t3;4B5%4B(B, C-y $(C@T4O4Y(B. $(CD?<-8&(B $(C8nG`(B $(C9X@87N(B $(C@L5?=CE0(B + $(C0m(B, $(CGQ9x(B $(C4u(B C-y $(C8&(B $(CE8@LGAGO?)(B $(C:8<n62(B $(CEX=:F.0!(B $(C:8A85G>n(B $(C@V0m(B, $(C4u183*(B $(C4Y8%(B $(CEX=:F.8&(B $(C;hA&GO8i(B +$(C>n6;0T(B $(C5G0Z=@4O1n(B? C-y$(C4B(B, $(C0!@e(B $(CCV1Y(B $(C;hA&5H(B $(C0M@;(B $(C2tA}>n3@4O4Y(B. + + >> $(CG`@;(B $(C;hA&GO0m(B, $(CD?<-8&(B $(C@L5?=CE00m(B, $(C4Y8%(B $(CG`@;(B $(C;hA&GO<pA&6s55(B, $(CEX=:F.8&(B $(C:/0fGO?4Av88(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'(B +$(C4B(B C-x u$(C7N(B $(C0mD(4O4Y(B. $(C:8Ek@:(B $(C@_8x5H(B $(C8m7I>n8&(B $(C9+H?7N(B $(CGO4B(B $(C@[5?@;(B $(CGU4O4Y(B. +$(C9]:9GX<-(B UNDO$(C8&(B $(CG`GO7A0m(B $(CGR(B $(C6'4B(B, $(C8n9x@L3*(B $(C1W(B $(C8m7I>n8&(B $(CG`GO8i(B $(C5G557O(B +$(C5G>n(B $(C@V=@4O4Y(B. + + >> $(C@L(B $(CG`@;(B C-k$(C7N(B $(CAv?l<n@T4O4Y(B. $(C1b4I@:(B, C-x u$(C?M(B $(C00(B + $(C=@4O4Y(B. + + C-_$(C3*(B C-x u$(C?!(B UNDO$(C@G(B $(CH8_(B $(CGU4O4Y(B. $(C:8A8GOAv(B $(C>J@88i(B, $(CG`GQ(B $(C:/0f@:(B, Emacs$(C8&(B $(CA>7aGO8i(B $(C5?=C?!(B $(C@R>n(B +$(C9v8.0T(B $(C5K4O4Y(B. + + $(CAv1](B $(C:80m(B $(C@V4B(B $(CH-@O?!(B $(C4kGX<-(B, $(C4g=E@L(B $(CFmA}@;(B $(CG`GQ(B $(C0M@;(B $(C=a3V=@4O4Y(B. +$(CAv1](B, $(C:80m(B $(C@V4B(B $(CH-@O@L6u(B $(C0M@:(B, $(C0#4\Hw(B $(C8;GO8i(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O(B $(C@ZC<@T(B +$(C4O4Y(B. + + $(C4g=E@L(B $(CH-@O@;(B $(C<<@L:j(B($(C:8A8GQ4Y(B)$(CGO1b(B $(C1nAv(B, $(CAv1]1nAv@G(B $(C:/0f@:(B $(CFmA}GO(B +$(C0m@V4B(B $(CH-@O?!(B $(C=a3V4B(B $(C0M@:(B $(C>F4U4O4Y(B. $(C1W0M@:(B, $(C4g=E@L(B $(C@L?M(B $(C00@L(B $(C:/0fGO0m(B +$(C=MAv(B $(C>J@:5%55(B, $(C55A_1nAv(B $(C:/0f@;(B $(C0!GQ(B $(C0M@L(B $(CA&8Z4k7N(B $(C=a3V>nAv4B(B $(C@O@L(B $(C>x55(B +$(C7O(B $(CGO1b(B $(C@'GX<-(B $(C@T4O4Y(B. + + $(C<<@L:j@;(B $(CG`GQ(B $(C5ZA6Bw(B $(C:/0fGQ(B $(C0M@L(B $(C@_8x(B $(C5G>n(B $(C@V@;(B $(C6'8&(B $(C@'GO?)(B Emacs +$(C4B(B $(C@L8'@;(B $(C:/0fGO?)(B $(C?x:;(B $(CH-@O@;(B $(C321i4O4Y(B. + +$(C:q0m(B: $(C6GGQ(B, Emacs$(C4B(B $(C?9CxGR(B $(Cx4B(B $(C;sEB?!(B $(C4k:qGO?)(B, $(C@OA$GQ(B $(C=C(B + $(C0#0#0]@87N(B $(C@Z5?@{@87N(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O@G(B $(C3;?k@;(B $(C@L8'(B + $(C@;(B $(C:/0fGQ(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L0M?!(B $(C@GGX(B, $(C88@O@G(B $(C0f?l(B + $(C4B(B $(CG`GQ(B $(C:/0f?!(B $(C4kGO?)(B $(CCVF7!(B $(CBJ@;(B $(C:88i(B, $(C@L?M(B $(C00@:(B $(C6f@87N(B $(C8p5e6s@N@L(B $(CG%=C5G>n(B $(C@V4Y(B +$(C0m(B $(C;}0"GU4O4Y(B. + +($(C?9(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- + + + $(C@L(B Emacs$(CF)Ed8.>s@G(B $(C:9;g:;@:(B MULE.tut$(C@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(CH-@O(B +$(C@;(B $(CH-@N5e(B($(CH-@O@;(B $(CC#>F<-(B $(C9vF[?!(B $(C@P>n3V4B(B $(C0M(B)$(CGO8i(B, MULE.tut$(C@G(B $(C:N:P?!(B $(CG%=C(B +$(C5K4O4Y(B. $(C?98&(B $(C5i8i(B, new-file$(C@L6s4B(B $(C@L8'@G(B $(CH-@O@;(B $(CH-@N5eGO?44Y8i(B, "Mule: +new-file"$(C@L6s4B(B $(C8p5e6s@N@L(B $(C5G0ZAv?d(B. + +$(CAV@G(B: $(C8p5e6s@N?!(B $(C4kGX<-4B(B $(C3*A_?!(B $(C<38mGO0Z=@4O4Y(B. $(C@a1q(B $(C1b4Y8.=C(B + $(C1b8&(B. + + $(CH-@O@;(B $(CH-@N5eGO0E3*(B, $(C<<@L:jGO4B(B $(C8m7I>n4B(B, $(CAv1]1nAv@G(B $(C0M0z4B(B $(C4^8.(B, +2$(C03@G(B $(C9.@Z7N(B $(C5G>n(B $(C@V=@4O4Y(B. C-x $(C?!(B $(C@L>n<-(B $(C@T7BGO4B(B $(C9.@Z0!(B, $(CH-@O?!(B $(C4kGX(B +$(C<-(B $(CG`GO4B(B $(CA6@[@;(B $(C3*E83@4O4Y(B. + + $(CGQ0!Av(B $(C4u(B, $(CAv1]1nAv@G(B $(C0M0z(B $(C4Y8%(B $(CA!@:(B, $(CH-@N5e(B $(C=C(B, $(CH-@O8m@;(B Emacs$(C0!(B +$(C90>n:>4O4Y(B. $(C@L0M@;(B, $(C4\8;7N:NEM(B $(C@Nn5i?)?@4B(B $(C8m7I>n6s0m(B $(C8;GO0m(B +$(C@V=@4O4Y(B. + + +$(CAV@G(B: $(C@L(B $(C0f?l4B(B $(CH-@O8m(B $(C@T4O4Y(B. + + C-x C-f $(CH-@O@;(B $(CC#4B4Y(B($(CH-@N5eGQ4Y(B) + + Emacs$(C4B(B $(CH-@O8m@;(B $(C90>n?I4O4Y(B. $(C@L0M@:(B, $(CH-8i9X@G(B $(CG`?!(B $(C3*E8334O4Y(B. +$(CH-@O8m@;(B $(CAvA$GO0m(B $(C@V4B(B $(C:N:P@:(B, $(C9L4O9vF[6s0m(B $(C:R8.?l4B(B $(C0M@T4O4Y(B. $(C9L4O9v(B +$(CF[4B(B $(C@L?M(B $(C00@L(B $(C;g?k5K4O4Y(B. $(CH-@O8m?!(B $(C@L>n<-(B, $(C8.4xE08&(B $(C4)8#8i(B, $(C9L4O9vF[(B +$(C?!(B $(CG%=C5G>nAx(B $(C3;?k@:(B $(C4u(B $(CGJ?dGOAv(B $(C>J1b(B $(C6'9.?!(B $(CAv?vA.(B $(C9v834O4Y(B. + + >> C-x C-f$(C6s0m(B $(CE8@LGAGQ(B $(C5Z?!(B C-g$(C6s0m(B $(CE8@LGAGO<n55(B $(CCkn62(B $(CH-@O55(B $(CC#Av(B $(C>J=@4O4Y(B. + + $(C@L9x?!4B(B $(CH-@O@;(B $(C<<@L:jGO?)(B $(C:8<n8&(B $(C;g?kGU4O4Y(B. + + C-x C-s $(CH-@O@;(B $(C<<@L:jGQ4Y(B + + Emacs$(C@G(B $(C3;?k@:(B $(CH-@O?!(B $(C=a3;>nA}4O4Y(B. $(C<<@L:jGR(B $(C6'(B, $(C?x:;@G(B $(CH-@O@:(B $(C;u(B +$(C7N?n(B $(C@L8'@;(B $(C:Y?)<-(B $(C320\Av1b(B $(C@V@89G7N(B $(C3;?k@:(B $(C>x>nAvAv(B $(C>J=@4O4Y(B. $(C@L(B $(C;u(B +$(C7N?n(B $(C@L8'@:(B $(C?x:;@G(B $(CH-@O@G(B $(C@L8'?!(B '~'$(C8&(B $(C:Y@N(B $(C0M@T4O4Y(B. + + $(C%;<<@L:j0!(B $(C3!3*8i(B, Emacs$(C4B(B $(C<<@L:jGQ(B $(CH-@O@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. + + >> C-x C-s$(C6s0m(B $(CE8@LGAGO0m(B $(CF)Ed8.>s@G(B $(C:9;g:;@;(B $(C<<@L:jGO<`(B, 2$(C9xB0@G(B $(CH-@O@;(B C-x C-f $(C7N(B $(C2(3;8i(B, 1$(C9xB0@G(B $(CH-@O@:(B Emacs$(C3;:N(B +$(C?!(B $(C32=@4O4Y(B. Emacs$(C3;:N?!(B $(C@V4B(B $(CH-@O7N:NEM(B $(CEX=:F.8&(B $(C@P>n3V>n(B $(C:8A8GO0m@V(B +$(C4B(B $(C0M@:(B $(C9vF[6s0m(B $(C:R8.?s4O4Y(B. $(CH-@O@;(B $(C2(3;4B(B $(C0M@:(B, Emacs$(C3;:N?!(B $(C;u7N?n(B +$(C9vF[8&(B $(C885l4O4Y(B. + + Emacs $(C3;?!(B $(C:8A8GO0m(B $(C@V4B(B $(C9vF[@G(B $(C8.=:F.8&(B $(C:84B5%4B(B, $(C4Y@=0z(B $(C00@L(B +$(CE8@LGAGU4O4Y(B. + + C-x C-b + + >> C-x C-b $(C6s0m(B $(CE8@LGAGO<n60GQ(B $(C@L8'@;(B $(C0.(B + $(C0m(B $(C@V4B0!(B, $(C1W8.0m(B, $(C>n60GQ(B $(CH-@O8m@;(B $(C:Y@L0m(B $(C@V4B(B $(C0M@N0!(B $(C0|B{(B + $(CGO<J4B(B $(C0M55(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, "*Buffer +List*" $(C6s4B(B $(CH-@O@:(B $(C>x=@4O4Y(B. $(C@L0M@:(B C-x C-b $(C?!(B $(C@GGO?)(B $(C885i>nAx(B $(C9vF[8.(B +$(C=:F.?!(B $(C4kGQ(B $(C9vF[@T4O4Y(B. + + $(C4g=E@L(B $(C:80m(B $(C@V4B(B Emacs$(C@)55?l3;?!(B $(C@V4B(B, $(C>n60GQ(B $(CEX=:F.6s55(B, $(C>n4@0M(B +$(C@N0!@G(B $(C9vF[3;?!(B $(C@V=@4O4Y(B. + + >> $(C9vF[8.=:F.8&(B $(CAv?l1b(B $(C@'GX(B C-x 1 $(C6s0m(B $(CE8@LGAGO<`(B, $(C>n62(B $(CH-@O@G(B $(CEX=:F.?!(B $(C:/0f@;(B $(CG`GO0m3*<-(B, $(C4Y8%(B $(CH-@O@;(B $(C2(3;>z(B +$(C4Y0m(B $(CG_4Y8i(B, $(CCVCJ@G(B $(CH-@O@:(B $(C<<@L:j5G>n(B $(C@VAv(B $(C>J=@4O4Y(B. $(C1W(B $(C:/0f@:(B Emacs +$(C3;:N@G(B $(CH-@O0z(B $(C4k@@GO4B(B $(C9vF[(B $(C3;?!88(B $(CG`GO?)A.(B $(C@V=@4O4Y(B. + + 2$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(C885i1b55GO0m(B, $(C?!5pF.GO4u6s55(B, 1$(C9x(B +$(CB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[?!4B(B $(C>F9+71(B $(C?5Gb@;(B $(CAVAv(B $(C>J=@4O4Y(B. $(C@L0M@:(B $(C4k(B +$(C4\Hw(B $(C;g?kGO1b(B $(C=10T(B, $(C6GGQ(B, 1$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(CH.:8GO?)(B $(C5N(B +$(C1b(B $(C@'GO?)(B $(C55?r@L(B $(C5G4B(B $(C9f9}@T4O4Y(B. + + C-x C-s $(C7N(B $(C9vF[8&(B $(C<<@L:jGO1b(B $(C@'GO?)(B C-x C-f $(C7N(B $(C9vF[8&(B $(C13CF7!@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-x s $(CGv@g(B $(C@V4B(B $(C9vF[8&(B $(C<<@L:jGQ4Y(B. + + C-x s $(C4B(B $(C3;?k@;(B $(C9Y2[(B $(C9vF[(B $(C@|C<8&(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L(B $(C6'(B, $(CGO3*(B +$(CGO3*@G(B ($(C<<@L:j5G>n>_(B $(CGR(B)$(C9vF[?!(B $(C4kGO?)(B, $(C<<@L:jGO4B0!(B, $(CGOAv(B $(C>J4B0!8&(B y$(C3*(B +n$(C@87N(B $(C9/=@4O4Y(B. $(C@L(B $(CG%=C4B(B $(CH-8i(B $(C9X@G(B $(CG`?!(B $(CG%=C5K4O4Y(B. $(C?98&(B $(C5i8i(B, $(C>F7!?M(B +$(C00=@4O4Y(B. + + Save file /usr/private/yours/MULE.tut? (y or n) + + + +$(C8m7I>n@G(B $(CH.@e(B +============= + + $(C?!5pEM?!4B(B, $(CD\F.7Q(B*$(CE03*(B $(C8^EM(B*$(CE07N(B $(C@T7BGR(B $(C@(B +$(C89@:(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(C@L0M5i@;(B $(C4Y7g1b(B $(C@'GO?)(B, $(CH.@e(B(eXtend) $(C8m7I>n8&(B +$(C;g?kGU4O4Y(B. $(C@L0M?!4B(B, $(C>F7!@G(B 2$(C0!Av(B $(CA>7y0!(B $(C@V=@4O4Y(B. + + C-x $(C9.@Z?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(CGQ9.@Z8&(B $(C@T7BGU4O4Y(B. + ESC x $(C@L8'?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(C8m7I>n@G(B $(C@L8'@;(B $(C@T7BGU4O4Y(B. + + $(C@L0M5i@:(B $(C@O9]@{@87N(B, $(CFm8.GOAv88(B, $(CAv1]1nAv(B $(C:8>F?B(B $(C0M0z(B $(CA61](B $(C:s9xGO(B +$(C0T4B(B $(C;g?k5GAv(B $(C>J4B(B $(C8m7I>n8&(B $(C@'GQ(B $(C0M@T4O4Y(B. C-x C-f ($(CH-@N5e(B)$(C3*(B C-x C-s +($(C<<@L:j(B)$(C4B(B $(C@L(B $(C:N7y@T4O4Y(B. $(C@L?\?!(B, C-x C-c($(C?!5pEM@G(B $(CA>7a(B)$(C55(B $(C1W78=@4O4Y(B. + + C-z$(C4B(B Emacs$(C?!<-(B $(C:|A.3*?@4@5%?!(B $(C@ZAV(B $(C;g?k5G4B(B $(C9f9}@T4O4Y(B. Emacs$(C8&(B +$(CA>7aGO4B(B $(C0M@L(B $(C>F4O6s(B, $(C@O4\(B, csh$(C@G(B $(C79:'?!(B $(C5G59>F0!4B5%?!4B(B $(CA&@O(B $(CAA@:(B $(C9f(B +$(C9}@L6s0m(B $(C8;GR(B $(CF4U4O4Y(B. + +$(CAV@G(B: $(C4\(B, X-window$(C?!<-(B $(CG`GO0m(B $(C@V4B(B $(C0f?l(B, $(CH$@:(B $(C;g?kGO0m(B $(C@V4B(B + $(C=)@L(B sh$(C@O(B $(C6'4B(B, $(C1W78Av(B $(C>J=@4O4Y(B. + + C-x $(C8m7I>n4B(B,$(C89@L(B $(C@V=@4O4Y(B. $(C@L9L(B $(C9h?n(B $(C0M@:(B $(C>F7!@G(B $(C0M@T4O4Y(B. + + C-x C-f $(CH-@O@G(B $(CFmA}(B(Find) + C-x C-s $(CH-@O@G(B $(C:8A8(B(Save) + C-x C-b $(C9vF[8.=:F.@G(B $(CG%=C(B + C-x C-c $(C?!F7aGQ4Y(B. $(CH-@O@G(B $(C:8A8@:(B, $(C@Z5?@{@87N4B(B $(CG`GO?)(B + $(CAvAv(B $(C>J4B4Y(B. $(C1W7/3*(B, $(CH-@O@L(B $(C:/0f5G>n(B $(C@V@88i(B, $(CH-@O@G(B $(C:8(B + $(CA8@;(B $(CGO4B0!(B, $(C>F4Q0!8&(B $(C90>n?I4O4Y(B. $(C:8A8GO?)(B $(CA>7aGO4B(B $(C:8(B + $(CEk@G(B $(C9f9}(B, C-x C-s C-x C-c $(C7N(B $(CGO4B(B $(C0M@T4O4Y(B. + + $(C@L8'?!(B $(C@GGQ(B $(CH.@e8m7I>n?!4B(B, $(C1W4YAv(B $(C;g?k5GAv(B $(C>J4B(B $(C0M@L3*(B, $(CF/A$@G(B +$(C8p5e?!<-9[?!(B $(C;g?k5GAv(B $(C>J4B(B $(C0M5n@L(B $(C@V=@4O4Y(B. $(C?97N<-(B, "command-apropos" +$(C8&(B $(C5l4O4Y(B. $(C@L(B $(C8m7I>n4B(B $(CE0?v5e8&(B $(C@T7B=CE00m(B, $(C1W0M?!(B $(C8ED!GO4B(B $(C8p5g(B $(C8m7I(B +$(C>n@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. ESC x $(C6s0m(B $(CE8@LGAGO8i(B, $(C=:E)80(B $(C9X?!(B "M-x" $(C0!(B $(CG%(B +$(C=C5K4O4Y(B. $(C@L0M?!(B $(C4kGO?)(B, $(C=GG`GO4B(B $(C8m7I>n@G(B $(C@L8'(B($(CAv1]@G(B $(C0f?l(B, +"command-apropos")$(C8&(B $(C@T7BGU4O4Y(B. "command-a" $(C1nAv(B $(C@T7BGQ(B $(C5Z(B $(C=:Fd@L=:(B +$(C8&(B $(CD!8i(B, $(C5Z@G(B $(C:N:P@:(B $(C@Z5?@{@87N(B $(C8^?vA}4O4Y(B. $(C@L(B $(CHD(B, $(CE0?v5e8&(B $(C90@89G7N(B, +$(C>K0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAGU4O4Y(B. $(C6GGQ(B, $(CE0?v5e8&(B $(C@T7BGOAv(B $(C>J@88i(B, $(C8p5g(B +$(C8m7I>n0!(B $(CG%=C5K4O4Y(B. + + >> ESC x $(C8&(B $(CE8@LGAGO0m(B, $(C@L>n<-(B, "command-apropos" $(CH$@:(B + "command-a" $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. $(C4Y@=?!(B, + "kanji"$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + $(C3*E83-(B "$(C@)55?l(B"$(C8&(B $(CAv?l4B5%4B(B, C-x 1 $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + +$(C8p5e6s@N(B +======== + + $(C88>`(B $(CC5C5Hw(B $(C8m7I>n8&(B $(CCF4Y8i(B, $(CH-8i@G(B $(C9XBJ@G(B $(C?!DZ?!8.>n6s0m(B $(C:R8.4B(B +$(C@en4B(B $(CH-8i@G(B $(CA&@O(B $(C9X(B $(CG`@T4O4Y(B. $(C1W(B +$(C9Y7N(B $(C@'@G(B $(CG`@:(B, $(C8p5e6s@N@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(C8p5e6s@N@:(B $(C@L7/GQ(B $(C=D@8(B +$(C7N(B $(CG%=C5G>n(B $(C@V0ZAv?d(B. + + [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- + + +$(CAV@G(B: NN%$(C@G(B NN$(C@:(B $(C<}@Z0!(B $(C5i>n(B $(C@V=@4O4Y(B. $(C4g=E@L(B $(C;g?kGO0m(B $(C@V4B(B + Emacs$(C@G(B $(C8p5e6s@N0z(B $(C4Y8&(B $(CAv55(B $(C8p8#Av88(B, $(C4gH2GOAv(B $(C8;557O(B. + $(C?98&(B $(C5i8i(B, $(C=C0#@L3*(B uptime$(C@L(B $(CG%=C5G0m(B $(C@V4B(B $(C0M@:(B, + display-time$(C@L6s4B(B $(C1b4I@L(B $(C@[5?GO0m(B $(C@V1b(B $(C6'9.@T4O4Y(B. + + $(C@L(B $(CG`?!(B $(C@GGO?)(B $(C89@:(B $(C@/?kGQ(B $(CA$:80!(B $(C>r>nA}4O4Y(B. + + + $(CAv1](B, $(C4g=E@L(B $(C:80m(B $(C@V4B(B $(CH-@O8m@;(B $(CG%=CGO0m(B $(C@V=@4O4Y(B. NN%$(C@:(B $(CGv@g(B $(C=:(B +$(CE)80@'?!(B $(CH-@O@G(B $(CA&@O(B $(C@'?!<-:NEM(B $(C8n(B $(CF[<>F.B00!(B $(CG%=C5G0m(B $(C@V4B(B $(C0!8&(B $(C3*E8(B +$(C3;0m(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVCJ8&(B $(CG%=CGO0m(B $(C@V@88i(B, --Top--$(C6s0m(B $(CG%=C5K(B +$(C4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVHD8&(B $(CG%=CGO0m(B $(C@V4Y8i(B, --Bot--$(C6s0m(B $(CG%=C5K4O4Y(B. $(CH-8i(B +$(C3;?!(B $(CH-@O(B $(C@|:N0!(B $(CG%=C5G0m(B $(C@V4Y8i(B, --All--$(C6s0m(B $(CG%=C5K4O4Y(B. + + $(C8p5e6s@N@G(B $(Cn60GQ(B $(C8p5e?!(B $(C5i>n@V4B(B $(C0!8&(B $(C3*E8(B +$(C3;0m(B $(C@V=@4O4Y(B. $(CGv@g4B(B, $(C5pFzF.@N(B Fundamental$(C?!(B $(C5i>n0!(B $(C@V=@4O4Y(B. $(C@L0M55(B +$(C8^@LA.8p5e@G(B $(CGO3*@G(B $(C?9@T4O4Y(B. + + Emacs$(C4B(B Lisp mode$(C3*(B Text mode$(C?M(B $(C00@L(B, $(C4Y8%(B $(CGA7N1W7%>p>n3*(B $(CEX=:F.(B +$(C?!(B $(C4kGO?)(B $(C?!5pF.8&(B $(CG`GO1b(B $(C@'GQ(B $(C8n0!Av@G(B $(C8^@LA.8p5e8&(B $(C0.0m(B $(C@V=@4O4Y(B. +$(C>n62(B $(C6'6s55(B $(C9]5e=C(B $(C>n4@0M@N0!@G(B $(C8^@LA.8p5e@G(B $(C;sEB7N(B $(C5G>n(B $(C@V=@4O4Y(B. + + $(C0"0"@G(B $(C8^@LA.8p5e4B(B $(C8n0!Av@G(B $(C8m7I>n8&(B $(C@|Gt(B $(C4Y8%(B $(CG`5?@87N(B $(CGO?)(B $(C9v(B +$(C834O4Y(B. $(C?98&(B $(C5i>n(B $(C:8=J4O4Y(B. $(CGA7N1W7%(B $(C3;?!(B $(C8m7I>n8&(B $(C885e4B(B $(C8m7I>n0!(B $(C@V(B +$(C=@4O4Y(B. $(C8m7I>n8&(B $(C>n60GQ(B $(CG|=D@87N(B $(CGO4B0!4B(B, $(C0"(B $(CGA7N1W7%>p>n?!(B $(C5{6s<-(B +$(C4Y8#Av88(B, $(C0"0"@G(B $(C8^@LA.8p5e4B(B, $(C9]5e=C(B $(C3V>nA]4O4Y(B. + + $(C0"0"@G(B $(C8^@LA.8p5e?!(B $(C5i>n0!1b(B $(C@'GQ(B $(C8m7I>n4B(B $(C8p5e8m@L(B $(CH.@e5H(B $(C0M@87N(B +$(C5G>n(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, M-x fundamental-mode$(C4B(B Fundamental$(C7N(B $(C5i>n0!(B +$(C1b(B $(C@'GQ(B $(C0M@T4O4Y(B. + + $(C88>`(B, $(C?5>n8&(B $(C?!5pF.GQ4Y8i(B, Text mode$(C7N(B $(C5i>n0)4O4Y(B. + + >> M-x text-mode $(C6s0m(B $(CE8@LGAGO<> C-h m $(C8&(B $(C;g?kGO?)(B Text mode$(C?M(B Fundamental mode$(C@G(B $(CBw@L8&(B $(C>K>F(B + $(C:8<> C-x 1$(C7N(B $(C55E%8UF.8&(B $(CH-8i@87N:NEM(B $(CAv?l<n(B $(C>KFD:*@;(B $(C1W4k7N(B $(C@T7BGR(B $(Cs@;(B $(C:8<n(B $(C@V=@4O4Y(B. Mule $(C@:(B, $(CH-@O@TCb7B(B, $(C@T7B(B, $(CH-8iCb7B?!(B $(C4kGO?)(B, $(C0"(B +$(C0"(B $(C5683@{@87N(B $(CDZ5eC<0h8&(B $(CAvA$=CE3(B $(C> $(C8p5e6s@N(B $(C@'?!(B "J:","S:", $(CH$@:(B "E:"$(C0!(B $(CG%=C5G>n(B $(C@V4B0!(B $(CH.@N(B + $(CGO<n(B $(C@L?\(B +$(C@G(B $(C9.@Z(B($(C@O:;>n(B, $(CGQ19>n5n(B)$(C55(B $(CG%=CGQ4Y4B(B $(C0M@;(B $(C3*E83;0m(B $(C@V=@4O4Y(B. J$(C4B(B +JUNET$(C@87N(B $(C;g?k5G0m(B $(C@V4B(B JIS $(CDZ5e(B, S $(C4B(B Shift-JIS, E $(C4B(B $(C@O:;>n(BEUC $(C8&(B $(C3*(B +$(CE83;0m(B $(C@V=@4O4Y(B. $(C4Y19>n(B $(CG%=C@G(B $(C@/9+4B(B C-x C-k t $(C7N(B ON/OFF$(C@G(B $(CEd1[@L(B $(C0!(B +$(C4IGU4O4Y(B. + + $(C4Y@=@G(B $(C?94B(B, $(C@O4\(B $(C4Y19>nG%=C8&(B OFF$(CGO0m3*<-(B, $(C4Y=C(B $(CGQ9x(B ON$(C@;(B $(CG`GO?)(B +$(C:>4O4Y(B. + + >> C-x C-k t$(C8&(B 2$(C9x(B $(CG`GO<n(B $(C@V@;(B $(C6'(B, $(C88>`(B $(C4g=E@L(B $(C;g?kGO0m(B $(C@V(B +$(C4B(B $(C4\8;?!(B $(C8^EM(B*$(CE00!(B $(C:Y>n(B $(C@V@88i(B, $(C@L=:DI@LGA(B*$(CE0(B $(C4k=E?!(B $(C1W0M@;(B $(C;g?kGO4B(B +$(C0M@L(B $(C0!4IGU4O4Y(B. $(C@L(B $(C6'(B, $(C8^EM(B*$(CE0@G(B $(C;g?k9f9}@:(B $(CD\F.7Q(B*$(CE0?M(B $(C00@L(B $(C4)8#8i<-(B +$(C9.@Z8&(B $(CE8@LGAGU4O4Y(B. ESC <$(C9.@Z(B>$(C55(B M-<$(C9.@Z(B>$(C55(B $(C00@:(B $(C@[5?@;(B $(CGU4O4Y(B. $(CAv1](B +$(C1nAv@G(B $(C<38m?!<-(B ESC <$(C9.@Z(B>$(C6s0m(B $(CG`GO0m(B $(C@V4x(B $(C0w@L(B, M-<$(C9.@Z(B>$(C7N(B $(C5K4O4Y(B. $(CAV(B +$(C@GGX>_(B $(CGO4B(B $(C0M@:(B, $(C=,GAF.(BJIS$(C3*(B EUC$(CDZ5e(B $(C6'4B(B $(C;g?kGR(B $(Cx=@4O4Y(B. + + $(CDZ5eC<0h@G(B $(C13C<4B(B, $(C0"0"@G(B $(C9vF[?!(B $(C4kGX<-88(B $(C@/H?GU4O4Y(B. $(C0"0"@G(B, $(CDZ(B +$(C5eC<0h(B $(CAvA$?!(B $(C4kGX<-4B(B, C-h a coding-system $(C@87N:<(B $(C> C-h a coding-system $(C@87N(B $(C3*?@4B(B $(C55E%8UF.(B $(C3;@G(B, + set-display-coding-system, set-file-coding-system, + set-process-coding-system $(C@G(B $(C<38m@;(B $(C@P>n:8<n4B(B, $(CD?<-@'D!(B $(C@LHD8&(B $(C0K;vGQ4Y8i(B, C-s, $(CD?<-@'D!(B $(C@L@|@L(B +$(C6s8i(B C-r $(C@T4O4Y(B. C-s $(C8&(B $(CE8@LGAGO8i(B, $(C?!DZ?!8.>n?!(B "I-search:"$(C6s4B(B $(C9.@Z?-(B +$(C@L(B $(CGA7RF.7N<-(B $(CG%=C5K4O4Y(B. ESC$(C8&(B $(C4)8#8i(B, $(CA>7a5K4O4Y(B. + + + >> C-s$(C7N(B $(C0K;v@L(B $(C=C@[5K4O4Y(B. $(C1W8.0m(B, $(CC5C5Hw(B 1$(C9.@Z>?(B "cursor"$(C6s4B(B + $(C4\>n8&(B $(C@T7BGU4O4Y(B. 1$(C9.@Z(B $(C@T7BGR(B $(C6'864Y(B, $(CD?<-4B(B, $(C>n6;0T(B $(C?rAw(B + $(C@T4O1n(B? + + >> $(CGQ9x(B $(C4u(B C-s $(C8&(B $(CE8@LGAGO8i(B, $(C4Y@=@G(B "cursor"$(C8&(B $(CC#@;(B $(C> $(C8&(B 4$(CH8(B $(C@T7BGO0m(B, $(CD?<-@G(B $(C?rAw@S@;(B $(C:8<> ESC$(C8&(B $(C4)8#0m(B, $(CA>7aGU4O4Y(B. + + $(CC#0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAA_?!55(B, $(CE8@LGAGQ(B $(C9.@Z:N:P88@87N(B, $(C0K;v@;(B +$(C=C@[GU4O4Y(B. $(C4Y@=(B $(C9.@Z8&(B $(CC#4B5%4B(B, $(C4Y=C(B C-s$(C8&(B $(CE8@LGAGU4O4Y(B. $(C88>`(B, $(C9.@Z(B +$(C?-@L(B $(CA8@gGOAv(B $(C>J@88i(B, $(C8^<7a5K4O4Y(B. + + $(C0K;v=GG`A_?!(B, $(C8&(B $(C@T7BGO8i(B, $(C0K;v9.@Z?-@G(B $(CA&@O(B $(C5Z@G(B $(C9.@Z0!(B +$(CAv?vA}4O4Y(B. $(C1W8.0m3*<-(B, $(CD?<-4B(B, $(C@L@|9x@G(B $(C@'D!7N(B $(C5G59>F0)4O4Y(B. $(C?98&(B $(C5i(B +$(C8i(B, "cu"$(C6s0m(B $(CE8@LGAGO0m(B, $(CCVCJ@G(B "cu"$(C@G(B $(C@'D!?!(B $(CD?<-0!(B $(C?rAw?44Y0m(B $(CGU=C4Y(B. +$(C?)1b?!<-(B $(C8&(B $(C@T7BGO8i(B, $(C<-D!6s@N@G(B 'u'$(C0!(B $(CAv?vAv0m(B, $(CD?<-4B(B 'u'$(C8&(B +$(CE8@LGAGO1b(B $(C@|?!(B, $(CD?<-0!(B $(C@V>z4x(B 'c'$(C@G(B $(C@'D!7N(B,$(C@L5?GU4O4Y(B. + + $(C0K;v=GG`A_?!(B, C-s $(C3*(B C-r $(C@L?\@G(B $(CD\F.7Q9.@Z8&(B $(CE8@LGAGO8i(B, $(C0K;v@:(B +$(CA>7aGU4O4Y(B. + + C-s $(C4B(B, $(CGv@g@G(B $(CD?<-@'D!(B $(C@LHD?!(B $(C3*?@4B(B $(C0K;v9.@Z?-@;(B $(CC#=@4O4Y(B. $(C88>`(B, +$(C@L@|(B $(CBJ@;(B $(CC#0m(B $(C=M@88i(B, C-r $(C@;(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C?*9fGb0K;v@L(B $(C0!4IGU4O(B +$(C4Y(B. C-s $(C?M(BC-r $(C4B(B, $(C0K;v@G(B $(C9fGb@L(B $(C9]4k@O(B $(C;S(B, $(C@|:N(B $(C00@:(B $(C?rAw@S@;(B $(CGU4O4Y(B. + +$(C8.D?=C:j(B $(C?!5pFC(B $(C79:'(B + + $(C6'6'7N(B, ($(C:;@G(B $(C>F4O0T(B) $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'@L6s0m(B $(C:R8.4B(B $(C;sEB?!(B $(C5i(B +$(C>n0!4B(B $(C6'0!(B $(C@V=@4O4Y(B. $(C8^@LA.8p5e@G(B $(CJ=@4O4Y(B. + + $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@1b(B $(C@'GX<-4B(B, M-x top-level +$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + >> $(C=CGhGO?)(B $(C:8<z4x(B $(C0M@T4O(B +$(C4Y(B. M-x top-level$(C@:(B, $(C>F9+71(B $(C?5Gb@;(B $(CAV0m(B $(C@VAv(B $(C>J=@4O4Y(B. + + $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@4B(B $(C0M?!(B $(C4kGX<-4B(B C-g$(C4B(B $(C5hAv(B $(C>J(B +$(C=@4O4Y(B. + + +$(CGoGA(B +==== + + Emacs$(C?!4B(B, $(C89@:(B $(C55?r1b4I@L(B $(C@V0m(B, $(C?)1b?!<-(B, $(C@|:N8&(B $(C<38mGO4B(B $(C0M@:(B +$(C:R0!4IGU4O4Y(B. $(C1W7/3*(B, $(C>FAw(B $(C8p8#4B(B $(C89@:(B $(C1b4I@;(B $(C9h?l1b(B $(C@'GX<-4B(B, +$(C6s0m(B $(C:R8.4B(B C-h $(C8&(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C89@:(B $(CA$:88&(B $(C@Tn<-(B $(CGJ?dGQ(B $(C?In62(B $(C?I`(B, C-h $(C8&(B $(CE8@LGAGO0m3*<-(B $(C86@=@L(B $(C:/G_4Y8i(B, C-g $(C8&(B $(CE8@LGAGO8i(B, +$(CCkn<-(B $(CE08&(B $(C@T7BGO8i(B, $(C1W(B +$(C8m7I>n?!(B $(C4kGQ(B $(CB*@:(B $(C<38m@;(B $(CG%=CGU4O4Y(B. + + >> C-h c C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<oGO0m(B $(C@VAv(B $(C>J@:(B $(C8m7I>n55(B $(C;}0"GX(B $(C3>(B $(Cn55(B C-h c $(C@G(B $(C5Z?!(B $(C@L>n(B +$(CA}4O4Y(B. + + $(C4u?m(B $(C;s<K0m(B $(C=M@88i(B, c $(C4k=E?!(B k $(C8&(B $(CAvA$GU4O4Y(B. + + >> C-h k C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<n@G(B $(C@L8'0z(B $(C1b4I@L(B $(CG%=C5K4O4Y(B. $(C4Y(B $(C@P>z@88i(B, +C-x 1 $(C6s0m(B $(CE8@LGAGO8i(B, $(C:|A.3*?I4O4Y(B. + + $(C@L?\?!55(B $(C55?r@L(B $(C5G4B(B $(C?I> C-h f previous-line $(C@;(B $(CE8@LGAGO0m(B, $(C@;(B $(C4)8#<n8&(B $(C=GG`GO4B(B $(CFcn8&(B $(CG%=CGU4O4Y(B. $(C@L(B $(C8m7I>n5i@:(B $(C8p5N(B ESC x $(C7N(B $(C=GG`GR(B + $(C> C-h a file $(C>K0m(B $(CE8@LGAGO0m(B, $(C@;(B $(C4)8#<n8&(B $(CG%=CGU4O4Y(B. $(C6GGQ(B, + find-file $(C@L3*(B write-file$(C6s4B(B $(C@L8'@G(B C-x C-f $(C3*(B C-x C-w $(C?M(B $(C00(B + $(C@:(B $(C8m7I>n55(B $(CG%=C5K4O4Y(B. + +$(C3!@87N(B +====== + +$(C@XAv8;0m(B: $(CA>7aGO4B5%4B(B, C-x C-c $(C6s0m(B $(CGU4O4Y(B. + + + $(C@L(B $(C@T9.Fm@:(B, $(CCJ=I@Z?!0T55(B $(C>K1b(B $(C=10T(B $(CGO557O(B $(C@G55GO0m(B $(C@V=@4O4Y(B. +$(C1W7/9G7N(B, $(CH$=C(B $(C9+>y@N0!(B $(C@LGXGO1b(B $(C>n7A?n(B $(CA!@L(B $(C@V4Y8i(B, $(CH%@Z<-(B $(CG*3d(B +$(CGOAv(B $(C8;0m(B, $(CF.A}@;(B $(C@b>F(B $(CAV<`(B, EMACS $(C8&(B $(C8n@OA$55(B $(C;g?kGO0m(B $(C:88i(B, $(C1W0M@;(B $(C1W885P4Y4B(B $(C0M@:(B +$(C8xGO0T(B $(C5I(B $(C0M@T4O4Y(B. $(CCVCJ?!4B(B $(C>n8.5U@}GR(B $(CAv55(B $(C8p8#0Z=@4O4Y(B. $(C1W7/3*(B, +$(C1W0M@:(B $(C>n60GQ(B $(C?!5pEM6s55(B $(C6H(B $(C00=@4O4Y(B. EMACS $(C?M(B $(C00@L(B, $(C4k4\Hw(B $(C89@:(B $(C0M@L(B +$(C0!4IGQ(B $(C0f?l?!4B(B $(CF/Hw(B $(C1W780ZAv?d(B. $(C1W8.0m(B, EMACS $(C?!<-4B(B, $(C=GA&7N(B, $(C9+>y@L(B +$(C3*(B $(CGR(B $(Cn(B MicroEMACS (kemacs) $(C@T9.Fm(B" +$(C@;(B GNUE- macs (Nemacs)$(C@G(B Tutorial$(C?k@87N(B $(C0mCD>4(B $(C0M@T4O4Y(B. + + Jonathan Payne $(C?!(B $(C@GGQ(B "JOVE Tutorial" (19 January 86) $(C@;(B $(C:/0fGQ(B + $(C0M@L0m(B, $(C1W0M@:(B $(C?x7!(B, CCA-UNIX$(C@G(B Steve Zimmerman $(C?!(B $(C@GGX<-(B $(C:/0f5H(B, + MIT $(C@G(B "Teach-Emacs" $(C@T9.Fm(B (31 October 85) $(C@;(B ($(C4u?m(B) $(C:/0fGQ(B $(C0M@L(B + $(C>z=@4O4Y(B. + + Update - February 1986 by Dana Hoggatt. + + Update - December 1986 by Kim Leburg. + + Update/Translate - July 1987 by SANETO Takanori + +$(CF/:0GQ(B $(C0(;g(B +=========== + + $(CCVCJ?!(B $(C@L(B $(C@O:;>n9x?*@;(B $(C@[<:GQ(B, SANETO Takanori$(C>>(B. $(C@L(B $(C9.@e@:(B GMW + +Wnn + Nemacs$(C@;(B $(C;g?kGO?)(B $(C@[<:G_=@4O4Y(B. $(C1W?M(B $(C00@:(B $(CHG8"GQ(B $(CGA7N1W7%@;(B $(C885g(B +$(C8p5g(B $(C:P?!0T(B $(C0(;g@G(B $(C6f@;(B $(CG%GO0m(B $(C=M=@4O4Y(B. $(C9x?*@L6s5g0!(B, $(C@T7B(B $(C5n(B +$(C?)7/8p7N(B $(C55?M(B $(CAX(B $(CHDAvGO6s>(B, $(C4k4\Hw(B $(C0(;gGU4O4Y(B. + + + +$(C?@?*(B, $(C0EA~(B, $(C@L(B $(C?\@G(B $(C9.C%@:(B $(C>F7!@G(B $(C;g6w?!0T(B $(C@V=@4O4Y(B. + + $BNkLZM5?.(B hironobu@sra.co.jp + + +Update/Add - December 1987 by Hironobu Suzuki +Update/Add - November 1989 by Ken'ichi Handa +Update/Add - January 1990 by Shigeki Yoshida +Update/Add - March 1992 by Kenichi HANDA + + +$(C6G4Y8%(B $(C0(;g(B +=========== + + $(C@L(B $(C9.<-4B(B "$(C@O:;>n(B GNUEMACS(Mule) $(C@T9.Fm(B"$(C@;(B $(CGQ19>n7N(B $(C9x?*GO?)(B, +hemacs$(C7N(B $(C@[<:GQ(B $(C0M@T4O4Y(B. $(C@O:;>n9x?*@;(B $(C4c4gGQ(B $(C8p5g(B $(C:P(B, hemacs$(C8&(B +$(C039_GO?)(B $(CAV=E(B $(C:P(B, $(CF/Hw(B Mule$(C0z(B hemacs$(C@G(B $(CH/0f18C`?!(B $(C89@:(B $(C55?r@;(B $(CAX(B +$(C136G4kGP(B $(C3*0!?@?,18=G(B $(CA9>w;}@N(B Masashi SHIMBO$(C>>?M(B Katsuyoshi +Yamagami$(C>>?!0T(B $(C0(;g@G(B $(C6f@;(B $(C@|GU4O4Y(B. + + 1993. 9. 25 + + $(C136G4kGP(B $(C0xGP:N(B $(C@|1b0xGP0z(B $(C3*0!?@?,18=G(B + Dosam HWANG hwang@forest.kuee.kyoto-u.ac.jp diff -r d3e9274cbc4e -r e45d5e7c476e etc/TUTORIAL.no --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.no Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1126 @@ +Copyright (c) 1997, Stig Bjørlykke +Se i slutten av dokumentet for vilkår og betingelser. + +Dette dokumentet er basert på den engelske veiledningen, som er +Copyright (c) 1985, 1996 Free Software Foundation, Inc. + + +Dette er den norske brukerveiledningen til Emacs. + +Emacs-kommandoer inkluderer ofte bruk av CONTROL-tasten (noen ganger +merket CTRL eller CTL) eller META-tasten. På noen tastaturer er +META-tasten merket ALT eller EDIT eller noe annet (på Sun-tastaturer +for eksempel, er det "ruter"-tasten til venstre for mellomromstasten). +Hvis du ikke har noen META-tast kan du bruke ESC. Istedenfor å skrive META +eller CONTROL vil vi her bruke følgende forkortelser: + + C- betyr at du skal holde nede CONTROL-tasten mens du trykker + bokstaven . Dermed vil C-f bety: hold nede + CONTROL-tasten og trykk f. + M- betyr at du skal holde nede META-tasten mens du trykker + . Hvis du ikke har noen META-tast kan du trykke , + slippe tasten, og så trykke bokstaven . + +Viktig: for å avslutte Emacs trykker du C-x C-c. (To tegn.) +Tegnene ">>" helt til venstre angir en veiledning slik at du kan prøve +ut en kommando. For eksempel: +<> +>> Trykk C-v (View next screen) for å hoppe til neste skjermbilde. + (kom igjen, hold ned control-tasten og trykk v). Fra nå av + bør du gjøre dette hver gang du er ferdig med å lese et + skjermbilde. + +Merk at det er en overlapping på to linjer når du skifter fra +skjermbilde til skjermbilde. Dette er for at det skal bli en viss +kontinuitet når du skal bevege deg gjennom filen. + +Det første du trenger å vite er hvordan du manøvrerer deg i fra plass +til plass i teksten. Du har allerede lært hvordan du flytter deg ett +skjermbilde framover, med C-v. For å flytte deg et skjermbilde +bakover trykker du M-v (hold ned META-tasten og trykk v, eller trykk +v hvis du ikke har META-, EDIT- eller ALT-tast). + +>> Prøv å trykke M-v og så C-v noen ganger. + + +* OPPSUMMERING +-------------- + +Følgende kommandoer er nyttige for å se hele skjermbilder: + + C-v Flytt ett skjermbilde framover. + M-v Flytt ett skjermbilde bakover. + C-l Rensker skjermen og plasser teksten der markøren står + på midten av skjermbildet. (Det var control-(liten L), + ikke control-1. Control-1 har en helt annen mening, + som beskrevet nedenfor.) + +>> Finn markøren og se hva slags tekst som står der. + Trykk C-l. + Finn markøren igjen og se hva slags tekst som står der nå. + + +* GRUNNLEGGENDE MARKØRBEVEGELSER +-------------------------------- + +Det å flytte seg fra skjermbilde til skjermbilde er nyttig, men +hvordan flytter man seg til en spesiell plass innenfor skjermbildet? + +Det er flere måter å gjøre dette på. Den vanligste måter er å bruke +kommandoene C-p, C-b, C-f og C-n. Hver av disse kommandoene flytter +markøren en rad eller kolonne i en bestemt retning på skjermen. Her +vises disse fire kommandoene og i hvilken retning de flytter markøren: + + + Forrige linje (previous), C-p + : + : + Bakover, C-b .... Nåværende markørposisjon .... Framover, C-f + : + : + Neste linje (next), C-n + +>> Flytt markøren til linjen midt i diagrammet ved å bruke C-n og C-p. + Bruk så C-l for å sentrere diagrammet på skjermbildet. + +Dette er sikkert litt enklere å huske hvis du tenker på disse +forkortelsene: P (engelsk previous) for forrige, N for neste, B for +bakover og F for framover. Dette er de grunnleggende kommandoene for +å flytte markøren, og du kommer sikkert til å bruke dem hele tiden, så +det vil være en stor fordel om du lærer dem nå. + +>> Gjør noen C-n slik at du kommer ned til denne linjen. + +>> Flytt deg innover på linjen ved hjelp av noen C-f og så oppover med + noen C-p. Legg merke til hva C-p gjør når markøren står midt i en + linje. + +Tekstlinjer er atskilt med linjeskift-tegn. Den siste linjen i teksten +avsluttes vanligvis med linjeskift, men Emacs krever ikke at du har +det. + +>> Prøv en C-b i begynnelsen av en linje. Dette gjør at markøren + flyttes til slutten av forrige linje. Dette er fordi den flytter + markøren over linjeskiftet. + +C-f flytter også over linjeskift, akkurat som C-b. + +>> Utfør noen flere C-b slik at du får en følelse av hvor markøren + er. Trykk så noen C-f til du kommer til slutten av linjen. Trykk + da en C-f til slik at du flytter markøren til neste linje. + +Når du flytter markøren forbi toppen eller bunnen av skjermbildet vil +teksten utenfor skjermen komme til syne. Dette kalles "scrolling" og +gjør det mulig for Emacs å flytte markøren uten at den forsvinner ut +av skjermbildet. + +>> Prøv å flytte markøren forbi bunnen av skjermbildet ved hjelp av C-n + og se hva som skjer. + +Hvis det går for tregt å flytte markøren ett og ett tegn kan du flytte +den ett og ett ord. M-f (Meta-f) flytter markøren ett ord framover, +og M-b flytter den ett ord bakover. + +>> Utfør noen M-f og M-b. + +Hvis markøren står midt i et ord vil M-f flytte markøren til slutten +av ordet. Hvis du står midt mellom to ord vil M-f flytte markøren til +slutten av det kommende ordet. M-b fungerer på samme måte, bare i +motsatt retning. + +>> Trykk M-f og M-b noen ganger og skift markørposisjon med noen C-f + og C-b slik at du ser hvordan M-f og M-b oppfører seg ved + forskjellig plassering av markøren både i og mellom ord. + +Legg merke til parallellen mellom C-f og C-b på en side, og M-f og M-b +på den andre. Ofte er Meta-kommandoer brukt til operasjoner relatert +til enheter definert av språket (ord, setninger, avsnitt), mens +Control-kommandoer blir brukt på grunnleggende enheter som er +uavhengig av hva man redigerer (bokstaver, linjer, etc.). + +Denne parallellen finnes også mellom linjer og setninger: C-a og C-e +flytter markøren til begynnelsen av linjen, eller til slutten av +linjen, mens M-a og M-e flytter den til begynnelsen eller slutten av +setningen. + +>> Prøv noen C-a, og så noen C-e + Prøv også noen M-a, og så noen M-e + +Se hvordan gjentatte C-a etter hverandre ikke gjør noe, mens flere M-a +fortsetter å flytte markøren til neste setning. Selv om dette ikke +virker selvfølgelig er det ganske naturlig. + +Her er en kort oppsummering av de enkleste markørforflyttnings- +kommandoene, inkludert ord- og setningsforflyttnings-kommandoene: + + C-f Flytte markøren en plass framover + C-b Flytte markøren en plass bakover + + M-f Flytte markøren ett ord framover + M-b Flytte markøren ett ord bakover + + C-n Flytte markøren til neste linje + C-p Flytte markøren til forrige linje + + C-a Flytte markøren til begynnelsen av linjen + C-e Flytte markøren til slutten av linjen + + M-a Flytte markøren til begynnelsen av setningen + M-e Flytte markøren til slutten av sentingen + +>> Prøv ut alle disse kommandoene noen ganger, bare for trening. + Dette er de mest brukte kommandoene. + +To andre viktige markørbevegelses-kommandoer er M-< (Meta Mindre-enn), +som flytter markøren til begynnelsen av teksten, og M-> (Meta +større-enn), som flytter den til slutten av teksten. + +På noen tastaturer er ">" plassert over komma, så man må bruke shift +for å få den fram. På disse tastaturene må man også bruke shift for å +taste M-<. Uten shift-tasten vil det bli M-komma. + +>> Prøv M-< nå for å flytte markøren til begynnelsen av veiledningen. + Bruk så C-v for å flytte markøren tilbake hit igjen. + +>> Prøv også M-> for å flytte markøren til slutten av veiledningen. + Bruk så M-v for å flytte markøren tilbake hit igjen. + +Du kan også flytte markøren ved hjelp av piltastene, hvis terminalen +har piltaster. Vi anbefaler at du lærer deg C-b, C-f, C-n og C-p av +tre grunner. Først fordi de vil fungere på alle slags terminaler. +Nummer to fordi når du først får litt trening i bruk av Emacs vil du +finne ut at det går mye kjappere å bruke control-kombinasjoner enn +piltastene (fordi du slipper å flytte hendene bort fra +touch-plasseringen). Den tredje grunnen er at når du først har lært +deg til å bruke control-tastene blir det lettere å lære seg de mer +avanserte control-funksjonene. + +De fleste av kommandoene i Emacs tar også et numerisk argument. For +de fleste av kommandoene vil dette si repetert utførelse. Måten du +gir en kommando et slikt argument er at du trykker C-u og deretter +tallet, før du taster kommandoen. Hvis du har en META- (eller EDIT- +eller ALT-) tast så finnes det et annet alternativ for å gi numeriske +argumenter: Trykk ned tallet mens du holder META-tasten nede. Vi +anbefaler at du bruker C-u fordi det fungerer på alle slags +terminaler. + +For eksempel: C-u 8 C-f flytter markøren åtte plasser framover. + +>> Prøv kommandoene C-n eller C-p med numerisk argument slik at du + kommer nærmest mulig denne linjen med bare en kommando. + +De fleste kommandoene bruker det numeriske argumentet som en repetert +utførelse. Men det finnes kommandoer som bruker den annerledes. C-v +og M-v er blant disse unntakene. Hvis man gir et argument til en av +disse kommandoene vil skjermbildet flytte seg opp eller ned så mange +linjer som argumentet, isteden for så mange skjermbilder. For +eksempel vil C-u 4 C-v flytte skjermbildet 4 linjer oppover. + +>> Prøv å taste C-u 8 C-v nå. + +Dette burde flyttet skjermbildet 8 linjer oppover. Hvis du ønsker å +flytte det tilbake igjen er det bare å gi samme argument til M-v. + +Hvis du bruker Emacs under X er det sannsynligvis et firkantet område +på høyresiden av Emacs-vinduene, også kalt rullefelt. Dette kan du +også bruker for å forflytte deg innenfor teksten. + +>> Prøv å trykk på den midterste musknappen i det uthevete området på + rullefeltet. Dette burde flyttet skjermbildet til en plass i + teksten avhengig av hvor i rullefeltet du trykket. + +>> Flytt muspekeren til en plass i rullefeltet ca. 1/5 fra toppen og + trykk på venstre musknapp noen ganger. + + +* MARKØRBEVEGELSE PÅ EN X-TERMINAL +---------------------------------- + +Hvis du sitter på en X-terminal vil du sansynligvis finne det mye +enklere å bruke piltastene for å bevege markøren. Venstre-, høyre-, opp- +og ned-pilene beveger markøren i ønsket retning. De fungerer på samme +måte som C-b, C-f, C-p og C-n, men er enklere å taste og huske. Du +kan også bruke C-venstre og C-høyre for å bevege den innenfor ord, og +C-opp og C-ned for å bevege den innenfor blokker (For eksempel +avsnitt hvis du redigerer tekst). Hvis du har tastene merket HOME +(eller BEGIN) og END kan du bruke disse for å gå til henholdsvis +begynnelsen av linjen og slutten av linjen, og C-HOME og C-END vil gå +til henholdsvis begynnelsen av filen og slutten av filen. Hvis +tastaturet har PgUp- og PgDn-taster kan du bruker dem for å gå opp og +ned et skjermbilde av gangen, på samme måte som M-v og C-v. + +Alle disse kan ta numeriske argumenter, som beskrevet ovenfor. Du kan +også benytte en snarvei for å skrive inn disse argumentene: hold ned +CONTROL eller META tasten og skriv inn nummeret. For eksempel for å gå +12 ord til høyre taster du C-1 C-2 C-høyre. Legg merke til at dette +blir svært enkelt å taste fordi du ikke slipper CONTROL-tasten mellom +tastetrykkene. + + +* HVIS EMACS HENGER +------------------- + +Hvis Emacs slutter å reagere på kommandoer kan du trygt stoppe den ved +å trykke C-g. Du kan også bruke C-g for å stoppe en kommando som tar +for lang tid å utføre. + +Det er også mulig å bruke C-g for å avbryte et numerisk argument eller +begynnelsen på en kommando du ikke ønsker å utføre. + +>> Tast C-u 100 for å lage et numerisk argument på 100 og trykk C-g. + Trykk nå C-f. Markøren skal nå flytte seg bare ett steg, + fordi du avbrøt argumentet med C-g. + +Hvis du ved en feiltakelse trykket blir du kvitt denne ved å +trykke C-g. + + +* UTILGJENGELIGE KOMMANDOER +--------------------------- + +Enkelte av Emacs-kommandoene er "utilgjengelige" slik at nybegynnere +ikke kan bruke dem uten at de ønsker det. + +Hvis du prøver en av disse utilgjengelige kommandoene vil Emacs komme +med en melding som forteller hvilken kommando det er, og vil spørre om +du virkelig vil fortsette å utføre denne kommandoen. + +Hvis du virkelig ønsker å prøve denne kommandoen trykker du mellomromstast +som svar på spørsmålet. Normalt, hvis du ikke ønsker å kjøre denne +kommandoen, svarer du "n" på spørsmålet. + +>> Tast `C-x n p' (som er en utilgjengelig kommando), + tast n som svar på spørsmålet. + + +* VINDUER +--------- + +Emacs kan ha flere vinduer, og hver av dem kan vise sin egen tekst. +Legg merke til at "vinduer" i Emacs ikke refererer til separate +overlappende vinduer i vindus-systemet, men til separate buffer +innenfor et enkelt X-vindu. (Emacs kan også ha flere X-vinduer, eller +"rammer" i Emacs-terminologi. Dette blir beskrevet senere.) + +Akkurat nå er det best at vi ikke går inn på teknikker for å bruke +flere vinduer, men du trenger å vite hvordan du blir kvitt ekstra +vinduer som kan dukke opp for å vise hjelp, eller utskrift fra enkelte +kommandoer. Det er enkelt: + + C-x 1 Ett vindu (dvs. gjem alle andre vinduer). + +Det er da Control-x etterfulgt av tallet 1. C-x 1 utvider vinduet der +markøren står, slik at det fyller hele skjermbildet og gjemmer alle +andre vinduer. + +>> Flytt markøren til denne linjen og trykk C-u 0 C-l. + +(Husk at C-l renser skjermen og midtstiller linjen der markøren +står. Hvis du gir et numerisk argument til denne kommandoen betyr det +"rensk skjermen og legg linjen der markøren står på linjen angitt av +argumentet" Derfor betyr C-u 0 C-l at skjermen skal renskes og +linjen der markøren står plasseres øverst.) + +>> Tast Control-x 2. + Se hvordan vinduet krympes og et nytt dukker opp med samme + innhold som dette. + +>> Tast C-x 1 for at vinduet skal forsvinne. + + +* INNSETTING OG SLETTING +------------------------ + +Hvis du ønsker å sette inn tekst er det bare å skrive teksten. Tegn +som du kan se, slik som A, 7, *, ol. blir tolket som tekst og blir +satt rett inn. Tast (enter-tasten) for å sette inn et +linjeskift. + +Du kan slette det siste tastete tegnet ved å trykke . + er en tast på tastaturet, og kan også være merket "Del". I +noen tilfeller fungerer også "Backspace" som , men ikke +alltid! + +Mere generelt sletter tegnet rett foran der markøren er +plassert. + +>> Gjør dette nå -- skriv inn noen tegn og slett dem ved å bruke + . Ikke vær redd for å skrive i denne filen, du vil ikke + kunne forandre på den originale veiledningen. Dette er bare en + lokal kopi. + +Når en linje blir for lang til å passe inn på en skjermbredde så +fortsetter den på linjen under. En backslash ("\") i enden av høyre +marg indikerer at linjen fortsetter. Om du kjører Emacs under X vil +du se en liten pil som peker ned til neste linje. + +>> Skriv inn litt tekst slik at du kommer til enden av linjen, og + fortsett å skrive litt til. Du vil da se hvordan + fortsettelseslinjen blir. + +>> Bruk for å slette teksten inntil linjen passer på en + skjermbredde igjen. Fortsettelseslinjen vil da forsvinne. + +Du kan slette linjeskift akkurat som andre tegn. Ved å slette +linjeskiftet mellom to linjer blir disse smeltet sammen til en. Hvis +resultatet av denne sammensmeltingen blir for stor til å passe på en +skjermbredde så vil den bli vist med en fortsettelseslinje. + +>> Flytt markøren til begynnelsen av en linje og trykk . + Dette vil spleise sammen linjen med linjen over. + +>> Trykk for å sette inn linjeskiftet du slettet. + +Husk at de fleste Emacs-kommandoene kan ta numeriske argumenter. +Dette gjelder også tekst-tegn. Ved å repetere et tekst-tegn vil det +komme flere ganger. + +>> Prøv det nå: tast C-u 8 * for å sette inn ********. + +Du har nå lært de mest grunnleggende måtene å skrive noe inn i Emacs, +og å rette feil. Du kan slette ord eller linjer også. Her er en +oversikt over kommandoer for sletting: + + sletter tegnet som står rett foran markøren + C-d sletter tegnet som står rett under markøren + + M- sletter ordet rett foran markøren + M-d sletter ordet rett etter markøren + + C-k sletter fra markøren til slutten av linjen + M-k sletter til slutten av setningen + +Legg merke til at og C-d kontra M- og M-d fortsetter +parallellen som ble startet av C-f og M-f (vel, er ikke +akkurat noe kontroll-tegn, men la oss ikke bry oss om det). C-k og +M-k fungerer på samme måte som C-e og M-e (nesten). + +Når du sletter flere enn ett tegn om gangen vil Emacs lagre den +slettete teksten slik at du han hente den tilbake igjen. Denne +teksten blir kalt "killed text". Å bringe tilbake "killed text" blir +kalt "yanking". Du kan enten hente tilbake "killed text" på samme +plassen som den ble slettet, eller du kan sette den inn en annen plass +i teksten. Du kan også hente den tilbake flere ganger etter hverandre +slik at du får flere like forekomster av den. Kommandoen for å hente +tilbake teksten er C-y. + +Legg merke til at forskjellen mellom "killed text" og "deleted text" +er at "killed text" kan bli hentet tilbake, mens "deleted text" ikke +kan det. Generelt kan man si at kommandoer som sletter flere enn ett +tegn lagrer unna teksten slik at den kan bli hentet tilbake, og +kommandoer som bare sletter ett tegn, eller tomme linjer og mellomrom +ikke lagrer det. + +>> Flytt markøren til begynnelsen av en linje som ikke er tom. + Trykk så C-k for å "kille" teksten på denne linjen. +>> Trykk C-k en gang til. Du vil nå se at den sletter den tomme + linjen som ble stående igjen etter teksten. + +Legg merke til at en enkel C-k bare sletter teksten på linjen, og at +enda en C-k sletter selve linjen og flytter teksten på linjen under en +linje opp. C-k takler numeriske argumenter litt spesielt. Den +sletter så mange linjer OG innholdet i dem. Dette er ikke bare +repetisjon av kommandoen. C-u 2 C-k sletter to linjer samt de tomme +linjene, mens C-k to ganger ikke vil gjøre det. + +Trykk C-y for å hente tilbake teksten som sist ble "killet" der +markøren står. + +>> Prøv dette. Trykk C-k etpar ganger. + +Og hent dem så tilbake igjen: + +>> Trykk C-y. Flytt markøren noen linjer ned og trykk C-y igjen. + Dette er måten å kopiere tekst på. + +Men hva gjør du hvis du har en tekst du ønsker å hente tilbake, og så +"killer" noe nytt? C-y vil hente tilbake den siste teksten som ble +"killet". Men den forrige teksten er ikke fortapt. Du kan få den +tilbake ved å bruke kommandoen M-y. Etter at du har brukt C-y for å +hente tilbake den siste "killed text" vil M-y erstatte denne teksten +med teksten fra den forrige "killed text". Når du har funnet fram til +ønsket tekst trenger du ikke gjøre noe mere for å beholde den. + +Hvis du tastet M-y mange nok ganger vil du komme tilbake til starten +igjen (teksten som sist ble "killet") + +>> "Kill" en linje, flytt markøren til en ny linje og "kill" denne + også. Bruk så C-y for å hente tilbake den siste linjen. Trykk M-y + for å bytte den med den forrige "killete" linjen. Trykk flere M-y + og se hva du får. Fortsett med dette til du får tilbake den første + linjen igjen, og så noen ganger til. Hvis du ønsker kan du prøve + med positive og negative argumenter til M-y. + + +* ANGRE +------- + +Hvis du gjør en forandring i teksten og finner ut at du angrer på det +du har gjort kan du oppheve dette med kommandoen C-x u (undo). + +Normalt vil C-x u oppheve forandringene gjort av den siste utførte +kommandoen. Hvis du repeterer C-x u flere ganger på rad vil hver +repetisjon oppheve enda en utført kommando. + +Men det er to unntak her. Kommandoer som ikke forandrer i teksten +teller ikke (dette inkluderer markørbevegelser og flytte-kommandoer), +og inntastede enkeltbokstaver blir vanligvis gruppert i grupper på opp +til 20 tegn. (Dette er for å redusere antall C-x u'er som trengs for +å angre inntastet tekst.) + +>> "Kill" denne linjen med C-k. C-x u vil få den tilbake igjen. + +C-_ er en alternativ angre-kommando. Den fungerer på samme måte som +C-x u, men er enklere å taste flere ganger på rad. Ulempen med C-_ er +at den er vanskelig å finne fram til på enkelte tastaturer. Det er +derfor vi i tillegg har C-x u. På enkelte terminaler kan du få fram +C-_ ved å trykke / mens CTRL er holdt nede. + +Et numerisk argument til C-_ eller C-x u vil repetere antall +angringer. + + +* FILER +------- + +For at teksten du har forandret på skal lagres permanent må du legge +den i en fil. Hvis ikke vil den forsvinne når du avslutter Emacs. Du +legger teksten i en fil ved først å "finne" denne filen. (Dette blir +også kalt å "besøke" filen.) + +Det å finne en fil betyr at du henter innholdet av filen inn i Emacs. +På mange måter er det som om du forandrer på selve filen, men +forandringene du gjør på filen mens du benytter Emacs vil ikke bli +permanente får du lagrer filen. Dette er fordi du skal slippe å legge +igjen halv-forandrete filer hvis du ikke ønsker det. Og selv når du +lagrer vil Emacs legge igjen en backup-fil i tilfelle du senere +bestemmer deg for at du ikke ønsker disse forandringene. + +Hvis du ser nesten nederst i skjermbildet så vil du se en linje som +begynner og slutter med minustegn, og som inneholder teksten "XEmacs: +TUTORIAL.no". Denne delen av skjermbildet vil alltid vise navnet på +filen du er "inne i". Akkurat nå er du inne i en fil som heter +"TUTORIAL.no" og som er en personlig kopi av Emacs- veiledningen. +Samme hvilken fil du er inne i så vil filnavnet stå akkurat på denne +plassen. + +Kommandoene for å finne filer og lagre filer er litt ulike de andre +kommandoene du har lært fordi de består av to tegn. Begge starter med +tegnet Control-x. Det er faktisk mange kommandoer som starter med +Control-x, og mange av dem har med filer, skjermbilder og slike ting å +gjøre. Disse kommandoene er to, tre eller fire tegn lange. + +En annen ting med kommandoen for å finne filer er at du må fortelle +hvilket filnavn du ønsker. Vi sier at kommandoen "leser et argument +fra terminalen" (i dette tilfellet vil argumentet være navnet på +filen). Etter at du har trykket kommandoen + + C-x C-f Finn en fil + +vil Emacs spørre etter et filnavn. Filnavnet du skriver vil komme +fram på den nederste linjen i skjermbildet. Denne linjen blir kalt +minibuffer når det blir brukt slik. Du kan bruke vanlige +Emacs-redigeringskommandoer for å forandre på filnavnet. + +Mens du holder på å skrive inn filnavnet (eller noe annet i +minibuffret) kan du avbryte med kommandoen C-g. + +>> Tast C-x C-f og så C-g. Dette avbryter minibuffret og avbryter + også C-x C-f kommandoen som brukte minibuffret. + +Når du er ferdig med å skrive filnavnet trykker du for å +fullføre kommandoen. Da vil C-x C-f kommandoen begynne å lete fram +filen. Minibuffret forsvinner når C-x C-f kommandoen er ferdig. + +Om en liten stund vil filen komme inn i skjermbildet og du kan begynne +å redigere innholdet. Når du ønsker å lagre filen kan du bruke denne +kommandoen + + C-x C-s Lagre fil + +Denne kopierer teksten i skjermbildet over til filen. Første gang +dette gjøres vil Emacs døpe om det originale filnavnet til et nytt +navn slik at den ikke går tapt. Det nye filnavnet blir laget ved at +det blir lagt til en "~" i slutten av det originale filnavnet. + +Når lagringen er utført vil Emacs skrive ut navnet på filen som ble +lagret. Du bør lagre ofte slik at du ikke mister så mye om det skulle +oppstå en system-krasj. + +>> Trykk C-x C-s for å lagre en kopi av denne veiledningen. + Dette skal føre til at "Wrote ...TUTORIAL.no" blir + skrevet ut nederst i skjermbildet. + +NB: På noen systemer vil C-x C-s føre til at skjermen "fryses" og du +vil ikke være istand til å utføre noen flere kommandoer. Dette +indikerer at en operativsystem-egenskap kalt "flytkontroll" har +fanget opp C-s'en og ikke sendt den videre til Emacs. For å fortsette +må du trykke C-q. Se da i avsnittet "Spontaneous Entry to Incremental +Search" i Emacs-manualen for råd om hvordan dette kan avverges. + +Du kan finne en eksisterende fil, enten for å forandre den eller for å +se på den. Du kan også finne en fil som ikke eksisterer. Dette er +måten du lager nye filer med Emacs: finn filen, som er tom til å begynne +med, og start å skrive teksten som skal inn i denne filen. Først når du +lagrer filen vil Emacs virkelig opprette filen med den teksten du har +skrevet. Fra nå av kan du betrakte deg selv som om du skriver i en +fil som allerede eksisterer. + + +* BUFFER +-------- + +Hvis du finner en ny fil med C-x C-f vil den første filen fortsatt +være åpen i Emacs. Du kan bytte tilbake til den ved å finne den på +nytt med C-x C-f. På denne måten kan du ha et stort antall åpne filer +i Emacs. + +>> Lag en fil med navnet "foo" ved å trykke C-x C-f foo . + Sett inn litt tekst, forandre litt på den, og lagre "foo" ved å + bruke C-x C-s. Skriv tilslutt C-x C-f TUTORIAL.no + for å komme tilbake til denne veiledningen. + +Emacs lagrer teksten i hver av filene i et objekt kalt "buffer". Når +du finner en ny fil vil det opprettes et nytt buffer i Emacs. For å +se en liste over eksisterende buffer i Emacs kan du trykke + + C-x C-b Utlisting av buffrene. + +>> Prøv C-x C-b nå. + +Se hvordan hvert av buffrene har hvert sitt navn, og at de også kan ha +et filnavn på den filen der innholdet kommer fra. Noen buffre er ikke +knyttet til noen fil, for eksempel bufferet "Buffer List". Det er det +buffret som inneholder listen over buffre som ble generert med C-x +C-b. All teksten du ser i et Emacs-vindu tilhører et buffer. + +>> Tast C-x 1 for å bli kvitt buffer-listen. + +Hvis du gjør forandringer i en av filene og åpner en ny fil så vil ikke +den første filen bli lagret, men forandringene vil fortsatt være i +buffret. Oppretting eller redigering av en ny fil vil ikke påvirke den +første filens buffer. Dette er nyttig, men betyr også at du trenger +en passende måte å lagre den første filens buffer. Det vil bli alt +for omstendig å skifte tilbake til det forrige buffret med C-x C-f for +så å lagre filen med C-x C-s. Derfor har vi kommandoen + + C-x s Lagre noen buffer + +C-x s spør for hvert enkelt buffer som har blitt forandret siden +forrige lagring om du ønsker å lagre dette. + +>> Sett inn en linje med tekst og lagre med C-x s + Du skal nå få et spørsmål om du ønsker å lagre buffret + TUTORIAL.no. Svar ja på spørsmålet ved å taste "y" (yes). + + +* BRUK AV MENYEN +---------------- + +Hvis du bruker en X-terminal vil du sikkert legge merke til menyen på +toppen av skjermbildet. Via denne menyen får du tilgang til de mest +brukte Emacs-kommandoene, slik som "find file". Dette er svært enkelt +i begynnelsen, når du ikke husker alle tastetrykkene som skal til for +hver av kommandoene. Men når du begynner å kjenne Emacs vil det være +lettere å begynne å bruke tastekombinasjonene. Disse står rett ved +siden av menynavnet i menyen. + +Legg merke til at det er mange menypunkter som ikke har en eksakt +tastekombinasjon. For eksempel "Buffers"-menyen, som lister ut alle +tilgjengelige buffre sortert i "sist brukt"-rekkefølge. Du kan enkelt +skifte til et buffer ved å finne navnet på det i "Buffers"-menyen og +velge det. + + +* BRUK AV MUSA +--------------- + +Når du kjører Emacs under X er det muligheter for å bruke musen. Du +kan plassere markøren ved å trykke venstre mustast der du ønsker at +den skal være, og du kan markere tekst ved å holde nede venstre +mustast mens du beveger markøren over teksten du ønsker å markere. +(Eller alternativt: klikk venstre mustast i den ene enden av teksten +du ønsker å markere, flytt muspekeren til den andre enden og bruk +Shift-klikk for å markere teksten.) + +For å "kille" den markerte teksten kan du bruke kommandoen C-w eller +velge Cut fra "Edit"-menyen. Legg merke til at disse *ikke* er +likeverdige. C-w lagrer bare teksten internt i Emacs (ala C-k, som +beskrevet ovenfor), mens Cut legger også teksten i X sitt "clipboard", +der den også blir tilgjengelig for andre applikasjoner. + +For å hente tekst fra X-clipboard'et kan du bruke "Paste" fra "Edit"- +menyen. + +Den midterste musknappen blir vanligvis brukt for å velge "linker" som +er tilgjengelig i skjermbildet. Hvis du for eksempel går inn i Info +(on-line dokumentasjonen til Emacs) ved å bruke C-h i, eller "Help"- +menyen, kan du følge linkene ved å trykke den midterste musknappen. +Og hvis du skriver inn et filnavn (For eksempel "Find File"), og +trykker TAB for å få fram en fillisting, så kan du komplettere filnavnet +ved å trykke den midterste musknappen på filnavnet. + +Ved å trykke høyre musknapp vil du få fram en popup-meny. Innholdet i +denne menyen er avhengig av hvilken modus du er inne i, og vanligvis +inneholder den et par av de mest brukte kommandoene slik at de blir +lett tilgjengelige. + +>> Trykk høyre mustast nå. + +Du er nødt til å holde knappen nede for at menyen skal vises. + + +* UTVIDING AV KOMMANDOSETTET +---------------------------- + +Det finnes mange flere Emacs-kommandoer enn det som er mulig å tilegne +control- eller meta-taster. For å komme rundt dette har Emacs en "X"- +(eXtend) kommando. Denne kommer i to utgaver: + + C-x Tegn-utvidelse. Etterfulgt av et tegn. + M-x Navngitt kommandoutvidelse. Etterfulgt av et + kommandonavn. + +Dette er kommandoer som er generelt viktige, men som blir brukt mindre +enn de kommandoene du allerede har lært. Du har allerede sett to av +dem, C-x C-f for Find, og C-x C-x for Save. Et annet eksempel er +kommandoen for å avslutte Emacs, som har kommandoen C-x C-c. (Ikke +vær redd for å miste eventuelle forandringer du har gjort, C-x C-c vil +sørge for at du får lagret de forandringene du ønsker før Emacs +avslutter.) + +C-z er kommandoen for å avslutte Emacs *midlertidig* slik at du kan +vende tilbake til samme Emacs senere. + +På systemer som tillater det vil C-z suspendere Emacs, dvs. returnere +tilbake til skallet uten å drepe Emacs-prosessen. I de fleste +skallene kan du få tilbake Emacs med kommandoen `fg', eller `%xemacs'. + +På systemer som ikke har implementert denne egenskapen vil C-z +opprette et skall som kjører under Emacs, og som gir deg sjansen til å +kjøre andre programmer og så returnere til Emacs etterpå. Den gir ingen +eksakt avslutning av Emacs. I slike tilfeller vil vanligvis +kommandoen `exit' returnere fra skallet og tilbake til Emacs. + +C-x C-c benyttes når du skal avslutte Emacs. Det er også fornuftig å +avslutte Emacs hvis den har blitt startet opp av et mail-program, +eller andre applikasjoner, siden det ikke er sikkert at de greier å +håndtere suspendering av Emacs. Under normale omstendigheter, hvis du +ikke har tenkt å logge ut, er det bedre å suspendere Emacs med C-z +isteden for å avslutte. + +Det finnes mange C-x kommandoer. Her er en liste over dem du har +lært: + + C-x C-f Finne fil. + C-x C-s Lagre fil. + C-x C-b Utlisting av buffrene. + C-x C-c Avslutte Emacs. + C-x u Angre. + +Navngitte kommandoer er kommandoer som blir brukt mye sjeldnere, eller +kommandoer som bare brukes i bestemte modus. Et eksempel på en slik +kommando er "replace-string", som globalt erstatter en tekststreng med +en annen. Når du taster M-x vil Emacs komme med en prompt nederst i +skjermbildet der du skal skrive inn kommandoen du ønsker å kjøre, i +dette tilfellet "replace-string". Det er bare å skrive "repl s", +Emacs vil da fullføre kommandonavnet. Avslutt kommandoen med +. + +Kommandoen "replace-string" krever to argumenter, tekststrengen som +skal erstattes og tekststrengen som denne skal erstattes med. Du må +avslutte begge argumentene med . + +>> Flytt markøren til den blanke linjen to linjer under denne. + Trykk M-x repl sforandretendret. + + Legg merke til hvordan denne linjen har blitt forandret, du har + erstattet ordet f-o-r-a-n-d-r-e-t med "endret" alle plassene der + ordet "forandret" forekommer, etter markørpossisjonen. + + +* AUTOMATISK LAGRING +-------------------- + +Når du har gjort forandringer i en fil, men ikke lagret den, vil det +gå tapt hvis maskinen krasjer. Som en beskyttelse mot dette vil Emacs +periodisk lagre en "autosave"-fil for hver av filene du redigerer. +Denne filen har en # i begynnelsen og slutten av filnavnet. Hvis du +for eksempel har en fil med navnet "hallo.c" så vil navnet på +"autosave"-filen bli "#hallo.c#". Når du lagrer filen på vanlig måte +vil Emacs slette unna "autosave"-filen. + +Hvis maskinen krasjer kan du gjenvinne "autosave"-filene ved å +finne filen på vanlig måte (filen du redigerte på, ikke "auto-save"- +filen) og trykke M-x recover file. Når Emacs vil ha +bekreftelse svarer du yes for å gjenvinne "autosave"-filen. + + +* ECHO-OMRÅDE +------------- + +Hvis Emacs ser at du skriver kommandoene langsomt så vil den vise dem på +den nederste linjen i skjermbildet i et område som blir kalt "echo +area". Dette området inneholder den nederste linjen i skjermbildet. + + +* MODUSLINJEN +------------- + +Linjen like over echoområdet blir kalt "moduslinje". Denne ser +omtrent slik ut: + +--**-XEmacs: TUTORIAL.no (Fundamental)--L773--68%-------- + +Denne linjen inneholder nyttig informasjon over statusen til Emacs og +teksten du redigerer på. + +Du vet allerede hva filnavnet betyr, det er den filen du har funnet. +-NN%-- forteller den aktuelle posisjonen i teksten, dvs. NN prosent av +teksten befinner seg over toppen av skjermbildet. Hvis toppen av +filen er i skjermbildet vil det stå --Top-- isteden for --00%--, og +hvis slutten av filen er i skjermbildet vil det stå --Bot--. Hvis du +ser på en fil der hele teksten passer inn på en side vil det stå +--All--. + +Stjernene i begynnelsen av linjen forteller at det er blitt foretatt +endringer i filen siden den sist ble lagret. Når du nettopp har åpnet +en fil vil det ikke stå noe her, bare minustegn. + +Den delen av moduslinjen som står inne i parenteser forteller hvilken +redigeringsmodus du bruker. Standardmodusen er "Fundamental", som er +den du bruker nå. Det er et eksempel på en "hovedmodus". + +Emacs har mange forskjellige hovedmoduser. Noen av dem er tiltenkt +redigering av forskjellige programmeringsspråk og/eller typer tekst, +for eksempel Lisp mode, Text mode, ol. Det kan bare være en +hovedmodus om gangen, og modusnavnet vil alltid stå der det står +Fundamental nå. + +Hver hovedmodus gjør at endel kommandoer oppfører seg annerledes. +Det finnes for eksempel kommandoer for å sette inn kommentarer i +programkode, og siden hvert programmeringsspråk har forskjellige måter +å angi kommentarer på må de ulike hovedmodusene sette inn disse +kommentarene på forskjellige måter. Hver hovedmodus har en kommando +som brukes for å skifte til denne modusen på. For eksempel M-x +fundamental-mode er kommandoen for å skifte til Fundamental mode. + +Hvis du skal redigere engelsk (eller norsk) tekst, slik som denne +filen, bør du bruke "Text Mode". + +>> Tast M-x text-mode. + +Ingen av kommandoene du har lært hittil vil forandre Emacs i noe +særlig grad. Men du kan legge merke til at M-f og M-b nå behandler +apostrofer som en del av ordet. Tidligere, i Fundamental mode, +behandlet M-f og M-b apostrofene som ordskillere. + +Hver hovedmodus gjør vanligvis små forandringer slik som denne, og de +fleste kommandoene gjør det samme i hver hovedmodus, de fungerer bare +litt annerledes. + +For å få fram dokumentasjonen på den hovedmodusen du er inne i nå kan +du trykke C-h m. + +>> Bruk C-u C-v slik at denne linjen kommer nær toppen av + skjermbildet. +>> Trykk C-h m, og se hvordan Text mode er forskjellig fra Fundamental + mode. +>> Trykk q for å fjerne dokumentasjonen fra skjermbildet. + +Hovedmodus blir kalt hovedmodus fordi det også finnes bimodus. +Bimodus er ikke alternativer til hovedmodus, men de modifiserer dem. +Hver bimodus kan bli slått av og på uavhenging av andre bimoduser, og +uavhengig av hovedmodus. Derfor kan du bruke ingen bimodus, en +bimodus, eller en kombinasjon av flere bimoduser. + +En bimodus som er nyttig, spesielt ved redigering av tekst, er "Auto +Fill mode". Når denne er slått på vil Emacs dele linjene automatisk +hvis linjen blir for lang for å passe inn på ett skjermbilde. + +Du kan slå på Auto Fill mode ved å utføre en M-x +auto-fill-mode. Når denne modusen er på kan du slå den av +igjen ved å utføre en ny M-x auto-fill-mode. Denne +kommandoen bytter mellom av og på, også kalt "toggle the mode". + +>> Trykk M-x auto-fill-mode nå. Skriv så inn en linje med + "aoeu " inntil linjen deler seg. Du er nødt til å putte inn + ordskillere, fordi Auto Fill bare brekker linjen ved ordskillere. + +Margen er vanligvis satt til 70 tegn, men du kan endre dette ved å +bruke kommandoen C-x f. Antall tegn blir gitt til kommandoen gjennom +et numerisk argument. + +>> Tast C-x f med et argument på 20. (C-u 20 C-x f). Skriv så inn + noe tekst og legg merke til at Emacs bryter linjer som er lengre + enn 20 tegn. Sett margen tilbake til 70 tegn igjen, ved å bruke + C-x f en gang til. + +Hvis du gjør forandringer midt i en linje så vil ikke Auto Fill mode +kunne reformatere linjene for deg. For å gjøre dette kan du taste M-q +(Meta-q) med markøren inne i det avsnittet du ønsker å reformatere. + +>> Flytt markøren inn i forrige avsnitt og trykk M-q. + + +* SØKING +-------- + +Emacs kan utføre søk etter tekststrenger (grupper med sammenhengende +bokstaver eller ord) enten framover eller bakover i teksten. Når du +søker etter tekst vil markøren flytte seg til den neste plassen der +tekststrengen opptrer. + +Søkemetoden til Emacs er litt forskjellig fra andre søkemetoder +implementert i de fleste andre redigeringsprogrammer på den måten at +den er inkrementell. Dette betyr at søket foregår mens du taster +inn tekststrengen du skal søke etter. + +Kommandoen for å innlede et søk er C-s for å søke framover, og C-r for +å søke bakover. MEN VENT! Ikke prøv dem enda. + +Når du taster C-s vil du legge merke til at teksten "I-search" dukker +opp i echoområdet. Dette forteller deg at Emacs er inne i det som +kalles inkrementellt søk, og venter på at du skal skrive inn det du +leter etter. avslutter søket. + +>> Trykk nå C-s for å starte et søk. Skriv så, en bokstav om gangen, + ordet 'markør', og legg inn en pause etter hver gang du skriver en + bokstav slik at du får med deg hva som skjer med markøren. + Nå har du søkt etter ordet "markør" en gang. +>> Tast C-s en gang til for å søke etter neste forekomst av ordet + "markør". +>> Trykk nå fire ganger og se hvordan markøren beveger seg +>> Trykk for å avslutte søket. + +La du merke til hva som skjedde? I inkrementell søk prøver Emacs å gå +til den forekomsten av teksten som du har skrevet så langt, og uthever +det slik at du ser hvor den er. For å gå til neste forekomst av ordet +'markør' er det bare å taste C-s en gang til. Hvis det ikke er flere +forekomster vil Emacs komme med et pip og en melding om at søket +midlertidig har feilet. C-g vil også avbryte søket. + +NB: På noen systemer vil C-s føre til at skjermen "fryses" og du +vil ikke være istand til å utføre noen flere kommandoer. Dette +indikerer at en operativsystem-egenskap kalt "flytkontroll" har +fanget opp C-s'en og ikke sendt den videre til Emacs. For å fortsette +må trykke C-q. Se da i avsnittet "Spontaneous Entry to Incremental +Search" i Emacs-manualen for råd om hvordan dette kan avverges. + +Hvis du er inne i et inkrementellt søk og trykker vil du legge +merke til at den siste bokstaven i søkestrengen blir slettet og søket +hopper tilbake til den forrige forekomsten fra søket. Hvis du for +eksempel taster "m" for å søke etter den første forekomsten av "m", og +så trykker "a" så vil markøren bevege seg til første forekomst av "ma". +Trykk nå . Dette fjerner "a" fra søkestrengen, og markøren +beveger seg tilbake til den første forekomsten av "m". + +Hvis du er midt i et søk og trykker en control- eller meta-kombinasjon +(med et par unntak: tegn som blir brukt under søkingen, slik som C-s +og C-r), vil søket avbrytes. + +C-s starter et søk som leter etter enhver forekomst av søkestrengen +ETTER markørposisjonen. Hvis du skal søke etter en streng tidligere +i teksten må du bruke C-r. Alt vi har fortalt om C-s fungerer også +for C-r, bortsett fra at retningen på søket er i motsatt retning. + + +* FLERE VINDUER +--------------- + +En av egenskapene til Emacs er at du kan vise flere en et buffer på +skjermen samtidig. + +>> Flytt markøren til denne linjen og trykk C-u 0 C-l + +>> Tast nå C-x 2, som vil føre til at skjermen deles i to vinduer. + Begge vinduene viser denne veiledningen. Markøren står i det + øverste vinduet. + +>> Tast C-M-v for å "scrolle" det nederste vinduet. + (Hvis du ikke har Meta-tasten trykker du ESC C-v.) + +>> Tast C-x o ("o" for "other") for å flytte markøren til det + nederste vinduet. + +>> Bruk C-v og M-v i det nederste vinduet for å flytte deg opp og ned + i teksten. Fortsett å les denne anvisningen i det øverste vinduet. + +>> Tast C-x o igjen for å flytte markøren tilbake til det øverste + vinduet. Markøren i det øverste vinduet står på samme plass som + det gjorde før du forlot det. + +Du kan fortsette å bruke C-x o for å bytte mellom de to vinduene. +Hvert av vinduene har sin egen plassering av markøren, men det er bare +ett av vinduene som viser den. Alle redigeringskommandoer fungerer på +det vinduet markøren er synlig i. Vi kaller dette vinduet det valgte +vinduet, eller "selected window". + +Kommandoen C-M-v er nyttig når du redigerer tekst i et vindu og bruker +det andre vinduet for referanser. Da kan du kan ha markøren i det +samme vinduet hele tiden og du kan bruke C-M-v for å flytte deg i det +andre vinduet. + +C-M-v er et eksempel på en CONTROL-META-kombinasjon. Hvis du har +META-tast holder du både CTRL og META nedtrykt mens du trykker v. +Det er ikke nøye hvilken av tastene CTRL og META som trykkes først, +fordi begge fungerer slik at de "modifiserer" de andre tastene du +trykker. + +Hvis du ikke har META-tasten, og bruker ESC isteden, er rekkefølgen +viktig. Du må trykke ESC etterfulgt av CTRL-v, CTRL-ESC v vil ikke +fungere. Dette er fordi ESC er et tegn for seg selv, og fungerer ikke +som "modifikator". + +>> Tast C-x 1 (i det øverste vinduet) for å bli kvitt det nederste + vinduet. + +(Hvis du hadde tastet C-x 1 i det nederste vinduet ville det øverste +forsvunnet. Tenk på denne kommandoen som "Behold bare et vindu, det +som markøren står i.") + +Du er ikke nødt til å ha samme buffer i begge vinduene. Du kan bruke +C-x C-f for å finne en ny fil i et av vinduene, det andre vinduet +forblir uforandret. Du vil merke at vinduene er helt uavhengige. + +Her er en annen måte å bruke to vinduer til å vise to forskjellige +filer: + +>> Tast C-x 4 C-f etterfulgt av et filnavn. Avslutt med . + Den nye filen vil da dukke opp i det nederste vinduet. Markøren + blir også flyttet dit. + +>> Tast C-x o for å gå tilbake til det øverste vinduet, og C-x 1 for å + bli kvitt det nederste igjen. + + +* REKURSIVE REDIGERINGSNIVÅER +----------------------------- + +Noen ganger kommer du inn i noe som blir kalt "recursive editing +level". Dette blir indikert med hakeparenteser i moduslinjen, og vil +omringe parentesene rundt hovedmodusen. For eksempel vil det da stå +[(Fundamental)] istedenfor (Fundamental). + +For å komme ut av "recursive editing mode" trykker du ESC ESC ESC. +Dette er en generell "kom seg ut" kommando. Du kan også bruke den for +å bli kvitt ekstra vinduer og for å komme deg ut av minibuffret. + +>> Tast M-x for å komme inn i minibuffren. Tast så ESC ESC ESC for å + komme ut. + +Du kan ikke bruke C-g for å komme ut av "recursive editing mode". +Dette er fordi C-g blir brukt for å avbryte kommandoer og argumenter +INNENFOR "recursive editing level". + + +* HVORDAN FINNE MERE HJELP +-------------------------- + +I denne veiledningen har vi prøvd å inkludere akkurat nok informasjon +til at du kan begynne å bruke Emacs. Det er så mange muligheter i +Emacs at det ville vært umulig å forklare her. Men du ønsker sikkert +å lære mer om Emacs siden den har mange nyttige egenskaper. Emacs +tilbyr kommandoer for å lese dokumentasjonen om Emacs-kommandoer. +Disse "hjelp"-kommandoene starter med tastekombinasjonen Control-h, +som blir kalt "the Help character". + +For å bruke denne hjelpen taster du C-h etterfulgt av et tegn som +forklarer hva du vil ha hjelp om. Hvis du virkelig har rotet deg bort +kan du taste C-h ? for at Emacs skal vise hvilken hjelp som er +tilgjengelig. Hvis du har tastet C-h og bestemmer deg for at du ikke +vil ha noen hjelp så kan du taste C-g for å avbryte. + +(På noen servere er C-h rekonfigurert. Dette skal vanligvis ikke +gjøres, og hvis det er det så klag til systemadministratoren. Imens +kan du bruke M-x help istedenfor.) + +Den mest grunnleggende hjelp-funksjonen er C-h c. Tast C-h, en "c" og +en kommandosekvens. Emacs vil da komme med en beskrivelse av denne +kommandoen. + +>> Tast C-h c Control-p. + Meldingen skal da bli noe slik som + + C-p runs the command previous-line + +Dette forteller navnet til funksjonen. Funksjonsnavn blir stort sett +brukt for å spesialtilpasse og utvide Emacs. Men siden +funksjonsnavnet er valgt for å indikere hvilken kommando den utfører +kan de også fungere som en enkel dokumentasjon, nok for å minne deg på +kommandoer du allerede har lært. + +Flertegnskommandoer, slik som C-x C-s og (hvis du ikke har META, EDIT +eller ALT tast) v, er også tillatt etter C-h c. + +For å få mere informasjon om en kommando kan du bruke C-h k isteden +for C-h c. + +>> Tast C-h k Control-p. + +Dette vil komme med en dokumentasjon på funksjonen og navnet i et eget +vindu. For å avslutte hjelpvinduet kan du trykke q. + +Her er flere nyttige C-h opsjoner: + + C-h f Beskrive en funksjon. Du skriver inn funksjonsnavnet. + +>> Prøv å tast C-h f previous-line. + Dette vil skrive ut informasjonen Emacs har om funksjonen som + implementerer C-p kommandoen. + + C-h a Apropos. Vil liste ut alle funksjoner og variabler + som søkestrengen angir. Kommandoer som kan bli utført + med Meta-x blir markert med en stjerne (*) til venstre + for funksjonsnavnet. + +>> Tast C-h a newline. + +Dette vil få fram en liste over alle funksjoner og variabler der +"newline" inngår i navnet. Du kan trykke eller klikk den +midterste musknappen for å finne ut mere om en funksjon eller +variabel. Trykk `q' for å avslutte. + + +* TIL SLUTT +----------- + +Husk at C-x C-c vil avslutte Emacs permanent. For å gå midlertidig +til et skall, slik at du senere kan komme tilbake igjen, bruker du C-z. +(Under X vil dette minimere Emacs.) + +Denne veiledningen er laget for at den skal være forståelig for nye +brukere, så hvis det er noe som er uklart holder det ikke å synes synd +på seg selv: send en mail og klag! + + +KOPIERING / DISTRIBUSJON +------------------------ + +Denne veiledningen stammer fra en hel rekke Emacs-veiledninger, og den +første ble skrevet av Stuart Cracraft for den originale Emacs. Ben +Wing oppdaterte veiledningen for X Windows. Martin Buchholz og Hrvoje +Niksic la til endringer for XEmacs, og Stig Bjørlykke oversatte den +til norsk. + + +This version of the tutorial, like GNU Emacs, is copyrighted, and +comes with permission to distribute copies on certain conditions: + +Copyright (c) 1997, Stig Bjørlykke. + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +The conditions for copying Emacs itself are more complex, but in the +same spirit. Please read the file COPYING and then do give copies of +GNU Emacs to your friends. Help stamp out software obstructionism +("ownership") by using, writing, and sharing free software! diff -r d3e9274cbc4e -r e45d5e7c476e etc/TUTORIAL.th --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.th Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,696 @@ + ============================== + GNUEMACS ,T@RIR0-Uh10;Xh19(B (Mule) ,T`0:Wi1M'05i19(B + ============================== + +,TKARB`K05X1(B: ,T`M!JRC)0:Q1:`0:Wi1M'05i1909Ui1(B 0,T6Y1!`0"U1B90"Vi19b4B0BV14K0EQ1!07Uh10Gh1R(B ",TEM'`0Eh19`EB04U1!0Gh1R`0CU1B90CYi1(B" + ,T:CC07Q1407Uh1`0CTh1A05i1904i1GB(B ">>" ,T(P0AU1$S0JQh1'0Gh1R(B 0,T5h1Md;(Pc0Ki17SMPdC(B + + ,Tb4B07Qh1Gd;(B ,T!RC0;i1M9$S0JQh1'c0Ki10!Q1:(B Mule ,T7Sd04i1b4Bc0*i1(B 0,T;Xh1A$M9b7CE(B (0,T;Xh1A07Uh1:9K09i1R0JQ1A0 ,TKARB06V1'(B ,Tc0Ki1!40;Xh1A$M9b7CE0$i1R'd0Gi1(B ,Ta0Ei1G!40;Xh1A(B <0,T5Q1G0MQ1!IC(B> 0,T5Q1GM0Bh1R'`0*h19(B C-f + ,TKARB06V1'(B ,Tc0Ki1!40;Xh1A$M9b7CE0$i1R'd0Gi1(B ,Ta0Ei1G!40;Xh1A(B f +<> + >> ,T5M909Ui1"Mc0Ki1EM'!4(B C-v (View Next Screen 0,T4Y1K09i1R05h1Md;(B) 0,T4Y1(B ,T`0>Wh1M`0EWh1M9d;0Mh1R9K09i1R(B + 0,T5h1Md;(B + 0,T5h1M(R!09Ui1`0;g1905i19d;(B 0,T7X1!$0CQi1'07Uh10Mh1R9K09i1RK09Vh1'(B ,Tf(B ,T(:"Mc0Ki17Sc97S9M'`04U1BG0!Q19(B ,T`0>Wh1M`0EWh1M9d;(B + 0,T4Y1K09i1R05h1Md;(B + +ESC <0,T5Q1G0MQ1!IC(B> ,TKARB06V1'(B ,Tc0Ki1!40;Xh1A(B ESC ,Ta0Ei1G;0Eh1MB(B ,TK0EQ1'(R!09Qi190(V1'!40;Xh1A(B <0,T5Q1G0MQ1!IC(B> ,T5RA(B + +,TKARB`K05X1(B: <0,T5Q1G0MQ1!IC(B> ,Td0Ah10Gh1R`0;g1905Q1GcK0-h1K0CW1M05Q1G`0Eg1!(B ,T(Pc0Ki1$GRAKARB`K0AW1M90!Q19`0AWh1M06Y1!c0*i1c9(B + ,T$S0JQh1'(B 0,T6i1RKR!0AU10;Xh1A(B META ,Tc0Ki1!4(B 0,T!g1(PJRARC6c0*i1!RC!4(B M-<0,T5Q1G0MQ1!IC(B> ,Ta79(B + ,T!RC(B ESC <0,T5Q1G0MQ1!IC(B> ,Td04i1(B (0,T$W1Mc0Ki1!40;Xh1A(B META 0,T$i1R'd0Gi1(B ,Ta0Ei1G0(V1'!4(B <0,T5Q1G0MQ1!IC(B>) + +0,T"i1MJS0$Q1-(B: ,T`GER(P`0ET1!c0*i1(B Emacs ,Tc0Ki1!4(B C-x C-c ,TK0CW1Mc9!C03U107Uh10JQh1'(B Emacs ,T(R!(B csh + 0,T!g1JRARC6c0*i1(B suspend (,TK0BX140*Qh1G$CRG(B) ,Td04i1(B ,T!RC(B suspend Emacs ,T7Sd04i1b4B(B + ,T!4(B C-z + + 0,T5h1M(R!09Ui1(B ,T"Mc0Ki10;i1M9$S0JQh1'(B C-v 0,T7X1!(B ,Tf(B ,T$0CQi1'07Uh10Mh1R9(:K09Vh1'K09i1R(B + + ,T@RBc9K09i1R07Uh1a0Ei1G0!Q1:K09i1R06Q14d;(B ,T(P0AU1`09Wi1MKR0+i1S0!Q19M0BYh1:R':CC07Q14(B 0,T7Uh1`0;g19`0*h1909Ui1(B 0,T!g1`0>Wh1Mc0Ki1JRARC60CYi1(B +,Td04i10Gh1R(B ,T`09Wi1MKR07Uh1aJ4'M0BYh109Qi19(B 0,T5h1M`09Wh1M'0!Q19M0BYh1(B + + + 0,T!h1M90MWh19(B ,T(S`0;g19(P05i1M'0CYi10GT108U1!RCbB!0Bi1RB5SaK09h1'd;AR(B ,T@RBc9a0?i1A0"i1M0AY1E`0JU1B0!h1M9(B ,T5RA07Uh1:M!d;(B +,Ta0Ei1G(B 0,T!g10$W1M(B C-v ,Tc0*i1JSK0CQ1:`0EWh1M9d;0"i1R'K09i1R(B 0,T6i1R(P`0EWh1M9!0EQ1:07Uh1`0!h1R(B 0,T!g1c0Ki1!4(B ESC v + + >> ,TEM'c0*i1(B ESC v ,TaEP(B C-v ,T`0>Wh1M`0EWh1M9d;AR04Y1(B 0,TJQ1!JM'JRA$0CQi1'(B + +,TJ0CX1;(B +=== + ,T$S0JQh1'(B ,TJSK0CQ1:`0EWh1M9d;AR07U1EPK09i1R@RBc9a0?i1A0"i1M0AY1E(B 0,T$W1M(B + + C-v ,T`0EWh1M9d;0"i1R'K09i1R(B ,TK09Vh1'K09i1R(M(B + ESC v ,T`0EWh1M9d;0"i1R'K0EQ1'(B ,TK09Vh1'K09i1R(M(B + C-l ,T`0"U1B9K09i1R(McK0Ah1(B ,TaEPc9"3P`04U1BG0!Q19(B 0,T!g1c0Ki1`0EWh1M95SaK09h1'"M'`$M0Cl1`+M0Cl1(B (cursor) + ,Td;M0BYh15C'!ER'(M(B + + >> ,T"Mc0Ki10JQ1'`!504Y10Gh1R(B ,Tc9"3P09Ui1`$M0Cl1`+M0Cl1M0BYh107Uh1dK9(B ,T>0Ci1MA07Qi1'(S0"i1M$GRA07Uh1M0BYh1CM:0"i1R'"M'(B + ,T`$M0Cl1`+M0Cl104i1GB(B ,Ta0Ei1GEM'!4(B C-l 0,T4Y1(B ,T5CG(JM:04Y10Gh1R(B ,T`$M0Cl1`+M0Cl1`0EWh1M9d;M0BYh107Uh1dK9(B + 0,T"i1M$GRA07Uh1M0BYh1CM:0"i1R'`;0EUh1B9d;M0Bh1R'dC(B + +0,TGT108U1bB!0Bi1RB`$M0Cl1`+M0Cl10"Qi190>Wi190R9(B +======================= + + ,T5M909Ui1(B ,T`CR0!g10CYi10GT108U1bB!0Bi1RBd;ARa::07U1EPK09i1Ra0Ei1G(B 0,T5h1Md;(B 0,T!g1AR`0CU1B90CYi10GT108U1bB!0Bi1RBd;07Uh15SaK09h1'c4(B +,T5SaK09h1'K09Vh1'@RBc9K09i1R`04U1BG0!Q19(B 0,T+Vh1'JRARC67Sd04i1KERB0GT108U1(B 0,TGT108U1K09Vh1'0!g10$W1Mc0Ki1c0*i1$S0JQh1'(B ,Td;:CC07Q140!h1M9K09i1R(B +(previous) ,Td;:CC07Q1405h1Md;(B (next) ,Td;04i1R9K09i1R(B (forward) ,Td;04i1R9K0EQ1'(B (backward) ,T$S0JQh1'(B +,T`K0Eh1R09Ui1(B 0,T6Y1!05Qi1'd0Gi107Uh1(B C-p C-n C-f ,TaEP(B C-b ,T5RAES04Q1:(B 0,T+Vh1'(P7Sc0Ki1bB!0Bi1RBd;ARd04i1(B ,Tb4B`07U1B:0!Q1:(B +,T5SaK09h1'0;Q1(0(X10:Q19(B ,TJ0CX1;`0"U1B9`0;g19a<9@R>d04i104Q1'09Ui1(B + + + ,T:CC07Q1407Uh1a0Ei1G(B C-p + : + : + 0,T5Q1G0MQ1!IC04i1R9K0EQ1'(B C-b .... ,T5SaK09h1'`$M0Cl1`+M0Cl10;Q1(0(X10:Q19(B .... 0,T5Q1G0MQ1!IC04i1R9K09i1R(B C-f + : + : + ,T:CC07Q1405h1Md;(B C-n + + + ,T$S0JQh1'`K0Eh1R09Ui1(B ,T`MRAR(R!05Q1G0MQ1!IC05Q1GaC!"M'(B ,T$S0Gh1R(B Previous Next Backward Forward +0,T+Vh1'(P0*h1GBc0Ki1(Sd04i1d0Ah1BR!(B ,T$S0JQh1'`K0Eh1R09Ui1`0;g19$S0JQh1'JSK0CQ1:!RCbB!0Bi1RB0"Qi190>Wi190R9(B 0,T+Vh1'05i1M'c0*i1M0BYh1`JAM(B + + >> ,TEM'!4(B C-n 0,T4Y1KERB(B ,Tf(B ,T$0CQi1'(B ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1AR0BQ1':CC07Q1409Ui1(B (,T:CC07Q1407Uh1!S0EQ1'0Mh1R9(B + ,TM0BYh109Ui1(B) + + >> ,TEM'!4(B C-f 0,T4Y1KERB(B ,Tf(B ,T$0CQi1'(B ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1d;0BQ1'5C'!ER'"M':CC07Q14(B ,Ta0Ei1GEM'(B + ,T!4(B C-p ,T`0EWh1M90"Vi190"i1R':904Y1(B 0,TJQ1'`!504Y104i1GB0Gh1R(B ,T5SaK09h1'"M'`$M0Cl1`+M0Cl1`;0EUh1B9d;M0Bh1R'dC(B + + >> ,TEM'!4(B C-b ,T"3P07Uh1M0BYh107Uh15SaK09h1'K09i1R0JX14"M':CC07Q1404Y1(B 0,TJQ1'`!504Y104i1GB0Gh1R(B ,T`$M0Cl1`+M0Cl1`$0EWh1M9(B + ,Td;M0Bh1R'dC(B ,T(R!09Qi19c0Ki1!4(B C-b 0,TMU1!JM'JRA$0CQi1'(B ,Ta0Ei1G!4(B C-f ,T`0>Wh1M`0EWh1M9d;0BQ1'07i1RB0JX14(B + ,T"M':CC07Q1404Y1(B ,T`$M0Cl1`+M0Cl1(P`0;g19M0Bh1R'dC(B 0,T6i1R!4(9`EB07i1RB:CC07Q14d;(B + + + ,T`GER07Uh1`0EWh1M9`$M0Cl1`+M0Cl1(B ,T(9`EB:CC07Q14aC!0JX14K0CW1M:CC07Q1407i1RB0JX14"M'K09i1Rd;(B ,T`$M0Cl1`+M0Cl1(P(B +,T`0EWh1M9d;0BQ1':CC07Q1405h1Md;c907T1H7R'09Qi19(B ,Tf(B ,TaEP;0CQ1:c0Ki1`$M0Cl1`+M0Cl1!0EQ1:ARM0BYh1:9K09i1R(M`JAM(B + + >> ,TEM'!4(B C-n ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1c0Ki1`EB:CC07Q140Eh1R'0JX14"M'K09i1R(M04Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R(B + ,T`0!T14MPdC0"Vi19(B ,TaEP5SaK09h1'"M'`$M0Cl1`+M0Cl1`;0EUh1B9d;M0Bh1R'dC(B + + 0,T6i1R0CYi10JV1!0Gh1R!RC"0BQ1:d;07U1EP05Q1G0MQ1!IC09Qi190MW14MR40BW14BR4(B 0,T!g1JRARC6c0*i1!RC`0EWh1M9`$M0Cl1`+M0Cl1d;07U1EP$S(B +,Td04i1(B ,T!4(B ESC f ,T`0>Wh1Mc0Ki1`0EWh1M9d;0"i1R'K09i1RK09Vh1'$S(B ,TaEP(B ESC b ,T`0>Wh1Mc0Ki1`0EWh1M9d;0"i1R'K0EQ1'K09Vh1'$S(B + +,TKARB`K05X1(B: ,TJSK0CQ1:@RIRd7B(B 0,TBQ1'd0Ah1JRARC6a0:h1'aB!5SaK09h1'"M'$Sd04i106Y1!05i1M'(B 0,T(V1'd0Ah1(B + ,TJRARC6c0*i1JM'$S0JQh1'09Ui1d04i1(B + + >> ,TEM'!4(B ESC f ,TaEP(B ESC b ,TEM'04Y1KERB(B ,Tf(B ,T$0CQi1'(B ,TaEPEM'c0*i10Ch1GA0!Q1:(B C-f 0,T!Q1:(B C-b 0,T4Y1(B + 0,T4i1GB(B + + ,T(P0JQ1'`!5`0Kg19d04i10Gh1R(B ESC f ,TaEP(B ESC b 0,TAU10CY1;a::$0Ei1RB$0EV1'0!Q1:(B C-f ,TaEP(B C-b ,Tb4B0Jh1G9cK0-h1(B +ESC <0,T5Q1G0MQ1!IC(B> ,T(Pc0*i1`0!Uh1BG0!Q1:!RC0(Q14!RC0"i1M$GRA(B 0,TJh1G9(B C-<0,T5Q1G0MQ1!IC(B> ,T(Pc0*i10!Q1:0JTh1'07Uh1`0;g190>Wi190R9AR!(B +,T!0Gh1R(B (,T`0*h19(B 0,T5Q1G0MQ1!IC(B ,TK0CW1M(B ,T:CC07Q14(B) + + C-a 0,T!Q1:(B C-e ,T`0;g19$S0JQh1'09h1R(P0CYi1d0Gi1(B ,T`>CRP0$h1M90"i1R'JP4G!04U107U1`04U1BG(B C-a ,Tc0*i1JSK0CQ1:`0EWh1M9(B +,T`$M0Cl1`+M0Cl1d;07Uh15SaK09h1'K09i1R0JX14"M':CC07Q14(B C-e ,TJSK0CQ1:`0EWh1M9d;07Uh15SaK09h1'07i1RB0JX14"M':CC07Q14(B + + + >> ,TEM'!4(B C-a 0,T4Y1JM'$0CQi1'(B ,TK0EQ1'(R!09Qi19c0Ki1!4(B C-e 0,T4Y1JM'$0CQi1'(B ,Ta0Ei1GEM'0JQ1'`!504Y10Gh1R(B ,T!RC(B + ,T!4$S0JQh1'09Ui1AR!!0Gh1RJM'$0CQi1'(B ,T(Pd0Ah10*h1GBc0Ki1`0EWh1M9`$M0Cl1`+M0Cl1d;dK9d04i1AR!!0Gh1R09Qi190MU1!(B + + 0,TBQ1'0AU10MU1!JM'$S0JQh1'(B ,TJSK0CQ1:!RC`0EWh1M9`$M0Cl1`+M0Cl1a::0'h1RB(B ,Tf(B 0,T$W1M(B ,T$S0JQh1'(B ESC < ,TJSK0CQ1:!RC`0EWh1M9(B +,T`$M0Cl1`+M0Cl1d;07Uh15SaK09h1'aC!0JX14"M'a0?i1A0"i1M0AY1E(B ,TaEP$S0JQh1'(B ESC > ,TJSK0CQ1:!RC`0EWh1M9d;5SaK09h1'07i1RB0JX14(B + + ,T`CR`0CU1B!5SaK09h1'"M'0"i1M$GRA(B 0,T7Uh10AU1`$M0Cl1`+M0Cl1M0BYh10Gh1R(B "0,T(X14(B (point)" ,TK0CW1M0>Y140MU1!M0Bh1R'K09Vh1'd04i1(B +0,TGh1R(B ,T`$M0Cl1`+M0Cl1(B ,T`0;g190JTh1'07Uh1:M!c0Ki1`CR0CYi10Gh1R(B 0,T(X14(B ,TM0BYh15C'dK9"M'K09i1R(M(B + + ,TJ0CX1;$S0JQh1'JSK0CQ1:!RC`$0EWh1M9d;AR(B 0,T+Vh1'CGA!RC`$0EWh1M907Uh1c9K09h1GB"M'$S(B ,TK09h1GB"M':CC07Q14d0Gi104i1GB(B +,Td04i104Q1'09Ui1(B + + C-f ,Td;0"i1R'K09i1RK09Vh1'05Q1G0MQ1!IC(B + C-b ,T!0EQ1:0"i1R'K0EQ1'K09Vh1'05Q1G0MQ1!IC(B + + ESC f ,Td;0"i1R'K09i1RK09Vh1'$S(B + ESC b ,T!0EQ1:0"i1R'K0EQ1'K09Vh1'$S(B + + C-n ,T`0EWh1M9d;:CC07Q1405h1Md;(B + C-p ,T`0EWh1M9d;:CC07Q1407Uh1a0Ei1G(B + + ESC ] ,T`0EWh1M9d;5SaK09h1'07i1RB0JX14"M'0Bh1MK09i1R(B (paragraph) + ESC [ ,T`0EWh1M9d;5SaK09h1'aC!0JX14"M'0Bh1MK09i1R(B + + C-a ,T`0EWh1M9d;5SaK09h1'aC!0JX14"M':CC07Q14(B + C-e ,T`0EWh1M9d;5SaK09h1'07i1RB0JX14"M':CC07Q14(B + + ESC < ,T`0EWh1M9d;5SaK09h1'aC!0JX14"M'a0?i1A0"i1M0AY1E(B + ESC > ,T`0EWh1M9d;5SaK09h1'07i1RB0JX14"M'a0?i1A0"i1M0AY1E(B + + >> ,TEM'c0*i1$S0JQh1'a05h1EP$S0JQh1'04Y1(B ,T$S0JQh1'`K0Eh1R09Ui1`0;g19$S0JQh1'07Uh1c0*i10!Q190:h1MB0JX14(B ,T$S0JQh1'JM'$S0JQh1'K0EQ1'(B + ,T(P`0EWh1M9`$M0Cl1`+M0Cl1(B ,Td;0BQ1'07Uh107Uh10$h1M90"i1R'd!E(B ,Tc0Ki1EM'c0*i1$S0JQh1'(B C-v ,TaEP(B ESC v ,T`0>Wh1M(B + ,T`0EWh1M9`$M0Cl1`+M0Cl1!0EQ1:AR07Uh15C'09Ui1(B + + ,TJSK0CQ1:$S0JQh1'0MWh19(B ,Tf(B ,T"M'(B Emacs 0,T!g1`0*h190!Q19(B ,T$S0JQh1'`K0Eh1R09Ui1(PJRARC6`0>Th1A05Q1G`0EW1M!(B (argument) +,T`0>Wh1M!SK94(B ,T(S9G9$0CQi1'(B ,Tc9!RC;0/T10:Q105T1'R9d04i1(B ,T!RC!SK94(S9G9$0CQi1'(B ,T7Sd04i1b4B!4(B C-u ,Ta0Ei1G5RA(B +0,T4i1GB(S9G9$0CQi1'07Uh105i1M'!RC0!h1M9(B ,Ta0Ei1G0(V1'0$h1MB!4$S0JQh1'5RA(B + + 0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'(B C-u 8 C-f ,TKARB06V1'(B ,Tc0Ki1`0EWh1M9d;0"i1R'K09i1R(B 8 0,T5Q1G0MQ1!IC(B + + >> ,Tc0Ki1EM'!SK94(S9G9$0CQi1'07Uh1`KARPJAJSK0CQ1:$S0JQh1'(B C-n ,TK0CW1M(B C-p ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1(B + ,Tc0Ki1ARM0BYh1c!0Ei1:CC07Q1409Ui1c0Ki1AR!07Uh10JX14`07h1R07Uh1(P7Sd04i1(B ,Tc9!RC`0EWh1M9`$M0Cl1`+M0Cl1$0CQi1'`04U1BG(B + + ,TJSK0CQ1:(B C-v ,TaEP(B ESC v ,T(Pd04i1> ,TEM'!4(B C-u 3 C-v 0,T4Y1(B + + ,T`0EWh1M9!0EQ1:07Uh1`0!h1Rd04i1b4B(B C-u 3 ESC v + +,T$S0JQh1'B!`0ET1!(B +========= + + ,T$S0JQh1'(B C-g ,Tc0*i1JSK0CQ1:0JQh1'B!`0ET1!$S0JQh1'05h1R'(B ,Tf(B 0,T7Uh105i1M'!RC!RC0;i1M90"i1M0AY1E`0>Th1A`05T1A(B 0,T5Q1GM0Bh1R'`0*h19(B +,TCPK0Gh1R'07Uh1c0Jh105Q1G`0EW1M!(B (argument) ,TM0BYh1(B ,TK0CW1MCPK0Gh1R'$S0JQh1'07Uh105i1M'!RC!40;Xh1AAR!!0Gh1R(B 2 0,T;Xh1A0"Vi19d;(B 0,T6i1R(B +,TKR!05i1M'!RCB!`0ET1!(B 0,T!g1c0Ki1!4(B C-g + + >> ,TEM'!SK94(S9G9$0CQi1'c0Ki1`0;g19(B 100 ,Tb4B!RC!4(B C-u 100 ,Ta0Ei1G!4(B C-g 0,T4Y1(B ,TK0EQ1'(R!09Qi19(B + ,Tc0Ki1EM'!4(B C-f 0,T4Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R`$M0Cl1`+M0Cl1`0EWh1M9d;0!Uh105Q1G0MQ1!IC(B ,TK0CW1M5M907Uh1>ER4d;!4(B + ESC ,Tb4Bd0Ah105Qi1'c((B 0,T!g1JRARC6!4(B C-g ,TB!`0ET1!d04i1(B + +0,T"i1M0ER4(B (Error) +================ + + ,Tc9:R'$0CQi1'(B ,TMR((P0AU1!RC0JQh1';0/T10:Q105T1'R9:R'M0Bh1R'(B 0,T7Uh1(B Emacs ,TBMA0CQ1:d0Ah1d04i1`0!T140"Vi19(B 0,T5Q1GM0Bh1R'`0*h19(B +,T!RC!4$S0JQh1'$M9b7CE:R'$S0JQh1'(B 0,T7Uh1d0Ah1d04i1!SK94d0Gi1c9(B Emacs 0,T!g1(P7Sc0Ki1(B Emacs 0,TJh1'`0JU1B'`05W1M9(B +,TaEPaJ4'ER4M0Bh1R'dC(B + + ,T$S0JQh1':R'$S0JQh1'07Uh1`0"U1B9d0Gi1c9`M!JRC)0:Q1:09Ui1(B ,TMR(c0*i1d0Ah1d04i10!Q1:(B Emacs ,T:R'0CXh19(B (version) 0,T+Vh1'(P(B +,T7Sc0Ki10AU1!RCaJ4'ER4(B (error) 0,T"Vi19(B ,Tc9!C03U109Ui1(B ,T"Mc0Ki1!40;Xh1AMPdC0!g1d04i1(B ,T`0>Wh1M`0EWh1M9d;0BQ1'0Jh1G9(B +0,T5h1Md;(B + +0,TGT19b40Gl1(B (Window) +============== + + Emacs ,TJRARC6`0;T140GT19b40Gl1d04i1>0Ci1MA0!Q19KERB0GT19b40Gl1(B ,TaEPc0*i10GT19b40Gl1`K0Eh1R09Qi19aJ4'08l1"M'$S0JQh1':R'$S0JQh1'(B ,TK0CW1M(B Help ,TMM!`0JU1B0!h1M9(B + + C-x 1 ,T7Sc0Ki1`0;g190GT19b40Gl1`04U1BG(B + + ,T$S0JQh1'(B C-x 1 ,Tc0*i1JSK0CQ1:E:0GT19b40Gl10MWh19(B ,Ta0Ei1G"BRB0GT19b40Gl107Uh10AU1`$M0Cl1`+M0Cl1M0BYh1(B ,Tc0Ki1`05g1A(M`0;g19(B +0,TGT19b40Gl1`04U1BG(B + + >> ,Tc0Ki1`0EWh1M9`$M0Cl1`+M0Cl1AR07Uh1:CC07Q1409Ui1(B ,Ta0Ei1G!4(B C-u 0 C-l + + >> ,TEM'!4(B C-h k C-f 0,T4Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R0GT19b40Gl109Ui1`;0EUh1B9d;M0Bh1R'dC(B ,T`0AWh1M0AU10GT19b40Gl1cK0Ah10+Vh1'(B + ,TM08T1:RB0GT108U1c0*i1$S0JQh1'(B C-f ,T;CR!/0"Vi19(B + + >> ,TEM'!4(B C-x 1 ,T`0>Wh1ME:0GT19b40Gl107Uh1b<0Eh10"Vi19ARcK0Ah1(B ,TMM!(B + +,T!RCa7C!(B (insert) ,TaEP(B ,T!RCE:(B (delete) +=================================== + + ,T:9(B Emacs ,T`CR(PJRARC60>T1A0>l105Q1G0MQ1!IC`0"i1Rd;d04i1`EB(B ,T`0AWh1M05i1M'!RC0>T1A0>l10"i1M$GRA(B Emacs ,T(P(B +0,T6W1M0Gh1R05Q1GK09Q1'0JW1M07Uh1AM'`0Kg19d04i107X1!05Q1G(B (,T`0*h19(B 'A' '7' '*' ',T!(B' ,TaEP0MWh19(B ,Tf(B) ,T`0;g190"i1M$GRA07Uh105i1M'!RC(P(B +,Ta7C!(B (insert) ,T`0"i1Rd;5C'(B ,Tf(B ,T`0AWh1M(P(::CC07Q14(B ,Tc0Ki1!4(B ,T`0>Wh1M`05T1A0MQ1!IC0"Vi19:CC07Q14cK0Ah1(B +(linefeed character) ,Ta7C!`0"i1Rd;(B + + ,Tc0Ki1!4(B ,T`0AWh1M05i1M'!RC(PE:05Q1G0MQ1!IC07Uh1`0>Th1'0>T1A0>l1`0"i1Rd;(B ,TKARB06V1'0;Xh1A`0"U1B9(B +,T:90 +,Tc0*i1JSK0CQ1:E:05Q1G0MQ1!IC07Uh1M0BYh10!h1M9K09i1R5SaK09h1'`$M0Cl1`+M0Cl10;Q1(0(X10:Q19(B + + >> ,TEM'0>T1A0>l105Q1G0MQ1!IC`0"i1Rd;KERB(B ,Tf(B 0,T5Q1G(B ,Ta0Ei1Gc0*i1(B ,TE:05Q1G0MQ1!IC`K0Eh1R09Qi1907Ti1'(B + + >> ,TEM'0>T1A0>l10"i1M$GRAE'd;c0Ki1`0!T19"M:"GR(B (right margin) ,T`GER07Uh10>T1A0>l10"i1M$GRA`0"i1Rd;(B + ,TBRG`0!T19$GRA!0Gi1R'"M'K09Vh1':CC07Q14(B ,T:CC07Q1409Qi190!g1(P(B "0,T6Y1!05h1M(B" ,Tc0Ki1BRG`0!T19K09Vh1'K09i1R(M(B + ,Tb4Bc0Jh1`$0CWh1M'KARB(B '\' ,Td0Gi107Uh1"M:"GR0JX14(B ,T`0>Wh1M:M!c0Ki10CYi10Gh1R:CC07Q1409Ui10BQ1'0AU105h1M(B Emacs ,T(P(B + ,T`0EWh1M9(B (scroll) ,TK09i1R(M`0>Wh1Mc0Ki1`0Kg195SaK09h1'07Uh1!S0EQ1'a0!i1d"M0BYh1d04i1M0Bh1R'0*Q14`(9(B 0,T6i1RKR!(B + ,T"M:"GRK0CW1M"M:0+i1RB"M'0AU1`$0CWh1M'KARB(B '\' ,TM0BYh1(B 0,T!g1`0;g19!RC:M!c0Ki10CYi10Gh1R(B ,T:CC07Q1409Qi190BQ1'0AU105h1M(B + ,Td;c907T1H7R'09Qi19(B ,Tf(B + + ,TEM';0/T10:Q105T104Y1`EB(B ,T$'(P0*h1GBc0Ki1`0"i1Rc(0'h1RB!0Gh1R!RCM08T1:RB04i1GB05Q1GK09Q1'0JW1M(B + + >> ,Tc0Ki1"0BQ1:`$M0Cl1`+M0Cl1d;d0Gi1:9:CC07Q140+Vh1'06Y1!05h1Mc0Ki1BRG`0!T19K09Vh1'K09i1R(M(B 0,T7Uh1`0>Th1'0;i1M9`0"i1Rd;`0AWh1M(B + 0,TJQ1!$0CYh109Ui1(B ,Ta0Ei1Gc0*i1(B C-d ,TE:0"i1M$GRAMM!:R'0Jh1G9(B ,T(9$GRABRG"M'0"i1M$GRAM0BYh1@RBc9K09Vh1'(B + ,T:CC07Q14(B 0,TJQ1'`!504Y10Gh1R`$0CWh1M'KARB(B '\' ,T(PKRBd;(B + + >> ,Tc0Ki1`0EWh1M9`$M0Cl1`+M0Cl1d;d0Gi107Uh15SaK09h1'aC!0JX14"M':CC07Q14(B ,Ta0Ei1G!4(B 0,T4Y1(B ,T!RC7S(B + ,Ta::09Ui1(B ,T(P7Sc0Ki10JQ1-0EQ1!I03l10$Qh19CPK0Gh1R':CC07Q1406Y1!E:MM!d;(B ,T:CC07Q1409Qi190!g1(P06Y1!`MRd;05h1M0!Q1:(B + ,T:CC07Q140!h1M9K09i1R09Qi19(B ,TCGA0!Q19`0;g19:CC07Q14BRG:CC07Q14`04U1BG(B ,TaEPMR((P0AU10JQ1-0EQ1!I03l105h1M:CC07Q14(B + ,T;CR!/0"Vi19(B + + >> ,Tc0Ki1!4(B ,T`0>Wh1M`0>Th1A(B 0,T5Q1G0MQ1!IC0"Vi19:CC07Q14cK0Ah1(B ,T!0EQ1:d;M0Bh1R'`04T1A(B + + ,T$S0JQh1'0Jh1G9cK0-h1"M'(B Emacs ,T(PJRARC6!SK94(S9G9$0CQi1'07Uh105i1M'!RCc0Ki1;0/T10:Q105T1d04i1(B ,TCGA07Qi1'!RC(B +,Ta7C!(B (insert) 0,T5Q1G0MQ1!IC04i1GB(B + + + >> ,TEM'0;i1M9$S0JQh1'(B C-u 8 * 0,T4Y1(B 0,TJQ1'`!504Y10Gh1R`0!T14MPdC0"Vi19(B + + 0,T6i1R05i1M'!RC(P`0>Th1A:CC07Q140Gh1R'(B ,Tf(B (blank line) ,TCPK0Gh1R'JM':CC07Q14(B ,Tc0Ki1`0EWh1M9d;07Uh15SaK09h1'(B +,TaC!0JX14"M':CC07Q1407Uh1JM'(B ,Ta0Ei1G!4(B C-o + + >> ,Tc0Ki1`0EWh1M9d;07Uh15SaK09h1'aC!0JX14"M':CC07Q14c40!g1d04i1(B ,Ta0Ei1GEM'!4(B C-o 0,T4Y1(B + + 0,T6V1'5C'09Ui1(B ,T`CR0!g1d04i1`0CU1B90GT108U10>Wi190R9JSK0CQ1:!RC0;i1M90"i1M$GRA(B ,TaEP!RCa0!i107Uh10 ,TE:05Q1G0MQ1!IC07Uh1M0BYh1K09i1R`$M0Cl1`+M0Cl1(B + C-d ,TE:05Q1G0MQ1!IC07Uh1M0BYh107Uh1`$M0Cl1`+M0Cl1(B + + ESC ,TE:$S07Uh1M0BYh1K09i1R`$M0Cl1`+M0Cl1(B + ESC d ,TE:$S05Qi1'a05h15SaK09h1'07Uh1`$M0Cl1`+M0Cl1M0BYh1(B + + C-k ,TE::CC07Q1405Qi1'a05h15SaK09h1'07Uh1`$M0Cl1`+M0Cl1M0BYh1(B + + ,Tc9:R'$0CQi1'(B ,T`CRMR(05i1M'!RC(P`MR0Jh1G907Uh1E:d;!0EQ1:0$W19AR(B ,Tb;Ca!CA(B Emacs ,T(P(S0Jh1G907Uh1E:(B +,TMM!d0Gi1(B ,T`GER07Uh1E:0"i1M$GRAc9K09h1GB07Uh1AR!!0Gh1RK09Vh1'05Q1G0MQ1!IC(B ,Tc0Ki1c0*i1$S0JQh1'(B C-y ,T`GER07Uh105i1M'!RC(P`MR(B +0,T"i1M$GRA!0EQ1:0$W19(B 0,TJTh1'07Uh1$GCCP0GQ1'0!g10$W1M(B C-y ,Td0Ah1c0*h1c0*i1d04i1`0>U1B'a0$h15SaK09h1'07Uh1E:0"i1M$GRAMM!`07h1R09Qi19(B ,Ta05h1(P(B +,Tc0*i10!Q1:5SaK09h1'c40!g1d04i1(B C-y ,T`0;g19$S0JQh1'JSK0CQ1:a7C!0"i1M$GRA07Uh1`0!g1:d0Gi1(B ,TE'c95SaK09h1'07Uh10AU1`$M0Cl1`+M0Cl1M0BYh1(B +,T`CRJRARC6c0*i1$GRAJRARC609Ui1c9!RC`$0EWh1M90Bi1RB0"i1M$GRAd04i1(B + + ,T$S0JQh1'JSK0CQ1:!RCE:0AU1M0BYh1JM'a::0$W1M(B ,T$S0JQh1'(B "Delete" 0,T!Q1:(B ,T$S0JQh1'(B "Kill" ,T$S0JQh1'(B "Kill" +,T(P`0!g1:0Jh1G9E:MM!d0Gi1(B ,Ta05h1$S0JQh1'(B "Delete" ,T(Pd0Ah1`0!g1:(B ,Ta05h106i1RKR!c0*i1$S0JQh1'09Ui1KERB(B ,Tf(B ,T$0CQi1'(B 0,T!g1(P`0!g1:(B +0,TJh1G907Uh1E:MM!d0Gi1c0Ki1(B + + >> ,Tc0Ki1!4(B C-n 0,TJQ1!JM'JRA$0CQi1'(B ,T`0>Wh1M`0EWh1M9d;0BQ1'07Uh107Uh1`KARPJA:9K09i1R(M(B ,Ta0Ei1GEM'!4(B C-k ,T`0>Wh1M(B + ,TE::CC07Q1409Qi19MM!04Y1(B + + ,T`0AWh1M!4(B C-k ,T$0CQi1'aC!(B 0,T"i1M$GRAc9:CC07Q1409Qi19(P06Y1!E:MM!(B ,TaEP`0AWh1M!40MU1!(B C-k 0,TMU1!$0CQi1'(B ,T:CC07Q14(B +0,T9Qi19`M'07Qi1':CC07Q140!g1(P06Y1!E:MM!d;04i1GB(B ,Ta05h106i1R!SK94(S9G9$0CQi1'c0Ki10!Q1:$S0JQh1'(B C-k 0,T!g1(PKARB06V1'(B ,Tc0Ki1E:(B +,T:CC07Q14MM!(B (0,T7Qi1'`09Wi1MKRaEP05Q1G:CC07Q14(B) ,T`0;g19(S9G9:CC07Q14(B ,T`07h1R0!Q1:(S9G9$0CQi1'07Uh1!SK94(B + + ,T:CC07Q1407Uh1`0>Th1'E:MM!d;(B ,T(P06Y1!`0!g1:d0Gi1(B ,TaEPJRARC69S!0EQ1:0$W19ARd04i1(B ,Tb4Bc0*i1$S0JQh1'(B C-y + + >> ,TEM'!4(B C-y 0,T4Y1(B + + 0,T"i1M$GRA07Uh106Y1!E:MM!(B ,Tb4B!RC!4(B C-k ,TKERB(B ,Tf(B ,T$0CQi1'(B ,T(P06Y1!`0!g1:CG:CGAd0Gi1(B ,TaEPJRARC69S(B +,T!0EQ1:AR07Qi1'KA4d04i1c9$0CQi1'`04U1BG(B ,Tb4B!RC!4(B C-y + + >> ,TEM'!4(B C-k 0,T4Y1KERB(B ,Tf(B ,T$0CQi1'(B + + >> ,T$S0JQh1'JSK0CQ1:`0CU1B!0"i1M$GRA!0EQ1:AR(B 0,T$W1M(B C-y 0,T!h1M90MWh19c0Ki1`0EWh1M9`$M0Cl1`+M0Cl1E'd;0"i1R'0Eh1R'(B + 0,TJQ1!JM'JRA:CC07Q14(B ,Ta0Ei1GEM'!4(B C-y 0,T4Y1(B 0,T!g1(PJRARC60$Q14EM!(B (copy) 0,T"i1M$GRAd04i1(B + + 0,T6i1R5M909Ui1`0!g1:0"i1M$GRAMPdC:R'M0Bh1R'd0Gi1(B ,Ta0Ei1GE:0"i1M$GRA0MWh19`0>Th1A`0"i1Rd;0MU1!(B ,T(P`0!T14MPdC0"Vi19(B +,T08l10$W1M(B C-y ,T(P`0CU1B!0$W19d04i1a0$h1`0>U1B'0"i1M$GRA07Uh1E:MM!$0CQi1'0Eh1R0JX14`07h1R09Qi19(B + + + >> ,TEM'E::CC07Q1404Y1K09Vh1':CC07Q14(B ,Ta0Ei1G`0EWh1M9`$M0Cl1`+M0Cl1d;07Uh10MWh19(B ,Ta0Ei1GE::CC07Q14MM!04Y10MU1!K09Vh1'(B + ,T:CC07Q14(B ,TEM'!4(B C-y 0,T4Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R(Pd04i1a0$h1`0>U1B':CC07Q1407Uh1JM'0$W19`07h1R09Qi19(B + +,T!RC0MQ1904Y1(B (UNDO) +============= + + ,T`GER07Uh1a0!i1d"0"i1M$GRA:R'M0Bh1R'(B ,Ta0Ei1G05i1M'!RC(P`;0EUh1B9!0EQ1:c0Ki1`0;g19M0Bh1R'`04T1A(B 0,T!g1JRARC67Sd04i107X1!(B +,T`0AWh1M04i1GB$S0JQh1'(B C-x u ,Tb4B;!05T1(B ,T(Pc0*i1JSK0CQ1:B!`0ET1!$S0JQh1'(B 0,T7Uh10;i1M9`0"i1Rd;b4Bd0Ah105Qi1'c((B ,TJRARC6c0*i1(B +,T$S0JQh1'09Ui10!Uh1$0CQi1'0!g1d04i15RA05i1M'!RC(B + + >> ,TEM'E::CC07Q1409Ui1MM!04Y1(B 0,T4i1GB$S0JQh1'(B C-k ,Ta0Ei1G`0CU1B!!0EQ1:0$W19AR04i1GB(B C-x u + + ,T$S0JQh1'(B C-_ 0,T!g1`0;g19$S0JQh1'0MQ1904Y10MU1!0MQ19K09Vh1'(B ,T$GRAJRARC6`K0AW1M90!Q1:$S0JQh1'(B C-x u + + ,TJRARC6!SK94(S9G9$0CQi1'c0Ki1$S0JQh1'(B C-_ ,TaEP(B C-x u ,Td04i1(B + + +,Ta0?i1A0"i1M0AY1E(B (File) +============== + + ,T`CR(S`0;g1905i1M'`0!g1:0CQ1!IR(B (save) 0,T"i1M$GRA07Uh1a0!i1d"d0Gi1c9a0?i1A0"i1M0AY1E(B 0,T6i1R05i1M'!RC(Pc0Ki10JTh1'07Uh1(B +,Ta0!i1d"`;0EUh1B9d;M0Bh1R'6RGC(B ,Td0Ah1`0*h1909Qi19(B 0,TJTh1'07Uh1a0!i1d"d;0!g1(PKRBd;(B 0,T7Q1907U107Uh1`0ET1!!RCc0*i1(B Emacs + + ,Ta0?i1A0"i1M0AY1E07Uh1AM'`0Kg19M0BYh1(B 0,T$W1M0JTh1'07Uh10:Q1907V1!0JTh1'07Uh1!S0EQ1'a0!i1d"M0BYh1(B ,TK0CW1M0>Y140'h1RB(B ,Tf(B 0,T!g10$W1Ma0?i1A0"i1M0AY1E07Uh1AM'`0Kg19(B +,TM0BYh10$W1M05Q1Ga0?i1A0"i1M0AY1E07Uh1!S0EQ1'a0!i1d"M0BYh1(B + + ,Ta05h1(9!0Gh1Ra0?i1A0"i1M0AY1E(P06Y1!`0!g1:0CQ1!IR(B (save) ,TE'd;(B ,Ta0?i1A0"i1M0AY1E07Uh106Y1!a0!i1d"M0BYh1(B ,T(Pd0Ah106Y1!`0"U1B907Q1:(B +,TE'd;M0Bh1R'`04g14"R4(B 0,TMQ1909Ui1`0>Wh1M`0;g19!RC0;i1M'0!Q19!RC`0"U1B907Q1:a0?i1A0"i1M0AY1E07Uh1a0!i1d"d;a::$0CVh1'(B ,Tf(B ,T!ER'(B ,Tf(B +,Tb4Bd0Ah1d04i105Qi1'c((B + + ,T9M!(R!09Ui1(B ,T`0>Wh1M`0;g19!RC0;i1M'0!Q19!RC`0!g1:0CQ1!IR(B (save) 0,TJTh1'07Uh1a0!i1d"0Th1A`05T1A`0!Uh1BG0!Q1::CC07Q14bKA4(B (mode line) ,Tc95M9K0EQ1'(B + + ,T$S0JQh1'c0Ki1KRa0?i1A0"i1M0AY1E(B ,TaEP$S0JQh1'c0Ki1`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B 0,TAU10EQ1!I3Pa5!05h1R'(R!$S0JQh1'07Uh10 + + >> ,TEM'!4(B C-x C-f ,Ta0Ei1G5RA04i1GB(B C-g 0,T4Y1(B ,T`0;g19!RC0JQh1'B!`0ET1!`09Wi1MKRc90AT109T10:Q1?`?M0Cl1(B ,TK0CW1M(B + ,TB!`0ET1!$S0JQh1'(B C-x C-f 0,T4Q1'09Qi19(B Emacs ,T(Pd0Ah10$i19KRa0?i1A0"i1M0AY1Ec4(B ,Tf(B + + ,T$CRG09Ui1(B ,TAREM'`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E04Y1(B ,T`GER07Uh105i1M'!RC`0!g1:0CQ1!IR0JTh1'07Uh1a0!i1d"AR(906V1'5M909Ui1(B 0,T!g1c0Ki1c0*i1(B +,T$S0JQh1'04Q1'09Ui1(B + + C-x C-s ,T`0!g1:0CQ1!IR(B (save) ,Ta0?i1A0"i1M0AY1E(B + + ,Ta0Ei1G`09Wi1MKR07Uh1M0BYh1c9(B Emacs 0,T!g1(P06Y1!`0"U1B9E'd;07Uh1a0?i1A0"i1M0AY1E(B ,T`GER`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B ,Ta0?i1A0"i1M0AY1E(B +0,T5i19)0:Q1:(Pd0Ah10JY1-KRBd;(B ,Ta05h1(P06Y1!`0!g1:d0Gi1c90*Wh1McK0Ah1(B 0,T+Vh1'd04i1AR(R!0*Wh1M`0!h1R07Uh105h1M07i1RB04i1GB(B '~' + + ,TK0EQ1'(R!07Uh1`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E`J0Cg1(a0Ei1G(B Emacs 0,T!g1(PaJ4'0*Wh1Ma0?i1A0"i1M0AY1E07Uh1`0!g1:c0Ki104Y1(B + + >> ,TEM'!4(B C-x C-x ,T`0>Wh1M`0!g1:0CQ1!IRJS`9R"M'(B Tutorial 0,T9Ui104Y1(B 0,T!g1(P`0Kg190Gh1R(B 0,T7Uh10Jh1G90Eh1R'(B + ,T"M'(M(B 0,TAU10"i1M$GRA0Gh1R(B "Wrote ...../TUTORIAL.th" ,T;CR!/0"Vi19(B + + ,T`GER07Uh1(PJ0Ci1R'a0?i1A0"i1M0AY1EcK0Ah1(B 0,T!g1c0Ki17SCRG0!Q1:0Gh1R(P0$i19KR(B (find-file) ,Ta0?i1A0"i1M0AY1E`0!h1R0+Vh1'0AU1(B +,TM0BYh10!h1M9K09i1R09Ui1a0Ei1G(B ,Ta0Ei1G0>T1A0>l10"i1M$GRAE'd;c9a0?i1A0"i1M0AY1E07Uh1KR`(M(B + + ,TaEP`GER07Uh10JQh1'`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E`07h1R09Qi19(B 0,T$W1M5M907Uh1(B Emacs ,T(P`0!g1:`09Wi1MKR07Uh1a0!i1d"AR07Qi1'KA4(B ,TE'(B +,Tc9a0?i1A0"i1M0AY1E`0;g19$0CQi1'aC!(B + + +0,T:Q1?`?M0Cl1(B (Buffer) +=============== + + 0,T6i1RKR!0JQh1'c0Ki1KRa0?i1A0"i1M0AY1E0MQ1907Uh1JM'(B 0,T4i1GB$S0JQh1'(B C-x C-f ,T`09Wi1MKR"M'a0?i1A0"i1M0AY1EaC!(B 0,T!g1(P0BQ1'$'(B +0,T6Y1!`0!g1:0CQ1!IRM0BYh1c9(B Emacs 0,TJTh1'07Uh1`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E07Uh10Mh1R9`0"i1RAR(B 0,T+Vh1'M0BYh1@RBc9(B Emacs ,T`0CU1B!0Gh1R(B +0,T:Q1?`?M0Cl1(B (Buffer) ,T`GER07Uh10Mh1R9a0?i1A0"i1M0AY1EcK0Ah1`0"i1RAR(B Emacs 0,T!g1(PJ0Ci1R'0:Q1?`?M0Cl1cK0Ah1(B 0,T"Vi19AR@RBc9(B + + 0,T6i1R05i1M'!RC(P04Y1CRB!RC"M'0:Q1?`?M0Cl1(B 0,T7Uh106Y1!`0!g1:0CQ1!IRM0BYh1@RBc9(B Emacs 0,T!g1c0Ki1!4$S0JQh1'(B + + C-x C-b + + >> ,TEM'!4(B C-x C-b 0,T4Y1(B 0,TJQ1'`!504Y10Gh1Ra05h1EP0:Q1?`?M0Cl10AU10*Wh1M0Gh1RMPdC(B ,TaEP06Y1!05Qi1'0*Wh1Md0Gi10Gh1R(B + ,TM0Bh1R'dC(B ,Tc9(B Emacs + + 0,TAU1:R'0:Q1?`?M0Cl1(B 0,T7Uh1d0Ah10AU10$Yh10!Q1:a0?i1A0"i1M0AY1E(0CT1'(B ,Tf(B 0,T5Q1GM0Bh1R'`0*h19(B ,Td0Ah10AU1a0?i1A0"i1M0AY1E07Uh10AU10*Wh1M0Gh1R(B "*Buffer +List*" ,TM0BYh1(0CT1'(B ,Tf(B ,Ta05h1`0;g190:Q1?`?M0Cl107Uh1J0Ci1R'0"Vi19AR`0>Wh1MaJ4'CRB!RC0:Q1?`?M0Cl1(B ,Tb4B$S0JQh1'(B C-x C-b + + 0,T"i1M$GRA07X1!0"i1M$GRA07Uh1;CR!/M0BYh1c90GT19b40Gl1"M'(B Emacs 0,T9Qi19(B ,T(PM0BYh1c90:Q1?`?M0Cl1c40:Q1?`?M0Cl1K09Vh1'`JAM(B + + >> ,TEM'!4(B C-x 1 ,T`0>Wh1ME:CRB!RC0:Q1?`?M0Cl1MM!04Y1(B + + ,T!RC`0CU1B!a0?i1A0"i1M0AY1E0MWh190"Vi19ARa0!i1d"(B ,T5M907Uh1!S0EQ1'a0!i1d"a0?i1A0"i1M0AY1EK09Vh1'M0BYh109Qi19(B ,T(Pd0Ah17Sc0Ki1a0?i1A0"i1M0AY1E(B +,TaC!06Y1!`0!g1:0CQ1!IR(B 0,TJTh1'07Uh1a0!i1d"d;c9a0?i1A0"i1M0AY1EaC!(P06Y1!0:Q1907V1!d0Gi1c90:Q1?`?M0Cl1"M'a0?i1A0"i1M0AY1E09Qi19(B ,T`07h1R09Qi19(B + + ,T!RCJ0Ci1R'0:Q1?`?M0Cl1cK0Ah10"Vi19(B ,TJSK0CQ1:a0!i1d"a0?i1A0"i1M0AY1E0MQ1907Uh1JM'(B ,Ta0Ei1Ga0!i1MPdC:R'M0Bh1R'c90:Q1?`?M0Cl109Qi19(B +,T(Pd0Ah10AU1Wh1M(B +,Ta0!i1d"c95M9K0EQ1'(B + + ,Ta05h1`GER07Uh105i1M'!RC(P`0!g1:0CQ1!IR(B (save) 0,T:Q1?`?M0Cl1E'd;c9a0?i1A0"i1M0AY1E(B 0,T4i1GB$S0JQh1'(B C-x C-s 0,T9Qi19(B +,T(P05i1M'J0GT170+l1d;0BQ1'0:Q1?`?M0Cl107Uh105i1M'!RC(P`0!g1:(B 0,T4i1GB$S0JQh1'(B C-x C-f 0,T+Vh1'0$h1M90"i1R'0BXh1'BR!(B ,T`CR0AU1$S0JQh1'0+Vh1'(B +,Tc0*i1JSK0CQ1:!RC09Ui1b4B`)>RP(B 0,T$W1M(B + + C-x s ,T`0!g1:0CQ1!IR(B (save) 0,T7X1!0:Q1?`?M0Cl107Uh10AU1M0BYh1(B + + C-x s ,T(P`0!g1:0CQ1!IR07X1!0:Q1?`?M0Cl107Uh106Y1!a0!i1d"`09Wi1MKRd;(B ,TE'c9a0?i1A0"i1M0AY1E(B ,Tb4B(P6RA0!h1M90Gh1R(Pc0Ki1(B +,T`0!g1:0:Q1?`?M0Cl109Ui1dKA(B y ,TK0CW1M(B n 0,T!Q1:0:Q1?`?M0Cl1a05h1EP0:Q1?`?M0Cl1(B ,T$S6RA(P;CR!/c90Jh1G90Eh1R'"M'K09i1R(M(B 0,T4Q1'(B +0,T5Q1GM0Bh1R'09Ui1(B + + Save file /usr/private/yours/TUTORIAL.th? (y or n) + + + +,T!RC"BRB$S0JQh1'(B (extension) +======================= + + ,Tc9b;Ca!CA(B Editor 0,T9Ui1(B 0,TAU1(S9G9$S0JQh1'AR!!0Gh1R(B ,T(S9G9$S0JQh1'0+Vh1'JRARC6!4d04i1b4B0;Xh1A$M9b7CE(B +,TK0CW1M0;Xh1A(B META ,Td04i1KA4(B ,T$S0JQh1'"BRB(B (eXtend) 0,TAU1d0Gi1`0>Wh1Mc0Ki1JRARC6c0*i1$S0JQh1'`K0Eh1R09Ui1d04i1KA4(B 0,TAU1M0BYh1(B 2 +,Ta::(B 0,T4Q1'09Ui1(B + + C-x ,T"BRB`0>Th1A04i1GB05Q1G0MQ1!IC(B ,TJSK0CQ1:!405Q1G0MQ1!IC5RA`0"i1Rd;(B 1 0,T5Q1G(B + ESC x ,T"BRB`0>Th1A04i1GB0*Wh1M$S0JQh1'(B ,TJSK0CQ1:!40*Wh1M$S0JQh1'5RA`0"i1Rd;07Qi1'KA4(B + + ,T$S0JQh1';CP`@709Ui1(B 0,T!g1`0;g19$S0JQh1'07Uh10AU1;CPbB*09l1(B ,Ta05h10Jh1G9cK0-h1(P06Y1!`0CU1B!c0*i1(B 0,T9i1MB$0CQi1'!0Gh1R$S0JQh1'07Qh1Gd;(B +0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'KRa0?i1A0"i1M0AY1E(B (find) C-x C-f ,T$S0JQh1'`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B (save) C-x C-s +,T$S0JQh1'(B C-x C-c (,T`0ET1!(B Editor) 0,T5h1R'0!g1`0;g19K09Vh1'c9$S0JQh1'`K0Eh1R09Ui1(B + + ,T$S0JQh1'(B C-z ,T`0;g19$S0JQh1'07Uh1c0*i1c9c9!RCMM!(R!(B Emacs 0,T$h1M90"i1R'0:h1MB(B ,T$S0JQh1'09Ui1(Pd0Ah1B!`0ET1!(B +Emacs ,T`EB07U1`04U1BG(B ,Ta05h1(PK0BX14(B Emacs ,Td0Gi10*Qh1G$CRG(B ,T`0>Wh1Mc0Ki1JRARC6!0EQ1:d;c0*i1(B csh ,Td04i10MU1!(B ,T!RC!4(B +C-z 0,T(V1'`0;g19!RCK0BX14(B Emacs ,Td0Gi10*Qh1G$CRG`07h1R09Qi19(B ,T(Pd0Ah17S$GRA`0JU1BKRBc0Ki10!Q1:`09Wi1MKR07Uh1a0!i1d"d;(B + +,TKARB`K05X1(B: ,Ta05h170Gh1R(B ,Tc9!C03U107Uh1c0*i1:9(B X-window ,TK0CW1Mc0*i1(B sh ,TM0BYh1(B 0,T!g1(Pd0Ah10AU1$GRAJRARC609Ui1(B + + + ,T$S0JQh1';CP`@7(B C-x 0,TAU1AR!ARBKERB$S0JQh1'(B ,T$S0JQh1'07Uh1M08T1:RBd;a0Ei1G0AU104Q1'09Ui1(B + + C-x C-f ,TKRa0?i1A0"i1M0AY1E(B (find) ,TJSK0CQ1:a0!i1d"(B + C-x C-s ,T`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B (save) + C-x C-b ,TaJ4'CRB!RC0:Q1?`?M0Cl1(B (buffer list) + C-x C-c ,T`0ET1!!RCc0*i1(B Editor ,TaEP`0!g1:0CQ1!IRa0?i1A0"i1M0AY1Eb4B0MQ15b90AQ105T1(B ,Ta05h106i1RKR!0AU1a0?i1A(B + 0,T"i1M0AY1E:R'0MQ1906Y1!a0!i1d"(B 0,T!g1c0Ki16RA0Gh1R(P`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E09Qi19dKA(B ,Tb4B07Qh1Gd;(B + ,T!RCMM!(R!(B Emacs ,T7Sd04i1b4B$S0JQh1'(B C-x C-s C-x C-c 0,T$W1Mc0Ki1`0!g1:0CQ1!IR(B + 0,T!h1M9a0Ei1G0(V1'`0ET1!(B + + ,T$S0JQh1'"BRB`0>Th1Aa::0*Wh1M09Qi19(B ,Tc0*i1JSK0CQ1:$S0JQh1'07Uh1d0Ah10$h1MBd04i1c0*i1(B ,TK0CW1M$S0JQh1'07Uh1c0*i1`)>RP0!Q1:bKA40>T1`HI:R'(B +,TbKA4(B 0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'(B "command-apropos" 0,T+Vh1'(P6RA(B 0,T$U10Bl1`0GT10Cl14(B (keyword) ,Ta0Ei1GaJ4'> ,TEM'!4(B ESC x ,T5RA04i1GB(B "command-apropos" ,TK0CW1M(B + "command-a" ,TK0EQ1'(R!09Qi190!g1!4(B "kanji" 0,T4Y1(B + + ,Tc0Ki1!4(B C-x 1 ,T`GER05i1M'!RC(PE:(B "0,TGT19b40Gl1(B" 0,T7Uh1b<0Eh10"Vi19ARcK0Ah1(B + +,T:CC07Q14bKA4(B (Mode Line) +===================== + + ,T`GER07Uh10>T1A0>l1$S0JQh1'`0"i1Rd;0*i1R(B ,Tf(B Emacs ,T(PaJ4'0JTh1'07Uh10>T1A0>l1E'd;5C':CC07Q140Eh1R'0JX14"M'(M0+Vh1'`0CU1B!(B +0,TGh1R(B echo area ,T:CC07Q140+Vh1'M0BYh106Q140"Vi19ARK09Vh1':CC07Q14(B ,T`0CU1B!0Gh1R:CC07Q14bKA4(B (mode line) ,T:CC07Q14(B +,TbKA40AU10EQ1!I3P04Q1'09Ui1(B + + + [--]J:--**-Mule: TUTORIAL.th (Fundamental) ---NN%-------------- + + +,TKARB`K05X1(B: ,T5C'0Jh1G9(B NN ,T"M'(B NN% ,T(P0AU105Q1G`E"c0Jh1M0BYh1(B ,T:CC07Q14bKA407Uh1aJ4'M0BYh1MR((Pa5!05h1R'(B + ,Td;(R!05Q1GM0Bh1R'0:i1R'(B ,Ta05h10!g1d0Ah1`0;g19dC(B 0,T5Q1GM0Bh1R'`0*h19(B ,TMR((P0AU1`GERK0CW1M(B uptime + ,TaJ4'D05T1!CCA07Uh1a5!05h1R'0!Q19b4B0JTi19`0*T1'(B ,T`0AWh1MM0BYh1c9bKA4K0EQ1!07Uh105h1R'0!Q19(B 0,T5Q1GM0Bh1R'(B +,T`0*h19(B ,T`GERb;Ca!CA@RIR(B ,T(P0AU1$S0JQh1'JSK0CQ1:J0Ci1R'(B ,TKARB`K05X1(B (comment) ,TM0BYh1(B ,T`09Wh1M'(R!0GT108U1c0Jh1(B +,TKARB`K05X1"M'@RIRa05h1EP@RIRa5!05h1R'0!Q19(B ,T$S0JQh1'09Ui10!g1(Pa5!05h1R'0!Q19d;c9a05h1EPbKA4K0EQ1!(B ,T`0>Wh1Mc0Ki1(B +,TJRARC6c0Jh1KARB`K05X1c9a05h1EP@RIRd04i1M0Bh1R'06Y1!05i1M'(B + + ,T$S0JQh1'JSK0CQ1:!RC`;0EUh1B9bKA4c0Ki1`0;g19bKA4K0EQ1!0MWh19(B 0,T$W1M$S0JQh1'"BRB(B (extend) 0,T+Vh1'0*Wh1M$S0JQh1'`0;g190*Wh1M(B +,TbKA4(B 0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'(B M-x fundamental-mode 0,T$W1M$S0JQh1'JSK0CQ1:`;0EUh1B9bKA4`0;g19bKA4(B +Fundamental + + ,T`GER07Uh1(Pa0!i1d"a0?i1A0"i1M0AY1E@RIR0MQ1'!DI(B 0,T!g1c0Ki1c0*i1(B Text mode + + >> ,TEM'0;i1M9$S0JQh1'(B M-x text-mode + + 0,T6i1R05i1M'!RCKR0"i1M0AY1E`0>Th1A`0!Uh1BG0!Q1:bKA4K0EQ1!07Uh1c0*i1M0BYh1c90;Q1(0(X10:Q19(B 0,T!g1c0Ki10;i1M9$S0JQh1'(B C-h m + + >> ,Tc0Ki1!4(B C-h m ,T`0>Wh1M0HV1!IR0"i1Ma5!05h1R'CPK0Gh1R'(B Text mode 0,T!Q1:(B Fundamental mode + + >> ,Tc0Ki1!4(B C-x 1 ,T`0>Wh1ME:`M!JRCMM!(R!(M(B + + ,T5C'0Jh1G90+i1RB"M':CC07Q14bKA4(B ,T(P0AU10JQ1-0EQ1!I03l1(B '[--]' ,T`0>Wh1MaJ4'bKA4JSK0CQ1:!RC0;i1M90"i1M0AY1E(B +(input mode) ,TM0BYh1(B 0,TJQ1-0EQ1!I03l1(B [--] ,TKARB06V1'JRARC60;i1M90"i1M0AY1Ed04i104i1GB05Q1G0MQ1!IC@RIR0MQ1'!DI(B +(English alphabets) ,T!0CX13R0Mh1R90$Yh10AW1M"M'(B "Tamago" ,TJSK0CQ1:CRBEP`0MU1B4"M'0GT108U1c0*i1(B + + ,TaEP5C'04i1R9"GR"M'0JQ1-0EQ1!I03l109Qi19(B ,T(P0AU1`$0CWh1M'KARBaJ4'J6R9P"M'(B flag ,T"M'CP::C0KQ1J(B +(coding-system) ,TM0BYh1(B Mule ,TJRARC6!SK94CP::C0KQ1JaB!`)>RPJSK0CQ1:(B ,T!RC`0!g1:0Mh1R9a0?i1A0"i1M0AY1E(B +,T!RC0;i1M90"i1M0AY1E(R!0$U10Bl1:M0Cl14(B ,T!RCaJ4'RP(B +0,TJQ1-0EQ1!I03l10*h1GB(S(B (mnemonic) ,T"M'CP::C0KQ1JJSK0CQ1:!RC`0!g1:0Mh1R9a0?i1A0"i1M0AY1E(B ,T`07h1R09Qi19(B + + >> ,T5CG(04Y10Gh1R0AU10JQ1-0EQ1!I03l1(B ,T$0Ei1RB$0EV1'0!Q1:(B "J:" "S:" "E:" ,TaJ4'M0BYh107Uh1:CC07Q14bKA4K0CW1Md0Ah1(B + + 0,T5Q1G0MQ1!IC05Q1GaC!0$W1M(B 0,TJQ1-0EQ1!I03l10*h1GB(S(B (mnemonic) ,T"M'CP::C0KQ1J07Uh1c0*i1M0BYh1(B 0,T5Q1G(B ':' ,TaJ4'c0Ki10CYi1(B +0,TGh1R0AU105Q1G0MQ1!IC"M'@RIR0MWh19(B ,T9M!(R!@RIR0MQ1'!DIaJ4'M0BYh1(B (,T`0*h19(B ,T@RIR0(U19(B ,T@RIR0-Uh10;Xh19(B ,T`0;g1905i19(B) 0,T5Q1G(B J +,TKARB06V1'(B ,TC0KQ1J07Uh1c0*i10!Q1:(B JUNET 0,T$W1M(B ,TC0KQ1J(B JIS 0,T5Q1G(B S ,TKARB06V1'(B Shift-JIS ,TaEP(B 0,T5Q1G(B E ,TKARB06V1'(B +,TC0KQ1J(B EUC ,T@RIR0-Uh10;Xh19(B ,T(PJ0EQ1:`;0EUh1B9(B (toggle) ,T!RCaJ4'> ,TEM'0;i1M9$S0JQh1'(B C-x C-k t 0,T4Y1JM'$0CQi1'(B + + 0,T6i1R`7M0Cl10AT109Q1E07Uh1c0*i1M0BYh10AU10;Xh1A(B META ,TaEPbKA407Uh1c0*i1M0BYh1`0;g19C0KQ1J(B JIS ,T`CR0!g1(PJRARC6c0*i10;Xh1A(B META +,Ta79!RC!40;Xh1A(B ESCAPE ,Td04i1(B 0,TGT108U1c0*i1(P`K0AW1M90!Q1:!RCc0*i10;Xh1A$M9b7CE(B 0,T$W1Mc0Ki1!40;Xh1A(B META 0,T$i1R'd0Gi1a0Ei1G0(V1'(B +,T!405Q1G0MQ1!IC5RA(B M-<0,T5Q1G0MQ1!IC(B> ,T(P7SK09i1R07Uh1`K0AW1M90!Q1:(B ESC <0,T5Q1G0MQ1!IC(B> 0,T9Qh190$W1M(B 0,T7X1!M0Bh1R'07Uh1M08T1:RBAR(B +,T(906V1'0(X1409Ui1(B ,T(P0BQ1'$'0AU1 ,Tc0Ki1`0;g19(B M-<0,T5Q1G0MQ1!IC(B> ,Ta05h10"i1M(B +,T$GCCP0GQ1'0!g10$W1M(B 0,T;Xh1A(B META ,T(Pd0Ah1JRARC6c0*i1d04i10!Q1:C0KQ1J(B Shift-JIS ,TaEP(B EUC + + ,T!RC`;0EUh1B9CP::C0KQ1J(P0AU1U1B'0!Q1:a05h1EP0:Q1?`?M0Cl1`07h1R09Qi19(B ,TJRARC604Y1$S0JQh1'`0!Uh1BG0!Q1:CP::C0KQ1J(B +,Td04i1b4B$S0JQh1'(B C-h a coding-system + + >> ,Tc0Ki10;i1M9$S0JQh1'(B C-h a coding-system ,Ta0Ei1G0Mh1R9CRBEP`0MU1B4"M'$S0JQh1'(B + set-display-coding-system set-file-coding-system ,TaEP(B + set-process-coding-system ,T(R!`M!JRC07Uh1;CR!/0"Vi19(B + +,T!RC0$i19KR(B (search) +================ + + Emacs ,TJRARC60$i19KRJRB0MQ1!"CP(B (string) ,T@RBc9a0?i1A0"i1M0AY1Ed;7R'0"i1R'K09i1RK0CW1M0"i1R'K0EQ1'd04i1(B +0,T6i1R05i1M'!RC0$i19KRd;7R'0"i1R'K09i1R"M'5SaK09h1'`$M0Cl1`+M0Cl1(B (cursor) 0,T!g1c0Ki1!4(B C-s 0,T6i1R05i1M'!RC0$i19KR(B +,Td;7R'0"i1R'K0EQ1'"M'5SaK09h1'`$M0Cl1`+M0Cl1(B 0,T!g1c0Ki1!4(B C-r ,TK0EQ1'(R!09Qi19(P0AU10"i1M$GRA0Gh1R(B "I-search:" +,T;CR!/0"Vi195C'(B echo area ,TB!`0ET1!!RC0$i19KRd04i104i1GB!RC!4(B ESC + + + >> ,T!4(B C-s ,T`0>Wh1M`0CTh1A!RC0$i19KR(B ,Ta0Ei1G!405Q1G0MQ1!IC"M'$S0Gh1R(B "cursor" ,TE'd;07U1EP05Q1GM0Bh1R'(B + 0,T*i1R(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R`$M0Cl1`+M0Cl1"0BQ1:d;M0Bh1R'dC(B + + >> ,TEM'!4(B C-s 0,T4Y10MU1!K09Vh1'$0CQi1'`0>Wh1M0$i19KR$S0Gh1R(B "cursor" 0,T5Q1G05h1Md;(B + + >> ,T!4(B 0,T4Y1(B 4 ,T$0CQi1'(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R!RC`$0EWh1M907Uh1"M'`$M0Cl1`+M0Cl1(B + + >> ,T!4(B ESC ,T`0>Wh1MB!`0ET1!!RC0$i19KR(B + + ,T!RC0$i19KR(P`0CTh1A0"Vi1907Q1907U1(B ,Tc9CPK0Gh1R'07Uh10>T1A0>l1JRB0MQ1!"CP07Uh105i1M'!RC(P0$i19KR(B ,T`0"i1Rd;`0>U1B':R'0Jh1G9(B +0,T6i1R05i1M'!RC(P0$i19KR05Q1G05h1Md;(B 0,T!g1c0Ki1!4(B C-s 0,TMU1!K09Vh1'$0CQi1'(B 0,T6i1RKR!0$i19KRJRB0MQ1!"CP07Uh10;i1M9`0"i1Rd;d0Ah1>:(B 0,T!g1(B +,T(P0AU10"i1M$GRA;CR!/0"Vi19(B ,Tc0Ki1!4(B C-g ,T`0>Wh1MB!`0ET1!(B + + ,TCPK0Gh1R'07Uh10$i19KRM0BYh1(B 0,T6i1R!4(B 0,T5Q1G0MQ1!IC05Q1G0JX1407i1RBc9JRB0MQ1!"CP0!g1(P06Y1!E:d;(B ,Ta0Ei1G(B +,T`$M0Cl1`+M0Cl10!g1(P!0EQ1:d;5SaK09h1'0!h1M9K09i1R(B 0,T5Q1GM0Bh1R'`0*h19(B 0,T6i1R!4(B "cu" 0,T!g1(P0$i19KRd;06V1'5SaK09h1'07Uh10AU1$S0Gh1R(B +"cu" ,Ta05h106i1R!4(B ,Tc90(Q1'KGP09Ui1(B 0,T5Q1G(B 'u' ,Tc9(B search line 0,T!g1(PKRBd;(B ,Ta0Ei1G`$M0Cl1`+M0Cl1(B +,T(P"0BQ1:!0EQ1:d;07Uh15SaK09h1'07Uh10AU105Q1G(B 'c' ,TM0BYh1(B + + 0,T6i1R!405Q1G0MQ1!IC$M9b7CE(B (control character) 0,T5Q1G0MWh19(B ,T9M!`K09W1M(R!(B C-s ,TK0CW1M(B C-r +,T!RC0$i19KR0!g1(P0JTi190JX14E'(B + + ,T$S0JQh1'(B C-s ,T(P0$i19KRJRB0MQ1!"CP07Uh105i1M'!RC(B ,Td;7R'0"i1R'K09i1R"M'5SaK09h1'`$M0Cl1`+M0Cl1(B 0,T6i1R05i1M'!RC(B +0,T$i19KRd;7R'07T1HK0EQ1'(B 0,T!g1c0Ki1!4(B C-r 0,T9Qh190$W1M(B ,TJRARC6c0*i1(B C-s ,TaEP(B C-r ,TJ0EQ1:0!Q19`0>Wh1M0$i19KRd;d04i1c907Qi1'(B +,TJM'07T1H7R'(B C-s ,TaEP(B C-r ,T7SK09i1R07Uh1`K0AW1M90!Q1907X1!;CP!RC(B ,T(P05h1R'0!Q190!g15C'07T1H7R'!RC0$i19KR`07h1R09Qi19(B + +Recursive Editing Level + + ,T:R'07U1(B ,T`CRMR((PK0EX14`0"i1Rd;M0BYh1c9J6R9P07Uh1`0CU1B!0Gh1R(B Recursive Editing Level ,Td04i1b4B(B +,Td0Ah105Qi1'c((B ,Tc9bKA409Ui1(B ,T`$0CWh1M'KARBG'`0Eg1:(B '()' 0,T7Uh1aJ4'0*Wh1MbKA4K0EQ1!(B (major mode) ,TM0BYh1(P0AU1G'`0Eg1:(B +'[]' 0,TEi1MA(B ,T`0>Th1A0"Vi190MU1!K09Vh1'0*Qi19(B 0,T5Q1GM0Bh1R'`0*h19(B 0,T6i1R`04T1A`0;g19(B (Fundamental) ,TM0BYh1(B 0,T!g1(P`;0EUh1B9`0;g19(B +[(Fundamental)] ,Ta79(B + +,TKARB`K05X1(B: ,T`CR(Pd0Ah1M08T1:RB`0!Uh1BG0!Q1:(B Recursive Editing Level ,Tc907Uh109Ui1(B + + ,Tc0Ki1!4(B M-x top-level ,T`0>Wh1M07Uh1(PMM!(R!(B Recursive Editing Level + + >> ,TEM'!404Y1(B ,T5C'0Jh1G90Eh1R'"M'(M(P0AU10"i1M$GRA0Gh1R(B "Back to top level" ,T;CR!/0"Vi19(B + + ,T`09Wh1M'(R!(B ,T`CRM0BYh1c9CP04Q1::90JX14(B (top level) ,TM0BYh1a0Ei1G(B ,T$S0JQh1'09Ui10(V1'd0Ah10AU1Wh1M07Uh1(PMM!(R!(B Recursive Editing Level ,Td04i1(B + + +Help +==== + + Emacs 0,TAU1$GRAJRARC607Uh10AU1;CPbB*09l1(B ,TAR!ARBKERBM0Bh1R'(B 0,T+Vh1'd0Ah1JRARC6M08T1:RBd04i1KA4c907Uh109Ui1(B +,Ta05h1`CR(PJRARC6`0CU1B!c0*i1(B ,T`0>Wh1M07Uh1(P`0CU1B90CYi1$GRAJRARC6`K0Eh1R09Ui1(B ,Td04i1b4B!RC!4(B C-h 0,T+Vh1'(P(B +0,T*h1GBc0Ki1`CRd04i10CQ1:0CYi10"i1M0AY1E`0>Th1A`05T1AKERBM0Bh1R'(B + + 0,TGT108U1c0*i10$W1Mc0Ki1!4(B C-h ,Ta0Ei1G5RA04i1GB05Q1G`0EW1M!(B (option) 0,TMU1!K09Vh1'05Q1G0MQ1!IC(B 0,T6i1Rd0Ah10CYi10Gh1R(P05i1M'c0*i1(B +0,T5Q1G`0EW1M!MPdC(B 0,T!g1c0Ki1!4(B C-h ? ,Ta0Ei1G(P0AU1$SM08T1:RB`0!Uh1BG0!Q1:05Q1G`0EW1M!;CR!/0"Vi19(B ,Td04i1KR!`;0EUh1B9c((P(B +,Td0Ah1`0CU1B!(B HELP ,TK0EQ1'(R!!4(B C-h 0,T!g1c0Ki1!4(B C-g ,T`0>Wh1MB!`0ET1!d04i1(B + + ,T$S0JQh1'(B HELP 0,T>Wi190R907Uh10JX140MQ19K09Vh1'0!g10$W1M(B C-h c ,Ta0Ei1G5RA04i1GB!RC!4$S0JQh1':R'$S0JQh1'(B 0,T+Vh1'(Pc0Ki1$S(B +,TM08T1:RB0JQi19(B ,Tf(B ,T`0!Uh1BG0!Q1:$S0JQh1'09Qi19(B + + >> ,TEM'!4(B C-h c C-p 0,T4Y1(B 0,T+Vh1'(Pc0Ki10"i1M$GRA0Gh1R(B + "C-p runs the command previous-line" + + ,T$S0JQh1'09Ui1(P0*h1GB0CWi1M0?Wi19$GRA(S(B ,T`0!Uh1BG0!Q1:$S0JQh1'07Uh1`$B0> ,TEM'!4(B C-h k C-p 0,T4Y1(B + + 0,T!g1(P0AU10GT19b40Gl1`0>Th1Ac9(B Emacs 0,TMU1!K09Vh1'0MQ19(B ,T`0>Wh1MaJ4'CRBEP`0MU1B4"M'$S0JQh1'09Qi19(B ,T`0AWh1M0Mh1R9(:a0Ei1G(B +0,T!g1c0Ki1!4(B C-x 1 ,T`0>Th1AE:0GT19b40Gl1MM!(B + + 0,T5Q1G`0EW1M!0MWh1907Uh10AU1;CPbB*09l1(B 0,TAU104Q1'09Ui1(B + + C-h f ,Tc0Ki1c0Jh10*Wh1M"M'$S0JQh1'(B ,T`0>Wh1MaJ4'CRBEP`0MU1B4`0!Uh1BG0!Q1:$S0JQh1'09Qi19(B + + >> ,Tc0Ki1!4(B C-h f previous-line ,Ta0Ei1G5RA04i1GB(B ,T`0>Wh1MaJ4'CRBEP`0MU1B4`0!Uh1BG(B + 0,T!Q1:$S0JQh1'0+Vh1'`0CU1B!c0*i1d04i1(R!!RC!4(B C-p + + C-h a ,Ta0Ei1G5RA04i1GB0$U10Bl1`0GT10Cl14(B (keyword) ,T`0>Wh1MaJ4'$S0JQh1'07X1!$S0JQh1'(B 0,T7Uh10AU10$U10Bl1`0GT10Cl14(B ,TCGAM0BYh1(B + ,T$S0JQh1'`K0Eh1R09Ui1JRARC6`0CU1B!c0*i1d04i1b4B!RC!4(B ESC x + + >> ,TEM'!4(B C-h a file ,Ta0Ei1G5RA04i1GB(B ,T`0>Wh1MaJ4'0*Wh1M$S0JQh1'07X1!$S0JQh1'07Uh10AU1$S0Gh1R(B + "file" ,TCGAM0BYh1(B 0,T+Vh1'(P0AU1(B find-file ,TaEP(B write-file 0,T7Uh1`0CU1B!c0*i1d04i1b4B!RC!4(B + C-x C-f ,TaEP(B C-x C-w ,TCGAM0BYh104i1GB(B + +0,T7i1RB0JX1409Ui1(B +====== + +,TM0Bh1R0EW1A(B: ,T$S0JQh1'JSK0CQ1:!RC`0ET1!(B Emacs 0,T$W1M(B C-x C-c + + + ,T`M!JRC)0:Q1:`0:Wi1M'05i1909Ui1(B 0,T5Qi1'c(`0"U1B90"Vi19JSK0CQ1:0RP(B 0,T6i1RKR!0AU10(X14dK907Uh1d0Ah1(B +,T`0"i1Rc((B 0,T!g1M0Bh1R0AQ1Ga05h1b7I05Q1G`M'(B ,Ta05h1"Mc0Ki1bB9$GRA0RP(B +,TM0Bh1R'0BTh1'0!Q1:(B EMACS ,T`09Wh1M'(R!`0;g19b;Ca!CA07Uh10AU1$GRAJRARC6KER!KERBAR!(B 0,TMQ1907Uh1(0CT1'a0Ei1G(B EMACS +,T7Sd04i107X1!0JTh1'07X1!M0Bh1R'(B + + + +,T"M"M:0$X13(B +======= + ,T`M!JRC)0:Q1:09Ui1(B 0,T4Q14a;E'AR(R!(B "MicroEMACS (kemacs) ,T@RIR0-Uh10;Xh19(B ,T`0:Wi1M'05i19(B" 0,T+Vh1'd04i1AR(R!(B +JUNET ,T`0>Wh1Mc0Ki1c0*i1`0;g19(B Tutorial ,TJSK0CQ1:(B GNUEmacs (Nemacs) + + ,T`M!JRC09Ui1(B 0,T4Q14a;E'AR(R!(B "JOVE Tutorial" (19 ,TA!CR$A(B 86) ,T"M'(B Jonathan Payne + 0,T+Vh1'04Q14a;E'AR(R!`M!JRC"M'(B Steve Zimmerman ,Ta0Kh1'(B CCA-UNIX 0,T+Vh1'04Q14a;E'(B (0,TMU1!07U1(B) ,TAR(B + ,T(R!`M!JRC(B "Teach-Emacs" ,T)0:Q1:`0:Wi1M'05i19(B (31 0,T5X1ER$A(B 85) ,T"M'(B MIT + + Update - February 1986 by Dana Hoggatt. + + Update - December 1986 by Kim Leburg. + + Update/Translate - July 1987 by SANETO Takanori + +,T"M"M:0$X13`0;g190>T1`HI(B +============== + + 0,T$X13(B SANETO Takanori (,T+R`9b5P(B ,T7R!Rb90CT1(B) 0,TER4(B 0,T"i1M0AY1E`07g1((B ,TaEP0MWh19(B ,Tf(B ,Td0Gi1a05h1`0>U1B'0>>" scroll-up t]) - (add-menu-button nil ["Bot" end-of-buffer t]) - + ;; Here's a way to add scrollbar-like buttons to the menubar + (add-menu-button nil ["Top" beginning-of-buffer t]) + (add-menu-button nil ["<<<" scroll-down t]) + (add-menu-button nil [" . " recenter t]) + (add-menu-button nil [">>>" scroll-up t]) + (add-menu-button nil ["Bot" end-of-buffer t])) + ;; Change the behavior of mouse button 2 (which is normally ;; bound to `mouse-yank'), so that it inserts the selected text ;; at point (where the text cursor is), instead of at the diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/CATALOG --- a/etc/sgml/CATALOG Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -PUBLIC "-//IETF//ENTITIES Added Latin 1 for HTML//EN" html-latin.sgml -PUBLIC "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML" html-latin.sgml -PUBLIC "-//IETF//ENTITIES icons for HTML//EN" html-icons.sgml -PUBLIC "-//IETF//ENTITIES Math and Greek for HTML//EN" html-math.sgml -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd -PUBLIC "-//IETF//DTD HTML//EN//3.0" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN//" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN//" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN//3.0" html-3.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN//3.0" html-3s.dtd -PUBLIC "-//W3O//DTD W3 HTML Strict 3.0//EN//" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN//3.0" html-3s.dtd -PUBLIC "HTML" html.dtd -PUBLIC "-//IETF//DTD HTML//EN" html.dtd -PUBLIC "-//IETF//DTD HTML//EN//2.0" html.dtd -PUBLIC "-//IETF//DTD HTML 2.0//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN//2.0" html.dtd -PUBLIC "-//IETF//DTD HTML Level 1//EN" html-1.dtd -PUBLIC "-//IETF//DTD HTML Level 1//EN//2.0" html-1.dtd -PUBLIC "-//IETF//DTD HTML Level 0//EN" html-0.dtd -PUBLIC "-//IETF//DTD HTML Level 0//EN//2.0" html-0.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN//2.0" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN//2.0" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN" html-1s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN//2.0" html-1s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN" html-0s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN//2.0" html-0s.dtd -PUBLIC "-//Netscape Comm. Corp.//DTD HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML 2.0//EN" html-mcom.dtd -PUBLIC "-//Netscape Comm. Corp.//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML 2.0//EN" html-mcoms.dtd -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava HTML//EN" html-hj.dtd -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava Strict HTML//EN" html-hjs.dtd -PUBLIC "-//WebTechs//DTD PUML 1.0//EN" puml.dtd -PUBLIC "-//SQ//DTD HTML 2.0 HoTMetaL + extensions//EN" SQ.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML//EN" iehtml.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML Strict//EN" iehtml-s.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 Tables//EN" ietables.dtd -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd -PUBLIC "-//W3C//DTD HTML 3.2 Final//EN" html-3.2f.dtd -PUBLIC "-//W3C//DTD HTML Experimental 19960712//EN" html-cougar.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 3.0 Tables//EN" ie3tables.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 3.0 HTML//EN" ie30.dtd -PUBLIC "+//Silmaril//DTD HTML Pro v0r11 19970101//EN" htmlpro.dtd -DOCTYPE HTML html-3.2f.dtd -DOCTYPE HTML-3 html-3.dtd diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ECAT --- a/etc/sgml/ECAT Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -FILE html.dtd [ HTML.Recommended "INCLUDE" ] cdtd/html-r -FILE html.dtd [ ] cdtd/html -FILE html-2.dtd [ ] cdtd/html-2 -FILE html-3.dtd [ ] cdtd/html-3 -FILE html-mcom.dtd [ ] cdtd/html-mcom -FILE html-3.2.dtd [ ] cdtd/html-3.2 -FILE html-hj.dtd [ ] cdtd/html-hj -FILE iehtml.dtd [ ] cdtd/iehtml -FILE html-3.2f.dtd [] cdtd/html-3.2f diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Added_Latin_1 --- a/etc/sgml/ISO_8879=1986/entities/Added_Latin_1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Added_Latin_1_for_HTML --- a/etc/sgml/ISO_8879=1986/entities/Added_Latin_1_for_HTML Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Delimiters --- a/etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Delimiters Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Ordinary --- a/etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Ordinary Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Relations --- a/etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Relations Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Diacritical_Marks --- a/etc/sgml/ISO_8879=1986/entities/Diacritical_Marks Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/General_Technical --- a/etc/sgml/ISO_8879=1986/entities/General_Technical Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Greek_Symbols --- a/etc/sgml/ISO_8879=1986/entities/Greek_Symbols Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOamsa --- a/etc/sgml/ISO_8879=1986/entities/ISOamsa Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,66 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOamsb --- a/etc/sgml/ISO_8879=1986/entities/ISOamsb Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOamsc --- a/etc/sgml/ISO_8879=1986/entities/ISOamsc Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOamsn --- a/etc/sgml/ISO_8879=1986/entities/ISOamsn Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOamso --- a/etc/sgml/ISO_8879=1986/entities/ISOamso Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOamsr --- a/etc/sgml/ISO_8879=1986/entities/ISOamsr Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISObox --- a/etc/sgml/ISO_8879=1986/entities/ISObox Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOcyr1 --- a/etc/sgml/ISO_8879=1986/entities/ISOcyr1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOcyr2 --- a/etc/sgml/ISO_8879=1986/entities/ISOcyr2 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOdia --- a/etc/sgml/ISO_8879=1986/entities/ISOdia Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOgrk1 --- a/etc/sgml/ISO_8879=1986/entities/ISOgrk1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOgrk2 --- a/etc/sgml/ISO_8879=1986/entities/ISOgrk2 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOgrk3 --- a/etc/sgml/ISO_8879=1986/entities/ISOgrk3 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOgrk4 --- a/etc/sgml/ISO_8879=1986/entities/ISOgrk4 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOlat1 --- a/etc/sgml/ISO_8879=1986/entities/ISOlat1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOlat2 --- a/etc/sgml/ISO_8879=1986/entities/ISOlat2 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,131 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOnum --- a/etc/sgml/ISO_8879=1986/entities/ISOnum Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOpub --- a/etc/sgml/ISO_8879=1986/entities/ISOpub Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/ISOtech --- a/etc/sgml/ISO_8879=1986/entities/ISOtech Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISO_8879=1986/entities/Numeric_and_Special_Graphic --- a/etc/sgml/ISO_8879=1986/entities/Numeric_and_Special_Graphic Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ISOlat1.sgml --- a/etc/sgml/ISOlat1.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/README.cdtd --- a/etc/sgml/README.cdtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -The compiled dtd's are currently built by hand. Currently, something like -the following will work: - -../../src/xemacs -batch -q -l psgml-parse.elc -l psgml-dtd.elc -eval "(progn (sgml-set-global) (setq sgml-no-elements 0) (sgml-compile-dtd \"$(pwd)/html.dtd\" \"$(pwd)/cdtd/html\" []))" - -Note that the parameters are taken roughly from the ECAT file. diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/README.htmlpro --- a/etc/sgml/README.htmlpro Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -Drazen Kacar writes regarding htmlpro.dtd: - -You probably want the home page URL, though. Try - -The site cannot be reached sometimes. The mirror exists somewhere, but I -don't have the URL. diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/Wing.ISOlat1.sgml --- a/etc/sgml/Wing.ISOlat1.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html Binary file etc/sgml/cdtd/html has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html-2 Binary file etc/sgml/cdtd/html-2 has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html-3 Binary file etc/sgml/cdtd/html-3 has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html-3.2 Binary file etc/sgml/cdtd/html-3.2 has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html-3.2f Binary file etc/sgml/cdtd/html-3.2f has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html-hj Binary file etc/sgml/cdtd/html-hj has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html-mcom Binary file etc/sgml/cdtd/html-mcom has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/html-r Binary file etc/sgml/cdtd/html-r has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/cdtd/iehtml Binary file etc/sgml/cdtd/iehtml has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-0.dtd --- a/etc/sgml/html-0.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ - - - - - ... - - -- - > - - - - - - - - - - - - -%html; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-0s.dtd --- a/etc/sgml/html-0s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ - - - - - ... - - -- - > - - - - - -%html-0; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-1.dtd --- a/etc/sgml/html-1.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ - - - - - ... - - -- - > - - - - - -%html; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-1s.dtd --- a/etc/sgml/html-1s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ - - - - - ... - - -- - > - - - - - -%html-1; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-2.dtd --- a/etc/sgml/html-2.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,599 +0,0 @@ - - - - - ... - - -- - > - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - -Heading - is preferred to -

Heading

- --> -]]> - - - - -" - > - - - - - - - - - - - - - -#AttVal(Alt)" - > - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Directory" - > -Menu" - > - - - - - - - - - - - - - -Heading -

Text ... - is preferred to -

Heading

- Text ... - --> -]]> - - - - - - - - - - - - - - - - - - - - - -Form:" - %SDASUFF; "Form End." - > - - - - - - - - - - - - - - - - - - - - - -Select #AttVal(Multiple)" - > - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - -]]> - - - - - - - - - - - - - - -" > - - - - - - - - - - -[Document is indexed/searchable.]"> - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-3.2.dtd --- a/etc/sgml/html-3.2.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,599 +0,0 @@ - - - - - ... - - -- - > - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-3.2f.dtd --- a/etc/sgml/html-3.2f.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,598 +0,0 @@ - - - - - ... - - -- - > - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-3.dtd --- a/etc/sgml/html-3.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1447 +0,0 @@ - - - - - ... - - -- - > - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - -%HTMLlat1; - - - - - - - - - - - - - - - - - - -%HTMLicons; - - - - - - -%HTMLmath; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - -Heading -

Text ... - is preferred to -

Heading

- Text ... - --> -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-3s.dtd --- a/etc/sgml/html-3s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ - - - - - ... - - -- - > - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-hj.dtd --- a/etc/sgml/html-hj.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1302 +0,0 @@ - - - - - ... - - -- - > - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - -%HTMLlat1; - - - - - - - - - - - - - - - - - - -%HTMLicons; - - - - - - -%HTMLmath; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - -Heading -

Text ... - is preferred to -

Heading

- Text ... - --> -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-hjs.dtd --- a/etc/sgml/html-hjs.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ - - - - - ... - - -- - > - - - - - -%html; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-icons.sgml --- a/etc/sgml/html-icons.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-latin.sgml --- a/etc/sgml/html-latin.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,161 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-math.sgml --- a/etc/sgml/html-math.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-mcom.dtd --- a/etc/sgml/html-mcom.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,494 +0,0 @@ - - - - - ... - - -- - > - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - -]]> - - - - - - - -Heading - is preferred to -

Heading

- --> -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - -]]> - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - -Heading -

Text ... - is preferred to -

Heading

- Text ... - --> -]]> - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-mcoms.dtd --- a/etc/sgml/html-mcoms.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ - - - - - ... - - -- - > - - - - - - - -%html; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html-s.dtd --- a/etc/sgml/html-s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ - - - - - ... - - -- - > - - - - - -%html; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html.decl --- a/etc/sgml/html.decl Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/html.dtd --- a/etc/sgml/html.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,616 +0,0 @@ - - - - - ... - - -- - > - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - -Heading - is preferred to -

Heading

- --> -]]> - - - - -" - > - - - - - - - - - - - - - -#AttVal(Alt)" - > - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Directory" - > -Menu" - > - - - - - - - - - - - - - -Heading -

Text ... - is preferred to -

Heading

- Text ... - --> -]]> - - - - - - - - - - - - - - - - - - - - - -Form:" - %SDASUFF; "Form End." - > - - - - - - - - - - - - - - - - - - - - - -Select #AttVal(Multiple)" - > - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - -]]> - - - - - - - - - - - - - - -" > - - - - - - - - - - -[Document is indexed/searchable.]"> - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/htmlpro.dtd --- a/etc/sgml/htmlpro.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6093 +0,0 @@ - - - - - ... - - -- - > - - - - - -%html; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ie30.dtd --- a/etc/sgml/ie30.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,867 +0,0 @@ - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - -]]> - - - - -]]> - - - - - - - - -]]> - - - - - - -]]> - - - - - - - - -]]> - - - - - -]]> - - - - - -]]> - - - - -]]> - - - - -]]> - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - -]]> - - -]]> - - - - - - - -]]> - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -%ietables; - - - - - - -]]> - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ie3tables.dtd --- a/etc/sgml/ie3tables.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,179 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/iehtml-s.dtd --- a/etc/sgml/iehtml-s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ - - - - - ... - - -- - > - - - - - -%html; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/iehtml.dtd --- a/etc/sgml/iehtml.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,835 +0,0 @@ - - - - - - - - - - -]]> - - - - - - - - - - - - - - -%ISOlat1; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - -]]> - - - - -]]> - - - - - - -]]> - - - - -]]> - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Heading - is preferred to -

Heading

- --> -]]> - - - - -" - > - - - - - - - - - - - - - -#AttVal(Alt)" - > - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Directory" - > -Menu" - > - - - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Form:" - %SDASUFF; "Form End." - > - - - - - - - - - - - - - - - - - - - - - -Select #AttVal(Multiple)" - > - - - - - - - - - - - - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - - - -" > - - - - - - - - - - -[Document is indexed/searchable.]" - PROMPT CDATA #IMPLIED - ACTION CDATA #IMPLIED - > - - - - - - - - - - - - - - -]]> - - - - - - - - - - - - -]]> - - - - - - - - - - - -%ietables; diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/ietables.dtd --- a/etc/sgml/ietables.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/iso88591.map --- a/etc/sgml/iso88591.map Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -160 [nbsp ] -161 [iexcl ] -162 [cent ] -163 [pound ] -164 [curren] -165 [yen ] -166 [brvbar] -167 [sect ] -168 [uml ] -169 [copy ] -170 [ordf ] -171 [laquo ] -172 [not ] -173 [shy ] -174 [reg ] -175 [macr ] -176 [deg ] -177 [plusmn] -178 [sup2 ] -179 [sup3 ] -180 [acute ] -181 [micro ] -182 [para ] -183 [middot] -184 [cedil ] -185 [sup1 ] -186 [ordm ] -187 [raquo ] -188 [frac14] -189 [frac12] -190 [frac34] -191 [iquest] -192 [Agrave] -193 [Aacute] -194 [Acirc ] -195 [Atilde] -196 [Auml ] -197 [Aring ] -198 [AElig ] -199 [Ccedil] -200 [Egrave] -201 [Eacute] -202 [Ecirc ] -203 [Euml ] -204 [Igrave] -205 [Iacute] -206 [Icirc ] -207 [Iuml ] -208 [ETH ] -209 [Ntilde] -210 [Ograve] -211 [Oacute] -212 [Ocirc ] -213 [Otilde] -214 [Ouml ] -216 [Oslash] -217 [Ugrave] -218 [Uacute] -219 [Ucirc ] -220 [Uuml ] -221 [Yacute] -222 [THORN ] -223 [szlig ] -224 [agrave] -225 [aacute] -226 [acirc ] -227 [atilde] -228 [auml ] -229 [aring ] -230 [aelig ] -231 [ccedil] -232 [egrave] -233 [eacute] -234 [ecirc ] -235 [euml ] -236 [igrave] -237 [iacute] -238 [icirc ] -239 [iuml ] -240 [eth ] -241 [ntilde] -242 [ograve] -243 [oacute] -244 [ocirc ] -245 [otilde] -246 [ouml ] -248 [oslash] -249 [ugrave] -250 [uacute] -251 [ucirc ] -252 [uuml ] -253 [yacute] -254 [thorn ] -255 [yuml ] -192 À -193 Á -194 Â -195 Ã -196 Ä -197 Å -198 Æ -199 Ç -200 È -201 É -202 Ê -203 Ë -204 Ì -205 Í -206 Î -207 Ï -208 Ð -209 Ñ -210 Ò -211 Ó -212 Ô -213 Õ -214 Ö -216 Ø -217 Ù -218 Ú -219 Û -220 Ü -221 Ý -222 Þ -223 ß -224 à -225 á -226 â -227 ã -228 ä -229 å -230 æ -231 ç -232 è -233 é -234 ê -235 ë -236 ì -237 í -238 î -239 ï -240 ð -241 ñ -242 ò -243 ó -244 ô -245 õ -246 ö -248 ø -249 ù -250 ú -251 û -252 ü -253 ý -254 þ -255 ÿ diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/sinfo.dtd --- a/etc/sgml/sinfo.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,449 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -%general; - - - - - - - - - -' > -

' > - - - - - - - - - - -' -- formula begin -- > -'> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -"> -"> - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' -- formula end -- > - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -" > -" > - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' > - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -"> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -r d3e9274cbc4e -r e45d5e7c476e etc/sgml/webtechs.catalog --- a/etc/sgml/webtechs.catalog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ - -- catalog: SGML Open style entity catalog for HTML -- - -- $Id: webtechs.catalog,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ -- - -- well that $id is messed up now cos I edited the file! -- - - -- ISO latin 1 entity set for HTML -- = -PUBLIC "-//IETF//ENTITIES Added Latin 1 for HTML//EN" ISOlat1.sgml -PUBLIC "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML" ISOlat1.sgml - - -- fake HTMLicons reference -- -PUBLIC "-//IETF//ENTITIES icons for HTML//EN" html-icons.sgml - - -- fake HTMLmath reference -- -PUBLIC "-//IETF//ENTITIES Math and Greek for HTML//EN" html-math.sgml - - -- Ways to refer to Level 3.2: most general to most specific -- -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd - - -- Ways to refer to Level 3: most general to most specific -- -PUBLIC "-//IETF//DTD HTML//EN//3.0" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN//" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN//" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN//3.0" html-3.dtd - - -- Ways to refer to strict Level 3: most general to most specific -- -PUBLIC "-//IETF//DTD HTML Strict//EN//3.0" html-3s.dtd -PUBLIC "-//W3O//DTD W3 HTML Strict 3.0//EN//" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN//3.0" html-3s.dtd - - -- Ways to refer to Level 2: most general to most specific -- -PUBLIC "HTML" html.dtd -PUBLIC "-//IETF//DTD HTML//EN" html.dtd -PUBLIC "-//IETF//DTD HTML//EN//2.0" html.dtd -PUBLIC "-//IETF//DTD HTML 2.0//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN//2.0" html.dtd - - -- Ways to refer to Level 1: most general to most specific -- -PUBLIC "-//IETF//DTD HTML Level 1//EN" html-1.dtd -PUBLIC "-//IETF//DTD HTML Level 1//EN//2.0" html-1.dtd - - -- Ways to refer to Level 0: most general to most specific -- -PUBLIC "-//IETF//DTD HTML Level 0//EN" html-0.dtd -PUBLIC "-//IETF//DTD HTML Level 0//EN//2.0" html-0.dtd - - -- Ways to refer to Strict Level 2 -- -PUBLIC "-//IETF//DTD HTML Strict//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN//2.0" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN//2.0" html-s.dtd - - -- Ways to refer to Strict Level 1 -- -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN" html-1s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN//2.0" html-1s.dtd - - -- Ways to refer to Strict Level 0 -- -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN" html-0s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN//2.0" html-0s.dtd - - -- Ways to refer to Netscape extensions HTML -- -PUBLIC "-//Netscape Comm. Corp.//DTD HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML 2.0//EN" html-mcom.dtd -PUBLIC "-//Netscape Comm. Corp.//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML 2.0//EN" html-mcoms.dtd - - -- Ways to refer to Sun Microsystems HotJava extensions -- -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava HTML//EN" html-hj.dtd -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava Strict HTML//EN" html-hjs.dtd - - -- Ways to refer to PUML -- -PUBLIC "-//WebTechs//DTD PUML 1.0//EN" puml.dtd - - -- Ways to Refer to SoftQuad HTML 2.0 + extensions -- -PUBLIC "-//SQ//DTD HTML 2.0 HoTMetaL + extensions//EN" SQ.dtd - - -- Ways to refer to Microsoft extensions HTML -- -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML//EN" iehtml.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML Strict//EN" iehtml-s.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 Tables//EN" ietables.dtd - -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd - diff -r d3e9274cbc4e -r e45d5e7c476e etc/slb.xpm.Z Binary file etc/slb.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/slbm.xpm.Z Binary file etc/slbm.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sperber.xpm.Z Binary file etc/sperber.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/sperberm.xpm.Z Binary file etc/sperberm.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/spook.lines Binary file etc/spook.lines has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/stig.xpm.Z Binary file etc/stig.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/stigm.xpm.Z Binary file etc/stigm.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/thiessel.xpm.Z Binary file etc/thiessel.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/thiesselm.xpm.Z Binary file etc/thiesselm.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/vin.xpm.Z Binary file etc/vin.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/vinm.xpm.Z Binary file etc/vinm.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/viperCard.tex --- a/etc/viperCard.tex Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,739 +0,0 @@ -% ViperCard -- The Reference Card for Viper under GNU Emacs 20 and XEmacs 20 -%**start of header -\newcount\columnsperpage - -% This file can be printed with 1 or 2 columns per page (see below). -% Specify how many you want here. Nothing else needs to be changed. - -\columnsperpage=2 - -% Copyright (c) 1995, 1996, 1997 Free Software Foundation, Inc. - -% This file is part of GNU Emacs. - -% This file is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY. No author or distributor -% accepts responsibility to anyone for the consequences of using it -% or for whether it serves any particular purpose or describes -% any piece of software unless they say so in writing. Refer to the -% GNU Emacs General Public License for full details. -% -% Permission is granted to copy, modify and redistribute this source -% file provided the copyright notice and permission notices are -% preserved on all copies. -% -% Permission is granted to process this file through TeX and print the -% results, provided the printed document carries copyright and -% permission notices identical to the ones below. - -% This file is intended to be processed by plain TeX (TeX82). -% -% The final reference card has six columns, three on each side. -% This file can be used to produce it in any of three ways: -% 1 column per page -% produces six separate pages, each of which needs to be reduced to 80%. -% This gives the best resolution. -% 2 columns per page -% produces three already-reduced pages. -% You will still need to cut and paste. -% 3 columns per page -% produces two pages which must be printed sideways to make a -% ready-to-use 8.5 x 11 inch reference card. -% For this you need a dvi device driver that can print sideways. -% Which mode to use is controlled by setting \columnsperpage above. -% -% Author of Viper: -% Michael Kifer -% email: kifer@cs.sunysb.edu -% -% Author of VIP 4.3: -% Aamod Sane -% email: sane@cs.uiuc.edu -% -% Author of VIP 3.5: -% Masahiko Sato -% email: ms@sail.stanford.edu -% -% The original TeX code for formatting the reference card was written by: -% Stephen Gildea -% UUCP: mit-erl!gildea -% email: gildea@erl.mit.edu - - -\def\versionnumber{2.96} -\def\year{1997} -\def\version{August \year\ v\versionnumber} - -\def\shortcopyrightnotice{\vskip 1ex plus 2 fill - \centerline{\small \copyright\ \year\ Free Software Foundation, Inc. - Permissions on back. v\versionnumber}} - -\def\copyrightnotice{ -%\vskip 1ex plus 2 fill\begingroup\small -\vskip 1ex \begingroup\small -\centerline{Copyright \copyright\ \year\ Free Software Foundation, Inc.} -\centerline{by Michael Kifer, Viper \version} -\centerline{by Aamod Sane, VIP version 4.3} -\centerline{by Masahiko Sato, VIP version 3.5} - -Permission is granted to make and distribute copies of -this card provided the copyright notice and this permission notice -are preserved on all copies. - -For copies of the GNU Emacs manual, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\endgroup} - -% make \bye not \outer so that the \def\bye in the \else clause below -% can be scanned without complaint. -\def\bye{\par\vfill\supereject\end} - -\newdimen\intercolumnskip -\newbox\columna -\newbox\columnb - -\def\ncolumns{\the\columnsperpage} - -\message{[\ncolumns\space - column\if 1\ncolumns\else s\fi\space per page]} - -\def\scaledmag#1{ scaled \magstep #1} - -% This multi-way format was designed by Stephen Gildea -% October 1986. -% Slightly modified by Masahiko Sato, September 1987. -\if 1\ncolumns - \hsize 4in - \vsize 10in - %\voffset -.7in - \voffset -.57in - \font\titlefont=\fontname\tenbf \scaledmag3 - \font\headingfont=\fontname\tenbf \scaledmag2 - \font\miniheadingfont=\fontname\tenbf \scaledmag1 % masahiko - \font\smallfont=\fontname\sevenrm - \font\smallsy=\fontname\sevensy - - \footline{\hss\folio} - \def\makefootline{\baselineskip10pt\hsize6.5in\line{\the\footline}} -\else - %\hsize 3.2in - %\vsize 7.95in - \hsize 3.41in % masahiko - \vsize 8in % masahiko - \hoffset -.75in - \voffset -.745in - \font\titlefont=cmbx10 \scaledmag2 - \font\headingfont=cmbx10 \scaledmag1 - \font\miniheadingfont=cmbx10 % masahiko - \font\smallfont=cmr6 - \font\smallsy=cmsy6 - \font\eightrm=cmr8 - \font\eightbf=cmbx8 - \font\eightit=cmti8 - \font\eightsl=cmsl8 - \font\eighttt=cmtt8 - \font\eightsy=cmsy8 - \textfont0=\eightrm - \textfont2=\eightsy - \def\rm{\eightrm} - \def\bf{\eightbf} - \def\it{\eightit} - \def\sl{\eightsl} % masahiko - \def\tt{\eighttt} - \normalbaselineskip=.8\normalbaselineskip - \normallineskip=.8\normallineskip - \normallineskiplimit=.8\normallineskiplimit - \normalbaselines\rm %make definitions take effect - - \if 2\ncolumns - \let\maxcolumn=b - \footline{\hss\rm\folio\hss} - \def\makefootline{\vskip 2in \hsize=6.86in\line{\the\footline}} - \else \if 3\ncolumns - \let\maxcolumn=c - \nopagenumbers - \else - \errhelp{You must set \columnsperpage equal to 1, 2, or 3.} - \errmessage{Illegal number of columns per page} - \fi\fi - - %\intercolumnskip=.46in - \intercolumnskip=.19in % masahiko .19x4 + 3.41x3 = 10.99 - \def\abc{a} - \output={% - % This next line is useful when designing the layout. - %\immediate\write16{Column \folio\abc\space starts with \firstmark} - \if \maxcolumn\abc \multicolumnformat \global\def\abc{a} - \else\if a\abc - \global\setbox\columna\columnbox \global\def\abc{b} - %% in case we never use \columnb (two-column mode) - \global\setbox\columnb\hbox to -\intercolumnskip{} - \else - \global\setbox\columnb\columnbox \global\def\abc{c}\fi\fi} - \def\multicolumnformat{\shipout\vbox{\makeheadline - \hbox{\box\columna\hskip\intercolumnskip - \box\columnb\hskip\intercolumnskip\columnbox} - \makefootline}\advancepageno} - \def\columnbox{\leftline{\pagebody}} - - \def\bye{\par\vfill\supereject - \if a\abc \else\null\vfill\eject\fi - \if a\abc \else\null\vfill\eject\fi - \end} -\fi - -% we won't be using math mode much, so redefine some of the characters -% we might want to talk about -\catcode`\^=12 -\catcode`\_=12 - -\chardef\\=`\\ -\chardef\{=`\{ -\chardef\}=`\} - -\hyphenation{mini-buf-fer} - -\parindent 0pt -\parskip 1ex plus .5ex minus .5ex - -\def\small{\smallfont\textfont2=\smallsy\baselineskip=.8\baselineskip} - -\outer\def\newcolumn{\vfill\eject} - -\outer\def\title#1{{\titlefont\centerline{#1}}\vskip 1ex plus .5ex} - -\outer\def\section#1{\par\filbreak - \vskip 3ex plus 2ex minus 2ex {\headingfont #1}\mark{#1}% - \vskip 2ex plus 1ex minus 1.5ex} - -% masahiko -\outer\def\subsection#1{\par\filbreak - \vskip 2ex plus 2ex minus 2ex {\miniheadingfont #1}\mark{#1}% - \vskip 1ex plus 1ex minus 1.5ex} - -\newdimen\keyindent - -\def\beginindentedkeys{\keyindent=1em} -\def\endindentedkeys{\keyindent=0em} -\endindentedkeys - -\def\paralign{\vskip\parskip\halign} - -\def\<#1>{$\langle${\rm #1}$\rangle$} - -\def\kbd#1{{\tt#1}\null} %\null so not an abbrev even if period follows - -\def\beginexample{\par\leavevmode\begingroup - \obeylines\obeyspaces\parskip0pt\tt} -{\obeyspaces\global\let =\ } -\def\endexample{\endgroup} - -\def\key#1#2{\leavevmode\hbox to \hsize{\vtop - {\hsize=.75\hsize\rightskip=1em - \hskip\keyindent\relax#1}\kbd{#2}\hfil}} - -\newbox\metaxbox -\setbox\metaxbox\hbox{\kbd{M-x }} -\newdimen\metaxwidth -\metaxwidth=\wd\metaxbox - -\def\metax#1#2{\leavevmode\hbox to \hsize{\hbox to .75\hsize - {\hskip\keyindent\relax#1\hfil}% - \hskip -\metaxwidth minus 1fil - \kbd{#2}\hfil}} - -\def\fivecol#1#2#3#4#5{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad&\kbd{#4}\quad&\kbd{#5}\cr} - -\def\fourcol#1#2#3#4{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad&\kbd{#4}\quad\cr} - -\def\threecol#1#2#3{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad\cr} - -\def\twocol#1#2{\hskip\keyindent\relax\kbd{#1}\hfil&\kbd{#2}\quad\cr} - -\def\twocolkey#1#2#3#4{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad&\relax#3\hfil&\kbd{#4}\quad\cr} - -%**end of header - -\beginindentedkeys - -\title{ViperCard: Viper Reference Pal} - -\centerline{(For Version 2.96 under Emacs 20 and XEmacs 20)} - -%\copyrightnotice - -\section{Loading Viper} - -Just type \kbd{M-x viper-mode} followed by \kbd{RET} - -OR put (require 'viper) in .emacs - -\section{Viper States} - -Viper has four states: {\it emacs state}, {\it vi state}, {\it insert state}, -{\it replace state}. -Mode line tells you which state you are in. -In emacs state you can do all the normal GNU Emacs editing. -This card explains only vi state and insert state (replace state is similar -to insert state). -{\bf GNU Emacs Reference Card} explains emacs state. -You can switch states as follows. - -\key{from emacs state to vi state}{C-z} -\key{from vi state to emacs state}{C-z} -\metax{from vi state to insert state}{i, I, a, A, o, O} -\metax{from vi state to replace state}{c, C, R} -\key{from insert or replace state to vi state}{ESC} - - -\section{Insert Mode} -You can do editing in insert state. - -\metax{go back to vi state}{ESC} -\metax{delete previous character}{C-h, DEL} -\key{delete previous word}{C-w} -\key{delete line word}{C-u} -\key{indent shiftwidth forward}{C-t} -\key{indent shiftwidth backward}{C-d} -\key{delete line word}{C-u} -\key{quote following character}{C-v} -\key{emulate Meta key in emacs state}{C-\\} -\key{escape to Vi state for one command}{C-z} - -\vskip 2mm - -{\bf The rest of this card explains commands in {\bf vi state}.} - -\section{Getting Information on Viper} - -Execute info command by typing \kbd{M-x info} and select menu item -\kbd{viper}. Also: - -\key{describe function attached to the key {\it x}}{$\backslash$ C-h k {\it x}} - -\section{Leaving Emacs} - -\metax{suspend Emacs}{:st {\rm or} :su} -\metax{exit Emacs permanently}{C-xC-c} -\metax{exit current file}{:wq {\rm or} :q} - -\shortcopyrightnotice - -\section{Error Recovery} - -\metax{abort command}{C-c (user level = 1)} -\metax{abort command}{C-g (user level > 1)} -\key{redraw messed up screen}{C-l} -\metax{{\bf recover} after system crash}{:rec file} -\metax{restore a buffer }{:e!\ {\rm or} M-x revert-buffer} - - -\section{Counts} - -Most commands in vi state accept a {\it count} which can be supplied as a -prefix to the commands. In most cases, if a count is given, the -command is executed that many times. E.g., \kbd{5 d d} deletes 5 -lines. - -\section{Registers} - -There are 26 registers (\kbd{a} to \kbd{z}) that can store texts -and marks. -You can append a text at the end of a register (say \kbd{x}) by -specifying the register name in capital letter (say \kbd{X}). -There are also 9 read only registers (\kbd{1} to \kbd{9}) that store -up to 9 previous changes. -We will use {\it x\/} to denote a register. -\section{Entering Insert Mode} - -\key{{\bf insert} at point}{i} -\key{{\bf append} after cursor}{a} -\key{{\bf insert} before first non-white}{I} -\key{{\bf append} at end of line}{A} -\key{{\bf open} line below}{o} -\key{{\bf open} line above}{O} - -\section{Buffers and Windows} - -\key{move cursor to {\bf next} window}{C-x o} -\key{delete current window}{C-x 0} -\key{delete other windows}{C-x 1} -\key{split current window into two windows}{C-x 2} -\key{{\bf switch} to a buffer in the current window}{C-x {\sl buffer}} -\metax{{\bf switch} to a buffer in another window}{:n, :b, {\rm or} C-x 4 {\sl buf}} -\key{{\bf kill} a buffer}{:q! {\rm or} C-x k} -\key{list existing {\bf buffers}}{:args {\rm or} C-x b} - -\section{Files} - -\metax{{\bf visit} file in the current window}{v {\sl file} {\rm or} :e {\sl file}} -\key{{\bf visit} file in another window}{V {\sl file}} -\key{{\bf visit} file in another frame}{C-v {\sl file}} -\key{{\bf save} buffer to the associated file}{:w {\rm or} C-xC-s} -\metax{{\bf write} buffer to a specified file}{:w {\sl file} {\rm or} C-xC-w} -\metax{{\bf insert} a specified file at point}{:r {\sl file} {\rm or} C-xi} -\key{{\bf get} information on the current {\bf file}}{C-c g {\rm or} :f} -\key{run the {\bf directory} editor}{:e RET {\rm or} C-xd} - -%\shortcopyrightnotice - -\section{Viewing the Buffer} - -\key{scroll to next screen}{C-f} -\key{scroll to previous screen}{C-b} -\key{scroll {\bf down} half screen}{C-d} -\key{scroll {\bf up} half screen}{C-u} -\key{scroll down one line}{C-e} -\key{scroll up one line}{C-y} - -\key{put current line on the {\bf home} line}{z H {\rm or} z RET} -\key{put current line on the {\bf middle} line}{z M {\rm or} z .} -\key{put current line on the {\bf last} line}{z L {\rm or} z -} - -\section{Marking and Returning} - -\key{{\bf mark} point in register {\it x}}{m {\it x}} -\key{set mark at buffer beginning}{m <} -\key{set mark at buffer end}{m >} -\key{set mark at point}{m .} -\key{jump to mark}{m ,} -\key{exchange point and mark}{` `} -\key{... and skip to first non-white on line}{' '} -\key{go to mark {\it x}}{` {\it x}} -\key{... and skip to first non-white on line}{' {\it x}} -\key{view contents of marker {\it x}}{[ {\it x}} -\key{view contents of register {\it x}}{] {\it x}} - -\section{Macros} - -Emacs style macros: - -\key{start remembering keyboard macro}{C-x (} -\key{finish remembering keyboard macro}{C-x )} -\key{call last keyboard macro}{*} - -\key{start remembering keyboard macro}{@ \#} -\key{finish macro and put into register {\it x}}{@ {\it x}} -\key{execute macro stored in register {\it x}}{@ {\it x}} -\key{repeat last @{\it x} command}{@ @} - -\key{Pull last macro into register {\it x}}{@ ! {\it x}} - -Vi-style macros (keys to be hit in quick succession): - -\key{define Vi-style macro for Vi state}{:map} -\key{define Vi-style macro for Insert state}{:map!} - -\key{toggle case-sensitive search}{//} -\key{toggle regular expression search}{///} -\key{toggle `\%' to ignore parentheses inside comments}{\%\%\%} - - -\section{Motion Commands} - -\key{go backward one character}{h {\rm or} C-h} -\key{go forward one character}{l} -\metax{next line keeping the column}{j {\rm or} LF {\rm or} C-n} -\key{previous line keeping the column}{k} -\metax{next line at first non-white}{+ {\rm or} RET {\rm or} C-p} -\key{previous line at first non-white}{-} - -\key{beginning of line}{0} -\key{first non-white on line}{^} -\key{end of line}{\$} -\key{go to {\it n}-th column on line}{{\it n} |} - -\key{go to {\it n}-th line}{{\it n} G} -\key{go to last line}{G} -\key{find matching parenthesis for \kbd{()}, \kbd{\{\}} and \kbd{[]}}{\%} - -\key{go to {\bf home} window line}{H} -\key{go to {\bf middle} window line}{M} -\key{go to {\bf last} window line}{L} - -\subsection{Words, Sentences, Paragraphs, Headings} - -\key{forward {\bf word}}{w {\rm or} W} -\key{{\bf backward} word}{b {\rm or} B} -\key{{\bf end} of word}{e {\rm or} E} - -In the case of capital letter commands, a word is delimited by a -non-white character. - -\key{forward sentence}{)} -\key{backward sentence}{(} - -\key{forward paragraph}{\}} -\key{backward paragraph}{\{} - -\key{forward heading}{]]} -\key{backward heading}{[[} -\key{end of heading}{[]} - -\subsection{Find Characters on the Line} - -\key{{\bf find} {\it c} forward on line}{f {\it c}} -\key{{\bf find} {\it c} backward on line}{F {\it c}} -\key{up {\bf to} {\it c} forward on line}{t {\it c}} -\key{up {\bf to} {\it c} backward on line}{T {\it c}} -\key{repeat previous \kbd{f}, \kbd{F}, \kbd{t} or \kbd{T}}{;} -\key{... in the opposite direction}{,} - -%\newcolumn -%\title{Viper Quick Reference Card} - -\section{Searching and Replacing} - -\key{search forward for {\sl pat}}{/ {\sl pat}} -\key{search backward with previous {\sl pat}}{?\ RET} -\key{search forward with previous {\sl pat}}{/ RET} -\key{search backward for {\sl pat}}{?\ {\sl pat}} -\key{repeat previous search}{n} -\key{... in the opposite direction}{N} - -\key{{\bf query} replace}{Q} -\key{{\bf replace} a character by another character {\it c}}{r {\it c}} -\key{{\bf overwrite} {\it n} lines}{{\it n} R} - -\metax{{\bf buffer} search (if enabled)}{g {\it move command}} - -\section{Modifying Commands} - -Most commands that operate on text regions accept the motion commands, -to describe regions. They also accept the Emacs region specifications -{\bf r} and {\bf R}. {\bf r} describes the region between {\it point} -and {\it mark}, and {\bf R} describes whole lines in that region. -Motion commands are classified into {\it point commands} and -{\it line commands}. In the case of line commands, whole lines will -be affected by the command. - -The point commands are as follows: - -\hskip 5ex -\kbd{h l 0 ^ \$ w W b B e E ( ) / ?\ ` f F t T \% ; ,} - -The line commands are as follows: - -\hskip 5ex -\kbd{j k + - H M L \{ \} G '} - -These region specifiers will be referred to as {\it m} below. - -\subsection{Delete/Yank/Change Commands} - -\paralign to \hsize{#\tabskip=10pt plus 1 fil&#\tabskip=0pt&#\tabskip=0pt&#\cr -\fourcol{}{{\bf delete}}{{\bf yank}}{{\bf change}} -\fourcol{region determined by {\it m}}{d {\it m}}{y {\it m}}{c {\it m}} -\fourcol{... into register {\it x}}{" {\it x\/} d {\it m}}{" {\it x\/} y {\it m}}{" {\it x\/} c {\it m}} -\fourcol{a line}{d d}{Y {\rm or} y y}{c c} -\fourcol{current {\bf region}}{d r}{y r}{c r} -\fourcol{expanded {\bf region}}{d R}{y R}{c R} -\fourcol{to end of line}{D}{y \$}{c \$} -\fourcol{a character after point}{x}{y l}{c l} -\fourcol{a character before point}{DEL}{y h}{c h} -} - -\vskip 2ex -\key{Overwrite {\it n} lines}{{\it n} R} - -\subsection{Put Back Commands} - -Deleted/yanked/changed text can be put back by the following commands. - -\key{{\bf Put} back at point/above line}{P} -\key{... from register {\it x}}{" {\it x\/} P} -\key{{\bf put} back after point/below line}{p} -\key{... from register {\it x}}{" {\it x\/} p} - -\subsection{Repeating and Undoing Modifications} - -\key{{\bf undo} last change}{u {\rm or} :und} -\key{repeat last change}{.\ {\rm (dot)}} - -Undo is undoable by \kbd{u} and repeatable by \kbd{.}. -For example, \kbd{u...} will undo 4 previous changes. -A \kbd{.} after \kbd{5dd} is equivalent to \kbd{5dd}, -while \kbd{3.} after \kbd{5dd} is equivalent to \kbd{3dd}. - -\section{Miscellaneous Commands} - -\endindentedkeys - -\paralign to \hsize{#\tabskip=5pt plus 1 fil&#\tabskip=0pt&#\tabskip=0pt&#\tabskip=0pt&#\cr -\fivecol{}{{\bf shift left}}{{\bf shift right}}{{\bf filter shell command}}{{\bf indent}} -\fivecol{region}{< {\it m}}{> {\it m}}{!\ {\it m\/} {\sl shell-com}}{= {\it m}} -\fivecol{line}{< <}{> >}{!\ !\ {\sl shell-com}}{= =} -} - -\key{{\bf join} lines}{J} -\key{toggle case (takes count)}{\~{}} - -\key{view register {\it x}}{] {\it x}} -\key{view marker {\it x}}{] {\it x}} - -\key{lowercase region}{\# c {\it m}} -\key{uppercase region}{\# C {\it m}} -\key{execute last keyboard macro on each line in the region}{\# g {\it m}} - -\key{insert specified string for each line in the region}{\# q {\it m}} -\key{check spelling of the words in the region}{\# s {\it m}} - -\key{repeat previous ex substitution}{\&} -\key{change to previous file}{C-^} - -\key{Viper Meta key}{_} - -\section{Customization} - -By default, search is case sensitive. -You can change this by including the following line in your \kbd{\~{}/.vip} file. - -\hskip 5ex -\kbd{(setq viper-case-fold-search t)} - -The following is a subset of the variety of -options available for customizing Viper. -See the Viper manual for details on these and other options. - -\beginindentedkeys - -\paralign to \hsize{#\tabskip=10pt plus 1 fil&#\tabskip=0pt&#\cr -\twocol{{\bf variable}}{{\bf default value}} -\twocol{viper-search-wrap-around}{t} -\twocol{viper-case-fold-search}{nil} -\twocol{viper-re-search}{t} -\twocol{viper-re-replace}{t} -\twocol{viper-re-query-replace}{t} -\twocol{viper-auto-indent}{nil} -\twocol{viper-shift-width}{8} -\twocol{viper-tags-file-name}{"TAGS"} -\twocol{viper-no-multiple-ESC}{t} -\twocol{viper-ex-style-motion}{t} -\twocol{viper-always}{t} -\twocol{viper-custom-file-name}{"\~{}/.vip"} -\twocol{ex-find-file-shell}{"csh"} -\twocol{ex-cycle-other-window}{t} -\twocol{ex-cycle-through-non-buffers}{t} -\twocol{blink-matching-paren}{t} -\twocol{buffer-read-only}{{\it buffer dependent}} -} - -To bind keys in Vi command state, put lines like these in your -\kbd{\~{}/.vip} file: - -\beginexample -(define-key viper-vi-global-user-map "\\C-v" 'scroll-down) -(define-key viper-vi-global-user-map "\\C-cm" 'smail) -\endexample - - -\newcolumn - -\title{Ex Commands in Viper} - -In vi state, an Ex command is entered by typing: - -\hskip 5ex -\kbd{:\ {\sl ex-command} RET} - -\section{Ex Addresses} - -\paralign to \hsize{#\tabskip=5pt plus 1 fil&#\tabskip=2pt&#\tabskip=5pt plus 1 fil&#\cr -\twocolkey{current line}{.}{next line with {\sl pat}}{/ {\sl pat} /} -\twocolkey{line {\it n}}{{\it n}}{previous line with {\sl pat}}{?\ {\sl pat} ?} -\twocolkey{last line}{\$}{{\it n\/} line before {\it a}}{{\it a} - {\it n}} -\twocolkey{next line}{+}{{\it a\/} through {\it b}}{{\it a\/} , {\it b}} -\twocolkey{previous line}{-}{line marked with {\it x}}{' {\it x}} -\twocolkey{entire buffer}{\%}{previous context}{' '} -} - -Addresses can be specified in front of a command. -For example, - -\hskip 5ex -\kbd{:.,.+10m\$} - -moves 11 lines below current line to the end of buffer. - -\section{Ex Commands} - -Avoid Ex text manipulation commands except substitute. -There are better VI equivalents -for all of them. Also note that all Ex commands expand \% to -current file name. To include a \% in the command, escape it with a $\backslash$. -Similarly, \# is replaced by previous file. For Viper, this is the -first file in the {\sl :args} listing for that buffer. This defaults -to the previous file in the VI sense if you have one window. -Ex commands can be made to have history. See the manual for details. - -\subsection{Ex Text Commands} - -\endindentedkeys - -\key{mark lines matching {\sl pat} and execute {\sl cmds} on these lines}{:g /{\sl pat}/ {\sl cmds}} - -\key{mark lines {\it not\/} matching {\sl pat} and execute {\sl cmds} on these lines}{:v /{\sl pat}/ {\sl cmds}} - - -\key{{\bf move} specified lines after {\sl addr}}{:m {\sl addr}} -\key{{\bf copy} specified lines after {\sl addr}}{:co\rm\ (or \kbd{:t})\ \sl addr} -\key{{\bf delete} specified lines [into register {\it x\/}]}{:d {\rm [{\it x\/}]}} -\key{{\bf yank} specified lines [into register {\it x\/}]}{:y {\rm [{\it x\/}]}} -\key{{\bf put} back text [from register {\it x\/}]}{:pu {\rm [{\it x\/}]}} - -\key{{\bf substitute} {\sl repl} for first string on line matching {\sl pat}}{:s /{\sl pat}/{\sl repl}/} - -\key{repeat last substitution}{:\&} -\key{repeat previous substitute with previous search pattern as {\sl pat}}{:\~{}} - -\subsection{Ex File and Shell Commands} - -\key{{\bf edit} file}{:e {\sl file}} -\key{reedit messed up current file}{:e!} -\key{edit previous file}{:e\#} -\key{{\bf read} in a file}{:r {\sl file}} -\key{{\bf read} in the output of a shell command}{:r {\sl !command}} -\key{write out specified lines into {\sl file}}{:w {\sl file}} -\key{save all modified buffers, ask confirmation}{:W {\sl file}} -\key{save all modified buffers, no confirmation}{:WW {\sl file}} -\key{write out specified lines at the end of {\sl file}}{:w>> {\sl file}} -\key{{\bf write} to the input of a shell command}{:w {\sl !command}} -\key{write out and then quit}{:wq {\sl file}} - -\key{run a sub{\bf shell} in a window}{:sh} -\key{execute shell command {\sl command}}{:!\ {\sl command}} -\key{execute previous shell command with {\it args} appended}{:!! {\sl args}} - -\subsection{Ex Miscellaneous Commands} - -\key{define a macro {\it x} that expands to {\sl cmd}}{:map {\it x} {\sl cmd}} -\key{remove macro expansion associated with {\it x}}{:unma {\it x}} -\key{define a macro {\it x} that expands to {\sl cmd} in insert state}{:map!\ {\it x} {\sl cmd}} -\key{remove macro expansion associated with {\it x} in insert state}{:unma!\ {\it x}} - -\key{print line number}{:.=} -\key{print last line number}{:=} -\key{print {\bf version} number of Viper}{:ve} - -\key{shift specified lines to the right}{:>} -\key{shift specified lines to the left}{:<} - -\key{{\bf join} lines}{:j} -\key{mark specified line to register {\it x}}{:k {\it x}} -\key{{\bf set} a variable's value}{:se} -\key{find first definition of {\bf tag} {\sl tag}}{:ta {\sl tag}} - -\key{Current directory}{:pwd} - - -\copyrightnotice - -\bye - -% Local variables: -% compile-command: "tex viperCard" -% End: diff -r d3e9274cbc4e -r e45d5e7c476e etc/vladimir.xpm.Z Binary file etc/vladimir.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/vladimirm.xpm.Z Binary file etc/vladimirm.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/audio_stamp-colorful.xpm --- a/etc/vm/audio_stamp-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -/* XPM */ -static char *audio_stamp[] = { -/* width height num_colors chars_per_pixel */ -" 18 24 12 1", -/* colors */ -". c #000000", -"# c #00ffff", -"a c #00ff00", -"b c #bebebe s background", -"c c #ff00ff", -"d c #ff0000", -"e c #6e6e6e", -"f c #ffffff", -"g c #ffff00", -"h c #e7e7e7", -"i c #bfbfbf", -"j c #0000ff", -/* pixels */ -"bbbbbbbbbbbbbbbbbb", -"bbbbbbbbbbbbabbbbb", -"bbbbbbbbbbbebbbbbb", -"bbbbbbbeebbbbbebbb", -"bbbbbbbe.bbbbjebbb", -"bbbbbbeh.bbejijhbb", -"bbbbbebh.bijhieiib", -"bbbbiehh.bieiejibb", -"b..e.hhh.biebjjiib", -"b.hehhhh.bejibebci", -"b.hhhhhh.ijjiibiib", -"b.hhhhhh.ihiiieiii", -"b.hhhhhh.ibiiieiii", -"b.hhhhhh.bhfbbdhii", -"b.hhhhhh.bbbbieiib", -"b.hehhhh.bbbideiib", -"b..e.hhh.bbbidebbb", -"bbbbbehh.bbbiibbbb", -"bbbbbebh.bbbbbbbgi", -"bbbbiieh.bbbbbbbgg", -"bbbbiibe.bb#bbbbib", -"bbbbbbbeebbbh#bbgb", -"bbbbbbbbbbbbbbbbii", -"bbbbbbbbbbbbbbbbgb" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/audio_stamp-simple.xpm --- a/etc/vm/audio_stamp-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -/* XPM */ -static char *audio_stamp[] = { -/* width height num_colors chars_per_pixel */ -" 18 24 12 1", -/* colors */ -". c #000000", -"# c #00ffff", -"a c #00ff00", -"b c #bebebe s background", -"c c #ff00ff", -"d c #ff0000", -"e c #6e6e6e", -"f c #ffffff", -"g c #ffff00", -"h c #e7e7e7", -"i c #bfbfbf", -"j c #0000ff", -/* pixels */ -"bbbbbbbbbbbbbbbbbb", -"bbbbbbbbbbbbabbbbb", -"bbbbbbbbbbbebbbbbb", -"bbbbbbbeebbbbbebbb", -"bbbbbbbe.bbbbjebbb", -"bbbbbbeh.bbejijhbb", -"bbbbbebh.bijhieiib", -"bbbbiehh.bieiejibb", -"b..e.hhh.biebjjiib", -"b.hehhhh.bejibebci", -"b.hhhhhh.ijjiibiib", -"b.hhhhhh.ihiiieiii", -"b.hhhhhh.ibiiieiii", -"b.hhhhhh.bhfbbdhii", -"b.hhhhhh.bbbbieiib", -"b.hehhhh.bbbideiib", -"b..e.hhh.bbbidebbb", -"bbbbbehh.bbbiibbbb", -"bbbbbebh.bbbbbbbgi", -"bbbbiieh.bbbbbbbgg", -"bbbbiibe.bb#bbbbib", -"bbbbbbbeebbbh#bbgb", -"bbbbbbbbbbbbbbbbii", -"bbbbbbbbbbbbbbbbgb" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/autofile-dn.xbm --- a/etc/vm/autofile-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00, - 0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb, - 0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0x5f,0xfe,0xff,0xff,0xff,0xff,0x7f, - 0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff, - 0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff, - 0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xfe,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xfe,0xff, - 0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe, - 0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb, - 0xfe,0xff,0xff,0xff,0xff,0xff,0xfa,0xdb,0xfe,0xff,0xff,0xff,0xff,0xff,0x01, - 0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xfc,0x0f,0x90,0xff,0xff,0xff,0xc3, - 0xff,0xfc,0xcf,0x9f,0xff,0xff,0xff,0xdb,0x4c,0x18,0xce,0x93,0xe1,0xff,0xff, - 0x99,0xcc,0xcc,0xcc,0x93,0xcc,0xff,0xff,0x99,0xcc,0xcc,0x0c,0x92,0xcc,0xff, - 0xff,0x81,0xcc,0xcc,0xcc,0x93,0xc0,0xff,0xff,0x3c,0xcc,0xcc,0xcc,0x93,0xfc, - 0xff,0xff,0x3c,0xc4,0xc4,0xcc,0x93,0xcc,0xff,0xff,0x3c,0xc9,0x19,0xce,0x93, - 0xe1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/autofile-dn.xpm --- a/etc/vm/autofile-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * autofile_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXooXXXXXXXXXXXooXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXooooXXXXXXXXXXooXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXoXXoXXooXXooXooooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXoooooXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooooooXooXXooXXooXXooXXooXXooXXXXooXooXooooooXXXXXXXXXX", -"XXXXXXXXooXXXXooooXXooXXooXXooXXooXXooXXXXooXooXooXXXXXXXXXXXXXX", -"XXXXXXXXooXXXXooooXoooXXooXoooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXooXXXXooXooXooXXXooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/autofile-up.xbm --- a/etc/vm/autofile-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff, - 0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04, - 0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x80, - 0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x80,0x00,0x00,0x01,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x05,0x24,0x01,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x18,0x00,0x03,0xf0,0x6f,0x00,0x00,0x00,0x3c, - 0x00,0x03,0x30,0x60,0x00,0x00,0x00,0x24,0xb3,0xe7,0x31,0x6c,0x1e,0x00,0x00, - 0x66,0x33,0x33,0x33,0x6c,0x33,0x00,0x00,0x66,0x33,0x33,0xf3,0x6d,0x33,0x00, - 0x00,0x7e,0x33,0x33,0x33,0x6c,0x3f,0x00,0x00,0xc3,0x33,0x33,0x33,0x6c,0x03, - 0x00,0x00,0xc3,0x3b,0x3b,0x33,0x6c,0x33,0x00,0x00,0xc3,0x36,0xe6,0x31,0x6c, - 0x1e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/autofile-up.xpm --- a/etc/vm/autofile-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * autofile_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXooXXXXXXXXXXXooXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXooooXXXXXXXXXXooXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXoXXoXXooXXooXooooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXoooooXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooooooXooXXooXXooXXooXXooXXooXXXXooXooXooooooXXXXXXXXXX", -"XXXXXXXXooXXXXooooXXooXXooXXooXXooXXooXXXXooXooXooXXXXXXXXXXXXXX", -"XXXXXXXXooXXXXooooXoooXXooXoooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXooXXXXooXooXooXXXooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/autofile-xx.xbm --- a/etc/vm/autofile-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3c, - 0x00,0x03,0x30,0x60,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x66,0x33,0x33,0x33,0x6c,0x33,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x7e,0x33,0x33,0x33,0x6c,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xc3,0x3b,0x3b,0x33,0x6c,0x33,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/compose-dn.xbm --- a/etc/vm/compose-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x01,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xe7,0xff, - 0xff,0xff,0xff,0xff,0xff,0xfd,0xd7,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0x87, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0x0f,0x00, - 0x00,0xf0,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x2f, - 0xff,0x7f,0xf4,0xff,0xff,0xff,0xff,0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff, - 0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff,0xef,0x03,0x78,0xf4,0xff,0xff,0xff, - 0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x03,0xfe,0xf7,0xff,0xff, - 0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x83,0xff,0xf7,0xff, - 0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7, - 0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x0f,0x00,0x00, - 0xf0,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe6, - 0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x3f,0x2c,0x62,0x72,0x38,0x1c,0xfe,0x3f, - 0x9f,0xc9,0x4c,0x24,0x93,0xc9,0xfc,0x3f,0x9f,0xc9,0x4c,0x26,0x13,0xcf,0xfc, - 0x3f,0x9f,0xc9,0x4c,0x26,0x73,0x0c,0xfc,0x3f,0x9f,0xc9,0x4c,0x26,0xf3,0xc8, - 0xff,0x7f,0x86,0xc9,0x4c,0x24,0x93,0xc9,0xfc,0xff,0x30,0xcc,0x4c,0x72,0x38, - 0x1c,0xfe,0xff,0xff,0xff,0x7f,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/compose-dn.xpm --- a/etc/vm/compose-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * compose_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXXXXooooXXoXoooXoooXXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXoooXXXXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXoooXXooooooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXXoooXooXXXXXXXXXX", -"XXXXXXXooXXooooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXXXooooXXooooXXooXXooXXooXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/compose-up.xbm --- a/etc/vm/compose-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x18,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x78, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0xf0,0xff, - 0xff,0x0f,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xd0, - 0x00,0x80,0x0b,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x19, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xc0,0xd3,0x9d,0x8d,0xc7,0xe3,0x01,0xc0, - 0x60,0x36,0xb3,0xdb,0x6c,0x36,0x03,0xc0,0x60,0x36,0xb3,0xd9,0xec,0x30,0x03, - 0xc0,0x60,0x36,0xb3,0xd9,0x8c,0xf3,0x03,0xc0,0x60,0x36,0xb3,0xd9,0x0c,0x37, - 0x00,0x80,0x79,0x36,0xb3,0xdb,0x6c,0x36,0x03,0x00,0xcf,0x33,0xb3,0x8d,0xc7, - 0xe3,0x01,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/compose-up.xpm --- a/etc/vm/compose-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * compose_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXXXXooooXXoXoooXoooXXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXoooXXXXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXoooXXooooooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXXoooXooXXXXXXXXXX", -"XXXXXXXooXXooooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXXXooooXXooooXXooXXooXXooXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/compose-xx.xbm --- a/etc/vm/compose-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x19, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0, - 0x60,0x36,0xb3,0xdb,0x6c,0x36,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xc0,0x60,0x36,0xb3,0xd9,0x8c,0xf3,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x79,0x36,0xb3,0xdb,0x6c,0x36,0x03,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/delete-dn.xbm --- a/etc/vm/delete-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0xf8, - 0xf1,0xff,0xff,0xff,0xff,0xff,0xfd,0x33,0xf0,0xff,0xff,0xff,0xff,0x1f,0xf0, - 0x0b,0xfc,0xff,0xff,0xff,0xff,0x0f,0x80,0x83,0xff,0xff,0xff,0xff,0xff,0xff, - 0x05,0x82,0xff,0xff,0xff,0xff,0xff,0xff,0x3d,0xb0,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7d,0xb8,0xff,0xff,0xff,0xff,0xff,0xff,0x3d,0xa0,0xff,0xff,0xff,0xff, - 0xff,0xff,0x1d,0x83,0xff,0xff,0xff,0xff,0xff,0xff,0x8d,0x0f,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xc5,0x3f,0xfc,0xff,0xff,0xff,0xff,0xff,0xe1,0xbf,0xf0,0xff, - 0xff,0xff,0xff,0xff,0xf0,0xbf,0xe1,0xff,0xff,0xff,0xff,0x3f,0xfc,0xbf,0xc3, - 0xff,0xff,0xff,0xff,0x1f,0xfc,0xbf,0xc7,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xf8,0x9f,0xff,0xfc,0xff,0xff,0xff,0x3f, - 0xf3,0x9f,0xff,0xfc,0xff,0xff,0xff,0x3f,0x67,0x98,0x61,0x18,0xfe,0xff,0xff, - 0x3f,0x27,0x93,0xcc,0xcc,0xfc,0xff,0xff,0x3f,0x27,0x93,0xcc,0xcc,0xfc,0xff, - 0xff,0x3f,0x27,0x90,0xc0,0x0c,0xfc,0xff,0xff,0x3f,0x27,0x9f,0xfc,0xcc,0xff, - 0xff,0xff,0x3f,0x33,0x93,0xcc,0xc4,0xfc,0xff,0xff,0x3f,0x78,0x98,0xe1,0x19, - 0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/delete-dn.xpm --- a/etc/vm/delete-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * delete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOooXXooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooOOOOOOo+ooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoooooooooooOOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOooooooOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOooooooOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOooooOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoooooooOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoooOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoooOOOOOoooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOoXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOoXXooooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOOOoXXXooooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooOOOOOOOOOOOOoXXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooooooXooXooooooXXooXXooooooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXooXXooXooXooXXooXXooXoooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXooooXXooXXooooXXXXooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/delete-up.xbm --- a/etc/vm/delete-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0e,0x00,0x00,0x00,0x00,0x00,0x02,0xcc,0x0f,0x00,0x00,0x00,0x00,0xe0,0x0f, - 0xf4,0x03,0x00,0x00,0x00,0x00,0xf0,0x7f,0x7c,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfa,0x7d,0x00,0x00,0x00,0x00,0x00,0x00,0xc2,0x4f,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x47,0x00,0x00,0x00,0x00,0x00,0x00,0xc2,0x5f,0x00,0x00,0x00,0x00, - 0x00,0x00,0xe2,0x7c,0x00,0x00,0x00,0x00,0x00,0x00,0x72,0xf0,0x01,0x00,0x00, - 0x00,0x00,0x00,0x3a,0xc0,0x03,0x00,0x00,0x00,0x00,0x00,0x1e,0x40,0x0f,0x00, - 0x00,0x00,0x00,0x00,0x0f,0x40,0x1e,0x00,0x00,0x00,0x00,0xc0,0x03,0x40,0x3c, - 0x00,0x00,0x00,0x00,0xe0,0x03,0x40,0x38,0x00,0x00,0x00,0x00,0x00,0x02,0x40, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x07,0x60,0x00,0x03,0x00,0x00,0x00,0xc0, - 0x0c,0x60,0x00,0x03,0x00,0x00,0x00,0xc0,0x98,0x67,0x9e,0xe7,0x01,0x00,0x00, - 0xc0,0xd8,0x6c,0x33,0x33,0x03,0x00,0x00,0xc0,0xd8,0x6c,0x33,0x33,0x03,0x00, - 0x00,0xc0,0xd8,0x6f,0x3f,0xf3,0x03,0x00,0x00,0xc0,0xd8,0x60,0x03,0x33,0x00, - 0x00,0x00,0xc0,0xcc,0x6c,0x33,0x3b,0x03,0x00,0x00,0xc0,0x87,0x67,0x1e,0xe6, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/delete-up.xpm --- a/etc/vm/delete-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * delete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOooXXooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooOOOOOOo+ooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoooooooooooOOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOooooooOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOooooooOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOooooOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoooooooOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoooOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoooOOOOOoooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOoXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOoXXooooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOOOoXXXooooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooOOOOOOOOOOOOoXXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooooooXooXooooooXXooXXooooooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXooXXooXooXooXXooXXooXoooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXooooXXooXXooooXXXXooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/delete-xx.xbm --- a/etc/vm/delete-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x0f, - 0xf4,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfa,0x7d,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x47,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xe2,0x7c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x3a,0xc0,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x0f,0x40,0x1e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xe0,0x03,0x40,0x38,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x07,0x60,0x00,0x03,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x98,0x67,0x9e,0xe7,0x01,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xd8,0x6c,0x33,0x33,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xd8,0x60,0x03,0x33,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x87,0x67,0x1e,0xe6, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/document-colorful.xpm --- a/etc/vm/document-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -/* XPM */ -static char *document2[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 32 1", -/* colors */ -". c #000000", -"# c #a4a5a4", -"a c #9f9f9f", -"b c #999999", -"c c #919191", -"d c #818181", -"e c #6d6d6d", -"f c #5d5d5d", -"g c #494949", -"h c #eaeaea", -"i c #373737", -"j c #e3e4e3", -"k c #d4d4d4", -"l c #c8c8c8", -"m c #0d0d0d", -"n c #b4b4b4", -"o c #b0aeb0", -"p c #aeaeae", -"q c #aaaaaa s background", -"r c #888888", -"s c #767676", -"t c #646464", -"u c #545454", -"v c #ffffff", -"w c #f6f7f6", -"x c #efefef", -"y c #dfdfdf", -"z c #dad9da", -"A c #242424", -"B c #cfcfcf", -"C c #bfbfbf", -"D c #b9b9b9", -/* pixels */ -"qqqqqaetr#qqqqqqqqqqqqqq", -"qqqq#errefd#qqqqqqqqqqqq", -"qqq#rzklCqcdsdra#qqqqqqq", -"qqqrkvvxzkkln#rtfdaqqqqq", -"qq#dvvvvvvxxzklCqcrdsr#q", -"qq#rresr#lxvvvvxhzl#tisq", -"qqqqqdsefgieCxvvvvxiAiiq", -"qqqqqrCttffuuuernkagtiiq", -"qqqq#nxvxxcsuetsuigrsitq", -"qqqqczhzxhzzlC#seffscifq", -"qqqqrvlyxxzlCCzxxkCaCmrq", -"qqqq#vvlzqhzvvvklalvciaq", -"qqqckhlkzzhlCCkhhxvvguqq", -"qqqrvvxvklalxxxlq#xvmd#q", -"qqqcvxklkvxvxllkhxvlArqq", -"qq#Cvvvvvvvvvvvvhxvtgqqq", -"qqrxxvvvvvvvvvvvvvvAeqqq", -"qqrvkzhzhxxvvvvvvvkmrqqq", -"qqqlhvvlCrnkhvvvvvci#qqq", -"qckxxxhxxkzzllllvvguqqqq", -"qrvklklxxxhlnlzxvhmrqqqq", -"qahzvvhCcCnxvxlhvqicqqqq", -"clxkkqlzhkkklCzvvfg#qqqq", -"txvvvvxlrzlzvvkvvAeqqqqq", -"dtalvvvvvvxknzhvlArqqqqq", -"rgimmgdqhvvvvvvvei#qqqqq", -"qq#rtiA..i#xvvvvitqqqqqq", -"qqqqqarsgimmis#Cmrqqqqqq", -"qqqqqqqqq#ceiA..icqqqqqq", -"qqqqqqqqqqqq#rdfeqqqqqqq" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/document-simple.xpm --- a/etc/vm/document-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #000000", -"a c #818181", -"b c #EAEAEA", -"c c #D4D4D4", -"d c #AAAAAA s background", -"e c #545454", -"f c #FFFFFF", -"g c #242424", -/* pixels */ -"ddddddaeaddddddddddddddd", -"dddddaaaaeaddddddddddddd", -"ddddacccddaaaaaddddddddd", -"dddacffbccccddaeeadddddd", -"dddaffffffbbcccddaaaaadd", -"dddaaaaadcbffffbbccdegad", -"dddddaaaeegadbffffbggggd", -"dddddadeeeeeeeaadcdeeggd", -"ddddddbfbbaaeaeaegeaaged", -"ddddacbcbbcccddaaeeaaged", -"ddddafccbbccddcbbcddd`ad", -"dddddffccdbcfffccdcfagdd", -"dddacbccccbcddcbbbffeedd", -"dddaffbfccdcbbbcddbf`add", -"dddafbcccfbfbcccbbfcgadd", -"ddddffffffffffffbbfeeddd", -"ddabbffffffffffffffgaddd", -"ddafccbcbbbfffffffc`addd", -"dddcbffcdadcbfffffagdddd", -"dacbbbbbbcccccccffeedddd", -"dafccccbbbbcdccbfb`adddd", -"ddbcffbdaddbfbcbfdgadddd", -"acbccdccbccccdcffeeddddd", -"ebffffbcacccffcffgaddddd", -"aedcffffffbcdcbfcgaddddd", -"aeg``eadbfffffffagdddddd", -"dddaegg``gdbffffgedddddd", -"ddddddaaeg``gadd`adddddd", -"ddddddddddaagg``gadddddd", -"dddddddddddddaaeaddddddd" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/file-dn.xbm --- a/etc/vm/file-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00, - 0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb, - 0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0x5f,0xfe,0xff,0xff,0xff,0xff,0x7f, - 0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff, - 0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff, - 0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xfe,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xfe,0xff, - 0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe, - 0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb, - 0xfe,0xff,0xff,0xff,0xff,0xff,0xfa,0xdb,0xfe,0xff,0xff,0xff,0xff,0xff,0x01, - 0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x80,0xfc,0xff,0xff,0xff,0xff,0xff, - 0x7f,0xfe,0xfc,0xff,0xff,0xff,0xff,0xff,0x7f,0x9e,0x0c,0xff,0xff,0xff,0xff, - 0xff,0x7f,0x9e,0x64,0xfe,0xff,0xff,0xff,0xff,0x7f,0x90,0x64,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0x9e,0x04,0xfe,0xff,0xff,0xff,0xff,0x7f,0x9e,0xe4,0xff,0xff, - 0xff,0xff,0xff,0x7f,0x9e,0x64,0xfe,0xff,0xff,0xff,0xff,0x7f,0x9e,0x0c,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/file-dn.xpm --- a/etc/vm/file-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * file_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooooXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/file-up.xbm --- a/etc/vm/file-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff, - 0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04, - 0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x80, - 0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x80,0x00,0x00,0x01,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x05,0x24,0x01,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x7f,0x03,0x00,0x00,0x00,0x00,0x00, - 0x80,0x01,0x03,0x00,0x00,0x00,0x00,0x00,0x80,0x61,0xf3,0x00,0x00,0x00,0x00, - 0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x80,0x6f,0x9b,0x01,0x00,0x00, - 0x00,0x00,0x80,0x61,0xfb,0x01,0x00,0x00,0x00,0x00,0x80,0x61,0x1b,0x00,0x00, - 0x00,0x00,0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x80,0x61,0xf3,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/file-up.xpm --- a/etc/vm/file-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * file_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooooXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/file-xx.xbm --- a/etc/vm/file-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x80,0x01,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x80,0x61,0xfb,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/film-colorful.xpm --- a/etc/vm/film-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -/* XPM */ -static char *film[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 32 1", -/* colors */ -". c #000000", -"# c #799fa1", -"a c #060919", -"b c #411707", -"c c #8fc7ff", -"d c #3f4040", -"e c #873d06", -"f c #62b1e6", -"g c #392e26", -"h c #292a2a", -"i c #9a9e9f", -"j c #284367", -"k c #646666", -"l c #aacae6", -"m c #238fc1", -"n c #182a50", -"o c #93673e", -"p c #7f7f80", -"q c #131516", -"r c #aaaaaa s background", -"s c #ddf2fd", -"t c #6991ac", -"u c #1c0804", -"v c #494b4a", -"w c #948b79", -"x c #733006", -"y c #151c34", -"z c #592009", -"A c #9f4c05", -"B c #54585d", -"C c #376389", -"D c #231305", -/* pixels */ -"rrrrrrrrwirrrrrrrrrrrrrr", -"rrrrpddv..prrrrrrrrrrrrr", -"rrrpjdkyajjprriiiwiiwirr", -"rrrnf.pfu.tgri.q....agir", -"rrktC.dlC.hCpiivqCCjjhBr", -"rrdcv..lca.tjrrddoBoogdr", -"rptcj.ulcj.djrrvdAAAAzBr", -"rBtcj..lcCuapprvgxxxxbdr", -"rvcfB.alkr..#BrBdDDDDuBr", -"rdjkt.kB.#..#vrBgnnnhadr", -"rjq.lCla.kq.BvrBgttmtjhr", -"rn..llc..Bh.BvrkvAAAAbBr", -"rh..rjl..Bh.kvrkgAAAAzdr", -"rn..#tla.pa.pdrBgxxxxbdr", -"rv..rccq.py.pBrvgzbzbqkr", -"rjhhlniC.ra.rdrvha.auhBr", -"rv#lt.Bctc..fBrdgCmCChkr", -"rvcct.qlc#.utkrhztCtpnBr", -"rBflC..lcC.nCiidxAAAxdkr", -"rptcB..lcj.Cvrphbeeezhpr", -"rrdcC.qlfuutkrkhDbzbqhrr", -"rrktt.Bcv.Cnrrkq....ddrr", -"rrihtnrtaaBkrrhnCCCnhBrr", -"rrrdq#t..avrrpBepppDqwrr", -"rrrp..BipwrrrvDeeexqdrrr", -"rrrrh.krrrrrkqDbDbDhkrrr", -"rrrrp.qrrrrphynnyaudrrrr", -"rrrrrd.hkpBqhoBkjqdprrrr", -"rrrrrrv......u.qhhprrrrr", -"rrrrrrrpvqu..uadpirrrrrr" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/film-simple.xpm --- a/etc/vm/film-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #000000", -"a c #8FC7FF", -"b c #284367", -"c c #238FC1", -"d c #7F7F80", -"e c #AAAAAA s background", -"f c #592009", -"g c #9F4C05", -/* pixels */ -"eeeeeeeedeeeeeeeeeeeeeee", -"eeeedbbb``deeeeeeeeeeeee", -"eeedbbd``bbdeeeeedeedeee", -"eeeba`da``dfee```````fee", -"eeddb`bab`fbdeeb`bbbbfbe", -"eebab``aa``dbeebbgbggfbe", -"eddab``aab`bbeebbggggfbe", -"ebdab``aab``ddebffffffbe", -"ebaab``ade``dbebb`````be", -"ebbdd`db`d``dbebfbbbf`be", -"eb``aba``d``bbebfddcdbfe", -"eb``aaa``bf`bbedbggggfbe", -"ef``eba``bf`dbedfggggfbe", -"eb``dda``d``dbebffffffbe", -"eb``eaa``d``dbebfffff`de", -"ebffabeb`e``ebebf````fbe", -"ebdad`bada``abebfbcbbfde", -"ebaad``aad``ddeffdbddbbe", -"ebaab``aab`bbeebfgggfbde", -"eddab``aab`bbedffgggffde", -"eebab``aa``ddedf`fff`fee", -"eeddd`bab`bbeed`````bbee", -"eeefdbed``bdeefbbbbbfbee", -"eeeb`dd```beedbgddd``dee", -"eeed``beddeeeb`gggf`beee", -"eeeef`deeeeed``f`f`fdeee", -"eeeed``eeeedf`bb```beeee", -"eeeeeb`fddb`fgbdb`bdeeee", -"eeeeeeb`````````ffdeeeee", -"eeeeeeedb``````bdeeeeeee" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/gear-colorful.xpm --- a/etc/vm/gear-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,279 +0,0 @@ -/* XPM */ -static char *gear[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 242 2", -/* colors */ -".. c #aaaaaa s background", -"zz c #aaaaaa", -".# c #8e8e8e", -".a c #4d4d4d", -".b c #9f9f9f", -".c c #888888", -".d c #848484", -".e c #838383", -".f c #828282", -".g c #484848", -".h c #303030", -".i c #131313", -".j c #141414", -".k c #707070", -".l c #777777", -".m c #2b2b2b", -".n c #1d1d1d", -".o c #121212", -".p c #393939", -".q c #727272", -".r c #a0a0a0", -".s c #8b8b8b", -".t c #3e3e3e", -".u c #878787", -".v c #151515", -".w c #2d2d2d", -".x c #8a8a8a", -".y c #171717", -".z c #202020", -".A c #0c0c0c", -".B c #191919", -".C c #222222", -".D c #333333", -".E c #2f2f2f", -".F c #353535", -".G c #cacaca", -".H c #e9e9e9", -".I c #5c5c5c", -".J c #c5c5c5", -".K c #323232", -".L c #d9d9d9", -".M c #f9f9f9", -".N c #ffffff", -".O c #fbfbfb", -".P c #c7c7c7", -".Q c #1e1e1e", -".R c #6c6c6c", -".S c #a7a7a7", -".T c #242424", -".U c #1a1a1a", -".V c #6e6e6e", -".W c #bababa", -".X c #efefef", -".Y c #fefefe", -".Z c #f6f6f6", -".0 c #eaeaea", -".1 c #e8e8e8", -".2 c #454545", -".3 c #d3d3d3", -".4 c #e0e0e0", -".5 c #f7f7f7", -".6 c #4f4f4f", -".7 c #232323", -".8 c #e4e4e4", -".9 c #f0f0f0", -"#. c #e7e7e7", -"## c #e5e5e5", -"#a c #bfbfbf", -"#b c #fcfcfc", -"#c c #d1d1d1", -"#d c #d2d2d2", -"#e c #ececec", -"#f c #f5f5f5", -"#g c #111111", -"#h c #363636", -"#i c #7f7f7f", -"#j c #e6e6e6", -"#k c #e2e2e2", -"#l c #e1e1e1", -"#m c #f4f4f4", -"#n c #cfcfcf", -"#o c #cdcdcd", -"#p c #d5d5d5", -"#q c #1c1c1c", -"#r c #101010", -"#s c #919191", -"#t c #666666", -"#u c #dfdfdf", -"#v c #dddddd", -"#w c #2e2e2e", -"#x c #dbdbdb", -"#y c #cecece", -"#z c #cccccc", -"#A c #c8c8c8", -"#B c #c6c6c6", -"#C c #c3c3c3", -"#D c #a3a3a3", -"#E c #1f1f1f", -"#F c #212121", -"#G c #a1a1a1", -"#H c #272727", -"#I c #565656", -"#J c #4e4e4e", -"#K c #b2b2b2", -"#L c #dedede", -"#M c #5d5d5d", -"#N c #6a6a6a", -"#O c #dadada", -"#P c #d0d0d0", -"#Q c #cbcbcb", -"#R c #c9c9c9", -"#S c #c4c4c4", -"#T c #c2c2c2", -"#U c #c1c1c1", -"#V c #373737", -"#W c #0f0f0f", -"#X c #969696", -"#Y c #d7d7d7", -"#Z c #d8d8d8", -"#0 c #d6d6d6", -"#1 c #d4d4d4", -"#2 c #bdbdbd", -"#3 c #494949", -"#4 c #181818", -"#5 c #343434", -"#6 c #dcdcdc", -"#7 c #bebebe", -"#8 c #bcbcbc", -"#9 c #0e0e0e", -"a. c #c0c0c0", -"a# c #bbbbbb", -"aa c #b8b8b8", -"ab c #414141", -"ac c #b6b6b6", -"ad c #f8f8f8", -"ae c #b9b9b9", -"af c #b7b7b7", -"ag c #b5b5b5", -"ah c #3d3d3d", -"ai c #404040", -"aj c #7b7b7b", -"ak c #b4b4b4", -"al c #afafaf", -"am c #444444", -"an c #161616", -"ao c #4b4b4b", -"ap c #b3b3b3", -"aq c #b1b1b1", -"ar c #adadad", -"as c #ababab", -"at c #8f8f8f", -"au c #b0b0b0", -"av c #aeaeae", -"aw c #acacac", -"ax c #a9a9a9", -"ay c #a6a6a6", -"az c #a4a4a4", -"aA c #9d9d9d", -"aB c #9b9b9b", -"aC c #a8a8a8", -"aD c #a5a5a5", -"aE c #9e9e9e", -"aF c #9c9c9c", -"aG c #9a9a9a", -"aH c #989898", -"aI c #383838", -"aJ c #8c8c8c", -"aK c #959595", -"aL c #939393", -"aM c #6d6d6d", -"aN c #a2a2a2", -"aO c #999999", -"aP c #979797", -"aQ c #949494", -"aR c #929292", -"aS c #909090", -"aT c #8d8d8d", -"aU c #292929", -"aV c #858585", -"aW c #3f3f3f", -"aX c #474747", -"aY c #868686", -"aZ c #525252", -"a0 c #2c2c2c", -"a1 c #7a7a7a", -"a2 c #4c4c4c", -"a3 c #585858", -"a4 c #686868", -"a5 c #7e7e7e", -"a6 c #898989", -"a7 c #717171", -"a8 c #3a3a3a", -"a9 c #515151", -"b. c #5a5a5a", -"b# c #424242", -"ba c #818181", -"bb c #050505", -"bc c #797979", -"bd c #505050", -"be c #747474", -"bf c #808080", -"bg c #7c7c7c", -"bh c #2a2a2a", -"bi c #4a4a4a", -"bj c #fafafa", -"bk c #1b1b1b", -"bl c #767676", -"bm c #737373", -"bn c #262626", -"bo c #f1f1f1", -"bp c #0d0d0d", -"bq c #0b0b0b", -"br c #787878", -"bs c #757575", -"bt c #6f6f6f", -"bu c #434343", -"bv c #3b3b3b", -"bw c #5e5e5e", -"bx c #696969", -"by c #252525", -"bz c #5f5f5f", -"bA c #575757", -"bB c #282828", -"bC c #010101", -"bD c #6b6b6b", -"bE c #676767", -"bF c #646464", -"bG c #636363", -"bH c #616161", -"bI c #000000", -"bJ c #5b5b5b", -"bK c #464646", -"bL c #656565", -"bM c #595959", -"bN c #3c3c3c", -"bO c #606060", -"bP c #555555", -"bQ c #545454", -"bR c #626262", -"bS c #535353", -"bT c #7d7d7d", -"bU c #313131", -/* pixels */ -"................................................", -"..................aB.I.l.#.a.a.IaB..............", -".................l.n.i.m.n.i.i.i.i#t............", -"...............p.i.i#N.i.i.i.i.n.n.a............", -"...........H.0.z.iab.M.Gab.i.n.i.i#t............", -".......W.M.0.H.l.i#N.H.3.0#N.i.i.i.m.r...r......", -"......#K#X.H.4...p...3.G.J.I.i.i.i.i.6ab.z.r....", -"......#N.m.4.3.3.G.G.J.J.W.z.i.i.i.n.i.i.i.I....", -".....J.6.r.4.3.G.G.J.W.W#K#X.n.6#t.i.i.i.i.n.#..", -"..#K.0.0.0.3.G.J.J.W.W#Kzzzz.#.H.#.n.i.i.i.i#t..", -"...G.H.3.3.G.J.J.W.W#Kzzzz.r.raB#X.6.i.i.i.aaB..", -"...4.3.G.G.J.J.W#K#Kzzzz.r.raB#X#X#i.n.i.n#i....", -"..#X.r.G.J.J#K.W#K.raB.r.raB#X.#.#.c.a.n.i.6....", -"..aB.p.r.J.W#K#KaB.p.m#NaB#X.#.#.c.l.z.i.i.m....", -"....aBaB.W#K#Kzz#t.n.i.h.#.#.#.c#iab.i.i.i.i#g.I", -"....#K#K#Kzzzz.r.a.z.a.i#X.c.c#i.l.a.i.i.i.i.i.6", -"...W.Hzzzz.r.raB.a.I.m.i.l.##i.l.l.I.i.i.i.n.h#t", -"...J.Gzz.r.raB#X#tab#t.i.Izz.l#N#N#N.a.p.n.h.6#t", -".....3.r.raB#X#X#N.p.p#g.m#K.l#N#N#t.I.I.h.6ab.l", -".....3aBaB#X#X.#.c.c.i.i#t.r#N#t#t.I.6.6ababab..", -".....3.#.c.#.c.c.czz.l.p.J.l#t.I.I.I.6.6.pab....", -"....#X.a.p#N.c#i#i#i#K.G.c#t.I.I.6.6abab.n.p....", -"..........#t#i#i.l#N#N#t.I.I.I.6.6ab.m.z.i.naB..", -"...........J.l#N#N#N#t.I.I.6.6.a.a.h.i.i.i#i....", -"........#K.r.l#N#N#t.I.I.6.6.aabab.h.i.i.a......", -"..........#N#t#t#t.I.I.6.6.aabab.p.p.z.p.r......", -"...........rab.6.m.p.6.6.aab.p.p.h.h.p.r........", -".............r.I.c.c.p.aab.h.n.n.h.h#X..........", -"..................aB.mab.p.p.i.i.z.#............", -"...................r.z.m.m.mab#N................" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/gear-simple.xpm --- a/etc/vm/gear-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 9 1", -/* colors */ -"` c #7F7F7F", -"a c #393939", -"b c #111111", -"c c #AAAAAA s background", -"C c #AAAAAA", -"d c #969696", -"e c #5C5C5C", -"f c #F9F9F9", -"g c #D3D3D3", -/* pixels */ -"cccccccccccccccccccccccc", -"cccccccccde`deeedccccccc", -"cccccccc`bbabbbbbecccccc", -"cccccccabbebbbbbbecccccc", -"cccccffbbafgabbbbecccccc", -"ccccfff`befgfebbbacccccc", -"ccccdfgCaCgggebbbbeabccc", -"ccceagggggggCbbbbbbbbecc", -"ccgeCgggggCCCdbeebbbbbdc", -"ccfffggggCCCCCdfdbbbbbec", -"cgfgggggCCCCCCCddebbbedc", -"cggggggCCCCCCCddd`bbb`cc", -"cdCgggCCCCdCCdddd`ebbecc", -"cdaCgCCCdaaedddd``bbbacc", -"ccddCCCCebbaddd``abbbbbe", -"ccCCCCCCebebd````ebbbbbe", -"ccfCCCCdeeab`d```ebbbbae", -"cggCCCddeaebec`eeeeabaee", -"ccgCCdddeaabac`eeeeeaea`", -"ccgddddd``bbeCeeeeeeaaac", -"ccgd`d```C`ag`eeeeeeaacc", -"ccdeae````Cg`eeeeeaabacc", -"ccccce```eeeeeeeeaabbbdc", -"cccccg`eeeeeeeeeeabbb`cc", -"cccccc`eeeeeeeeaaabbeccc", -"ccccceeeeeeeeeaaaabacccc", -"ccccccaeaaeeeaaaaaaccccc", -"ccccccce``aeaabbaadccccc", -"cccccccccdaaaabbbdcccccc", -"ccccccccccbaaaaecccccccc" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/getmail-dn.xbm --- a/etc/vm/getmail-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define getmail-dn_width 64 -#define getmail-dn_height 42 -static char getmail-dn_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xf0,0xff,0xff,0xff, - 0xff,0xff,0xff,0x9f,0xc3,0xff,0xff,0xff,0xff,0xff,0xff,0x8f,0x0f,0xff,0xff, - 0xff,0xff,0xff,0xff,0x4f,0x3d,0xfc,0xff,0xff,0xff,0xff,0xff,0x07,0xea,0xf0, - 0xff,0xff,0xff,0xff,0xff,0x07,0xd0,0xc3,0xff,0xff,0xff,0xff,0xff,0x13,0xa0, - 0x0e,0xff,0xff,0xff,0xff,0xff,0xab,0x00,0x3d,0xfc,0xff,0xff,0xff,0xff,0x53, - 0x05,0x2a,0xf9,0xff,0xff,0xff,0xff,0xfb,0x0a,0x90,0xf2,0xff,0xff,0xff,0xff, - 0x1b,0x57,0x40,0xf5,0xff,0xff,0xff,0xff,0x1b,0xac,0xaa,0xe8,0xff,0xff,0xff, - 0xff,0x1b,0x70,0x55,0xe0,0xff,0xff,0xff,0xff,0x1b,0xc0,0x22,0xe3,0xff,0xff, - 0xff,0xff,0x1b,0x02,0x55,0xe0,0xff,0xff,0xff,0xff,0x1b,0x0e,0xa4,0xe0,0xff, - 0xff,0xff,0xff,0x33,0x3e,0x56,0xe1,0xff,0xff,0xff,0xff,0xcf,0xff,0xa6,0xea, - 0xff,0xff,0xff,0xff,0x3f,0xff,0x57,0xe5,0xff,0xff,0xff,0xff,0xff,0xfc,0xa7, - 0xea,0xff,0xff,0xff,0xff,0xff,0xf1,0x57,0xe5,0xff,0xff,0xff,0xff,0xff,0xcf, - 0xa7,0xf8,0xff,0xff,0xff,0xff,0xff,0x1f,0x57,0xfe,0xff,0xff,0xff,0xff,0xff, - 0x7f,0x84,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe1,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xfd,0xff,0xff,0xff,0xff,0xff,0x83,0xff,0xf9,0xf3,0xf9,0x27,0xff, - 0xff,0x39,0xff,0xf9,0xf3,0xf9,0x3f,0xff,0xff,0xfc,0xc3,0xf0,0xe3,0x18,0x26, - 0xff,0xff,0xfc,0x99,0xf9,0xe3,0xc8,0x24,0xff,0xff,0x0c,0x99,0xf9,0x43,0xf8, - 0x24,0xff,0xff,0x3c,0x81,0xf9,0x53,0x19,0x24,0xff,0xff,0x3c,0xf9,0xf9,0x13, - 0xc9,0x24,0xff,0xff,0x39,0x99,0xe9,0xb3,0xc9,0x24,0xff,0xff,0x43,0xc3,0xf3, - 0xb3,0x19,0x21,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/getmail-dn.xpm --- a/etc/vm/getmail-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * getmail-up_xpm[] = { -"64 42 6 1", -" c gray75 s backgroundToolBarColor", -"@ c #C0C0C0C0C0C0", -". c gray60", -"X c #808080808080", -"o c #FFFFFFFFFFFF", -"O c gray60", -" ", -" ..... ", -" ..@@@XX.. ", -" .Xo@@@@@XX.. ", -" .o@o@o@@@@XX.. ", -" .ooooo@o@o@@@XX.. ", -" .oooooooo@o@@@@XX.. ", -" .o@oooooooo@o@o@@@XX.. ", -" .@o@o@oooooooo@o@@@@XX.. ", -" .o@o@o@o@oooooo@o@o@..@X. ", -" .@@@@@o@o@oooooooo@.X@X@X. ", -" .@@..X@@@o@o@ooooo.X@X@X@. ", -" .@@.O..X@@o@o@o@o@.@X@..X@. ", -" .@@.OO...X@@@o@o@.@X@.XX.X. ", -" .@@.OO.....X@@o@o.X@X.@@X.. ", -" .@@.OO.@X....X@o@.@X@X.oX.. ", -" .@@..O.@@@X....X@.X@X@.oX.. ", -" ..@@X..@@@@@X..@@.@X@X@..X. ", -" ..@@@@@@@@@@X@@.X@X@X@X@. ", -" ..@@@@@@@@@@@.@X@X@X@X. ", -" ..@@@@@@@@@.X@X@X@X@. ", -" ...@@@@@@@.@X@X@X@.. ", -" ..@@@@@.X@X@X.. ", -" ...@@@.@X@.. ", -" X..@.X.. ", -" .... ", -" ", -" ", -" . ", -" ..... .. .. .. .. .. ", -" .. .. .. .. .. .. ", -" .. .... .... ... ... .... .. .. ", -" .. .. .. .. ... ... .. .. .. .. ", -" .. .... .. .. .. .... .... .. .. .. ", -" .. .. ...... .. .. . . .. ..... .. .. ", -" .. .. .. .. .. ... .. .. .. .. .. ", -" .. .. .. .. .. . .. . .. .. .. .. .. ", -" .... . .... .. .. . .. ... .... .. ", -" ", -" ", -" ", -" "}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/getmail-up.xbm --- a/etc/vm/getmail-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define getmail-up_width 64 -#define getmail-up_height 42 -static char getmail-up_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x0f,0x00,0x00,0x00, - 0x00,0x00,0x00,0x60,0x3c,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0xf0,0x00,0x00, - 0x00,0x00,0x00,0x00,0xb0,0xc2,0x03,0x00,0x00,0x00,0x00,0x00,0xf8,0x15,0x0f, - 0x00,0x00,0x00,0x00,0x00,0xf8,0x2f,0x3c,0x00,0x00,0x00,0x00,0x00,0xec,0x5f, - 0xf1,0x00,0x00,0x00,0x00,0x00,0x54,0xff,0xc2,0x03,0x00,0x00,0x00,0x00,0xac, - 0xfa,0xd5,0x06,0x00,0x00,0x00,0x00,0x04,0xf5,0x6f,0x0d,0x00,0x00,0x00,0x00, - 0xe4,0xa8,0xbf,0x0a,0x00,0x00,0x00,0x00,0xe4,0x53,0x55,0x17,0x00,0x00,0x00, - 0x00,0xe4,0x8f,0xaa,0x1f,0x00,0x00,0x00,0x00,0xe4,0x3f,0xdd,0x1c,0x00,0x00, - 0x00,0x00,0xe4,0xfd,0xaa,0x1f,0x00,0x00,0x00,0x00,0xe4,0xf1,0x5b,0x1f,0x00, - 0x00,0x00,0x00,0xcc,0xc1,0xa9,0x1e,0x00,0x00,0x00,0x00,0x30,0x00,0x59,0x15, - 0x00,0x00,0x00,0x00,0xc0,0x00,0xa8,0x1a,0x00,0x00,0x00,0x00,0x00,0x03,0x58, - 0x15,0x00,0x00,0x00,0x00,0x00,0x0e,0xa8,0x1a,0x00,0x00,0x00,0x00,0x00,0x30, - 0x58,0x07,0x00,0x00,0x00,0x00,0x00,0xe0,0xa8,0x01,0x00,0x00,0x00,0x00,0x00, - 0x80,0x7b,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x1e,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x02,0x00,0x00,0x00,0x00,0x00,0x7c,0x00,0x06,0x0c,0x06,0xd8,0x00, - 0x00,0xc6,0x00,0x06,0x0c,0x06,0xc0,0x00,0x00,0x03,0x3c,0x0f,0x1c,0xe7,0xd9, - 0x00,0x00,0x03,0x66,0x06,0x1c,0x37,0xdb,0x00,0x00,0xf3,0x66,0x06,0xbc,0x07, - 0xdb,0x00,0x00,0xc3,0x7e,0x06,0xac,0xe6,0xdb,0x00,0x00,0xc3,0x06,0x06,0xec, - 0x36,0xdb,0x00,0x00,0xc6,0x66,0x16,0x4c,0x36,0xdb,0x00,0x00,0xbc,0x3c,0x0c, - 0x4c,0xe6,0xde,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/getmail-up.xpm --- a/etc/vm/getmail-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * getmail-up_xpm[] = { -"64 42 6 1", -" c #C3C3C3C3C3C3 s backgroundToolBarColor", -"@ c #C0C0C0C0C0C0", -". c #000000000000", -"X c #808080808080", -"o c #FFFFFFFFFFFF", -"O c #FFFF00000000", -" ", -" ..... ", -" ..@@@XX.. ", -" .Xo@@@@@XX.. ", -" .o@o@o@@@@XX.. ", -" .ooooo@o@o@@@XX.. ", -" .oooooooo@o@@@@XX.. ", -" .o@oooooooo@o@o@@@XX.. ", -" .@o@o@oooooooo@o@@@@XX.. ", -" .o@o@o@o@oooooo@o@o@..@X. ", -" .@@@@@o@o@oooooooo@.X@X@X. ", -" .@@..X@@@o@o@ooooo.X@X@X@. ", -" .@@.O..X@@o@o@o@o@.@X@..X@. ", -" .@@.OO...X@@@o@o@.@X@.XX.X. ", -" .@@.OO.....X@@o@o.X@X.@@X.. ", -" .@@.OO.@X....X@o@.@X@X.oX.. ", -" .@@..O.@@@X....X@.X@X@.oX.. ", -" ..@@X..@@@@@X..@@.@X@X@..X. ", -" ..@@@@@@@@@@X@@.X@X@X@X@. ", -" ..@@@@@@@@@@@.@X@X@X@X. ", -" ..@@@@@@@@@.X@X@X@X@. ", -" ...@@@@@@@.@X@X@X@.. ", -" ..@@@@@.X@X@X.. ", -" ...@@@.@X@.. ", -" X..@.X.. ", -" .... ", -" ", -" ", -" . ", -" ..... .. .. .. .. .. ", -" .. .. .. .. .. .. ", -" .. .... .... ... ... .... .. .. ", -" .. .. .. .. ... ... .. .. .. .. ", -" .. .... .. .. .. .... .... .. .. .. ", -" .. .. ...... .. .. . . .. ..... .. .. ", -" .. .. .. .. .. ... .. .. .. .. .. ", -" .. .. .. .. .. . .. . .. .. .. .. .. ", -" .... . .... .. .. . .. ... .... .. ", -" ", -" ", -" ", -" "}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/getmail-xx.xbm Binary file etc/vm/getmail-xx.xbm has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/help-dn.xbm --- a/etc/vm/help-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0xf8,0xff,0xff, - 0xff,0xff,0xff,0x7f,0x00,0xc0,0xff,0xff,0xff,0xff,0xff,0x3f,0x00,0x00,0xbe, - 0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x7c,0xeb,0xff,0xff,0xdf,0x07,0x48,0x12, - 0x38,0xe0,0xff,0xff,0xd4,0x83,0x00,0x80,0x70,0xe0,0xff,0xff,0xc0,0x01,0x02, - 0x00,0x00,0xc0,0xff,0xff,0x01,0x08,0x90,0x24,0x04,0xc9,0xff,0xff,0x03,0x40, - 0x00,0x00,0x00,0xe0,0xff,0xff,0x0b,0x00,0x02,0x80,0x90,0xe1,0xff,0xff,0x63, - 0x12,0x40,0x12,0x02,0xc1,0xff,0xff,0x23,0x80,0x08,0x00,0x00,0xc1,0xff,0xff, - 0xb3,0x00,0x00,0x40,0x40,0x80,0xff,0xff,0x03,0x10,0x22,0x09,0x02,0x12,0xfe, - 0xff,0x01,0x40,0x00,0x00,0x00,0x00,0xff,0xff,0x01,0x01,0x08,0x40,0x80,0xff, - 0xff,0xff,0xff,0x00,0x81,0x04,0x90,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0xc0, - 0xff,0xff,0xff,0xff,0x05,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0x03,0x50,0x05, - 0xf0,0xff,0xff,0xff,0xff,0x07,0xe0,0x0c,0xf8,0xff,0xff,0xff,0xff,0x0f,0x80, - 0x35,0xfe,0xff,0xff,0xff,0xff,0x7f,0x00,0xad,0xff,0xff,0xff,0xff,0xff,0xff, - 0x81,0x56,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xba,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xad,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe5,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xc3,0xff,0x9f,0x7c,0xf0,0xff,0xf3,0xe7,0x93,0xff,0xbf,0x7c,0xe6,0xff,0xff, - 0xe7,0x33,0x63,0xd9,0x78,0x66,0x2c,0x33,0xe6,0x33,0x49,0xf2,0x7c,0xa6,0x49, - 0x92,0xe6,0x33,0x49,0xf2,0x7c,0x70,0x48,0x92,0xe7,0x33,0x49,0xf2,0x7c,0x3e, - 0x49,0x92,0xe7,0x93,0x49,0xf2,0x7c,0x3e,0x49,0x92,0xfe,0xc3,0x63,0xf2,0x79, - 0x7e,0x42,0x32,0xe6,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/help-dn.xpm --- a/etc/vm/help-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * help3_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"i c Gray60", -"@ c white", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXiiiiiiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXiiii@@@@@@@@iiiXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXi@@@@@@@@@@@@@@@iiiXXXXXiXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXii@@@@@@@@@@@@@@@@@@@iXXXXX@XX@XiXXXXXXXXXXX", -"XXXXXXXXXXXXXiXXXXXi@@@@@@@@@@@@@@@@@@@@@@iXXXi@@ii@@XXXXXXXXXXX", -"XXXXXXXXiiXiXiXXXXi@@@@@@@@@@@@@@@@@@@@@@@@iXXXi@@@@iXXXXXXXXXXX", -"XXXXXXXXi@@@@iXXXi@@@@@@@@@@@@@@@@@@@@@@@@@@iii@@@@@@iXXXXXXXXXX", -"XXXXXXXXXi@@@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@i@@@@@@@iXXXXXXXXXX", -"XXXXXXXXXX@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iiii@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXXi@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@iXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@ii@@@@iii@@iXXXXXXXXX", -"XXXXXXXXXXi@iii@@@oo@@@@@@@@@@@@@@@@@@@@@@oooi@@@@@@@@@@iXXXXXXX", -"XXXXXXXXXi@@@@@@@@oo@@@@@@@@@@@@@@@@@@@@@ooo@@@iiiiiiiiiXXXXXXXX", -"XXXXXXXXXiiiiiii@@@ooi@@@@@@@@@@@@@@@@@ioooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@ioooi@@@@@@@@@@@i@@oooooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@@ooooooi@i@@@@iioooooooi@@iXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXi@@iooooooooooooooooooooi@@iXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXii@@ioooi@@@@i@@@oooooi@@iXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXi@@@iioooi@@@i@@@oo@@@iiXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXiii@@@iiio@@@i@@@@iiiXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXii@@@@@i@@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXiiiiiX@@@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXi@@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXi@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXi@@@iiXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXooooXXXXXXXXXXXXXXXooXooXXXXXoooooXXXXXXXXXXXXXXooXXXXXXXooXXX", -"XXooXooXXXXXXXXXXXXXXXoXooXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXooXXX", -"XXooXXooXXoooXXoXooXXoXXoooXXXXooXXooXXoooXXoXooXXooXXoooXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXooXoXXooXooXooXooXooXoXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXoooooXXXooooXooXooXooXooXXXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXXXXooXXX", -"XXooXooXXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXoXXXXXXX", -"XXooooXXXXoooXXooXooXXXXXooXXXXooXXXXXXooXooooXooXooXXoooXXooXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/help-up.xbm --- a/etc/vm/help-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0x07,0x00,0x00, - 0x00,0x00,0x00,0x80,0x07,0x38,0x00,0x00,0x00,0x00,0x00,0x40,0x00,0xc0,0x41, - 0x00,0x00,0x00,0x00,0x30,0x00,0x00,0x02,0x10,0x00,0x00,0x20,0x08,0x48,0x12, - 0x44,0x06,0x00,0x00,0x2b,0x84,0x00,0x80,0x88,0x10,0x00,0x00,0x21,0x02,0x02, - 0x00,0x70,0x20,0x00,0x00,0xc2,0x09,0x90,0x24,0x24,0x29,0x00,0x00,0x00,0x40, - 0x00,0x00,0xc0,0x13,0x00,0x00,0xec,0x00,0x02,0x80,0x50,0x12,0x00,0x00,0x84, - 0x12,0x40,0x12,0x82,0x22,0x00,0x00,0x54,0x80,0x08,0x00,0x80,0x22,0x00,0x00, - 0xc4,0x00,0x00,0x40,0x58,0x4e,0x00,0x00,0x74,0x1c,0x22,0x09,0x3e,0x12,0x01, - 0x00,0x02,0x4c,0x00,0x00,0x8e,0xff,0x00,0x00,0xfe,0x39,0x08,0xc0,0x4f,0x00, - 0x00,0x00,0x00,0xf9,0x81,0xcc,0x5f,0x00,0x00,0x00,0x00,0xf1,0x17,0xfe,0x27, - 0x00,0x00,0x00,0x00,0xf6,0xff,0xff,0x13,0x00,0x00,0x00,0x00,0xcc,0xff,0xff, - 0x09,0x00,0x00,0x00,0x00,0x88,0xff,0x3d,0x06,0x00,0x00,0x00,0x00,0x70,0xbc, - 0xf7,0x01,0x00,0x00,0x00,0x00,0x80,0x41,0x6d,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfe,0xd6,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x7a,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x6d,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x1d,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x3c,0x00,0x60,0x83,0x0f,0x00,0x0c,0x18,0x6c,0x00,0x40,0x83,0x19,0x00,0x00, - 0x18,0xcc,0x9c,0x26,0x87,0x99,0xd3,0xcc,0x19,0xcc,0xb6,0x0d,0x83,0x59,0xb6, - 0x6d,0x19,0xcc,0xb6,0x0d,0x83,0x8f,0xb7,0x6d,0x18,0xcc,0xb6,0x0d,0x83,0xc1, - 0xb6,0x6d,0x18,0x6c,0xb6,0x0d,0x83,0xc1,0xb6,0x6d,0x01,0x3c,0x9c,0x0d,0x86, - 0x81,0xbd,0xcd,0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/help-up.xpm --- a/etc/vm/help-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * help3_xpm[] = { -"64 42 6 1", -"X c Gray75 s backgroundToolBarColor", -"i c Gray20", -"@ c rgb:00/df/ff", -"T c red", -"t c pink", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXiiiiiiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXiiii@@@@@@@@iiiXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXi@@@@@@@@@@@@@@@iiiXXXXXiXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXii@@@@@@@@@@@@@@@@@@@iXXXXX@XX@XiXXXXXXXXXXX", -"XXXXXXXXXXXXXiXXXXXi@@@@@@@@@@@@@@@@@@@@@@iXXXi@@ii@@XXXXXXXXXXX", -"XXXXXXXXiiXiXiXXXXi@@@@@@@@@@@@@@@@@@@@@@@@iXXXi@@@@iXXXXXXXXXXX", -"XXXXXXXXi@@@@iXXXi@@@@@@@@@@@@@@@@@@@@@@@@@@iii@@@@@@iXXXXXXXXXX", -"XXXXXXXXXi@@@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@i@@@@@@@iXXXXXXXXXX", -"XXXXXXXXXX@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iiii@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXXi@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@iXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@ii@@@@iii@@iXXXXXXXXX", -"XXXXXXXXXXi@iii@@@oo@@@@@@@@@@@@@@@@@@@@@@oooi@@@@@@@@@@iXXXXXXX", -"XXXXXXXXXi@@@@@@@@oo@@@@@@@@@@@@@@@@@@@@@ooo@@@iiiiiiiiiXXXXXXXX", -"XXXXXXXXXiiiiiii@@@ooi@@@@@@@@@@@@@@@@@ioooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@ioooi@@@@@@@@@@@i@@oooooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@@ooooooi@i@@@@iioooooooi@@iXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXi@@iooooooooooooooooooooi@@iXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXii@@ioooiiTiTiTiToooooi@@iXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXi@@@iioooiTTTiTTToo@@@iiXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXiii@@@iiioTTTiTTTTiiiXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXii@@@@@iTTTTTTTiXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXiiiiiiTtTTTtTTiXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiTtTTTTTiXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiTtTTTTiXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiTTTiiXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXooooXXXXXXXXXXXXXXXooXooXXXXXoooooXXXXXXXXXXXXXXooXXXXXXXooXXX", -"XXooXooXXXXXXXXXXXXXXXoXooXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXooXXX", -"XXooXXooXXoooXXoXooXXoXXoooXXXXooXXooXXoooXXoXooXXooXXoooXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXooXoXXooXooXooXooXooXoXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXoooooXXXooooXooXooXooXooXXXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXXXXooXXX", -"XXooXooXXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXoXXXXXXX", -"XXooooXXXXoooXXooXooXXXXXooXXXXooXXXXXXooXooooXooXooXXoooXXooXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/help-xx.xbm --- a/etc/vm/help-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0x07,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x40,0x00,0xc0,0x41, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20,0x08,0x00,0x00, - 0x44,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x21,0x02,0x88, - 0x24,0x70,0x20,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20, - 0x01,0x00,0xc0,0x13,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x84, - 0x00,0x20,0x00,0x89,0x22,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x44,0x12,0x02,0x24,0x58,0x4e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x22,0x0c,0x80,0x00,0x8e,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0xf9,0x11,0xc8,0x4f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xf2,0xff,0xff,0x13,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x88,0xff,0xbf,0x06,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x41,0x7b,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x6e,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x1d,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x6c,0x00,0x40,0x83,0x19,0x00,0x00, - 0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xcc,0xb6,0x0d,0x83,0x59,0xb6, - 0x6d,0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xcc,0xb6,0x0d,0x83,0xc1, - 0xb6,0x6d,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3c,0x9c,0x0d,0x86, - 0x81,0xbd,0xcd,0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/message-colorful.xpm --- a/etc/vm/message-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -/* XPM */ -static char *message[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 25 1", -/* colors */ -". c #000000", -"# c #a4a579", -"a c #9f9c66", -"b c #918e5d", -"c c #817f53", -"d c #6d6b46", -"e c #5d5b3c", -"f c #49482f", -"g c #eae696", -"h c #373623", -"i c #d4d088", -"j c #c8c480", -"k c #0d0d08", -"l c #b4b173", -"m c #aaa76d s background", -"n c #888657", -"o c #76744c", -"p c #646240", -"q c #545236", -"r c #fffaa3", -"s c #efeb99", -"t c #dfdb8f", -"u c #bac384", -"v c #242317", -"w c #bfbc7a", -/* pixels */ -"mmmmmadpn#mmmmmmmmmmmmmm", -"mmmm#dnndec#mmmmmmmmmmmm", -"mmm#nuijwmbcocna#mmmmmmm", -"mmmnirrsuiijl#npecammmmm", -"mm#crrrrrrssuijwmbncon#m", -"mm#nndon#jsrrrrsguj#phom", -"mmmmmcodefhdwsrrrrshvhhm", -"mmmmmnwppeeqqqdnliafphhm", -"mmmm#lsrssboqdpoqhfnohpm", -"mmmmbugusguujw#odeeobhem", -"mmmmnrjtssujwwussiwawknm", -"mmmm#rrjumgurrrijajrbham", -"mmmbigjiuugjwwiggsrrfqmm", -"mmmnrrsrijajsssjm#srkc#m", -"mmmbrsijirsrsjjigsrjvnmm", -"mm#wrrrrrrrrrrrrgsrpfmmm", -"mmnssrrrrrrrrrrrrrrvdmmm", -"mmnriugugssrrrrrrriknmmm", -"mmmjgrrjwnligrrrrrbh#mmm", -"mbisssgssiuujjjjrrfqmmmm", -"mnrijijsssgjljusrgknmmmm", -"magurrgwbwlsrsjgrmhbmmmm", -"bjsiimjugiiijwurref#mmmm", -"psrrrrsjnujurrirrvdmmmmm", -"cpajrrrrrrsilugrjvnmmmmm", -"nfhkkfcmgrrrrrrrdh#mmmmm", -"mm#nphv..h#srrrrhpmmmmmm", -"mmmmmanofhkkho#wknmmmmmm", -"mmmmmmmmm#bdhv..hbmmmmmm", -"mmmmmmmmmmmm#ncedmmmmmmm" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/message-simple.xpm --- a/etc/vm/message-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #000000", -"a c #817F53", -"b c #FFFAA3", -"c c #545236", -"d c #BFBC7A", -"e c #AAA76D s background", -"f c #242317", -"g c #D4D088", -/* pixels */ -"eeeeeeacaeeeeeeeeeeeeeee", -"eeeeeaaaacaeeeeeeeeeeeee", -"eeeeadgddeaaaaaeeeeeeeee", -"eeeagbbbdggdeeaccaeeeeee", -"eeeabbbbbbbbdgddeaaaaaee", -"eeeaaaaaedbbbbbbbddecfae", -"eeeeeaaaccfadbbbbbbffffe", -"eeeeeadcccccccaaegeccffe", -"eeeeeebbbbaacacacfcaafce", -"eeeeadbdbbddddeaaccaafce", -"eeeeabdgbbdddddbbgded`ae", -"eeeeebbddebdbbbgdedbafee", -"eeeagbdgddbdddgbbbbbccee", -"eeeabbbbgdedbbbdeebb`aee", -"eeeabbgdgbbbbddgbbbdfaee", -"eeedbbbbbbbbbbbbbbbcceee", -"eeabbbbbbbbbbbbbbbbfaeee", -"eeabgdbdbbbbbbbbbbg`aeee", -"eeedbbbddaegbbbbbbafeeee", -"eagbbbbbbgddddddbbcceeee", -"eabgdgdbbbbdeddbbb`aeeee", -"eebdbbbdadebbbdbbefaeeee", -"adbggeddbgggdddbbcceeeee", -"cbbbbbbdadddbbgbbfaeeeee", -"acedbbbbbbbgedbbdfaeeeee", -"acf``caebbbbbbbbafeeeeee", -"eeeacff``febbbbbfceeeeee", -"eeeeeeaacf``faed`aeeeeee", -"eeeeeeeeeeaaff``faeeeeee", -"eeeeeeeeeeeeeaacaeeeeeee" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-colorful-dn.xpm --- a/etc/vm/mime-colorful-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,137 +0,0 @@ -/* XPM */ -static char *mime-colorful-dn[] = { -/* width height num_colors chars_per_pixel */ -" 64 42 88 2", -/* colors */ -".. c #878787", -".# c #818181", -".a c #7f7f7f", -".b c #939393", -".c c #969696", -".d c #979797", -".e c #9f9f9f", -".f c #a7a7a7", -".g c #a1a1a1", -".h c #a5a5a5", -".i c #aeaeae", -".j c #adadad", -".k c #959595", -".l c #9a9a9a", -".m c #939393", -".n c #868686", -".o c #828282", -".p c #8b8b8b", -".q c #a3a3a3", -".r c #838383", -".s c #8e8e8e", -".t c #a2a2a2", -".u c #7d7d7d", -".v c #7b7b7b", -".w c #797979", -".x c #767676", -".y c #757575", -".z c #757575", -".A c #777777", -".B c #727272", -".C c #6f6f6f", -".D c #6a6a6a", -".E c #636363", -".F c #6b6b6b", -".G c #8a8a8a", -".H c #8e8e8e", -".I c #676767", -".J c #6e6e6e", -".K c #7a7a7a", -".L c #626262", -".M c #7e7e7e", -".N c #8d8d8d", -".O c #565656", -".P c #505050", -".Q c #4d4d4d", -".R c #494949", -".S c #434343", -".T c #404040", -".U c #575757", -".V c #393939", -".W c #3d3d3d", -".X c #3f3f3f", -".Y c #4f4f4f", -".Z c #585858", -".0 c #5b5b5b", -".1 c #5a5a5a", -".2 c #858585", -".3 c #5e5e5e", -".4 c #4b4b4b", -".5 c #7b7b7b", -".6 c #3a3a3a", -".7 c #636363", -".8 c #444444", -".9 c #3c3c3c", -"#. c #353535", -"## c #515151", -"#a c #323232", -"#b c #6c6c6c", -"#c c #6a6a6a", -"#d c #6f6f6f", -"#e c #2a2a2a", -"#f c #666666", -"#g c #838383", -"#h c #2d2d2d", -"#i c #737373", -"#j c #8f8f8f", -"#k c #6c6c6c", -"#l c #a3a3a3", -"#m c #9f9f9f", -"#n c Gray60", -"#o c #969696", -"#p c #b0b0b0", -"#q c #ababab", -"#r c #9e9e9e", -"#s c #9a9a9a", -"#t c #8a8a8a", -"#u c Gray60", -"#v c #a7a7a7", -/* pixels */ -"...#.#.......a.a.#.....b.b.c.d.d.d.e.d.e.e.e.e.e.e.f.g.g.h.h.e.f.h.i.h.h.f.h.h.f.h.j.j.f.h.f.j.f.h.j.h.j.h.g.e.e.e.d.d.k.c.l.b.m", -".b.n...........o...p.b.b.b.b.c.d.d.e.c.d.e.e.e.d.g.e.e.e.g.l.g.e.e.g.g.e.g.q.f.h.h.h.g.h.h.h.j.i.h.h.h.h.e.e.e.e.l.e.c.d.e.c.m.c", -".r.r...#...........b.b.b.s.b.m.d.d.c.l.e.d.l.e.d.e.m.d.l.d.e.e.e.e.e.e.e.e.d.g.d.e.e.e.h.g.f.h.h.h.h.f.h.g.t.e.e.d.e.d.c.c.d.c.c", -".#.o.a.#.#.#...#.......p...b.b.b.m.k.d.b.d.d.m.b.b.d.d.b.b.b.m.k.d.d.d.d.d.b.m.k.d.d.d.d.g.g.g.e.e.g.e.g.e.e.d.d.d.d.d.b.k.b.b.d", -".s.......#.#.#...#.o.#.....#.....p.....p.......#.a.#.#.......#.............b.b.b...b.b.k.e.c.e.d.e.d.e.d.e.e.d.d.k.c.b.b.m.b.m.d", -".#.#.o.r.a.u.a.u.o.u.u.u.a.#.o.u.u.r.u.u.u.v.u.w.w.x.u.u.u.u.u.u.a.#.o.#.o.............s.s.b.k.k.k.b.k.b.m.b.b.s.......s...b.s.b", -"...a.u.u.w.u.u.y.w.z.z.u.u.u.z.u.w.z.y.z.z.u.z.z.z.z.z.y.u.w.u.z.#.a.u.#.a.#.#.#...#.....#...........p.b.b...#.o.o.a.o.o.#.s.s.s", -".a.w.z.u.w.z.w.w.w.z.A.u.z.z.z.B.z.z.A.z.A.z.A.y.z.C.A.z.z.y.w.w.w.a.o.a.#.#.o.a.o...o...#...#.#.#.#.r.#.#...o.a.a.o.u.a.o.o.#..", -".#.o.u.z.z.z.z.B.B.z.y.B.z.B.B.B.B.B.B.B.B.B.B.B.C.B.B.w.w.w.w.x.u.w.u.u.o...a...#.....#.#...n.#.#.#.n...#.#.o.#.#.....#.o.r.#.#", -".w.a.w.w.B.B.B.z.B.B.z.B.B.D.C.B.C.B.B.C.D.C.E.C.C.F.z.B.B.B.w.B.u.u.u.u.u.#.#.#.....G.......H...#.#.#.........#.....H..........", -".w.x.z.z.B.B.z.C.z.B.B.B.C.C.D.C.E.I.C.E.E.D.D.C.B.F.B.B.F.z.w.w.w.u.#.v.o.a...........G...G...b.s.H.s.H.....G.s.H...G.b.s......", -".w.x.z.B.B.z.A.z.B.B.B.F.C.B.F.E.C.E.E.C.E.F.E.B.J.B.B.B.w.w.w.w.w.o.u.#.o.#.#...n.#.....s...p.s.b...b.b...G.b...G.b...p.b...G..", -".w.w.w.x.B.#.B.w.B.F.B.B.F.D.B.D.B.D.D.I.F.E.C.D.B.B.F.z.z.z.B.w.z.w.o.K.u.#.o.w.o.n...#.G.....H.b...s.G.b.b.s.H.p.b.b.s...G...#", -".u.w.w.w.w.w.w.K.u.z.B.B.B.F.B.B.C.D.C.E.F.L.E.L.L.I.E.F.C.C.B.F.B.C.C.z.z.u.M.w.a.o.a.#.....H...s.G.b.b.N...b.....p...s.G.N...#", -".a.w.a.w.a.o.a.u.y.w.B.B.B.B.C.E.L.O.P.P.Q.R.S.S.T.Q.R.R.R.P.P.U.O.L.L.L.E.B.F.B.B.x.w.M.w.#.o.o.#.#.......s.....s.s.G...s......", -".#...o...o.r.a.#.u.u.B.C.F.E.P.U.R.V.P.R.V.W.T.V.V.X.S.S.T.Q.R.P.Y.Z.0.1.Z.1.L.1.E.L.B.B.B.x.w.w.o.2...#...G...#.n.s...G.....#..", -".....#...#.o.r.a.w.w.B.F.3.P.Z.4.R.R.Q.V.S.S.T.W.V.S.V.S.V.S.S.W.R.P.Z.U.L.0.0.L.0.U.L.E.F.C.z.w.a.5.#.#.o.#...#...n.o.#...o....", -".........#.o.a.o.x.x.C.O.Z.U.R.Y.R.R.R.W.W.S.S.W.W.V.6.6.W.S.W.W.R.S.W.R.S.R.P.Z.L.L.L.0.0.0.7.F.B.x.w.w.K.o.o.o.o...n.....n....", -".s.H.......o.a.w.x.F.U.Z.U.Y.P.R.Y.R.S.S.8.R.6.S.S.6.S.W.6.9.9.9.9#..9#..6.S.R.Y.U.Z.P##.L.L.0.L.0.F.F.B.x.x.M.o.5...n.n.o...G..", -".b.s.H...#.n.K.x.F.1.L.L.P.P.4.Y.R.8.Z.Y.L.Z.V.W.R.S.W#..9#.#..6.S.8.8.W.6.W.R.R.R.R.R.Z.L.L.F.L.L.U.0.F.F.M.w.M.o.n.2...o......", -".s.s...n.#.o.w.F.L.L.L.1.L.L.U.Z.Z.Z.Z.5.7.R.S.S.R.S.9#a.9#.#.#b#b#c.Z.R.W.S.S.Y.R.Y.R.Y.Y.U.7.L.L.F.L.E.F.F.M.M.w.M.o.n.....G.s", -".s.G.....o.K.M.1.F.F.E.F.L.L.Z#d.o.K.n.n.7.Z.Z.Y.S.W#a#e#a#e.6#d#d.5#b.R.8.S.Y#d.Z.R.R.R.8.Z.Z.U.7.F.B#d.C.B.x.A.#.o.a...G.H.b.k", -".s.N.G...o.5.B.F.C.C.3.F.F#f#d.n.K.o.n#g#c.Z.Z.Z.S.6#.#e#h#..8#d.5#g.5.Z.8.Y.U.5.5#c.Y.Y.Y.R.Y.L.L.F.F.B.x.F.A.x.5..#g.....b.k.k", -".H.s...n.o.w.C.F.B.C.C.F#f.M.o#g.n.n.H.G.5#d.U.Y.Y.6#.#a#.#..6#d#b.5#d.Z.Y.Z.7#g.n.5#d.Z.R.Y.Y.P.L.7.F.F.B.o.K.#.o.n...G.H.b.H.d", -".s.H.....#.w.B.B#i.F#d.B.o.n.n.H.H.n.H#j.5.Z.Z.Z.L.U.Z.Y.6#..W.7#d.7#d.Z.7.7#d.H#j.H.G.5.Z.U.4.Z.Z.L.L#k.A.w.5.o.....G.m.b.k.b.k", -".s.H...n.#.w.w.x.B.z.B.5.5.n#g.n.n.H#j.H#g#c.L.L#d#d#d.7.Y.R.W.Y.7#d.7.Y.Z#c.n#l#m.G#m.H.A.7.F.L.0.L.C.A.B.F.o.....G.b.H.k.d.d.g", -".k.H.....n.#.o.w#n#n#n#n#n.n.n.n.H#m.k#o.H.5#c#c#b#b#c#d#d#d#d.7#b#b#d#c#d#d#p#q#l#n#n.5.A.x.M.M.A.A#d.F#d.#.N.G.b.k.k.k.d.g.k.g", -".b.H.G...n.#.o.5#n#n.B.x#n#n.n.H.k#r.k.t.t.H#d#c#b#b#d#d#c.5#d#d#d#d#d#b#d#l#p.t#q#n#n.M.M.M.M.M.M.o.G.H.G.H.b.k.k.k.d.g#s.d.g#m", -".H.k.H.H...o.n#n#n.B.B.B#n#n.n.G#n#n#n#n.t#m#g#n#n#n#n#d#d#d#n#n#n#n#d#d#r#n#n#l#n#n.5.5#n#n#n#n.M.5.n.b.k.k.k.k.g.b#m.b.g.g.g.k", -".d#m.b.k.#.o.o#n#n.x.B.B#n#n.n#n#n.k#l#n#n#p#n#n#d#d#n#n#d#n#n#d#b#n#n.k#n#n#q#n#n#n.n#n#n.M.M#n.o.n.s.G.b.k.g.k.b#m.k.g.g#r.g.k", -".b.k.b.k...o#n#n.o.w.B.B#n#n#n#n.G.k#r#n#n#n#n#r.5.5#b#d#n#n#b#d#d#n#n#n#n#p#r.H#n#n#n#n.M.A#g#n.o.n.H.H.d#m.d.g.g.g.g.g.e.g.g.g", -".k.d.g.k.H.o#n#n.w.B.w#n#n.M#n#n#n#n#n#n#r#n#n#l.t#m.H#g#n#n.5.H#n#n#p#n#n#m.G#n#n#t#n#n#n#n#n#n.H.k.H.k.d.g#m.g.g.g.g.g.h.g.g.g", -".g.e.d.d.H.o#n#n.x.w.w#n#n#n#n.o#g.n.o#g#n#n.s#m#r#n#n#n#n#m#m#u#u#n#n#n#m.G#u#u#n#u#u.n#u#u.n.n.H.H.k#u#u.e#u#u#u#u#u.g.h.h.f.h", -".e.k.g.k.b#n#n.M.M.M#n#n.5#n#n.a.o#n#n.n#n#n.G.H#n#n.s#n#n.H.H#u#u#u#n#n.N#u#u#u#j#u#u.N#u#u#u.H.H.b#u#u#u.g#u#u.h.h.g#q.h#q.h.h", -".e#m.d.d.b#n#n#n#n#n#n.o.w.M#n#n#n#n.w.5.##n#n#n#n.H.H.G#n#n#n#u#u#u.G#n#n#u#u#u.H#u#u#n#u#u#u.k.k.H#u#u#u.g#u#u.g.h.h.h.h.i.h.g", -".d.g.g.k.d.k.p.s...#...n.5.5.#.5.M.A.M.#.5.o...5.n.G...n#g.G#g#u#u#u#u.n#u#u#u#u.k#u#u.b#u#u#u#u.g#u#u#u#u.h#u#u#u#u#u.h#v.f.f#q", -".g.g.g.g.d.d.b.G.H...G.....n.o.o.A.o.s.M.#.n.5.o.o.n.o#g.x.n.n#u#u.b#u.G#u.k#u#u.H#u#u.g#u#u.g#u.g#u.h#u#u.i#u#u.i.g.i.f.i.g.h.i", -".g.t.g.g.d.e.k.b.H.H.G.H.G.....5.o.n.o.5...5.G.o.n.....G.M.G..#u#u.d#u#u#u#m#u#u.k#u#u.g#u#u.g#u#u#u.h#u#u.h#u#u.h#q.f#q.h.i.h.j", -".t.h.h.g.g#r.d.d.H.s.H.b.H.H.G.G.......n.G...G.n.G.H.H.H.n.H.H#u#u.g#m#u.g#m#u#u#r#u#u#r#u#u.h#q#u#q.h#u#u.i#u#u#q.h#q.h.i#q.i.h", -".g.t.h.g.g.g.k.d.k.b.H.b.H.k.b.H.G.s.n.H.G.H.H.s.H.k.d.k.s.H.H#u#u#m#m#u#s#m#u#u#m#u#u#m#u#u#q.g#u.g#q#u#u.i#u#u#u#u#u#q.h.i.h#q", -".h.h#v.h.g.g.g#m.d.d.k.d.k.k.k.d.H.k.G.s.H.b.b.k.b.d.b.H.e#m.H.k.g#m#m.g#r.g.g#q.g.h#q.h#q.g#q.h#q#q.h.i.i.h.i.i.i.i.h.i.h.i.h.f", -".g.g.h.f.h.g.g.e.d.g.b.k.d.k.b.k.k.k.d.b.b.k.k.k.d.d.d.g.k.g.k.g#r.g.g.g.t.g.h#q#m.h#v#q.h#q.h#q#q#q.i#q.i.h.h#q.h.i.h.i.h.f.i.h" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-colorful-up.xpm --- a/etc/vm/mime-colorful-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,133 +0,0 @@ -/* XPM */ -static char * mime-fancy-up_xpm[] = { -"64 42 88 1", -" c #B8B878785050", -". c #B0B070705050", -"X c #B0B070704848", -"o c #C8C880806060", -"O c #C8C888885858", -"+ c #C8C888886060", -"@ c #D0D090906868", -"# c #D8D898987070", -"$ c #D0D090907070", -"% c #D0D098987070", -"& c #D8D8A0A08080", -"* c #D8D8A0A07878", -"= c #C0C088886060", -"- c #D0D088886060", -"; c #C0C088885858", -": c #B0B078785858", -"> c #B0B070705858", -", c #C0C078785858", -"< c #D0D098986868", -"1 c #B8B870705050", -"2 c #C0C080805050", -"3 c #C8C898987070", -"4 c #A8A870704848", -"5 c #B0B068684848", -"6 c #A8A868684848", -"7 c #A0A068684848", -"8 c #A8A860604848", -"9 c #A0A068684040", -"0 c #A0A068685050", -"q c #A0A060604848", -"w c #989860604848", -"e c #989858584040", -"r c #909050504040", -"t c #909060604040", -"y c #B8B878786060", -"u c #B8B880806060", -"i c #909058584040", -"p c #989860604040", -"a c #A0A070704848", -"s c #808058584040", -"d c #A8A870705050", -"f c #B8B880805858", -"g c #787848483838", -"h c #686848483838", -"j c #686840404040", -"k c #606040403838", -"l c #585838383838", -"z c #505038383838", -"x c #787848484040", -"c c #484830303838", -"v c #484838383838", -"b c #505038383030", -"n c #606048484040", -"m c #707050504040", -"M c #787850504040", -"N c #808048484040", -"B c #B0B078785050", -"V c #808050504040", -"C c #606040404040", -"Z c #A0A070705050", -"A c #404038383838", -"S c #808058584848", -"D c #505040403838", -"F c #484838383030", -"G c #404030303030", -"H c #686848484040", -"J c #383830303030", -"K c #808068685050", -"L c #888860604848", -"P c #888868685050", -"I c #303028282828", -"U c #888858584848", -"Y c #A8A878785858", -"T c #383828282828", -"R c #989868684848", -"E c #B8B880806868", -"W c #909060604848", -"Q c #C8C898987878", -"! c #C8C890907878", -"~ c #FFFFFFFFFFFF", -"^ c #C0C088886868", -"/ c #D0D0A8A88888", -"( c #D0D0A0A08080", -") c #C8C890907070", -"_ c #C8C888887070", -"` c #B0B080805858", -"' c #000000000000", -"] c #D0D098988080", -" .. XX. ooO+++@+@@@@@@#$$%%@#%&%%#%%#%**#%#*#%*%*%$@@@++=O-o;", -"o: > ,ooooO++@O+@@@+$@@@$-$@@$$@$<#%%%$%%%*&%%%%@@@@-@O+@O;O", -"11 . ooo2o;++O-@+-@+@;+-+@@@@@@@@+$+@@@%$#%%%%#%$3@@+@+OO+OO", -".>X... . , ooo;=+o++;oo++ooo;=+++++o;=++++$$$@@$@$@@+++++o=oo+", -"2 ... .>. . , , .X.. . ooo oo=@O@+@+@+@@++=Ooo;o;+", -"..>1X4X4>444X.>44144454667444444X.>.> 22o===o=o;oo2 2 o2o", -" X446448699444946989949999984649.X4.X... . . ,oo .>>X>>.222", -"X69469666904999q990909089w0998666X>X..>X> > . ....1.. >XX>4X>>. ", -".>49999qq98q9qqqqqqqqqqqwqq666674644> X . .. :...: ..>.. .>1..", -"6X66qqq9qq9qqewqwqqwewrwwt9qqq6q44444... y u ... . u ", -"6799qq9w9qqqwwewriwrreewqtqqt96664.5>X y y o2u2u y2u yo2 ", -"679qq909qqqtwqtrwrrwrtrqpqqq66666>4.>.. :. 2 ,2o oo yo yo ,o y ", -"6667q.q6qtqqteqeqeeitrweqqt999q696>a4.>6>: .y uo 2yoo2u,oo2 y .", -"4666666a49qqqtqqwewrtsrssirtwwqtqww994d6X>X. u 2yoof o , 2yf .", -"X6X6X>X486qqqqwrsghhjkllzjkkkhhxgsssrqtqq76d6.>>.. 2 22y 2 ", -". > >1X.44qwtrhxkchkcvzccbllzjkhnmMNmNsNrsqqq766>B . y .:2 y . ", -" . .>1X66qtVhmCkkjcllzvclclcllvkhmxsMMsMxsrtw96XZ..>. . :>. > ", -" .>X>77wgmxknkkkvvllvvcAAvlvvklvklkhmsssMMMStq766a>>>> : : ", -"2u >X67txmxnhknkllDkAllAlvAFFFFGFGAlknxmhHssMsMttq77d>Z ::> y ", -"o2u .:a7tNsshhCnkDmnsmcvklvGFGGAlDDvAvkkkkkmsstssxMttd6d>:B > ", -"22 :.>6tsssNssxmmmmZSkllklFJFGGKKLmkvllnknknnxSsstsrttdd6d>: y2", -"2y >adNttrtssmP>a::SmmnlvJIJIAPPZKkDlnPmkkkDmmxStqPwq70.>X yuo=", -"2fy >ZqtwwVttUP:a>:YLmmmlAGITGDPZYZmDnxZZLnnnknssttq7t07Z Y o==", -"u2 :>6wtqwwtUd>Y::uyZPxnnAGJGGAPKZPmnmSY:ZPmknnhsSttq>a.>: yuou+", -"2u .6qqRtPq>::uu:uEZmmmsxmnAGvSPSPmSSPuEuyZmxCmmssW06Z> y;o=o=", -"2u :.667q9qZZ:Y::uEuYLssPPPSnkvnSPSnmL:Q!y!u0StsMsw0qt> you=++$", -"=u :.>6~~~~~:::u!=^uZLLKKLPPPPSKKPLPP/(Q~~Z07dd00PtP.fyo===+$=$", -"ouy :.>Z~~q7~~:u=)=33uPLKKPPLZPPPPPKPQ/3(~~dddddd>yuyuo===+$_+$!", -"u=uu >:~~qqq~~:y~~~~3!Y~~~~PPP~~~~PP)~~Q~~ZZ~~~~dZ:o====$o!o$$$=", -"+!o=.>>~~7qq~~:~~=Q~~/~~PP~~P~~PK~~=~~(~~~:~~dd~>:2yo=$=o!=$$)$=", -"o=o= >~~>6qq~~~~y=)~~~~)ZZKP~~KPP~~~~/)u~~~~d0Y~>:uu+!+$$$$$@$$$", -"=+$=u>~~6q6~~d~~~~~~)~~Q3!uY~~Zu~~/~~!y~~`~~~~~~u=u=+$!$$$$$%$$$", -"$@++u>~~766~~~~>Y:>Y~~2!)~~~~!!''~~~!y''~'':''::uu=''@'''''$%%#%", -"@=$=o~~ddd~~Z~~X>~~:~~yu~~2~~uu'''~~f'''E''f'''uuo'''$''%%$(%(%%", -"@!++o~~~~~~>6d~~~~6Z.~~~~uuy~~~'''y~~'''u''~'''==u'''$''$%%%%&%$", -"+$$=+=,2 . :ZZ.Zd0d.Z> Z:y :YyY'''':''''=''o''''$''''%'''''%]##(", -"$$$$++oyu y :>>0>2d.:Z>>:>Y7::''o'y'=''u''$''$'$'%''&''&$&#&$%&", -"$3$$+@=ouuyuy Z>:>Z Zy>: ydy ''+'''!''=''$''$'''%''%''%(#(%&%*", -"3%%$$)++u2uouuyy :y y:yuuu:uu''$!'$!'')'')''%('(%''&''(%(%&(&%", -"$3%$$$=+=ouou=ouy2:uyuu2u=+=2uu''!!'_!''!''!''($'$(''&'''''(%&%(", -"%%]%$$$!++=+===+u=y2uoo=o+ou@!u=$!!$)$$($%(%($(%((%&&%&&&&%&%&%#", -"$$%#%$$@+$o=+=o===+oo===+++$=$=$)$$$3$%(!%](%(%(((&(&%%(%&%&%#&%"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-colorful-xx.xpm --- a/etc/vm/mime-colorful-xx.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,134 +0,0 @@ -/* XPM */ -static char * mime-fancy-up_xpm[] = { -"64 42 89 1", -" c #B8B878785050", -". c #B0B070705050", -"X c #B0B070704848", -"o c #C8C880806060", -"O c #C8C888885858", -"+ c #C8C888886060", -"@ c #D0D090906868", -"# c #D8D898987070", -"$ c #D0D090907070", -"% c #D0D098987070", -"& c #D8D8A0A08080", -"* c #D8D8A0A07878", -"= c #C0C088886060", -"- c #D0D088886060", -"; c #C0C088885858", -": c #B0B078785858", -"> c #B0B070705858", -", c #C0C078785858", -"< c #D0D098986868", -"1 c #B8B870705050", -"2 c #C0C080805050", -"3 c #C8C898987070", -"4 c #A8A870704848", -"5 c #B0B068684848", -"6 c #A8A868684848", -"7 c #A0A068684848", -"8 c #A8A860604848", -"9 c #A0A068684040", -"0 c #A0A068685050", -"q c #A0A060604848", -"w c #989860604848", -"e c #989858584040", -"r c #909050504040", -"t c #909060604040", -"y c #B8B878786060", -"u c #B8B880806060", -"i c #909058584040", -"p c #989860604040", -"a c #A0A070704848", -"s c #808058584040", -"d c #A8A870705050", -"f c #B8B880805858", -"g c #787848483838", -"h c #686848483838", -"j c #686840404040", -"k c #606040403838", -"l c #585838383838", -"z c #505038383838", -"x c #787848484040", -"c c #484830303838", -"v c #484838383838", -"b c #505038383030", -"n c #606048484040", -"m c #707050504040", -"M c #787850504040", -"N c #808048484040", -"B c #B0B078785050", -"V c #808050504040", -"C c #606040404040", -"Z c #A0A070705050", -"A c #404038383838", -"S c #808058584848", -"D c #505040403838", -"F c #484838383030", -"G c #404030303030", -"H c #686848484040", -"J c #383830303030", -"K c #808068685050", -"L c #888860604848", -"P c #888868685050", -"I c #303028282828", -"U c #888858584848", -"Y c #A8A878785858", -"T c #383828282828", -"R c #989868684848", -"E c #B8B880806868", -"W c #909060604848", -"Q c #C8C898987878", -"! c #C8C890907878", -"~ c Gray60", -"^ c #C0C088886868", -"/ c #D0D0A8A88888", -"( c #D0D0A0A08080", -") c #C8C890907070", -"_ c #C8C888887070", -"` c #B0B080805858", -"' c Gray60", -"] c #D0D098988080", -"[ c black s backgroundToolBarColor", -" [.[ [X[.[ [o[+[+[+[@[@[@[$[%[@[%[%[#[%[%[*[%[*[%[%[%[@[@[+[O[o[", -"[:[ [ [>[,[o[o[+[@[+[@[+[@[@[-[@[$[@[<[%[%[%[%[&[%[%[@[@[@[+[O[O", -"1[ [ [ [ [o[2[;[+[-[+[@[@[+[+[@[@[@[@[$[@[@[$[%[%[#[$[@[+[+[O[O[", -"[>[.[.[.[ [,[o[o[=[o[+[o[+[o[o[=[+[+[o[=[+[+[$[@[$[$[@[+[+[o[o[+", -"2[ [.[.[.[.[ [ [,[ [ [ [X[.[ [.[ [ [ [o[ [o[@[@[@[@[@[+[=[o[;[;[", -"[.[1[4[4[4[4[.[4[1[4[5[6[7[4[4[4[.[.[ [ [ [2[o[=[o[o[o[2[ [2[o[o", -" [4[6[4[6[9[4[9[6[8[9[9[9[9[4[4[.[4[X[.[ [ [.[ [ [,[o[.[>[>[.[2[", -"[6[4[9[6[9[4[9[q[9[9[9[8[w[9[8[6[X[X[.[X[ [ [ [.[.[.[ [X[>[X[>[ ", -".[4[9[9[q[8[9[q[q[q[q[q[w[q[6[6[4[4[>[X[.[ [.[:[.[:[.[>[.[ [>[.[", -"[X[6[q[9[q[q[e[q[q[w[w[w[t[q[q[q[4[4[.[.[ [ [ [ [.[ [ [.[ [ [ [ ", -"6[9[q[9[9[q[w[e[r[w[r[e[q[q[t[6[6[.[>[ [ [ [ [ [2[2[ [y[u[y[2[ [", -"[7[q[9[9[q[t[q[r[r[w[t[q[q[q[6[6[>[.[.[ [.[ [ [2[ [o[y[ [o[,[ [ ", -"6[6[q[q[q[q[t[q[q[e[t[w[q[t[9[q[9[>[4[>[>[ [y[ [o[2[o[2[,[o[ [ [", -"[6[6[6[a[9[q[t[q[e[r[s[s[i[t[w[t[w[9[4[6[>[.[ [ [y[o[ [ [,[2[f[.", -"X[X[X[X[8[q[q[w[s[h[j[l[z[k[k[h[g[s[r[t[q[6[6[>[.[ [ [ [2[y[2[ [", -"[ [ [1[.[4[w[r[x[c[k[v[c[b[l[j[h[m[N[N[N[s[q[7[6[B[.[y[.[2[y[ [ ", -" [.[.[1[6[q[V[m[k[j[l[z[c[c[c[l[k[m[s[M[M[s[t[9[X[.[>[ [ [>[ [ [", -"[ [ [>[>[7[g[x[n[k[v[l[v[c[A[l[v[l[k[k[m[s[M[M[t[7[6[>[>[ [ [:[ ", -"2[ [ [X[7[x[x[h[n[l[D[A[l[l[A[F[F[F[A[k[x[h[s[M[M[t[7[d[Z[:[>[y[", -"[2[ [:[7[N[s[h[n[D[n[m[v[l[G[G[A[D[v[v[k[k[m[s[s[x[t[d[d[:[ [ [ ", -"2[ [.[6[s[s[s[x[m[m[S[l[k[F[F[G[K[m[v[l[k[k[n[S[s[s[t[d[6[>[ [y[", -"[y[ [a[N[t[t[s[P[a[:[m[n[v[I[I[P[Z[k[l[P[k[k[m[x[t[P[q[0[>[ [u[=", -"2[y[>[q[w[V[t[P[a[:[L[m[l[G[T[D[Z[Z[D[x[Z[n[n[n[s[t[7[0[Z[Y[ [=[", -"[2[:[6[t[w[t[d[Y[:[y[P[n[A[J[G[P[Z[m[m[Y[Z[m[n[h[S[t[>[.[:[y[o[+", -"2[ [.[q[R[P[>[:[u[u[Z[m[s[m[A[v[P[P[S[P[E[y[m[C[m[s[0[Z[ [y[o[o[", -"[u[:[6[7[9[Z[:[:[u[u[L[s[P[S[k[n[P[n[L[Q[y[u[S[s[s[0[t[ [y[u[+[$", -"=[ [:[>[~[~[~[:[u[=[u[L[K[L[P[P[K[P[P[/[Q[~[0[d[0[P[P[f[o[=[+[=[", -"[u[ [.[Z[~[7[~[u[)[3[u[L[K[P[Z[P[P[K[Q[3[~[d[d[d[>[u[u[=[=[$[+[!", -"u[u[ [:[~[q[~[:[~[~[3[Y[~[~[P[~[~[P[)[~[~[Z[~[~[d[:[=[=[$[![$[$[", -"[![=[>[~[7[q[~[~[=[~[/[~[P[~[~[P[~[=[~[~[~[~[d[~[:[y[=[=[![$[)[=", -"o[o[ [~[>[q[~[~[y[)[~[~[Z[K[~[K[P[~[~[)[~[~[d[Y[>[u[+[+[$[$[@[$[", -"[+[=[>[~[q[~[d[~[~[~[~[Q[![Y[~[u[~[~[![~[`[~[~[~[=[=[$[$[$[$[$[$", -"$[+[u[~[7[6[~[~[Y[>[~[2[)[~[~[!['[~[!['[~['['[:[u[=['['['['[%[#[", -"[=[=[~[d[d[~[~[X[~[:[~[u[~[~[u['['[~['['['[f['[u[o['[$['[%[([([%", -"@[+[o[~[~[~[6[~[~[6[.[~[~[u[~[~['[y[~['[u['['['[=['['['[$[%[%[%[", -"[$[=[=[2[.[:[Z[Z[0[.[>[Z[y[:[y['['[:['['['[o['['['['[%['['[%[#[(", -"$[$[+[o[u[y[ [>[0[2[.[Z[>[>[7[:['['['['[u['['[$[$[%['['[&[&[&[%[", -"[3[$[@[o[u[u[ [Z[:[Z[Z[>[ [y[y['[+['[!['['[$['['['['[%['[([([&[*", -"3[%[$[+[u[u[u[y[ [ [y[y[y[u[:[u['[![$['[)['['[%['[%['['[([([&[&[", -"[3[$[$[+[o[o[=[u[2[u[u[2[=[=[u['[!['[!['['[!['[$[$['[&['['[([&[(", -"%[][$[$[+[=[=[=[u[y[u[o[o[o[@[u[$[![)[$[$[([([([([%[&[&[&[%[%[%[", -"[$[#[$[@[$[=[=[=[=[o[=[=[+[$[$[$[$[$[$[([%[([([([([([%[([&[&[#[%"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-dn.xbm --- a/etc/vm/mime-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define e_width 64 -#define e_height 42 -static char e_bits[] = { - 0x39,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xf7,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x42,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x8f,0xda,0x7f,0xb8,0xff,0xff,0xff,0xff,0x0c,0x41,0x02,0x00,0xf4, - 0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0xed,0xbf,0xed,0x00,0x00,0x00,0x00, - 0x44,0x2f,0x64,0xb2,0x02,0x00,0x00,0x00,0xb0,0x66,0x4c,0x36,0x00,0x00,0x00, - 0x00,0x00,0xff,0x78,0xff,0x00,0x00,0x00,0x00,0xd0,0xff,0xff,0xff,0x00,0x00, - 0x00,0x00,0x92,0xfd,0xff,0xff,0x00,0x00,0x00,0x00,0x44,0xf7,0xff,0x7f,0x00, - 0x00,0x00,0x00,0x00,0xf2,0xff,0x7f,0x20,0x00,0x00,0x00,0x00,0xc0,0xfc,0xff, - 0x3e,0x00,0x00,0x00,0x00,0x00,0x77,0xbf,0x6b,0x00,0x00,0x00,0x00,0x00,0x50, - 0xf7,0xaf,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0x3f,0x00,0x00,0x00,0x0a,0x00, - 0x80,0xfe,0x2f,0x00,0x00,0x68,0x00,0x00,0x00,0xff,0x2f,0x00,0x00,0x68,0x00, - 0x00,0x00,0xfc,0x1f,0x00,0x0d,0x3c,0x00,0x00,0x00,0xfa,0x1f,0x80,0x0e,0x3c, - 0x02,0x00,0x00,0xfe,0x1f,0xc0,0x0f,0x3c,0x80,0x01,0x20,0xff,0x0f,0xf0,0x0f, - 0x20,0x80,0x07,0x80,0xff,0x0f,0xe0,0x1f,0x00,0xc0,0x0f,0xc0,0xff,0x5f,0xff, - 0x1f,0x00,0xc0,0x07,0xc0,0xff,0x5f,0xf3,0x3f,0x00,0xe0,0x07,0xfe,0xff,0xff, - 0xf1,0xff,0xc7,0xf3,0xf3,0xfc,0xff,0xef,0xf1,0xff,0x6c,0xfe,0x9f,0xff,0xff, - 0xff,0xf1,0xff,0x30,0xfe,0xcf,0xff,0xff,0xff,0xd8,0xff,0xbf,0xff,0xff,0xff, - 0xff,0xff,0xf8,0xff,0x7f,0x3e,0xc9,0x27,0xf8,0x7f,0x6c,0xff,0x7f,0x1c,0x89, - 0x23,0xff,0xff,0xcf,0xe3,0x7f,0x1c,0x89,0x23,0xff,0xff,0x0d,0x60,0x7f,0x08, - 0x09,0x21,0xf8,0xff,0xff,0xa6,0x6f,0x2a,0x49,0x25,0xff,0xff,0x7f,0xd7,0x6f, - 0x22,0x49,0x24,0xff,0xff,0xff,0xff,0x7f,0x36,0xc9,0x26,0xff,0xff,0xff,0xff, - 0x7f,0x36,0xc9,0x26,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-simple-dn.xpm --- a/etc/vm/mime-simple-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"64 42 8 1", -/* colors */ -"` c Gray60", -"a c #666666666666", -"b c #9A9A9A9A9A9A", -"c c #B0B0B0B0B0B0", -"d c #2A2A2A2A2A2A", -"e c #878787878787", -"f c Gray60", -"g c #434343434343", -/* pixels */ -"eeeeeeeeeeebbbbbbbbbbbbbbcbbccbccccccccccccccccccccccbbbbbbbbbbb", -"beeeeeeeeebbbbbbbbbbbbbbbbbbbbbbbbbbbbccccbcccccccccbbbbbbbbbbbb", -"eeeeeeeeebbbebbbbbbbbbbbbbbbbbbbbbbbbbbbbbbcbcccccccbbbbbbbbbbbb", -"eeeeeeeeeeeeebbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb", -"eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeebbbebbbbbbbbbbbbbbbbbbbbbbb", -"eeeeeeeeeeeeeeeeeeeeeeeeeaeeeeeeeeeeeeeeeeeeebbbbbbbbbbeeeeeebeb", -"eeeeeeeaeaaeeeaeeaaaaeaaaaaaeeeaeeeeeeeeeeeeeeeeeeebbeeeeeeeeeee", -"eeaeeaeeeaeeaaaaaaeaeaeaaaeaaaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", -"eeeaaaaaaaaaaaaaaaaaaaaaaaaeeeeaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", -"eeeeaaaaaaaaaaaaaaaaaaaaaaaaaaeaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", -"eaaaaaaaaaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeeeeeebeeeeeeeeeeebeeee", -"eaaaaaeaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeeeeeeeeebebbeebeebeebeee", -"eeeaaeaeaaaaaaaaaaaaaaaaaaaaaaaeaeeeeeeeeeeeeeeebeeebbeeebbeeeee", -"eeeeeeeeeaaaaaaaaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeebbeebeeeeeeeee", -"eeeeeeeeaeaaaaaaaagggggggggggggaaaaaaaaaaaeeeeeeeeeeeeeeeeeeeeee", -"eeeeeeeeeeaaaagagggggggggggggggggaaaaaaaaaaaaaeeeeeeeeeeeeeeeeee", -"eeeeeeeeeeaaagagggggggggggggggggggaaaaaaaaaaaaaeeeeeeeeeeeeeeeee", -"eeeeeeeeaaaaaagggggggggggggggggggggggggaaaaaaaaaaaeeeeeeeeeeeeee", -"eeeeeeeeaaaaaggggggggggggggggggggdgdggggaaggaaaaaaaaaaeeeeeeeeee", -"beeeeeeaaaaaggggggagaagggggdgddggggggggggggaaaaaaaaaaeeeeeeeeeee", -"eeeeeeeaaaaaaaaaaaaeaggggggdgddaaaaggggggggggaaaaaaaaaeeeeeeeeee", -"eeeeeeeaaaaaaaaaeeeeaaagggddddgaaeaggggaaggggaaaaaaaaaaeeeeeeebb", -"eeeeeeaaaaaaaaaeeeeeaaaaggddddgaeeeaggaeeagggggaaaaaaaeaeeeeebbb", -"eeeeeeaaaaaaaeeeeeeeeaagggddddgaaeaagaaeeeaaggggaaaaaeeeeeeeebeb", -"eeeeeeaaaaaaeeeeeeeeeaaaaaaggdgaaaaaaaaeeeeeaagaaaaaeeeeeeebbbbb", -"eeeeeeeaaaaeeeeeeeeeeaaaaaaaggggaaagaaebbebeeaaaaaaeaaeeeebebbbb", -"beeeeeeefffffeeeebbbeeaaaaaaaaaaaaaaaaccbffeeaeeeeaaaeeebbbbbbbb", -"beeeeeeeffaaffeebbbbbeaaaaaaaeaaaaaaabcbcffeeeeeeeeeeebbbbbbbbbb", -"ebeeeeeffaaaffeeffffbbeffffaaaffffaabffbffeeffffeeebbbbbbbbbbbbb", -"bbbbeeeffaaaffeffbbffcffaaffaffaaffbffcfffeffeefeeeebbbbbbbbbbbb", -"bbbbeeffeeaaffffebbffffbeeaaffaaaffffcbeffffeeefeeeebbbbbbbbbbbb", -"bbbbeeffeaeffeffffffbffbbbeeffeeffcffbeffeffffffebebbbbbbbbbcbbb", -"bbbbeeffaeeffffeeeeeffebbffffbb``fffbe``f``e``eeeeb``b`````bcccc", -"bbbbbffeeeffeffeeffeffeeffeffee```ffe```e``e```eeb```b``ccbccccc", -"bbbbbffffffeeeffffeeeffffeeefff```eff```e``f```bbe```b``bccccccb", -"bbbbbbeeeeeeeeeeeeeeeeeeeeeeeee````e````b``b````b````c`````ccccc", -"bbbbbbbeeeeeeeeeeeeeeeeeeeeeaee``b`e`b``e``b``b`b`c``c``cbcccbcc", -"bbbbbbbbeeeeeeeeeeeeeeeeeeeeeee``b```b``b``b``b```c``c``cccccccc", -"bccbbbbbeeebeeeeeeeeeeeeeeeeeee``bb`bb``b``b``cc`cc``c``cccccccc", -"bbcbbbbbbbebebbeeeeeeeeeebbbeee``bb`bb``b``b``cb`bc``c`````ccccc", -"ccccbbbbbbbbbbbbebeeebbbbbbebbebbbbbbbbcbccccbcccccccccccccccccc", -"bbcccbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbccbccccccccccccccccccccccc" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-simple-up.xpm --- a/etc/vm/mime-simple-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"64 42 8 1", -/* colors */ -"` c #000000000000", -"a c #B8B878785050", -"b c #D0D0A8A88888", -"c c #585838383838", -"d c #303028282828", -"e c #FFFFFFFFFFFF", -"f c #D0D090906868", -"g c #909050504040", -/* pixels */ -"aaaaaaaaaaaffffffffffffffffffffffbfffffffbbfffbffbfbfffffffffffa", -"faaaaaaaaaffffffffffffffffffffffffffffffffffffbbffffffffffffffaf", -"aaaaaaaaafffafaffffffffffaffffffffffffffffffffffffffffffffffffff", -"aaaaaaaaaaaaafffafffffafffffffafffffffafffffffffffffffffffffffff", -"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafffafffffffffffffffffffafaf", -"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafffffffaffaaaaaafaf", -"aaaaaaaaaggaaagaagaggagggggaaaagaaaaaaaaaaaaaaaaaaaffaaaaaaaaaaa", -"aagaagaaagaaggggggagagaaggaggaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", -"aaagggggggaggggggggggggggggaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", -"aaaaggggggggggggggggggggggggggagaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", -"aaggggggggggggggggggggggggggggaaaaaaaaaaaaaaaaafaaaaaaaaaaafaaaa", -"aaggggagggggggggggggggggggggaaaaaaaaaaaaaaaaaaaafaffaafaafaafaaa", -"aaaagagagggggggggggggggggggggggagaaaaaaaaaaaaaaafaaaffaaaffaaaaa", -"aaaaaaaaaggggggggggggggggggggggggggggaaaaaaaaaaaaaffaafaaaaaaaaa", -"aaaaaaaaaaggggggggcccccccccccccggggggggggaaaaaaaaaaaaaaaaaaaaaaa", -"aaaaaaaaaaggggcgcccccccccccccccccggggggggggggaaaaaaaaaaaaaaaaaaa", -"aaaaaaaaaagggcgcccccccccccccccccccgggggggggggggaaaaaaaaaaaaaaaaa", -"aaaaaaaaaaggggcccccccccccccccccccccccccggggggggggaaaaaaaaaaaaaaa", -"aaaaaaaaaggggccccccccccccccccccccdcdccccggccggggggggaaaaaaaaaaaa", -"faaaaaaaggggccccccgcggcccccdcddccccccccccccggggggggggaaaaaaaaaaa", -"aaaaaaaggggggggggggagccccccdcddggggccccccccccgggggggggaaaaaaaaaa", -"aaaaaaagggggggggaaaagggcccddddcggagccccggccccgggggggggaaaaaaaaff", -"aaaaaagggggggggaaaaaggggccddddcgaaagccgaagcccccgggggagaaaaaaafff", -"aaaaaagggggggaaaaaaaaggcccddddcggaggcggaaaggccccgggggaaaaaaaafaf", -"aaaaaaggggggaaaaaaaaaggggggccdcggggggggaaaaaggcgggggaaaaaaaaffff", -"aaaaaaaagggaaaaaaaaaagggggggccccgggcggaffafaaggggggaggaaaafaffff", -"faaaaaaaeeeeeaaaafffaaggggggggggggggggbbfeeaaaaaaagggaaaffffffff", -"faaaaaaaeegaeeaafffffagggggggagggggggfbfbeeaaaaaaaaaaaffffffffff", -"afaaaaaeegggeeaaeeeeffaeeeegggeeeeggfeefeeaaeeeeaaafffffffffffff", -"ffffaaaeeaggeeaeeffeebeeggeegeeggeefeebeeeaeeaaeaaaaffffffffffff", -"ffffaaeeaaggeeeeaffeeeefaaggeegggeeeebfaeeeeaaaeaaaaffffffffffff", -"ffffaaeeagaeeaeeeeeefeefffaaeeaaeebeefaeeaeeeeeeafafffffffffffff", -"ffffaaeeaaaeeeeaaaaaeeaffeeeeff``eeefa``e``a``aaaaf``f`````fffff", -"fffffeeaaaeeaeeaaeeaeeaaeeaeeaa```eea```a``a```aaf```f``fffbfbff", -"fffffeeeeeeaaaeeeeaaaeeeeaaaeee```aee```a``e```ffa```f``fffffbff", -"ffffffaaaaaaaaaaaaaaaaaaaaaaaaa````a````f``f````f````f`````fbffb", -"fffffffaaaaaaaaaaaaaaaaaaaaaaaa``f`a`f``a``f``f`f`f``b``bfbfbffb", -"ffffffffaaaaaaaaaaaaaaaaaaaaaaa``f```f``f``f``f```f``f``fbfbfbfb", -"ffffffffaaafaaaaaaaaaaaaaaaaaaa``ff`ff``f``f``fb`bf``b``bfbfbbbf", -"ffffffffffafaffaaaaaaaaaafffaaa``ff`ff``f``f``bf`fb``b`````bfbfb", -"ffbfffffffffffffafaaaffffffaffaffffffffbffbfbfbfbbfbbfbbbbfbfbff", -"fffffffffffffffffffffffffffffffffffffffbffbbfbfbbbbbbffbfbfbffbf" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-simple-xx.xpm --- a/etc/vm/mime-simple-xx.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"64 42 8 1", -/* colors */ -"` c #000000000000", -"a c #D0D0A8A88888", -"b c #B8B870705050", -"c c #888868685050", -"d c #999999999999", -"e c #505040403838", -"f c #303028282828", -"g c #787848483838", -/* pixels */ -"b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b`", -"`b`b`b`b`b`b`b`b`a`b`a`b`a`a`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b", -"b`b`b`b`b`b`b`b`b`b`b`a`a`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b`b`", -"`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`b`b`b`b`b", -"b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`b`b`b`b`b`", -"`b`b`b`b`b`b`b`b`b`b`b`b`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`b`b`b`c`b`c`b`b`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`c`b`c`b`c`c`c`c`c`b`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`c`c`c`b`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`c`c`c`c`c`c`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`c`c`c`c`c`c`c`g`c`g`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`c`c`c`c`c`c`c`g`g`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`c`c`c`c`c`c`c`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`b`b`c`c`c`c`c`g`g`g`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`b`b`b`c`c`c`g`g`g`e`e`e`e`g`g`g`g`c`c`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`b`b`b`c`g`g`e`e`e`e`e`e`g`g`g`g`g`g`g`c`c`b`b`b`b`b`b`b`b`b", -"b`b`b`b`b`c`g`g`e`g`e`e`e`e`e`e`e`g`g`g`g`g`c`c`b`b`b`b`b`b`b`b`", -"`b`b`b`b`c`g`g`e`e`e`e`e`e`e`e`e`e`e`e`g`g`g`g`c`c`b`b`b`b`b`b`b", -"b`b`b`b`c`g`g`g`e`e`e`e`e`e`e`e`e`e`e`e`g`g`g`g`g`c`c`b`b`b`b`b`", -"`b`b`b`c`g`g`g`e`e`e`g`e`e`f`f`e`e`e`e`e`e`g`g`g`g`c`b`b`b`b`b`b", -"b`b`b`b`g`g`g`g`g`g`c`e`e`e`e`f`c`g`e`e`e`e`e`c`g`g`c`b`b`b`b`b`", -"`b`b`b`g`c`c`g`c`b`b`g`e`e`f`f`c`b`e`e`c`e`e`g`g`c`c`c`c`b`b`b`b", -"b`b`b`c`c`g`c`c`b`b`c`g`e`f`f`e`b`b`e`g`b`e`e`e`g`c`c`c`b`b`b`b`", -"`b`b`b`c`c`c`b`b`b`b`c`e`e`f`f`c`b`g`g`b`b`g`e`g`c`c`b`b`b`b`b`b", -"b`b`b`c`c`c`b`b`b`b`b`g`g`g`e`e`c`c`c`c`b`b`g`e`g`g`c`b`b`b`b`b`", -"`b`b`b`c`c`b`b`b`b`b`c`g`c`c`e`e`c`e`c`a`b`b`c`g`g`c`c`b`b`b`b`a", -"b`b`b`b`d`d`d`b`b`b`b`c`c`c`c`c`c`c`c`a`a`d`c`b`c`c`c`b`b`b`b`b`", -"`b`b`b`b`d`c`d`b`a`a`b`c`c`c`b`c`c`c`a`a`d`b`b`b`b`b`b`b`b`a`b`a", -"b`b`b`b`d`c`d`b`d`d`a`b`d`d`c`d`d`c`a`d`d`b`d`d`b`b`b`b`a`a`a`a`", -"`a`b`b`d`c`c`d`d`b`d`a`d`c`d`d`c`d`b`d`d`d`d`b`d`b`b`b`b`a`a`a`b", -"b`b`b`d`b`c`d`d`b`a`d`d`b`c`d`c`c`d`d`a`d`d`b`b`b`b`b`b`a`a`a`a`", -"`b`b`b`d`c`d`b`d`d`d`d`a`a`b`d`b`d`d`a`d`b`d`d`d`b`b`a`a`a`a`a`a", -"a`b`b`d`c`b`d`d`b`b`d`b`a`d`d`a`d`d`a`d`d`d`d`b`b`b`d`d`d`d`a`a`", -"`b`b`d`b`b`d`d`b`d`b`d`b`d`d`b`d`d`d`d`d`d`b`d`b`b`d`a`d`a`a`a`a", -"a`b`b`d`d`d`b`d`d`b`b`d`d`b`d`d`d`b`d`d`b`d`d`d`b`d`d`d`a`a`a`a`", -"`a`b`b`b`b`b`b`b`c`b`b`b`b`b`b`d`d`b`d`d`d`b`d`d`d`d`a`d`d`a`a`a", -"a`a`b`b`b`b`b`b`c`b`b`b`b`b`c`b`d`d`d`d`b`d`d`a`a`a`d`d`a`a`a`a`", -"`a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`d`b`d`a`d`d`a`d`d`d`d`a`d`a`a`a`a", -"a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`b`d`a`a`d`a`d`d`a`d`a`d`d`a`a`a`a`", -"`a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`d`a`d`a`d`d`a`d`a`a`d`a`d`d`a`a`a", -"a`a`a`a`b`b`b`b`b`b`b`b`b`b`a`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`", -"`a`a`a`a`a`b`b`b`b`b`b`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-up.xbm --- a/etc/vm/mime-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -#define e_width 64 -#define e_height 42 -static unsigned char e_bits[] = { - 0xc6, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0xbd, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x25, 0x80, 0x47, - 0x00, 0x00, 0x00, 0x00, 0xf3, 0xbe, 0xfd, 0xff, 0x0b, 0x00, 0x00, 0x00, - 0xfe, 0xff, 0xff, 0xff, 0xff, 0x12, 0x40, 0x12, 0xff, 0xff, 0xff, 0xff, - 0xbb, 0xd0, 0x9b, 0x4d, 0xfd, 0xff, 0xff, 0xff, 0x4f, 0x99, 0xb3, 0xc9, - 0xff, 0xff, 0xff, 0xff, 0xff, 0x00, 0x87, 0x00, 0xff, 0xff, 0xff, 0xff, - 0x2f, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0x6d, 0x02, 0x00, 0x00, - 0xff, 0xff, 0xff, 0xff, 0xbb, 0x08, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff, - 0xff, 0x0d, 0x00, 0x80, 0xdf, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x03, 0x00, - 0xc1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x88, 0x40, 0x94, 0xff, 0xff, 0xff, - 0xff, 0xff, 0xaf, 0x08, 0x50, 0xff, 0xff, 0xff, 0xff, 0xff, 0x1f, 0x00, - 0xc0, 0xff, 0xff, 0xff, 0xf5, 0xff, 0x7f, 0x01, 0xd0, 0xff, 0xff, 0x97, - 0xff, 0xff, 0xff, 0x00, 0xd0, 0xff, 0xff, 0x97, 0xff, 0xff, 0xff, 0x03, - 0xe0, 0xff, 0xf2, 0xc3, 0xff, 0xff, 0xff, 0x05, 0xe0, 0x7f, 0xf1, 0xc3, - 0xfd, 0xff, 0xff, 0x01, 0xe0, 0x3f, 0xf0, 0xc3, 0x7f, 0xfe, 0xdf, 0x00, - 0xf0, 0x0f, 0xf0, 0xdf, 0x7f, 0xf8, 0x7f, 0x00, 0xf0, 0x1f, 0xe0, 0xff, - 0x3f, 0xf0, 0x3f, 0x00, 0xa0, 0x00, 0xe0, 0xff, 0x3f, 0xf8, 0x3f, 0x00, - 0xa0, 0x0c, 0xc0, 0xff, 0x1f, 0xf8, 0x01, 0x00, 0x00, 0x0e, 0x00, 0x38, - 0x0c, 0x0c, 0x03, 0x00, 0x10, 0x0e, 0x00, 0x93, 0x01, 0x60, 0x00, 0x00, - 0x00, 0x0e, 0x00, 0xcf, 0x01, 0x30, 0x00, 0x00, 0x00, 0x27, 0x00, 0x40, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x07, 0x00, 0x80, 0xc1, 0x36, 0xd8, 0x07, - 0x80, 0x93, 0x00, 0x80, 0xe3, 0x76, 0xdc, 0x00, 0x00, 0x30, 0x1c, 0x80, - 0xe3, 0x76, 0xdc, 0x00, 0x00, 0xf2, 0x9f, 0x80, 0xf7, 0xf6, 0xde, 0x07, - 0x00, 0x00, 0x59, 0x90, 0xd5, 0xb6, 0xda, 0x00, 0x00, 0x80, 0x28, 0x90, - 0xdd, 0xb6, 0xdb, 0x00, 0x00, 0x00, 0x00, 0x80, 0xc9, 0x36, 0xd9, 0x00, - 0x00, 0x00, 0x00, 0x80, 0xc9, 0x36, 0xd9, 0x07, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - }; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mime-xx.xbm --- a/etc/vm/mime-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define ee_width 64 -#define ee_height 42 -static char ee_bits[] = { - 0xc6,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x70,0x25,0x80,0x47,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0x12,0x40,0x12,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfd,0xff,0xff,0xff,0x4f,0x99,0xb3,0xc9,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0x2f,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xbb,0x08,0x00,0x80,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xdf,0xff,0xff,0xff,0xff,0x3f,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x94,0xff,0xff,0xff,0xff,0xff,0xaf, - 0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xf5,0xff, - 0x7f,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0xff,0xff,0x97,0xff, - 0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x7f,0xf1,0xc3, - 0xfd,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0x0f,0xf0, - 0xdf,0x7f,0xf8,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x00, - 0xe0,0xff,0x3f,0xf8,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x0e,0x00,0x38,0x0c,0x0c,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x0e,0x00,0xcf,0x01,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x07,0x00,0x80,0xc1,0x36,0xd8,0x07,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x30,0x1c,0x80,0xe3,0x76,0xdc,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x59,0x90,0xd5,0xb6,0xda,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xc9,0x36,0xd9,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mona_stamp-colorful.xpm --- a/etc/vm/mona_stamp-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 86 2", -/* colors */ -"`` c #B88D37", -"`a c #200505", -"`b c #F49B12", -"`c c #704B25", -"`d c #B65D0A", -"`e c #4D2713", -"`f c #FFAC19", -"`g c #64300F", -"`h c #321B0C", -"`i c #582E03", -"`j c #C07920", -"`k c #874F09", -"`l c #593514", -"`m c #A07C21", -"`n c #DE7F1C", -"`o c #481103", -"`p c #542D15", -"`q c #58220F", -"`r c #D1AC4A", -"`s c #DFA644", -"`t c #EC9708", -"`u c #501A07", -"`v c #3D1608", -"`w c #90602B", -"`x c #350000", -"`y c #A77B13", -"`z c #A04E13", -"a` c #AC7E39", -"aa c #997319", -"ab c #DA9C1A", -"ac c #8B6F1F", -"ad c #280C0A", -"ae c #98460B", -"af c #AF5707", -"ag c #631C0F", -"ah c #764F35", -"ai c #E6B339", -"aj c #804500", -"ak c #DEAB31", -"al c #802B00", -"am c #C06B21", -"an c #91732E", -"ao c #643C19", -"ap c #A54F03", -"aq c #A78A40", -"ar c #7E5C25", -"as c #793313", -"at c #804F1D", -"au c #AD913F", -"av c #85681B", -"aw c #CB6E00", -"ax c #30120D", -"ay c #B89846", -"az c #8C3904", -"b` c #B96219", -"ba c #FABB1D", -"bb c #A68527", -"bc c #85652B", -"bd c #F2B315", -"be c #FFC125", -"bf c #7D430C", -"bg c #C86B0D", -"bh c #EAAB0D", -"bi c #420907", -"bj c #9D5828", -"bk c #D68000", -"bl c #813A1D", -"bm c #F7A413", -"bn c #9C6E2A", -"bo c #A1833C", -"bp c #75551E", -"bq c #BF6307", -"br c #997B34", -"bs c #D27213", -"bt c #431F0E", -"bu c #712A0D", -"bv c #74411D", -"bw c #CAA239", -"bx c #C0982F", -"by c #A7551A", -"bz c #E98912", -"c` c #E1810A", -"ca c #501321", -"cb c #DB7B04", -"cc c #EF911E", -"cd c #390C00", -/* pixels */ -"acananacbcanbrananacbracbpararacanacananananbrbr", -"avananacacacacanbnbp`pbtaxad`hbtaobcananbrbrbobr", -"anbranaaanananar`vad`x`a`a`a`a`a`aad`eavbrbobobr", -"br`mbbbbbbbrbpadadbibi`aad`a`a`a`a`a`aaxbcbobobo", -"bbbbbbbbaqbnad`a`x`ucd`x`a`a`a`a`aadad`a`hanauaq", -"bbbbaq``aq`v`uae`jc``nbsae`qad`a`a`aad`a`a`eaqaq", -"bb``bxayat`vafab`fbabd`bbzapagbi`a`a`aad`a`aarau", -"````ay``btbubzbdbebababa`bbsajcdad`a`a`a`a`a`hau", -"ayayay`wadaeab`fbdbdbdbd`tawaeagbi`aad`a`a`a`aac", -"bwbx```qbiae`tbmbh`fbh`fc`bs`dae`gbi`a`a`a`a`a`p", -"`s`rbjbi`hbqc`bmbmbh`fbm`bc``nbqaecdadadad`a`a`h", -"aiakbvadbibsbzc``tbm`tbqaf`dbqaebuadad`xadad`aax", -"bw```qbibiasazasafc`azbiblal`obicd`x`aad`xadad`a", -"a`br`uadbibtbl`uasbzagalafca`uas`z`uadadad`aadad", -"bcbo`vbi`hbsbsbyawccalbybs`d`dbkbg`u`xadadadadad", -"`ebv`vad`uc`bhbmc`bzafbsbhbabmcbap`uad`xadadadad", -"`v`e`vbibibgbmbmbzbm`dbs`tbm`tbqbl`xad`xad`x`xbi", -"`v`vbiadadaf`t`tc`bzaf`dcc`tbsae`q`xbiadbiadadad", -"bi`h`x`vbibubsc`bq`z`vbu`tcbafbu`uadadbiadbiadbi", -"`vbibiad`h`uapbqbzas`qaeafafaebu`ubiadadadbiadad", -"`h`hbibibi`haeapbyae`q`uazbqapbu`vadadcdaxadbiax", -"btbtad`hbiadagbqc`afbfbfapbybf`ucdad`xaxbiadadbi", -"`ibtbibiadbiad`qbsbm`n`daeas`u`vcd`xadbiad`hbiad", -"ao`e`hbiaxadadadasc`bk`z`q`u`vbibiaxadadbiadadbi", -"ar`c`v`hbiadbi`aad`u`u`vcdbiadadbibiadbiadadbiad", -"bparbt`x`hbiad`aadadbibiad`xbiadbi`h`xadadadadad", -"bp`c`eaxbiadbi`aadadas`g`v`hbibt`v`q`v`xadadbiad", -"ar`c`lbiaxbiadadad`abu`daj`q`u`ubuaj`qbiadadadad", -"ahaobtax`hbiaxadadad`u`dae`kbfbfaeaebf`vbiad`vcd", -"ax`h`hbiadadbiadbi`q`d`yb``d`d`ybgam`d`gbi`hcd`v" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/mona_stamp-simple.xpm --- a/etc/vm/mona_stamp-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #F49B12", -"a c #64300F", -"b c #280C0A", -"c c #B89846", -"d c #8C3904", -"e c #FFC125", -"f c #9D5828", -"g c #D68000", -/* pixels */ -"ffffffffffffffffffffffff", -"ffffffffffabbbbbafffffcf", -"ffffffffbbbbbbbbbbaffccf", -"ffcccffbbbbbbbbbbbbbfccc", -"cccccfbbbabbbbbbbbbbbfcc", -"cccccbadggggdabbbbbbbacc", -"ccccfbf``e```dabbbbbbbfc", -"ccccba``eeee`gdbbbbbbbbc", -"cccfbd```````gdabbbbbbbf", -"cccabd``````ggfdabbbbbba", -"ccfbbgg``````gggdbbbbbbb", -"e`abbg`g```gffgdabbbbbbb", -"ccabbadafgdbddbbbbbbbbbb", -"cfabbbdaa`adfaaafabbbbbb", -"fcbbbggfg`dfgffggabbbbbb", -"aabbag``g`fg`e`gdabbbbbb", -"babbbg````fg```gdbbbbbbb", -"bbbbbf``g`ff``gdabbbbbbb", -"bbbbbagggfba`gfaabbbbbbb", -"bbbbbadg`aadffdaabbbbbbb", -"bbbbbbddfdaadgdabbbbbbbb", -"bbbbbbaggfdddfdabbbbbbbb", -"abbbbbbag`gfdaabbbbbbbbb", -"aabbbbbbaggfaabbbbbbbbbb", -"fabbbbbbbaabbbbbbbbbbbbb", -"ffbbbbbbbbbbbbbbbbbbbbbb", -"faabbbbbbbaabbbbbabbbbbb", -"faabbbbbbbafdaaaadabbbbb", -"fabbbbbbbbafdddddddbbbbb", -"bbbbbbbbbaffffffgffabbbb" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/next-dn.xbm --- a/etc/vm/next-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xcf,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xff,0xff,0xff,0xff,0xff, - 0x1f,0x00,0x60,0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xbf,0xfe,0xff,0xff,0xff, - 0xff,0x5f,0x00,0x00,0xfd,0xff,0xff,0xff,0xff,0x5f,0x00,0x00,0xf8,0xff,0xff, - 0xff,0xff,0x5f,0x00,0x00,0xfc,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0xfe,0xff, - 0xff,0xff,0xff,0x1f,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x8f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xcf,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x73,0xfe,0xff,0xf9,0xff,0xff,0xff,0xff, - 0x63,0xfe,0xff,0xf9,0xff,0xff,0xff,0xff,0x63,0x86,0x99,0xf0,0xff,0xff,0xff, - 0xff,0x53,0x32,0x99,0xf9,0xff,0xff,0xff,0xff,0x53,0x32,0xc3,0xf9,0xff,0xff, - 0xff,0xff,0x33,0x02,0xe7,0xf9,0xff,0xff,0xff,0xff,0x33,0xf2,0xc3,0xf9,0xff, - 0xff,0xff,0xff,0x73,0x32,0x99,0xe9,0xff,0xff,0xff,0xff,0x73,0x86,0x99,0xf3, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/next-dn.xpm --- a/etc/vm/next-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * next_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooWWoXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWWWWWWWWWWWWWWWWoWoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXooooXXooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooooooXXXooXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooXXXXXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/next-up.xbm --- a/etc/vm/next-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x50,0x00,0x00,0x00,0x00,0x00, - 0xe0,0xff,0x9f,0x00,0x00,0x00,0x00,0x00,0x20,0x00,0x40,0x01,0x00,0x00,0x00, - 0x00,0xa0,0xff,0xff,0x02,0x00,0x00,0x00,0x00,0xa0,0xff,0xff,0x07,0x00,0x00, - 0x00,0x00,0xa0,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x01,0x00, - 0x00,0x00,0x00,0xe0,0xff,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x8c,0x01,0x00,0x06,0x00,0x00,0x00,0x00, - 0x9c,0x01,0x00,0x06,0x00,0x00,0x00,0x00,0x9c,0x79,0x66,0x0f,0x00,0x00,0x00, - 0x00,0xac,0xcd,0x66,0x06,0x00,0x00,0x00,0x00,0xac,0xcd,0x3c,0x06,0x00,0x00, - 0x00,0x00,0xcc,0xfd,0x18,0x06,0x00,0x00,0x00,0x00,0xcc,0x0d,0x3c,0x06,0x00, - 0x00,0x00,0x00,0x8c,0xcd,0x66,0x16,0x00,0x00,0x00,0x00,0x8c,0x79,0x66,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/next-up.xpm --- a/etc/vm/next-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * next_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooWWoXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWWWWWWWWWWWWWWWWoWoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXooooXXooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooooooXXXooXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooXXXXXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/next-xx.xbm --- a/etc/vm/next-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x50,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20,0x00,0x40,0x01,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0xff,0xff,0x07,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x01,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x9c,0x01,0x00,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xac,0xcd,0x66,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xcc,0xfd,0x18,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x8c,0xcd,0x66,0x16,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/previous-dn.xbm --- a/etc/vm/previous-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xf3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x06,0x00,0xf8,0xff,0xff,0xff,0xff,0x7f,0xfd,0xff,0xfb,0xff,0xff,0xff, - 0xff,0xbf,0x00,0x00,0xfa,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0xfa,0xff,0xff, - 0xff,0xff,0x3f,0x00,0x00,0xfa,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0xf8,0xff, - 0xff,0xff,0xff,0xff,0x00,0x00,0xf8,0xff,0xff,0xff,0xff,0xff,0xf1,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xf3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x3f,0xf0,0xff,0xff,0xf9,0xff,0xff,0xff,0x3f,0xe7, - 0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x87,0x84,0x39,0x19,0x66,0x86,0xff,0x3f, - 0x07,0x30,0x39,0xc9,0x64,0x32,0xff,0x3f,0x10,0x33,0x93,0xc9,0x64,0xe2,0xff, - 0x3f,0x9f,0x03,0x93,0xc9,0x64,0x8e,0xff,0x3f,0x9f,0xf3,0xc7,0xc9,0x64,0x1e, - 0xff,0x3f,0x9f,0x33,0xc7,0xc9,0x24,0x32,0xff,0x3f,0x9f,0x87,0xef,0x19,0x4e, - 0x86,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/previous-dn.xpm --- a/etc/vm/previous-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * previous_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoWWooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoWoWWWWWWWWWWWWWWWWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooooooXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooooXooXooooXXooXXXooXooXXooooXXooXXooXXooooXXXXXXXXX", -"XXXXXXooXXXoooooooooXXooXooXXXooXooXooXXooXooXXooXooXXooXXXXXXXX", -"XXXXXXooooooXoooXXooXXooXXooXooXXooXooXXooXooXXooXoooXXXXXXXXXXX", -"XXXXXXooXXXXXooXXXooooooXXooXooXXooXooXXooXooXXooXXXoooXXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXXXXXXoooXXXooXooXXooXooXXooXXXXoooXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXooXXXoooXXXooXooXXooXooXoooXooXXooXXXXXXXX", -"XXXXXXooXXXXXooXXXXooooXXXXXoXXXXooXXooooXXXooXooXXooooXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/previous-up.xbm --- a/etc/vm/previous-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x0c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0a,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xf9,0xff,0x07,0x00,0x00,0x00,0x00,0x80,0x02,0x00,0x04,0x00,0x00,0x00, - 0x00,0x40,0xff,0xff,0x05,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x05,0x00,0x00, - 0x00,0x00,0xc0,0xff,0xff,0x05,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0x07,0x00, - 0x00,0x00,0x00,0x00,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00,0x0e,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x0c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xc0,0x0f,0x00,0x00,0x06,0x00,0x00,0x00,0xc0,0x18, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x78,0x7b,0xc6,0xe6,0x99,0x79,0x00,0xc0, - 0xf8,0xcf,0xc6,0x36,0x9b,0xcd,0x00,0xc0,0xef,0xcc,0x6c,0x36,0x9b,0x1d,0x00, - 0xc0,0x60,0xfc,0x6c,0x36,0x9b,0x71,0x00,0xc0,0x60,0x0c,0x38,0x36,0x9b,0xe1, - 0x00,0xc0,0x60,0xcc,0x38,0x36,0xdb,0xcd,0x00,0xc0,0x60,0x78,0x10,0xe6,0xb1, - 0x79,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/previous-up.xpm --- a/etc/vm/previous-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * previous_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoWWooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoWoWWWWWWWWWWWWWWWWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooooooXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooooXooXooooXXooXXXooXooXXooooXXooXXooXXooooXXXXXXXXX", -"XXXXXXooXXXoooooooooXXooXooXXXooXooXooXXooXooXXooXooXXooXXXXXXXX", -"XXXXXXooooooXoooXXooXXooXXooXooXXooXooXXooXooXXooXoooXXXXXXXXXXX", -"XXXXXXooXXXXXooXXXooooooXXooXooXXooXooXXooXooXXooXXXoooXXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXXXXXXoooXXXooXooXXooXooXXooXXXXoooXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXooXXXoooXXXooXooXXooXooXoooXooXXooXXXXXXXX", -"XXXXXXooXXXXXooXXXXooooXXXXXoXXXXooXXooooXXXooXooXXooooXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/previous-xx.xbm --- a/etc/vm/previous-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0a,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x02,0x00,0x04,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x05,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0x07,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0e,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x18, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0, - 0xf8,0xcf,0xc6,0x36,0x9b,0xcd,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xc0,0x60,0xfc,0x6c,0x36,0x9b,0x71,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xc0,0x60,0xcc,0x38,0x36,0xdb,0xcd,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/print-dn.xbm --- a/etc/vm/print-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0xfc, - 0xff,0xff,0xff,0xff,0xff,0xff,0xc2,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xfe, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xe2,0x57,0xfe,0xff,0xff,0xff,0xff,0xff, - 0xfe,0xe7,0xfd,0xff,0xff,0xff,0xff,0xff,0x00,0xf0,0xfc,0xff,0xff,0xff,0xff, - 0x7f,0xff,0x77,0xfd,0xff,0xff,0xff,0xff,0xbf,0xff,0xaf,0xfd,0xff,0xff,0xff, - 0xff,0x1f,0x00,0xc0,0xfd,0xff,0xff,0xff,0xff,0xdf,0xff,0xdf,0xfd,0xff,0xff, - 0xff,0xff,0xdf,0xff,0xdf,0xfc,0xff,0xff,0xff,0xff,0xdf,0xff,0x5f,0xfe,0xff, - 0xff,0xff,0xff,0xdf,0xff,0x9f,0xfe,0xff,0xff,0xff,0xff,0x1f,0x00,0x40,0xff, - 0xff,0xff,0xff,0xff,0xbf,0xff,0xaf,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xd7, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xe7,0xff,0xff,0xff,0xff,0xff,0xff,0x00, - 0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x3f,0xff,0xf9,0xff,0xff,0xff,0xff, - 0x73,0xfe,0xff,0xf9,0xff,0xff,0xff,0xff,0x73,0x08,0xc9,0xf0,0xff,0xff,0xff, - 0xff,0x73,0x00,0x91,0xf9,0xff,0xff,0xff,0xff,0x03,0x31,0x99,0xf9,0xff,0xff, - 0xff,0xff,0xf3,0x39,0x99,0xf9,0xff,0xff,0xff,0xff,0xf3,0x39,0x99,0xf9,0xff, - 0xff,0xff,0xff,0xf3,0x39,0x99,0xe9,0xff,0xff,0xff,0xff,0xf3,0x39,0x99,0xf3, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/print-dn.xpm --- a/etc/vm/print-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * print_xpm,[] = { -"64 42 6 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"@ c Gray90", -"# c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOooooOOoXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOoooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOoXo+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOoo++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooo++++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@o+++o+oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@o+o++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@oo#oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo#oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo+++++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++ooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooooXooooXooXooXXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXoooooooooXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXoooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/print-up.xbm --- a/etc/vm/print-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0x3d,0x05,0x00,0x00,0x00,0x00,0x00,0x00,0x01, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x1d,0xa8,0x01,0x00,0x00,0x00,0x00,0x00, - 0x01,0x18,0x02,0x00,0x00,0x00,0x00,0x00,0xff,0x0f,0x03,0x00,0x00,0x00,0x00, - 0x80,0x00,0x88,0x02,0x00,0x00,0x00,0x00,0x40,0x00,0x50,0x02,0x00,0x00,0x00, - 0x00,0xe0,0xff,0x3f,0x02,0x00,0x00,0x00,0x00,0x20,0x00,0x20,0x02,0x00,0x00, - 0x00,0x00,0x20,0x00,0x20,0x03,0x00,0x00,0x00,0x00,0x20,0x00,0xa0,0x01,0x00, - 0x00,0x00,0x00,0x20,0x00,0x60,0x01,0x00,0x00,0x00,0x00,0xe0,0xff,0xbf,0x00, - 0x00,0x00,0x00,0x00,0x40,0x00,0x50,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x28, - 0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xc0,0x00,0x06,0x00,0x00,0x00,0x00, - 0x8c,0x01,0x00,0x06,0x00,0x00,0x00,0x00,0x8c,0xf7,0x36,0x0f,0x00,0x00,0x00, - 0x00,0x8c,0xff,0x6e,0x06,0x00,0x00,0x00,0x00,0xfc,0xce,0x66,0x06,0x00,0x00, - 0x00,0x00,0x0c,0xc6,0x66,0x06,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x06,0x00, - 0x00,0x00,0x00,0x0c,0xc6,0x66,0x16,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/print-up.xpm --- a/etc/vm/print-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * print_xpm,[] = { -"64 42 6 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"@ c Gray90", -"# c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOooooOOoXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOoooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOoXo+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOoo++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooo++++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@o+++o+oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@o+o++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@oo#oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo#oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo+++++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++ooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooooXooooXooXooXXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXoooooooooXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXoooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/print-xx.xbm --- a/etc/vm/print-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x01,0x18,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x80,0x00,0x88,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xe0,0xff,0x3f,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x20,0x00,0x20,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x20,0x00,0x60,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x40,0x00,0x50,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xc0,0x00,0x06,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x8c,0xf7,0x36,0x0f,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xce,0x66,0x06,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/quit-dn.xbm --- a/etc/vm/quit-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f, - 0xc0,0xff,0xff,0xf0,0xff,0xff,0xff,0x0f,0x27,0xff,0xff,0xf8,0xfc,0xff,0xff, - 0x87,0x7f,0xff,0xff,0x7c,0xfc,0xff,0xff,0xe7,0xff,0xff,0xff,0x7f,0xfe,0xff, - 0xff,0xe3,0x9f,0xfe,0xff,0x3f,0xfe,0xff,0xff,0xe3,0xbf,0x83,0x61,0x10,0xf5, - 0xff,0xff,0x73,0xbf,0xc7,0xa3,0x38,0xff,0xff,0xff,0xfb,0x3f,0xf7,0xfb,0xbe, - 0xef,0xff,0xff,0xf3,0x3f,0xe7,0xf3,0x3c,0xff,0xff,0xff,0x53,0x10,0xe7,0xf3, - 0x3c,0xff,0xff,0xff,0x77,0x19,0xe7,0xf3,0x34,0xfd,0xff,0xff,0xf7,0x9f,0xe7, - 0xf3,0x3c,0xe7,0xff,0xff,0xa7,0xb2,0xa7,0xf1,0x3c,0xe7,0xff,0xff,0x7f,0xf2, - 0xf7,0x58,0xbc,0xf7,0xff,0xff,0xdf,0xf7,0xff,0xf7,0xfe,0xfd,0xff,0xff,0xff, - 0x2f,0xde,0xff,0xd7,0xf7,0xff,0xff,0xff,0x67,0xfe,0xff,0xff,0xff,0xff,0xff, - 0xff,0xf7,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xdf,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/quit-dn.xpm --- a/etc/vm/quit-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -/* XPM */ -static char * quit-up_xpm[] = { -"64 42 9 1", -"X c Gray75 s backgroundToolBarColor", -". c Gray60", -"G c Gray60", -"o c Gray60", -"O c Gray60", -"+ c Gray60", -"@ c Gray60", -"# c Gray60", -"$ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXX.GGGGGGoXXXXXXXXXXXXXXXXXX.GGoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXX.GOOoXX.G..oXXXXXXXXXXXXXXXXGOGX+XXX.oXXXXXXXXXXXXXX", -"XXXXXXXXXXX.OOGX@@#$XXo.XXXXXXXXXXXXXXXXGGX##XX.Oo+XXXXXXXXXXXXX", -"XXXXXXXXXXXGO.$@@$XXXXXX$+XXXXXXXXXXXXXXoX#@#XXGO+#XXXXXXXXXXXXX", -"XXXXXXXXXX.OGX#@$XXXX.oX+$XXXXXXXXXXXXXXX+##$X.OG##XXXXXXXXXXXXX", -"XXXXXXXXXXGO.$@#XXXXXo.XX$oGGGoXX.GGGoX.GGGoX.OO.+XoXXXXXXXXXXXX", -"XXXXXXXXXXGGX#@$XXXXXX.oX#$GGGX+XoGGGX+oGGGX+oG.X$$++XXXXXXXXXXX", -"XXXXXXXXXXGGX##XXXXXXXGGX##.oX##XX.oX##X.oX##X.oX#@#$XXXXXXXXXXX", -"XXXXXXXXXXGGX##XXXXXXXGGX##GGX##XXGGX##XGGX##XGGX##XXXXXXXXXXXXX", -"XXXXXXXXXXGGX+$.GGGoX.OGX##GGX##XXGGX##XGGX##XGGX##XXXXXXXXXXXXX", -"XXXXXXXXXXo.XXXoo.G.XGO.$@#GGX##XXGGX##XGGX##XGGX##XXXXXXXXXXXXX", -"XXXXXXXXXXX.oX$#$$XXXGGX#@$GGX##XXGGX##XGGX##XGGX##.oXXXXXXXXXXX", -"XXXXXXXXXXXo.X+++X.oXo.$@#XGGX+$X.OGX##XGGX##XGGX##Go+XXXXXXXXXX", -"XXXXXXXXXXXXX$+o..OGX$#@@$Xo.XXX..G.X+$.OGX+$Xo.X+X.+#XXXXXXXXXX", -"XXXXXXXXXXXXX+$$#$XoX#@#$XXXX$##$++$###Xo+###+XX$#$+$$XXXXXXXXXX", -"XXXXXXXXXXXXXXX+###Xo+$.oXXXX+####$+###$+####$XX+###$XXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXGGXXGo+XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXo.XX+$#XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX$#@@$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX+##$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/quit-up.xbm --- a/etc/vm/quit-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x21,0x00,0x00,0x10,0x00,0x00,0x00, - 0x00,0x4f,0x00,0x00,0x18,0x04,0x00,0x00,0xe0,0x03,0x03,0x00,0x1d,0x06,0x00, - 0x00,0xc0,0x01,0x02,0x00,0x1e,0x06,0x00,0x00,0xe0,0x20,0x02,0x20,0x00,0x02, - 0x00,0x00,0x60,0x80,0x86,0x82,0xb0,0x1c,0x00,0x00,0x68,0x00,0xd6,0x68,0x1a, - 0x0e,0x00,0x00,0x60,0x00,0xc6,0x60,0x18,0x06,0x00,0x00,0x40,0x00,0xc6,0x60, - 0x18,0x06,0x00,0x00,0x04,0x09,0xc7,0x60,0x18,0x06,0x00,0x00,0xd0,0x03,0xc7, - 0x60,0x18,0x06,0x00,0x00,0x80,0xa0,0x83,0x60,0x18,0x26,0x00,0x00,0x60,0xe2, - 0x13,0x48,0x90,0x30,0x00,0x00,0xc0,0xe3,0xe1,0x77,0x3e,0x3f,0x00,0x00,0x80, - 0x27,0xc0,0xff,0x1f,0x0e,0x00,0x00,0x00,0x00,0x02,0x00,0x00,0x00,0x00,0x00, - 0x00,0x90,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x03,0x00,0x00,0x00,0x00, - 0x00,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/quit-up.xpm --- a/etc/vm/quit-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -/* XPM */ -static char * quit-up_xpm[] = { -"64 42 10 1", -"X c Gray75 s backgroundToolBarColor", -"x c Gray75", -". c #BEBEBEBEBEBE", -"G c #DEDEDEDEDEDE", -"o c #9E9E9E9E9E9E", -"O c #FEFEFEFEFEFE", -"+ c #606060606060", -"@ c #000000000000", -"# c #202020202020", -"$ c #404040404040", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXX.GGGGGGoXXXXXXXXXXXXXXXXXX.GGoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXX.GOOoxx.G..oXXXXXXXXXXXXXXXXGOGx+XXX.oXXXXXXXXXXXXXX", -"XXXXXXXXXXX.OOGx@@#$xxo.XXXXXXXXXXXXXXXXGGx##XX.Oo+XXXXXXXXXXXXX", -"XXXXXXXXXXXGO.$@@$XXXxxx$+XXXXXXXXXXXXXXox#@#XXGO+#XXXXXXXXXXXXX", -"XXXXXXXXXX.OGx#@$XXXX.ox+$XXXXXXXXXXXXXXX+##$X.OG##XXXXXXXXXXXXX", -"XXXXXXXXXXGO.$@#XXXXXo.xx$oGGGoXX.GGGoX.GGGoX.OO.+xoXXXXXXXXXXXX", -"XXXXXXXXXXGGx#@$XXXXXX.ox#$GGGx+XoGGGX+oGGGX+oG.x$$++XXXXXXXXXXX", -"XXXXXXXXXXGGx##XXXXXXXGGx##.ox##XX.ox##X.ox##X.ox#@#$XXXXXXXXXXX", -"XXXXXXXXXXGGx##XXXXXXXGGx##GGx##XXGGx##XGGx##XGGx##XXXXXXXXXXXXX", -"XXXXXXXXXXGGx+$.GGGox.OGx##GGx##XXGGx##XGGx##XGGx##XXXXXXXXXXXXX", -"XXXXXXXXXXo.xxxoo.G.xGO.$@#GGx##XXGGx##XGGx##XGGx##XXXXXXXXXXXXX", -"XXXXXXXXXXX.ox$#$$xxxGGx#@$GGx##XXGGx##XGGx##XGGx##.oXXXXXXXXXXX", -"XXXXXXXXXXXo.x+++X.oxo.$@#XGGx+$X.OGx##XGGx##XGGx##Go+XXXXXXXXXX", -"XXXXXXXXXXXXX$+o..OGx$#@@$Xo.xxx..G.x+$.OGx+$Xo.x+x.+#XXXXXXXXXX", -"XXXXXXXXXXXXX+$$#$xox#@#$XXXX$##$++$###Xo+###+XX$#$+$$XXXXXXXXXX", -"XXXXXXXXXXXXXXX+###xo+$.oXXXX+####$+###$+####$XX+###$XXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXGGxxGo+XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXo.xx+$#XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX$#@@$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX+##$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/quit-xx.xbm --- a/etc/vm/quit-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x10,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x03,0x01,0x00,0x1c,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x20,0x02,0x20,0x00,0x02, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x00,0xd6,0x68,0x9a, - 0x1e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x00,0xc6,0x60, - 0x18,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x03,0xc7, - 0x60,0x18,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20,0xe0, - 0x03,0x60,0x18,0x32,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, - 0x57,0xe1,0xff,0x3e,0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xe0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/recover-dn.xbm --- a/etc/vm/recover-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xfa, - 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x6f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfd,0xff,0xff,0xff,0xff,0xff,0xff, - 0xef,0xfe,0xff,0xff,0xff,0xff,0xff,0x7f,0xdf,0x75,0xff,0xff,0xff,0xff,0xff, - 0xdf,0xb5,0xae,0xfb,0xff,0xff,0xff,0xff,0x5f,0xef,0x7d,0xfd,0xff,0xff,0xff, - 0xff,0xef,0x5a,0xab,0xff,0xff,0xff,0xff,0xff,0xbf,0xf7,0xde,0xfa,0xff,0xff, - 0xff,0xff,0xdf,0x5a,0x6b,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xff,0xaf,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfb,0xff, - 0xff,0xff,0xff,0xff,0xff,0xef,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfd, - 0xff,0xff,0xff,0xff,0xff,0xff,0xdf,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xbf, - 0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xce, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xce,0x70,0x38,0xcc,0x19,0x26,0xff,0x7f, - 0x4e,0x26,0x93,0xc9,0xc9,0x04,0xff,0x7f,0x60,0x26,0x9f,0x99,0xcc,0xc4,0xff, - 0x7f,0x66,0x20,0x9f,0x99,0x0c,0xe4,0xff,0x7f,0x4e,0x3e,0x9f,0x39,0xce,0xe7, - 0xff,0x7f,0x4e,0x26,0x93,0x39,0xce,0xe4,0xff,0x7f,0xce,0x70,0x38,0x7c,0x1f, - 0xe6,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/recover-dn.xpm --- a/etc/vm/recover-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * recover-up_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"# c Gray60", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXooXXXooXXooooXXooXooXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXooXXXooXooXXooXoooooXXXXXXXX", -"XXXXXXXooooooXXooXXooXooXXXXXooXXooXXooXooXXooXXooXoooXXXXXXXXXX", -"XXXXXXXooXXooXXooooooXooXXXXXooXXooXXooXooXXooooooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXXXXooXXXXXooXXooXXXoooXXXooXXXXXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXXXoooXXXooXXooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXXXXoXXXXXooooXXooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/recover-up.xbm --- a/etc/vm/recover-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xb0,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x06, - 0x00,0x00,0x00,0x00,0x00,0x00,0x50,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0xf0, - 0x06,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x03,0x00,0x00,0x00,0x00,0x00,0x00, - 0xf0,0x06,0x00,0x00,0x00,0x00,0x00,0x70,0xab,0x7d,0x07,0x00,0x00,0x00,0x00, - 0xd0,0x7e,0xab,0x03,0x00,0x00,0x00,0x00,0xd0,0xd5,0xdd,0x06,0x00,0x00,0x00, - 0x00,0x60,0x7b,0xb7,0x05,0x00,0x00,0x00,0x00,0xb0,0xad,0xdd,0x06,0x00,0x00, - 0x00,0x00,0x60,0xef,0xb6,0x03,0x00,0x00,0x00,0x00,0x00,0xb0,0x03,0x00,0x00, - 0x00,0x00,0x00,0x00,0xd0,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0xd0,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0xb0, - 0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x31, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x31,0x8f,0xc7,0x33,0xe6,0xd9,0x00,0x80, - 0xb1,0xd9,0x6c,0x36,0x36,0xfb,0x00,0x80,0x9f,0xd9,0x60,0x66,0x33,0x3b,0x00, - 0x80,0x99,0xdf,0x60,0x66,0xf3,0x1b,0x00,0x80,0xb1,0xc1,0x60,0xc6,0x31,0x18, - 0x00,0x80,0xb1,0xd9,0x6c,0xc6,0x31,0x1b,0x00,0x80,0x31,0x8f,0xc7,0x83,0xe0, - 0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/recover-up.xpm --- a/etc/vm/recover-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * recover-up_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"# c red", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXooXXXooXXooooXXooXooXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXooXXXooXooXXooXoooooXXXXXXXX", -"XXXXXXXooooooXXooXXooXooXXXXXooXXooXXooXooXXooXXooXoooXXXXXXXXXX", -"XXXXXXXooXXooXXooooooXooXXXXXooXXooXXooXooXXooooooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXXXXooXXXXXooXXooXXXoooXXXooXXXXXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXXXoooXXXooXXooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXXXXoXXXXXooooXXooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/recover-xx.xbm --- a/etc/vm/recover-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xf0,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x07,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0xd7,0xba,0x07,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0xbe,0xb7,0x02,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x6a,0xed,0x07,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xb0,0x03,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xb0,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0, - 0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x31, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, - 0xb1,0xd9,0x6c,0x36,0x36,0xfb,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x80,0x99,0xdf,0x60,0x66,0xf3,0x1b,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0xb1,0xd9,0x6c,0xc6,0x31,0x1b,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/reply-dn.xbm --- a/etc/vm/reply-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x01,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xe7,0xff, - 0xff,0xff,0xff,0xff,0xff,0xfd,0xd7,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0x87, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0x0f,0x00, - 0x00,0xf0,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x2f, - 0xff,0x7f,0xf4,0xff,0xff,0xff,0xff,0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff, - 0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff,0xef,0x03,0x78,0xf4,0xff,0xff,0xff, - 0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x03,0xfe,0xf7,0xff,0xff, - 0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x83,0xff,0xf7,0xff, - 0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7, - 0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x0f,0x00,0x00, - 0xf0,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc0,0xff,0x3f,0xff,0xff,0xff,0xff,0xff, - 0x9c,0xff,0x3f,0xff,0xff,0xff,0xff,0xff,0x9c,0x61,0x32,0x39,0xff,0xff,0xff, - 0xff,0x9c,0x4c,0x24,0x39,0xff,0xff,0xff,0xff,0xc0,0x4c,0x26,0x93,0xff,0xff, - 0xff,0xff,0xcc,0x40,0x26,0x93,0xff,0xff,0xff,0xff,0x9c,0x7c,0x26,0xc7,0xff, - 0xff,0xff,0xff,0x9c,0x4c,0x24,0xc7,0xff,0xff,0xff,0xff,0x9c,0x61,0x32,0xcf, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xfe,0xef,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe, - 0xe7,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe,0xf3,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/reply-dn.xpm --- a/etc/vm/reply-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * reply_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXooXXooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXooXXooooooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXXXXooXXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXXXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/reply-up.xbm --- a/etc/vm/reply-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x18,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x78, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0xf0,0xff, - 0xff,0x0f,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xd0, - 0x00,0x80,0x0b,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3f,0x00,0xc0,0x00,0x00,0x00,0x00,0x00, - 0x63,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x63,0x9e,0xcd,0xc6,0x00,0x00,0x00, - 0x00,0x63,0xb3,0xdb,0xc6,0x00,0x00,0x00,0x00,0x3f,0xb3,0xd9,0x6c,0x00,0x00, - 0x00,0x00,0x33,0xbf,0xd9,0x6c,0x00,0x00,0x00,0x00,0x63,0x83,0xd9,0x38,0x00, - 0x00,0x00,0x00,0x63,0xb3,0xdb,0x38,0x00,0x00,0x00,0x00,0x63,0x9e,0xcd,0x30, - 0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x10,0x00,0x00,0x00,0x00,0x00,0x80,0x01, - 0x18,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x0c,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/reply-up.xpm --- a/etc/vm/reply-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * reply_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXooXXooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXooXXooooooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXXXXooXXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXXXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/reply-xx.xbm --- a/etc/vm/reply-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x63,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x63,0xb3,0xdb,0xc6,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x33,0xbf,0xd9,0x6c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x63,0xb3,0xdb,0x38,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x10,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x0c,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/stuffed_box-colorful.xpm --- a/etc/vm/stuffed_box-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,291 +0,0 @@ -/* XPM */ -static char *stuffed_box[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 254 2", -/* colors */ -".. c #000000", -".# c #b1b1b1", -".a c #242120", -".b c #505955", -".c c #491909", -".d c #3e1608", -".e c #a9a9a9 s background", -".f c #eeeef0", -".g c #a7a7a7", -".h c #a3411c", -".i c #663622", -".j c #5c210b", -".k c #a83e17", -".l c #2f2824", -".m c #9f7b71", -".n c #d38141", -".o c #a3a3a3", -".p c #d27f40", -".q c #a1a1a1", -".r c #511c0a", -".s c #ccc1be", -".t c #9d9d9d", -".u c #cd773b", -".v c #903a13", -".w c #592a15", -".x c #1e1d1d", -".y c #cdcccc", -".z c #959595", -".A c #939393", -".B c #e8ac69", -".C c #919191", -".D c #8f8f8f", -".E c #8d8d8d", -".F c #240e05", -".G c #652810", -".H c #a55f3b", -".I c #878787", -".J c #f2f1f0", -".K c #a0491f", -".L c #8a4a27", -".M c #0c0401", -".N c #efbf80", -".O c #7d7d7d", -".P c #3d3531", -".Q c #2a0b04", -".R c #7b7b7b", -".S c #81401e", -".T c #797979", -".U c #adacac", -".V c #904d26", -".W c #eab071", -".X c #11132a", -".Y c #737373", -".Z c #999695", -".0 c #ab4119", -".1 c #d16d31", -".2 c #b3b8b5", -".3 c #030305", -".4 c #212129", -".5 c #b74c1e", -".6 c #ca7b41", -".7 c #696969", -".8 c #404644", -".9 c #2d1e17", -"#. c #656565", -"## c #8b3417", -"#a c #dfae7d", -"#b c #f5eeef", -"#c c #5e260f", -"#d c #d58445", -"#e c #5f5f5f", -"#f c #763416", -"#g c #5a200b", -"#h c #301006", -"#i c #7a2f10", -"#j c #edb87a", -"#k c #4e1b09", -"#l c #da8e4d", -"#m c #8b8a8a", -"#n c #d97435", -"#o c #d58648", -"#p c #32160b", -"#q c #fefefe", -"#r c #e8ad6b", -"#s c #020000", -"#t c #474747", -"#u c #bfbfc0", -"#v c #4f505c", -"#w c #6b280e", -"#x c #fcdf9c", -"#y c #e39e5c", -"#z c #160803", -"#A c #3f3f3f", -"#B c #61230e", -"#C c #140601", -"#D c #3c0e04", -"#E c #7e3010", -"#F c #eaeaea", -"#G c #a4a3a2", -"#H c #bb5121", -"#I c #cd642c", -"#J c #b94f1f", -"#K c #cb622a", -"#L c #333333", -"#M c #d88747", -"#N c #110601", -"#O c #d58344", -"#P c #070301", -"#Q c #511e0b", -"#R c #bf9f84", -"#S c #d2d2d2", -"#T c #6f290e", -"#U c #eed6b2", -"#V c #c55c27", -"#W c #441708", -"#X c #bab8b7", -"#Y c #e9ae6b", -"#Z c #823110", -"#0 c #171717", -"#1 c #eccba6", -"#2 c #51200e", -"#3 c #a33c16", -"#4 c #983915", -"#5 c #7f6352", -"#6 c #eab26f", -"#7 c #361207", -"#8 c #bd5222", -"#9 c #d0672e", -"a. c #a35326", -"a# c #da8f52", -"aa c #aaaaaa", -"ab c #a8a8a8", -"ac c #a6a6a6", -"ad c #a4a4a4", -"ae c #d38041", -"af c #303246", -"ag c #a2a2a2", -"ah c #b85020", -"ai c #d17e3f", -"aj c #521d0b", -"ak c #a0a0a0", -"al c #e6a764", -"am c #d07c3e", -"an c #cf7a3d", -"ao c #9e9e9e", -"ap c #9c9c9c", -"aq c #c75d28", -"ar c #1b0a03", -"as c #d88a49", -"at c #433f3e", -"au c #989898", -"av c #65250d", -"aw c #969696", -"ax c #0a0806", -"ay c #949494", -"az c #581e0a", -"aA c #c6c5c5", -"aB c #909090", -"aC c #d67d3d", -"aD c #9ea0a1", -"aE c #121211", -"aF c #db7838", -"aG c #414249", -"aH c #8a8a8a", -"aI c #d88c4c", -"aJ c #b0461b", -"aK c #28322d", -"aL c #4f5150", -"aM c #833613", -"aN c #848484", -"aO c #361306", -"aP c #808080", -"aQ c #551e0a", -"aR c #762d10", -"aS c #837b79", -"aT c #17110f", -"aU c #cfcfd4", -"aV c #943413", -"aW c #767676", -"aX c #98534f", -"aY c #ad461b", -"aZ c #727272", -"a0 c #1c1917", -"a1 c #c06a34", -"a2 c #6c6c6c", -"a3 c #722b0f", -"a4 c #c96029", -"a5 c #9a9999", -"a6 c #60616a", -"a7 c #67240e", -"a8 c #764a37", -"a9 c #3b1407", -"b. c #504e4d", -"b# c #100601", -"ba c #e7aa67", -"bb c #f4e0b9", -"bc c #d4d6d5", -"bd c #423028", -"be c #545454", -"bf c #d66f32", -"bg c #c05623", -"bh c #d36b2f", -"bi c #d2692e", -"bj c #4a4a4a", -"bk c #762e0f", -"bl c #461d0e", -"bm c #56150a", -"bn c #6c290f", -"bo c #ecb472", -"bp c #c58859", -"bq c #404040", -"br c #5f220c", -"bs c #3a3a3a", -"bt c #cd652c", -"bu c #363636", -"bv c #e7e7e7", -"bw c #732c0f", -"bx c #fee4a1", -"by c #68270e", -"bz c #dfdfdf", -"bA c #7a3819", -"bB c #2c2c2c", -"bC c #dbdbdb", -"bD c #f0ece9", -"bE c #d48243", -"bF c #282828", -"bG c #4e4b4a", -"bH c #5c5b5b", -"bI c #988f8c", -"bJ c #de7c39", -"bK c #b54c1e", -"bL c #b44a1d", -"bM c #b3481c", -"bN c #342f2d", -"bO c #220701", -"bP c #c45b26", -"bQ c #190802", -"bR c #c35925", -"bS c #d56c30", -"bT c #3f3d3b", -"bU c #e0803e", -"bV c #fbfafa", -"bW c #dd9252", -"bX c #afb0b6", -"bY c #772b0f", -"bZ c #f7f6f6", -"b0 c #220b04", -"b1 c #0e0e0e", -"b2 c #cb763d", -"b3 c #dd9b5f", -"b4 c #ad4219", -"b5 c #fadb99", -"b6 c #67756f", -"b7 c #e9e8e8", -/* pixels */ -".e.e.e.e.e.e.e.e.e.e.e.e.o.e.e.e.e.e.e.e.e.e.e.e", -".e.e.e.e.e.e.e.e.e.e.e.o.2.Z.m.o.e.e.e.e.o.o.e.e", -".e.e.e.e.e.e.e.e.e.e.obcbZ.6bp.H.m.o.e.e.e.s.o.o", -".e.e.e.e.e.e.e.e.e.e.fbZbZbbbc.Nbp.H.map.2.mbZbz", -".e.e.e.e.e.e.e.e.e.e#RbIbc#b.qbp.W.Bbpa.a8.YaA.7", -".e.e.e.e.e.e.e.ebIa8.y.sbD#S.Ibe.L.B#rbob3.Lbl.o", -".e.e.e.e.e.e.o#5a1#abe.y.o.qb.#e.q#U.Nbobob5.w.e", -".e.e.e.e.ebI.H.n#RbI.q#eaPbdb..o.I#X.N.W.N#lbl.e", -".e.e.e.oaXa1.nai.Vblb.#..9.x.Rbc#S.i#a.N#daF.d.e", -".e.e.e.ia1bU.uai.n.6bdbs.3#z.dbI#jal.N#n#n.SaLaA", -".e.e.e#W#c.Hai.u.6a#.m.3a8aI.H.Hal.N#n.1.Sat#XbI", -".e.e.e#W.v.j.V.uai.n#l.6bpas#lal#1#n#I.S.vbnaTaN", -".e.e.e.Q.v.v#w.Ga1.u#d#das#lbW.N#I#I.S#Z.1#Ibl.e", -".e.e.e.9bO#T.v#Z.j.H.u.n.na#.N.u#V.v.F#Ra#.1.9.U", -".e.e.e.P#haE.G.v.v.jbA.ua#.N.ubg.haTb.#b#obfbl.e", -".e.e.A.o#SbHbF#p#T.v#E.Gbpa4#HbnaTaLbIbp#Va.bT.U", -".e.e.e.IbcaubH#7#7.j.v#i.v.5#E##bY.v.h#V#Hbdak.e", -".e.e.eb.a8#S.9.G#ibl.d#T##.vaY#H.5.5bgbgblaN.q.e", -".e.e.eb..Ga8.i#ZbYbY.j.Q.jaY.5.5#H#H.m.w.7.o.e.e", -".e.e.ebGbYbn#w#i#T#T#T.j#ZaJ.5.5.5.S.y#u.A.o.e.e", -".e.e.oaL.d#Tbn#T#T#T#w.G#ZaY.5.h.i.Dbz.fbV.y#u.o", -".e.eapbHaxbObTa2#T#w.G.j#iaYaYb..2aua6.Obzbz#q.2", -".e.e.o.RaL.a.q.Ube#w.j.jaR.k#4#h#A.o.Dbzau#qbcap", -".e.eapaN#Aa2.ybv#Xa8#g#g#T.k#Z.PbG#L.o.2.2bZ.A.o", -".o.I.Aak.fbZbXaZbz#.#gbl#T##bd.IaNbH#L.Obz.2.z.e", -".Aa2.Rbz.eaAaDaNaU.lax.d.j.9aP.q.e.AbHbsa2aN.o.e", -"ap.Y#AaA#S.o.DbZ.obebBb1aTaS.o.e.e.o.Ia2.Yap.e.e", -".o.AbHbeaAaU.faA.I.I.7be.Rak.e.e.e.e.eap.o.e.e.e", -".e.o.Ibe#A#u.e.R.o.oap.A.o.e.e.e.e.e.e.e.e.e.e.e", -".e.e.oaNbHbe.R.o.e.e.e.e.e.e.e.e.e.e.e.e.e.e.e.e" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/stuffed_box-simple.xpm --- a/etc/vm/stuffed_box-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 9 1", -/* colors */ -"` c #A9A9A9 s background", -"- c #A9A9A9", -"a c #A83E17", -"b c #030305", -"c c #DA8E4D", -"d c #FEFEFE", -"e c #60616A", -"f c #423028", -"g c #FADB99", -/* pixels */ -"````````````````````````", -"``````````````e`````````", -"```````````ddccae```````", -"``````````dddgdgcae``edd", -"`````````---dd-ccccafe`e", -"`````````f--dg-eaccccaf`", -"```````ecce---ee-ggccgf`", -"``````ac---eefe---gcgcf`", -"````acccafeeffedgfcgccf`", -"```fccccccffbbf-gcgccae`", -"```ffaccccebfcaacgccaf-`", -"```fafacccccccccgccaafbe", -"```baaffcccccccgccaaccf`", -"```fbfaafaccccgcaab-ccf`", -"```fbbfaafaccgcaabedccf`", -"```-gefffaafcaafbe-caaf`", -"```-d-efffaaaaaaaaaaaf``", -"```efgffafffaaaaaaaafe``", -"```efffaaafbfaaaaaefe```", -"```eaffaffffaaaaaa--````", -"```effffffffaaaaf-ddd```", -"```ebbfeffffaaae--eeddd`", -"```eef--efffaaabf--d-dd`", -"```efe-d-ffffaafef---d``", -"```-dd-edefffaf`eefed```", -"`eed---e-fbfffe```efee``", -"`ef-g--d-efbbe`````ee```", -"``ee--d---eee```````````", -"```ef--e````````````````", -"```eeee`````````````````" -}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/undelete-dn.xbm --- a/etc/vm/undelete-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0xf8, - 0xf5,0xff,0xff,0xff,0xff,0xff,0xfd,0xbb,0xfa,0xff,0xff,0xff,0xff,0x5f,0xf5, - 0x5b,0xfd,0xff,0xff,0xff,0xff,0xaf,0xaa,0x8b,0xff,0xff,0xff,0xff,0xff,0xff, - 0x55,0x97,0xff,0xff,0xff,0xff,0xff,0xff,0xbd,0xba,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7d,0xbd,0xff,0xff,0xff,0xff,0xff,0xff,0xbd,0xaa,0xff,0xff,0xff,0xff, - 0xff,0xff,0x5d,0x97,0xff,0xff,0xff,0xff,0xff,0xff,0xad,0xaf,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xd5,0x3f,0xfd,0xff,0xff,0xff,0xff,0xff,0xe9,0xbf,0xfa,0xff, - 0xff,0xff,0xff,0xff,0xf5,0xbf,0xf5,0xff,0xff,0xff,0xff,0xbf,0xfc,0xbf,0xeb, - 0xff,0xff,0xff,0xff,0x5f,0xfd,0xbf,0xd7,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x9f,0xf3,0xff,0xfc,0xf3,0x9f,0xff,0xff,0x9f,0xf3, - 0xff,0xfc,0xf3,0x9f,0xff,0xff,0x9f,0x93,0x9c,0x0c,0x33,0x0c,0xc3,0xff,0x9f, - 0x13,0x49,0x64,0x92,0x99,0x99,0xff,0x9f,0x93,0xc9,0x64,0x92,0x99,0x99,0xff, - 0x9f,0x93,0xc9,0x04,0x12,0x98,0x81,0xff,0x9f,0x93,0xc9,0xe4,0x93,0x9f,0xf9, - 0xff,0x3f,0x99,0x49,0x64,0x92,0x99,0x98,0xff,0x3f,0x98,0x99,0x0c,0x33,0x3c, - 0xc3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/undelete-dn.xpm --- a/etc/vm/undelete-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * undelete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOoOXXoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOoOOOOOOo+OoXoXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoXoXoXoOoOoOOOo+oooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOoOoOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOoOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoOoOOOOOoOoXoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOOOOOOOOooXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooOoOOOOOOOOOoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOOOOOOOOOOoXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoXooOOOOOOOOOOOOoXXXoXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOOOOOOOOOOOOoXXXXoXoXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXooXooXXXooXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXX", -"XXXXXooXXXooXoooXooXooXoooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooooooXooXooooooXXooXXooooooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXX", -"XXXXXXooXooXXooXXooXooXoooXooXXooXooXooXXooXXooXoooXXooXXXXXXXXX", -"XXXXXXoooooXXooXXooXXooXooXXooooXXooXXooooXXXXooXXooooXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/undelete-up.xbm --- a/etc/vm/undelete-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0a,0x00,0x00,0x00,0x00,0x00,0x02,0x44,0x05,0x00,0x00,0x00,0x00,0xa0,0x0a, - 0xa4,0x02,0x00,0x00,0x00,0x00,0x50,0x55,0x74,0x00,0x00,0x00,0x00,0x00,0x00, - 0xaa,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x42,0x45,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x42,0x00,0x00,0x00,0x00,0x00,0x00,0x42,0x55,0x00,0x00,0x00,0x00, - 0x00,0x00,0xa2,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x52,0x50,0x01,0x00,0x00, - 0x00,0x00,0x00,0x2a,0xc0,0x02,0x00,0x00,0x00,0x00,0x00,0x16,0x40,0x05,0x00, - 0x00,0x00,0x00,0x00,0x0a,0x40,0x0a,0x00,0x00,0x00,0x00,0x40,0x03,0x40,0x14, - 0x00,0x00,0x00,0x00,0xa0,0x02,0x40,0x28,0x00,0x00,0x00,0x00,0x00,0x02,0x40, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x60,0x0c,0x00,0x03,0x0c,0x60,0x00,0x00,0x60,0x0c, - 0x00,0x03,0x0c,0x60,0x00,0x00,0x60,0x6c,0x63,0xf3,0xcc,0xf3,0x3c,0x00,0x60, - 0xec,0xb6,0x9b,0x6d,0x66,0x66,0x00,0x60,0x6c,0x36,0x9b,0x6d,0x66,0x66,0x00, - 0x60,0x6c,0x36,0xfb,0xed,0x67,0x7e,0x00,0x60,0x6c,0x36,0x1b,0x6c,0x60,0x06, - 0x00,0xc0,0x66,0xb6,0x9b,0x6d,0x66,0x67,0x00,0xc0,0x67,0x66,0xf3,0xcc,0xc3, - 0x3c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/undelete-up.xpm --- a/etc/vm/undelete-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * undelete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOoOXXoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOoOOOOOOo+OoXoXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoXoXoXoOoOoOOOo+oooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOoOoOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOoOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoOoOOOOOoOoXoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOOOOOOOOooXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooOoOOOOOOOOOoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOOOOOOOOOOoXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoXooOOOOOOOOOOOOoXXXoXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOOOOOOOOOOOOoXXXXoXoXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXooXooXXXooXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXX", -"XXXXXooXXXooXoooXooXooXoooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooooooXooXooooooXXooXXooooooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXX", -"XXXXXXooXooXXooXXooXooXoooXooXXooXooXooXXooXXooXoooXXooXXXXXXXXX", -"XXXXXXoooooXXooXXooXXooXooXXooooXXooXXooooXXXXooXXooooXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/undelete-xx.xbm --- a/etc/vm/undelete-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0a,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x0a, - 0xa4,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xaa,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x42,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xa2,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x2a,0xc0,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x0a,0x40,0x0a,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xa0,0x02,0x40,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x60,0x0c,0x00,0x03,0x0c,0x60,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x6c,0x63,0xf3,0xcc,0xf3,0x3c,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x6c,0x36,0x9b,0x6d,0x66,0x66,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x6c,0x36,0x1b,0x6c,0x60,0x06, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x67,0x66,0xf3,0xcc,0xc3, - 0x3c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/visit-dn.xbm --- a/etc/vm/visit-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfb, - 0xf3,0xf9,0xff,0xff,0xff,0xff,0x7f,0x74,0x34,0xfa,0xff,0xff,0xff,0xff,0x9f, - 0x87,0xc3,0xfb,0xff,0xff,0xff,0xff,0xdf,0x7f,0xfc,0xfd,0xff,0xff,0xff,0xff, - 0xbf,0x9f,0xff,0xfd,0xff,0xff,0xff,0xff,0xbf,0xdf,0xe3,0xfe,0xff,0xff,0xff, - 0xff,0xbf,0x5f,0xfc,0xfe,0xff,0xff,0xff,0xff,0x7f,0xef,0xff,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0xef,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x36,0x1f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xf6,0xe3,0xff,0xff,0xff,0xff,0xff,0xff,0x76,0xfc,0xff, - 0xff,0xff,0xff,0xff,0xff,0x89,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf1,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xe1,0x9f,0xf9,0xff,0xff,0xff,0xff, - 0xe7,0xf9,0xff,0xf9,0xff,0xff,0xff,0xff,0xcf,0x64,0x98,0xf0,0xff,0xff,0xff, - 0xff,0xcf,0x24,0x93,0xf9,0xff,0xff,0xff,0xff,0xcf,0x24,0x9e,0xf9,0xff,0xff, - 0xff,0xff,0xdf,0xe6,0x98,0xf9,0xff,0xff,0xff,0xff,0x1f,0xe6,0x91,0xf9,0xff, - 0xff,0xff,0xff,0x3f,0x27,0x93,0xe9,0xff,0xff,0xff,0xff,0x3f,0x67,0x98,0xf3, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/visit-dn.xpm --- a/etc/vm/visit-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * visit_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXooXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooOoXXXoooOoXXooo+oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooOOOOooooOOOoooo++++oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooo+++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOoo++++++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo++++ooo+++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo+ooo++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++++++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++oo+++++oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++oo+++++oooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++++++oooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo+++oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoo+oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooooXXXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXXooooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXooXXooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXoooXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXXoXXooXXXoooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooXXooXXXXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/visit-up.xbm --- a/etc/vm/visit-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x04, - 0x0c,0x06,0x00,0x00,0x00,0x00,0x80,0x8b,0xcb,0x05,0x00,0x00,0x00,0x00,0x60, - 0x78,0x3c,0x04,0x00,0x00,0x00,0x00,0x20,0x80,0x03,0x02,0x00,0x00,0x00,0x00, - 0x40,0x60,0x00,0x02,0x00,0x00,0x00,0x00,0x40,0x20,0x1c,0x01,0x00,0x00,0x00, - 0x00,0x40,0xa0,0x03,0x01,0x00,0x00,0x00,0x00,0x80,0x10,0x00,0x01,0x00,0x00, - 0x00,0x00,0x80,0x10,0x83,0x00,0x00,0x00,0x00,0x00,0x00,0xc9,0xe0,0x00,0x00, - 0x00,0x00,0x00,0x00,0x09,0x1c,0x00,0x00,0x00,0x00,0x00,0x00,0x89,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0x76,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0e,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x18,0x1e,0x60,0x06,0x00,0x00,0x00,0x00, - 0x18,0x06,0x00,0x06,0x00,0x00,0x00,0x00,0x30,0x9b,0x67,0x0f,0x00,0x00,0x00, - 0x00,0x30,0xdb,0x6c,0x06,0x00,0x00,0x00,0x00,0x30,0xdb,0x61,0x06,0x00,0x00, - 0x00,0x00,0x20,0x19,0x67,0x06,0x00,0x00,0x00,0x00,0xe0,0x19,0x6e,0x06,0x00, - 0x00,0x00,0x00,0xc0,0xd8,0x6c,0x16,0x00,0x00,0x00,0x00,0xc0,0x98,0x67,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/visit-up.xpm --- a/etc/vm/visit-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * visit_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXooXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooOoXXXoooOoXXooo+oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooOOOOooooOOOoooo++++oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooo+++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOoo++++++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo++++ooo+++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo+ooo++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++++++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++oo+++++oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++oo+++++oooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++++++oooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo+++oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoo+oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooooXXXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXXooooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXooXXooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXoooXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXXoXXooXXXoooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooXXooXXXXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/vm/visit-xx.xbm --- a/etc/vm/visit-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x04, - 0x0c,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60, - 0x78,0x3c,0x04,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x40,0x60,0x00,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x40,0xa0,0x03,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x80,0x10,0x83,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x09,0x1c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x76,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x18,0x1e,0x60,0x06,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x30,0x9b,0x67,0x0f,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x30,0xdb,0x61,0x06,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x19,0x6e,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x98,0x67,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r d3e9274cbc4e -r e45d5e7c476e etc/wing.xpm.Z Binary file etc/wing.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/wingm.xpm.Z Binary file etc/wingm.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/wmperry.xpm.Z Binary file etc/wmperry.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/wmperrym.xpm.Z Binary file etc/wmperrym.xpm.Z has changed diff -r d3e9274cbc4e -r e45d5e7c476e etc/xemacs-beta.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/xemacs-beta.xpm Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,170 @@ +/* XPM */ +static char *magick[] = { +/* columns rows colors chars-per-pixel */ +"388 145 19 1", +" c #090909090b0b", +". c #2ef52ef52f89", +"X c #131315154c4c", +"o c #7e7e00000000", +"O c #50e450e451e5", +"+ c #6f5c6f5c705d", +"@ c #232327278888", +"# c #36363a3acccc", +"$ c #48704e4ed384", +"% c #68f76cfbddbc", +"& c #99d200000000", +"* c #af5000000000", +"= c #d23a00000000", +"- c #f5e900000000", +"; c #912a912a922b", +": c None", +"> c #8d5e9162eb8a", +", c #b3c7b7cbf93d", +"< c #d6dbd706d9dc", +/* pixels */ +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::<:::::::<::::::::::<:::::::::::::::::::::<:::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::<:::::::::::::::::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::<<::::<<<<:::::::::::<<<<<<:::::::::<<::<:::::::::::::::::::::::::::::<:::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::<:<::::::::::<::::::::<::::::<:::::<::<:::::::::::::::::::<:::::::<::::<:<:::::::<:::::<:<<:::::::::<:::<:::::<:::::::::::::<:::::::::::::<::::::::<::::::<:::::<::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::<<::<<<<<::::::::::<<<<:::<<<<<:::<<<<:::::<<<::::::::::<:::::::<:::::::<<:::::::::::<<<<<:::<<<::::::::::<<<<<<::<<<<<:::<<<<<::<<<<<::::::::::<<<<:::<<<<<::<<<<<:::<::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::<:::<::<<<<<<::<:::<::<:::<::<::::<::<::::::::::::::::::::::<::::::<<<<::::<::::<<<<<::::::::::<<<<<<:<<:<:<::<::::::<::::<:<<<<<<::<<<<<:::<::<::<::::<::<::::<::<<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::<::::::::::<:::<::<::::<:<::::<::<<<::::::::::::::::::::<::<::<:::<::::<::::<<<:<<:::::<::::::::::<<:<:<::<::::<:<::::<:<<<<<<::::::::::<::<::<::::<::<::::<::<<<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::<<::<::::::::::::::<:::<::<<::<::<<::<<::<::<:::::::::::::::::::<::<::<::<<::::<::::::::::::<:::<:::::::::<<:<:<::<<:<:::<<::<<:::::::::::::::::<::<:::<::<<::<<::<:::<:<<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::<::<::<<<<<::::::::<:::<::::<::<:::<::<::<<::::::::::::::::::::<:::::::<::::<::<::<::::::<::<:<:<:<:::::::<:<:::<<::<:<::::<:<::<::<:<::::::::::<::::::::<:<::::<::::::<:<:<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<::::::::::::::<:::<:::::::::<:<::::::::::<::::::::::::::::::::::::::::::::::::::::::::::<::<:::::::::::::::::::::::::::::::::::::<::::::::::::::::<::::::::::<:::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::<::::::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::<::::::::::::::<:::::::::::<::::::<::::::::::::<::<:::::::::::::::::::::::::::::::::::<:::<:::::::::::::::::::::::::::::::::::::<:::::::::::::::::<:::::::::<::<:::::::::::::<::::<::::::::::::::::::::::::::::::::::::<::::::::::::::::::<:::::::::::::::::::::<:::::::::::::::<:::::::::::<::<:::::::::::::<::::<:::::::::::::::::::::::::::::::::::<::::::::::::::::::::::", +"::::::::::::::::::::::::::<::::::::::::<:<::::::::::::<::::::::::<::<::::::::::::<::::::::::::::::::::::::::::<:::::::::::::::::::<::::::::::<::::::::::<::<:::::::::::<:::::::::::::::<:::::::::<::::<::::::::::<:::::::::::::::::::::::::::::::<::::::::::::<::::::::::::::<::::::::::::<:::::::::::::<::::::::::::::<:::::::::<::::<::::::::::<::::::::::::::::::::::::::::<:::::::::::::::::::::", +"::::::::::::::::::::::<:<:::<::::::::::::::::::::::::::::::::::::::::<:<::<:::::::::::::::::::::::::::::::::::::::<:::::<:<:<:::::<::<::::::::::::::<::::<:::::::::::::::::::::::::::::::::::::::::<:<::::<::::::::::::::::::::::::::::::::::::::::<:::::<:<::::::<::<::::::::::::::<:<:<:::<::::::::::::::::::::::::::::::::::::::<:<::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::<:::::<::<::::::::<:::::::::::::::::<::::<::::::::::::::::<::::::::::::::::::::::::::::::::<:::::::::<:<:::<:::::::<:<:<:::::<::<::<::<::<::::::::<:::::::::::::::::<::::::::<:<:::::::::::::::::::::::::::::::::<:::::::::::<:::::<:::<::<::::::::<:<:<::::::::<:::::<::<::::::::<:::::::::::::::::<::::::::<:<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::<::<:<:<::<::::::::::::::::::::::<::::<::::<::<;;<<::<::::<:::<::::<:::::::::::<<:::::::<::::::<::::<<::::<<:::<::::::::::::::::<::<::<:::<:<::::<:::::::::::::::<::<::<:::::::<::<::<:<::<:<::::::::::::::::::::::::::<:::::::::<::::::::::::<:::::::::::::::::<::<:<::::<::::::<:::::::::::::::<::<::<:::::::<::<::<:<::<:<::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::<::<::::<::::<::::::::::::<::::::::::<::<::::<:<::::<::::::::::::<:::::::::::<<:::<:::::<::::<:<::;:::::::<::<:::::::<:<::<::::<:<:<:<::::::::::::::::::::<::::::::::<::<::::<::<::::::::::::::::::::::::::::::::<:::::<::<::::<:::<:<:::<:<:<::::::<:<:<::<::::<::<:<::<:::::::::::::::::<:&&:::::::<::<::::<::<:::::::::::::::::::::::::::::<:::<:::::::::::::::::::::::", +":::::::::::::::::::::<:<::::::<:<::::::::<::<:::<::::::<::::::::::::::<<:::<<:<:<:<<<<<<<::::<<<::::<<:<::<<<<:::::<::::::::<:<::<<:::<:<:::::::<::::<::<::::::<:<:<:::::<::<:::<::::::<::::::::::::::::<::<::<:::<:::<::::::::::::::::::::::<:::::<::<::::<:::::<:::::<::::::::<:::<::<:<:::::<::<::::::<::<:::<:::&&*&&:::::::::::::::<::<::<:::<:::<:::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::<::<<:<:::<<:::::::<:::::::::<:::<:::::::<<:<::::<::::<<:::::;:;::<:<::<;::::<<;:::<<::<:::::<:::<:::::::::::::::::::::<:::<:<::::<:<:<:::<::::::::<:::::::::<:::<::::::::::<:<:<:::<:::<:::<::::::::::::::::::::::::::::::::::::<:::::::::::<::<::::::<:::::<::<::<:<<:::<:::::::&&&&&::::::&&-=&::::::::::<:<:<:::<:::<:::<::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::<::::::::::::<:::::::::<:<::<:::<:::<:<::<:<::::::::::::<:<:<;;;::<;:::::::<:::::<:::::::::;:<::<:::<:<:::::<:<:::<:<::<:<:::::<::::<:<:::::<::::::::::<:<::<:::<:::<:<::<:<:::::::::::<<:::<:::<:::<:::<:::::::::::::::::::::::<::<::<:::<:<:<:<:::::::<::::::<<::::::::&:::<:::::::::&*---&:::<:::*--&:<:<:::::::::::<<:::<:::<:::<:::<::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::<:<::::::::<:::::::::<:<::::::::::<:::<::<:<::<::;::::::::::::::::::::::<:<::::::::::<:::<::::::::::::::::::::::::::::::::::::::<:<:::::::::<::::::::<::::::<:::::<:::<:<:::<:::<:::::::<::::::::::::::::<:::::::::::<:::<:::::<::<::::<::::::::::<&&&&&&&&:::::<:<:::=---&&<:::::=--&::::::<:::::<:::<:<:::<:::<:::::::<::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::<:::::::::::<:::::::::::::::::::::<<:<<:::<::<:::<:::::;:<:;:::::::;<::<:<::::::::::<:::::<::::<:::::<:<<:::<::<:<:<::::::<::::<:<::::::::::<::::::::::::::::::::<:<::<::<:::<::::::::::<::::<:<::::<::::::::::::::::::::<::<::<:<:::<:::::::::<::<:::::::<:&&--=&&--=&::::<::::=----&::::::&-=&:<:<::<::<:::<::::::::::<::::<:<::::<::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::<:::::::::::::::::::::::::::::::::::<::<::::;<:::;;;;<::;;;<;:;;::<:;<;<;;<:::<;;<:::<;;<;<<::::<:::::<::::::<<::<::::<:<:<<<<<<<<<<<<<:::::::::::::::::::::::::::::<::<<::::::<::<<::<:::<::<:<::::<:::::::::::<:<::::::<::::::::::::<::<:<<<:<:<:::<:<:<:<<::&=--&&&&&--=&:::::::&=----*&:::::&-=&<::<<::::::<::<<::<:::<::<:<::::<::::::::::::<:::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::<:::::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,<:<<<:::<<,,,,,,,,,,,,,,,,,,,<:<::::::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,>>>>>>>>>>,:::::::<::::::::::<:<::<::::::<:::::::<:::::<:<:::::::::<:<:::<:<:<:::::::::<:::<::<:<:<:<:<:::<:<::::<:<::<&&&:<::<::<&==&&::::&o--&::<::::&=-----&&::<:&==&:<:::::::<:::::<:<:::::::::<:<:::<:<:<:::::::::<:::::::::::::::::::::::::::", +"::::::::::::::::::::::::<::::::::,###$##########################%:::<:::<%###################%:<:<:::,######################################################:<:<::::<<:::::::::::::<:::::::<:::<:::<:<:::::<:<:::::::<<<::<::::<:<::::<::<::::::::::::::<:::<&&<::<:<:::&&&<:<::::&&-&&::<:<<&&=&&::<<:&&=------&::<:&*-&::<:::<:::<:<:::::<:<:::::::<<<:::<:::<:<::::<:::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::<:<:<::<##############################@O:<::::<%###################@O::::::<#####################################################@ <:::<<:::::<::<:<::<::<:<<:<::::::::::<::<::<:::::<:<::::::<::<:<:::::::::::::<<::<:<:<<::&&&&*=*&&&::<:<::&*&<::<<<:&=-&::<::<:<&&-&&:::::&=---=&=&&::<&=-&::::::::::<::<::<:::::<:<::::::<::::<:::::::::::::<::::::::::::::::::::::::", +":::::::::::::::::::::::::::<:::<::%@#########################@@@XO::<:<::,#@################@XO<:<<:::%@###################################################XO<:<:<:::::<:::::::<:<:<:<:::::::<::<<::::<::::<<:::::::<:<::<:::::<:<<:::::<:::<<::::::<:&&=------==&:<:<:<:&&&<:::<:&=-&&::<:<:<:&=-&::::<&----&&--&<:::--=&:::<::<<::::<::::<<:::::::<:<:<<:<:::<:<<:::::::::<:::::::::::::::::::::::", +"::::::::::::::::::::::::::::<::<:::O.XX###################@X .OO;<::<:<::;OOO$##########@@ .;:<:::<::OO. @$##################X XX@@################X+<<<<:<:<:<:<<:<:<::<::::::<::<:::::::<:<:::::::<<<:<:<:::<<:::<<<:::::::<:&&&<:::<::::::&&--***&&&=-=&:::<::&*&<::<<&*--&:::::<:<:<--&<:<:<:---*&:--*::::=--&<:::::::<:<:::::::<<<:<:<:::<::::<:<:::::::::<::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::<::::<::+$################X O:<<:<<<<<<<<<::::<>#########X .+<<<<<<:<:<:::::<>################@ X+:<<<<<:;;O.X@############# ;<<<<<<<:<:<::<::<<<:::<:<::::::::::<::<::<<<::::::::::::::::<::::<<:<::::&&&&&&&::<:::<:&*-*&<<:::&--&:<:<<<*-&::::::---o<:<:::::::==&:<:<:<*--&<<&==&<<:&--&::::::<::<::<<<:::::::::::::<:<:::<:<<:<::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<:<<%###############XO::<<:<::::<<<<<:::<>######## +:::::::<<<<<:<::<<<%############### .::<:::::::::<<+O@##########@ :::::<<<<<:<:<:<:<:<<<:<::<:<::::<::::<:<<::::::::<:::<::<&&:<:<:<&*&&&&&===----*&::<:::<*-&&<:::<:&---&<:::<=-&<:<:::=--&::::<:<:::&&::::<:##############XOOOOO++++++;;:<<<:,,######@ .OOO++O+O++++;::<<::<<,%##############XXOO+OO+++++++++++++++$#######X.OOOO++::<:::::::<:<::::::<<<:<::<<<:<::::::::<:::&&*&&==----=&::::&--*&&:::<&&&=-=&::::::*-&:<:<<:<::<:<::<:&&-&&<:<:&&-&::::<:<::::&&:::::::&&-*&<::&=&&<&=--&:<<<::::::::::<:::<<:::<::<:<:<::::::::<::<::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<::::::::<<;>##############X.......OO+++;::<<<,$#####@ .........OOO++OO:<::<<,############### ..........OO+OOOOOOOO%$###### .....+;:<<::::<:::<:<<<<<::<:<:<::<:<<::<:&&&<:<&&----==-=*&&&<::::*-&;::<:::::&--&:::::&&-&<<::::<:::<:<:<:<&-=&<:<::&-*&::::::<:<<&*&::<:::&---&:<:&--&:<---&<:<:<<<::<::<:<:<<::<:::::<::<:::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::<<<:;%#############@ . ..OO++;;:<<<,%#####@ X.. . . ...OO++O:<:::::<,##############@ . ..O.O+++++++OOOO%###### ..O+OO+<<:<:<::<:<:++O+O::<:<<<<:OO<:O&&=&::<&---&&&&&:<&<::::::&-&:::::::::&--&:::::&*-&&:::<::<::::::<:<&--*&:::<&--&::<:::::::&-&::::<:<=--&:<:<&-&::*--&:<<:<:<<::::<:::<:<::::::::<:<:::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::<::<<<:>############## ...O+;;::<<<,>#####@ .OO. ..O++++;:<<:::<>##############X X..OO;+++;;;+O++O>$####@ .O;:;<:<:::<:::::::<:::&&&::<<:<#####@ .O+.. ...+;;;+::::<:+,%##############X ..O++:++;::O++OO;;%####X ..+;:;<::<:::::;<<:::::&*=&&;;+<:<<+O&&-&::::&--&:+:;<:<+::+<::+&-*;::+;:;+<&--&:::<;;&--=&&&::;<:<++;:+::&=--&:<<<:&*&:::<:::::::&&&:::<<&*-&&<<::&&-&&&--&<<<<:<:<<:<<::::::::::::::::::::::::::<::::::<:::::::::::::::::::::::::::", +"::::::::::::::::::::::::<::::::::::::<:<<:<<%#############X ..+;:<<<<<,,$####@ O;<;+.. ..O.::<<;<<<::::,$############## .;;;O:<<<<+;;;O;:>#### ..+;:;:<<:<:;++;:<<:::<&&-*&:;+::<<+;:&-&+++O&--*::::::::::::::<&-=&:<+:::+:&--&++::::<&--=--==&&&&:<:<:;:&&--&:::::&*&<::<:::::::&&&<:<::&&-&:<:<<:&=&&&--*:<:<<<<:<:<<:::<<:::<::::::::::::::<::::::<:::<::::::::::::::::::::::::::", +"::::::::::::::::::::<:::::::::::<:<:<::<:<:<>#############@ .O+;<<<::,,$##### O<;:;O. . ..O++:<<<:<::<<::,##############@ ..+;:+:+<<<:+::;;<<>#### X ..+:<;<:<::::<<;::<:<::<&--&:::<<:;::&*-&::::&--=&::::::::::::::&--&::+::::&&-*&:::::::&&&&=---===*&<:<:;<&&--&:<:<<&=&<:<:<::<<:<&=&<:<<<:&-*<::<:<:&-=---=&<::::<::::::<:::::<:::::::::::::::::<:::<:::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::<:<::::::<:<:<:<:,############## .O+:<<:<,,$####@ .<<;+;O. ...+;::<<<:;:<::<<,>##############X .O+:<:<<+:<:O::<<:<,###@&&& .O+:<:<:<;:;::<+<:<:::::&&-=::<::::<:&-=&:::<&=-=&:::::<:::;::<+&*-&<:+:<&&=-=&:::::::<:<:&&&*&=&*--&&:;<<<&--=&:<::&-*&::::<<:::<&-=:<::<:&-=&:<:<::&-----=&::::::<<:<::::::::::::::::::::<::<:::<<::<::<:::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::<:<:<<:<:<:::<<<$#############X .O+:<::<,$##### <<<:+... .O+OO+::<;OOO;:<:+,%############## .O;:+;<:O+<:<;O;::<,##&&&=* .O;;OOOO+::##&=&*-*&..+::<<<<<::<:<:<:<<:<::<<:&*=&:<:::::&*=&:<::&---&&&&&&&&&&:<:<::&--**---&&&--&&::::::::<::<:<<::<:&---=&&:&==&:<<:<&&*-*&:<:<:<<&*=&<<<:::&&--&::<:<::&&&&&:<:<<:::::::<:<<:<::<::::::::<<:<::<:<:<:<:::<:::::::::::::::::::::::::::", +":::::::::::::::::::<::::<<::::::::<:<:<<:::::<$#############X .O;,,%##### <<<<:;+O..O+;::<<<:::<:<<:<<:,>##############X .O&*=-------=-*&:<<<<%&&=&&*=&.O+::<<:<<:<::<:<:<:<<<::<:<&-&<:<<::<&-=&:<<:*----&&*-----*<<:<::&-=&&:&&&<&&--&:<<:<::::&<<<:<:<:<&*--=&::&*=&<<:<<<&&--*&::<::&&-*&<<<<<<<*--&<<<:<<:&<:<::<::<<:::<<<:<:<::<::::::::::::<:<::::<:<::<:::::::::::::::::::::::::::::", +":::::::::::::::::<:::::::::<::<::::<:<:::<<<:<%#############@ .O:,%##### X<<<<:;+O..O+;:<<<:<<<<:<<<:<::,%##########&&&&&&& &&&---===*&&&&&&<<<:<<&*=&&&=&.O;:<<<<:<:<<<:<::<::<:<:<:<*-*&:::<<<*-=<<:::&---------**&&<<<<<:&-=&<<:<::::&*=&::::::&&&&::<<::<<&=--&&<:&==&:<<<:<<&---&<<:<<&-=&<:<::::<&*&&:::<::<<<<<<<<:::::<::::<:<:<::<::<::<::::<<<<:<::::<<::<<<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::<::<:::::<>############## >,%####@ <<<::;+O..O+;:<:::::::<::<<:<:<,#####&&&&*&&&=---*& &&&&&&&&&&&,$##;::<<:<<:&*-&&*-*&+;<<<:<:<:::<:<<<<<,<<:::<:&--*<<,,>>o-&::<<<&-----=&&&&&,,>>>><<&**&<:<:::::&==&::<::&&-=&<:<:<<,,&*-*&<<<&=-&:<<<<<<&&--*&&&&&--&&<<:<<<::<&<<<<<<<,,,>>>>>,<<<:::<:::<:<<:<:<<::<::<,,,,>>>>,<<<::::<,>>,:::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<<:::<<:<<##############X ;,%##### X<<<<:;+O..O+;:<<::::<:::<::<:<:<>####&&====&&=*=-*&& .O+:<<<:&&>### :::::::::=-&:&--*+;<:<:<<<<<<<<,,,>>%$><::::&&-*&>%###&=&%<<:<&*----o&<,,%$######%&==&<:<:<<<:&*-&<<:<::*--&::<,,>%##=-*#$>::*-*,,>>>>>>&&--=&*=--&&::<<<::::<:<:<<,,>%$#######$>,::::<:::<:<<<::<:<<<,,%$#######$>,<<:<,>###:::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<:<:::::<<$#############@.,%##### <<<::;+OO.O+;:<<<::::::<&&&&&&&<,%####&*-&&##&&&& .O;:<<<:<&$##@ ::::::::&-=<:;&-=&:,,,,,,>>>>%%$######X+<::::&=&&####&&=&#$:<<&*---=&,,%##########&*-&::<<:::<:=-&&::<::&--=<,,>$###o--&###$<&-=#########&&*&&**&&<::::<<<:<:::<,,>%##############%<:<:<<:<:<:<<<::<,,%############$%>,,>$##@ ::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::<:<<:<:<>##############,>##### X<<<<:;+O..O+;:<<<<<:&&&&&&*-**-=&&$#####=-&####&# ..O;:<<<<&&###@.::::::::&-*<<:&--&>%$#####$########### :<<:<,&*=&&###&*=&###<<&&----&>$############=-*<::<:<:<:=--&:<::<:*--&>$####&=-&&####O&=&&#########X+:&&&<:::<::::<<<<<<,>$#################$<<:::<:<<:<:<:<,>$######################@O::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::<:<::,##############>##### <<<<:;+O..O+;:<<::<;O=-&:&&&&&&*--*&#####---&####@ ..+;<<<<,&&###X+<:<<+O::&=&&<:&=-&&##################X.<<<<<,&&-=&####==&##$@<<&----&##############*-*O:<:<:<:<&--*::<::<&--=&&##&&&-&&####$#&&&########## :::<:O;::::::::::<,,%#######@X O$#######$<<<<:<:<<<<<<,>########@X X##########XO::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::<::<<:<<%##################X :<<<:;+OO.O++;:<<:::;:--&:::<;:<&=--&#####&--&####X .O;:<<<,&&&&## ::<<<<<;&&-&&<::&==&################## +<:<,,$#&--*####-=####@+<&---=&##############&-*&<:<<;O.+&=-&<::<:<&&=--==**==*& ####%>##########@ <<:<<:;::::::::<<,>$#######X .;:<>########@<:<<:<<:<:<,>$#######X O;<:<;$########X;<:<<:<::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::<::<:<<%#################X O:<<:;+OO.O+;::<<::::;<*&&:::+::::&=-&#####&--&&### ..;:<:,,&*=&#@ ;<<::::+&*-&:<<:&=-&OXX############### :<;,,$###=-*###&-*#####.:&---&###############&&*&:<<<<:;:&&-*&:::<,>&&&*---=*& O::;%##%%##########X.::<<<<;:<:<<:::<,>########X O:<<,%#########.:<<<:<;:<<,$#######@ ;<<<<:;:%####### ;<<<::<<:<:<:::::::::::::", +"::::::::::::::::::::::::::::::<:<::<:::::::::<::,################X .;:::;+O.OO+;;:<<<<:::::&&&<<:;::::+&=&&###&&--&&### .O;:,,>$&==&#X.;O:;;+;+<--&<:<<<---&OO+>############@ ::,,$####&==&&&&-&##### ;&---&&###############&=&&::<<<;<:&==&&:;,>###&&&*&&& O;::;;$#$########### O+O::::;<<<:######## .;<<:;+O++$###### :<:+;;;<<<<<<<<:::<::::::", +"::::::::::::::::::::::::::::::::::<:<<::<::::::<<$##############X .O+;;;+OO.O+;::<<<<<:<:::&&&:<:;<<<:<&==&####&=-=&##@ .OO;:,,>$###--&#X+<<+;++;+<--*::::<&--*;<<,############X.;,,$###@ X&=-**--&##### O&=--*&@ $&&&&&&####&&-&+;;::<;:<:&&&++,>#########@ ++.;+++>############@ ;++;;;;+<<<<;<<,%########@ O;;;.,%##########@..::;<<<:,$######## :;;;;++OOO>#####@ ;:;++;::<:<::::::<:::::::", +":::::::::::::::::::::::::<::::::<::<::<:<:<:::::<>#############@ OO+++O..O++::<<<<::::<::&*=&&<;<:<;<&=-&####&---&##>,&,,,>>>%%######=-&# :<:++OO++&--&<:<::&*-&;::,############ O>,$###X O&&-----=&####@ >&*---&&&&&&----&&####=&&.O+;:<;<:;&:;<,>##########X +++O+O.O>############X OOOOO+;+:<<<:<,%######### OO++++,###########@ .+;+:<<:>######### :++OOO..OO;$####@ +++OO+;;<<<:<::::<:<:::::", +":::::::::::::::::::::::::::::::::::<:::<:::<::<::>############## ..OOOOOO+;;:<<<<<<<:::;:&---&<;<<<<,*--&#####*--&##&&*&&o&##########&=&@ <:OOOO++&&-&&:<&&&&=-&&<<,###########@ O,%##@ O:<&=-----&####@O,$&---=&*-------=&####&&&..O+;:;<:;:<;,>##########@ .;++O..X+>############ ... ..O++:<<<,,%######### :.+;++>###########@ .O++:<<,>######### ;OO.....OO+%####@ OOO.OO;;<::::::::<:::::::", +"::::::::::::::::::::::::::<:::::::::<::<:<<::::<:,$#############X ......OO;::<:<::<:::::;::---&<;<:<:&--&&#####&*--=&&&=---&##########&&#X.O.+OO....&-&&&&=------&&>>###########X ,>### O.::&-----=&####@,>##=-------**&&&&&#####X .O..OOOO<:,,$########## O+.. .. ;>############ .. ...O<<,%#########@ ;:;..XO>###########@ ....O::>%#########X.. .X.....+>####X ... .O+;<:::<::<:::<:::::", +":::::::::::::::::::::::::::<:::::::::<:<::<<<:::<<%#############@ ...OO+::<<<<<<<<<:::;;<*--&<:+<<,&-*&#######&=----&&*=&&##########&&& ;;;OO.O+;&&-=&&&--=**&--&<%########### >,### O;:<&=-----&#####>>##@&-*&&&&&&&########## ..O;:<<<<<,$##########X ;+O... X.>%###########X .O+:<::,>########## .;++O...>########### ..O+:<,%##########... .O+;::,$###X... ..O;:<::::::::::::::::", +":::::::::::::::::::::::::::::::::<:::::::<:::<::::>############## ...O;;:<<:<::<:<:::::;&&--&&&&&&&=-&&#######&=-=&&&XXX@@##########&*& ;;O...O+:&--=&&&&&&&&&--*&%##########@O,$## .O;::&----=&######,$##X .+&&:;,############ .O+:<::<,%##########@ OOO. ...,%###########X .O+:<<,,##########@ ;+O...X.+##########@ .+;:<%##########@ ..+;::<<%### .. .O;:<::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::<:<:<::<:::,$#############X ..O+;:<<<:<<<<::::<<<:<&--=&*------&&######&&-*& & XXX#######&=&X+O....O+:&--&&&::<:<:<=--&###########@,>##X X.+;::&=---&######%%##X .O;::,%###########@ .O+::<<,>########### .O... ..O,$########### ..O;:<<,$########## .+O.. ..O%######### ..O;:,%##########$ .O+:<<<<>### +O. ..O;:<::::::::::::::::", +"::::::::::::::::::::::::::::::<:::::<::::<::<:::::,%#############@ ..+;:<<<<<::::<::::<<<<:&-----=**&*-*&#####&=--& .O+;+$#####&=&.O..X..O;:&=-&<:<::::::&--&###########,>##@ .O+;::,&&*-&&#####>##@ .O;;:,$###########X ..+::<<,$##########@ O.. ..O;,###########@ O+;<<,%##########@ OO.. . .O+;$#######X .O+:<$############ .O;:<<:::##@ +O.. .+;<<::::::::::::::::", +":::::::::::::::::::::::::::::::::<:::::::::<<:<:<<,$############## .O+:<<:::::::::::<<:<:<<&--*&&&<&&&&-=&####&=--& .O+;;;%#####*=&. X.O;:&--&:::<:<:<&&=-&&#########$,### .O;;:,>#&&&&&####$$## ..+;;>,############ .O+;<<,%###########X .. ..O+,>###########X .O;:<,,###########X O.. ..+;:############. .O;:<<<<:< .;+...O+:<<::::::::::::::::", +":::::::::::::::::<:::::<::::::::::<:<<:<:::::<::<,%###############X .O;:<<::<::<<::<<<<::<<:&=-&:::,%##&=-*&###&*--=& ..O+++>#####&-& ..+;&&--&<:::<:::::&-=&#########%%##X .O+;:;,%####&#####$##@ .O++:>############ ..+:<,>###########@ .. .O+;:%########### .O;:<,$########### ..X ..O;:<::##@ .O+;;;,#############@ ..O++,$###########X .O;:<,$###########X . ..+;:,%##########@ .+;:,>###########X .. .O+;:<<<<<:;O. .O;:<,##############..+;<<:<::<:<:;O..O;:<<::::::::::::::::", +"::::::::::::::::::::::::::<::::<:::::::<:<::::<,%################## ..+;<<:<::<<:<<<::<:::<:&*-&<:<,###&&*-&####&*-& ..OOOOO+%###&*-*& .O;&&=--=&<<:::<::<<&&&########$$## .O+;+>>#############X ..OO;,############X .O;:,>###########@ X .O+::,###########X .O+:<,$###########X . .O;:<<<:<<:;O.. ..+;:<<%##############.O;:<::<::<<<;+OOO;:<:::::::::::::::::", +":::::::::::::::::::::::::::<::::::::<:<::<:::<,%################### .O;<<<<::<::<<<:<<:::<<:&-&:<<%####&=-&####&&** .O;;;+;>###&--=& . .;&&---=&<:<<:<:::,%##########$##X .O+++,%############@ ...O,%###########@ .+;:,$###########X ..+;:,>########### .O;:,>############ . .O+;<<<:<<<:;+O. ..O+;<<:,##############$O+;<<::::::<:;+O+;<<<::::::::::::::::", +":::::::::::::::::::::::<::::::::::::::::<<:<<,>#####O$#############@ .O+:<<:<:+<<<<<<::<::::&=-*:;,%####&--&#####&==& & .O&&&::;,>###&=-=& .OO;:&*==&<:<::::<:<,$############# ..O++;,$############X X..+,$###########@ ..+;,>############ .O;:<,%########### .O;:,%###########X .O;:<<<<::<<:;OO.....O+;:<<<<%##############$O;:<<<<:<<<:;++;:<::::::::::::::::::", +"::::::::::::::::::::<::::::::::<:::::::::::<,>#####X.%#############@ .O+:<<:<:+<:<<<;;<:::::&--=<+,#####&-=&#####&-=&&&*&&&*=&&;;<>###&&=*& .OO:<<&&:::::<;:;:;<>#############@ .O++>>############@ ...;>############ .O+:,$###########@ ..+;:<,$##########X .O+;<,############X ..+;:<::<::<<:;;OOOOOO+;:<<:::,$##############.+;:<:<:::<<:;;::<<:::::::::::::::::", +":::::::::::::::::::::::::::::<::::::<:<:<:<,>#####X :,############## .O;:<:::::<<:;;:;:<:;<&---&>>#####&-=&####&&--=&&*=---*&&;+<>### &&.. ..OO:<<<<<<<:<<++;+;,%############# . .O+,%############X ..O,%############ .O;,,############ .O;:<<>###########X .O;:,>############ .O+:<<<::<:<<<<:;++++;;:<<::::<>##############$.+:<<:<:::<<::<<<::::::::::::::::::", +":::::::::::::::::::::<:<:<::::::<::::::<::,>#####X ;:,$#############X .O+:<<:;:::<<+O++::<;<&*--=&&####&&=&&####&&--=&&&&**&&&&<:<>### ;OO....+O<<:<;OOOO+::;:;:,%############X . O+,$###########@ X.+,$###########X ..+;,%############ ..+;<<,%########### .O;:,%###########@ ..+;:<<:<:<::<<<<::::;::<<<::::::$###############O+:<<<:<:<<<<<<:::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::<:<,,$####X ;:<<%############## ..+;<<:;:<::;:<<;<:<;<&&---=&&&&&=-o&######&&-& &...;:<<<:;<%##X :O+...O++<<::<<<:<:<;::;<,#############X ...O;>############X ..>>############X .O+:,$###########X .O+:<<,$##########@ ..+;<,############@ ..+:<<<<::<:<::<<<<:<<<<<<<:<<:<:<$##############.+;:<:<::::<:<::::::::::::::::::::", +":::::::::::::::::::::::<:<:<:::::::<::::<,$####@ +:<<:>############## .O;:<<<;:<:+::<+:<<+<<*-----------&######@ .OO;<<<:<;:>$#X+<++O..O;+<,<::<<<<<<;;::<>############@ ..O+,>############ .O,%###########@ .O+,>############ ..O;:<<>###########X .O+;<>############X .O+:<::<:<::<::<:::<<<<<<<<<:<:<::,$##############.+;:<:<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<:::::::::<,,$####@ O<<<<;>$#############X .O+:<<<+:::$%<:::<<:O+:O,%############X O+,$###########XX .O+,$###########@ .+;,>############ .O+:<<,%########### .O+:,>############ .O;<<<::<::<:<<<:::<<:<:<:<<:<::::<>##############@O+;:<<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<:<::<::<:<,$####@ O<<<:;++%#############@ .O+;<<<::<::<:<::::<:<&*&&&&&&&########## .O;:<<::::::<::<<:;OOO+:<,$##O<:::::<<<:,$############ ..O:,############ .O>>############ .O+;,$###########@ .+;:<<,###########@ ..+;<,%############ .O+:<<<<::<:::::<:<::::::<:<<::<:<:<<%##############XO+:<<:<::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::<:::::<,%##### O:<<<;;OO>############## .+;:<<<:<:::::<<::<:<:<&,$############## ..+;:<<<:<:<:::<<<:;OO+;:,%##@ <:::<:<:<<,############X .O+,>###########@ ..+,%############ .O;:,############X ..+;<<,>###########X .O+;<,%############ .O;:<:<<<::::<<:<:<:::::::::<<<<::::<<%#############X.O;:<<:::::::::::::::::::::::::", +":::::::::::::::::::::::::::::<:::<::<,%####@ .:<<:;;OO.+$#############X .O;:<<<<<<:<<:::::::<::<>##############@ .O+:<<:<::::::::<<:;+O+;,>###X.<:<<<:<:<<%############ .O;,$###########X ..O;,$###########X ..+;,>############ .O;:<<,$########### .O;:<,############@ .O;:<:<::<::::<<<::::::::<::<:<<<<::<<<$############# O+;<<<::::::::::::::::::::::::", +":::::::::::::::::::::::::<:::<:<:::,,%##### X<:<<:++O.OO>#############@ .O;:<<<:<:<:<:<:<:<:<<<<>##############X .O;:<<:::<<:::<:<<:;+++,,$###X;<<:<<:<<<,%############ .O+:,###########@ X..+:,############ O+:<>###########@ ..+;<<,%############ .O;:<,############@ ..+;:<:<<<:<::::::::::<:::,>,::<:<<:<:<<,$############ .O+:<<::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<::::<<,%##### <<<<:;+O.OO+,############## .O+:<<<<<:<::<:<:<<<::<,$############## .+;<<<::<:<::<<<<<::;+,,$###@ ::<<<<<<<<,############X .O;,>###########@ X.O;,>############ O .O;:,%###########@ .O+;<<,$###########@ ..+::<,############@ .O+:<<::<::<<,<::::<:<:::<,##%<::<<:<::<<>############X..O;:<<:::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<::<,%#####XX<<<<:;+O.OO+;,##############X .O;:<::<<<<::<:<::<<<<,##############@ ..+:<<::<<:::<:::<<<:::,%####@X<:<<<::<<<>############ ..+;,%########### X..+;,%###########X .,>++;:,%###########X .O+:<,>############X OOO;:<<,############@ .O;::<<::<<<,>#>:::::<<:::>###O<::<<<<:<<<%###########@ ..+;<<:::::::::::::::::::::::", +":::::::::::::::::::::::::::::::<<,>#####X ;<<<:;+O..O+;:,%#############X .O+:<<::<:<:<<<<:<:<<<>##############@ .O+:<<::::<::<<:<<<<<,,%##### +<<<::::<<,%###########@ .O+:,############ X.O+:,$########### ,>##O:<,%###########X .+;:<,$############ X,>>;<<:,############@ .O;:<<:::<:,,$##$:::<::::<>### <::::<:::<<,$##########@ .O+:<<::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::,>#####X ;<<<:;+O.OO+;:<<>############## ..+;:<<<:::<:<<<<::<:<%##############X .O;:<<::<<<::<<:<:<<<,%###### :<<:;;;;:<,$###########X ..+;,>###########X X.+;,,############ +,$##X+<<%###########X ..+;,,%##$########## >,##$<::<$############ .O;:<:<:::<,$###XO::<::::<%###X<<<<::<<<:<<>##########@ ..+;:<::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<,>#####X :<<<:;+OO.O+;:<:<,############## .O;:<<:<:<:<<<<<<:<<,$############## ..+;<<<<<<:<::::<:::,,%######@ <<::;++;:<,############ .O+;,%########### ..+;,>###########@ .,%##@ ;<<%###########X .O+:,>##%##########@ +,$##XO<<<%############ .+;::<<::<,%###@ +:::<:::,%###@;<:<<<::<<<<,$#########@ .O;:<::::::::::::::::::::::", +":::::::::::::::::::::::::::::<,>#####@ +<<<:;+O..O+;:<<::<$#############@ .O+::<<<<::<:<:<:<:<,##############@ O+;<<<::<:::;O:<<<,,$#######XO<<:;+O+;:,>############ .O;:,############ .O;:,%###########X >>### O<<<%###########X .O;,,$##>##########X O,%##@ +::<%############@ ..+;<<:::<,>#### .<<::<<<:,$####O<<<<<<<<:<<<>#########X ..+:<::::::::::::::::::::::", +"::::::::<::::::::::::::::::<<,>###### .:<<:;+O.OO+;:<<:<:<$############## ..+;:<<::<<:<:<<<:<<%##############X .O+:<<:<<:<:<:<:<,,>######### ;<:;O.O+;:,$###########X ..+;,>###########@ X.O;:,%########### ,,$##X ;<<<%############ .+,,$##%%##########X .,>### .<<::>############# .+;:<::<,>####X <:<<<:<<<,#####.<::::<<:<:<<>######### .+;:<:::::::::::::::::::::", +":::::::::::::::<:::::<<<::<,,>######@ <:::;+OO.O+;;;:::::,>##############@ .O;:<<::<::;<:<<:<,$##############X .O;:<<<::<:<<<<,,>$#########@ ;;;+...O+<,############X .O+:,%###########X .O+;:,$########### ,,$##@ +:<<:>############$ .+,,$##@,%##########X .,>###X :<:<:<$############$ ..+:<<<<,%####X ;::<<<<<<<,######;:;;;:<<<<:<,######### .O;:<:::::::::::::::::::::", +":::::::::::::<<<:::::<<:<:<,%#######@.+;:;+O..OO;;;;;:<:::>###############. .O+:<<<:<+;;+:+<:,>###############X ..O;:<:;:;;<:<<,>$###########X.+.+O...O;,>############ .O;:,$########### .O;:<,############%,,$##@ .:<<<<,#############%%;,,%$##@ ,###########$>,>###X +<<<<<<%#############$O..+:<<,,$####@ ;<<<<::;::<>######.;++;:<<<<<<,########X .O+:<:::::::::::::::::::::", +":::::::::::::<<::::<<<<<:,,%#########O:;;;O..OO;::+O;:<<<,>###############$.XOO.OOO;::::;<:<<,$###############X ..O:<:;+;:<,,>$############# O++O...O;:,%###########@ ..+;<>###########@ ..O;:<,#############%####X +:<:<::%##############%%##### .,############%$###@ .:<:<<:::$#############$>>,,,>$#####@ O<<:<:;;+;:,>######$++O+;<<<:<<>#######@ .O+:<<::::::::::::::::::::", +":::::::::::::::<<:::<<<,,>$##########%:++OO..O+;:;<:<::<<,$################$>O+;:<:::::::<:,,%################$O. .O+:<<:,,,,>%###############@ ;O.....+;:,$###########X .O+:,%###########X .O+:<<,#################X O;:<<::;>#################### X<,################@ .;:<<<::;;>#########################@ O<:<<:;+++;:,>#######$OOO;:<:<<,$#######X .O+:<<::::::::::::::::::::", +":::::::::::::::::<:::,,>%#############$>,;..O+;:<;<<,,,,>$###################$>,,<<:<::<,,,>$##################$%>,,,,,,>>>%%$##################@ +O. . .+::,############ .O;:,$########### .O;:<<<$###############X .+;:<<;;+;$##################X ::<$############### +;::<:;;+;;%#######################@ O::<<:;+OO++:,%########%OO+:<<<,>#######X .O+:<:::::::::::::::::::::", +"::::::::<::::<<<<:::<>$##################$#.+;:<::+,%$###########################$>:<+;,%####################################################### . . ..OOO>>###########@ ..+;,,###########@ .O;<<:<%##############X O+;:<:;++;>$################X ;<<:%############## .+::::;;++;:<%#####################X O<<:::;+OOO+;:,%#########$>;,,,,%#######X .. .O;:<:::::::::::::::::::::", +"::::::::::::::::::::<>#####################.+:<<:::,##############################@;:::,######################################################## .. ..O;:,%###########X .O+:<>###########X .O+;:<<:<#############X .O+;::;+++;:>############### +:<<<<$###########@ O+;:::;++;;:<<+##################@ ;<<<<:;;+OO+;:<,$############%%$########X .O. .O;:<<::::::::::::::::::::", +":::::::::::::::::::::,##################### ;:<:::::##############################@O<:::#######################################################@ .. ..+;:<############ .O;:<%########### .O+:<<:<:,##########X .O+;;;+++;;:<;############@ O;::::;;##########X ..+;;;++++;:<<<<+@##############@X .:<<<::;+OOO+;;:<,####XXX@##############X +;O. .O+;<<:::::::::::::::::::::", +"::::::::::::::::::::::: ;:<<:::<: .<<<:: .O+:<<< .+;:<:O .O;:<<:<:<<@@###@@X .O++++++;:<<<:@@######@X .O++;;;++O@######@ .O++++O+;::<<<<<:.X@########@@X +:::::;++OOOO+::<<<### X++OXX@########@X +<:;O. .O;:<::::::::::::::::::::::", +":::::::::::::::::::::::::::<<<<:;;+O. .O;:<<<<::::::<:<<<<<:;+. .O+::<<<<<:<:<<:<<<;;O.X X.+;:<<<<<<<<<<::::;;;++O... .O;:<:<:<<<<<;+OX ..+:<<:::<:<<:;O. .O+;<<<:::<:<+. ..OOOO+;:<<:<<X .:<:;O. XXXX O+:<<:+O. ..O+;:<<:::::::::::::::::::::", +":::::::::::::::::::::::::<:<<<:;;+O.. .O+;::<<<<::<::<<<<::;+O.X ..O+;;:<<<<<:<<<<:;;+.. .O+;::<<<<:::::;;;++OO... ..+::<::<:::<<;+.. .O;:<<:::::<<:+O. .O+:<<:<<:<:<<<;+. ...OO+;:<<<:<<<:;OX .....OO+;;;O.. ...OO+;:<<::::<<:;O.. ...OOOOOO..OO+;:<<:::<;;:<<:+O. X..OO+<<<<<<:;O.. ..+;:<<::::::::::::::::::::::", +":::::::::::::::::::::::::::<<:;+O... ..O++;::<<:::<:<<::;;+O.. ..O++;;:<<<:<<<:;+OO.. ..O+;;;;;;;;;;+++OOO.... .O+:<<<:<::<<:;O. ..O;<<<:::<:<<;+O. ..+;:<<:::<:<:<<:+O. ..OO;:<<<:<::<<;+O. X...O+;:::;+O. ...O+;:<<<:<:::<<:;O.. ........OO+:<:<:<<<:<:::::+O.. ..O+;;:::::;+O.....O;:<<:::::::::::::::::::::::", +":::::::::::::::::::::::::<:<:;+OO... . . ..OO++;:<<<:::<<::;++OO.. . . .....O+++;:<<<<<:;+OO... . ...OOO++++++++OOOOO.... . . ...O;:<:<::<<:<:;O.. . .O+:<<:::::<<:;+... ..O+;<<:<::<:::<<:;O. ...++::<:<:<:<<<:;+O.X ...O+;:<<<:;O. ..O+;:<<:<:<:<:<<::;OO.. ......O+;;:<:<::<:<:<<<<:+........O+;;;;;;+O....O++::<<:<:::::::::::::::::::::", +"::::::::::::::::::::::::::<<:;+OO...........OOO++;:<<:::<<:;++OOO..................OOO++;::<<<:;++OO..................OOOO+OO+OOOOOOOOO.............OO+::<:::<::<<:;+O.......OO;:<<::::<:<:;+O.......O+;:<<:<<::<::<<:;+O.. . ....O+;:<<:<:::<:<<::;+O.. . ...O+;:<<<<<;+O.. ...O+;:<<:<::::::<<<::;+O.. . . . ...OO+;;<<<:::<:<:<::<:;+O....OOOOOO++++OOO...O+;::<:::::::::::::::::::::::::", +"::::::::::::::::::::::::::<<:;++++OO+OOO+O+O++++;:<<::<::<<:;+++++O++OOOOO+OOO+OO+O+O+++;:<<<<<:;++++++O+O+O+OOOOOO+O++++++++++++++++++OOO+O+OOOO+O++;;:<<::<::<:<:;;++OOOO+++;;<<:<::::<<<:;++OOOO+O+;:<<:<:<:<<::<<<:;+OO...OOO+;;:<<<:::::::<<<<:;+OO......OO++;:<:::<<:;+OO....OO+;;:<<:<:<<::<::<<<<:;++OO.........OO+;;:<<<:<::<:::::<<<:+OOO+++++OOOOOO+OOOOO+;;:<<::::::<:::::::::::::::::::", +":::::::::::::::::::::::::::<<::;;;;;;;;;;;;;;;;:::<:::::<<<:::;;;;;;;;;;;;;;;;;;;;;;;;;:::<<<<:+::;;;;;;;;;O+;;;:;;;;+;;;;;;;;;;+O+O;;;+;;;;;;;+;;;;:::<<<:::::<<<<:O;;;;;;;;::<<<:::::::<<+O:;;;;;+O:::<<+<;<::<:::<<<:;;++++++;;::<<:::::::;::::<<:;;++OOOO++;;::<;+<:::<:;++OOOO+;;:<<<<:::::<:<:<+::<<::;;++OOOOOO+++;;:<<<<:::::::<<:<::<:;++;;;;;;;++++++++++;;::<:<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<<<::::::::<<<<<<<:<<<;<:::::<<<<<<<<<<:<:<::<:<:<<::::::::<<<<:<<<:<<<:::<::::.::<::<<<+:::::<;;<:<;O;.<:<<;<:<:<:;<<::<<<::::::::::<<<<;::<<<<;<<<<::::::<::<<:<<:<<;:<+:<<:O + + * update-autoloads.sh (mule_p): EFS has been packaged. + * update-elc.sh (make_special_commands): Ditto. + + * update-elc.sh: VM has been packaged. + + * update-autoloads.sh: Add directory language + +1997-10-23 SL Baur + + * update-elc.sh (BYTECOMP): Specify -vanilla + * update-autoloads.sh (dirs): Ditto. + * update-custom.sh (dirs): Ditto. + 1997-10-10 Martin Buchholz * config.values.in: Run config.values.sh diff -r d3e9274cbc4e -r e45d5e7c476e lib-src/config.values.in --- a/lib-src/config.values.in Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/config.values.in Mon Aug 13 10:03:52 2007 +0200 @@ -63,6 +63,7 @@ infodir "@infodir@" infodir_user_defined "@infodir_user_defined@" infopath "@infopath@" +infopath_user_defined "@infopath_user_defined@" internal_makefile_list "@internal_makefile_list@" ld "@ld@" ld_libs_all "@ld_libs_all@" diff -r d3e9274cbc4e -r e45d5e7c476e lib-src/digest-doc.c --- a/lib-src/digest-doc.c Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/digest-doc.c Mon Aug 13 10:03:52 2007 +0200 @@ -5,10 +5,10 @@ See also sorted-doc.c, which produces similar output but in texinfo format and sorted by function/variable name. */ -#include #ifdef emacs #include <../src/config.h> #endif +#include int main () diff -r d3e9274cbc4e -r e45d5e7c476e lib-src/gnuslib.c --- a/lib-src/gnuslib.c Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/gnuslib.c Mon Aug 13 10:03:52 2007 +0200 @@ -33,8 +33,8 @@ static char rcsid [] = "!Header: gnuslib.c,v 2.4 95/02/16 11:57:37 arup alpha !"; #endif +#include "gnuserv.h" #include -#include "gnuserv.h" #ifdef SYSV_IPC static int connect_to_ipc_server (void); diff -r d3e9274cbc4e -r e45d5e7c476e lib-src/make-path.c --- a/lib-src/make-path.c Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/make-path.c Mon Aug 13 10:03:52 2007 +0200 @@ -26,15 +26,15 @@ command on some of the purer BSD systems (like Mt. Xinu) don't have that option. */ +#ifdef emacs +#include <../src/config.h> +#endif + #include #include #include #include -#ifdef emacs -#include <../src/config.h> -#endif - extern int errno; char *prog_name; diff -r d3e9274cbc4e -r e45d5e7c476e lib-src/update-autoloads.sh --- a/lib-src/update-autoloads.sh Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/update-autoloads.sh Mon Aug 13 10:03:52 2007 +0200 @@ -62,7 +62,7 @@ # Compute patterns to ignore when searching for files # These directories don't have autoloads or are partially broken. -ignore_dirs="egg eos ilisp its language locale mel mu sunpro term tooltalk" +ignore_dirs="egg eos ilisp its locale mel mu sunpro term tooltalk" # Prepare for autoloading directories with directory-specific instructions make_special_commands='' @@ -76,7 +76,7 @@ # Only use Mule XEmacs to build Mule-specific autoloads & custom-loads. echon "Checking for Mule support..." lisp_prog='(princ (featurep (quote mule)))' -mule_p="`$EMACS -batch -no-site-file -eval \"$lisp_prog\"`" +mule_p="`$EMACS -batch -vanilla -eval \"$lisp_prog\"`" if test "$mule_p" = nil ; then echo No ignore_dirs="$ignore_dirs mule leim" @@ -91,7 +91,8 @@ # make_special auctex autoloads MULE_EL=tex-jp.elc # fi #make_special cc-mode autoloads -make_special efs autoloads +# EFS is now packaged +#make_special efs autoloads #make_special eos autoloads # EOS doesn't have custom or autoloads make_special hyperbole autoloads # make_special ilisp autoloads @@ -115,7 +116,7 @@ # set -x for dir in $dirs; do - $EMACS -batch -q -l autoload -f batch-update-directory $dir + $EMACS -batch -vanilla -l autoload -f batch-update-directory $dir done eval "$make_special_commands" diff -r d3e9274cbc4e -r e45d5e7c476e lib-src/update-custom.sh --- a/lib-src/update-custom.sh Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/update-custom.sh Mon Aug 13 10:03:52 2007 +0200 @@ -72,7 +72,7 @@ # Only use Mule XEmacs to build Mule-specific autoloads & custom-loads. echon "Checking for Mule support..." lisp_prog='(princ (featurep (quote mule)))' -mule_p="`$EMACS -batch -no-site-file -eval \"$lisp_prog\"`" +mule_p="`$EMACS -batch -vanilla -eval \"$lisp_prog\"`" if test "$mule_p" = nil ; then echo No ignore_dirs="$ignore_dirs mule leim" @@ -97,4 +97,4 @@ done echo done -$EMACS -batch -q -l cus-dep -f Custom-make-dependencies $dirs +$EMACS -batch -vanilla -l cus-dep -f Custom-make-dependencies $dirs diff -r d3e9274cbc4e -r e45d5e7c476e lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 10:03:52 2007 +0200 @@ -61,11 +61,11 @@ fi REAL=`cd \`dirname $EMACS\` ; pwd | sed 's|^/tmp_mnt||'`/`basename $EMACS` -BYTECOMP="$REAL -batch -q -no-site-file " +BYTECOMP="$REAL -batch -vanilla " echo "Recompiling in `pwd|sed 's|^/tmp_mnt||'`" echo " with $REAL..." -$EMACS -batch -q -l `pwd`/lisp/prim/cleantree -f batch-remove-old-elc lisp +$EMACS -batch -vanilla -l `pwd`/lisp/prim/cleantree -f batch-remove-old-elc lisp prune_vc="( -name SCCS -o -name RCS -o -name CVS ) -prune -o" @@ -91,7 +91,7 @@ # Only use Mule XEmacs to compile Mule-specific elisp dirs echon "Checking for Mule support..." lisp_prog='(princ (featurep (quote mule)))' -mule_p="`$EMACS -batch -no-site-file -eval \"$lisp_prog\"`" +mule_p="`$EMACS -batch -vanilla -eval \"$lisp_prog\"`" if test "$mule_p" = nil ; then echo No ignore_dirs="$ignore_dirs its egg mule language leim" @@ -109,13 +109,6 @@ echo "Checking the byte compiler..." $BYTECOMP -f batch-byte-recompile-directory lisp/bytecomp -# Byte-compile VM first, because other packages depend on it, -# but it depends on nothing (Kyle is like that). -ignore_dirs="$ignore_dirs vm" -echo "Compiling in lisp/vm"; -(cd lisp/vm && ${MAKE:-make} EMACS=$REAL autoload) -echo "lisp/vm done." - # Prepare for byte-compiling directories with directory-specific instructions make_special_commands='' make_special () { @@ -134,7 +127,8 @@ # make_special auctex some MULE_ELC=tex-jp.elc # fi #make_special cc-mode all -make_special efs x20 +# EFS is now packaged +# make_special efs x20 make_special eos -k # not strictly necessary... ## make_special gnus some # Now this is a package. make_special hyperbole elc diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ChangeLog --- a/lisp/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 10:03:52 2007 +0200 @@ -1,3 +1,852 @@ +1997-10-30 SL Baur + + * vm/vm-vars.el (vm-image-directory): Use locate-data-directory if + it exists. + + * language/european.el: Remove erroneous references to + `Serbo-Croatian'. + * language/cyril-util.el: Ditto. + * leim/quail/cyrillic.el: Ditto. + + * comint.el: reverse previous patch + +1997-10-29 MORIOKA Tomohiko + + * mule/mule-init.el (init-mule): Load locale-start even if lang is + not exactly matched. + + * mule/mule-init.el (auto-language-alist): Modify for new language + environment feature. + (init-mule): Modify for new language environment feature. + +1997-10-29 MORIOKA Tomohiko + + * language/korean.el (setup-korean-environment): Modify for + XEmacs. + + * language/greek.el: Modify setting about language environment. + + * language/european.el: Fix setting for Croatian language + environment. + + * language/vietnamese.el: Fix setting about language environment. + + * language/viet-util.el (setup-vietnamese-environment): Modify for + XEmacs. + + * language/cyril-util.el (setup-cyrillic-iso-environment): Modify + for XEmacs. + (setup-cyrillic-koi8-environment): Modify for XEmacs. + (setup-cyrillic-alternativnyj-environment): Modify for XEmacs. + +1997-10-28 MORIOKA Tomohiko + + * language/hebrew.el (setup-hebrew-environment): Modify for + XEmacs. + + * mule/mule-cmds.el (set-default-coding-systems): New function. + (set-language-info): Fix about menu. + (read-input-method-name, toggle-input-method): Sync with Emacs + 20.2. + + * language/cyril-util.el: Modify header. + + * language/cyril-util.el + (setup-cyrillic-alternativnyj-environment): Modify for XEmacs. + + * language/cyril-util.el: New file; imported from Emacs 20.2. + + * language/japan-util.el (setup-japanese-environment): Use + `set-default-coding-systems'. + + * language/european.el (setup-8-bit-environment): Modify for + XEmacs. + + * language/english.el (setup-english-environment): Use + `set-default-coding-systems'. + + * language/chinese.el: Modify for XEmacs. + + * language/china-util.el (setup-chinese-gb-environment, + setup-chinese-big5-environment): Use `set-default-coding-systems'. + + * mule/mule-files.el (file-coding-system-alist): Fix typo. + +1997-10-28 MORIOKA Tomohiko + + * prim/dumped-lisp.el: Abolish Thai support temporary. + + * language/thai.el, language/thai-util.el: Delete Thai specific + files because composite character features don't work in XEmacs. + + * language/japan-util.el: Modify header. + + * language/chinese.el: Abolish `Chinese-CNS' environment + temporary. + + * language/china-util.el: Abolish `setup-chinese-cns-environment' + temporary. + + * language/china-util.el (setup-chinese-big5-environment): Modify + for XEmacs. + + * language/china-util.el (setup-chinese-gb-environment): Modify + for XEmacs. + + * language/chinese.el: Delete set-coding-category-system for big5. + + * language/japan-util.el (setup-japanese-environment): Modify for + XEmacs. + + * language/japanese.el: Delete set-coding-category-system for + shift-jis. + + * language/english.el (setup-english-environment): Modify for + XEmacs. + +1997-10-28 MORIOKA Tomohiko + + * language/auto-autoloads.el: New file. + + * mule/mule-files.el (file-coding-system-alist): Add setting for + TUTORIAL.hr to iso-8859-2. + + * leim/quail/tibetan.el, leim/quail/ethiopic.el, + leim/quail/japanese.el, leim/quail/lao.el, leim/quail/lrt.el, + leim/quail/devanagari.el: Delete broken features temporary. + + * language/tibetan.el, language/indian.el, language/lao-util.el, + language/lao.el, language/tibet-util.el, language/ethio-util.el, + language/ethiopic.el, language/devanagari.el: Delete broken + features temporary. + + * mule/mule-cmds.el (universal-coding-system-argument): New + function; imported from Emacs 20.2. + +1997-10-27 MORIOKA Tomohiko + + * language/korean.el, language/thai.el, language/vietnamese.el, + language/chinese.el, language/japanese.el, language/arabic.el, + language/ethiopic.el: Abolish setting for old language + environment. + + * language/hebrew.el: Modify for XEmacs. + + * Use language/hebrew.el instead of mule/hebrew-hooks.el; abolish + mule/hebrew-hooks.el. + + * mule/mule-misc.el: Abolish old language environment features. + + * mule/mule-init.el: Delete old language environment specific + features temporary. + + * prim/dumped-lisp.el: Use language/hebrew.el instead of + hebrew-hooks.el. + + * mule/mule-cmds.el (describe-language-environment): Modify for + XEmacs because `coding-system-mnemonic' returns string instead of + character in XEmacs. + + * mule/mule-cmds.el: Sync with Emacs 20.2 about language + environment. + + * mule/mule-cmds.el: Don't use `mule-prefix'. + +1997-10-26 MORIOKA Tomohiko + + * language/ethiopic.el (ccl-encode-ethio-font): Modify to sync + with Emacs 20.2. + +1997-10-26 MORIOKA Tomohiko + + * mule-diag.el (list-coding-systems): Modify for XEmacs. + +1997-10-26 MORIOKA Tomohiko + + * mule/mule-files.el (find-coding-system-magic-cookie): Regard top + line magic. + (load): Use `find-file-coding-system-for-read-from-filename'. + + * language/arabic-util.el: Use iso-2022-7bit. + +1997-10-26 MORIOKA Tomohiko + + * mule-diag.el (describe-designation): Moved from mule-debug.el. + (describe-coding-system): Use `describe-designation'. + + * mule-debug.el: Move function `describe-designation' to + mule-diag.el; Abolish function `describe-coding-system' because of + using it in mule-diag.el. + + * mule-coding.el (keyboard-coding-system): New inline function. + (terminal-coding-system): New inline function. + + * mule-cmds.el: Bind `describe-coding-system' to C-h C instead of + `describe-current-coding-system' to sync with Emacs 20.2. + + * mule-diag.el: Abolish `print-designation' because it does not + work in XEmacs. + + (describe-coding-system): Modify for XEmacs. + (print-coding-system-briefly): Modify for XEmacs. + (describe-current-coding-system): Modify for XEmacs. + + * mule-coding.el: Abolish function `coding-system-charset' + (defined as builtin function). + + * mule-diag.el: New file; imported from Emacs 20.2. + + * mule-misc.el (set-buffer-process-coding-system): New function; + imported from mule.el of Emacs 20.2. + + * mule-cmds.el: Bind `set-buffer-process-coding-system' to C-x C-m + p and abolish C-x C-m P. + + * mule-files.el (load): Use `binary' instead of `no-conversion'. + +1997-10-28 Kyle Jones + + * modes/enriched.el (enriched-face-ans): Use + color-name instead of color-instance-name. + color-instance-name will not handle the specifiers that + are passed as arguments. + +1997-10-28 Tomasz Cholewo + + * prim/find-func.el (find-function-noselect): Fix nil argument + handling and add support for dumped macros. + +1997-10-28 SL Baur + + * pcl-cvs/pcl-cvs-xemacs.el: Add `cvs-mode-update-no-prompt' to menu. + From Stig Bjorlykke + +1997-10-28 Didier Verna + + * packages/man.el (manual-entry): corrected the `when' + form to include 'section' in the buffer name. + +1997-10-28 SL Baur + + * prim/packages (packages-find-pacakges): Fix test on + inhibit-package-init + +1997-10-27 Tomasz Cholewo + + * prim/keymap.el (event-apply-modifier): Fix the return type and + scan the function-key-map. + (next-key-event): New function. + (key-sequence-list-description): Ditto. + +1997-10-27 SL Baur + + * x11/x-menubar.el: Turn off `popup-menubar-menu' keybinding. + + * prim/dumped-lisp.el (preloaded-file-list): Dump canna-leim and + egg-leim with XEmacs. + + * mule/canna-leim.el: Clean up file for dumping with XEmacs. + * egg/egg-leim.el: Ditto. + +1997-10-27 Stephen J. Turnbull + + * mule/canna-leim.el: Register Canna with LEIM when loaded + + * mule/canna.el (canna): Bind `canna-toggle-japanese-mode' to + "\C-o" only if LEIM is not present + + * egg/egg-leim.el: Registers EGG/Wnn with LEIM when loaded + + * egg/egg.el: Bind `toggle-egg-mode' to "\C-\" only if LEIM is + not present when loaded + +1997-10-27 SL Baur + + * prim/about.el: Update entries + +1997-10-26 SL Baur + + * prim/startup.el (startup-message-timeout): Startup message + timeout is too short. + + * mule/canna.el (canna): Move canna-toggle-japanese-mode + keybinding to C-\. + + * emulators/edt-mapper.el (edt-lucid-emacs19-p): Test for XEmacs + instead of Lucid in `emacs-version'. + +1997-10-25 SL Baur + + * mule/mule-cmds.el: describe-language-support, + describe-language-support-internal removed. + +Fri Aug 8 12:58:00 1997 David Byers + + * fill.el (fill-region-as-paragraph): When justifying, check for + end-of-buffer at the end of whitespace point is sitting in, and + delete the trailing whitespace if we are on the last line. + +1997-10-24 Hrvoje Niksic + + * prim/about.el (about-finish-buffer): Kill the buffer, when + button documents so. + +1997-10-24 Jens-Ulrik Holger Petersen + + * pcl-cvs.el (cvs-parse-stderr): Ignore ssh-askpass message. + +1997-10-20 Hrvoje Niksic + + * prim/packages.el (locate-library): Make NOSUFFIX not affect + compression. + +1997-10-24 SL Baur + + * modes/c-comment.el: Create c-comment-edit-map. + (c-comment-edit): Fix docstring, use new keymap. + Suggested by Chris Felaco + + * prim/help-nomule.el (tutorial-supported-languages): Add + Norwegian. + + * prim/simple.el (assoc-ignore-case): Synch with Emacs 20.1. + + * mule/mule-cmds.el (set-language-info): Forgot to set any data + values in language-alist. + (read-multilingual-string): Fix call to `read-string'. + +1997-10-22 Karl M. Hegbloom + + * packages/backup-dir.el (bkup-backup-directory-info): customized, + with :require so it loads automagicly if you've set it. Docstring + updated to reflect that, and reformatted for easier reading. + + * packages/jka-compr.el (jka-compr-compression-info-list): + Docstring clarification: what does the append flag do? + + * prim/minibuf.el (minibuffer-electric-slash): leave efs prefix + and ~\(blah\)? when / is pressed. + +1997-10-24 Jens-Ulrik Holger Petersen + + * efs/dired.el (dired-create-files): Get mark-char thing working + again: replace `integerp' by `characterp'. + (dired-add-entry): Ditto. + (dired-add-entry-do-indentation): Ditto. + +1997-10-24 Hrvoje Niksic + + * x11/x-faces.el (*try-oblique-before-italic-fonts*): Customized. + +1997-10-23 SL Baur + + * prim/startup.el (command-line-do-help): Add Documentation for + -vanilla and -no-packages. + (command-line-early): Implement them. + + * prim/packages.el (inhibit-package-init): New variable. + (packages-find-packages): Use it. + + + * packages/jka-compr.el (jka-compr-compression-info-list): + Add bzip2 extensions. + From Tomasz Cholewo + +1997-10-22 Karl M. Hegbloom + + * comint/comint.el (comint-scroll-show-maximum-output): fixups to + docstring, and to :type to allow numbers. + (comint-postoutput-scroll-to-bottom): Added window arg to + `recenter' call to fix the horrid flash and global recentering, + and uncommented the code allowing numeric values for + `comint-scroll-show-maximum-output'. + +1997-10-23 Hrvoje Niksic + + * packages/info.el (Info-mode): Don't initialize faces. + + * packages/info.el: Use `defface' to initialize faces. + +1997-10-23 Karl M. Hegbloom + + * modes/cperl-mode.el (cperl-here-face): fix the horrible invisible + green default face. + +1997-10-23 Hrvoje Niksic + + * custom/wid-edit.el (widget-choose): Acknowledge aborted choice + with a `Canceled' message, even if C-g wasn't pressed explicitly. + +1997-10-23 Per Abrahamsen + + * custom/cus-edit.el (hook): Use `widget-group-match' instead of + `widget-editable-list-match'. + +1997-10-23 SL Baur + + * modes/c-comment.el (c-comment-edit): Fixed autoload cookie. + Reformatted Lisp comments. + +1997-10-22 SL Baur + + * psgml/psgml-charent.el (sgml-display-char-list-filename): Use + locate-data-directory instead of data-directory. + * psgml.el (sgml-data-directory): Ditto. + +1997-10-20 Jan Vroonhof + + * extents.c: Renamed shot property to initial-redisplay-function + (extent_fragment_update): Changed the bookkeeping whether an event + has been spawned. The initial-redisplay-function property is no + longer set to nil. + +1997-10-21 SL Baur + + * custom/cus-dep.el (Custom-make-dependencies): Ditch the time + stamp. + +1997-10-22 Jens-Ulrik Holger Petersen + + * comint/gdb.el (gdb-with-core): Fixed autoload cookie. + +1997-10-22 Hrvoje Niksic + + * prim/startup.el (command-line-1): Run term-setup-hook regardless + of `input-pending-p'. + + * custom/cus-edit.el (custom-split-regexp-maybe): Use `split-string'. + + * custom/cus-start.el (custom-start-quote): Synch with + `custom-quote'. + + * prim/subr.el (functionp): Synched docstring with Emacs 20.2. + + * custom/cus-edit.el (custom-quote): Use `keywordp'; use + `car-safe'; don't conditionalize on having `characterp'. + +1997-10-21 Hrvoje Niksic + + * custom/wid-edit.el (radio-button): Use "radio0" as inactive + glyph. + (widget-visibility-value-create): Use new semantics of + `widget-glyph-insert'. + + * custom/cus-edit.el (custom-buffer-create-internal): Setup + tag-down-glyphs with list. + (custom-group-value-create): Ditto. + + * custom/wid-edit.el (widget-glyph-click): Check whether the + extent was detached/killed. + (widget-push-button-value-create): Removed crufty XPM contrast + hack. + (widget-default-create): Make the markers point nowhere after + using them. + (widget-default-create): Use `point-min-marker'/`point-max-marker'. + (widget-glyph-find): Disallow list. + (widget-glyph-insert): Allow IMAGE to be a list. + +1997-10-20 Hrvoje Niksic + + * prim/featurep.el (featurep): Handle `not' correctly. + +1997-10-21 SL Baur + + * prim/about.el (about-maintainer-glyph): Pictures have been moved + to photos subdirectory. + +1997-10-21 Hrvoje Niksic + + * x11/x-menubar.el (options-menu-saved-forms): Check whether + `pending-delete' is bound before accessing it. + +1997-10-21 SL Baur + + * x11/x-menubar.el (default-menubar): Conditionalize games menu. + +1997-10-21 Colin Rafferty + + * x11/x-menubar.el (default-menubar): Made it use lazy-shot + instead of lazy-lock in "Syntax Highlighting->Lazy". + (options-menu-saved-forms): Made it save lazy-shot instead of + lazy-lock in the options. + +1997-10-21 SL Baur + + * mule/mule-help.el (help-with-tutorial): New file. + + * prim/dumped-lisp.el (preloaded-file-list): New entries for + help-nomule and mule-help. + + * prim/help.el: Remove `help-with-tutorial'. + + * prim/help-nomule.el: New file. + +1997-10-19 Hrvoje Niksic + + * prim/subr.el: Moved int-char and char-int definitions from + obsolete.el. + +1997-10-18 Hrvoje Niksic + + * custom/wid-edit.el (widget-push-button-value-create): Require + `xpm-button'. + (widget-push-button-value-create): Use :tag-down-glyph and + :tag-inactive-glyph. + (widget-default-create): Use :tag-inactive-glyph. + (widget-button-click): Correctly merge faces. + + * custom/cus-edit.el (custom-variable-action): Don't redraw + magic. + + * custom/wid-edit.el (widget-glyph-insert): Return glyph. + (widget-default-create): Insert :button-prefix and :button-suffix + only if a glyph is not used. + (widget-glyph-click): Respect :mouse-down-action. + (widget-specify-insert): Document for edebug. + (widget-default-create): Use markers to keep track of stuff. + + * custom/cus-edit.el (custom-group-value-create): Ditto. + + * custom/wid-edit.el (widget-default-create): Use :tag-down-glyph. + + * custom/cus-edit.el (custom-group-value-create): Use image. + + * prim/glyphs.el (init-glyphs): Minor fixups. + +1997-10-17 Hrvoje Niksic + + * custom/wid-edit.el (widget-field-value-get): Use `cond'. + (default): Use :button-keymap. + (widget-specify-button): Ditto. + (widget-glyph-insert-glyph): Ditto. + (widget-activation-glyph-mapper): Renamed from + `widget-activation-glyphs-mapper'. + + * custom/cus-edit.el (Custom-mode-menu): Go to `Easy + Customization' node. + (boolean): Don't use nested backquotes. + + * custom/wid-edit.el (widget-field-action): Check whether the new + value is valid before using it. + +1997-10-16 Hrvoje Niksic + + * custom/wid-edit.el (character): Use [\0-\377] instead of . in + :valid-regexp. + (widget-color-notify): Use `valid-color-name-p'. + (widget-activation-widget-mapper): New function. + (widget-specify-inactive): Use it. + (widget-specify-active): Ditto. + (widget-setup): Ditto. + (radio-button): Added :inactive-glyph spec. + (widget-toggle-value-create): Use it. + (widget-color-sample-face-get): Check for color before setting it. + (widget-color-sample-face-get): Store the face object, not its + name. + +1997-10-18 Jens-Ulrik Holger Petersen + + * help.el (function-at-point): Use `function-at-point-function'. + (function-at-point-function): New variable, formerly + `find-function-function'. + (describe-function): Use `function-at-point'. + (where-is): Ditto. + + * find-func.el (find-function-read-function): Use + `function-at-point'. + + * packages/info.el (Info-elisp-ref): Use `function-at-point'. + + * packages/hyper-apropos.el (hyper-apropos-read-function-symbol): + Use `function-at-point'. + + * packages/etags.el (emacs-lisp-default-tag): Use + `function-at-point'. + + * prim/obsolete.el (function-called-at-point): Make it + obsolete. + +1997-10-09 Jens-Ulrik Holger Petersen + + * prim/files.el (switch-to-buffer-other-frame): Remove call to + `select-frame'. + +1997-10-17 SL Baur + + * prim/packages.el (packages-find-packages-1): New argument: + `user-package' non-nil when searching user packages. + - Load any autoloads found in user packages. + +1997-10-17 Karl M. Hegbloom + + * packages/info.el (Info-insert-dir): Also kill the localdir temp + buffers. + +1997-10-17 SL Baur + + * utils/facemenu.el: autoload the `facemenu-keymap' properly. + + * mule/mule-cmds.el (read-language-name): Fix typo. + From Didier Verna + +1997-10-15 Adrian Aichner + + * utils/build-report.el: Leaving point at begin of composed mail now. + Using mime-edit-content-beginning to determine file-begin of + Installation file. + Introduced the according alias for SEMI/TM compatibility. + + * utils/build-report.el: + Corrected backward search for begin of last configuration in + Installation file. + + * utils/build-report.el: + Incorporated `xemacs-build-report-installation-insert-all' feature + suggested by Didier Verna. + Composing mail parts (with-temp-buffer ...) to simplify implementing + future features. + Eliminated use of mail-mode -specific function `mail-text'. + +1997-10-14 Adrian Aichner + + * utils/build-report.el: + Incorporated fix for SEMI/TM compatibility suggested by Jens-Ulrik + Holger Petersen . If SEMI symbols are + not fboundp, alias them to corresponding TM symbols. + +1997-10-13 Adrian Aichner + + * utils/build-report.el: + Changed to (mime-edit-insert-tag "text" "plain" ...) from + "application" "octet-stream" due to complaint from + Kazuyoshi Furutaka in + Message-Id: <19971013102132V.furutaka@Flux.tokai.jaeri.go.jp> + +1997-10-13 Hrvoje Niksic + + * utils/facemenu.el: Autoload `facemenu-keymap' function definition. + (facemenu-color-defined-p): Nuked. + (facemenu-find-face): Ditto. + (facemenu-region-active-p): Ditto. + (facemenu-sized-face): Declare `prefix'. + (facemenu-read-color): Aliased to `read-color'. + (facemenu-face-attributes): Use `mapvector'. + + * utils/facemenu.el: Customized and synched with FSF 20.2. + +1997-10-17 Hrvoje Niksic + + * cl/cl-macs.el (extent-properties): Remove old setf method. + +1997-10-16 Karl M. Hegbloom + + * prim/files.el (revert-without-query): changed from boolean to + list of regexp as documented in NEWS and its docstring. + +1997-10-16 SL Baur + + * utils/floating-toolbar.el: (TopLevel): Don't unconditionally + require the feature `toolbar' it causes breakage only at + bytecompile time. Don't do any initialization if toolbar support + is not available. + (floating-toolbar): Whine if no run-time toolbar support is + available. + + * custom/wid-edit.el (widget-change-glyphs-mapper): cosmetic changes. + From Hrvoje Niksic + + * prim/glyphs.el (init-glyphs): Use different logo for beta XEmacsen. + From Didier Verna + +1997-10-15 Hrvoje Niksic + + * cl/cl-macs.el (extent-property): Updated SETF methods for `get' + and `extent-property'. + + * custom/wid-edit.el (widget-field-value-create): Revert to using + two markers. + (widget-setup): Ditto. + (widget-color-sample-face-get): Get only a unique face per widget. + (widget-color-notify): Change the color of the face instead of + creating a new one. + + * packages/add-log.el (add-change-log-entry): Push window + configuration. + (change-log-exit): New function. + (change-log-cancel): Ditto. + (change-log-mode-map): Bind them. + + * custom/wid-edit.el (widget-specify-inactive): Make glyphs look + inactive. + (widget-change-glyphs-mapper): New function. + (widget-glyph-click): Disallow operations on inactive glyphs. + +1997-10-14 Hrvoje Niksic + + * custom/wid-edit.el: (widget-glyph-insert-glyph): Use + `widget-mouse-help' if necessary. + (widget-documentation-string-value-create): Don't coerce help-echo + WIDGET to widget. + (widget-button-keymap): New keymap. + (widget-specify-button): Use it. + (widget-glyph-insert-glyph): Ditto. + (widget-glyph-click): Dispatch events during the loop. + (widget-glyph-click): Use `unwind-protect' to ensure that the + glyph stays in up position. + (widget-keymap): Don't bind buttons and RET. + (widget-button-keymap): Bind mouse buttons and RET. + (widget-field-activate): Use `widget-field-find'. + + * custom/wid-edit.el (widget-button-click): Visually "release" the + button *before* doing the buttonup action. + (widget-button-click): Reworked. + (widget-echo-help): Accept extent. + + * custom/cus-edit.el (custom-face-value-create): Use `make-face'. + + * custom/wid-edit.el (widget-restore-tabable): New function. + (widget-deactivate-widget-extent): New function. + (widget-reactivate-widget-extent): New function. + (widget-specify-inactive): Use `widget-deactivate-widget-extent'. + (widget-setup): Ditto. + (widget-specify-active): Use `widget-reactivate-widget-extent'. + (widget-move): Don't stop within inactive range. + +1997-10-14 MORIOKA Tomohiko + + * language/japan-util.el: Copied from Emacs 20.2. + + * mule/mule-cmds.el (char-code-property-table): New variable. + (get-char-code-property): New function. + (put-char-code-property): New function. + +1997-10-10 MORIOKA Tomohiko + + * language/vietnamese.el: Use language/viet-util.el instead of + mule/mule-vietnamese.el; abolish mule/mule-vietnamese.el. + +1997-10-09 MORIOKA Tomohiko + + * mule/mule-coding.el: Rename `automatic-conversion' -> + `undecided' to sync with Emacs 20.2; define coding-system + `automatic-conversion' as an alias for `undecided'. + + mule/mule-files.el (buffer-file-coding-system-for-read, + convert-mbox-coding-system, insert-file-contents), + language/japanese.el, language/chinese.el, language/korean.el: + Rename `automatic-conversion' -> `undecided' to sync with Emacs + 20.2. + +1997-10-08 MORIOKA Tomohiko + + * language/viet-chars.el: New file; moved from + mule/vietnamese-hooks-1.el. + + * language/vietnamese.el: Merge mule/vietnamese-hooks-2.el; + abolish mule/vietnamese-hooks-2.el. + + * prim/dumped-lisp.el: Use language/viet-chars and + language/vietnamese instead of mule/vietnamese-hooks-{1|2}. + +1997-10-07 MORIOKA Tomohiko + + * mule/mule-misc.el (split-char): New function. + +1997-10-14 SL Baur + + * default.el: New file. + * site-start.el: New file. XEmacs starts faster if dummy versions + of these files are found early in the `load-path'. + Suggested by Kyle Jones + +1997-10-14 Hrvoje Niksic + + * custom/wid-edit.el (widget-field-find): Use `map-extents'. + (widget-transpose-chars): Check for empty fields, and point at + beginning of field. + (widget-documentation-string-value-create): `insert-char' handles + 0 gracefully, so no need to protect. + (widget-specify-inactive): Detach the button extents. + (widget-specify-active): Reattach the button extents. + (widget-make-field-untabable): New function. + (widget-specify-inactive): Make the fields non-tabable; use + `widget-make-field-untabable'. + (widget-type): Revert to defsubst. + +1997-10-13 Adrian Aichner + + * utils/xemacs-build-report.el: + Switched from (mail ...) to (compose-mail ...) upon suggestion by + Hrvoje Niksic. + Extended xemacs-build-report-keep-regexp. + Changed xemacs-build-report-make-output-file value to beta.err + Shortend and bracketed xemacs-build-report-subject. + Improved (I hope) tm-edit to SEMI aliasing logic. + +1997-10-09 Adrian Aichner + + * utils/xemacs-build-report.el: + Restored RCS keywords and updated comment for `xemacs-build-report-version'. + + * utils/xemacs-build-report.el: + Separated the Spaghetti code into separate functions to do the following: + xemacs-build-report-insert-header + xemacs-build-report-insert-make-output + xemacs-build-report-insert-installation-file + +1997-10-13 Hrvoje Niksic + + * custom/cus-load.el: Disable gc while loading `custom-load' + files. + (custom-put): Added docstring; ignore PROPERTY. + + * custom/wid-edit.el (widget-previous-button-or-field): If the + point is within a button or field, return the beginning position + of the field. + + * prim/frame.el (frame-list): Use `nconc' instead of `append'. + (set-frame-configuration): Use `mapc'. + (delete-other-frames): Ditto. + + * prim/faces.el: Use the CL macro at top-level. + + * prim/faces.el (face-spec-set-match-display): Use `case'. + (set-face-stipple): Use backquotes. + + * custom/wid-edit.el (widget-glyph-find): Use `laxputf'. + (widget-push-button-value-create): Ditto. + + * custom/cus-face.el (custom-face-attributes): Support + inverse-video for TTY-s. + + * prim/cmdloop.el (keyboard-escape-quit): Abort recursive edit, as + documented. + +1997-10-12 Hrvoje Niksic + + * prim/simple.el (zmacs-deactivate-region): Use `mapc' instead of + `mapcar'. + (zmacs-make-extent-for-region): Ditto. + + * custom/cus-dep.el: Updated comments. + + * custom/cus-edit.el (custom-variable-prompt): Prompt with + `variable'. + +1997-10-12 Karl Hegbloom + + * custom/cus-edit.el (custom-guess-name-alist): Allow `-hooks' + instead of `hook'. + +1997-10-12 Hrvoje Niksic + + * prim/profile.el (profile-results): Use %-*s format. + (profile-align): Nuked. + + * packages/gnuserv.el (gnuserv-frame-plist): New variable. + (gnuserv-special-frame-function): Use it. + (gnuserv-edit-files): Ditto. + 1997-10-12 SL Baur * prim/package-admin.el (package-admin-add-binary-package): @@ -45,6 +894,24 @@ (pretty-print-profiling-info): Ditto. From Kyle Jones +1997-10-10 Per Abrahamsen + + * custom/wid-edit.el (variable-link): New widget. + (widget-variable-link-action): New function. + (function-link): New widget. + (widget-function-link-action): New function. + +1997-10-10 Karl M. Hegbloom + + * prim/modeline.el (modeline-minor-mode-menu): menus are toggles + not strings now. + +1997-10-10 SL Baur + + * psgml/psgml-html.el (html-quote-region): Grow bounds when performing + substitutions. + From Adrian Aichner + 1997-10-10 SL Baur * utils/highlight-headers.el (highlight-headers-citation-header-regexp): diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/appt.el --- a/lisp/calendar/appt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,744 +0,0 @@ -;;; appt.el --- appointment notification functions. -;; Keywords: calendar - -;;; -*- Mode:Emacs-Lisp -*- -;; Appointment notification functions. -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; 29-nov-89 created by Neil Mager . -;;; 23-feb-91 hacked upon by Jamie Zawinski . -;;; 1-apr-91 some more. -;;; 12-jul-95 updated for XEmacs 19.12 by Greg Veres -;;; -;;; 21-mar-97 better support for fancy diary display by Tomasz J. Cholewo -;;; -;;; -;; appt.el - visible and/or audible notification of -;; appointments from ~/diary file generated from -;; Edward M. Reingold's calendar.el. -;; -;; Version 2.1 -;; -;; Comments, corrections, and improvements should be sent to -;; Neil M. Mager -;; Net -;; Voice (617) 981-4803 -;;; -;;; Thanks to Edward M. Reingold for much help and many suggestions, -;;; And to many others for bug fixes and suggestions. -;;; -;;; -;;; This functions in this file will alert the user of a -;;; pending appointment based on their diary file. -;;; -;;; ******* It is necessary to invoke 'display-time' and ******** -;;; ******* 'appt-initialize' for this to work properly. ******** -;;; -;;; A message will be displayed in the mode line of the emacs buffer and (if -;;; the user desires) the terminal will beep and display a message from the -;;; diary in the mini-buffer, or the user may select to have a message -;;; displayed in a new buffer. -;;; -;;; Variables of note: -;;; -;;; appt-issue-message If this variable is nil, then the code in this -;;; file does nothing. -;;; appt-msg-countdown-list Specifies how much warning you want before -;;; appointments. -;;; appt-audible Whether to beep when it's notification-time. -;;; appt-display-mode-line Whether to display a countdown to the next -;;; appointment in the mode-line. -;;; appt-announce-method The function used to do the notifications. -;;; 'appt-window-announce do it in a pop-up window. -;;; 'appt-frame-announce do it in a pop-up frame (v19 only) -;;; 'appt-message-announce do it in the echo area. -;;; 'appt-persistent-message-announce do it in the echo area, but make the -;;; messages not go away at the next keystroke. -;;; appt-display-duration If appt-announce-method is set to the function -;;; 'appt-window-announce, this specifies how many -;;; seconds the pop-up window should stick around. -;;; -;;; In order to use this, create a diary file, and add the following to your -;;; .emacs file: -;;; -;;; (require 'appt) -;;; (display-time) -;;; (appt-initialize) -;;; -;;; If you wish to see a list of appointments, or a full calendar, when emacs -;;; starts up, you can add a call to (diary) or (calendar) after this. -;;; -;;; This is an example of what can be in your diary file: -;;; Monday -;;; 9:30am Coffee break -;;; 12:00pm Lunch -;;; -;;; Based upon the above lines in your .emacs and diary files, the calendar -;;; and/or diary will be displayed when you enter emacs and your appointments -;;; list will automatically be created. You will then be reminded at 9:20am -;;; about your coffee break and at 11:50am to go to lunch. -;;; -;;; In order to interactively add or delete items from today's list, use -;;; Meta-x appt-add and Meta-x appt-delete. (This does not modify your -;;; diary file, so these will be forgotten when you exit emacs.) -;;; -;;; Additionally, the appointments list is recreated automatically at 12:01am -;;; for those who do not logout every day or are programming late. -;;; -;;; You can have special appointments which execute arbitrary code rather than -;;; simply notifying you -- sort of like the unix "cron" facility. The syntax -;;; for this is borrowed from the Calendar's special-date format. If you have -;;; a diary entry like -;;; -;;; Monday -;;; 3:00am %%(save-all-modified-buffers) -;;; -;;; then on monday at 3AM, the function `save-all-modified-buffers' will be -;;; invoked. (Presumably this function is defined in your .emacs file.) -;;; There will be no notification that these "special" appointments are being -;;; triggered, unless the form evaluated produces a notification. -;;; -;;; It is necessary for the entire list after the "%%" to be on one line in -;;; your .diary file -- there may not be embedded newlines in it. This is a -;;; bit of a misfeature. -;;; -;;; This also interacts correctly with Benjamin Pierce's reportmail.el package. -;;; -;;; Brief internal description - Skip this if you are not interested! -;;; -;;; The function appt-initialize invokes 'diary' to get a list of today's -;;; appointments, and parses the lines beginning with date descriptions. -;;; This list is cached away. 'diary' is invoked in such a way so as to -;;; not pop up a window displaying the diary buffer. -;;; -;;; The function appt-check is run from the 'loadst' process (or the 'wakeup' -;;; process in emacs 18.57 or newer) which is started by invoking display-time. -;;; It checks this cached list, and announces as appropriate. At midnight, -;;; appt-initialize is called again to rebuild this list. -;;; -;;; display-time-filter is modified to invoke appt-check. -;;; -;;; TO DO: -;;; -;;; o multiple adjacent appointments are not handled gracefully. If there -;;; is an appointment at 3:30 and another at 3:35, and you have set things -;;; up so that you get a notification twenty minutes before each appt, -;;; then a notification should come at 3:10 for the first appt, and at -;;; 3:15 for the second. Currently, no notifications are generated for an -;;; appointment until all preceding appointments have completely expired. -;;; -;;; o If there are two appointments at the same time, all but the first are -;;; ignored (not announced.) -;;; -;;; o Appointments which are early enough in the morning that their -;;; announcements should begin before midnight are not announced until -;;; midnight. -;;; -;;; o There should be some way to mark certain appointments as "important," -;;; so that you will be harassed about them even after they have expired. - - -(require 'calendar) -(require 'diary-lib) - -(defcustom appt-issue-message t - "*If T, the diary buffer is checked for appointments. For an - appointment warning to be made, the time must be the first thing on - the line." - :type 'boolean - :group 'appt) - -(defcustom appt-msg-countdown-list '(20 15 10 5 3 1) - "*A list of the intervals in minutes before the appointment when - the warnings will be given. That is, if this were the list '(5 3 1), - then a notification would be given five minutes, three minutes, and - one minute before the appointment." - :type '(repeat integer) - :group 'appt) - -(defcustom appt-check-time-syntax nil - "*Whether all diary entries are intended to beging with time specifications. -Appt will beep and issue a warning message when encountering unparsable -lines." - :type 'boolean - :group 'appt) - -(defcustom appt-audible t - "*Controls whether appointment announcements should beep. -Appt uses two sound-types for beeps: `appt' and `appt-final'. -If this is a number, then that many beeps will occur. -If this is a cons, the car is how many beeps, and the cdr is the - delay between them (a float, fraction of a second to sleep.) -See also the variable `appt-msg-countdown-list'" - :type 'boolean - :group 'appt) - -(defcustom appt-display-mode-line t - "*Controls if minutes-to-appointment should be displayed on the mode line." - :type 'boolean - :group 'appt) - -(defcustom appt-announce-method 'appt-window-announce - "*The name of the function used to notify the user of an impending -appointment. This is called with two arguments, the number of minutes -until the appointment, and the appointment description list. - -Reasonable values for this variable are 'appt-window-announce, -'appt-message-announce, or 'appt-persistent-message-announce." - :type 'function - :group 'appt) - - -(defvar appt-time-msg-list nil - "The list of appointments for today. Use appt-add and appt-delete - to add and delete appointments from list. The original list is generated - from the today's diary-entries-list. The number before each time/message - is the time in minutes after midnight.") - -(defconst max-time 1439 - "11:59pm in minutes - number of minutes in a day minus 1.") - -(defconst appt-check-tick -1) - -(defvar appt-disp-frame nil - "If non-nil, frame to display appointments in.") -(defvaralias 'appt-disp-screen 'appt-disp-frame) - - -;;; Announcement methods - -(defun appt-message-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in the minibuffer." - (message (if (eq min-to-app 0) "App't NOW." - (format "App't in %d minute%s -- %s" - min-to-app - (if (eq 1 min-to-app) "" "s") - (car (cdr appt)))))) - - -(defun appt-persistent-message-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in the minibuffer, but have those -messages stay around even if you type something (unlike normal messages)." - (let ((str (if (eq min-to-app 0) - (format "App't NOW -- %s" (car (cdr appt))) - (format "App't in %d minute%s -- %s" - min-to-app - (if (eq 1 min-to-app) "" "s") - (car (cdr appt))))) - (in-echo-area-already (eq (selected-window) (minibuffer-window)))) - (if (not in-echo-area-already) - ;; don't stomp the echo-area-buffer if reading from the minibuffer now. - (save-excursion - (save-window-excursion - (select-window (minibuffer-window)) - (delete-region (point-min) (point-max)) - (insert str)))) - ;; if we're reading from the echo-area, and all we were going to do is - ;; clear the thing, like, don't bother, that's annoying. - (if (and in-echo-area-already (string= "" str)) - nil - (message "%s" str)) - )) - - -(defcustom appt-display-duration 5 - "*The number of seconds an appointment message is displayed in its own - window if appt-announce-method is 'appt-window-announce." - :type 'integer - :group 'appt) - -(defun appt-window-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in a pop-up window. The variable -appt-display-duration controls how long this window should be left up." - (require 'electric) - (save-excursion - (save-window-excursion - ;; Make sure we're not in the minibuffer - ;; before splitting the window. - (if (window-minibuffer-p (selected-window)) - nil - (select-window (frame-lowest-window)) - (split-window)) - (let (appt-disp-buf) - (unwind-protect - (progn - (setq appt-disp-buf (set-buffer (get-buffer-create "*appt-buf*"))) - ;; set the mode-line of the pop-up window - (setq modeline-format - (concat "-------------------- Appointment " - (if (eq min-to-app 0) - "NOW" - (concat "in " min-to-app - (if (eq min-to-app 1) " minute" " minutes"))) - ". (" - (let ((h (string-to-int - (substring (current-time-string) 11 13)))) - (concat (if (> h 12) (- h 12) h) ":" - (substring (current-time-string) 14 16) - (if (< h 12) "am" "pm"))) - ") %-")) - (pop-to-buffer appt-disp-buf) - (insert (car (cdr appt))) - (shrink-window-if-larger-than-buffer - (get-buffer-window appt-disp-buf)) - (set-buffer-modified-p nil) - (sit-for appt-display-duration)) - (and appt-disp-buf (kill-buffer appt-disp-buf))))))) - -(defvar appt-frame-defaults nil) -(defvaralias 'appt-screen-defaults 'appt-frame-defaults) - -(defun appt-frame-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in a pop-up frame." - (let () - (save-excursion - (set-buffer (get-buffer-create "*appt-buf*")) - (erase-buffer) - ;; set the mode-line of the pop-up window - (setq modeline-format - (concat "-------------------- Appointment " - (if (eq min-to-app 0) - "NOW" - (concat "in " min-to-app - (if (eq min-to-app 1) " minute" " minutes"))) - ". (" - (let ((h (string-to-int - (substring (current-time-string) 11 13)))) - (concat (if (> h 12) (- h 12) h) ":" - (substring (current-time-string) 14 16) - (if (< h 12) "am" "pm"))) - ") %-")) - (insert (car (cdr appt))) - (let ((height (max 10 (min 20 (+ 2 (count-lines (point-min) - (point-max))))))) - ;; If we already have a frame constructed, use it. If not, or it has - ;; been deleted, then make a new one - (if (and appt-disp-frame (frame-live-p appt-disp-frame)) - (let ((s (selected-frame))) - (select-frame appt-disp-frame) - (make-frame-visible appt-disp-frame) - (set-frame-height appt-disp-frame height) - (sit-for 0) - (select-frame s)) - (progn - (setq appt-disp-frame (make-frame)) - (set-frame-height appt-disp-frame height) - ) - ) - ) - ) - ) - ) -(defalias 'appt-screen-announce 'appt-frame-announce) - -;;; To display stuff in the mode line, we use a new variable instead of -;;; just adding stuff to the display-time-string -- this causes less -;;; flicker. - -(defcustom appt-mode-line-string "" - "*The string displayed in the mode line by the appointment package." - :type 'string - :group 'appt) - -(defun appt-display-mode-line (min-to-app) - "Add an appointment annotation to the mode line." - (setq appt-mode-line-string - (if (and appt-display-mode-line min-to-app) - (if (eq 0 min-to-app) - "App't NOW " - (concat "App't in " min-to-app - (if (eq 1 min-to-app) " minute " " minutes "))) - "")) - ;; make sure our variable is visible in global-mode-string. - (cond ((not appt-display-mode-line) nil) - ((null global-mode-string) - (setq global-mode-string (list "" 'appt-mode-line-string))) - ((stringp global-mode-string) - (setq global-mode-string - (list global-mode-string 'appt-mode-line-string))) - ((not (memq 'appt-mode-line-string global-mode-string)) - (setq global-mode-string - (append global-mode-string (list 'appt-mode-line-string))))) - ;; force mode line updates - from time.el - (save-excursion (set-buffer (other-buffer))) - (set-buffer-modified-p (buffer-modified-p)) - (sit-for 0)) - - -;;; Internal stuff - -(defun appt-convert-time (time2conv) - "Convert hour:min[am/pm] format to minutes from midnight." - (cond ((string-match "^[ \t]*midni\\(ght\\|te\\)[ \t]*\\'" time2conv) - 0) - ((string-match "^[ \t]*noon[ \t]*\\'" time2conv) - (* 12 60)) - (t - (let ((hr 0) - (min 0)) - (or (string-match - "\\`[ \t]*\\([0-9][0-9]?\\)[ \t]*\\(:[ \t]*\\([0-9][0-9]\\)\\)?[ \t]*\\(am\\|pm\\)?" - time2conv) - (error "unparsable time \"%s\"" time2conv)) - (setq hr (string-to-int - (substring time2conv - (match-beginning 1) (match-end 1)))) - (if (match-beginning 3) - (setq min (string-to-int - (substring time2conv - (match-beginning 3) (match-end 3))))) - ;; convert the time appointment time into 24 hour time - (if (match-beginning 4) - (progn - (if (or (= hr 0) (> hr 12)) - (error "mixing 12hr and 24 hr time! %s" time2conv)) - (if (string-match "am" - (substring time2conv (match-beginning 4))) - (if (= hr 12) (setq hr 0)) - (if (< hr 12) (setq hr (+ 12 hr)))))) - (if (> min 59) (error "minutes outa bounds - %s" time2conv)) - (+ (* hr 60) min))))) - - -(defun appt-current-time-in-minutes () - "Returns the current time in minutes since midnight." - (let* ((str (current-time-string)) - (hour (string-to-int (substring str 11 13))) - (min (string-to-int (substring str 14 16)))) - (+ (* hour 60) min))) - - -(defun appt-sort-list (appt-list) - (sort (copy-sequence appt-list) - (function (lambda (x y) - (< (car (car x)) (car (car y))))))) - -(defun appt-diary-entries () - "Return an updated list of appointments for today." - (let ((list-diary-entries-hook '(appt-make-list)) - (diary-display-hook 'ignore) - (diary-list-include-blanks nil)) - ;; this will set appt-time-msg-list. - (diary 1) - appt-time-msg-list)) - -(defun appt-initialize () - "Read your `diary-file' and remember today's appointments. Call this from - your .emacs file, or any time you want your .diary file re-read (this happens - automatically at midnight to notice the next day's appointments). - - The time must be at the beginning of a line for it to be put in the - appointments list. - 02/23/89 - 12:00pm lunch - Wednesday - 10:00am group meeting" - (install-display-time-hook) - (let ((n (length (appt-diary-entries)))) - (cond ((= n 0) (message "no appointments today.")) - ((= n 1) (message "1 appointment today.")) - (t (message "%d appointments today." n))))) - -(defun appt-make-list () - "Don't call this directly; call appt-initialize or appt-diary-entries." - (setq appt-time-msg-list nil) - (if diary-entries-list - ;; Cycle through the entry-list (diary-entries-list) looking for - ;; entries beginning with a time. If the entry begins with a time, - ;; add it to the appt-time-msg-list. Then sort the list. - ;; - (let ((entry-list diary-entries-list) - (new-appts '())) - (while (and entry-list - (calendar-date-equal - (calendar-current-date) (car (car entry-list)))) - (let ((time-string (car (cdr (car entry-list))))) - (while (string-match - "\\`[ \t\n]*\\([0-9]?[0-9]\\(:[0-9][0-9]\\)?[ \t]*\\(am\\|pm\\)?\\|noon\\|midnight\\|midnite\\).*$" - time-string) - (let* ((eol (match-end 0)) - (appt-time-string - (substring time-string (match-beginning 1) - (match-end 1))) - (appt-msg-string - (substring time-string (match-end 1) eol)) - (appt-time (list (appt-convert-time appt-time-string)))) - (setq time-string (substring time-string eol) - new-appts (cons (cons appt-time - (list (concat appt-time-string ":" - appt-msg-string))) - new-appts)))) - (if appt-check-time-syntax - (while (string-match "\n*\\([^\n]+\\)$" time-string) - (beep) - (message "Unparsable time: %s" - (substring time-string (match-beginning 1) - (match-end 1))) - (sit-for 3) - (setq time-string (substring time-string (match-end 0))))) - - ) - (setq entry-list (cdr entry-list))) - (setq appt-time-msg-list ; seems we can't nconc this list... - (append (nreverse new-appts) appt-time-msg-list)))) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)) - ;; - ;; Get the current time and convert it to minutes from midnight, i.e., - ;; 12:01am = 1, midnight = 0, so that the elements in the list that - ;; are earlier than the present time can be removed. - ;; - (let ((cur-comp-time (appt-current-time-in-minutes)) - (appt-comp-time (car (car (car appt-time-msg-list))))) - (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) - (if appt-time-msg-list - (setq appt-comp-time (car (car (car appt-time-msg-list))))))) - appt-time-msg-list) - - -(defun appt-beep (&optional final-p) - (cond ((null appt-audible) nil) - ((numberp appt-audible) - (let ((i appt-audible)) - (while (> i 0) (beep) (setq i (1- i))))) - ((consp appt-audible) - (let ((i (car appt-audible)) - (j (cdr appt-audible))) - (if (consp j) (setq j (car j))) - (while (> i 0) - (if (fboundp 'play-sound) - (beep nil (if final-p 'appt-final 'appt)) - (beep)) - (sleep-for j) - (setq i (1- i))))) - (t (beep)))) - - -(defun appt-check () - "Check for an appointment and update the mode line and minibuffer if - desired. 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 24 hour or am/pm. Example: - - 02/23/89 - 18:00 Dinner - Thursday - 11:45am Lunch meeting. - - The following variables control the action of the notification: - - appt-issue-message If this variable is nil, then the code in this - file does nothing. - appt-msg-countdown-list Specifies how much warning you want before - appointments. - appt-audible Whether to beep when it's notification-time. - appt-display-mode-line Whether to display a countdown to the next - appointment in the mode-line. - appt-announce-method The function used to do the notifications. - 'appt-window-announce to do it in a pop-up - window, 'appt-message-announce or - 'appt-persistent-message-announce to do it - in the echo-area. - appt-display-duration If appt-announce-method is set to the function - 'appt-window-announce, this specifies how many - seconds the pop-up window should stick around. - - This function is run from the `loadst' or `wakeup' process for display-time. - Therefore, you need to have (display-time) in your .emacs file." - (if appt-issue-message - (let ((min-to-app -1)) - ;; Get the current time and convert it to minutes - ;; from midnight, i.e., 12:01am = 1, midnight = 0. - (let* ((cur-comp-time (appt-current-time-in-minutes)) - ;; If the current time is the same as the tick, just return. - ;; This means that this function has been called more than once - ;; in the current minute, which is not useful. - (shut-up-this-time (= cur-comp-time appt-check-tick)) - (turnover-p (> appt-check-tick cur-comp-time))) - (setq appt-check-tick cur-comp-time) - ;; - ;; If it is now the next day (we have crossed midnight since the last - ;; time this was called) then we should update our appointments to - ;; today's list. Show the diary entries (tjc). - (if turnover-p (diary 1)) - ;; - ;; Get the first time off of the list and calculate the number - ;; of minutes until the appointment. - (if appt-time-msg-list - (let ((appt-comp-time (car (car (car appt-time-msg-list))))) - (setq min-to-app (- appt-comp-time cur-comp-time)) - (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) - (if appt-time-msg-list - (setq appt-comp-time (car (car (car appt-time-msg-list)))))) - ;; - ;; If we have an appointment between midnight and warning-time - ;; minutes after midnight, we must begin to issue a message - ;; before midnight. Midnight is considered 0 minutes and 11:59pm - ;; is 1439 minutes. Therefore we must recalculate the minutes to - ;; appointment variable. It is equal to the number of minutes - ;; before midnight plus the number of minutes after midnight our - ;; appointment is. - ;; - ;; ## I don't think this does anything -- it would if it were - ;; (for example) a 12:01am appt on the list at 11:55pm, but that - ;; can't ever happen, because the applicable 12:01am appt is for - ;; tomorrow, not today, and we only have today's diary list. - ;; It's not simply a matter of concatenating two days together, - ;; either, because then tuesday's appts would be signalled on - ;; monday. We have to do a real one-day lookahead -- keep a list - ;; of tomorrow's appts, and check it when near midnight. - ;; - (if (and (< appt-comp-time (apply 'max appt-msg-countdown-list)) - (> (+ cur-comp-time (apply 'max appt-msg-countdown-list)) - max-time)) - (setq min-to-app (+ (- (1+ max-time) cur-comp-time)) - appt-comp-time)) - ;; - ;; issue warning if the appointment time is within warning-time - (cond - ;; if there should not be any notifications in the mode-line, - ;; clear it. - ((> min-to-app (apply 'max appt-msg-countdown-list)) - (appt-display-mode-line nil)) - ;; do nothing if this is the second time this minute we've - ;; gotten here, of if we shouldn't be notifying right now. - ((or shut-up-this-time - (and (not (= min-to-app 0)) - (not (memq min-to-app appt-msg-countdown-list)))) - nil) - - ((and (= min-to-app 0) - (string-match "%%(" (nth 1 (car appt-time-msg-list)))) - ;; - ;; If this is a magic evaluating-notification, evaluate it. - ;; these kinds of notifications aren't subject to the - ;; appt-msg-countdown-list. - ;; - (let* ((list-string (substring (nth 1 (car appt-time-msg-list)) - (1- (match-end 0)))) - (form (condition-case () - (read list-string) - (error - (ding) - (message "Appt: error reading from \"%s\"" - (nth 1 (car appt-time-msg-list))) - (sit-for 2) - nil)))) - (eval form))) - - ((and (<= min-to-app (apply 'max appt-msg-countdown-list)) - (>= min-to-app 0)) - ;; - ;; produce a notification. - (appt-beep (= min-to-app 0)) - (funcall appt-announce-method min-to-app - (car appt-time-msg-list)) - ;; update mode line and expire if necessary - (appt-display-mode-line min-to-app) - ;; if it's expired, remove it. - (if (= min-to-app 0) - (setq appt-time-msg-list (cdr appt-time-msg-list)))) - (t - ;; else we're not near any appointment, or there are no - ;; apointments; make sure mode line is clear. - (appt-display-mode-line nil)))) - (appt-display-mode-line nil)))))) - - - -;;; Interactively adding and deleting appointments - -(defun appt-add (new-appt-time new-appt-msg) - "Adds an appointment to the list of appointments for the day at TIME - and issue MESSAGE. The time should be in either 24 hour format or - am/pm format. " - - (interactive "sTime (hh:mm[am/pm]): \nsMessage: ") - (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" new-appt-time) - nil - (error "Unacceptable time-string")) - - (let* ((appt-time-string (concat new-appt-time " " new-appt-msg)) - (appt-time (list (appt-convert-time new-appt-time))) - (time-msg (cons appt-time (list appt-time-string)))) - (setq appt-time-msg-list (append appt-time-msg-list - (list time-msg))) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)))) - -(defun appt-delete () - "Deletes an appointment from the list of appointments." - (interactive) - (let* ((tmp-msg-list appt-time-msg-list)) - (while tmp-msg-list - (let* ((element (car tmp-msg-list)) - (prompt-string (concat "Delete " - (prin1-to-string (car (cdr element))) - " from list? ")) - (test-input (y-or-n-p prompt-string))) - (setq tmp-msg-list (cdr tmp-msg-list)) - (if test-input - (setq appt-time-msg-list (delq element appt-time-msg-list))))) - (message ""))) - - -;;; Patching in to existing time code to install our hook. - - -(defvar display-time-hook-installed nil) - -(defun install-display-time-hook () - (unless display-time-hook-installed ; only do this stuff once! - (unless (boundp 'display-time-hook) ; Need to wrapper it. - (defvar display-time-hook nil - "*List of functions to be called when the time is updated on the mode line.") - (let ((old-fn (if (or (featurep 'reportmail) - ;; old reportmail without a provide statement - (and (fboundp 'display-time-filter-18-55) - (fboundp 'display-time-filter-18-57))) - (if (and (featurep 'itimer) ; XEmacs reportmail.el - (fboundp 'display-time-timer-function)) - 'display-time-timer-function - ;; older reportmail, or no timer.el. - (if (string-match "18\\.5[0-5]" (emacs-version)) - 'display-time-filter-18-55 - 'display-time-filter-18-57)) - ;; othewise, time.el - (if (and (featurep 'itimer) - (fboundp 'display-time-function)) ; XEmacs - 'display-time-function - 'display-time-filter)))) - ;; we're about to redefine it... - (fset 'old-display-time-filter (symbol-function old-fn)) - (fset old-fn - (lambda (&rest args) ;; ...here's the revised definition - "Revised version of the original function: this version calls a hook." - (apply 'old-display-time-filter args) - (run-hooks 'display-time-hook))))) - (setq display-time-hook-installed t) - (if (fboundp 'add-hook) - (add-hook 'display-time-hook 'appt-check) - (setq display-time-hook (cons appt-check display-time-hook))) - )) - -(provide 'appt) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/auto-autoloads.el --- a/lisp/calendar/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,378 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'calendar-autoloads) (error "Already loaded")) - -;;;### (autoloads nil "cal-dst" "calendar/cal-dst.el") - -(put 'calendar-daylight-savings-starts 'risky-local-variable t) - -(put 'calendar-daylight-savings-ends 'risky-local-variable t) - -;;;*** - -;;;### (autoloads nil "cal-x" "calendar/cal-x.el") - -(defvar calendar-setup 'one-frame "\ -The frame set up of the calendar. -The choices are `one-frame' (calendar and diary together in one separate, -dediciated frame) or `two-frames' (calendar and diary in separate, dedicated -frames); with any other value the current frame is used.") - -;;;*** - -;;;### (autoloads (list-yahrzeit-dates calendar) "calendar" "calendar/calendar.el") - -(defcustom calendar-week-start-day 0 "*The day of the week on which a week in the calendar begins.\n0 means Sunday (default), 1 means Monday, and so on." :type 'integer :group 'calendar) - -(defcustom calendar-offset 0 "*The offset of the principal month from the center of the calendar window.\n0 means the principal month is in the center (default), -1 means on the left,\n+1 means on the right. Larger (or smaller) values push the principal month off\nthe screen." :type 'integer :group 'calendar) - -(defcustom view-diary-entries-initially nil "*Non-nil means display current date's diary entries on entry.\nThe diary is displayed in another window when the calendar is first displayed,\nif the current date is visible. The number of days of diary entries displayed\nis governed by the variable `number-of-diary-entries'." :type 'boolean :group 'diary) - -(defcustom number-of-diary-entries 1 "*Specifies how many days of diary entries are to be displayed initially.\nThis variable affects the diary display when the command M-x diary is used,\nor if the value of the variable `view-diary-entries-initially' is t. For\nexample, if the default value 1 is used, then only the current day's diary\nentries will be displayed. If the value 2 is used, then both the current\nday's and the next day's entries will be displayed.\n\nThe value can also be a vector such as [0 2 2 2 2 4 1]; this value\nsays to display no diary entries on Sunday, the display the entries\nfor the current date and the day after on Monday through Thursday,\ndisplay Friday through Monday's entries on Friday, and display only\nSaturday's entries on Saturday.\n\nThis variable does not affect the diary display with the `d' command\nfrom the calendar; in that case, the prefix argument controls the\nnumber of days of diary entries displayed." :type 'integer :group 'diary) - -(defcustom mark-diary-entries-in-calendar nil "*Non-nil means mark dates with diary entries, in the calendar window.\nThe marking symbol is specified by the variable `diary-entry-marker'." :type 'boolean :group 'diary) - -(defcustom view-calendar-holidays-initially nil "*Non-nil means display holidays for current three month period on entry.\nThe holidays are displayed in another window when the calendar is first\ndisplayed." :type 'boolean :group 'holidays) - -(defcustom mark-holidays-in-calendar nil "*Non-nil means mark dates of holidays in the calendar window.\nThe marking symbol is specified by the variable `calendar-holiday-marker'." :type 'boolean :group 'holidays) - -(defcustom all-hebrew-calendar-holidays nil "*If nil, show only major holidays from the Hebrew calendar.\nThis means only those Jewish holidays that appear on secular calendars.\n\nIf t, show all the holidays that would appear in a complete Hebrew calendar." :type 'boolean :group 'holidays) - -(defcustom all-christian-calendar-holidays nil "*If nil, show only major holidays from the Christian calendar.\nThis means only those Christian holidays that appear on secular calendars.\n\nIf t, show all the holidays that would appear in a complete Christian\ncalendar." :type 'boolean :group 'holidays) - -(defcustom all-islamic-calendar-holidays nil "*If nil, show only major holidays from the Islamic calendar.\nThis means only those Islamic holidays that appear on secular calendars.\n\nIf t, show all the holidays that would appear in a complete Islamic\ncalendar." :type 'boolean :group 'holidays) - -(defcustom calendar-load-hook nil "*List of functions to be called after the calendar is first loaded.\nThis is the place to add key bindings to `calendar-mode-map'." :type 'hook :group 'calendar) - -(defcustom initial-calendar-window-hook nil "*List of functions to be called when the calendar window is first opened.\nThe functions invoked are called after the calendar window is opened, but\nonce opened is never called again. Leaving the calendar with the `q' command\nand reentering it will cause these functions to be called again." :type 'hook :group 'calendar) - -(defcustom today-visible-calendar-hook nil "*List of functions called whenever the current date is visible.\nThis can be used, for example, to replace today's date with asterisks; a\nfunction `calendar-star-date' is included for this purpose:\n (setq today-visible-calendar-hook 'calendar-star-date)\nIt can also be used to mark the current date with `calendar-today-marker';\na function is also provided for this:\n (setq today-visible-calendar-hook 'calendar-mark-today)\n\nThe corresponding variable `today-invisible-calendar-hook' is the list of\nfunctions called when the calendar function was called when the current\ndate is not visible in the window.\n\nOther than the use of the provided functions, the changing of any\ncharacters in the calendar buffer by the hooks may cause the failure of the\nfunctions that move by days and weeks." :type 'hook :group 'calendar) - -(defcustom today-invisible-calendar-hook nil "*List of functions called whenever the current date is not visible.\n\nThe corresponding variable `today-visible-calendar-hook' is the list of\nfunctions called when the calendar function was called when the current\ndate is visible in the window.\n\nOther than the use of the provided functions, the changing of any\ncharacters in the calendar buffer by the hooks may cause the failure of the\nfunctions that move by days and weeks." :type 'hook :group 'calendar) - -(defcustom diary-file "~/diary" "*Name of the file in which one's personal diary of dates is kept.\n\nThe file's entries are lines in any of the forms\n\n MONTH/DAY\n MONTH/DAY/YEAR\n MONTHNAME DAY\n MONTHNAME DAY, YEAR\n DAYNAME\n\nat the beginning of the line; the remainder of the line is the diary entry\nstring for that date. MONTH and DAY are one or two digit numbers, YEAR is\na number and may be written in full or abbreviated to the final two digits.\nIf the date does not contain a year, it is generic and applies to any year.\nDAYNAME entries apply to any date on which is on that day of the week.\nMONTHNAME and DAYNAME can be spelled in full, abbreviated to three\ncharacters (with or without a period), capitalized or not. Any of DAY,\nMONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year,\nrespectively.\n\nThe European style (in which the day precedes the month) can be used\ninstead, if you execute `european-calendar' when in the calendar, or set\n`european-calendar-style' to t in your .emacs file. The European forms are\n\n DAY/MONTH\n DAY/MONTH/YEAR\n DAY MONTHNAME\n DAY MONTHNAME YEAR\n DAYNAME\n\nTo revert to the default American style from the European style, execute\n`american-calendar' in the calendar.\n\nA diary entry can be preceded by the character\n`diary-nonmarking-symbol' (ordinarily `&') to make that entry\nnonmarking--that is, it will not be marked on dates in the calendar\nwindow but will appear in a diary window.\n\nMultiline diary entries are made by indenting lines after the first with\neither a TAB or one or more spaces.\n\nLines not in one the above formats are ignored. Here are some sample diary\nentries (in the default American style):\n\n 12/22/1988 Twentieth wedding anniversary!!\n &1/1. Happy New Year!\n 10/22 Ruth's birthday.\n 21: Payday\n Tuesday--weekly meeting with grad students at 10am\n Supowit, Shen, Bitner, and Kapoor to attend.\n 1/13/89 Friday the thirteenth!!\n &thu 4pm squash game with Lloyd.\n mar 16 Dad's birthday\n April 15, 1989 Income tax due.\n &* 15 time cards due.\n\nIf the first line of a diary entry consists only of the date or day name with\nno trailing blanks or punctuation, then that line is not displayed in the\ndiary window; only the continuation lines is shown. For example, the\nsingle diary entry\n\n 02/11/1989\n Bill Blattner visits Princeton today\n 2pm Cognitive Studies Committee meeting\n 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative'\n 4:00pm Jamie Tappenden\n 7:30pm Dinner at George and Ed's for Alan Ryan\n 7:30-10:00pm dance at Stewart Country Day School\n\nwill appear in the diary window without the date line at the beginning. This\nfacility allows the diary window to look neater, but can cause confusion if\nused with more than one day's entries displayed.\n\nDiary entries can be based on Lisp sexps. For example, the diary entry\n\n %%(diary-block 11 1 1990 11 10 1990) Vacation\n\ncauses the diary entry \"Vacation\" to appear from November 1 through November\n10, 1990. Other functions available are `diary-float', `diary-anniversary',\n`diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date',\n`diary-hebrew-date', `diary-islamic-date', `diary-mayan-date',\n`diary-yahrzeit', `diary-sunrise-sunset', `diary-phases-of-moon',\n`diary-parasha', `diary-omer', `diary-rosh-hodesh', and\n`diary-sabbath-candles'. See the documentation for the function\n`list-sexp-diary-entries' for more details.\n\nDiary entries based on the Hebrew and/or the Islamic calendar are also\npossible, but because these are somewhat slow, they are ignored\nunless you set the `nongregorian-diary-listing-hook' and the\n`nongregorian-diary-marking-hook' appropriately. See the documentation\nfor these functions for details.\n\nDiary files can contain directives to include the contents of other files; for\ndetails, see the documentation for the variable `list-diary-entries-hook'." :type 'file :group 'diary) - -(defcustom diary-nonmarking-symbol "&" "*Symbol indicating that a diary entry is not to be marked in the calendar." :type 'string :group 'diary) - -(defcustom hebrew-diary-entry-symbol "H" "*Symbol indicating a diary entry according to the Hebrew calendar." :type 'string :group 'diary) - -(defcustom islamic-diary-entry-symbol "I" "*Symbol indicating a diary entry according to the Islamic calendar." :type 'string :group 'diary) - -(defcustom diary-include-string "#include" "*The string indicating inclusion of another file of diary entries.\nSee the documentation for the function `include-other-diary-files'." :type 'string :group 'diary) - -(defcustom sexp-diary-entry-symbol "%%" "*The string used to indicate a sexp diary entry in diary-file.\nSee the documentation for the function `list-sexp-diary-entries'." :type 'string :group 'diary) - -(defcustom abbreviated-calendar-year t "*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD.\nFor the Gregorian calendar; similarly for the Hebrew and Islamic calendars.\nIf this variable is nil, years must be written in full." :type 'boolean :group 'diary) - -(defcustom european-calendar-style nil "*Use the European style of dates in the diary and in any displays.\nIf this variable is t, a date 1/2/1990 would be interpreted as February 1,\n1990. The accepted European date styles are\n\n DAY/MONTH\n DAY/MONTH/YEAR\n DAY MONTHNAME\n DAY MONTHNAME YEAR\n DAYNAME\n\nNames can be capitalized or not, written in full, or abbreviated to three\ncharacters with or without a period." :type 'boolean :group 'diary) - -(defcustom american-date-diary-pattern '((month "/" day "[^/0-9]") (month "/" day "/" year "[^0-9]") (monthname " *" day "[^,0-9]") (monthname " *" day ", *" year "[^0-9]") (dayname "\\W")) "*List of pseudo-patterns describing the American patterns of date used.\nSee the documentation of `diary-date-forms' for an explanation." :type '(repeat (choice (cons :tag "Backup" (const backup) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp)))) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp))))) :group 'diary) - -(defcustom european-date-diary-pattern '((day "/" month "[^/0-9]") (day "/" month "/" year "[^0-9]") (backup day " *" monthname "\\W+\\<[^*0-9]") (day " *" monthname " *" year "[^0-9]") (dayname "\\W")) "*List of pseudo-patterns describing the European patterns of date used.\nSee the documentation of `diary-date-forms' for an explanation." :type '(repeat (choice (cons :tag "Backup" (const backup) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp)))) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp))))) :group 'diary) - -(defcustom european-calendar-display-form '((if dayname (concat dayname ", ")) day " " monthname " " year) "*Pseudo-pattern governing the way a date appears in the European style.\nSee the documentation of calendar-date-display-form for an explanation." :type 'sexp :group 'calendar) - -(defcustom american-calendar-display-form '((if dayname (concat dayname ", ")) monthname " " day ", " year) "*Pseudo-pattern governing the way a date appears in the American style.\nSee the documentation of `calendar-date-display-form' for an explanation." :type 'sexp :group 'calendar) - -(defcustom print-diary-entries-hook 'lpr-buffer "*List of functions called after a temporary diary buffer is prepared.\nThe buffer shows only the diary entries currently visible in the diary\nbuffer. The default just does the printing. Other uses might include, for\nexample, rearranging the lines into order by day and time, saving the buffer\ninstead of deleting it, or changing the function used to do the printing." :type 'hook :group 'diary) - -(defcustom list-diary-entries-hook nil "*List of functions called after diary file is culled for relevant entries.\nIt is to be used for diary entries that are not found in the diary file.\n\nA function `include-other-diary-files' is provided for use as the value of\nthis hook. This function enables you to use shared diary files together\nwith your own. The files included are specified in the diary file by lines\nof the form\n\n #include \"filename\"\n\nThis is recursive; that is, #include directives in files thus included are\nobeyed. You can change the \"#include\" to some other string by changing\nthe variable `diary-include-string'. When you use `include-other-diary-files'\nas part of the list-diary-entries-hook, you will probably also want to use the\nfunction `mark-included-diary-files' as part of `mark-diary-entries-hook'.\n\nFor example, you could use\n\n (setq list-diary-entries-hook\n '(include-other-diary-files sort-diary-entries))\n (setq diary-display-hook 'fancy-diary-display)\n\nin your `.emacs' file to cause the fancy diary buffer to be displayed with\ndiary entries from various included files, each day's entries sorted into\nlexicographic order." :type 'hook :group 'diary) - -(defcustom diary-hook nil "*List of functions called after the display of the diary.\nCan be used for appointment notification." :type 'hook :group 'diary) - -(defcustom diary-display-hook nil "*List of functions that handle the display of the diary.\nIf nil (the default), `simple-diary-display' is used. Use `ignore' for no\ndiary display.\n\nOrdinarily, this just displays the diary buffer (with holidays indicated in\nthe mode line), if there are any relevant entries. At the time these\nfunctions are called, the variable `diary-entries-list' is a list, in order\nby date, of all relevant diary entries in the form of ((MONTH DAY YEAR)\nSTRING), where string is the diary entry for the given date. This can be\nused, for example, a different buffer for display (perhaps combined with\nholidays), or produce hard copy output.\n\nA function `fancy-diary-display' is provided as an alternative\nchoice for this hook; this function prepares a special noneditable diary\nbuffer with the relevant diary entries that has neat day-by-day arrangement\nwith headings. The fancy diary buffer will show the holidays unless the\nvariable `holidays-in-diary-buffer' is set to nil. Ordinarily, the fancy\ndiary buffer will not show days for which there are no diary entries, even\nif that day is a holiday; if you want such days to be shown in the fancy\ndiary buffer, set the variable `diary-list-include-blanks' to t." :type 'hook :group 'diary) - -(defcustom nongregorian-diary-listing-hook nil "*List of functions called for listing diary file and included files.\nAs the files are processed for diary entries, these functions are used to cull\nrelevant entries. You can use either or both of `list-hebrew-diary-entries'\nand `list-islamic-diary-entries'. The documentation for these functions\ndescribes the style of such diary entries." :type 'hook :group 'diary) - -(defcustom mark-diary-entries-hook nil "*List of functions called after marking diary entries in the calendar.\n\nA function `mark-included-diary-files' is also provided for use as the\nmark-diary-entries-hook; it enables you to use shared diary files together\nwith your own. The files included are specified in the diary file by lines\nof the form\n #include \"filename\"\nThis is recursive; that is, #include directives in files thus included are\nobeyed. You can change the \"#include\" to some other string by changing the\nvariable `diary-include-string'. When you use `mark-included-diary-files' as\npart of the mark-diary-entries-hook, you will probably also want to use the\nfunction `include-other-diary-files' as part of `list-diary-entries-hook'." :type 'hook :group 'diary) - -(defcustom nongregorian-diary-marking-hook nil "*List of functions called for marking diary file and included files.\nAs the files are processed for diary entries, these functions are used to cull\nrelevant entries. You can use either or both of `mark-hebrew-diary-entries'\nand `mark-islamic-diary-entries'. The documentation for these functions\ndescribes the style of such diary entries." :type 'hook :group 'diary) - -(defcustom diary-list-include-blanks nil "*If nil, do not include days with no diary entry in the list of diary entries.\nSuch days will then not be shown in the fancy diary buffer, even if they\nare holidays." :type 'boolean :group 'diary) - -(defcustom holidays-in-diary-buffer t "*Non-nil means include holidays in the diary display.\nThe holidays appear in the mode line of the diary buffer, or in the\nfancy diary buffer next to the date. This slows down the diary functions\nsomewhat; setting it to nil makes the diary display faster." :type 'boolean :group 'diary) - -(defcustom general-holidays '((holiday-fixed 1 1 "New Year's Day") (holiday-float 1 1 3 "Martin Luther King Day") (holiday-fixed 2 2 "Ground Hog Day") (holiday-fixed 2 14 "Valentine's Day") (holiday-float 2 1 3 "President's Day") (holiday-fixed 3 17 "St. Patrick's Day") (holiday-fixed 4 1 "April Fool's Day") (holiday-float 5 0 2 "Mother's Day") (holiday-float 5 1 -1 "Memorial Day") (holiday-fixed 6 14 "Flag Day") (holiday-float 6 0 3 "Father's Day") (holiday-fixed 7 4 "Independence Day") (holiday-float 9 1 1 "Labor Day") (holiday-float 10 1 2 "Columbus Day") (holiday-fixed 10 31 "Halloween") (holiday-fixed 11 11 "Veteran's Day") (holiday-float 11 4 4 "Thanksgiving")) "*General holidays. Default value is for the United States.\nSee the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) - -(put 'general-holidays 'risky-local-variable t) - -(defcustom local-holidays nil "*Local holidays.\nSee the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays :group 'local) - -(put 'local-holidays 'risky-local-variable t) - -(defcustom other-holidays nil "*User defined holidays.\nSee the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) - -(put 'other-holidays 'risky-local-variable t) - -(defvar hebrew-holidays-1 '((holiday-rosh-hashanah-etc) (if all-hebrew-calendar-holidays (holiday-julian 11 (let* ((m displayed-month) (y displayed-year) (year)) (increment-calendar-month m y -1) (let ((year (extract-calendar-year (calendar-julian-from-absolute (calendar-absolute-from-gregorian (list m 1 y)))))) (if (zerop (% (1+ year) 4)) 22 21))) "\"Tal Umatar\" (evening)")))) - -(put 'hebrew-holidays-1 'risky-local-variable t) - -(defvar hebrew-holidays-2 '((if all-hebrew-calendar-holidays (holiday-hanukkah) (holiday-hebrew 9 25 "Hanukkah")) (if all-hebrew-calendar-holidays (holiday-hebrew 10 (let ((h-year (extract-calendar-year (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (list displayed-month 28 displayed-year)))))) (if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year)) 7) 6) 11 10)) "Tzom Teveth")) (if all-hebrew-calendar-holidays (holiday-hebrew 11 15 "Tu B'Shevat")))) - -(put 'hebrew-holidays-2 'risky-local-variable t) - -(defvar hebrew-holidays-3 '((if all-hebrew-calendar-holidays (holiday-hebrew 11 (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y 1) (let* ((h-year (extract-calendar-year (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (list m (calendar-last-day-of-month m y) y))))) (s-s (calendar-hebrew-from-absolute (if (= (% (calendar-absolute-from-hebrew (list 7 1 h-year)) 7) 6) (calendar-dayname-on-or-before 6 (calendar-absolute-from-hebrew (list 11 17 h-year))) (calendar-dayname-on-or-before 6 (calendar-absolute-from-hebrew (list 11 16 h-year)))))) (day (extract-calendar-day s-s))) day)) "Shabbat Shirah")))) - -(put 'hebrew-holidays-3 'risky-local-variable t) - -(defvar hebrew-holidays-4 '((holiday-passover-etc) (if (and all-hebrew-calendar-holidays (let* ((m displayed-month) (y displayed-year) (year)) (increment-calendar-month m y -1) (let ((year (extract-calendar-year (calendar-julian-from-absolute (calendar-absolute-from-gregorian (list m 1 y)))))) (= 21 (% year 28))))) (holiday-julian 3 26 "Kiddush HaHamah")) (if all-hebrew-calendar-holidays (holiday-tisha-b-av-etc)))) - -(put 'hebrew-holidays-4 'risky-local-variable t) - -(defvar hebrew-holidays (append hebrew-holidays-1 hebrew-holidays-2 hebrew-holidays-3 hebrew-holidays-4) "\ -*Jewish holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'hebrew-holidays 'risky-local-variable t) - -(defvar christian-holidays '((if all-christian-calendar-holidays (holiday-fixed 1 6 "Epiphany")) (holiday-easter-etc) (if all-christian-calendar-holidays (holiday-greek-orthodox-easter)) (if all-christian-calendar-holidays (holiday-fixed 8 15 "Assumption")) (if all-christian-calendar-holidays (holiday-advent)) (holiday-fixed 12 25 "Christmas") (if all-christian-calendar-holidays (holiday-julian 12 25 "Eastern Orthodox Christmas"))) "\ -*Christian holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'christian-holidays 'risky-local-variable t) - -(defvar islamic-holidays '((holiday-islamic 1 1 (format "Islamic New Year %d" (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y 1) (extract-calendar-year (calendar-islamic-from-absolute (calendar-absolute-from-gregorian (list m (calendar-last-day-of-month m y) y))))))) (if all-islamic-calendar-holidays (holiday-islamic 1 10 "Ashura")) (if all-islamic-calendar-holidays (holiday-islamic 3 12 "Mulad-al-Nabi")) (if all-islamic-calendar-holidays (holiday-islamic 7 26 "Shab-e-Mi'raj")) (if all-islamic-calendar-holidays (holiday-islamic 8 15 "Shab-e-Bara't")) (holiday-islamic 9 1 "Ramadan Begins") (if all-islamic-calendar-holidays (holiday-islamic 9 27 "Shab-e Qadr")) (if all-islamic-calendar-holidays (holiday-islamic 10 1 "Id-al-Fitr")) (if all-islamic-calendar-holidays (holiday-islamic 12 10 "Id-al-Adha"))) "\ -*Islamic holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'islamic-holidays 'risky-local-variable t) - -(defvar solar-holidays '((if (fboundp 'atan) (solar-equinoxes-solstices)) (if (progn (require 'cal-dst) t) (funcall 'holiday-sexp calendar-daylight-savings-starts '(format "Daylight Savings Time Begins %s" (if (fboundp 'atan) (solar-time-string (/ calendar-daylight-savings-starts-time (float 60)) calendar-standard-time-zone-name) "")))) (funcall 'holiday-sexp calendar-daylight-savings-ends '(format "Daylight Savings Time Ends %s" (if (fboundp 'atan) (solar-time-string (/ calendar-daylight-savings-ends-time (float 60)) calendar-daylight-time-zone-name) "")))) "\ -*Sun-related holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'solar-holidays 'risky-local-variable t) - -(defvar calendar-holidays (append general-holidays local-holidays other-holidays christian-holidays hebrew-holidays islamic-holidays solar-holidays) "\ -*List of notable days for the command M-x holidays. - -Additional holidays are easy to add to the list, just put them in the list -`other-holidays' in your .emacs file. Similarly, by setting any of -`general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays', -`islamic-holidays', or `solar-holidays' to nil in your .emacs file, you can -eliminate unwanted categories of holidays. The intention is that (in the US) -`local-holidays' be set in site-init.el and `other-holidays' be set by the -user. - -Entries on the list are expressions that return (possibly empty) lists of -items of the form ((month day year) string) of a holiday in the in the -three-month period centered around `displayed-month' of `displayed-year'. -Several basic functions are provided for this purpose: - - (holiday-fixed MONTH DAY STRING) is a fixed date on the Gregorian calendar - (holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in - MONTH on the Gregorian calendar (0 for Sunday, - etc.); K<0 means count back from the end of the - month. An optional parameter DAY means the Kth - DAYNAME after/before MONTH DAY. - (holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar - (holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar - (holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar - (holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression - in the variable `year'; if it evaluates to - a visible date, that's the holiday; if it - evaluates to nil, there's no holiday. STRING - is an expression in the variable `date'. - -For example, to add Bastille Day, celebrated in France on July 14, add - - (holiday-fixed 7 14 \"Bastille Day\") - -to the list. To add Hurricane Supplication Day, celebrated in the Virgin -Islands on the fourth Monday in August, add - - (holiday-float 8 1 4 \"Hurricane Supplication Day\") - -to the list (the last Monday would be specified with `-1' instead of `4'). -To add the last day of Hanukkah to the list, use - - (holiday-hebrew 10 2 \"Last day of Hanukkah\") - -since the Hebrew months are numbered with 1 starting from Nisan, while to -add the Islamic feast celebrating Mohammed's birthday use - - (holiday-islamic 3 12 \"Mohammed's Birthday\") - -since the Islamic months are numbered from 1 starting with Muharram. To -add Thomas Jefferson's birthday, April 2, 1743 (Julian), use - - (holiday-julian 4 2 \"Jefferson's Birthday\") - -To include a holiday conditionally, use the sexp form or a conditional. For -example, to include American presidential elections, which occur on the first -Tuesday after the first Monday in November of years divisible by 4, add - - (holiday-sexp - (if (zerop (% year 4)) - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 year))))))) - \"US Presidential Election\") - -or - - (if (zerop (% displayed-year 4)) - (holiday-fixed 11 - (extract-calendar-day - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 displayed-year))))))) - \"US Presidential Election\")) - -to the list. To include the phases of the moon, add - - (lunar-phases) - -to the holiday list, where `lunar-phases' is an Emacs-Lisp function that -you've written to return a (possibly empty) list of the relevant VISIBLE dates -with descriptive strings such as - - (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... ).") - -(put 'calendar-holidays 'risky-local-variable t) - -(autoload 'calendar "calendar" "\ -Display a three-month calendar in another window. -The three months appear side by side, with the current month in the middle -surrounded by the previous and next months. The cursor is put on today's date. - -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file; appropriate setting -of the variable `view-diary-entries-initially' will cause the diary entries for -the current date to be displayed in another window. The value of the variable -`number-of-diary-entries' controls the number of days of diary entries -displayed upon initial display of the calendar. - -An optional prefix argument ARG causes the calendar displayed to be ARG -months in the future if ARG is positive or in the past if ARG is negative; -in this case the cursor goes on the first day of the month. - -Once in the calendar window, future or past months can be moved into view. -Arbitrary months can be displayed, or the calendar can be scrolled forward -or backward. - -The cursor can be moved forward or backward by one day, one week, one month, -or one year. All of these commands take prefix arguments which, when negative, -cause movement in the opposite direction. For convenience, the digit keys -and the minus sign are automatically prefixes. The window is replotted as -necessary to display the desired date. - -Diary entries can be marked on the calendar or displayed in another window. - -Use M-x describe-mode for details of the key bindings in the calendar window. - -The Gregorian calendar is assumed. - -After loading the calendar, the hooks given by the variable -`calendar-load-hook' are run. This is the place to add key bindings to the -calendar-mode-map. - -After preparing the calendar window initially, the hooks given by the variable -`initial-calendar-window-hook' are run. - -The hooks given by the variable `today-visible-calendar-hook' are run -everytime the calendar window gets scrolled, if the current date is visible -in the window. If it is not visible, the hooks given by the variable -`today-invisible-calendar-hook' are run. Thus, for example, setting -`today-visible-calendar-hook' to 'calendar-star-date will cause today's date -to be replaced by asterisks to highlight it whenever it is in the window." t nil) - -(autoload 'list-yahrzeit-dates "calendar" "\ -List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR. -When called interactively from the calendar window, the date of death is taken -from the cursor position." t nil) - -;;;*** - -;;;### (autoloads (diary) "diary-lib" "calendar/diary-lib.el") - -(autoload 'diary "diary-lib" "\ -Generate the diary window for ARG days starting with the current date. -If no argument is provided, the number of days of diary entries is governed -by the variable `number-of-diary-entries'. This function is suitable for -execution in a `.emacs' file." t nil) - -;;;*** - -;;;### (autoloads (holidays) "holidays" "calendar/holidays.el") - -(autoload 'holidays "holidays" "\ -Display the holidays for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." t nil) - -;;;*** - -;;;### (autoloads (phases-of-moon) "lunar" "calendar/lunar.el") - -(autoload 'phases-of-moon "lunar" "\ -Display the quarters of the moon for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." t nil) - -;;;*** - -;;;### (autoloads (solar-equinoxes-solstices sunrise-sunset) "solar" "calendar/solar.el") - -(defvar calendar-time-display-form '(12-hours ":" minutes am-pm (if time-zone " (") time-zone (if time-zone ")")) "\ -*The pseudo-pattern that governs the way a time of day is formatted. - -A pseudo-pattern is a list of expressions that can involve the keywords -`12-hours', `24-hours', and `minutes', all numbers in string form, -and `am-pm' and `time-zone', both alphabetic strings. - -For example, the form - - '(24-hours \":\" minutes - (if time-zone \" (\") time-zone (if time-zone \")\")) - -would give military-style times like `21:07 (UTC)'.") - -(defvar calendar-latitude nil "\ -*Latitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + north, - south, such as 40.7 for New York City, or the value -can be a vector [degrees minutes north/south] such as [40 50 north] for New -York City. - -This variable should be set in site-local.el.") - -(defvar calendar-longitude nil "\ -*Longitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + east, - west, such as -73.9 for New York City, or the value -can be a vector [degrees minutes east/west] such as [73 55 west] for New -York City. - -This variable should be set in site-local.el.") - -(defvar calendar-location-name '(let ((float-output-format "%.1f")) (format "%s%s, %s%s" (if (numberp calendar-latitude) (abs calendar-latitude) (+ (aref calendar-latitude 0) (/ (aref calendar-latitude 1) 60.0))) (if (numberp calendar-latitude) (if (> calendar-latitude 0) "N" "S") (if (equal (aref calendar-latitude 2) 'north) "N" "S")) (if (numberp calendar-longitude) (abs calendar-longitude) (+ (aref calendar-longitude 0) (/ (aref calendar-longitude 1) 60.0))) (if (numberp calendar-longitude) (if (> calendar-longitude 0) "E" "W") (if (equal (aref calendar-latitude 2) 'east) "E" "W")))) "\ -*Expression evaluating to name of `calendar-longitude', calendar-latitude'. -For example, \"New York City\". Default value is just the latitude, longitude -pair. - -This variable should be set in site-local.el.") - -(autoload 'sunrise-sunset "solar" "\ -Local time of sunrise and sunset for today. Accurate to +/- 2 minutes. -If called with an optional prefix argument, prompt for date. - -If called with an optional double prefix argument, prompt for longitude, -latitude, time zone, and date, and always use standard time. - -This function is suitable for execution in a .emacs file." t nil) - -(autoload 'solar-equinoxes-solstices "solar" "\ -Date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." nil nil) - -;;;*** - -(provide 'calendar-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/cal-dst.el --- a/lisp/calendar/cal-dst.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,335 +0,0 @@ -;;; cal-dst.el --- calendar functions for daylight savings rules. - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Paul Eggert -;; Edward M. Reingold -;; Keywords: calendar -;; Human-Keywords: daylight savings time, calendar, diary, holidays - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; holiday.el that deal with daylight savings time. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -(defvar calendar-current-time-zone-cache nil - "Cache for result of calendar-current-time-zone.") - -(defvar calendar-system-time-basis - (calendar-absolute-from-gregorian '(1 1 1970)) - "Absolute date of starting date of system clock.") - -(defun calendar-absolute-from-time (x utc-diff) - "Absolute local date of time X; local time is UTC-DIFF seconds from UTC. - -X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the -high and low 16 bits, respectively, of the number of seconds since -1970-01-01 00:00:00 UTC, ignoring leap seconds. - -Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on -absolute date ABS-DATE is the equivalent moment to X." - (let* ((h (car x)) - (xtail (cdr x)) - (l (+ utc-diff (if (numberp xtail) xtail (car xtail)))) - (u (+ (* 512 (mod h 675)) (floor l 128)))) - ;; Overflow is a terrible thing! - (cons (+ calendar-system-time-basis - ;; floor((2^16 h +l) / (60*60*24)) - (* 512 (floor h 675)) (floor u 675)) - ;; (2^16 h +l) mod (60*60*24) - (+ (* (mod u 675) 128) (mod l 128))))) - -(defun calendar-time-from-absolute (abs-date s) - "Time of absolute date ABS-DATE, S seconds after midnight. - -Returns the pair (HIGH . LOW) where HIGH and LOW are the high and low -16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC, -ignoring leap seconds, that is the equivalent moment to S seconds after -midnight UTC on absolute date ABS-DATE." - (let* ((a (- abs-date calendar-system-time-basis)) - (u (+ (* 163 (mod a 512)) (floor s 128)))) - ;; Overflow is a terrible thing! - (cons - ;; floor((60*60*24*a + s) / 2^16) - (+ a (* 163 (floor a 512)) (floor u 512)) - ;; (60*60*24*a + s) mod 2^16 - (+ (* 128 (mod u 512)) (mod s 128))))) - -(defun calendar-next-time-zone-transition (time) - "Return the time of the next time zone transition after TIME. -Both TIME and the result are acceptable arguments to current-time-zone. -Return nil if no such transition can be found." - (let* ((base 65536);; 2^16 = base of current-time output - (quarter-multiple 120);; approx = (seconds per quarter year) / base - (time-zone (current-time-zone time)) - (time-utc-diff (car time-zone)) - hi - hi-zone - (hi-utc-diff time-utc-diff) - (quarters '(2 1 3))) - ;; Heuristic: probe the time zone offset in the next three calendar - ;; quarters, looking for a time zone offset different from TIME. - (while (and quarters (eq time-utc-diff hi-utc-diff)) - (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0)) - (setq hi-zone (current-time-zone hi)) - (setq hi-utc-diff (car hi-zone)) - (setq quarters (cdr quarters))) - (and - time-utc-diff - hi-utc-diff - (not (eq time-utc-diff hi-utc-diff)) - ;; Now HI is after the next time zone transition. - ;; Set LO to TIME, and then binary search to increase LO and decrease HI - ;; until LO is just before and HI is just after the time zone transition. - (let* ((tail (cdr time)) - (lo (cons (car time) (if (numberp tail) tail (car tail)))) - probe) - (while - ;; Set PROBE to halfway between LO and HI, rounding down. - ;; If PROBE equals LO, we are done. - (let* ((lsum (+ (cdr lo) (cdr hi))) - (hsum (+ (car lo) (car hi) (/ lsum base))) - (hsumodd (logand 1 hsum))) - (setq probe (cons (/ (- hsum hsumodd) 2) - (/ (+ (* hsumodd base) (% lsum base)) 2))) - (not (equal lo probe))) - ;; Set either LO or HI to PROBE, depending on probe results. - (if (eq (car (current-time-zone probe)) hi-utc-diff) - (setq hi probe) - (setq lo probe))) - hi)))) - -(defun calendar-time-zone-daylight-rules (abs-date utc-diff) - "Return daylight transition rule for ABS-DATE, UTC-DIFF sec offset from UTC. -ABS-DIFF must specify a day that contains a daylight savings transition. -The result has the proper form for calendar-daylight-savings-starts'." - (let* ((date (calendar-gregorian-from-absolute abs-date)) - (weekday (% abs-date 7)) - (m (extract-calendar-month date)) - (d (extract-calendar-day date)) - (y (extract-calendar-year date)) - (last (calendar-last-day-of-month m y)) - (candidate-rules - (append - ;; Day D of month M. - (list (list 'list m d 'year)) - ;; The first WEEKDAY of month M. - (if (< d 8) - (list (list 'calendar-nth-named-day 1 weekday m 'year))) - ;; The last WEEKDAY of month M. - (if (> d (- last 7)) - (list (list 'calendar-nth-named-day -1 weekday m 'year))) - ;; The first WEEKDAY after day J of month M, for D-6 < J <= D. - (let (l) - (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do - (setq l - (cons - (list 'calendar-nth-named-day 1 weekday m 'year j) - l))) - l))) - (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day - (year (1+ y))) - ;; Scan through the next few years until only one rule remains. - (while - (let ((rules candidate-rules) - new-rules) - (while - (let* - ((rule (car rules)) - (date - ;; The following is much faster than - ;; (calendar-absolute-from-gregorian (eval rule)). - (cond ((eq (car rule) 'calendar-nth-named-day) - (eval (cons 'calendar-nth-named-absday (cdr rule)))) - ((eq (car rule) 'calendar-gregorian-from-absolute) - (eval (car (cdr rule)))) - (t (let ((g (eval rule))) - (calendar-absolute-from-gregorian g)))))) - (or (equal - (current-time-zone - (calendar-time-from-absolute date prevday-sec)) - (current-time-zone - (calendar-time-from-absolute (1+ date) prevday-sec))) - (setq new-rules (cons rule new-rules))) - (setq rules (cdr rules)))) - ;; If no rules remain, just use the first candidate rule; - ;; it's wrong in general, but it's right for at least one year. - (setq candidate-rules (if new-rules (nreverse new-rules) - (list (car candidate-rules)))) - (setq year (1+ year)) - (cdr candidate-rules))) - (car candidate-rules))) - -(defun calendar-current-time-zone () - "Return UTC difference, dst offset, names and rules for current time zone. - -Returns (UTC-DIFF DST-OFFSET STD-ZONE DST-ZONE DST-STARTS DST-ENDS -DST-STARTS-TIME DST-ENDS-TIME), based on a heuristic probing of what the -system knows: - -UTC-DIFF is an integer specifying the number of minutes difference between - standard time in the current time zone and Coordinated Universal Time - (Greenwich Mean Time). A negative value means west of Greenwich. -DST-OFFSET is an integer giving the daylight savings time offset in minutes. -STD-ZONE is a string giving the name of the time zone when no seasonal time - adjustment is in effect. -DST-ZONE is a string giving the name of the time zone when there is a seasonal - time adjustment in effect. -DST-STARTS and DST-ENDS are sexps in the variable `year' giving the daylight - savings time start and end rules, in the form expected by - `calendar-daylight-savings-starts'. -DST-STARTS-TIME and DST-ENDS-TIME are integers giving the number of minutes - after midnight that daylight savings time starts and ends. - -If the local area does not use a seasonal time adjustment, STD-ZONE and -DST-ZONE are equal, and all the DST-* integer variables are 0. - -Some operating systems cannot provide all this information to Emacs; in this -case, `calendar-current-time-zone' returns a list containing nil for the data -it can't find." - (or - calendar-current-time-zone-cache - (setq - calendar-current-time-zone-cache - (let* ((t0 (current-time)) - (t0-zone (current-time-zone t0)) - (t0-utc-diff (car t0-zone)) - (t0-name (car (cdr t0-zone)))) - (if (not t0-utc-diff) - ;; Little or no time zone information is available. - (list nil nil t0-name t0-name nil nil nil nil) - (let* ((t1 (calendar-next-time-zone-transition t0)) - (t2 (and t1 (calendar-next-time-zone-transition t1)))) - (if (not t2) - ;; This locale does not have daylight savings time. - (list (/ t0-utc-diff 60) 0 t0-name t0-name nil nil 0 0) - ;; Use heuristics to find daylight savings parameters. - (let* ((t1-zone (current-time-zone t1)) - (t1-utc-diff (car t1-zone)) - (t1-name (car (cdr t1-zone))) - (t1-date-sec (calendar-absolute-from-time t1 t0-utc-diff)) - (t2-date-sec (calendar-absolute-from-time t2 t1-utc-diff)) - (t1-rules (calendar-time-zone-daylight-rules - (car t1-date-sec) t0-utc-diff)) - (t2-rules (calendar-time-zone-daylight-rules - (car t2-date-sec) t1-utc-diff)) - (t1-time (/ (cdr t1-date-sec) 60)) - (t2-time (/ (cdr t2-date-sec) 60))) - (cons - (/ (min t0-utc-diff t1-utc-diff) 60) - (cons - (/ (abs (- t0-utc-diff t1-utc-diff)) 60) - (if (< t0-utc-diff t1-utc-diff) - (list t0-name t1-name t1-rules t2-rules t1-time t2-time) - (list t1-name t0-name t2-rules t1-rules t2-time t1-time) - ))))))))))) - -;;; The following six defvars relating to daylight savings time should NOT be -;;; marked to go into loaddefs.el where they would be evaluated when Emacs is -;;; dumped. These variables' appropriate values depend on the conditions under -;;; which the code is INVOKED; so it's inappropriate to initialize them when -;;; Emacs is dumped---they should be initialized when calendar.el is loaded. -;;; They default to US Eastern time if time zone info is not available. - -(calendar-current-time-zone) - -(defvar calendar-time-zone (or (car calendar-current-time-zone-cache) -300) - "*Number of minutes difference between local standard time at -`calendar-location-name' and Coordinated Universal (Greenwich) Time. For -example, -300 for New York City, -480 for Los Angeles.") - -(defvar calendar-daylight-time-offset - (or (car (cdr calendar-current-time-zone-cache)) 60) - "*Number of minutes difference between daylight savings and standard time. - -If the locale never uses daylight savings time, set this to 0.") - -(defvar calendar-standard-time-zone-name - (or (car (nthcdr 2 calendar-current-time-zone-cache)) "EST") - "*Abbreviated name of standard time zone at `calendar-location-name'. -For example, \"EST\" in New York City, \"PST\" for Los Angeles.") - -(defvar calendar-daylight-time-zone-name - (or (car (nthcdr 3 calendar-current-time-zone-cache)) "EDT") - "*Abbreviated name of daylight-savings time zone at `calendar-location-name'. -For example, \"EDT\" in New York City, \"PDT\" for Los Angeles.") - -;;;###autoload -(put 'calendar-daylight-savings-starts 'risky-local-variable t) -(defvar calendar-daylight-savings-starts - (or (car (nthcdr 4 calendar-current-time-zone-cache)) - (and (not (zerop calendar-daylight-time-offset)) - '(calendar-nth-named-day 1 0 4 year))) - "*Sexp giving the date on which daylight savings time starts. -This is an expression in the variable `year' whose value gives the Gregorian -date in the form (month day year) on which daylight savings time starts. It is -used to determine the starting date of daylight savings time for the holiday -list and for correcting times of day in the solar and lunar calculations. - -For example, if daylight savings time is mandated to start on October 1, -you would set `calendar-daylight-savings-starts' to - - '(10 1 year) - -If it starts on the first Sunday in April, you would set it to - - '(calendar-nth-named-day 1 0 4 year) - -If the locale never uses daylight savings time, set this to nil.") - -;;;###autoload -(put 'calendar-daylight-savings-ends 'risky-local-variable t) -(defvar calendar-daylight-savings-ends - (or (car (nthcdr 5 calendar-current-time-zone-cache)) - (and (not (zerop calendar-daylight-time-offset)) - '(calendar-nth-named-day -1 0 10 year))) - "*Sexp giving the date on which daylight savings time ends. -This is an expression in the variable `year' whose value gives the Gregorian -date in the form (month day year) on which daylight savings time ends. It is -used to determine the starting date of daylight savings time for the holiday -list and for correcting times of day in the solar and lunar calculations. - -For example, if daylight savings time ends on the last Sunday in October: - - '(calendar-nth-named-day -1 0 10 year) - -If the locale never uses daylight savings time, set this to nil.") - -(defvar calendar-daylight-savings-starts-time - (or (car (nthcdr 6 calendar-current-time-zone-cache)) 120) - "*Number of minutes after midnight that daylight savings time starts.") - -(defvar calendar-daylight-savings-ends-time - (or (car (nthcdr 7 calendar-current-time-zone-cache)) - calendar-daylight-savings-starts-time) - "*Number of minutes after midnight that daylight savings time ends.") - -(provide 'cal-dst) - -;;; cal-dst.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/cal-french.el --- a/lisp/calendar/cal-french.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,220 +0,0 @@ -;;; cal-french.el --- calendar functions for the French Revolutionary calendar. - -;; Copyright (C) 1988, 1989, 1992, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; Keywords: calendar -;; Human-Keywords: French Revolutionary calendar, calendar, diary - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the French Revolutionary calendar. - -;; Technical details of the French Revolutionary calendar can be found in -;; ``Calendrical Calculations, Part II: Three Historical Calendars'' -;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -(defconst french-calendar-month-name-array - ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" - "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]) - -(defconst french-calendar-day-name-array - ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" - "Octidi" "Nonidi" "Decadi"]) - -(defconst french-calendar-special-days-array - ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Recompense" - "de la Revolution"]) - -(defun french-calendar-leap-year-p (year) - "True if YEAR is a leap year on the French Revolutionary calendar. -For Gregorian years 1793 to 1805, the years of actual operation of the -calendar, uses historical practice based on equinoxes is followed (years 3, 7, -and 11 were leap years; 15 and 20 would have been leap years). For later -years uses the proposed rule of Romme (never adopted)--leap years fall every -four years except century years not divisible 400 and century years that are -multiples of 4000." - (or (memq year '(3 7 11));; Actual practice--based on equinoxes - (memq year '(15 20)) ;; Anticipated practice--based on equinoxes - (and (> year 20) ;; Romme's proposal--never adopted - (zerop (% year 4)) - (not (memq (% year 400) '(100 200 300))) - (not (zerop (% year 4000)))))) - -(defun french-calendar-last-day-of-month (month year) - "Return last day of MONTH, YEAR on the French Revolutionary calendar. -The 13th month is not really a month, but the 5 (6 in leap years) day period of -`sansculottides' at the end of the year." - (if (< month 13) - 30 - (if (french-calendar-leap-year-p year) - 6 - 5))) - -(defun calendar-absolute-from-french (date) - "Compute absolute date from French Revolutionary date DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ (* 365 (1- year));; Days in prior years - ;; Leap days in prior years - (if (< year 20) - (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15) - ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion) - (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20 - (- (/ (1- year) 100)) - (/ (1- year) 400) - (- (/ (1- year) 4000)))) - (* 30 (1- month));; Days in prior months this year - day;; Days so far this month - 654414)));; Days before start of calendar (September 22, 1792). - -(defun calendar-french-from-absolute (date) - "Compute the French Revolutionary equivalent for absolute date DATE. -The result is a list of the form (MONTH DAY YEAR). -The absolute date is the number of days elapsed since the -\(imaginary) Gregorian date Sunday, December 31, 1 BC." - (if (< date 654415) - (list 0 0 0);; pre-French Revolutionary date - (let* ((approx (/ (- date 654414) 366));; Approximation from below. - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-french (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from Vendemiaire. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-french - (list m - (french-calendar-last-day-of-month m year) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date - (1- (calendar-absolute-from-french (list month 1 year)))))) - (list month day year)))) - -(defun calendar-french-date-string (&optional date) - "String of French Revolutionary date of Gregorian DATE. -Returns the empty string if DATE is pre-French Revolutionary. -Defaults to today's date if DATE is not given." - (let* ((french-date (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))) - (y (extract-calendar-year french-date)) - (m (extract-calendar-month french-date)) - (d (extract-calendar-day french-date))) - (cond - ((< y 1) "") - ((= m 13) (format "Jour %s de l'Année %d de la Revolution" - (aref french-calendar-special-days-array (1- d)) - y)) - (t (format "Decade %s, %s de %s de l'Année %d de la Revolution" - (make-string (1+ (/ (1- d) 10)) ?I) - (aref french-calendar-day-name-array (% (1- d) 10)) - (aref french-calendar-month-name-array (1- m)) - y))))) - -(defun calendar-print-french-date () - "Show the French Revolutionary calendar equivalent of the selected date." - (interactive) - (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - (message "Date is pre-French Revolution") - (message f)))) - -(defun calendar-goto-french-date (date &optional noecho) - "Move cursor to French Revolutionary date DATE. -Echo French Revolutionary date unless NOECHO is t." - (interactive - (let* ((year (calendar-read - "Année de la Revolution (>0): " - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))))) - (month-list - (mapcar 'list - (append french-calendar-month-name-array - (if (french-calendar-leap-year-p year) - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array) - (nreverse - (cdr;; we don't want rev. day in a non-leap yr. - (nreverse - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array)))))))) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Mois ou Sansculottide: " - month-list - nil t)) - (calendar-make-alist - month-list - 1 - '(lambda (x) (capitalize (car x))))))) - (decade (if (> month 12) - 1 - (calendar-read - "Décade (1-3): " - '(lambda (x) (memq x '(1 2 3)))))) - (day (if (> month 12) - (- month 12) - (calendar-read - "Jour (1-10): " - '(lambda (x) (and (<= 1 x) (<= x 10)))))) - (month (if (> month 12) 13 month)) - (day (+ day (* 10 (1- decade))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-french date))) - (or noecho (calendar-print-french-date))) - -(defun diary-french-date () - "French calendar equivalent of date diary entry." - (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - "Date is pre-French Revolution" - f))) - -(provide 'cal-french) - -;;; cal-french.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/cal-mayan.el --- a/lisp/calendar/cal-mayan.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,385 +0,0 @@ -;;; cal-mayan.el --- calendar functions for the Mayan calendars. - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Stewart M. Clamen -;; Edward M. Reingold -;; Keywords: calendar -;; Human-Keywords: Mayan calendar, Maya, calendar, diary - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Mayan calendar. It was written jointly by - -;; Stewart M. Clamen School of Computer Science -;; clamen@cs.cmu.edu Carnegie Mellon University -;; 5000 Forbes Avenue -;; Pittsburgh, PA 15213 - -;; and - -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; Comments, improvements, and bug reports should be sent to Reingold. - -;; Technical details of the Mayan calendrical calculations can be found in -;; ``Calendrical Calculations, Part II: Three Historical Calendars'' -;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;;; Code: - -(require 'calendar) - -(defun mayan-adjusted-mod (m n) - "Non-negative remainder of M/N with N instead of 0." - (1+ (mod (1- m) n))) - -(defconst calendar-mayan-days-before-absolute-zero 1137140 - "Number of days of the Mayan calendar epoch before absolute day 0. -According to the Goodman-Martinez-Thompson correlation. This correlation is -not universally accepted, as it still a subject of astro-archeological -research. Using 1232041 will give you Spinden's correlation; using -1142840 will give you Hochleitner's correlation.") - -(defconst calendar-mayan-haab-at-epoch '(8 . 18) - "Mayan haab date at the epoch.") - -(defconst calendar-mayan-haab-month-name-array - ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax" - "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"]) - -(defconst calendar-mayan-tzolkin-at-epoch '(4 . 20) - "Mayan tzolkin date at the epoch.") - -(defconst calendar-mayan-tzolkin-names-array - ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc" - "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"]) - -(defun calendar-mayan-long-count-from-absolute (date) - "Compute the Mayan long count corresponding to the absolute DATE." - (let ((long-count (+ date calendar-mayan-days-before-absolute-zero))) - (let* ((baktun (/ long-count 144000)) - (remainder (% long-count 144000)) - (katun (/ remainder 7200)) - (remainder (% remainder 7200)) - (tun (/ remainder 360)) - (remainder (% remainder 360)) - (uinal (/ remainder 20)) - (kin (% remainder 20))) - (list baktun katun tun uinal kin)))) - -(defun calendar-mayan-long-count-to-string (mayan-long-count) - "Convert MAYAN-LONG-COUNT into traditional written form." - (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count))) - -(defun calendar-string-to-mayan-long-count (str) - "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums." - (let ((rlc nil) - (c (length str)) - (cc 0)) - (condition-case condition - (progn - (while (< cc c) - (let* ((start (string-match "[0-9]+" str cc)) - (end (match-end 0)) - datum) - (setq datum (read (substring str start end))) - (setq rlc (cons datum rlc)) - (setq cc end))) - (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil))) - (invalid-read-syntax nil)) - (reverse rlc))) - -(defun calendar-mayan-haab-from-absolute (date) - "Convert absolute DATE into a Mayan haab date (a pair)." - (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero)) - (day-of-haab - (% (+ long-count - (car calendar-mayan-haab-at-epoch) - (* 20 (1- (cdr calendar-mayan-haab-at-epoch)))) - 365)) - (day (% day-of-haab 20)) - (month (1+ (/ day-of-haab 20)))) - (cons day month))) - -(defun calendar-mayan-haab-difference (date1 date2) - "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2." - (mod (+ (* 20 (- (cdr date2) (cdr date1))) - (- (car date2) (car date1))) - 365)) - -(defun calendar-mayan-haab-on-or-before (haab-date date) - "Absolute date of latest HAAB-DATE on or before absolute DATE." - (- date - (% (- date - (calendar-mayan-haab-difference - (calendar-mayan-haab-from-absolute 0) haab-date)) - 365))) - -(defun calendar-next-haab-date (haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-haab-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-haab-on-or-before - haab-date - (+ 365 - (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-previous-haab-date (haab-date &optional noecho) - "Move cursor to previous instance of Mayan HAAB-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-haab-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-haab-on-or-before - haab-date - (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-haab-to-string (haab) - "Convert Mayan haab date (a pair) into its traditional written form." - (let ((month (cdr haab)) - (day (car haab))) - ;; 19th month consists of 5 special days - (if (= month 19) - (format "%d Uayeb" day) - (format "%d %s" - day - (aref calendar-mayan-haab-month-name-array (1- month)))))) - -(defun calendar-mayan-tzolkin-from-absolute (date) - "Convert absolute DATE into a Mayan tzolkin date (a pair)." - (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero)) - (day (mayan-adjusted-mod - (+ long-count (car calendar-mayan-tzolkin-at-epoch)) - 13)) - (name (mayan-adjusted-mod - (+ long-count (cdr calendar-mayan-tzolkin-at-epoch)) - 20))) - (cons day name))) - -(defun calendar-mayan-tzolkin-difference (date1 date2) - "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2." - (let ((number-difference (- (car date2) (car date1))) - (name-difference (- (cdr date2) (cdr date1)))) - (mod (+ number-difference - (* 13 (mod (* 3 (- number-difference name-difference)) - 20))) - 260))) - -(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date) - "Absolute date of latest TZOLKIN-DATE on or before absolute DATE." - (- date - (% (- date (calendar-mayan-tzolkin-difference - (calendar-mayan-tzolkin-from-absolute 0) - tzolkin-date)) - 260))) - -(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to next instance of Mayan TZOLKIN-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-tzolkin-on-or-before - tzolkin-date - (+ 260 - (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to previous instance of Mayan TZOLKIN-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-tzolkin-on-or-before - tzolkin-date - (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-tzolkin-to-string (tzolkin) - "Convert Mayan tzolkin date (a pair) into its traditional written form." - (format "%d %s" - (car tzolkin) - (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin))))) - -(defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date) - "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE. -Latest such date on or before DATE. -Returns nil if such a tzolkin-haab combination is impossible." - (let* ((haab-difference - (calendar-mayan-haab-difference - (calendar-mayan-haab-from-absolute 0) - haab-date)) - (tzolkin-difference - (calendar-mayan-tzolkin-difference - (calendar-mayan-tzolkin-from-absolute 0) - tzolkin-date)) - (difference (- tzolkin-difference haab-difference))) - (if (= (% difference 5) 0) - (- date - (mod (- date - (+ haab-difference (* 365 difference))) - 18980)) - nil))) - -(defun calendar-read-mayan-haab-date () - "Prompt for a Mayan haab date" - (let* ((completion-ignore-case t) - (haab-day (calendar-read - "Haab kin (0-19): " - '(lambda (x) (and (>= x 0) (< x 20))))) - (haab-month-list (append calendar-mayan-haab-month-name-array - (and (< haab-day 5) '("Uayeb")))) - (haab-month (cdr - (assoc - (capitalize - (completing-read "Haab uinal: " - (mapcar 'list haab-month-list) - nil t)) - (calendar-make-alist - haab-month-list 1 'capitalize))))) - (cons haab-day haab-month))) - -(defun calendar-read-mayan-tzolkin-date () - "Prompt for a Mayan tzolkin date" - (let* ((completion-ignore-case t) - (tzolkin-count (calendar-read - "Tzolkin kin (1-13): " - '(lambda (x) (and (> x 0) (< x 14))))) - (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) - (tzolkin-name (cdr - (assoc - (capitalize - (completing-read "Tzolkin uinal: " - (mapcar 'list tzolkin-name-list) - nil t)) - (calendar-make-alist - tzolkin-name-list 1 'capitalize))))) - (cons tzolkin-count tzolkin-name))) - -(defun calendar-next-calendar-round-date - (tzolkin-date haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date) - (calendar-read-mayan-haab-date))) - (let ((date (calendar-mayan-tzolkin-haab-on-or-before - tzolkin-date haab-date - (+ 18980 (calendar-absolute-from-gregorian - (calendar-cursor-to-date)))))) - (if (not date) - (error "%s, %s does not exist in the Mayan calendar round" - (calendar-mayan-tzolkin-to-string tzolkin-date) - (calendar-mayan-haab-to-string haab-date)) - (calendar-goto-date (calendar-gregorian-from-absolute date)) - (or noecho (calendar-print-mayan-date))))) - -(defun calendar-previous-calendar-round-date - (tzolkin-date haab-date &optional noecho) - "Move to previous instance of Mayan TZOKLIN-DATE HAAB-DATE combination. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date) - (calendar-read-mayan-haab-date))) - (let ((date (calendar-mayan-tzolkin-haab-on-or-before - tzolkin-date haab-date - (1- (calendar-absolute-from-gregorian - (calendar-cursor-to-date)))))) - (if (not date) - (error "%s, %s does not exist in the Mayan calendar round" - (calendar-mayan-tzolkin-to-string tzolkin-date) - (calendar-mayan-haab-to-string haab-date)) - (calendar-goto-date (calendar-gregorian-from-absolute date)) - (or noecho (calendar-print-mayan-date))))) - -(defun calendar-absolute-from-mayan-long-count (c) - "Compute the absolute date corresponding to the Mayan Long Count C. -Long count is a list (baktun katun tun uinal kin)" - (+ (* (nth 0 c) 144000) ; baktun - (* (nth 1 c) 7200) ; katun - (* (nth 2 c) 360) ; tun - (* (nth 3 c) 20) ; uinal - (nth 4 c) ; kin (days) - (- ; days before absolute date 0 - calendar-mayan-days-before-absolute-zero))) - -(defun calendar-mayan-date-string (&optional date) - "String of Mayan date of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((d (calendar-absolute-from-gregorian - (or date (calendar-current-date)))) - (tzolkin (calendar-mayan-tzolkin-from-absolute d)) - (haab (calendar-mayan-haab-from-absolute d)) - (long-count (calendar-mayan-long-count-from-absolute d))) - (format "Long count = %s; tzolkin = %s; haab = %s" - (calendar-mayan-long-count-to-string long-count) - (calendar-mayan-tzolkin-to-string tzolkin) - (calendar-mayan-haab-to-string haab)))) - -(defun calendar-print-mayan-date () - "Show the Mayan long count, tzolkin, and haab equivalents of date." - (interactive) - (message "Mayan date: %s" - (calendar-mayan-date-string (calendar-cursor-to-date t)))) - -(defun calendar-goto-mayan-long-count-date (date &optional noecho) - "Move cursor to Mayan long count DATE. Echo Mayan date unless NOECHO is t." - (interactive - (let (lc) - (while (not lc) - (let ((datum - (calendar-string-to-mayan-long-count - (read-string "Mayan long count (baktun.katun.tun.uinal.kin): " - (calendar-mayan-long-count-to-string - (calendar-mayan-long-count-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date)))))))) - (if (calendar-mayan-long-count-common-era datum) - (setq lc datum)))) - (list lc))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-absolute-from-mayan-long-count date))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-long-count-common-era (lc) - "T if long count represents date in the Common Era." - (let ((base (calendar-mayan-long-count-from-absolute 1))) - (while (and (not (null base)) (= (car lc) (car base))) - (setq lc (cdr lc) - base (cdr base))) - (or (null lc) (> (car lc) (car base))))) - -(defun diary-mayan-date () - "Show the Mayan long count, haab, and tzolkin dates as a diary entry." - (format "Mayan date: %s" (calendar-mayan-date-string date))) - -(provide 'cal-mayan) - -;;; cal-mayan.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/cal-x.el --- a/lisp/calendar/cal-x.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,180 +0,0 @@ -;;; cal-x.el --- calendar windows in dedicated frames in x-windows - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Author: Michael Kifer -;; Edward M. Reingold -;; Modified for XEmacs by: Chuck Thompson -;; Keywords: calendar -;; Human-Keywords: calendar, dedicated frames, x-windows - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements dedicated frames in x-windows for -;; calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) -(if (not (fboundp 'calendar-basic-setup)) - (fset 'calendar-basic-setup (symbol-function 'calendar))) - -;;;###autoload -(defvar calendar-setup 'one-frame - "The frame set up of the calendar. -The choices are `one-frame' (calendar and diary together in one separate, -dediciated frame) or `two-frames' (calendar and diary in separate, dedicated -frames); with any other value the current frame is used.") - -(defun calendar (&optional arg) - "Choose between the one frame, two frame, or basic calendar displays. -The original function `calendar' has been renamed `calendar-basic-setup'." - (interactive "P") - (cond ((equal calendar-setup 'one-frame) (calendar-one-frame-setup arg)) - ((equal calendar-setup 'two-frames) (calendar-two-frame-setup arg)) - (t (calendar-basic-setup arg)))) - -(defvar calendar-frame nil "Frame in which to display the calendar.") - -(defvar diary-frame nil "Frame in which to display the diary.") - -(defvar diary-frame-parameters - '((name . "Diary") (height . 10) (width . 80) (unsplittable . t) - (font . "6x13") (auto-lower . t) (auto-raise . t) (minibuffer . nil)) - "Parameters of the diary frame, if the diary is in its own frame. -Location and color should be set in .Xdefaults.") - -(defvar calendar-frame-parameters - '((name . "Calendar") (minibuffer . nil) (height . 10) (width . 80) - (auto-raise . t) (auto-lower . t) (font . "6x13") (unsplittable . t) - (vertical-scroll-bars . nil)) - "Parameters of the calendar frame, if the calendar is in a separate frame. -Location and color should be set in .Xdefaults.") - -(defvar calendar-and-diary-frame-parameters - '((name . "Calendar") (height . 28) (width . 80) (minibuffer . nil) - (font . "6x13") (auto-raise . t) (auto-lower . t)) - "Parameters of the frame that displays both the calendar and the diary. -Location and color should be set in .Xdefaults.") - -(defvar calendar-after-frame-setup-hooks nil - "Hooks to be run just after setting up a calendar frame. -Can be used to change frame parameters, such as font, color, location, etc.") - -(defun calendar-not-using-window-system-p () - "Return t if not running under a window system." - (if (fboundp 'device-type) - (not (eq (device-type (selected-device)) 'x)) - (not window-system))) - -(defun calendar-deiconify-frame (frame) - "Deiconify the given frame if it is currently iconified." - (if (string-match "XEmacs" emacs-version) - (if (frame-iconified-p frame) - (deiconify-frame frame)) - (if (eq 'icon (cdr (assoc 'visibility (frame-parameters frame)))) - ;; This isn't necessary going to do what is intended since it - ;; only works with the selected frame. - (iconify-or-deiconify-frame)))) - -(defun calendar-one-frame-setup (&optional arg) - "Start calendar and display it in a dedicated frame together with the diary." - (if (calendar-not-using-window-system-p) - (calendar-basic-setup arg) - (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) - (if (frame-live-p diary-frame) (delete-frame diary-frame)) - (let ((special-display-buffer-names nil) - (view-diary-entries-initially t)) - (save-window-excursion - (save-excursion - (setq calendar-frame - (make-frame calendar-and-diary-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame calendar-frame) - (calendar-deiconify-frame calendar-frame) - (calendar-basic-setup arg) - (set-window-dedicated-p (selected-window) 'calendar) - (set-window-dedicated-p - (display-buffer - (if (not (memq 'fancy-diary-display diary-display-hook)) - (get-file-buffer diary-file) - (if (not (bufferp (get-buffer fancy-diary-buffer))) - (make-fancy-diary-buffer)) - fancy-diary-buffer)) - 'diary)))))) - -(defun calendar-two-frame-setup (&optional arg) - "Start calendar and diary in separate, dedicated frames." - (if (calendar-not-using-window-system-p) - (calendar-basic-setup arg) - (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) - (if (frame-live-p diary-frame) (delete-frame diary-frame)) - (let ((pop-up-windows nil) - (view-diary-entries-initially nil) - (special-display-buffer-names nil)) - (save-window-excursion - (save-excursion (calendar-basic-setup arg)) - (setq calendar-frame (make-frame calendar-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame calendar-frame) - (calendar-deiconify-frame calendar-frame) - (display-buffer calendar-buffer) - (set-window-dedicated-p (selected-window) 'calendar) - (setq diary-frame (make-frame diary-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame diary-frame) - (calendar-deiconify-frame diary-frame) - (save-excursion (diary)) - (set-window-dedicated-p - (display-buffer - (if (not (memq 'fancy-diary-display diary-display-hook)) - (get-file-buffer diary-file) - (if (not (bufferp (get-buffer fancy-diary-buffer))) - (make-fancy-diary-buffer)) - fancy-diary-buffer)) - 'diary))))) - -(defun make-fancy-diary-buffer () - (save-excursion - (set-buffer (get-buffer-create fancy-diary-buffer)) - (setq buffer-read-only nil) - (make-local-variable 'mode-line-format) - (calendar-set-mode-line "Diary Entries") - (erase-buffer) - (set-buffer-modified-p nil) - (setq buffer-read-only t))) - -(if (not (string-match "XEmacs" emacs-version)) - (setq special-display-buffer-names - (append special-display-buffer-names - (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer - fancy-diary-buffer (get-file-buffer diary-file) - calendar-buffer)))) - -(run-hooks 'cal-x-load-hook) - -(provide 'cal-x) - -;;; cal-x.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/cal-xemacs.el --- a/lisp/calendar/cal-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,260 +0,0 @@ -;;; cal-xemacs.el --- calendar functions for menu bar and popup menu support -;;; Original file is cal-menu.el. - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; Lara Rios -;; Ported to XEmacs by Chuck Thompson -;; Keywords: calendar -;; Human-Keywords: calendar, popup menus, menu bar - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements menu bar and popup menu support for -;; calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -;;(define-key calendar-mode-map 'button2 'calendar-mouse-2-date-menu) -;;(define-key calendar-mode-map 'button2up 'ignore) - -(defconst calendar-popup-menu-3 - '("Calendar" - ["Scroll forward" scroll-calendar-left-three-months t] - ["Scroll backward" scroll-calendar-right-three-months t] - ["Mark diary entries" mark-diary-entries t] - ["List holidays" list-calendar-holidays t] - ["Mark holidays" mark-calendar-holidays t] - ["Unmark" calendar-unmark t] - ["Lunar phases" calendar-phases-of-moon t] - ["Show diary" show-all-diary-entries t] - ["Exit calendar" exit-calendar t] - )) - -(defun calendar-popup-menu-3 (e) - (interactive "@e") - (popup-menu calendar-popup-menu-3)) -(define-key calendar-mode-map 'button3 'calendar-popup-menu-3) - -(defvar calendar-foobar nil) - -(defun calendar-popup-menu-2 (e) - (interactive "@e") - (setq calendar-foobar (calendar-event-to-date e t)) - (let ((menu (list (format "Menu - %s" (calendar-date-string calendar-foobar) t t) - "-----" - ["Holidays" calendar-mouse-holidays t] - ["Mark date" calendar-mouse-set-mark t] - ["Sunrise/sunset" calendar-mouse-sunrise/sunset t] - ["Other calendars" calendar-mouse-print-dates (calendar-event-to-date e)] - ["Diary entries" calendar-mouse-view-diary-entries t] - ["Insert diary entry" calendar-mouse-insert-diary-entry t] - ["Other Diary file entries" - calendar-mouse-view-other-diary-entries - (calendar-cursor-to-date)] - ))) - (popup-menu menu))) -(define-key calendar-mode-map 'button2 'calendar-popup-menu-2) - -(defconst calendar-scroll-menu - '("Scroll" - ["Forward 1 Month" scroll-calendar-left t] - ["Forward 3 Months" scroll-calendar-left-three-months t] - ["Forward 1 Year" (scroll-calendar-left-three-months 4) t] - ["Backward 1 Month" scroll-calendar-right t] - ["Backward 3 Months" scroll-calendar-right-three-months t] - ["Backward 1 Year" (scroll-calendar-right-three-months 4) t])) - -(defconst calendar-goto-menu - '("Goto" - ["Today" calendar-current-month t] - ["Beginning of week" calendar-beginning-of-week (calendar-cursor-to-date)] - ["End of week" calendar-end-of-week (calendar-cursor-to-date)] - ["Beginning of month" calendar-beginning-of-month (calendar-cursor-to-date)] - ["End of month" calendar-end-of-month (calendar-cursor-to-date)] - ["Beginning of year" calendar-beginning-of-year (calendar-cursor-to-date)] - ["End of year" calendar-end-of-year (calendar-cursor-to-date)] - ["Other date" calendar-goto-date t] - ["ISO date" calendar-goto-iso-date t] - ["Astronomical date" calendar-goto-astro-day-number t] - ["Hebrew date" calendar-goto-hebrew-date t] - ["Islamic date" calendar-goto-islamic-date t] - ["Julian date" calendar-goto-julian-date t] - ("Mayan date" - ["Next Tzolkin" calendar-next-tzolkin-date t] - ["Previous Tzolkin" calendar-previous-tzolkin-date t] - ["Next Haab" calendar-next-haab-date t] - ["Previous Haab" calendar-previous-haab-date t] - ["Next Round" calendar-next-calendar-round-date t] - ["Previous Round" calendar-previous-calendar-round-date t]) - ["French date" calendar-goto-french-date t])) - -(defconst calendar-holidays-menu - '("Holidays" - ["One day" calendar-cursor-holidays (calendar-cursor-to-date)] - ["3 months" list-calendar-holidays t] - ["Mark" mark-calendar-holidays t] - ["Unmark" calendar-unmark t])) - -(defconst calendar-diary-menu - '("Diary" - ["Other file" view-other-diary-entries (calendar-cursor-to-date)] - ["Cursor date" view-diary-entries (calendar-cursor-to-date)] - ["Mark all" mark-diary-entries t] - ["Show all" show-all-diary-entries t] - ["Insert daily"insert-diary-entry t] - ["Insert weekly" insert-weekly-diary-entry (calendar-cursor-to-date)] - ["Insert monthly" insert-monthly-diary-entry (calendar-cursor-to-date)] - ["Insert yearly" insert-yearly-diary-entry (calendar-cursor-to-date)] - ["Insert anniversary" insert-anniversary-diary-entry (calendar-cursor-to-date)] - ["Insert block" insert-block-diary-entry (calendar-cursor-to-date)] - ["Insert cyclic" insert-cyclic-diary-entry (calendar-cursor-to-date)] - ["Insert Islamic" calendar-mouse-insert-islamic-diary-entry (calendar-cursor-to-date)] - ["Insert Hebrew" calendar-mouse-insert-hebrew-diary-entry (calendar-cursor-to-date)])) - -(defun calendar-add-menus () - (set-buffer-menubar (copy-sequence current-menubar)) - (if (assoc "Calendar" current-menubar) - nil - (add-submenu nil '("Calendar")) - (if (not (assoc "Scroll" current-menubar)) - (add-submenu '("Calendar") calendar-scroll-menu)) - (if (not (assoc "Goto" current-menubar)) - (add-submenu '("Calendar") calendar-goto-menu)) - (if (not (assoc "Holidays" current-menubar)) - (add-submenu '("Calendar") calendar-holidays-menu)) - (if (not (assoc "Diary" current-menubar)) - (add-submenu '("Calendar") calendar-diary-menu)) - (if (not (assoc "Moon" current-menubar)) - (add-menu-button '("Calendar") ["Moon" calendar-phases-of-moon t])))) - -(defun calendar-event-to-date (event &optional error) - "Date of last event. -If event is not on a specific date, signals an error if optional parameter -ERROR is t, otherwise just returns nil." - (save-excursion - (goto-char (event-point event)) - (calendar-cursor-to-date error))) - -(defun calendar-mouse-insert-hebrew-diary-entry (event) - "Pop up menu to insert a Hebrew-date diary entry." - (interactive "e") - (let ((menu (list (format "Hebrew insert menu - %s" - (calendar-hebrew-date-string - (calendar-cursor-to-date))) - "-----" - ["One time" insert-hebrew-diary-entry t] - ["Monthly" insert-monthly-hebrew-diary-entry t] - ["Yearly" insert-yearly-hebrew-diary-entry t]))) - (popup-menu menu))) - -(defun calendar-mouse-insert-islamic-diary-entry (event) - "Pop up menu to insert an Islamic-date diary entry." - (interactive "e") - (let ((menu (list (format "Islamic insert menu - %s" - (calendar-islamic-date-string - (calendar-cursor-to-date))) - "-----" - ["One time" insert-islamic-diary-entry t] - ["Monthly" insert-monthly-islamic-diary-entry t] - ["Yearly" insert-yearly-islamic-diary-entry t]))) - (popup-menu menu))) - -(defun calendar-mouse-sunrise/sunset () - "Show sunrise/sunset times for mouse-selected date." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (calendar-sunrise-sunset))) - -(defun calendar-mouse-holidays () - "Show holidays for mouse-selected date." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (calendar-cursor-holidays))) - -(defun calendar-mouse-view-diary-entries () - "View diary entries on mouse-selected date." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (view-diary-entries 1))) - -(defun calendar-mouse-view-other-diary-entries (event) - "View diary entries from alternative file on mouse-selected date." - (interactive "e") - (save-excursion - (calendar-goto-date calendar-foobar) - (call-interactively 'view-other-diary-entries))) - -(defun calendar-mouse-insert-diary-entry (event) - "Insert diary entry for mouse-selected date." - (interactive "e") - (save-excursion - (calendar-goto-date calendar-foobar) - (insert-diary-entry nil))) - -(defun calendar-mouse-set-mark () - "Mark the date under the cursor." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (calendar-set-mark nil))) - -(defun calendar-mouse-print-dates () - "Pop up menu of equivalent dates to mouse selected date." - (interactive) - (let* ((menu (list (format "Date Menu - %s (Gregorian)" - (calendar-date-string calendar-foobar)) - "-----" - (calendar-day-of-year-string calendar-foobar) - (format "ISO date: %s" (calendar-iso-date-string calendar-foobar)) - (format "Julian date: %s" - (calendar-julian-date-string calendar-foobar)) - (format "Astronomical (Julian) date (before noon): %s" - (calendar-astro-date-string calendar-foobar)) - (format "Hebrew date (before sunset): %s" - (calendar-hebrew-date-string calendar-foobar)) - (let ((i (calendar-islamic-date-string calendar-foobar))) - (if (not (string-equal i "")) - (format "Islamic date (before sunset): %s" i))) - (let ((f (calendar-french-date-string calendar-foobar))) - (if (not (string-equal f "")) - (format "French Revolutionary date: %s" f))) - (format "Mayan date: %s" (calendar-mayan-date-string calendar-foobar))))) - (popup-menu menu)) - (setq calendar-foobar nil)) - -(run-hooks 'cal-xemacs-load-hook) - -(provide 'cal-xemacs) - -;;; cal-menu.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/calendar.el --- a/lisp/calendar/calendar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3063 +0,0 @@ -;;; calendar.el --- Calendar functions. -*-byte-compile-dynamic: t;-*- - -;;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994 Free Software -;;; Foundation, Inc. - -;; Author: Edward M. Reingold -;; Keywords: calendar -;; Human-Keywords: calendar, Gregorian calendar, Julian calendar, -;; Hebrew calendar, Islamic calendar, ISO calendar, Julian day number, -;; diary, holidays - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements a calendar window. It -;; generates a calendar for the current month, together with the previous -;; and coming months, or for any other three-month period. The calendar -;; can be scrolled forward and backward in the window to show months in -;; the past or future; the cursor can move forward and backward by days, -;; weeks, or months, making it possible, for instance, to jump to the -;; date a specified number of days, weeks, or months from the date under -;; the cursor. The user can display a list of holidays and other notable -;; days for the period shown; the notable days can be marked on the -;; calendar, if desired. The user can also specify that dates having -;; corresponding diary entries (in a file that the user specifies) be -;; marked; the diary entries for any date can be viewed in a separate -;; window. The diary and the notable days can be viewed independently of -;; the calendar. Dates can be translated from the (usual) Gregorian -;; calendar to the day of the year/days remaining in year, to the ISO -;; commercial calendar, to the Julian (old style) calendar, to the Hebrew -;; calendar, to the Islamic calendar, to the French Revolutionary calendar, -;; to the Mayan calendar, and to the astronomical (Julian) day number. -;; When floating point is available, times of sunrise/sunset can be displayed, -;; as can the phases of the moon. Appointment notification for diary entries -;; is available. - -;; The following files are part of the calendar/diary code: - -;; cal-menu.el Menu support -;; cal-x.el X-windows dedicated frame functions -;; diary-lib.el, diary-ins.el Diary functions -;; holidays.el Holiday functions -;; cal-french.el French Revolutionary calendar -;; cal-mayan.el Mayan calendars -;; cal-dst.el Daylight savings time rules -;; solar.el Sunrise/sunset, equinoxes/solstices -;; lunar.el Phases of the moon -;; appt.el Appointment notification - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; GNU Emacs users too numerous to list pointed out a variety of problems -;; with earlier forms of the `infinite' sliding calendar and suggested some -;; of the features included in this package. Especially significant in this -;; regard was the suggestion of mark-diary-entries and view-diary-entries, -;; together ideas for their implementation, by -;; Michael S. Littman Cognitive Science Research Group -;; (201) 829-5155 Bell Communications Research -;; mlittman@wind.bellcore.com 445 South St. Box 1961 (2L-331) -;; Morristown, NJ 07960 - -;; The algorithms for the Hebrew calendar are those of the Rambam (Rabbi Moses -;; Maimonides), from his Mishneh Torah, as implemented by -;; Nachum Dershowitz Department of Computer Science -;; (217) 333-4219 University of Illinois at Urbana-Champaign -;; nachum@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; Technical details of all the calendrical calculations can be found in - -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990), -;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical -;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;; Hard copies of these two papers can be obtained by sending email to -;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and -;; the message BODY containing your mailing address (snail). - -;;; Code: - -(defgroup diary nil - "Diary customization" - :group 'calendar) - -(defgroup holidays nil - "Holidays in calendar" - :group 'calendar) - -(defun calendar-version () - (interactive) - (message "Version 5.3, January 25, 1994")) - -(defgroup appt nil - "Appointment notification" - :tag "Appointments" - :group 'calendar) - - -;;;###autoload -(defcustom calendar-week-start-day 0 - "*The day of the week on which a week in the calendar begins. -0 means Sunday (default), 1 means Monday, and so on." - :type 'integer - :group 'calendar) - -;;;###autoload -(defcustom calendar-offset 0 - "*The offset of the principal month from the center of the calendar window. -0 means the principal month is in the center (default), -1 means on the left, -+1 means on the right. Larger (or smaller) values push the principal month off -the screen." - :type 'integer - :group 'calendar) - -;;;###autoload -(defcustom view-diary-entries-initially nil - "*Non-nil means display current date's diary entries on entry. -The diary is displayed in another window when the calendar is first displayed, -if the current date is visible. The number of days of diary entries displayed -is governed by the variable `number-of-diary-entries'." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom number-of-diary-entries 1 - "*Specifies how many days of diary entries are to be displayed initially. -This variable affects the diary display when the command M-x diary is used, -or if the value of the variable `view-diary-entries-initially' is t. For -example, if the default value 1 is used, then only the current day's diary -entries will be displayed. If the value 2 is used, then both the current -day's and the next day's entries will be displayed. - -The value can also be a vector such as [0 2 2 2 2 4 1]; this value -says to display no diary entries on Sunday, the display the entries -for the current date and the day after on Monday through Thursday, -display Friday through Monday's entries on Friday, and display only -Saturday's entries on Saturday. - -This variable does not affect the diary display with the `d' command -from the calendar; in that case, the prefix argument controls the -number of days of diary entries displayed." - :type 'integer - :group 'diary) - -;;;###autoload -(defcustom mark-diary-entries-in-calendar nil - "*Non-nil means mark dates with diary entries, in the calendar window. -The marking symbol is specified by the variable `diary-entry-marker'." - :type 'boolean - :group 'diary) - -(defcustom diary-entry-marker - (progn - (make-face 'diary-face) - (cond ((face-differs-from-default-p 'diary-face) nil) - (t (set-face-foreground 'diary-face "red" 'global '(x color)) - (set-face-highlight-p 'diary-face t 'global 'tty) - ;; avoid a weird problem when byte-compiling appt.el - ;; in batch mode. - (if (and (not noninteractive) (fboundp 'x-make-font-bold)) - (let ((bfont (x-make-font-bold - (face-font-instance 'default))) - (mono-tag (list 'x 'mono)) - (gray-tag (list 'x 'grayscale))) - (if bfont - (progn - (set-face-font 'diary-face bfont 'global mono-tag) - (set-face-font 'diary-face bfont 'global - gray-tag))))))) - 'diary-face) - "*Used to mark dates that have diary entries. -Can be either a single-character string or a face." - :type '(choice string face) - :group 'diary) - -(defcustom calendar-today-marker - (progn - (make-face 'calendar-today-face) - (if (not (face-differs-from-default-p 'calendar-today-face)) - (set-face-underline-p 'calendar-today-face t)) - 'calendar-today-face) - "*Used to mark today's date. -Can be either a single-character string or a face." - :type '(choice string face) - :group 'calendar) - -(defcustom calendar-holiday-marker - (progn - (make-face 'holiday-face) - (cond ((face-differs-from-default-p 'holiday-face) nil) - (t (let ((color-tag (list 'x 'color)) - (mono-tag (list 'x 'mono)) - (gray-tag (list 'x 'grayscale))) - (set-face-background 'holiday-face [default foreground] 'global - mono-tag) - (set-face-foreground 'holiday-face [default background] 'global - mono-tag) - (set-face-background 'holiday-face [default foreground] 'global - gray-tag) - (set-face-foreground 'holiday-face [default background] 'global - gray-tag) - (set-face-background 'holiday-face "pink" 'global color-tag) - (set-face-reverse-p 'holiday-face t 'global 'tty)))) - 'holiday-face) - "*Used to mark notable dates in the calendar. -Can be either a single-character string or a face." - :type '(choice string face) - :group 'holidays) - -;;;###autoload -(defcustom view-calendar-holidays-initially nil - "*Non-nil means display holidays for current three month period on entry. -The holidays are displayed in another window when the calendar is first -displayed." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom mark-holidays-in-calendar nil - "*Non-nil means mark dates of holidays in the calendar window. -The marking symbol is specified by the variable `calendar-holiday-marker'." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom all-hebrew-calendar-holidays nil - "*If nil, show only major holidays from the Hebrew calendar. -This means only those Jewish holidays that appear on secular calendars. - -If t, show all the holidays that would appear in a complete Hebrew calendar." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom all-christian-calendar-holidays nil - "*If nil, show only major holidays from the Christian calendar. -This means only those Christian holidays that appear on secular calendars. - -If t, show all the holidays that would appear in a complete Christian -calendar." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom all-islamic-calendar-holidays nil - "*If nil, show only major holidays from the Islamic calendar. -This means only those Islamic holidays that appear on secular calendars. - -If t, show all the holidays that would appear in a complete Islamic -calendar." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom calendar-load-hook nil - "*List of functions to be called after the calendar is first loaded. -This is the place to add key bindings to `calendar-mode-map'." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom initial-calendar-window-hook nil - "*List of functions to be called when the calendar window is first opened. -The functions invoked are called after the calendar window is opened, but -once opened is never called again. Leaving the calendar with the `q' command -and reentering it will cause these functions to be called again." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom today-visible-calendar-hook nil - "*List of functions called whenever the current date is visible. -This can be used, for example, to replace today's date with asterisks; a -function `calendar-star-date' is included for this purpose: - (setq today-visible-calendar-hook 'calendar-star-date) -It can also be used to mark the current date with `calendar-today-marker'; -a function is also provided for this: - (setq today-visible-calendar-hook 'calendar-mark-today) - -The corresponding variable `today-invisible-calendar-hook' is the list of -functions called when the calendar function was called when the current -date is not visible in the window. - -Other than the use of the provided functions, the changing of any -characters in the calendar buffer by the hooks may cause the failure of the -functions that move by days and weeks." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom today-invisible-calendar-hook nil - "*List of functions called whenever the current date is not visible. - -The corresponding variable `today-visible-calendar-hook' is the list of -functions called when the calendar function was called when the current -date is visible in the window. - -Other than the use of the provided functions, the changing of any -characters in the calendar buffer by the hooks may cause the failure of the -functions that move by days and weeks." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom diary-file "~/diary" - "*Name of the file in which one's personal diary of dates is kept. - -The file's entries are lines in any of the forms - - MONTH/DAY - MONTH/DAY/YEAR - MONTHNAME DAY - MONTHNAME DAY, YEAR - DAYNAME - -at the beginning of the line; the remainder of the line is the diary entry -string for that date. MONTH and DAY are one or two digit numbers, YEAR is -a number and may be written in full or abbreviated to the final two digits. -If the date does not contain a year, it is generic and applies to any year. -DAYNAME entries apply to any date on which is on that day of the week. -MONTHNAME and DAYNAME can be spelled in full, abbreviated to three -characters (with or without a period), capitalized or not. Any of DAY, -MONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year, -respectively. - -The European style (in which the day precedes the month) can be used -instead, if you execute `european-calendar' when in the calendar, or set -`european-calendar-style' to t in your .emacs file. The European forms are - - DAY/MONTH - DAY/MONTH/YEAR - DAY MONTHNAME - DAY MONTHNAME YEAR - DAYNAME - -To revert to the default American style from the European style, execute -`american-calendar' in the calendar. - -A diary entry can be preceded by the character -`diary-nonmarking-symbol' (ordinarily `&') to make that entry -nonmarking--that is, it will not be marked on dates in the calendar -window but will appear in a diary window. - -Multiline diary entries are made by indenting lines after the first with -either a TAB or one or more spaces. - -Lines not in one the above formats are ignored. Here are some sample diary -entries (in the default American style): - - 12/22/1988 Twentieth wedding anniversary!! - &1/1. Happy New Year! - 10/22 Ruth's birthday. - 21: Payday - Tuesday--weekly meeting with grad students at 10am - Supowit, Shen, Bitner, and Kapoor to attend. - 1/13/89 Friday the thirteenth!! - &thu 4pm squash game with Lloyd. - mar 16 Dad's birthday - April 15, 1989 Income tax due. - &* 15 time cards due. - -If the first line of a diary entry consists only of the date or day name with -no trailing blanks or punctuation, then that line is not displayed in the -diary window; only the continuation lines is shown. For example, the -single diary entry - - 02/11/1989 - Bill Blattner visits Princeton today - 2pm Cognitive Studies Committee meeting - 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative' - 4:00pm Jamie Tappenden - 7:30pm Dinner at George and Ed's for Alan Ryan - 7:30-10:00pm dance at Stewart Country Day School - -will appear in the diary window without the date line at the beginning. This -facility allows the diary window to look neater, but can cause confusion if -used with more than one day's entries displayed. - -Diary entries can be based on Lisp sexps. For example, the diary entry - - %%(diary-block 11 1 1990 11 10 1990) Vacation - -causes the diary entry \"Vacation\" to appear from November 1 through November -10, 1990. Other functions available are `diary-float', `diary-anniversary', -`diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date', -`diary-hebrew-date', `diary-islamic-date', `diary-mayan-date', -`diary-yahrzeit', `diary-sunrise-sunset', `diary-phases-of-moon', -`diary-parasha', `diary-omer', `diary-rosh-hodesh', and -`diary-sabbath-candles'. See the documentation for the function -`list-sexp-diary-entries' for more details. - -Diary entries based on the Hebrew and/or the Islamic calendar are also -possible, but because these are somewhat slow, they are ignored -unless you set the `nongregorian-diary-listing-hook' and the -`nongregorian-diary-marking-hook' appropriately. See the documentation -for these functions for details. - -Diary files can contain directives to include the contents of other files; for -details, see the documentation for the variable `list-diary-entries-hook'." - :type 'file - :group 'diary) - -;;;###autoload -(defcustom diary-nonmarking-symbol "&" - "*Symbol indicating that a diary entry is not to be marked in the calendar." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom hebrew-diary-entry-symbol "H" - "*Symbol indicating a diary entry according to the Hebrew calendar." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom islamic-diary-entry-symbol "I" - "*Symbol indicating a diary entry according to the Islamic calendar." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom diary-include-string "#include" - "*The string indicating inclusion of another file of diary entries. -See the documentation for the function `include-other-diary-files'." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom sexp-diary-entry-symbol "%%" - "*The string used to indicate a sexp diary entry in diary-file. -See the documentation for the function `list-sexp-diary-entries'." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom abbreviated-calendar-year t - "*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD. -For the Gregorian calendar; similarly for the Hebrew and Islamic calendars. -If this variable is nil, years must be written in full." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom european-calendar-style nil - "*Use the European style of dates in the diary and in any displays. -If this variable is t, a date 1/2/1990 would be interpreted as February 1, -1990. The accepted European date styles are - - DAY/MONTH - DAY/MONTH/YEAR - DAY MONTHNAME - DAY MONTHNAME YEAR - DAYNAME - -Names can be capitalized or not, written in full, or abbreviated to three -characters with or without a period." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom american-date-diary-pattern - '((month "/" day "[^/0-9]") - (month "/" day "/" year "[^0-9]") - (monthname " *" day "[^,0-9]") - (monthname " *" day ", *" year "[^0-9]") - (dayname "\\W")) - "*List of pseudo-patterns describing the American patterns of date used. -See the documentation of `diary-date-forms' for an explanation." - :type '(repeat (choice (cons :tag "Backup" - (const backup) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp)))) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp))))) - :group 'diary) - -;;;###autoload -(defcustom european-date-diary-pattern - '((day "/" month "[^/0-9]") - (day "/" month "/" year "[^0-9]") - (backup day " *" monthname "\\W+\\<[^*0-9]") - (day " *" monthname " *" year "[^0-9]") - (dayname "\\W")) - "*List of pseudo-patterns describing the European patterns of date used. -See the documentation of `diary-date-forms' for an explanation." - :type '(repeat (choice (cons :tag "Backup" - (const backup) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp)))) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp))))) - :group 'diary) - -(defcustom diary-date-forms - (if european-calendar-style - european-date-diary-pattern - american-date-diary-pattern) - "*List of pseudo-patterns describing the forms of date used in the diary. -The patterns on the list must be MUTUALLY EXCLUSIVE and must should not match -any portion of the diary entry itself, just the date component. - -A pseudo-pattern is a list of regular expressions and the keywords `month', -`day', `year', `monthname', and `dayname'. The keyword `monthname' will -match the name of the month, capitalized or not, or its three-letter -abbreviation, followed by a period or not; it will also match `*'. -Similarly, `dayname' will match the name of the day, capitalized or not, or -its three-letter abbreviation, followed by a period or not. The keywords -`month', `day', and `year' will match those numerical values, preceded by -arbitrarily many zeros; they will also match `*'. - -The matching of the diary entries with the date forms is done with the -standard syntax table from Fundamental mode, but with the `*' changed so -that it is a word constituent. - -If, to be mutually exclusive, a pseudo-pattern must match a portion of the -diary entry itself, the first element of the pattern MUST be `backup'. This -directive causes the date recognizer to back up to the beginning of the -current word of the diary entry, so in no case can the pattern match more than -a portion of the first word of the diary entry." - :type '(repeat (choice (cons :tag "Backup" - (const backup) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp)))) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp))))) - :group 'diary) - -;;;###autoload -(defcustom european-calendar-display-form - '((if dayname (concat dayname ", ")) day " " monthname " " year) - "*Pseudo-pattern governing the way a date appears in the European style. -See the documentation of calendar-date-display-form for an explanation." - :type 'sexp - :group 'calendar) - -;;;###autoload -(defcustom american-calendar-display-form - '((if dayname (concat dayname ", ")) monthname " " day ", " year) - "*Pseudo-pattern governing the way a date appears in the American style. -See the documentation of `calendar-date-display-form' for an explanation." - :type 'sexp - :group 'calendar) - -(defcustom calendar-date-display-form - (if european-calendar-style - european-calendar-display-form - american-calendar-display-form) - "*Pseudo-pattern governing the way a date appears. - -Used by the function `calendar-date-string', a pseudo-pattern is a list of -expressions that can involve the keywords `month', `day', and `year', all -numbers in string form, and `monthname' and `dayname', both alphabetic -strings. For example, the ISO standard would use the pseudo- pattern - - '(year \"-\" month \"-\" day) - -while a typical American form would be - - '(month \"/\" day \"/\" (substring year -2)) - -and - - '((format \"%9s, %9s %2s, %4s\" dayname monthname day year)) - -would give the usual American style in fixed-length fields. - -See the documentation of the function `calendar-date-string'." - :type 'sexp - :group 'calendar) - -(defun european-calendar () - "Set the interpretation and display of dates to the European style." - (interactive) - (setq european-calendar-style t) - (setq calendar-date-display-form european-calendar-display-form) - (setq diary-date-forms european-date-diary-pattern) - (update-calendar-mode-line)) - -(defun american-calendar () - "Set the interpretation and display of dates to the American style." - (interactive) - (setq european-calendar-style nil) - (setq calendar-date-display-form american-calendar-display-form) - (setq diary-date-forms american-date-diary-pattern) - (update-calendar-mode-line)) - -;;;###autoload -(defcustom print-diary-entries-hook 'lpr-buffer - "*List of functions called after a temporary diary buffer is prepared. -The buffer shows only the diary entries currently visible in the diary -buffer. The default just does the printing. Other uses might include, for -example, rearranging the lines into order by day and time, saving the buffer -instead of deleting it, or changing the function used to do the printing." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom list-diary-entries-hook nil - "*List of functions called after diary file is culled for relevant entries. -It is to be used for diary entries that are not found in the diary file. - -A function `include-other-diary-files' is provided for use as the value of -this hook. This function enables you to use shared diary files together -with your own. The files included are specified in the diary file by lines -of the form - - #include \"filename\" - -This is recursive; that is, #include directives in files thus included are -obeyed. You can change the \"#include\" to some other string by changing -the variable `diary-include-string'. When you use `include-other-diary-files' -as part of the list-diary-entries-hook, you will probably also want to use the -function `mark-included-diary-files' as part of `mark-diary-entries-hook'. - -For example, you could use - - (setq list-diary-entries-hook - '(include-other-diary-files sort-diary-entries)) - (setq diary-display-hook 'fancy-diary-display) - -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." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom diary-hook nil - "*List of functions called after the display of the diary. -Can be used for appointment notification." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom diary-display-hook nil - "*List of functions that handle the display of the diary. -If nil (the default), `simple-diary-display' is used. Use `ignore' for no -diary display. - -Ordinarily, this just displays the diary buffer (with holidays indicated in -the mode line), if there are any relevant entries. At the time these -functions are called, the variable `diary-entries-list' is a list, in order -by date, of all relevant diary entries in the form of ((MONTH DAY YEAR) -STRING), where string is the diary entry for the given date. This can be -used, for example, a different buffer for display (perhaps combined with -holidays), or produce hard copy output. - -A function `fancy-diary-display' is provided as an alternative -choice for this hook; this function prepares a special noneditable diary -buffer with the relevant diary entries that has neat day-by-day arrangement -with headings. The fancy diary buffer will show the holidays unless the -variable `holidays-in-diary-buffer' is set to nil. Ordinarily, the fancy -diary buffer will not show days for which there are no diary entries, even -if that day is a holiday; if you want such days to be shown in the fancy -diary buffer, set the variable `diary-list-include-blanks' to t." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom nongregorian-diary-listing-hook nil - "*List of functions called for listing diary file and included files. -As the files are processed for diary entries, these functions are used to cull -relevant entries. You can use either or both of `list-hebrew-diary-entries' -and `list-islamic-diary-entries'. The documentation for these functions -describes the style of such diary entries." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom mark-diary-entries-hook nil - "*List of functions called after marking diary entries in the calendar. - -A function `mark-included-diary-files' is also provided for use as the -mark-diary-entries-hook; it enables you to use shared diary files together -with your own. The files included are specified in the diary file by lines -of the form - #include \"filename\" -This is recursive; that is, #include directives in files thus included are -obeyed. You can change the \"#include\" to some other string by changing the -variable `diary-include-string'. When you use `mark-included-diary-files' as -part of the mark-diary-entries-hook, you will probably also want to use the -function `include-other-diary-files' as part of `list-diary-entries-hook'." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom nongregorian-diary-marking-hook nil - "*List of functions called for marking diary file and included files. -As the files are processed for diary entries, these functions are used to cull -relevant entries. You can use either or both of `mark-hebrew-diary-entries' -and `mark-islamic-diary-entries'. The documentation for these functions -describes the style of such diary entries." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom diary-list-include-blanks nil - "*If nil, do not include days with no diary entry in the list of diary entries. -Such days will then not be shown in the fancy diary buffer, even if they -are holidays." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom holidays-in-diary-buffer t - "*Non-nil means include holidays in the diary display. -The holidays appear in the mode line of the diary buffer, or in the -fancy diary buffer next to the date. This slows down the diary functions -somewhat; setting it to nil makes the diary display faster." - :type 'boolean - :group 'diary) - -(defvar calendar-mark-ring nil) - -;;;###autoload -(defcustom general-holidays - '((holiday-fixed 1 1 "New Year's Day") - (holiday-float 1 1 3 "Martin Luther King Day") - (holiday-fixed 2 2 "Ground Hog Day") - (holiday-fixed 2 14 "Valentine's Day") - (holiday-float 2 1 3 "President's Day") - (holiday-fixed 3 17 "St. Patrick's Day") - (holiday-fixed 4 1 "April Fool's Day") - (holiday-float 5 0 2 "Mother's Day") - (holiday-float 5 1 -1 "Memorial Day") - (holiday-fixed 6 14 "Flag Day") - (holiday-float 6 0 3 "Father's Day") - (holiday-fixed 7 4 "Independence Day") - (holiday-float 9 1 1 "Labor Day") - (holiday-float 10 1 2 "Columbus Day") - (holiday-fixed 10 31 "Halloween") - (holiday-fixed 11 11 "Veteran's Day") - (holiday-float 11 4 4 "Thanksgiving")) - "*General holidays. Default value is for the United States. -See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) - -;;;###autoload -(put 'general-holidays 'risky-local-variable t) - -;;;###autoload -(defcustom local-holidays nil - "*Local holidays. -See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays - :group 'local) - -;;;###autoload -(put 'local-holidays 'risky-local-variable t) -;;;###autoload -(defcustom other-holidays nil - "*User defined holidays. -See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) - -;;;###autoload -(put 'other-holidays 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-1 - '((holiday-rosh-hashanah-etc) - (if all-hebrew-calendar-holidays - (holiday-julian - 11 - (let* ((m displayed-month) - (y displayed-year) - (year)) - (increment-calendar-month m y -1) - (let ((year (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m 1 y)))))) - (if (zerop (% (1+ year) 4)) - 22 - 21))) "\"Tal Umatar\" (evening)")))) - -;;;###autoload -(put 'hebrew-holidays-1 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-2 - '((if all-hebrew-calendar-holidays - (holiday-hanukkah) - (holiday-hebrew 9 25 "Hanukkah")) - (if all-hebrew-calendar-holidays - (holiday-hebrew - 10 - (let ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 28 displayed-year)))))) - (if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year)) - 7) - 6) - 11 10)) - "Tzom Teveth")) - (if all-hebrew-calendar-holidays - (holiday-hebrew 11 15 "Tu B'Shevat")))) - -;;;###autoload -(put 'hebrew-holidays-2 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-3 - '((if all-hebrew-calendar-holidays - (holiday-hebrew - 11 - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list m - (calendar-last-day-of-month m y) - y))))) - (s-s - (calendar-hebrew-from-absolute - (if (= - (% (calendar-absolute-from-hebrew - (list 7 1 h-year)) - 7) - 6) - (calendar-dayname-on-or-before - 6 (calendar-absolute-from-hebrew - (list 11 17 h-year))) - (calendar-dayname-on-or-before - 6 (calendar-absolute-from-hebrew - (list 11 16 h-year)))))) - (day (extract-calendar-day s-s))) - day)) - "Shabbat Shirah")))) -;;;###autoload -(put 'hebrew-holidays-3 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-4 - '((holiday-passover-etc) - (if (and all-hebrew-calendar-holidays - (let* ((m displayed-month) - (y displayed-year) - (year)) - (increment-calendar-month m y -1) - (let ((year (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m 1 y)))))) - (= 21 (% year 28))))) - (holiday-julian 3 26 "Kiddush HaHamah")) - (if all-hebrew-calendar-holidays - (holiday-tisha-b-av-etc)))) -;;;###autoload -(put 'hebrew-holidays-4 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays (append hebrew-holidays-1 hebrew-holidays-2 - hebrew-holidays-3 hebrew-holidays-4) - "*Jewish holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'hebrew-holidays 'risky-local-variable t) - -;;;###autoload -(defvar christian-holidays - '((if all-christian-calendar-holidays - (holiday-fixed 1 6 "Epiphany")) - (holiday-easter-etc) - (if all-christian-calendar-holidays - (holiday-greek-orthodox-easter)) - (if all-christian-calendar-holidays - (holiday-fixed 8 15 "Assumption")) - (if all-christian-calendar-holidays - (holiday-advent)) - (holiday-fixed 12 25 "Christmas") - (if all-christian-calendar-holidays - (holiday-julian 12 25 "Eastern Orthodox Christmas"))) - "*Christian holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'christian-holidays 'risky-local-variable t) - -;;;###autoload -(defvar islamic-holidays - '((holiday-islamic - 1 1 - (format "Islamic New Year %d" - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list - m (calendar-last-day-of-month m y) y))))))) - (if all-islamic-calendar-holidays - (holiday-islamic 1 10 "Ashura")) - (if all-islamic-calendar-holidays - (holiday-islamic 3 12 "Mulad-al-Nabi")) - (if all-islamic-calendar-holidays - (holiday-islamic 7 26 "Shab-e-Mi'raj")) - (if all-islamic-calendar-holidays - (holiday-islamic 8 15 "Shab-e-Bara't")) - (holiday-islamic 9 1 "Ramadan Begins") - (if all-islamic-calendar-holidays - (holiday-islamic 9 27 "Shab-e Qadr")) - (if all-islamic-calendar-holidays - (holiday-islamic 10 1 "Id-al-Fitr")) - (if all-islamic-calendar-holidays - (holiday-islamic 12 10 "Id-al-Adha"))) - "*Islamic holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'islamic-holidays 'risky-local-variable t) - -;;;###autoload -(defvar solar-holidays - '((if (fboundp 'atan) - (solar-equinoxes-solstices)) - (if (progn - (require 'cal-dst) - t) - (funcall - 'holiday-sexp - calendar-daylight-savings-starts - '(format "Daylight Savings Time Begins %s" - (if (fboundp 'atan) - (solar-time-string - (/ calendar-daylight-savings-starts-time (float 60)) - calendar-standard-time-zone-name) - "")))) - (funcall - 'holiday-sexp - calendar-daylight-savings-ends - '(format "Daylight Savings Time Ends %s" - (if (fboundp 'atan) - (solar-time-string - (/ calendar-daylight-savings-ends-time (float 60)) - calendar-daylight-time-zone-name) - "")))) - "*Sun-related holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'solar-holidays 'risky-local-variable t) - -;;;###autoload -(defvar calendar-holidays - (append general-holidays local-holidays other-holidays - christian-holidays hebrew-holidays islamic-holidays - solar-holidays) - "*List of notable days for the command M-x holidays. - -Additional holidays are easy to add to the list, just put them in the list -`other-holidays' in your .emacs file. Similarly, by setting any of -`general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays', -`islamic-holidays', or `solar-holidays' to nil in your .emacs file, you can -eliminate unwanted categories of holidays. The intention is that (in the US) -`local-holidays' be set in site-init.el and `other-holidays' be set by the -user. - -Entries on the list are expressions that return (possibly empty) lists of -items of the form ((month day year) string) of a holiday in the in the -three-month period centered around `displayed-month' of `displayed-year'. -Several basic functions are provided for this purpose: - - (holiday-fixed MONTH DAY STRING) is a fixed date on the Gregorian calendar - (holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in - MONTH on the Gregorian calendar (0 for Sunday, - etc.); K<0 means count back from the end of the - month. An optional parameter DAY means the Kth - DAYNAME after/before MONTH DAY. - (holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar - (holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar - (holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar - (holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression - in the variable `year'; if it evaluates to - a visible date, that's the holiday; if it - evaluates to nil, there's no holiday. STRING - is an expression in the variable `date'. - -For example, to add Bastille Day, celebrated in France on July 14, add - - (holiday-fixed 7 14 \"Bastille Day\") - -to the list. To add Hurricane Supplication Day, celebrated in the Virgin -Islands on the fourth Monday in August, add - - (holiday-float 8 1 4 \"Hurricane Supplication Day\") - -to the list (the last Monday would be specified with `-1' instead of `4'). -To add the last day of Hanukkah to the list, use - - (holiday-hebrew 10 2 \"Last day of Hanukkah\") - -since the Hebrew months are numbered with 1 starting from Nisan, while to -add the Islamic feast celebrating Mohammed's birthday use - - (holiday-islamic 3 12 \"Mohammed's Birthday\") - -since the Islamic months are numbered from 1 starting with Muharram. To -add Thomas Jefferson's birthday, April 2, 1743 (Julian), use - - (holiday-julian 4 2 \"Jefferson's Birthday\") - -To include a holiday conditionally, use the sexp form or a conditional. For -example, to include American presidential elections, which occur on the first -Tuesday after the first Monday in November of years divisible by 4, add - - (holiday-sexp - (if (zerop (% year 4)) - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 year))))))) - \"US Presidential Election\") - -or - - (if (zerop (% displayed-year 4)) - (holiday-fixed 11 - (extract-calendar-day - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 displayed-year))))))) - \"US Presidential Election\")) - -to the list. To include the phases of the moon, add - - (lunar-phases) - -to the holiday list, where `lunar-phases' is an Emacs-Lisp function that -you've written to return a (possibly empty) list of the relevant VISIBLE dates -with descriptive strings such as - - (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... ).") - -;;;###autoload -(put 'calendar-holidays 'risky-local-variable t) - -(defconst calendar-buffer "*Calendar*" - "Name of the buffer used for the calendar.") - -(defconst holiday-buffer "*Holidays*" - "Name of the buffer used for the displaying the holidays.") - -(defconst fancy-diary-buffer "*Fancy Diary Entries*" - "Name of the buffer used for the optional fancy display of the diary.") - -(defconst lunar-phases-buffer "*Phases of Moon*" - "Name of the buffer used for the lunar phases.") - -(defmacro increment-calendar-month (mon yr n) - "Move the variables MON and YR to the month and year by N months. -Forward if N is positive or backward if N is negative." - (` (let (( macro-y (+ (* (, yr) 12) (, mon) -1 (, n) ))) - (setq (, mon) (1+ (% macro-y 12) )) - (setq (, yr) (/ macro-y 12))))) - -(defmacro calendar-for-loop (var from init to final do &rest body) - "Execute a for loop." - (` (let (( (, var) (1- (, init)) )) - (while (>= (, final) (setq (, var) (1+ (, var)))) - (,@ body))))) - -(defmacro calendar-sum (index initial condition expression) - "For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION." - (` (let (( (, index) (, initial)) - (sum 0)) - (while (, condition) - (setq sum (+ sum (, expression) )) - (setq (, index) (1+ (, index)))) - sum))) - -;; The following are in-line for speed; they can be called thousands of times -;; when looking up holidays or processing the diary. Here, for example, are -;; the numbers of calls to calendar/diary/holiday functions in preparing the -;; fancy diary display, for a moderately complex diary file, with functions -;; used instead of macros. There were a total of 10000 such calls: -;; -;; 1934 extract-calendar-month -;; 1852 extract-calendar-year -;; 1819 extract-calendar-day -;; 845 calendar-leap-year-p -;; 837 calendar-day-number -;; 775 calendar-absolute-from-gregorian -;; 346 calendar-last-day-of-month -;; 286 hebrew-calendar-last-day-of-month -;; 188 hebrew-calendar-leap-year-p -;; 180 hebrew-calendar-elapsed-days -;; 163 hebrew-calendar-last-month-of-year -;; 66 calendar-date-compare -;; 65 hebrew-calendar-days-in-year -;; 60 calendar-absolute-from-julian -;; 50 calendar-absolute-from-hebrew -;; 43 calendar-date-equal -;; 38 calendar-gregorian-from-absolute -;; . -;; . -;; . -;; -;; The use of these seven macros eliminates the overhead of 92% of the function -;; calls; it's faster this way. - -(defsubst extract-calendar-month (date) - "Extract the month part of DATE which has the form (month day year)." - (car date)) - -(defsubst extract-calendar-day (date) - "Extract the day part of DATE which has the form (month day year)." - (car (cdr date))) - -(defsubst extract-calendar-year (date) - "Extract the year part of DATE which has the form (month day year)." - (car (cdr (cdr date)))) - -(defsubst calendar-leap-year-p (year) - "Returns t if YEAR is a Gregorian leap year." - (and (zerop (% year 4)) - (or (not (zerop (% year 100))) - (zerop (% year 400))))) - -;; The foregoing is a bit faster, but not as clear as the following: -;; -;;(defsubst calendar-leap-year-p (year) -;; "Returns t if YEAR is a Gregorian leap year." -;; (or -;; (and (= (% year 4) 0) -;; (/= (% year 100) 0)) -;; (= (% year 400) 0))) - -(defsubst calendar-last-day-of-month (month year) - "The last day in MONTH during YEAR." - (if (and (= month 2) (calendar-leap-year-p year)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - -;; An explanation of the calculation can be found in PascAlgorithms by -;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988. - -(defsubst calendar-day-number (date) - "Return the day number within the year of the date DATE. -For example, (calendar-day-number '(1 1 1987)) returns the value 1, -while (calendar-day-number '(12 31 1980)) returns 366." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (day-of-year (+ day (* 31 (1- month))))) - (if (> month 2) - (progn - (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) - (if (calendar-leap-year-p year) - (setq day-of-year (1+ day-of-year))))) - day-of-year)) - -(defsubst calendar-absolute-from-gregorian (date) - "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. -The Gregorian date Sunday, December 31, 1 BC is imaginary." - (let ((prior-years (1- (extract-calendar-year date)))) - (+ (calendar-day-number date);; Days this year - (* 365 prior-years);; + Days in prior years - (/ prior-years 4);; + Julian leap years - (- (/ prior-years 100));; - century years - (/ prior-years 400))));; + Gregorian leap years - -;;;###autoload -(defun calendar (&optional arg) - "Display a three-month calendar in another window. -The three months appear side by side, with the current month in the middle -surrounded by the previous and next months. The cursor is put on today's date. - -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file; appropriate setting -of the variable `view-diary-entries-initially' will cause the diary entries for -the current date to be displayed in another window. The value of the variable -`number-of-diary-entries' controls the number of days of diary entries -displayed upon initial display of the calendar. - -An optional prefix argument ARG causes the calendar displayed to be ARG -months in the future if ARG is positive or in the past if ARG is negative; -in this case the cursor goes on the first day of the month. - -Once in the calendar window, future or past months can be moved into view. -Arbitrary months can be displayed, or the calendar can be scrolled forward -or backward. - -The cursor can be moved forward or backward by one day, one week, one month, -or one year. All of these commands take prefix arguments which, when negative, -cause movement in the opposite direction. For convenience, the digit keys -and the minus sign are automatically prefixes. The window is replotted as -necessary to display the desired date. - -Diary entries can be marked on the calendar or displayed in another window. - -Use M-x describe-mode for details of the key bindings in the calendar window. - -The Gregorian calendar is assumed. - -After loading the calendar, the hooks given by the variable -`calendar-load-hook' are run. This is the place to add key bindings to the -calendar-mode-map. - -After preparing the calendar window initially, the hooks given by the variable -`initial-calendar-window-hook' are run. - -The hooks given by the variable `today-visible-calendar-hook' are run -everytime the calendar window gets scrolled, if the current date is visible -in the window. If it is not visible, the hooks given by the variable -`today-invisible-calendar-hook' are run. Thus, for example, setting -`today-visible-calendar-hook' to 'calendar-star-date will cause today's date -to be replaced by asterisks to highlight it whenever it is in the window." - (interactive "P") - (set-buffer (get-buffer-create calendar-buffer)) - (calendar-mode) - (let* ((pop-up-windows t) - (split-height-threshold 1000) - (date (if arg - (calendar-read-date t) - (calendar-current-date))) - (month (extract-calendar-month date)) - (year (extract-calendar-year date))) - (pop-to-buffer calendar-buffer) - (increment-calendar-month month year (- calendar-offset)) - (generate-calendar-window month year) - (if (and view-diary-entries-initially (calendar-date-is-visible-p date)) - (view-diary-entries - (if (vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date)) - number-of-diary-entries)))) - (let* ((diary-buffer (get-file-buffer diary-file)) - (diary-window (if diary-buffer (get-buffer-window diary-buffer))) - (split-height-threshold (if diary-window 2 1000))) - (if view-calendar-holidays-initially - (list-calendar-holidays))) - (run-hooks 'initial-calendar-window-hook)) - -(autoload 'view-diary-entries "diary-lib" - "Prepare and display a buffer with diary entries. -Searches your diary file for entries that match ARG days starting with -the date indicated by the cursor position in the displayed three-month -calendar." - t) - -(autoload 'calendar-sunrise-sunset "solar" - "Local time of sunrise and sunset for date under cursor." - t) - -(autoload 'calendar-phases-of-moon "lunar" - "Create a buffer of the phases of the moon for the current calendar window." - t) - -(autoload 'calendar-print-french-date "cal-french" - "Show the French Revolutionary calendar equivalent of the date under the cursor." - t) - -(autoload 'calendar-goto-french-date "cal-french" - "Move cursor to French Revolutionary date." - t) - -(autoload 'calendar-french-date-string "cal-french" - "String of French Revolutionary date of Gregorian DATE." - t) - -(autoload 'calendar-mayan-date-string "cal-mayan" - "String of Mayan date of Gregorian DATE." - t) - -(autoload 'calendar-print-mayan-date "cal-mayan" - "Show the Mayan long count, Tzolkin, and Haab equivalents of the date under the cursor." - t) - -(autoload 'calendar-goto-mayan-long-count-date "cal-mayan" - "Move cursor to Mayan long count date." - t) - -(autoload 'calendar-next-haab-date "cal-mayan" - "Move cursor to next instance of Mayan Haab date." - t) - -(autoload 'calendar-previous-haab-date "cal-mayan" - "Move cursor to previous instance of Mayan Haab date." - t) - -(autoload 'calendar-next-tzolkin-date "cal-mayan" - "Move cursor to next instance of Mayan Tzolkin date." - t) - -(autoload 'calendar-previous-tzolkin-date "cal-mayan" - "Move cursor to previous instance of Mayan Tzolkin date." - t) - -(autoload 'calendar-next-calendar-round-date "cal-mayan" - "Move cursor to next instance of Mayan Haab/Tzoklin combination." - t) - -(autoload 'calendar-previous-calendar-round-date "cal-mayan" - "Move cursor to previous instance of Mayan Haab/Tzoklin combination." - t) - -(autoload 'show-all-diary-entries "diary-lib" - "Show all of the diary entries in the diary file. -This function gets rid of the selective display of the diary file so that -all entries, not just some, are visible. If there is no diary buffer, one -is created." - t) - -(autoload 'mark-diary-entries "diary-lib" - "Mark days in the calendar window that have diary entries. -Each entry in diary file visible in the calendar window is marked." - t) - -(autoload 'insert-diary-entry "diary-ins" - "Insert a diary entry for the date indicated by point." - t) - -(autoload 'insert-weekly-diary-entry "diary-ins" - "Insert a weekly diary entry for the day of the week indicated by point." - t) - - -(autoload 'insert-monthly-diary-entry "diary-ins" - "Insert a monthly diary entry for the day of the month indicated by point." - t) - -(autoload 'insert-yearly-diary-entry "diary-ins" - "Insert an annual diary entry for the day of the year indicated by point." - t) - -(autoload 'insert-anniversary-diary-entry "diary-ins" - "Insert an anniversary diary entry for the date indicated by point." - t) - -(autoload 'insert-block-diary-entry "diary-ins" - "Insert a block diary entry for the dates indicated by point and mark." - t) - -(autoload 'insert-cyclic-diary-entry "diary-ins" - "Insert a cyclic diary entry starting at the date indicated by point." - t) - -(autoload 'insert-hebrew-diary-entry "diary-ins" - "Insert a diary entry for the Hebrew date corresponding to the date -indicated by point." - t) - -(autoload 'insert-monthly-hebrew-diary-entry "diary-ins" - "Insert a monthly diary entry for the day of the Hebrew month corresponding -to the date indicated by point." - t) - -(autoload 'insert-yearly-hebrew-diary-entry "diary-ins" - "Insert an annual diary entry for the day of the Hebrew year corresponding -to the date indicated by point." - t) - -(autoload 'insert-islamic-diary-entry "diary-ins" - "Insert a diary entry for the Islamic date corresponding to the date -indicated by point." - t) - -(autoload 'insert-monthly-islamic-diary-entry "diary-ins" - "Insert a monthly diary entry for the day of the Islamic month corresponding -to the date indicated by point." - t) - -(autoload 'insert-yearly-islamic-diary-entry "diary-ins" - "Insert an annual diary entry for the day of the Islamic year corresponding -to the date indicated by point." - t) - -(autoload 'list-calendar-holidays "holidays" - "Create a buffer containing the holidays for the current calendar window. -The holidays are those in the list `calendar-notable-days'. Returns t if any -holidays are found, nil if not." - t) - -(autoload 'mark-calendar-holidays "holidays" - "Mark notable days in the calendar window." - t) - -(autoload 'calendar-cursor-holidays "holidays" - "Find holidays for the date specified by the cursor in the calendar window." - t) - -(defun generate-calendar-window (&optional mon yr) - "Generate the calendar window for the current date. -Or, for optional MON, YR." - (let* ((buffer-read-only nil) - (today (calendar-current-date)) - (month (extract-calendar-month today)) - (day (extract-calendar-day today)) - (year (extract-calendar-year today)) - (today-visible - (or (not mon) - (let ((offset (calendar-interval mon yr month year))) - (and (<= offset 1) (>= offset -1))))) - (day-in-week (calendar-day-of-week today))) - (update-calendar-mode-line) - (if mon - (generate-calendar mon yr) - (generate-calendar month year)) - (calendar-cursor-to-visible-date - (if today-visible today (list displayed-month 1 displayed-year))) - (set-buffer-modified-p nil) - (or (one-window-p t) - (/= (frame-width) (window-width)) - (shrink-window (- (window-height) 9))) - (sit-for 0) - (and mark-holidays-in-calendar - (mark-calendar-holidays) - (sit-for 0)) - (unwind-protect - (if mark-diary-entries-in-calendar (mark-diary-entries)) - (if today-visible - (run-hooks 'today-visible-calendar-hook) - (run-hooks 'today-invisible-calendar-hook))))) - -(defun generate-calendar (month year) - "Generate a three-month Gregorian calendar centered around MONTH, YEAR." - (if (< (+ month (* 12 (1- year))) 2) - (error "Months before February, 1 AD are not available.")) - (setq displayed-month month) - (setq displayed-year year) - (erase-buffer) - (increment-calendar-month month year -1) - (calendar-for-loop i from 0 to 2 do - (generate-calendar-month month year (+ 5 (* 25 i))) - (increment-calendar-month month year 1))) - -(defun generate-calendar-month (month year indent) - "Produce a calendar for MONTH, YEAR on the Gregorian calendar. -The calendar is inserted in the buffer starting at the line on which point -is currently located, but indented INDENT spaces. The indentation is done -from the first character on the line and does not disturb the first INDENT -characters on the line." - (let* ((blank-days;; at start of month - (mod - (- (calendar-day-of-week (list month 1 year)) - calendar-week-start-day) - 7)) - (last (calendar-last-day-of-month month year))) - (goto-char (point-min)) - (calendar-insert-indented - (calendar-string-spread - (list "" (format "%s %d" (calendar-month-name month) year) "") ? 20) - indent t) - (calendar-insert-indented "" indent);; Go to proper spot - (calendar-for-loop i from 0 to 6 do - (insert (substring (aref calendar-day-name-array - (mod (+ calendar-week-start-day i) 7)) - 0 2)) - (insert " ")) - (calendar-insert-indented "" 0 t);; Force onto following line - (calendar-insert-indented "" indent);; Go to proper spot - ;; Add blank days before the first of the month - (calendar-for-loop i from 1 to blank-days do (insert " ")) - ;; Put in the days of the month - (calendar-for-loop i from 1 to last do - (insert (format "%2d " i)) - (put-text-property (- (point) (if (< i 10) 2 3)) (1- (point)) - 'highlight t) - (and (zerop (mod (+ i blank-days) 7)) - (/= i last) - (calendar-insert-indented "" 0 t) ;; Force onto following line - (calendar-insert-indented "" indent)))));; Go to proper spot - -(defun calendar-insert-indented (string indent &optional newline) - "Insert STRING at column INDENT. -If the optional parameter NEWLINE is t, leave point at start of next line, -inserting a newline if there was no next line; otherwise, leave point after -the inserted text. Value is always t." - ;; Try to move to that column. - (move-to-column indent) - ;; If line is too short, indent out to that column. - (if (< (current-column) indent) - (indent-to indent)) - (insert string) - ;; Advance to next line, if requested. - (if newline - (progn - (end-of-line) - (if (eobp) - (newline) - (forward-line 1)))) - t) - -(defun redraw-calendar () - "Redraw the calendar display." - (interactive) - (let ((cursor-date (calendar-cursor-to-date))) - (generate-calendar-window displayed-month displayed-year) - (calendar-cursor-to-visible-date cursor-date))) - -(defvar calendar-debug-sexp nil - "*Turn debugging on when evaluating a sexp in the diary or holiday list.") - -(defvar calendar-mode-map nil) -(if calendar-mode-map - nil - (setq calendar-mode-map (make-sparse-keymap)) - (calendar-for-loop i from 0 to 9 do - (define-key calendar-mode-map (int-to-string i) 'digit-argument)) - (let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph - 'mark-defun 'mark-whole-buffer 'mark-page - 'downcase-region 'upcase-region 'kill-region - 'copy-region-as-kill 'capitalize-region 'write-region))) - (while l - (substitute-key-definition (car l) 'calendar-not-implemented - calendar-mode-map) - (setq l (cdr l)))) - (define-key calendar-mode-map "-" 'negative-argument) - (define-key calendar-mode-map "\C-x>" 'scroll-calendar-right) - (define-key calendar-mode-map '[prior] 'scroll-calendar-right-three-months) - (define-key calendar-mode-map "\M-v" 'scroll-calendar-right-three-months) - (define-key calendar-mode-map "\C-x<" 'scroll-calendar-left) - (define-key calendar-mode-map '[next] 'scroll-calendar-left-three-months) - (define-key calendar-mode-map "\C-v" 'scroll-calendar-left-three-months) - (define-key calendar-mode-map "\C-b" 'calendar-backward-day) - (define-key calendar-mode-map "\C-p" 'calendar-backward-week) - (define-key calendar-mode-map "\M-{" 'calendar-backward-month) - (define-key calendar-mode-map "\C-x[" 'calendar-backward-year) - (define-key calendar-mode-map "\C-f" 'calendar-forward-day) - (define-key calendar-mode-map "\C-n" 'calendar-forward-week) - (define-key calendar-mode-map '[left] 'calendar-backward-day) - (define-key calendar-mode-map '[up] 'calendar-backward-week) - (define-key calendar-mode-map '[right] 'calendar-forward-day) - (define-key calendar-mode-map '[down] 'calendar-forward-week) - (define-key calendar-mode-map "\M-}" 'calendar-forward-month) - (define-key calendar-mode-map "\C-x]" 'calendar-forward-year) - (define-key calendar-mode-map "\C-a" 'calendar-beginning-of-week) - (define-key calendar-mode-map "\C-e" 'calendar-end-of-week) - (define-key calendar-mode-map "\M-a" 'calendar-beginning-of-month) - (define-key calendar-mode-map "\M-e" 'calendar-end-of-month) - (define-key calendar-mode-map "\M-<" 'calendar-beginning-of-year) - (define-key calendar-mode-map "\M->" 'calendar-end-of-year) - (define-key calendar-mode-map "\C-@" 'calendar-set-mark) - ;; Many people are used to typing C-SPC and getting C-@. - (define-key calendar-mode-map "\C- " 'calendar-set-mark) - (define-key calendar-mode-map "\C-x\C-x" 'calendar-exchange-point-and-mark) - (define-key calendar-mode-map "\M-=" 'calendar-count-days-region) - (define-key calendar-mode-map "gd" 'calendar-goto-date) - (define-key calendar-mode-map "gj" 'calendar-goto-julian-date) - (define-key calendar-mode-map "ga" 'calendar-goto-astro-day-number) - (define-key calendar-mode-map "gh" 'calendar-goto-hebrew-date) - (define-key calendar-mode-map "gi" 'calendar-goto-islamic-date) - (define-key calendar-mode-map "gc" 'calendar-goto-iso-date) - (define-key calendar-mode-map "gf" 'calendar-goto-french-date) - (define-key calendar-mode-map "gml" 'calendar-goto-mayan-long-count-date) - (define-key calendar-mode-map "gmpc" 'calendar-previous-calendar-round-date) - (define-key calendar-mode-map "gmnc" 'calendar-next-calendar-round-date) - (define-key calendar-mode-map "gmph" 'calendar-previous-haab-date) - (define-key calendar-mode-map "gmnh" 'calendar-next-haab-date) - (define-key calendar-mode-map "gmpt" 'calendar-previous-tzolkin-date) - (define-key calendar-mode-map "gmnt" 'calendar-next-tzolkin-date) - (define-key calendar-mode-map "S" 'calendar-sunrise-sunset) - (define-key calendar-mode-map "M" 'calendar-phases-of-moon) - (define-key calendar-mode-map " " 'scroll-other-window) - (define-key calendar-mode-map "\C-c\C-l" 'redraw-calendar) - (define-key calendar-mode-map "." 'calendar-goto-today) - (define-key calendar-mode-map "o" 'calendar-other-month) - (define-key calendar-mode-map "q" 'exit-calendar) - (define-key calendar-mode-map "a" 'list-calendar-holidays) - (define-key calendar-mode-map "h" 'calendar-cursor-holidays) - (define-key calendar-mode-map "x" 'mark-calendar-holidays) - (define-key calendar-mode-map "u" 'calendar-unmark) - (define-key calendar-mode-map "m" 'mark-diary-entries) - (define-key calendar-mode-map "d" 'view-diary-entries) - (define-key calendar-mode-map "D" 'view-other-diary-entries) - (define-key calendar-mode-map "s" 'show-all-diary-entries) - (define-key calendar-mode-map "pd" 'calendar-print-day-of-year) - (define-key calendar-mode-map "pc" 'calendar-print-iso-date) - (define-key calendar-mode-map "pj" 'calendar-print-julian-date) - (define-key calendar-mode-map "pa" 'calendar-print-astro-day-number) - (define-key calendar-mode-map "ph" 'calendar-print-hebrew-date) - (define-key calendar-mode-map "pi" 'calendar-print-islamic-date) - (define-key calendar-mode-map "pf" 'calendar-print-french-date) - (define-key calendar-mode-map "pm" 'calendar-print-mayan-date) - (define-key calendar-mode-map "id" 'insert-diary-entry) - (define-key calendar-mode-map "iw" 'insert-weekly-diary-entry) - (define-key calendar-mode-map "im" 'insert-monthly-diary-entry) - (define-key calendar-mode-map "iy" 'insert-yearly-diary-entry) - (define-key calendar-mode-map "ia" 'insert-anniversary-diary-entry) - (define-key calendar-mode-map "ib" 'insert-block-diary-entry) - (define-key calendar-mode-map "ic" 'insert-cyclic-diary-entry) - (define-key calendar-mode-map "ihd" 'insert-hebrew-diary-entry) - (define-key calendar-mode-map "ihm" 'insert-monthly-hebrew-diary-entry) - (define-key calendar-mode-map "ihy" 'insert-yearly-hebrew-diary-entry) - (define-key calendar-mode-map "iid" 'insert-islamic-diary-entry) - (define-key calendar-mode-map "iim" 'insert-monthly-islamic-diary-entry) - (define-key calendar-mode-map "iiy" 'insert-yearly-islamic-diary-entry) - (define-key calendar-mode-map "?" 'calendar-goto-info-node)) - -(defun describe-calendar-mode () - "Create a help buffer with a brief description of the calendar-mode." - (interactive) - (with-output-to-temp-buffer "*Help*" - (princ - (format - "Calendar Mode:\nFor a complete description, type %s\n%s\n" - (substitute-command-keys - "\\\\[describe-mode] from within the calendar") - (substitute-command-keys "\\{calendar-mode-map}"))) - (save-excursion - (set-buffer standard-output) - (help-mode)) - (print-help-return-message))) - -;; Calendar mode is suitable only for specially formatted data. -(put 'calendar-mode 'mode-class 'special) - -(defvar calendar-mode-line-format - (list - (substitute-command-keys "\\\\[scroll-calendar-left]") - "Calendar" - (substitute-command-keys "\\\\[calendar-goto-info-node] info/\\[calendar-other-month] other/\\[calendar-goto-today] today") - '(calendar-date-string (calendar-current-date) t) - (substitute-command-keys "\\\\[scroll-calendar-right]")) - "The mode line of the calendar buffer.") - -(defun calendar-goto-info-node () - "Go to the info node for the calendar." - (interactive) - (require 'info) - (let ((where (Info-find-emacs-command-nodes 'calendar))) - (if (not where) - (error "Couldn't find documentation for the calendar.") - (save-window-excursion (info)) - (pop-to-buffer "*info*") - (Info-find-node (car (car where)) (car (cdr (car where))))))) - -(defun calendar-mode () - "A major mode for the calendar window. - -For a complete description, type \ -\\\\[calendar-goto-info-node] from within the calendar. - -\\\\{calendar-mode-map}" - - (kill-all-local-variables) - (setq major-mode 'calendar-mode) - (setq mode-name "Calendar") - (use-local-map calendar-mode-map) - (setq buffer-read-only t) - (setq indent-tabs-mode nil) - (update-calendar-mode-line) - (if (and (string-match "XEmacs" emacs-version) current-menubar) - (progn - (require 'cal-xemacs) - (calendar-add-menus) - (make-variable-buffer-local 'scroll-on-clipped-lines) - (setq scroll-on-clipped-lines nil))) - (make-local-variable 'calendar-mark-ring) - (make-local-variable 'displayed-month);; Month in middle of window. - (make-local-variable 'displayed-year));; Year in middle of window. - -(defun calendar-string-spread (strings char length) - "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH -There must be at least 2 strings. The effect is like mapconcat but the -separating pieces are as balanced as possible. Each item of STRINGS is -evaluated before concatenation so it can actually be an expression that -evaluates to a string. If LENGTH is too short, the STRINGS are just -concatenated and the result truncated." -;; The algorithm is based on equation (3.25) on page 85 of Concrete -;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik, -;; Addison-Wesley, Reading, MA, 1989 - (let* ((strings (mapcar 'eval strings)) - (n (- length (length (apply 'concat strings)))) - (m (1- (length strings))) - (s (car strings)) - (strings (cdr strings)) - (i 0)) - (while strings - (setq s (concat s - (make-string (max 0 (/ (+ n i) m)) char) - (car strings))) - (setq i (1+ i)) - (setq strings (cdr strings))) - (substring s 0 length))) - -(defun update-calendar-mode-line () - "Update the calendar mode line with the current date and date style." - (if (bufferp (get-buffer calendar-buffer)) - (save-excursion - (set-buffer calendar-buffer) - (setq mode-line-format - (calendar-string-spread - calendar-mode-line-format ? (frame-width)))))) - -(defun calendar-window-list () - "List of all calendar-related windows." - (let ((calendar-buffers (calendar-buffer-list)) - list) - (walk-windows '(lambda (w) - (if (memq (window-buffer w) calendar-buffers) - (setq list (cons w list)))) - nil t) - list)) - -(defun calendar-buffer-list () - "List of all calendar-related buffers." - (let* ((diary-buffer (get-file-buffer diary-file)) - (buffers (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer - fancy-diary-buffer diary-buffer calendar-buffer)) - (buffer-list nil) - b) - (while buffers - (setq b (car buffers)) - (setq b (cond ((stringp b) (get-buffer b)) - ((bufferp b) b) - (t nil))) - (if b (setq buffer-list (cons b buffer-list))) - (setq buffers (cdr buffers))) - buffer-list)) - -(defun exit-calendar () - "Get out of the calendar window and hide it and related buffers." - (interactive) - (let* ((diary-buffer (get-file-buffer diary-file))) - (if (and diary-buffer (buffer-modified-p diary-buffer) - (not - (yes-or-no-p - "Diary modified; do you really want to exit the calendar? "))) - (error) - ;; Need to do this multiple times because one time can replace some - ;; calendar-related buffers with other calendar-related buffers - (mapcar (lambda (x) - (mapcar 'calendar-hide-window (calendar-window-list))) - (calendar-window-list))))) - -(defun calendar-hide-window (window) - "Hide WINDOW if it is calendar-related." - (let ((buffer (if (window-live-p window) (window-buffer window)))) - (if (memq buffer (calendar-buffer-list)) - (cond - ((and window-system - (eq 'icon (cdr (assoc 'visibility - (frame-parameters - (window-frame window)))))) - nil) - ((and window-system (window-dedicated-p window)) - (iconify-frame (window-frame window))) - ((not (and (select-window window) (one-window-p window))) - (delete-window window)) - (t (set-buffer buffer) - (bury-buffer)))))) - -(defun calendar-goto-today () - "Reposition the calendar window so the current date is visible." - (interactive) - (let ((today (calendar-current-date)));; The date might have changed. - (if (not (calendar-date-is-visible-p today)) - (generate-calendar-window) - (update-calendar-mode-line) - (calendar-cursor-to-visible-date today)))) - -(defun calendar-forward-month (arg) - "Move the cursor forward ARG months. -Movement is backward if ARG is negative." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((cursor-date (calendar-cursor-to-date t)) - (month (extract-calendar-month cursor-date)) - (day (extract-calendar-day cursor-date)) - (year (extract-calendar-year cursor-date))) - (increment-calendar-month month year arg) - (let ((last (calendar-last-day-of-month month year))) - (if (< last day) - (setq day last))) - ;; Put the new month on the screen, if needed, and go to the new date. - (let ((new-cursor-date (list month day year))) - (if (not (calendar-date-is-visible-p new-cursor-date)) - (calendar-other-month month year)) - (calendar-cursor-to-visible-date new-cursor-date)))) - -(defun calendar-forward-year (arg) - "Move the cursor forward by ARG years. -Movement is backward if ARG is negative." - (interactive "p") - (calendar-forward-month (* 12 arg))) - -(defun calendar-backward-month (arg) - "Move the cursor backward by ARG months. -Movement is forward if ARG is negative." - (interactive "p") - (calendar-forward-month (- arg))) - -(defun calendar-backward-year (arg) - "Move the cursor backward ARG years. -Movement is forward is ARG is negative." - (interactive "p") - (calendar-forward-month (* -12 arg))) - -(defun scroll-calendar-left (arg) - "Scroll the displayed calendar left by ARG months. -If ARG is negative the calendar is scrolled right. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let ((old-date (calendar-cursor-to-date)) - (today (calendar-current-date))) - (if (/= arg 0) - (progn - (increment-calendar-month displayed-month displayed-year arg) - (generate-calendar-window displayed-month displayed-year) - (calendar-cursor-to-visible-date - (cond - ((calendar-date-is-visible-p old-date) old-date) - ((calendar-date-is-visible-p today) today) - (t (list displayed-month 1 displayed-year)))))))) - -(defun scroll-calendar-right (arg) - "Scroll the displayed calendar window right by ARG months. -If ARG is negative the calendar is scrolled left. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (scroll-calendar-left (- arg))) - -(defun scroll-calendar-left-three-months (arg) - "Scroll the displayed calendar window left by 3*ARG months. -If ARG is negative the calendar is scrolled right. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (scroll-calendar-left (* 3 arg))) - -(defun scroll-calendar-right-three-months (arg) - "Scroll the displayed calendar window right by 3*ARG months. -If ARG is negative the calendar is scrolled left. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (scroll-calendar-left (* -3 arg))) - -(defun calendar-current-date () - "Returns the current date in a list (month day year)." - (let ((s (current-time-string))) - (list (length (member (substring s 4 7) - '("Dec" "Nov" "Oct" "Sep" "Aug" "Jul" - "Jun" "May" "Apr" "Mar" "Feb" "Jan"))) - (string-to-number (substring s 8 10)) - (string-to-number (substring s 20 24))))) - -(defun calendar-cursor-to-date (&optional error) - "Returns a list (month day year) of current cursor position. -If cursor is not on a specific date, signals an error if optional parameter -ERROR is t, otherwise just returns nil." - ;; #### This check is to avoid a race condition created by - ;; pop-to-buffer's call to other-window interacting with the 19.13 - ;; changes allowing that to be in another frame. - (if (not (number-or-marker-p displayed-month)) - nil - (let* ((segment (/ (current-column) 25)) - (month (% (+ displayed-month segment -1) 12)) - (month (if (= 0 month) 12 month)) - (year - (cond - ((and (= 12 month) (= segment 0)) (1- displayed-year)) - ((and (= 1 month) (= segment 2)) (1+ displayed-year)) - (t displayed-year)))) - (if (and (looking-at "[0-9]") - (< 2 (count-lines (point-min) (point)))) - (save-excursion - (re-search-backward "[^0-9]") - (list month - (string-to-int (buffer-substring (1+ (point)) (+ 4 (point)))) - year)) - (if (looking-at "\\*") - (save-excursion - (re-search-backward "[^*]") - (if (looking-at ".\\*\\*") - (list month calendar-starred-day year) - (if error (error "Not on a date!")))) - (if error (error "Not on a date!"))))))) - -(defun calendar-cursor-to-nearest-date () - "Move the cursor to the closest date. -The position of the cursor is unchanged if it is already on a date. -Returns the list (month day year) giving the cursor position." - (let ((date (calendar-cursor-to-date)) - (column (current-column))) - (if date - date - (if (> 3 (count-lines (point-min) (point))) - (progn - (goto-line 3) - (move-to-column column))) - (if (not (looking-at "[0-9]")) - (if (and (not (looking-at " *$")) - (or (< column 25) - (and (> column 27) - (< column 50)) - (and (> column 52) - (< column 75)))) - (progn - (re-search-forward "[0-9]" nil t) - (backward-char 1)) - (re-search-backward "[0-9]" nil t))) - (calendar-cursor-to-date)))) - -(defun calendar-forward-day (arg) - "Move the cursor forward ARG days. -Moves backward if ARG is negative." - (interactive "p") - (if (/= 0 arg) - (let* - ((cursor-date (calendar-cursor-to-date)) - (cursor-date (if cursor-date - cursor-date - (if (> arg 0) (setq arg (1- arg))) - (calendar-cursor-to-nearest-date))) - (new-cursor-date - (calendar-gregorian-from-absolute - (+ (calendar-absolute-from-gregorian cursor-date) arg))) - (new-display-month (extract-calendar-month new-cursor-date)) - (new-display-year (extract-calendar-year new-cursor-date))) - ;; Put the new month on the screen, if needed, and go to the new date. - (if (not (calendar-date-is-visible-p new-cursor-date)) - (calendar-other-month new-display-month new-display-year)) - (calendar-cursor-to-visible-date new-cursor-date)))) - -(defun calendar-backward-day (arg) - "Move the cursor back ARG days. -Moves forward if ARG is negative." - (interactive "p") - (calendar-forward-day (- arg))) - -(defun calendar-forward-week (arg) - "Move the cursor forward ARG weeks. -Moves backward if ARG is negative." - (interactive "p") - (calendar-forward-day (* arg 7))) - -(defun calendar-backward-week (arg) - "Move the cursor back ARG weeks. -Moves forward if ARG is negative." - (interactive "p") - (calendar-forward-day (* arg -7))) - -(defun calendar-beginning-of-week (arg) - "Move the cursor back ARG calendar-week-start-day's." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) - (calendar-backward-day - (if (= day calendar-week-start-day) - (* 7 arg) - (+ (mod (- day calendar-week-start-day) 7) - (* 7 (1- arg))))))) - -(defun calendar-end-of-week (arg) - "Move the cursor forward ARG calendar-week-start-day+6's." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) - (calendar-forward-day - (if (= day (mod (1- calendar-week-start-day) 7)) - (* 7 arg) - (+ (- 6 (mod (- day calendar-week-start-day) 7)) - (* 7 (1- arg))))))) - -(defun calendar-beginning-of-month (arg) - "Move the cursor backward ARG month beginnings." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (if (= day 1) - (calendar-backward-month arg) - (calendar-cursor-to-visible-date (list month 1 year)) - (calendar-backward-month (1- arg))))) - -(defun calendar-end-of-month (arg) - "Move the cursor forward ARG month ends." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (last-day (calendar-last-day-of-month month year))) - (if (/= day last-day) - (progn - (calendar-cursor-to-visible-date (list month last-day year)) - (setq arg (1- arg)))) - (increment-calendar-month month year arg) - (let ((last-day (list - month - (calendar-last-day-of-month month year) - year))) - (if (not (calendar-date-is-visible-p last-day)) - (calendar-other-month month year) - (calendar-cursor-to-visible-date last-day))))) - -(defun calendar-beginning-of-year (arg) - "Move the cursor backward ARG year beginnings." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (jan-first (list 1 1 year))) - (if (and (= day 1) (= 1 month)) - (calendar-backward-month (* 12 arg)) - (if (and (= arg 1) - (calendar-date-is-visible-p jan-first)) - (calendar-cursor-to-visible-date jan-first) - (calendar-other-month 1 (- year (1- arg))))))) - -(defun calendar-end-of-year (arg) - "Move the cursor forward ARG year beginnings." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (dec-31 (list 12 31 year))) - (if (and (= day 31) (= 12 month)) - (calendar-forward-month (* 12 arg)) - (if (and (= arg 1) - (calendar-date-is-visible-p dec-31)) - (calendar-cursor-to-visible-date dec-31) - (calendar-other-month 12 (- year (1- arg))) - (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))) - -;; The following version of calendar-gregorian-from-absolute is preferred for -;; reasons of clarity, BUT it's much slower than the version that follows it. - -;;(defun calendar-gregorian-from-absolute (date) -;; "Compute the list (month day year) corresponding to the absolute DATE. -;;The absolute date is the number of days elapsed since the (imaginary) -;;Gregorian date Sunday, December 31, 1 BC." -;; (let* ((approx (/ date 366));; Approximation from below. -;; (year ;; Search forward from the approximation. -;; (+ approx -;; (calendar-sum y approx -;; (>= date (calendar-absolute-from-gregorian (list 1 1 (1+ y)))) -;; 1))) -;; (month ;; Search forward from January. -;; (1+ (calendar-sum m 1 -;; (> date -;; (calendar-absolute-from-gregorian -;; (list m (calendar-last-day-of-month m year) year))) -;; 1))) -;; (day ;; Calculate the day by subtraction. -;; (- date -;; (1- (calendar-absolute-from-gregorian (list month 1 year)))))) -;; (list month day year))) - -(defun calendar-gregorian-from-absolute (date) - "Compute the list (month day year) corresponding to the absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." -;; See the footnote on page 384 of ``Calendrical Calculations, Part II: -;; Three Historical Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. -;; Clamen, Software--Practice and Experience, Volume 23, Number 4 -;; (April, 1993), pages 383-404 for an explanation. - (let* ((d0 (1- date)) - (n400 (/ d0 146097)) - (d1 (% d0 146097)) - (n100 (/ d1 36524)) - (d2 (% d1 36524)) - (n4 (/ d2 1461)) - (d3 (% d2 1461)) - (n1 (/ d3 365)) - (day (1+ (% d3 365))) - (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1))) - (if (or (= n100 4) (= n1 4)) - (list 12 31 year) - (let ((year (1+ year)) - (month 1)) - (while (let ((mdays (calendar-last-day-of-month month year))) - (and (< mdays day) - (setq day (- day mdays)))) - (setq month (1+ month))) - (list month day year))))) - -(defun calendar-cursor-to-visible-date (date) - "Move the cursor to DATE that is on the screen." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (first-of-month-weekday (calendar-day-of-week (list month 1 year)))) - (goto-line (+ 3 - (/ (+ day -1 - (mod - (- (calendar-day-of-week (list month 1 year)) - calendar-week-start-day) - 7)) - 7))) - (move-to-column (+ 6 - (* 25 - (1+ (calendar-interval - displayed-month displayed-year month year))) - (* 3 (mod - (- (calendar-day-of-week date) - calendar-week-start-day) - 7)))))) - -(defun calendar-other-month (month year) - "Display a three-month calendar centered around MONTH and YEAR." - (interactive (calendar-read-date 'noday)) - (if (and (= month displayed-month) - (= year displayed-year)) - nil - (let ((old-date (calendar-cursor-to-date)) - (today (calendar-current-date))) - (generate-calendar-window month year) - (calendar-cursor-to-visible-date - (cond - ((calendar-date-is-visible-p old-date) old-date) - ((calendar-date-is-visible-p today) today) - (t (list month 1 year))))))) - -(defun calendar-set-mark (arg) - "Mark the date under the cursor, or jump to marked date. -With no prefix argument, push current date onto marked date ring. -With argument, jump to mark, pop it, and put point at end of ring." - (interactive "P") - (let ((date (calendar-cursor-to-date t))) - (if (null arg) - (progn - (setq calendar-mark-ring (cons date calendar-mark-ring)) - ;; Since the top of the mark ring is the marked date in the - ;; calendar, the mark ring in the calendar is one longer than - ;; in other buffers to get the same effect. - (if (> (length calendar-mark-ring) (1+ mark-ring-max)) - (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil)) - (message "Mark set")) - (if (null calendar-mark-ring) - (error "No mark set in this buffer") - (calendar-goto-date (car calendar-mark-ring)) - (setq calendar-mark-ring - (cdr (nconc calendar-mark-ring (list date)))))))) - -(defun calendar-exchange-point-and-mark () - "Exchange the current cursor position with the marked date." - (interactive) - (let ((mark (car calendar-mark-ring)) - (date (calendar-cursor-to-date t))) - (if (null mark) - (error "No mark set in this buffer") - (setq calendar-mark-ring (cons date (cdr calendar-mark-ring))) - (calendar-goto-date mark)))) - -(defun calendar-count-days-region () - "Count the number of days (inclusive) between point and the mark." - (interactive) - (let* ((days (- (calendar-absolute-from-gregorian - (calendar-cursor-to-date t)) - (calendar-absolute-from-gregorian - (or (car calendar-mark-ring) - (error "No mark set in this buffer"))))) - (days (1+ (if (> days 0) days (- days))))) - (message "Region has %d day%s (inclusive)" - days (if (> days 1) "s" "")))) - -(defun calendar-not-implemented () - "Not implemented." - (interactive) - (error "%s not available in the calendar" - (global-key-binding (this-command-keys)))) - -(defun calendar-read (prompt acceptable &optional initial-contents) - "Return an object read from the minibuffer. -Prompt with the string PROMPT and use the function ACCEPTABLE to decide if -entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS -is a string to insert in the minibuffer before reading." - (let ((value (read-minibuffer prompt initial-contents))) - (while (not (funcall acceptable value)) - (setq value (read-minibuffer prompt initial-contents))) - value)) - -(defun calendar-read-date (&optional noday) - "Prompt for Gregorian date. Returns a list (month day year). -If optional NODAY is t, does not ask for day, but just returns -(month nil year); if NODAY is any other non-nil value the value returned is -(month year) " - (let* ((year (calendar-read - "Year (>0): " - '(lambda (x) (> x 0)) - (int-to-string (extract-calendar-year - (calendar-current-date))))) - (month-array calendar-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Month name: " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last (calendar-last-day-of-month month year))) - (if noday - (if (eq noday t) - (list month nil year) - (list month year)) - (list month - (calendar-read (format "Day (1-%d): " last) - '(lambda (x) (and (< 0 x) (<= x last)))) - year)))) - -(defun calendar-goto-date (date) - "Move cursor to DATE." - (interactive (list (calendar-read-date))) - (let ((month (extract-calendar-month date)) - (year (extract-calendar-year date))) - (if (not (calendar-date-is-visible-p date)) - (calendar-other-month - (if (and (= month 1) (= year 1)) - 2 - month) - year))) - (calendar-cursor-to-visible-date date)) - -(defun calendar-goto-julian-date (date &optional noecho) - "Move cursor to Julian DATE; echo Julian date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "Julian calendar year (>0): " - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - today)))))) - (month-array calendar-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Julian calendar month name: " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last - (if (and (zerop (% year 4)) (= month 2)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - (day (calendar-read - (format "Julian calendar day (%d-%d): " - (if (and (= year 1) (= month 1)) 3 1) last) - '(lambda (x) - (and (< (if (and (= year 1) (= month 1)) 2 0) x) - (<= x last)))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-julian date))) - (or noecho (calendar-print-julian-date))) - -(defun calendar-goto-hebrew-date (date &optional noecho) - "Move cursor to Hebrew DATE; echo Hebrew date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "Hebrew calendar year (>3760): " - '(lambda (x) (> x 3760)) - (int-to-string - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian today)))))) - (month-array (if (hebrew-calendar-leap-year-p year) - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year)) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Hebrew calendar month name: " - (mapcar 'list (append month-array nil)) - (if (= year 3761) - '(lambda (x) - (let ((m (cdr - (assoc - (car x) - (calendar-make-alist - month-array))))) - (< 0 - (calendar-absolute-from-hebrew - (list m - (hebrew-calendar-last-day-of-month - m year) - year)))))) - - t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last (hebrew-calendar-last-day-of-month month year)) - (first (if (and (= year 3761) (= month 10)) - 18 1)) - (day (calendar-read - (format "Hebrew calendar day (%d-%d): " - first last) - '(lambda (x) (and (<= first x) (<= x last)))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew date))) - (or noecho (calendar-print-hebrew-date))) - -(defun calendar-goto-islamic-date (date &optional noecho) - "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "Islamic calendar year (>0): " - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian today)))))) - (month-array calendar-islamic-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Islamic calendar month name: " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last (islamic-calendar-last-day-of-month month year)) - (day (calendar-read - (format "Islamic calendar day (1-%d): " last) - '(lambda (x) (and (< 0 x) (<= x last)))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic date))) - (or noecho (calendar-print-islamic-date))) - -(defun calendar-goto-iso-date (date &optional noecho) - "Move cursor to ISO DATE; echo ISO date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "ISO calendar year (>0): " - '(lambda (x) (> x 0)) - (int-to-string (extract-calendar-year today)))) - (no-weeks (extract-calendar-month - (calendar-iso-from-absolute - (1- - (calendar-dayname-on-or-before - 1 (calendar-absolute-from-gregorian - (list 1 4 (1+ year)))))))) - (week (calendar-read - (format "ISO calendar week (1-%d): " no-weeks) - '(lambda (x) (and (> x 0) (<= x no-weeks))))) - (day (calendar-read - "ISO day (1-7): " - '(lambda (x) (and (<= 1 x) (<= x 7)))))) - (list (list week day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-iso date))) - (or noecho (calendar-print-iso-date))) - -(defun calendar-interval (mon1 yr1 mon2 yr2) - "The number of months difference between MON1, YR1 and MON2, YR2." - (+ (* 12 (- yr2 yr1)) - (- mon2 mon1))) - -(defun calendar-day-name (date) - "Returns a string with the name of the day of the week of DATE." - (aref calendar-day-name-array (calendar-day-of-week date))) - -(defvar calendar-day-name-array - ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]) - -(defvar calendar-month-name-array - ["January" "February" "March" "April" "May" "June" - "July" "August" "September" "October" "November" "December"]) - -(defun calendar-make-alist (sequence &optional start-index filter) - "Make an assoc list corresponding to SEQUENCE. -Start at index 1, unless optional START-INDEX is provided. -If FILTER is provided, apply it to each item in the list." - (let ((index (if start-index (1- start-index) 0))) - (mapcar - '(lambda (x) - (setq index (1+ index)) - (cons (if filter (funcall filter x) x) - index)) - (append sequence nil)))) - -(defun calendar-month-name (month) - "The name of MONTH." - (aref calendar-month-name-array (1- month))) - -(defun calendar-day-of-week (date) - "Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc." - (% (calendar-absolute-from-gregorian date) 7)) - -(defun calendar-unmark () - "Delete all diary/holiday marks/highlighting from the calendar." - (interactive) - (setq mark-holidays-in-calendar nil) - (setq mark-diary-entries-in-calendar nil) - (redraw-calendar)) - -(defun calendar-date-is-visible-p (date) - "Returns t if DATE is legal and is visible in the calendar window." - (let ((gap (calendar-interval - displayed-month displayed-year - (extract-calendar-month date) (extract-calendar-year date)))) - (and (calendar-date-is-legal-p date) (> 2 gap) (< -2 gap)))) - -(defun calendar-date-is-legal-p (date) - "Returns t if DATE is a legal date." - (let ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (and (<= 1 month) (<= month 12) - (<= 1 day) (<= day (calendar-last-day-of-month month year)) - (<= 1 year)))) - -(defun calendar-date-equal (date1 date2) - "Returns t if the DATE1 and DATE2 are the same." - (and - (= (extract-calendar-month date1) (extract-calendar-month date2)) - (= (extract-calendar-day date1) (extract-calendar-day date2)) - (= (extract-calendar-year date1) (extract-calendar-year date2)))) - -(defun mark-visible-calendar-date (date &optional mark) - "Mark DATE in the calendar window with MARK. -MARK is either a single-character string or a face. -MARK defaults to diary-entry-marker." - (if (calendar-date-is-legal-p date) - (save-excursion - (set-buffer calendar-buffer) - (calendar-cursor-to-visible-date date) - (let ((mark (or mark diary-entry-marker))) - (if (stringp mark) - (let ((buffer-read-only nil)) - (forward-char 1) - (delete-char 1) - (insert mark) - (forward-char -2)) - - (set-extent-property (make-extent (1- (point)) (1+ (point))) - 'face mark)))))) - -(defun calendar-star-date () - "Replace the date under the cursor in the calendar window with asterisks. -This function can be used with the today-visible-calendar-hook run after the -calendar window has been prepared." - (let ((buffer-read-only nil)) - (make-variable-buffer-local 'calendar-starred-day) - (forward-char 1) - (setq calendar-starred-day - (string-to-int - (buffer-substring (point) (- (point) 2)))) - (delete-char -2) - (insert "**") - (backward-char 1) - (set-buffer-modified-p nil))) - -(defun calendar-mark-today () - "Mark the date under the cursor in the calendar window. -The date is marked with calendar-today-marker. This function can be used with -the today-visible-calendar-hook run after the calendar window has been -prepared." - (mark-visible-calendar-date - (calendar-cursor-to-date) - calendar-today-marker)) - -(defun calendar-date-compare (date1 date2) - "Returns t if DATE1 is before DATE2, nil otherwise. -The actual dates are in the car of DATE1 and DATE2." - (< (calendar-absolute-from-gregorian (car date1)) - (calendar-absolute-from-gregorian (car date2)))) - -(defun calendar-date-string (date &optional abbreviate nodayname) - "A string form of DATE, driven by the variable `calendar-date-display-form'. -An optional parameter ABBREVIATE, when t, causes the month and day names to be -abbreviated to three characters. An optional parameter NODAYNAME, when t, -omits the name of the day of the week." - (let* ((dayname - (if nodayname - nil - (if abbreviate - (substring (calendar-day-name date) 0 3) - (calendar-day-name date)))) - (month (extract-calendar-month date)) - (monthname - (if abbreviate - (substring - (calendar-month-name month) 0 3) - (calendar-month-name month))) - (day (int-to-string (extract-calendar-day date))) - (month (int-to-string month)) - (year (int-to-string (extract-calendar-year date)))) - (mapconcat 'eval calendar-date-display-form ""))) - -(defun calendar-dayname-on-or-before (dayname date) - "Returns the absolute date of the DAYNAME on or before absolute DATE. -DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on. - -Note: Applying this function to d+6 gives us the DAYNAME on or after an -absolute day d. Similarly, applying it to d+3 gives the DAYNAME nearest to -absolute date d, applying it to d-1 gives the DAYNAME previous to absolute -date d, and applying it to d+7 gives the DAYNAME following absolute date d." - (- date (% (- date dayname) 7))) - -(defun calendar-nth-named-absday (n dayname month year &optional day) - "The absolute date of Nth DAYNAME in MONTH, YEAR before/after optional DAY. -A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0, -return the Nth DAYNAME before MONTH DAY, YEAR (inclusive). -If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive). - -If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise." - (if (> n 0) - (+ (* 7 (1- n)) - (calendar-dayname-on-or-before - dayname - (+ 6 (calendar-absolute-from-gregorian - (list month (or day 1) year))))) - (+ (* 7 (1+ n)) - (calendar-dayname-on-or-before - dayname - (calendar-absolute-from-gregorian - (list month - (or day (calendar-last-day-of-month month year)) - year)))))) - -(defun calendar-nth-named-day (n dayname month year &optional day) - "The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY. -A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0, -return the Nth DAYNAME before MONTH DAY, YEAR (inclusive). -If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive). - -If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise." - (calendar-gregorian-from-absolute - (calendar-nth-named-absday n dayname month year day))) - -(defun calendar-day-of-year-string (&optional date) - "String of day number of year of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((d (or date (calendar-current-date))) - (year (extract-calendar-year d)) - (day (calendar-day-number d)) - (days-remaining (- (calendar-day-number (list 12 31 year)) day))) - (format "Day %d of %d; %d day%s remaining in the year" - day year days-remaining (if (= days-remaining 1) "" "s")))) - -(defun calendar-print-day-of-year () - "Show day number in year/days remaining in year for date under the cursor." - (interactive) - (message (calendar-day-of-year-string (calendar-cursor-to-date t)))) - -(defun calendar-absolute-from-iso (date) - "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. -The `ISO year' corresponds approximately to the Gregorian year, but -weeks start on Monday and end on Sunday. The first week of the ISO year is -the first such week in which at least 4 days are in a year. The ISO -commercial DATE has the form (week day year) in which week is in the range -1..52 and day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = -Sunday). The Gregorian date Sunday, December 31, 1 BC is imaginary." - (let* ((week (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ (calendar-dayname-on-or-before - 1 (+ 3 (calendar-absolute-from-gregorian (list 1 1 year)))) - (* 7 (1- week)) - (if (= day 0) 6 (1- day))))) - -(defun calendar-iso-from-absolute (date) - "Compute the `ISO commercial date' corresponding to the absolute DATE. -The ISO year corresponds approximately to the Gregorian year, but weeks -start on Monday and end on Sunday. The first week of the ISO year is the -first such week in which at least 4 days are in a year. The ISO commercial -date has the form (week day year) in which week is in the range 1..52 and -day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = Sunday). The -absolute date is the number of days elapsed since the (imaginary) Gregorian -date Sunday, December 31, 1 BC." - (let* ((approx (extract-calendar-year - (calendar-gregorian-from-absolute (- date 3)))) - (year (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-iso (list 1 1 (1+ y)))) - 1)))) - (list - (1+ (/ (- date (calendar-absolute-from-iso (list 1 1 year))) 7)) - (% date 7) - year))) - -(defun calendar-iso-date-string (&optional date) - "String of ISO date of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((d (calendar-absolute-from-gregorian - (or date (calendar-current-date)))) - (day (% d 7)) - (iso-date (calendar-iso-from-absolute d))) - (format "Day %s of week %d of %d" - (if (zerop day) 7 day) - (extract-calendar-month iso-date) - (extract-calendar-year iso-date)))) - -(defun calendar-print-iso-date () - "Show equivalent ISO date for the date under the cursor." - (interactive) - (message "ISO date: %s" - (calendar-iso-date-string (calendar-cursor-to-date t)))) - -(defun calendar-julian-from-absolute (date) - "Compute the Julian (month day year) corresponding to the absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((approx (/ (+ date 2) 366));; Approximation from below. - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-julian (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from January. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-julian - (list m - (if (and (= m 2) (= (% year 4) 0)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] - (1- m))) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date (1- (calendar-absolute-from-julian (list month 1 year)))))) - (list month day year))) - -(defun calendar-absolute-from-julian (date) - "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. -The Gregorian date Sunday, December 31, 1 BC is imaginary." - (let ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ (calendar-day-number date) - (if (and (= (% year 100) 0) - (/= (% year 400) 0) - (> month 2)) - 1 0);; Correct for Julian but not Gregorian leap year. - (* 365 (1- year)) - (/ (1- year) 4) - -2))) - -(defun calendar-julian-date-string (&optional date) - "String of Julian date of Gregorian DATE. -Defaults to today's date if DATE is not given. -Driven by the variable `calendar-date-display-form'." - (calendar-date-string - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date)))) - nil t)) - -(defun calendar-print-julian-date () - "Show the Julian calendar equivalent of the date under the cursor." - (interactive) - (message "Julian date: %s" - (calendar-julian-date-string (calendar-cursor-to-date t)))) - -(defun islamic-calendar-leap-year-p (year) - "Returns t if YEAR is a leap year on the Islamic calendar." - (memq (% year 30) - (list 2 5 7 10 13 16 18 21 24 26 29))) - -(defun islamic-calendar-last-day-of-month (month year) - "The last day in MONTH during YEAR on the Islamic calendar." - (cond - ((memq month (list 1 3 5 7 9 11)) 30) - ((memq month (list 2 4 6 8 10)) 29) - (t (if (islamic-calendar-leap-year-p year) 30 29)))) - -(defun islamic-calendar-day-number (date) - "Return the day number within the year of the Islamic date DATE." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date))) - (+ (* 30 (/ month 2)) - (* 29 (/ (1- month) 2)) - day))) - -(defun calendar-absolute-from-islamic (date) - "Absolute date of Islamic DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (y (% year 30)) - (leap-years-in-cycle - (cond - ((< y 3) 0) ((< y 6) 1) ((< y 8) 2) ((< y 11) 3) ((< y 14) 4) - ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9) - (t 10)))) - (+ (islamic-calendar-day-number date);; days so far this year - (* (1- year) 354) ;; days in all non-leap years - (* 11 (/ year 30)) ;; leap days in complete cycles - leap-years-in-cycle ;; leap days this cycle - 227014))) ;; days before start of calendar - -(defun calendar-islamic-from-absolute (date) - "Compute the Islamic date (month day year) corresponding to absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (if (< date 227015) - (list 0 0 0);; pre-Islamic date - (let* ((approx (/ (- date 227014) 355));; Approximation from below. - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-islamic - (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from Muharram. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-islamic - (list m - (islamic-calendar-last-day-of-month - m year) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date - (1- (calendar-absolute-from-islamic (list month 1 year)))))) - (list month day year)))) - -(defvar calendar-islamic-month-name-array - ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II" - "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"]) - -(defun calendar-islamic-date-string (&optional date) - "String of Islamic date before sunset of Gregorian DATE. -Returns the empty string if DATE is pre-Islamic. -Defaults to today's date if DATE is not given. -Driven by the variable `calendar-date-display-form'." - (let ((calendar-month-name-array calendar-islamic-month-name-array) - (islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date)))))) - (if (< (extract-calendar-year islamic-date) 1) - "" - (calendar-date-string islamic-date nil t)))) - -(defun calendar-print-islamic-date () - "Show the Islamic calendar equivalent of the date under the cursor." - (interactive) - (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) - (if (string-equal i "") - (message "Date is pre-Islamic") - (message "Islamic date (until sunset): %s" i)))) - -(defun calendar-hebrew-from-absolute (date) - "Compute the Hebrew date (month day year) corresponding to absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((greg-date (calendar-gregorian-from-absolute date)) - (month (aref [9 10 11 12 1 2 3 4 7 7 7 8] - (1- (extract-calendar-month greg-date)))) - (day) - (year (+ 3760 (extract-calendar-year greg-date)))) - (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year)))) - (setq year (1+ year))) - (let ((length (hebrew-calendar-last-month-of-year year))) - (while (> date - (calendar-absolute-from-hebrew - (list month - (hebrew-calendar-last-day-of-month month year) - year))) - (setq month (1+ (% month length))))) - (setq day (1+ - (- date (calendar-absolute-from-hebrew (list month 1 year))))) - (list month day year))) - -(defun hebrew-calendar-leap-year-p (year) - "t if YEAR is a Hebrew calendar leap year." - (< (% (1+ (* 7 year)) 19) 7)) - -(defun hebrew-calendar-last-month-of-year (year) - "The last month of the Hebrew calendar YEAR." - (if (hebrew-calendar-leap-year-p year) - 13 - 12)) - -(defun hebrew-calendar-last-day-of-month (month year) - "The last day of MONTH in YEAR." - (if (or (memq month (list 2 4 6 10 13)) - (and (= month 12) (not (hebrew-calendar-leap-year-p year))) - (and (= month 8) (not (hebrew-calendar-long-heshvan-p year))) - (and (= month 9) (hebrew-calendar-short-kislev-p year))) - 29 - 30)) - -(defun hebrew-calendar-elapsed-days (year) - "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR." - (let* ((months-elapsed - (+ (* 235 (/ (1- year) 19));; Months in complete cycles so far. - (* 12 (% (1- year) 19)) ;; Regular months in this cycle - (/ (1+ (* 7 (% (1- year) 19))) 19)));; Leap months this cycle - (parts-elapsed (+ 204 (* 793 (% months-elapsed 1080)))) - (hours-elapsed (+ 5 - (* 12 months-elapsed) - (* 793 (/ months-elapsed 1080)) - (/ parts-elapsed 1080))) - (parts ;; Conjunction parts - (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080))) - (day ;; Conjunction day - (+ 1 (* 29 months-elapsed) (/ hours-elapsed 24))) - (alternative-day - (if (or (>= parts 19440) ;; If the new moon is at or after midday, - (and (= (% day 7) 2);; ...or is on a Tuesday... - (>= parts 9924) ;; at 9 hours, 204 parts or later... - (not (hebrew-calendar-leap-year-p year)));; of a - ;; common year, - (and (= (% day 7) 1);; ...or is on a Monday... - (>= parts 16789) ;; at 15 hours, 589 parts or later... - (hebrew-calendar-leap-year-p (1- year))));; at the end - ;; of a leap year - ;; Then postpone Rosh HaShanah one day - (1+ day) - ;; Else - day))) - (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday - (memq (% alternative-day 7) (list 0 3 5)) - ;; Then postpone it one (more) day and return - (1+ alternative-day) - ;; Else return - alternative-day))) - -(defun hebrew-calendar-days-in-year (year) - "Number of days in Hebrew YEAR." - (- (hebrew-calendar-elapsed-days (1+ year)) - (hebrew-calendar-elapsed-days year))) - -(defun hebrew-calendar-long-heshvan-p (year) - "t if Heshvan is long in Hebrew YEAR." - (= (% (hebrew-calendar-days-in-year year) 10) 5)) - -(defun hebrew-calendar-short-kislev-p (year) - "t if Kislev is short in Hebrew YEAR." - (= (% (hebrew-calendar-days-in-year year) 10) 3)) - -(defun calendar-absolute-from-hebrew (date) - "Absolute date of Hebrew DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ day ;; Days so far this month. - (if (< month 7);; before Tishri - ;; Then add days in prior months this year before and after Nisan - (+ (calendar-sum - m 7 (<= m (hebrew-calendar-last-month-of-year year)) - (hebrew-calendar-last-day-of-month m year)) - (calendar-sum - m 1 (< m month) - (hebrew-calendar-last-day-of-month m year))) - ;; Else add days in prior months this year - (calendar-sum - m 7 (< m month) - (hebrew-calendar-last-day-of-month m year))) - (hebrew-calendar-elapsed-days year);; Days in prior years. - -1373429))) ;; Days elapsed before absolute date 1. - -(defvar calendar-hebrew-month-name-array-common-year - ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" - "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]) - -(defvar calendar-hebrew-month-name-array-leap-year - ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" - "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]) - -(defun calendar-hebrew-date-string (&optional date) - "String of Hebrew date before sunset of Gregorian DATE. -Defaults to today's date if DATE is not given. -Driven by the variable `calendar-date-display-form'." - (let* ((hebrew-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))) - (calendar-month-name-array - (if (hebrew-calendar-leap-year-p (extract-calendar-year hebrew-date)) - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year))) - (calendar-date-string hebrew-date nil t))) - -(defun calendar-print-hebrew-date () - "Show the Hebrew calendar equivalent of the date under the cursor." - (interactive) - (message "Hebrew date (until sunset): %s" - (calendar-hebrew-date-string (calendar-cursor-to-date t)))) - -(defun hebrew-calendar-yahrzeit (death-date year) - "Absolute date of the anniversary of Hebrew DEATH-DATE in Hebrew YEAR." - (let* ((death-day (extract-calendar-day death-date)) - (death-month (extract-calendar-month death-date)) - (death-year (extract-calendar-year death-date))) - (cond - ;; If it's Heshvan 30 it depends on the first anniversary; if - ;; that was not Heshvan 30, use the day before Kislev 1. - ((and (= death-month 8) - (= death-day 30) - (not (hebrew-calendar-long-heshvan-p (1+ death-year)))) - (1- (calendar-absolute-from-hebrew (list 9 1 year)))) - ;; If it's Kislev 30 it depends on the first anniversary; if - ;; that was not Kislev 30, use the day before Teveth 1. - ((and (= death-month 9) - (= death-day 30) - (hebrew-calendar-short-kislev-p (1+ death-year))) - (1- (calendar-absolute-from-hebrew (list 10 1 year)))) - ;; If it's Adar II, use the same day in last month of - ;; year (Adar or Adar II). - ((= death-month 13) - (calendar-absolute-from-hebrew - (list (hebrew-calendar-last-month-of-year year) death-day year))) - ;; If it's the 30th in Adar I and year is not a leap year - ;; (so Adar has only 29 days), use the last day in Shevat. - ((and (= death-day 30) - (= death-month 12) - (not (hebrew-calendar-leap-year-p year))) - (calendar-absolute-from-hebrew (list 11 30 year))) - ;; In all other cases, use the normal anniversary of the date of death. - (t (calendar-absolute-from-hebrew - (list death-month death-day year)))))) - -(defun calendar-set-mode-line (str) - "Set mode line to STR, centered, surrounded by dashes." - (setq mode-line-format - (calendar-string-spread (list "" str "") ?- (frame-width)))) - -;;;###autoload -(defun list-yahrzeit-dates (death-date start-year end-year) - "List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR. -When called interactively from the calendar window, the date of death is taken -from the cursor position." - (interactive - (let* ((death-date - (if (equal (current-buffer) (get-buffer calendar-buffer)) - (calendar-cursor-to-date) - (let* ((today (calendar-current-date)) - (year (calendar-read - "Year of death (>0): " - '(lambda (x) (> x 0)) - (int-to-string (extract-calendar-year today)))) - (month-array calendar-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Month of death (name): " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist - month-array 1 'capitalize)))) - (last (calendar-last-day-of-month month year)) - (day (calendar-read - (format "Day of death (1-%d): " last) - '(lambda (x) (and (< 0 x) (<= x last)))))) - (list month day year)))) - (death-year (extract-calendar-year death-date)) - (start-year (calendar-read - (format "Starting year of Yahrzeit table (>%d): " - death-year) - '(lambda (x) (> x death-year)) - (int-to-string (1+ death-year)))) - (end-year (calendar-read - (format "Ending year of Yahrzeit table (>=%d): " - start-year) - '(lambda (x) (>= x start-year))))) - (list death-date start-year end-year))) - (message "Computing yahrzeits...") - (let* ((yahrzeit-buffer "*Yahrzeits*") - (h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian death-date))) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (set-buffer (get-buffer-create yahrzeit-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line - (format "Yahrzeit dates for %s = %s" - (calendar-date-string death-date) - (let ((calendar-month-name-array - (if (hebrew-calendar-leap-year-p h-year) - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year))) - (calendar-date-string h-date nil t)))) - (erase-buffer) - (goto-char (point-min)) - (calendar-for-loop i from start-year to end-year do - (insert - (calendar-date-string - (calendar-gregorian-from-absolute - (hebrew-calendar-yahrzeit - h-date - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian (list 1 1 i))))))) "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer yahrzeit-buffer) - (message "Computing yahrzeits...done"))) - -(defun calendar-astro-date-string (&optional date) - "String of astronomical (Julian) day number of afternoon of Gregorian DATE. -Defaults to today's date if DATE is not given." - (int-to-string - (+ 1721425 (calendar-absolute-from-gregorian - (or date (calendar-current-date)))))) - -(defun calendar-print-astro-day-number () - "Show astronomical (Julian) day number of afternoon on date shown by cursor." - (interactive) - (message - "Astronomical (Julian) day number after noon UTC: %s" - (calendar-astro-date-string (calendar-cursor-to-date t)))) - -(defun calendar-goto-astro-day-number (daynumber &optional noecho) - "Move cursor to astronomical (Julian) DAYNUMBER. -Echo astronomical (Julian) day number unless NOECHO is t." - (interactive (list (calendar-read - "Astronomical (Julian) day number (>1721425): " - '(lambda (x) (> x 1721425))))) - (calendar-goto-date (calendar-gregorian-from-absolute (- daynumber 1721425))) - (or noecho (calendar-print-astro-day-number))) - -(run-hooks 'calendar-load-hook) - -(provide 'calendar) - -;;; calendar.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/custom-load.el --- a/lisp/calendar/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sat Sep 27 08:13:36 1997 - -;;; Code: - -(custom-put 'holidays 'custom-loads '("calendar")) -(custom-put 'calendar 'custom-loads '("calendar")) -(custom-put 'local 'custom-loads '("calendar")) -(custom-put 'diary 'custom-loads '("calendar")) -(custom-put 'appt 'custom-loads '("appt")) - -;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/diary-ins.el --- a/lisp/calendar/diary-ins.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,251 +0,0 @@ -;;; diary-ins.el --- calendar functions for adding diary entries. - -;; Copyright (C) 1990, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; Keywords: diary, calendar - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the diary insertion features as -;; described in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'diary-lib) - -(defun make-diary-entry (string &optional nonmarking file) - "Insert a diary entry STRING which may be NONMARKING in FILE. -If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." - (find-file-other-window - (substitute-in-file-name (if file file diary-file))) - (goto-char (point-max)) - (insert - (if (bolp) "" "\n") - (if nonmarking diary-nonmarking-symbol "") - string " ")) - -(defun insert-diary-entry (arg) - "Insert a diary entry for the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t) - arg)) - -(defun insert-weekly-diary-entry (arg) - "Insert a weekly diary entry for the day of the week indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-day-name (calendar-cursor-to-date t)) - arg)) - -(defun insert-monthly-diary-entry (arg) - "Insert a monthly diary entry for the day of the month indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " * ") - '("* " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-yearly-diary-entry (arg) - "Insert an annual diary entry for the day of the year indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-anniversary-diary-entry (arg) - "Insert an anniversary diary entry for the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-anniversary %s)" - sexp-diary-entry-symbol - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-block-diary-entry (arg) - "Insert a block diary entry for the days between the point and marked date. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year))) - (cursor (calendar-cursor-to-date t)) - (mark (or (car calendar-mark-ring) - (error "No mark set in this buffer"))) - (start) - (end)) - (if (< (calendar-absolute-from-gregorian mark) - (calendar-absolute-from-gregorian cursor)) - (setq start mark - end cursor) - (setq start cursor - end mark)) - (make-diary-entry - (format "%s(diary-block %s %s)" - sexp-diary-entry-symbol - (calendar-date-string start nil t) - (calendar-date-string end nil t)) - arg))) - -(defun insert-cyclic-diary-entry (arg) - "Insert a cyclic diary entry starting at the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-cyclic %d %s)" - sexp-diary-entry-symbol - (calendar-read "Repeat every how many days: " - '(lambda (x) (> x 0))) - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-hebrew-diary-entry (arg) - "Insert a diary entry. -For the Hebrew date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-hebrew-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Hebrew month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-hebrew-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Hebrew year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-islamic-diary-entry (arg) - "Insert a diary entry. -For the Islamic date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-islamic-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Islamic month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-islamic-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Islamic year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(provide 'diary-ins) - -;;; diary-ins.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/diary-lib.el --- a/lisp/calendar/diary-lib.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1938 +0,0 @@ -;;; diary-lib.el --- diary functions. - -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; Keywords: calendar - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the diary features as described -;; in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -;;;###autoload -(defun diary (&optional arg) - "Generate the diary window for ARG days starting with the current date. -If no argument is provided, the number of days of diary entries is governed -by the variable `number-of-diary-entries'. This function is suitable for -execution in a `.emacs' file." - (interactive "P") - (let ((d-file (substitute-in-file-name diary-file)) - (date (calendar-current-date))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries - date - (cond - (arg (prefix-numeric-value arg)) - ((vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date))) - (t number-of-diary-entries))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-diary-entries (arg) - "Prepare and display a buffer with diary entries. -Searches the file named in `diary-file' for entries that -match ARG days starting with the date indicated by the cursor position -in the displayed three-month calendar." - (interactive "p") - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries (calendar-cursor-to-date t) arg) - (error "Diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-other-diary-entries (arg diary-file) - "Prepare and display buffer of diary entries from an alternative diary file. -Prompts for a file name and searches that file for entries that match ARG -days starting with the date indicated by the cursor position in the displayed -three-month calendar." - (interactive - (list (cond ((null current-prefix-arg) 1) - ((listp current-prefix-arg) (car current-prefix-arg)) - (t current-prefix-arg)) - (setq diary-file (read-file-name "Enter diary file name: " - default-directory nil t)))) - (view-diary-entries arg)) - -(autoload 'check-calendar-holidays "holidays" - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'calendar-holiday-list "holidays" - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'diary-french-date "cal-french" - "French calendar equivalent of date diary entry." - t) - -(autoload 'diary-mayan-date "cal-mayan" - "Mayan calendar equivalent of date diary entry." - t) - -(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t) - -(autoload 'diary-sunrise-sunset "solar" - "Local time of sunrise and sunset as a diary entry." - t) - -(autoload 'diary-sabbath-candles "solar" - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - t) - -(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table)) - "The syntax table used when parsing dates in the diary file. -It is the standard syntax table used in Fundamental mode, but with the -syntax of `*' changed to be a word constituent.") - -(modify-syntax-entry ?* "w" diary-syntax-table) - -(defun list-diary-entries (date number) - "Create and display a buffer containing the relevant lines in diary-file. -The arguments are DATE and NUMBER; the entries selected are those -for NUMBER days starting with date DATE. The other entries are hidden -using selective display. - -Returns a list of all relevant diary entries found, if any, in order by date. -The list entries have the form ((month day year) string). If the variable -`diary-list-include-blanks' is t, this list includes a dummy diary entry -\(consisting of the empty string) for a date with no diary entries. - -After the list is prepared, the hooks `nongregorian-diary-listing-hook', -`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run. -These hooks have the following distinct roles: - - `nongregorian-diary-listing-hook' can cull dates from the diary - and each included file. Usually used for Hebrew or Islamic - diary entries in files. Applied to *each* file. - - `list-diary-entries-hook' adds or manipulates diary entries from - external sources. Used, for example, to include diary entries - from other files or to sort the diary entries. Invoked *once* only, - before the display hook is run. - - `diary-display-hook' does the actual display of information. If this is - nil, simple-diary-display will be used. Use add-hook to set this to - fancy-diary-display, if desired. If you want no diary display, use - add-hook to set this to ignore. - - `diary-hook' is run last. This can be used for an appointment - notification function." - - (if (< 0 number) - (let* ((original-date date);; save for possible use in the hooks - (old-diary-syntax-table) - (diary-entries-list) - (date-string (calendar-date-string date)) - (d-file (substitute-in-file-name diary-file))) - (message "Preparing diary...") - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t)))) - (setq selective-display t) - (setq selective-display-ellipses nil) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (unwind-protect - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (mark (regexp-quote diary-nonmarking-symbol))) - (goto-char (1- (point-max))) - (if (not (looking-at "\^M\\|\n")) - (progn - (forward-char 1) - (insert-string "\^M"))) - (goto-char (point-min)) - (if (not (looking-at "\^M\\|\n")) - (insert-string "\^M")) - (subst-char-in-region (point-min) (point-max) ?\n ?\^M t) - (calendar-for-loop i from 1 to number do - (let ((d diary-date-forms) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (entry-found (list-sexp-diary-entries date))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name date) "\\|" - (substring (calendar-day-name date) 0 3) ".?")) - (monthname - (concat - "\\*\\|" - (calendar-month-name month) "\\|" - (substring (calendar-month-name month) 0 3) ".?")) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (setq entry-found t) - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start - (point) ?\^M ?\n t) - (add-to-diary-list - date (buffer-substring entry-start (point))))))) - (setq d (cdr d))) - (or entry-found - (not diary-list-include-blanks) - (setq diary-entries-list - (append diary-entries-list - (list (list date ""))))) - (setq date - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian date)))) - (setq entry-found nil))) - (set-buffer-modified-p diary-modified)) - (set-syntax-table old-diary-syntax-table)) - (goto-char (point-min)) - (run-hooks 'nongregorian-diary-listing-hook - 'list-diary-entries-hook) - (if diary-display-hook - (run-hooks 'diary-display-hook) - (simple-diary-display)) - (run-hooks 'diary-hook) - diary-entries-list)))) - -(defun include-other-diary-files () - "Include the diary entries from other diary files with those of diary-file. -This function is suitable for use in `list-diary-entries-hook'; -it enables you to use shared diary files together with your own. -The files included are specified in the diaryfile by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (diary-list-include-blanks nil) - (list-diary-entries-hook 'include-other-diary-files) - (diary-display-hook 'ignore) - (diary-hook nil)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (unwind-protect - (setq diary-entries-list - (append diary-entries-list - (list-diary-entries original-date number))) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun simple-diary-display () - "Display the diary buffer if there are any relevant entries or holidays." - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string)) - (calendar-set-mode-line - (concat "Diary for " date-string - (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) - (display-buffer (get-file-buffer d-file)) - (message "Preparing diary...done")))) - -(defun fancy-diary-display () - "Prepare a diary buffer with relevant entries in a fancy, noneditable form. -This function is provided for optional use as the `diary-display-hook'." - (save-excursion;; Turn off selective-display in the diary file's buffer. - (set-buffer (get-file-buffer (substitute-in-file-name diary-file))) - (let ((diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (kill-local-variable 'mode-line-format) - (set-buffer-modified-p diary-modified))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string))) - (save-excursion;; Prepare the fancy diary buffer. - (set-buffer (get-buffer-create fancy-diary-buffer)) - (setq buffer-read-only nil) - (setq modeline-buffer-identification '("Diary Entries")) - (erase-buffer) - (let ((entry-list diary-entries-list) - (holiday-list) - (holiday-list-last-month 1) - (holiday-list-last-year 1) - (date (list 0 0 0))) - (while entry-list - (if (not (calendar-date-equal date (car (car entry-list)))) - (progn - (setq date (car (car entry-list))) - (and holidays-in-diary-buffer - (calendar-date-compare - (list (list holiday-list-last-month - (calendar-last-day-of-month - holiday-list-last-month - holiday-list-last-year) - holiday-list-last-year)) - (list date)) - ;; We need to get the holidays for the next 3 months. - (setq holiday-list-last-month - (extract-calendar-month date)) - (setq holiday-list-last-year - (extract-calendar-year date)) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1) - (setq holiday-list - (let ((displayed-month holiday-list-last-month) - (displayed-year holiday-list-last-year)) - (calendar-holiday-list))) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1)) - (let* ((date-string (calendar-date-string date)) - (date-holiday-list - (let ((h holiday-list) - (d)) - ;; Make a list of all holidays for date. - (while h - (if (calendar-date-equal date (car (car h))) - (setq d (append d (cdr (car h))))) - (setq h (cdr h))) - d))) - (insert (if (= (point) (point-min)) "" ?\n) date-string) - (if date-holiday-list (insert ": ")) - (let ((l (current-column))) - (insert (mapconcat 'identity date-holiday-list - (concat "\n" (make-string l ? ))))) - (let ((l (current-column))) - (insert ?\n (make-string l ?=) ?\n))))) - (if (< 0 (length (car (cdr (car entry-list))))) - (insert (car (cdr (car entry-list))) ?\n)) - (setq entry-list (cdr entry-list)))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (setq buffer-read-only t) - (display-buffer fancy-diary-buffer) - (message "Preparing diary...done")))) - -(defun print-diary-entries () - "Print a hard copy of the diary display. - -If the simple diary display is being used, prepare a temp buffer with the -visible lines of the diary buffer, add a heading line composed from the mode -line, print the temp buffer, and destroy it. - -If the fancy diary display is being used, just print the buffer. - -The hooks given by the variable `print-diary-entries-hook' are called to do -the actual printing." - (interactive) - (if (bufferp (get-buffer fancy-diary-buffer)) - (save-excursion - (set-buffer (get-buffer fancy-diary-buffer)) - (run-hooks 'print-diary-entries-hook)) - (let ((diary-buffer - (get-file-buffer (substitute-in-file-name diary-file)))) - (if diary-buffer - (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")) - (heading)) - (save-excursion - (set-buffer diary-buffer) - (setq heading - (if (not (stringp mode-line-format)) - "All Diary Entries" - (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format) - (substring mode-line-format - (match-beginning 1) (match-end 1)))) - (copy-to-buffer temp-buffer (point-min) (point-max)) - (set-buffer temp-buffer) - (while (re-search-forward "\^M.*$" nil t) - (replace-match "")) - (goto-char (point-min)) - (insert heading "\n" - (make-string (length heading) ?=) "\n") - (run-hooks 'print-diary-entries-hook) - (kill-buffer temp-buffer))) - (error "You don't have a diary buffer!"))))) - -(defun show-all-diary-entries () - "Show all of the diary entries in the diary file. -This function gets rid of the selective display of the diary file so that -all entries, not just some, are visible. If there is no diary buffer, one -is created." - (interactive) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t))) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (make-local-variable 'mode-line-format) - (setq mode-line-format default-mode-line-format) - (display-buffer (current-buffer)) - (set-buffer-modified-p diary-modified)))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun diary-name-pattern (string-array &optional fullname) - "Convert an STRING-ARRAY, an array of strings to a pattern. -The pattern will match any of the strings, either entirely or abbreviated -to three characters. An abbreviated form will match with or without a period; -If the optional FULLNAME is t, abbreviations will not match, just the full -name." - (let ((pattern "")) - (calendar-for-loop i from 0 to (1- (length string-array)) do - (setq pattern - (concat - pattern - (if (string-equal pattern "") "" "\\|") - (aref string-array i) - (if fullname - "" - (concat - "\\|" - (substring (aref string-array i) 0 3) ".?"))))) - pattern)) - -(defun mark-diary-entries () - "Mark days in the calendar window that have diary entries. -Each entry in the diary file visible in the calendar window is marked. -After the entries are marked, the hooks `nongregorian-diary-marking-hook' and -`mark-diary-entries-hook' are run." - (interactive) - (setq mark-diary-entries-in-calendar t) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (message "Marking diary entries...") - (set-buffer (find-file-noselect d-file t)) - (let ((d diary-date-forms) - (old-diary-syntax-table)) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-month-name-array) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-current-date))) - (y (+ (string-to-int y-str) - (* 100 - (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize - (substring mm-name 0 3)) - (calendar-make-alist - calendar-month-name-array - 1 - '(lambda (x) (substring x 0 3))) - ))))) - (mark-calendar-date-pattern mm dd yy)))) - (setq d (cdr d)))) - (mark-sexp-diary-entries) - (run-hooks 'nongregorian-diary-marking-hook - 'mark-diary-entries-hook) - (set-syntax-table old-diary-syntax-table) - (message "Marking diary entries...done"))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun mark-sexp-diary-entries () - "Mark days in the calendar window that have sexp diary entries. -Each entry in the diary file (or included files) visible in the calendar window -is marked. See the documentation for the function `list-sexp-diary-entries'." - (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "(")) - (m) - (y) - (first-date) - (last-date)) - (save-excursion - (set-buffer calendar-buffer) - (setq m displayed-month) - (setq y displayed-year)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (calendar-for-loop date from first-date to last-date do - (if (diary-sexp-entry sexp entry - (calendar-gregorian-from-absolute date)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date)))))))) - -(defun mark-included-diary-files () - "Mark the diary entries from other diary files with those of the diary file. -This function is suitable for use as the `mark-diary-entries-hook'; it enables -you to use shared diary files together with your own. The files included are -specified in the diary-file by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (mark-diary-entries-hook 'mark-included-diary-files)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (progn - (mark-diary-entries) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun mark-calendar-days-named (dayname) - "Mark all dates in the calendar window that are day DAYNAME of the week. -0 means all Sundays, 1 means all Mondays, and so on." - (save-excursion - (set-buffer calendar-buffer) - (let ((prev-month displayed-month) - (prev-year displayed-year) - (succ-month displayed-month) - (succ-year displayed-year) - (last-day) - (day)) - (increment-calendar-month succ-month succ-year 1) - (increment-calendar-month prev-month prev-year -1) - (setq day (calendar-absolute-from-gregorian - (calendar-nth-named-day 1 dayname prev-month prev-year))) - (setq last-day (calendar-absolute-from-gregorian - (calendar-nth-named-day -1 dayname succ-month succ-year))) - (while (<= day last-day) - (mark-visible-calendar-date (calendar-gregorian-from-absolute day)) - (setq day (+ day 7)))))) - -(defun mark-calendar-date-pattern (month day year) - "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (calendar-for-loop i from 0 to 2 do - (mark-calendar-month m y month day year) - (increment-calendar-month m y 1))))) - -(defun mark-calendar-month (month year p-month p-day p-year) - "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. -A value of 0 in any position of the pattern is a wildcard." - (if (or (and (= month p-month) - (or (= p-year 0) (= year p-year))) - (and (= p-month 0) - (or (= p-year 0) (= year p-year)))) - (if (= p-day 0) - (calendar-for-loop - i from 1 to (calendar-last-day-of-month month year) do - (mark-visible-calendar-date (list month i year))) - (mark-visible-calendar-date (list month p-day year))))) - -(defun sort-diary-entries () - "Sort the list of diary entries by time of day." - (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) - -(defun diary-entry-compare (e1 e2) - "Returns t if E1 is earlier than E2." - (or (calendar-date-compare e1 e2) - (and (calendar-date-equal (car e1) (car e2)) - (< (diary-entry-time (car (cdr e1))) - (diary-entry-time (car (cdr e2))))))) - -(defun diary-entry-time (s) - "Time at the beginning of the string S in a military-style integer. -For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized. -The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm, -and XX:XXam or XX:XXpm." - (cond ((string-match;; Military time - "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s) - (+ (* 100 (string-to-int - (substring s (match-beginning 1) (match-end 1)))) - (string-to-int (substring s (match-beginning 2) (match-end 2))))) - ((string-match;; Hour only XXam or XXpm - "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (if (string-equal "a" - (substring s (match-beginning 2) (match-end 2))) - 0 1200))) - ((string-match;; Hour and minute XX:XXam or XX:XXpm - "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (string-to-int (substring s (match-beginning 2) (match-end 2))) - (if (string-equal "a" - (substring s (match-beginning 3) (match-end 3))) - 0 1200))) - (t -9999)));; Unrecognizable - -(defun list-hebrew-diary-entries () - "Add any Hebrew date entries from the diary file to `diary-entries-list'. -Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol' -\(normally an `H'). The same diary date forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. If a Hebrew date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (hdate (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month hdate)) - (day (extract-calendar-day hdate)) - (year (extract-calendar-year hdate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-hebrew-diary-entries () - "Mark days in the calendar window that have Hebrew date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol -\(normally an `H'). The same diary-date-forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. Hebrew date diary entries that begin with a -diary-nonmarking symbol will not be marked in the calendar. This function -is provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-hebrew-month-name-array-leap-year t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq - mm - (cdr - (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-hebrew-month-name-array-leap-year)))))) - (mark-hebrew-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-hebrew-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Hebrew date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (if (memq displayed-month;; This test is only to speed things up a - (list ;; bit; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 - (calendar-last-day-of-month m2 y2) - y2))) - (hebrew-start - (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((h-date (calendar-hebrew-from-absolute date)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (and (or (zerop month) - (= month h-month)) - (or (zerop day) - (= day h-day)) - (or (zerop year) - (= year h-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(defun list-sexp-diary-entries (date) - "Add sexp entries for DATE from the diary file to `diary-entries-list'. -Also, Make them visible in the diary file. Returns t if any entries were -found. - -Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally -`%%'). The form of a sexp diary entry is - - %%(SEXP) ENTRY - -Both ENTRY and DATE are globally available when the SEXP is evaluated. If the -SEXP yields the value nil, the diary entry does not apply. If it yields a -non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a -string, that string will be the diary entry in the fancy diary display. - -For example, the following diary entry will apply to the 21st of the month -if it is a weekday and the Friday before if the 21st is on a weekend: - - &%%(let ((dayname (calendar-day-of-week date)) - (day (extract-calendar-day date))) - (or - (and (= day 21) (memq dayname '(1 2 3 4 5))) - (and (memq day '(19 20)) (= dayname 5))) - ) UIUC pay checks deposited - -A number of built-in functions are available for this type of diary entry: - - %%(diary-float MONTH DAYNAME N) text - Entry will appear on the Nth DAYNAME of MONTH. - (DAYNAME=0 means Sunday, 1 means Monday, and so on; - if N is negative it counts backward from the end of - the month. MONTH can be a list of months, a single - month, or t to specify all months. - - %%(diary-block M1 D1 Y1 M2 D2 Y2) text - Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2, - inclusive. (If `european-calendar-style' is t, the - order of the parameters should be changed to D1, M1, Y1, - D2, M2, Y2.) - - %%(diary-countdown BEFORE AFTER M1 D1 Y1) text - Entry will appear on dates between BEFORE days before - and AFTER days after specified date. (If - `european-calendar-style' is t, the order of the - parameters should be changed to BEFORE, AFTER, D1, M1, - Y1.) - - %%(diary-anniversary MONTH DAY YEAR) text - Entry will appear on anniversary dates of MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of years since the MONTH DAY, YEAR and %s will be replaced - by the ordinal ending of that number (that is, `st', `nd', - `rd' or `th', as appropriate. The anniversary of February - 29 is considered to be March 1 in a non-leap year. - - %%(diary-cyclic N MONTH DAY YEAR) text - Entry will appear every N days, starting MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to N, DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of repetitions since the MONTH DAY, YEAR and %s will - be replaced by the ordinal ending of that number (that is, - `st', `nd', `rd' or `th', as appropriate. - - %%(diary-day-of-year) - Diary entries giving the day of the year and the number of - days remaining in the year will be made every day. Note - that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-iso-date) - Diary entries giving the corresponding ISO commercial date - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - - %%(diary-french-date) - Diary entries giving the corresponding French Revolutionary - date will be made every day. Note that since there is no - text, it makes sense only if the fancy diary display is used. - - %%(diary-islamic-date) - Diary entries giving the corresponding Islamic date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-hebrew-date) - Diary entries giving the corresponding Hebrew date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-astro-day-number) Diary entries giving the corresponding - astronomical (Julian) day number will be made every day. - Note that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-julian-date) Diary entries giving the corresponding - Julian date will be made every day. Note that since - there is no text, it makes sense only if the fancy diary - display is used. - - %%(diary-sunrise-sunset) - Diary entries giving the local times of sunrise and sunset - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-phases-of-moon) - Diary entries giving the times of the phases of the moon - will be when appropriate. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-yahrzeit MONTH DAY YEAR) text - Text is assumed to be the name of the person; the date is - the date of death on the *civil* calendar. The diary entry - will appear on the proper Hebrew-date anniversary and on the - day before. (If `european-calendar-style' is t, the order - of the parameters should be changed to DAY, MONTH, YEAR.) - - %%(diary-rosh-hodesh) - Diary entries will be made on the dates of Rosh Hodesh on - the Hebrew calendar. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-parasha) - Diary entries giving the weekly parasha will be made on - every Saturday. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-omer) - Diary entries giving the omer count will be made every day - from Passover to Shavuoth. Note that since there is no text, - it makes sense only if the fancy diary display is used. - -Marking these entries is *extremely* time consuming, so these entries are -best if they are nonmarking." - (let* ((mark (regexp-quote diary-nonmarking-symbol)) - (sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) - (entry-found)) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (let ((diary-entry (diary-sexp-entry sexp entry date))) - (if diary-entry - (subst-char-in-region line-start (point) ?\^M ?\n t)) - (add-to-diary-list date diary-entry) - (setq entry-found (or entry-found diary-entry))))) - entry-found)) - -(defun diary-sexp-entry (sexp entry date) - "Process a SEXP diary ENTRY for DATE." - (let ((result (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car (read-from-string sexp)))) - (condition-case nil - (eval (car (read-from-string sexp))) - (error - (beep) - (message "Bad sexp at line %d in %s: %s" - (save-excursion - (save-restriction - (narrow-to-region 1 (point)) - (goto-char (point-min)) - (let ((lines 1)) - (while (re-search-forward "\n\\|\^M" nil t) - (setq lines (1+ lines))) - lines))) - diary-file sexp) - (sleep-for 2)))))) - (if (stringp result) - result - (if result - entry - nil)))) - -(defun diary-block (m1 d1 y1 m2 d2 y2) - "Block diary entry. -Entry applies if date is between two dates. Order of the parameters is -M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and -D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t." - (let ((date1 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d1 m1 y1) - (list m1 d1 y1)))) - (date2 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d2 m2 y2) - (list m2 d2 y2)))) - (d (calendar-absolute-from-gregorian date))) - (if (and (<= date1 d) (<= d date2)) - entry))) - -(defun diary-countdown (before after m1 d1 y1) - "Countdown diary entry. -Entry applies if date is between BEFORE days before and AFTER days after -specified date. Order of the parameters is BEFORE, AFTER, M1, D1, Y1 if -`european-calendar-style' is nil, and BEFORE, AFTER, D1, M1, Y1 if -`european-calendar-style' is t." - (let* ((date1 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d1 m1 y1) - (list m1 d1 y1)))) - (d (calendar-absolute-from-gregorian date)) - (diff (- d date1))) - (cond - ((and (<= (- before) diff) (< diff 0)) - (concat (format "It is %d day%s before " - (- diff) (if (= diff -1) "" "s")) entry)) - ((= diff 0) (concat (format "TODAY: " diff) entry)) - ((and (<= diff after) (> diff 0)) - (concat (format "It is %d day%s after " - diff (if (= diff 1) "" "s")) entry)) - (t nil)))) - -(defun diary-float (month dayname n) - "Floating diary entry--entry applies if date is the nth dayname of month. -Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant -t, or an integer. The constant t means all months. If N is negative, count -backward from the end of the month." - (let ((m (extract-calendar-month date)) - (y (extract-calendar-year date))) - (if (and - (or (and (listp month) (memq m month)) - (equal m month) - (eq month t)) - (calendar-date-equal date (calendar-nth-named-day n dayname m y))) - entry))) - -(defun diary-anniversary (month day year) - "Anniversary diary entry. -Entry applies if date is the anniversary of MONTH, DAY, YEAR if -`european-calendar-style' is nil, and DAY, MONTH, YEAR if -`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the -%d will be replaced by the number of years since the MONTH DAY, YEAR and the -%s will be replaced by the ordinal ending of that number (that is, `st', `nd', -`rd' or `th', as appropriate. The anniversary of February 29 is considered -to be March 1 in non-leap years." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (y (extract-calendar-year date)) - (diff (- y year))) - (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y))) - (setq m 3 - d 1)) - (if (and (> diff 0) (calendar-date-equal (list m d y) date)) - (format entry diff (diary-ordinal-suffix diff))))) - -(defun diary-cyclic (n month day year) - "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR. -If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR. -ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of -years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal -ending of that number (that is, `st', `nd', `rd' or `th', as appropriate." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (diff (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian - (list m d year)))) - (cycle (/ diff n))) - (if (and (>= diff 0) (zerop (% diff n))) - (format entry cycle (diary-ordinal-suffix cycle))))) - -(defun diary-ordinal-suffix (n) - "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)" - (if (or (memq (% n 100) '(11 12 13)) - (< 3 (% n 10))) - "th" - (aref ["th" "st" "nd" "rd"] (% n 10)))) - -(defun diary-day-of-year () - "Day of year and number of days remaining in the year of date diary entry." - (calendar-day-of-year-string date)) - -(defun diary-iso-date () - "ISO calendar equivalent of date diary entry." - (format "ISO date: %s" (calendar-iso-date-string date))) - -(defun diary-islamic-date () - "Islamic calendar equivalent of date diary entry." - (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) - (if (string-equal i "") - "Date is pre-Islamic" - (format "Islamic date (until sunset): %s" i)))) - -(defun diary-hebrew-date () - "Hebrew calendar equivalent of date diary entry." - (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date))) - -(defun diary-julian-date () - "Julian calendar equivalent of date diary entry." - (format "Julian date: %s" (calendar-julian-date-string date))) - -(defun diary-astro-day-number () - "Astronomical (Julian) day number diary entry." - (format "Astronomical (Julian) day number %s" - (calendar-astro-date-string date))) - -(defun diary-omer () - "Omer count diary entry. -Entry applies if date is within 50 days after Passover." - (let* ((passover - (calendar-absolute-from-hebrew - (list 1 15 (+ (extract-calendar-year date) 3760)))) - (omer (- (calendar-absolute-from-gregorian date) passover)) - (week (/ omer 7)) - (day (% omer 7))) - (if (and (> omer 0) (< omer 50)) - (format "Day %d%s of the omer (until sunset)" - omer - (if (zerop week) - "" - (format ", that is, %d week%s%s" - week - (if (= week 1) "" "s") - (if (zerop day) - "" - (format " and %d day%s" - day (if (= day 1) "" "s"))))))))) - -(defun diary-yahrzeit (death-month death-day death-year) - "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before. -Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed -to be the name of the person. Date of death is on the *civil* calendar; -although the date of death is specified by the civil calendar, the proper -Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the -order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR." - (let* ((h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (if european-calendar-style - (list death-day death-month death-year) - (list death-month death-day death-year))))) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (d (calendar-absolute-from-gregorian date)) - (yr (extract-calendar-year (calendar-hebrew-from-absolute d))) - (diff (- yr h-year)) - (y (hebrew-calendar-yahrzeit h-date yr))) - (if (and (> diff 0) (or (= y d) (= y (1+ d)))) - (format "Yahrzeit of %s%s: %d%s anniversary" - entry - (if (= y d) "" " (evening)") - diff - (cond ((= (% diff 10) 1) "st") - ((= (% diff 10) 2) "nd") - ((= (% diff 10) 3) "rd") - (t "th")))))) - -(defun diary-rosh-hodesh () - "Rosh Hodesh diary entry. -Entry applies if date is Rosh Hodesh, the day before, or the Saturday before." - (let* ((d (calendar-absolute-from-gregorian date)) - (h-date (calendar-hebrew-from-absolute d)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (leap-year (hebrew-calendar-leap-year-p h-year)) - (last-day (hebrew-calendar-last-day-of-month h-month h-year)) - (h-month-names - (if leap-year - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year)) - (this-month (aref h-month-names (1- h-month))) - (h-yesterday (extract-calendar-day - (calendar-hebrew-from-absolute (1- d))))) - (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7))) - (format - "Rosh Hodesh %s" - (if (= h-day 30) - (format - "%s (first day)" - ;; next month must be in the same year since this - ;; month can't be the last month of the year since - ;; it has 30 days - (aref h-month-names h-month)) - (if (= h-yesterday 30) - (format "%s (second day)" this-month) - this-month))) - (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim - (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s)" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)) - (aref calendar-day-name-array (- 29 h-day)))) - ((and (< h-day 30) (> h-day 22) (= 30 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s-%s)" - (aref h-month-names h-month) - (if (= h-day 29) - "tomorrow" - (aref calendar-day-name-array (- 29 h-day))) - (aref calendar-day-name-array - (% (- 30 h-day) 7))))) - (if (and (= h-day 29) (/= h-month 6)) - (format "Erev Rosh Hodesh %s" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)))))))) - -(defun diary-parasha () - "Parasha diary entry--entry applies if date is a Saturday." - (let ((d (calendar-absolute-from-gregorian date))) - (if (= (% d 7) 6);; Saturday - (let* - ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute d))) - (rosh-hashannah - (calendar-absolute-from-hebrew (list 7 1 h-year))) - (passover - (calendar-absolute-from-hebrew (list 1 15 h-year))) - (rosh-hashannah-day - (aref calendar-day-name-array (% rosh-hashannah 7))) - (passover-day - (aref calendar-day-name-array (% passover 7))) - (long-h (hebrew-calendar-long-heshvan-p h-year)) - (short-k (hebrew-calendar-short-kislev-p h-year)) - (type (cond ((and long-h (not short-k)) "complete") - ((and (not long-h) short-k) "incomplete") - (t "regular"))) - (year-format - (symbol-value - (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah - rosh-hashannah-day type passover-day)))) - (first-saturday;; of Hebrew year - (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah))) - (saturday;; which Saturday of the Hebrew year - (/ (- d first-saturday) 7)) - (parasha (aref year-format saturday))) - (if parasha - (format - "Parashat %s" - (if (listp parasha);; Israel differs from diaspora - (if (car parasha) - (format "%s (diaspora), %s (Israel)" - (hebrew-calendar-parasha-name (car parasha)) - (hebrew-calendar-parasha-name (cdr parasha))) - (format "%s (Israel)" - (hebrew-calendar-parasha-name (cdr parasha)))) - (hebrew-calendar-parasha-name parasha)))))))) - -(defun add-to-diary-list (date string) - "Add the entry (DATE STRING) to `diary-entries-list'. -Do nothing if DATE or STRING is nil." - (and date string - (setq diary-entries-list - (append diary-entries-list (list (list date string)))))) - -(defvar hebrew-calendar-parashiot-names -["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" - "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" - "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" - "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" - "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" - "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" - "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" - "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" - "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] - "The names of the parashiot in the Torah.") - -;; The seven ordinary year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Sunday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have -29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Saturday-complete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Tuesday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-complete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Thursday-regular-Saturday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23 - 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30) - (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48 - 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-complete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Sunday.") - -;; The seven leap year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Saturday-complete-Thursday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-complete-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-incomplete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both -have 29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Thursday-complete-Tuesday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both -have 30 days), and has Passover start on Tuesday.") - -(defun hebrew-calendar-parasha-name (p) - "Name(s) corresponding to parasha P." - (if (arrayp p);; combined parasha - (format "%s/%s" - (aref hebrew-calendar-parashiot-names (aref p 0)) - (aref hebrew-calendar-parashiot-names (aref p 1))) - (aref hebrew-calendar-parashiot-names p))) - -(defun list-islamic-diary-entries () - "Add any Islamic date entries from the diary file to `diary-entries-list'. -Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol' -\(normally an `I'). The same diary date forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. If an Islamic date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (idate (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month idate)) - (day (extract-calendar-day idate)) - (year (extract-calendar-year idate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-islamic-month-name-array) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-islamic-diary-entries () - "Mark days in the calendar window that have Islamic date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol -\(normally an `I'). The same diary-date-forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. Islamic date diary entries that begin with a -diary-nonmarking-symbol will not be marked in the calendar. This function is -provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-islamic-month-name-array t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-islamic-month-name-array)))))) - (mark-islamic-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-islamic-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Islamic date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day y))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((i-date (calendar-islamic-from-absolute date)) - (i-month (extract-calendar-month i-date)) - (i-day (extract-calendar-day i-date)) - (i-year (extract-calendar-year i-date))) - (and (or (zerop month) - (= month i-month)) - (or (zerop day) - (= day i-day)) - (or (zerop year) - (= year i-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(provide 'diary-lib) - -;;; diary-lib.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/holidays.el --- a/lisp/calendar/holidays.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,629 +0,0 @@ -;;; holidays.el --- holiday functions for the calendar package - -;;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; Keywords: holidays, calendar - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the holiday features as described -;; in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990), -;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical -;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;; Hard copies of these two papers can be obtained by sending email to -;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and -;; the message BODY containing your mailing address (snail). - -;;; Code: - -(require 'calendar) - -(autoload 'solar-equinoxes-solstices "solar" - "Date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." - t) - -;;;###autoload -(defun holidays (&optional arg) - "Display the holidays for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." - (interactive "P") - (save-excursion - (let* ((completion-ignore-case t) - (date (if arg - (calendar-read-date t) - (calendar-current-date))) - (displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date))) - (list-calendar-holidays)))) - -(defun check-calendar-holidays (date) - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list calendar-holidays." - (let* ((displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date)) - (h (calendar-holiday-list)) - (holiday-list)) - (while h - (if (calendar-date-equal date (car (car h))) - (setq holiday-list (append holiday-list (cdr (car h))))) - (setq h (cdr h))) - holiday-list)) - -(defun calendar-cursor-holidays () - "Find holidays for the date specified by the cursor in the calendar window." - (interactive) - (message "Checking holidays...") - (let* ((date (calendar-cursor-to-date t)) - (date-string (calendar-date-string date)) - (holiday-list (check-calendar-holidays date)) - (holiday-string (mapconcat 'identity holiday-list "; ")) - (msg (format "%s: %s" date-string holiday-string))) - (if (not holiday-list) - (message "No holidays known for %s" date-string) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "Checking holidays...done"))))) - -(defun mark-calendar-holidays () - "Mark notable days in the calendar window." - (interactive) - (setq mark-holidays-in-calendar t) - (message "Marking holidays...") - (let ((holiday-list (calendar-holiday-list))) - (while holiday-list - (mark-visible-calendar-date - (car (car holiday-list)) calendar-holiday-marker) - (setq holiday-list (cdr holiday-list)))) - (message "Marking holidays...done")) - -(defun list-calendar-holidays () - "Create a buffer containing the holidays for the current calendar window. -The holidays are those in the list calendar-notable-days. Returns t if any -holidays are found, nil if not." - (interactive) - (message "Looking up holidays...") - (let ((holiday-list (calendar-holiday-list)) - (m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (if (not holiday-list) - (progn - (message "Looking up holidays...none found") - nil) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (calendar-set-mode-line - (if (= y1 y2) - (format "Notable Dates from %s to %s, %d%%-" - (calendar-month-name m1) (calendar-month-name m2) y2) - (format "Notable Dates from %s, %d to %s, %d%%-" - (calendar-month-name m1) y1 (calendar-month-name m2) y2))) - (erase-buffer) - (insert - (mapconcat - '(lambda (x) (concat (calendar-date-string (car x)) - ": " (car (cdr x)))) - holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "Looking up holidays...done") - t))) - -(defun calendar-holiday-list () - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list calendar-holidays." - (let ((p calendar-holidays) - (holiday-list)) - (while p - (let* ((holidays - (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car p))) - (condition-case nil - (eval (car p)) - (error (beep) - (message "Bad holiday list item: %s" (car p)) - (sleep-for 2)))))) - (if holidays - (setq holiday-list (append holidays holiday-list)))) - (setq p (cdr p))) - (setq holiday-list (sort holiday-list 'calendar-date-compare)))) - -;; Below are the functions that calculate the dates of holidays; these -;; are eval'ed in the function calendar-holiday-list. If you -;; write other such functions, be sure to imitate the style used below. -;; Remember that each function must return a list of items of the form -;; ((month day year) string) of VISIBLE dates in the calendar window. - -(defun holiday-fixed (month day string) - "Holiday on MONTH, DAY (Gregorian) called STRING. -If MONTH, DAY is visible, the value returned is the list (((MONTH DAY year) -STRING)). Returns nil if it is not visible in the current calendar window." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (- 11 month)) - (if (> m 9) - (list (list (list month day y) string))))) - -(defun holiday-float (month dayname n string &optional day) - "Holiday on MONTH, DAYNAME (Nth occurrence, Gregorian) called STRING. -If the Nth DAYNAME in MONTH is visible, the value returned is the list -\(((MONTH DAY year) STRING)). - -If N<0, count backward from the end of MONTH. - -An optional parameter DAY means the Nth DAYNAME after/before MONTH DAY. - -Returns nil if it is not visible in the current calendar window." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (- 11 month)) - (if (> m 9) - (list (list (calendar-nth-named-day n dayname month y day) string))))) - -(defun holiday-julian (month day string) - "Holiday on MONTH, DAY (Julian) called STRING. -If MONTH, DAY (Julian) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 (calendar-last-day-of-month m2 y2) y2))) - (julian-start (calendar-julian-from-absolute start-date)) - (julian-end (calendar-julian-from-absolute end-date)) - (julian-y1 (extract-calendar-year julian-start)) - (julian-y2 (extract-calendar-year julian-end))) - (setq year (if (< 10 month) julian-y1 julian-y2)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-julian - (list month day year))))) - (if (calendar-date-is-visible-p date) - (list (list date string))))))) - -(defun holiday-islamic (month day string) - "Holiday on MONTH, DAY (Islamic) called STRING. -If MONTH, DAY (Islamic) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic (list month day y))))) - (if (calendar-date-is-visible-p date) - (list (list date string)))))))) - -(defun holiday-hebrew (month day string) - "Holiday on MONTH, DAY (Hebrew) called STRING. -If MONTH, DAY (Hebrew) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (if (memq displayed-month;; This test is only to speed things up a bit; - (list ;; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 (calendar-last-day-of-month m2 y2) y2))) - (hebrew-start (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (list (list date string)))))))) - -(defun holiday-sexp (sexp string) - "Sexp holiday for dates in the calendar window. -SEXP is an expression in variable `year' evaluates to `date'. - -STRING is an expression in `date' that evaluates to the holiday description -of `date'. - -If `date' is visible in the calendar window, the holiday STRING is on that -date. If date is nil, or if the date is not visible, there is no holiday." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (filter-visible-calendar-holidays - (append - (let* ((year y) - (date (eval sexp)) - (string (if date (eval string)))) - (list (list date string))) - (let* ((year (1+ y)) - (date (eval sexp)) - (string (if date (eval string)))) - (list (list date string))))))) - -(defun holiday-advent () - "Date of Advent, if visible in calendar window." - (let ((year displayed-year) - (month displayed-month)) - (increment-calendar-month month year -1) - (let ((advent (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 0 - (calendar-absolute-from-gregorian - (list 12 3 year)))))) - (if (calendar-date-is-visible-p advent) - (list (list advent "Advent")))))) - -(defun holiday-easter-etc () - "List of dates related to Easter, as visible in calendar window." - (if (and (> displayed-month 5) (not all-christian-calendar-holidays)) - nil;; Ash Wednesday, Good Friday, and Easter are not visible. - (let* ((century (1+ (/ displayed-year 100))) - (shifted-epact ;; Age of moon for April 5... - (% (+ 14 (* 11 (% displayed-year 19));; ...by Nicaean rule - (- ;; ...corrected for the Gregorian century rule - (/ (* 3 century) 4)) - (/ ;; ...corrected for Metonic cycle inaccuracy. - (+ 5 (* 8 century)) 25) - (* 30 century));; Keeps value positive. - 30)) - (adjusted-epact ;; Adjust for 29.5 day month. - (if (or (= shifted-epact 0) - (and (= shifted-epact 1) (< 10 (% displayed-year 19)))) - (1+ shifted-epact) - shifted-epact)) - (paschal-moon ;; Day after the full moon on or after March 21. - (- (calendar-absolute-from-gregorian (list 4 19 displayed-year)) - adjusted-epact)) - (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-easter) - "Easter Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 2)) - "Good Friday") - (list (calendar-gregorian-from-absolute (- abs-easter 46)) - "Ash Wednesday"))) - (optional - (list - (list (calendar-gregorian-from-absolute (- abs-easter 63)) - "Septuagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 56)) - "Sexagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 49)) - "Shrove Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 48)) - "Shrove Monday") - (list (calendar-gregorian-from-absolute (- abs-easter 47)) - "Shrove Tuesday") - (list (calendar-gregorian-from-absolute (- abs-easter 14)) - "Passion Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 7)) - "Palm Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 3)) - "Maundy Thursday") - (list (calendar-gregorian-from-absolute (+ abs-easter 35)) - "Rogation Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 39)) - "Ascension Day") - (list (calendar-gregorian-from-absolute (+ abs-easter 49)) - "Pentecost (Whitsunday)") - (list (calendar-gregorian-from-absolute (+ abs-easter 50)) - "Whitmunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 56)) - "Trinity Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 60)) - "Corpus Christi"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-christian-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-greek-orthodox-easter () - "Date of Easter according to the rule of the Council of Nicaea." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((julian-year - (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))))) - (shifted-epact ;; Age of moon for April 5. - (% (+ 14 - (* 11 (% julian-year 19))) - 30)) - (paschal-moon ;; Day after full moon on or after March 21. - (- (calendar-absolute-from-julian (list 4 19 julian-year)) - shifted-epact)) - (nicaean-easter;; Sunday following the Paschal moon - (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 0 (+ paschal-moon 7))))) - (if (calendar-date-is-visible-p nicaean-easter) - (list (list nicaean-easter "Pascha (Greek Orthodox Easter)")))))) - -(defun holiday-rosh-hashanah-etc () - "List of dates related to Rosh Hashanah, as visible in calendar window." - (if (or (< displayed-month 8) - (> displayed-month 11)) - nil;; None of the dates is visible - (let* ((abs-r-h (calendar-absolute-from-hebrew - (list 7 1 (+ displayed-year 3761)))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-r-h) - (format "Rosh HaShanah %d" (+ 3761 displayed-year))) - (list (calendar-gregorian-from-absolute (+ abs-r-h 9)) - "Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 14)) - "Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 21)) - "Shemini Atzeret") - (list (calendar-gregorian-from-absolute (+ abs-r-h 22)) - "Simchat Torah"))) - (optional - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-r-h 4))) - "Selichot (night)") - (list (calendar-gregorian-from-absolute (1- abs-r-h)) - "Erev Rosh HaShannah") - (list (calendar-gregorian-from-absolute (1+ abs-r-h)) - "Rosh HaShanah (second day)") - (list (calendar-gregorian-from-absolute - (if (= (% abs-r-h 7) 4) (+ abs-r-h 3) (+ abs-r-h 2))) - "Tzom Gedaliah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ 7 abs-r-h))) - "Shabbat Shuvah") - (list (calendar-gregorian-from-absolute (+ abs-r-h 8)) - "Erev Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 13)) - "Erev Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 15)) - "Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 16)) - "Hol Hamoed Sukkot (first day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 17)) - "Hol Hamoed Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 18)) - "Hol Hamoed Sukkot (third day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 19)) - "Hol Hamoed Sukkot (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 20)) - "Hoshannah Rabbah"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-hebrew-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-hanukkah () - "List of dates related to Hanukkah, as visible in calendar window." - (if (memq displayed-month;; This test is only to speed things up a bit; - '(10 11 12 1 2));; it works fine without the test too. - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((h-y (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))))) - (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y)))) - (filter-visible-calendar-holidays - (list - (list (calendar-gregorian-from-absolute (1- abs-h)) - "Erev Hanukkah") - (list (calendar-gregorian-from-absolute abs-h) - "Hanukkah (first day)") - (list (calendar-gregorian-from-absolute (1+ abs-h)) - "Hanukkah (second day)") - (list (calendar-gregorian-from-absolute (+ abs-h 2)) - "Hanukkah (third day)") - (list (calendar-gregorian-from-absolute (+ abs-h 3)) - "Hanukkah (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 4)) - "Hanukkah (fifth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 5)) - "Hanukkah (sixth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 6)) - "Hanukkah (seventh day)") - (list (calendar-gregorian-from-absolute (+ abs-h 7)) - "Hanukkah (eighth day)"))))))) - -(defun holiday-passover-etc () - "List of dates related to Passover, as visible in calendar window." - (if (< 7 displayed-month) - nil;; None of the dates is visible - (let* ((abs-p (calendar-absolute-from-hebrew - (list 1 15 (+ displayed-year 3760)))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-p) - "Passover") - (list (calendar-gregorian-from-absolute (+ abs-p 50)) - "Shavuot"))) - (optional - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 43))) - "Shabbat Shekalim") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 30))) - "Shabbat Zachor") - (list (calendar-gregorian-from-absolute - (if (= (% abs-p 7) 2) (- abs-p 33) (- abs-p 31))) - "Fast of Esther") - (list (calendar-gregorian-from-absolute (- abs-p 31)) - "Erev Purim") - (list (calendar-gregorian-from-absolute (- abs-p 30)) - "Purim") - (list (calendar-gregorian-from-absolute - (if (zerop (% abs-p 7)) (- abs-p 28) (- abs-p 29))) - "Shushan Purim") - (list (calendar-gregorian-from-absolute - (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7)) - "Shabbat Parah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 14))) - "Shabbat HaHodesh") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (1- abs-p))) - "Shabbat HaGadol") - (list (calendar-gregorian-from-absolute (1- abs-p)) - "Erev Passover") - (list (calendar-gregorian-from-absolute (1+ abs-p)) - "Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 2)) - "Hol Hamoed Passover (first day)") - (list (calendar-gregorian-from-absolute (+ abs-p 3)) - "Hol Hamoed Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 4)) - "Hol Hamoed Passover (third day)") - (list (calendar-gregorian-from-absolute (+ abs-p 5)) - "Hol Hamoed Passover (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-p 6)) - "Passover (seventh day)") - (list (calendar-gregorian-from-absolute (+ abs-p 7)) - "Passover (eighth day)") - (list (calendar-gregorian-from-absolute (+ abs-p 12)) - "Yom HaShoah") - (list (calendar-gregorian-from-absolute - (if (zerop (% abs-p 7)) - (+ abs-p 18) - (if (= (% abs-p 7) 6) - (+ abs-p 19) - (+ abs-p 20)))) - "Yom HaAtzma'ut") - (list (calendar-gregorian-from-absolute (+ abs-p 33)) - "Lag BaOmer") - (list (calendar-gregorian-from-absolute (+ abs-p 43)) - "Yom Yerushalim") - (list (calendar-gregorian-from-absolute (+ abs-p 49)) - "Erev Shavuot") - (list (calendar-gregorian-from-absolute (+ abs-p 51)) - "Shavuot (second day)"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-hebrew-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-tisha-b-av-etc () - "List of dates around Tisha B'Av, as visible in calendar window." - (if (or (< displayed-month 5) - (> displayed-month 9)) - nil;; None of the dates is visible - (let* ((abs-t-a (calendar-absolute-from-hebrew - (list 5 9 (+ displayed-year 3760))))) - - (filter-visible-calendar-holidays - (list - (list (calendar-gregorian-from-absolute - (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21))) - "Tzom Tammuz") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 abs-t-a)) - "Shabbat Hazon") - (list (calendar-gregorian-from-absolute - (if (= (% abs-t-a 7) 6) (1+ abs-t-a) abs-t-a)) - "Tisha B'Av") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ abs-t-a 7))) - "Shabbat Nahamu")))))) - -(defun filter-visible-calendar-holidays (l) - "Return a list of all visible holidays of those on L." - (let ((visible) - (p l)) - (while p - (and (car (car p)) - (calendar-date-is-visible-p (car (car p))) - (setq visible (append (list (car p)) visible))) - (setq p (cdr p))) - visible)) - -(provide 'holidays) - -;;; holidays.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/lunar.el --- a/lisp/calendar/lunar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,252 +0,0 @@ -;;; lunar.el --- calendar functions for phases of the moon. - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; Keywords: calendar -;; Human-Keywords: moon, lunar phases, calendar, diary - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements lunar phases for calendar.el and -;; diary.el. - -;; Based on ``Astronomical Formulae for Calculators,'' 3rd ed., by Jean Meeus, -;; Willmann-Bell, Inc., 1985. -;; -;; WARNING: The calculations will be accurate only to within a few minutes. - -;; The author would be delighted to have an astronomically more sophisticated -;; person rewrite the code for the lunar calculations in this file! - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(if (fboundp 'atan) - (require 'lisp-float-type) - (error "Lunar calculations impossible since floating point is unavailable.")) - -(require 'solar) - -(defun lunar-phase-list (month year) - "List of lunar phases for three months starting with Gregorian MONTH, YEAR." - (let ((end-month month) - (end-year year) - (start-month month) - (start-year year)) - (increment-calendar-month end-month end-year 3) - (increment-calendar-month start-month start-year -1) - (let* ((end-date (list (list end-month 1 end-year))) - (start-date (list (list start-month - (calendar-last-day-of-month - start-month start-year) - start-year))) - (index (* 4 - (truncate - (* 12.3685 - (+ year - ( / (calendar-day-number (list month 1 year)) - 366.0) - -1900))))) - (new-moon (lunar-phase index)) - (list)) - (while (calendar-date-compare new-moon end-date) - (if (calendar-date-compare start-date new-moon) - (setq list (append list (list new-moon)))) - (setq index (1+ index)) - (setq new-moon (lunar-phase index))) - list))) - -(defun lunar-phase (index) - "Local date and time of lunar phase INDEX. -Integer below INDEX/4 gives the lunation number, counting from Jan 1, 1900; -remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, -3 last quarter." - (let* ((phase (mod index 4)) - (index (/ index 4.0)) - (time (/ index 1236.85)) - (date (+ (calendar-absolute-from-gregorian '(1 0.5 1900)) - 0.75933 - (* 29.53058868 index) - (* 0.0001178 time time) - (* -0.000000155 time time time) - (* 0.00033 - (solar-sin-degrees (+ 166.56 - (* 132.87 time) - (* -0.009173 time time)))))) - (sun-anomaly (mod - (+ 359.2242 - (* 29.105356 index) - (* -0.0000333 time time) - (* -0.00000347 time time time)) - 360.0)) - (moon-anomaly (mod - (+ 306.0253 - (* 385.81691806 index) - (* 0.0107306 time time) - (* 0.00001236 time time time)) - 360.0)) - (moon-lat (mod - (+ 21.2964 - (* 390.67050646 index) - (* -0.0016528 time time) - (* -0.00000239 time time time)) - 360.0)) - (adjustment - (if (memq phase '(0 2)) - (+ (* (- 0.1734 (* 0.000393 time)) - (solar-sin-degrees sun-anomaly)) - (* 0.0021 (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.4068 (solar-sin-degrees moon-anomaly)) - (* 0.0161 (solar-sin-degrees (* 2 moon-anomaly))) - (* -0.0004 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.0104 (solar-sin-degrees (* 2 moon-lat))) - (* -0.0051 (solar-sin-degrees (+ sun-anomaly moon-anomaly))) - (* -0.0074 (solar-sin-degrees (- sun-anomaly moon-anomaly))) - (* 0.0004 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly))) - (* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly))) - (* -0.0006 (solar-sin-degrees - (+ (* 2 moon-lat) moon-anomaly))) - (* 0.0010 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly))) - (* 0.0005 (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly)))) - (+ (* (- 0.1721 (* 0.0004 time)) - (solar-sin-degrees sun-anomaly)) - (* 0.0021 (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.6280 (solar-sin-degrees moon-anomaly)) - (* 0.0089 (solar-sin-degrees (* 2 moon-anomaly))) - (* -0.0004 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.0079 (solar-sin-degrees (* 2 moon-lat))) - (* -0.0119 (solar-sin-degrees (+ sun-anomaly moon-anomaly))) - (* -0.0047 (solar-sin-degrees (- sun-anomaly moon-anomaly))) - (* 0.0003 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly))) - (* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly))) - (* -0.0006 (solar-sin-degrees (+ (* 2 moon-lat) moon-anomaly))) - (* 0.0021 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly))) - (* 0.0003 (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly))) - (* 0.0004 (solar-sin-degrees - (- sun-anomaly (* 2 moon-anomaly)))) - (* -0.0003 (solar-sin-degrees - (+ (* 2 sun-anomaly) moon-anomaly)))))) - (adj (+ 0.0028 - (* -0.0004 (solar-cosine-degrees - sun-anomaly)) - (* 0.0003 (solar-cosine-degrees - moon-anomaly)))) - (adjustment (cond ((= phase 1) (+ adjustment adj)) - ((= phase 2) (- adjustment adj)) - (t adjustment))) - (date (+ date adjustment)) - (date (+ date (/ (- calendar-time-zone - (solar-ephemeris-correction - (extract-calendar-year - (calendar-gregorian-from-absolute - (truncate date))))) - 60.0 24.0))) - (time (* 24 (- date (truncate date)))) - (date (calendar-gregorian-from-absolute (truncate date))) - (adj (solar-adj-time-for-dst date time))) - (list (car adj) (apply 'solar-time-string (cdr adj)) phase))) - -(defun lunar-phase-name (phase) - "Name of lunar PHASE. -0 = new moon, 1 = first quarter, 2 = full moon, 3 = last quarter." - (cond ((= 0 phase) "New Moon") - ((= 1 phase) "First Quarter Moon") - ((= 2 phase) "Full Moon") - ((= 3 phase) "Last Quarter Moon"))) - -(defun calendar-phases-of-moon () - "Create a buffer with the lunar phases for the current calendar window." - (interactive) - (message "Computing phases of the moon...") - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (set-buffer (get-buffer-create lunar-phases-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line - (if (= y1 y2) - (format "Phases of the Moon from %s to %s, %d%%-" - (calendar-month-name m1) (calendar-month-name m2) y2) - (format "Phases of the Moon from %s, %d to %s, %d%%-" - (calendar-month-name m1) y1 (calendar-month-name m2) y2))) - (erase-buffer) - (insert - (mapconcat - '(lambda (x) - (let ((date (car x)) - (time (car (cdr x))) - (phase (car (cdr (cdr x))))) - (concat (calendar-date-string date) - ": " - (lunar-phase-name phase) - " " - time))) - (lunar-phase-list m1 y1) "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer lunar-phases-buffer) - (message "Computing phases of the moon...done"))) - -;;;###autoload -(defun phases-of-moon (&optional arg) - "Display the quarters of the moon for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." - (interactive "P") - (save-excursion - (let* ((date (if arg - (calendar-read-date t) - (calendar-current-date))) - (displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date))) - (calendar-phases-of-moon)))) - -(defun diary-phases-of-moon () - "Moon phases diary entry." - (let* ((index (* 4 - (truncate - (* 12.3685 - (+ (extract-calendar-year date) - ( / (calendar-day-number date) - 366.0) - -1900))))) - (phase (lunar-phase index))) - (while (calendar-date-compare phase (list date)) - (setq index (1+ index)) - (setq phase (lunar-phase index))) - (if (calendar-date-equal (car phase) date) - (concat (lunar-phase-name (car (cdr (cdr phase)))) " " - (car (cdr phase)))))) - -(provide 'lunar) - -;;; lunar.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/calendar/solar.el --- a/lisp/calendar/solar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,588 +0,0 @@ -;;; solar.el --- calendar functions for solar events. - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; Keywords: calendar -;; Human-Keywords: sunrise, sunset, equinox, solstice, calendar, diary, -;; holidays - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el, -;; diary.el, and holiday.el that deal with times of day, sunrise/sunset, and -;; eqinoxes/solstices. - -;; Based on the ``Almanac for Computers 1984,'' prepared by the Nautical -;; Almanac Office, United States Naval Observatory, Washington, 1984 and -;; on ``Astronomical Formulae for Calculators,'' 3rd ed., by Jean Meeus, -;; Willmann-Bell, Inc., 1985. -;; -;; WARNINGS: -;; 1. SUNRISE/SUNSET calculations will be accurate only to +/- 2 minutes. -;; Locations should be between +/- 65 degrees of latitude. -;; Dates should be in the latter half of the 20th century. -;; -;; 2. Equinox/solstice times will be accurate only to +/- 15 minutes. - -;; The author would be delighted to have an astronomically more sophisticated -;; person rewrite the code for the solar calculations in this file! - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(if (fboundp 'atan) - (require 'lisp-float-type) - (error "Solar/lunar calculations impossible since floating point is unavailable.")) - -(require 'cal-dst) - -;;;###autoload -(defvar calendar-time-display-form - '(12-hours ":" minutes am-pm - (if time-zone " (") time-zone (if time-zone ")")) - "*The pseudo-pattern that governs the way a time of day is formatted. - -A pseudo-pattern is a list of expressions that can involve the keywords -`12-hours', `24-hours', and `minutes', all numbers in string form, -and `am-pm' and `time-zone', both alphabetic strings. - -For example, the form - - '(24-hours \":\" minutes - (if time-zone \" (\") time-zone (if time-zone \")\")) - -would give military-style times like `21:07 (UTC)'.") - -;;;###autoload -(defvar calendar-latitude nil - "*Latitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + north, - south, such as 40.7 for New York City, or the value -can be a vector [degrees minutes north/south] such as [40 50 north] for New -York City. - -This variable should be set in site-local.el.") - -;;;###autoload -(defvar calendar-longitude nil - "*Longitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + east, - west, such as -73.9 for New York City, or the value -can be a vector [degrees minutes east/west] such as [73 55 west] for New -York City. - -This variable should be set in site-local.el.") - -(defsubst calendar-latitude () - "Convert calendar-latitude to a signed decimal fraction, if needed." - (if (numberp calendar-latitude) - calendar-latitude - (let ((lat (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0)))) - (if (equal (aref calendar-latitude 2) 'north) - lat - (- lat))))) - -(defsubst calendar-longitude () - "Convert calendar-longitude to a signed decimal fraction, if needed." - (if (numberp calendar-longitude) - calendar-longitude - (let ((long (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0)))) - (if (equal (aref calendar-longitude 2) 'east) - long - (- long))))) - -;;;###autoload -(defvar calendar-location-name - '(let ((float-output-format "%.1f")) - (format "%s%s, %s%s" - (if (numberp calendar-latitude) - (abs calendar-latitude) - (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0))) - (if (numberp calendar-latitude) - (if (> calendar-latitude 0) "N" "S") - (if (equal (aref calendar-latitude 2) 'north) "N" "S")) - (if (numberp calendar-longitude) - (abs calendar-longitude) - (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0))) - (if (numberp calendar-longitude) - (if (> calendar-longitude 0) "E" "W") - (if (equal (aref calendar-latitude 2) 'east) "E" "W")))) - "*Expression evaluating to name of `calendar-longitude', calendar-latitude'. -For example, \"New York City\". Default value is just the latitude, longitude -pair. - -This variable should be set in site-local.el.") - -(defvar solar-n-hemi-seasons - '("Vernal Equinox" "Summer Solstice" "Autumnal Equinox" "Winter Solstice") - "List of season changes for the northern hemisphere.") - -(defvar solar-s-hemi-seasons - '("Autumnal Equinox" "Winter Solstice" "Vernal Equinox" "Summer Solstice") - "List of season changes for the southern hemisphere.") - -(defun solar-setup () - "Prompt user for latitude, longitude, and time zone." - (beep) - (if (not calendar-longitude) - (setq calendar-longitude - (solar-get-number - "Enter longitude (decimal fraction; + east, - west): "))) - (if (not calendar-latitude) - (setq calendar-latitude - (solar-get-number - "Enter latitude (decimal fraction; + north, - south): "))) - (if (not calendar-time-zone) - (setq calendar-time-zone - (solar-get-number - "Enter difference from Coordinated Universal Time (in minutes): ")))) - -(defun solar-get-number (prompt) - "Return a number from the minibuffer, prompting with PROMPT. -Returns nil if nothing was entered." - (let ((x (read-string prompt ""))) - (if (not (string-equal x "")) - (string-to-int x)))) - -(defsubst solar-sin-degrees (x) - (sin (degrees-to-radians x))) - -(defsubst solar-cosine-degrees (x) - (cos (degrees-to-radians x))) - -(defun solar-tangent-degrees (x) - (tan (degrees-to-radians x))) - -(defun solar-xy-to-quadrant (x y) - "Determines the quadrant of the point X, Y." - (if (> x 0) - (if (> y 0) 1 4) - (if (> y 0) 2 3))) - -(defun solar-degrees-to-quadrant (angle) - "Determines the quadrant of ANGLE." - (1+ (floor (mod angle 360) 90))) - -(defun solar-arctan (x quad) - "Arctangent of X in quadrant QUAD." - (let ((deg (radians-to-degrees (atan x)))) - (cond ((equal quad 2) (+ deg 180)) - ((equal quad 3) (+ deg 180)) - ((equal quad 4) (+ deg 360)) - (t deg)))) - -(defun solar-arccos (x) - (let ((y (sqrt (- 1 (* x x))))) - (solar-arctan (/ y x) (solar-xy-to-quadrant x y)))) - -(defun solar-arcsin (y) - (let ((x (sqrt (- 1 (* y y))))) - (solar-arctan (/ y x) (solar-xy-to-quadrant x y)))) - -(defconst solar-earth-inclination 23.441884 - "Inclination of earth's equator to its solar orbit in degrees.") - -(defconst solar-cos-inclination (solar-cosine-degrees solar-earth-inclination) - "Cosine of earth's inclination.") - -(defconst solar-sin-inclination (solar-sin-degrees solar-earth-inclination) - "Sine of earth's inclination.") - -(defconst solar-earth-orbit-eccentricity 0.016718 - "Eccentricity of orbit of the earth around the sun.") - -(defsubst solar-degrees-to-hours (deg) - (/ deg 15.0)) - -(defsubst solar-hours-to-days (hour) - (/ hour 24.0)) - -(defun solar-longitude-of-sun (day) - "Longitude of the sun at DAY in the year." - (let ((mean-anomaly (- (* 0.9856 day) 3.289))) - (mod (+ mean-anomaly - (* 1.916 (solar-sin-degrees mean-anomaly)) - (* 0.020 (solar-sin-degrees (* 2 mean-anomaly))) - 282.634) - 360))) - -(defun solar-right-ascension (longitude) - "Right ascension of the sun, given its LONGITUDE." - (solar-degrees-to-hours - (solar-arctan - (* solar-cos-inclination (solar-tangent-degrees longitude)) - (solar-degrees-to-quadrant longitude)))) - -(defun solar-declination (longitude) - "Declination of the sun, given its LONGITUDE." - (solar-arcsin - (* solar-sin-inclination - (solar-sin-degrees longitude)))) - -(defun solar-sunrise (date) - "Calculates the *standard* time of sunrise for Gregorian DATE. -Calculation is for location given by `calendar-latitude' and -`calendar-longitude'. - -Returns a decimal fraction of hours. Returns nil if the sun does not rise at -that location on that day." - (let* ((day-of-year (calendar-day-number date)) - (approx-sunrise - (+ day-of-year - (solar-hours-to-days - (- 6 (solar-degrees-to-hours (calendar-longitude)))))) - (solar-longitude-of-sun-at-sunrise - (solar-longitude-of-sun approx-sunrise)) - (solar-right-ascension-at-sunrise - (solar-right-ascension solar-longitude-of-sun-at-sunrise)) - (solar-declination-at-sunrise - (solar-declination solar-longitude-of-sun-at-sunrise)) - (cos-local-sunrise - (/ (- (solar-cosine-degrees (+ 90 (/ 50.0 60.0))) - (* (solar-sin-degrees solar-declination-at-sunrise) - (solar-sin-degrees (calendar-latitude)))) - (* (solar-cosine-degrees solar-declination-at-sunrise) - (solar-cosine-degrees (calendar-latitude)))))) - (if (<= (abs cos-local-sunrise) 1);; otherwise, no sunrise that day - (let* ((local-sunrise (solar-degrees-to-hours - (- 360 (solar-arccos cos-local-sunrise)))) - (local-mean-sunrise - (mod (- (+ local-sunrise solar-right-ascension-at-sunrise) - (+ (* 0.065710 approx-sunrise) - 6.622)) - 24))) - (+ (- local-mean-sunrise (solar-degrees-to-hours (calendar-longitude))) - (/ calendar-time-zone 60.0)))))) - -(defun solar-sunset (date) - "Calculates the *standard* time of sunset for Gregorian DATE. -Calculation is for location given by `calendar-latitude' and -`calendar-longitude'. - -Returns a decimal fractions of hours. Returns nil if the sun does not set at -that location on that day." - (let* ((day-of-year (calendar-day-number date)) - (approx-sunset - (+ day-of-year - (solar-hours-to-days - (- 18 (solar-degrees-to-hours (calendar-longitude)))))) - (solar-longitude-of-sun-at-sunset - (solar-longitude-of-sun approx-sunset)) - (solar-right-ascension-at-sunset - (solar-right-ascension solar-longitude-of-sun-at-sunset)) - (solar-declination-at-sunset - (solar-declination solar-longitude-of-sun-at-sunset)) - (cos-local-sunset - (/ (- (solar-cosine-degrees (+ 90 (/ 50.0 60.0))) - (* (solar-sin-degrees solar-declination-at-sunset) - (solar-sin-degrees (calendar-latitude)))) - (* (solar-cosine-degrees solar-declination-at-sunset) - (solar-cosine-degrees (calendar-latitude)))))) - (if (<= (abs cos-local-sunset) 1);; otherwise, no sunset that day - (let* ((local-sunset (solar-degrees-to-hours - (solar-arccos cos-local-sunset))) - (local-mean-sunset - (mod (- (+ local-sunset solar-right-ascension-at-sunset) - (+ (* 0.065710 approx-sunset) 6.622)) - 24))) - (+ (- local-mean-sunset (solar-degrees-to-hours (calendar-longitude))) - (/ calendar-time-zone 60.0)))))) - -(defun solar-adj-time-for-dst (date time &optional style) - "Adjust decimal fraction standard TIME on DATE to account for dst. -Returns a list (date adj-time zone) where `date' and `time' are the values -adjusted for `zone'; here `date' is a list (month day year), `time' is a -decimal fraction time, and `zone' is a string. - -Optional parameter STYLE forces the result time to be standard time when its -value is 'standard and daylight savings time (if available) when its value is -'daylight. - -Conversion to daylight savings time is done according to -`calendar-daylight-savings-starts', `calendar-daylight-savings-ends', -`calendar-daylight-savings-starts-time', -`calendar-daylight-savings-ends-time', and -`calendar-daylight-savings-offset'." - - (let* ((year (extract-calendar-year date)) - (rounded-abs-date (+ (calendar-absolute-from-gregorian date) - (/ (round (* 60 time)) 60.0 24.0))) - (dst-starts (and calendar-daylight-savings-starts - (+ (calendar-absolute-from-gregorian - (eval calendar-daylight-savings-starts)) - (/ calendar-daylight-savings-starts-time - 60.0 24.0)))) - (dst-ends (and calendar-daylight-savings-ends - (+ (calendar-absolute-from-gregorian - (eval calendar-daylight-savings-ends)) - (/ (- calendar-daylight-savings-ends-time - calendar-daylight-time-offset) - 60.0 24.0)))) - (dst (and (not (eq style 'standard)) - (or (eq style 'daylight) - (and dst-starts dst-ends - (or (and (< dst-starts dst-ends);; northern hemi. - (<= dst-starts rounded-abs-date) - (< rounded-abs-date dst-ends)) - (and (< dst-ends dst-starts);; southern hemi. - (or (< rounded-abs-date dst-ends) - (<= dst-starts rounded-abs-date))))) - (and dst-starts (not dst-ends) - (<= dst-starts rounded-abs-date)) - (and dst-ends (not dst-starts) - (< rounded-abs-date dst-ends))))) - (time-zone (if dst - calendar-daylight-time-zone-name - calendar-standard-time-zone-name)) - (time (+ rounded-abs-date - (if dst (/ calendar-daylight-time-offset 24.0 60.0) 0)))) - (list (calendar-gregorian-from-absolute (truncate time)) - (* 24.0 (- time (truncate time))) - time-zone))) - -(defun solar-time-string (time time-zone) - "Printable form for decimal fraction TIME on DATE. -Format used is given by `calendar-time-display-form'." - (let* ((time (round (* 60 time))) - (24-hours (/ time 60)) - (minutes (format "%02d" (% time 60))) - (12-hours (format "%d" (1+ (% (+ 24-hours 11) 12)))) - (am-pm (if (>= 24-hours 12) "pm" "am")) - (24-hours (format "%02d" 24-hours))) - (mapconcat 'eval calendar-time-display-form ""))) - -(defun solar-sunrise-sunset (date) - "String giving local times of sunrise and sunset on Gregorian DATE." - (let* ((rise (solar-sunrise date)) - (adj-rise (if rise (solar-adj-time-for-dst date rise))) - (set (solar-sunset date)) - (adj-set (if set (solar-adj-time-for-dst date set)))) - (format "%s, %s at %s" - (if (and rise (calendar-date-equal date (car adj-rise))) - (concat "Sunrise " (apply 'solar-time-string (cdr adj-rise))) - "No sunrise") - (if (and set (calendar-date-equal date (car adj-set))) - (concat "sunset " (apply 'solar-time-string (cdr adj-set))) - "no sunset") - (eval calendar-location-name)))) - -(defun solar-apparent-longitude-of-sun (date) - "Apparent longitude of the sun on Gregorian DATE." - (let* ((time (/ (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian '(1 0.5 1900))) - 36525)) - (l (+ 279.69668 - (* 36000.76892 time) - (* 0.0003025 time time))) - (m (+ 358.47583 - (* 35999.04975 time) - (* -0.000150 time time) - (* -0.0000033 time time time))) - (c (+ (* (+ 1.919460 - (* -0.004789 time) - (* -0.000014 time time)) - (solar-sin-degrees m)) - (* (+ 0.020094 - (* -0.000100 time)) - (solar-sin-degrees (* 2 m))) - (* 0.000293 - (solar-sin-degrees (* 3 m))))) - (L (+ l c)) - (omega (+ 259.18 - (* -1934.142 time))) - (app (+ L - -0.00569 - (* -0.00479 - (solar-sin-degrees omega))))) - app)) - -(defun solar-ephemeris-correction (year) - "Difference in minutes between Ephemeris time and UTC in YEAR. -Value is only an approximation." - (let ((T (/ (- year 1900) 100.0))) - (+ 0.41 (* 1.2053 T) (* 0.4992 T T)))) - -(defun solar-equinoxes/solstices (k year) - "Date of equinox/solstice K for YEAR. K=0, spring equinox; K=1, summer -solstice; K=2, fall equinox; K=3, winter solstice. Accurate to within -several minutes." - (let ((date (list (+ 3 (* k 3)) 21 year)) - app - (correction 1000)) - (while (> correction 0.00001) - (setq app (mod (solar-apparent-longitude-of-sun date) 360)) - (setq correction (* 58 (solar-sin-degrees (- (* k 90) app)))) - (setq date (list (extract-calendar-month date) - (+ (extract-calendar-day date) correction) - year))) - (list (extract-calendar-month date) - (+ (extract-calendar-day date) (/ calendar-time-zone 60.0 24.0) - (- (/ (solar-ephemeris-correction year) 60.0 24.0))) - year))) - -;;;###autoload -(defun sunrise-sunset (&optional arg) - "Local time of sunrise and sunset for today. Accurate to +/- 2 minutes. -If called with an optional prefix argument, prompt for date. - -If called with an optional double prefix argument, prompt for longitude, -latitude, time zone, and date, and always use standard time. - -This function is suitable for execution in a .emacs file." - (interactive "p") - (or arg (setq arg 1)) - (if (and (< arg 16) - (not (and calendar-latitude calendar-longitude calendar-time-zone))) - (solar-setup)) - (let* ((calendar-longitude - (if (< arg 16) calendar-longitude - (solar-get-number - "Enter longitude (decimal fraction; + east, - west): "))) - (calendar-latitude - (if (< arg 16) calendar-latitude - (solar-get-number - "Enter latitude (decimal fraction; + north, - south): "))) - (calendar-time-zone - (if (< arg 16) calendar-time-zone - (solar-get-number - "Enter difference from Coordinated Universal Time (in minutes): "))) - (calendar-location-name - (if (< arg 16) calendar-location-name - (let ((float-output-format "%.1f")) - (format "%s%s, %s%s" - (if (numberp calendar-latitude) - (abs calendar-latitude) - (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0))) - (if (numberp calendar-latitude) - (if (> calendar-latitude 0) "N" "S") - (if (equal (aref calendar-latitude 2) 'north) "N" "S")) - (if (numberp calendar-longitude) - (abs calendar-longitude) - (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0))) - (if (numberp calendar-longitude) - (if (> calendar-longitude 0) "E" "W") - (if (equal (aref calendar-latitude 2) 'east) - "E" "W")))))) - (calendar-standard-time-zone-name - (if (< arg 16) calendar-standard-time-zone-name - (cond ((= calendar-time-zone 0) "UTC") - ((< calendar-time-zone 0) - (format "UTC%dmin" calendar-time-zone)) - (t (format "UTC+%dmin" calendar-time-zone))))) - (calendar-daylight-savings-starts - (if (< arg 16) calendar-daylight-savings-starts)) - (calendar-daylight-savings-ends - (if (< arg 16) calendar-daylight-savings-ends)) - (date (if (< arg 4) (calendar-current-date) (calendar-read-date))) - (date-string (calendar-date-string date t)) - (time-string (solar-sunrise-sunset date)) - (msg (format "%s: %s" date-string time-string)) - (one-window (one-window-p t))) - (if (<= (length msg) (frame-width)) - (message msg) - (with-output-to-temp-buffer "*temp*" - (princ (concat date-string "\n" time-string))) - (message (substitute-command-keys - (if one-window - (if pop-up-windows - "Type \\[delete-other-windows] to remove temp window." - "Type \\[switch-to-buffer] RET to remove temp window.") - "Type \\[switch-to-buffer-other-window] RET to restore old contents of temp window.")))))) - -(defun calendar-sunrise-sunset () - "Local time of sunrise and sunset for date under cursor. -Accurate to +/- 2 minutes." - (interactive) - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (let ((date (calendar-cursor-to-date t))) - (message "%s: %s" - (calendar-date-string date t t) - (solar-sunrise-sunset date)))) - -(defun diary-sunrise-sunset () - "Local time of sunrise and sunset as a diary entry. -Accurate to +/- 2 minutes." - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (solar-sunrise-sunset date)) - -(defun diary-sabbath-candles () - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (if (= (% (calendar-absolute-from-gregorian date) 7) 5);; Friday - (let* ((sunset (solar-sunset date)) - (light (if sunset - (solar-adj-time-for-dst - date - (- sunset (/ 18.0 60.0)))))) - (if (and light (calendar-date-equal date (car light))) - (format "%s Sabbath candle lighting" - (apply 'solar-time-string (cdr light))))))) - -;;;###autoload -(defun solar-equinoxes-solstices () - "Date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (cond ((= 1 (% m 3)) -1) - ((= 2 (% m 3)) 1) - (t 0))) - (let* ((calendar-standard-time-zone-name - (if calendar-time-zone calendar-standard-time-zone-name "UTC")) - (calendar-daylight-savings-starts - (if calendar-time-zone calendar-daylight-savings-starts)) - (calendar-daylight-savings-ends - (if calendar-time-zone calendar-daylight-savings-ends)) - (calendar-time-zone (if calendar-time-zone calendar-time-zone 0)) - (k (1- (/ m 3))) - (date (solar-equinoxes/solstices k y)) - (s-hemi (and calendar-latitude (< (calendar-latitude) 0))) - (day (extract-calendar-day date)) - (adj (solar-adj-time-for-dst - (list (extract-calendar-month date) - (truncate day) - (extract-calendar-year date)) - (* 24 (- day (truncate day)))))) - (list (list (car adj) - (format "%s %s" - (nth k (if s-hemi solar-s-hemi-seasons - solar-n-hemi-seasons)) - (apply 'solar-time-string (cdr adj)))))))) - -(provide 'solar) - -;;; solar.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/cc-mode/custom-load.el --- a/lisp/cc-mode/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/cc-mode/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,9 +1,8 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:06 1997 ;;; Code: -(custom-put 'c 'custom-loads '("cc-vars")) +(custom-add-loads 'c '("cc-vars")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/cl/auto-autoloads.el --- a/lisp/cl/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/cl/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,5 +1,7 @@ ;;; DO NOT MODIFY THIS FILE (if (featurep 'cl-autoloads) (error "Already loaded")) + +(provide 'cl-autoloads) ;;;### (autoloads (compiler-macroexpand define-compiler-macro ignore-errors assert check-type typep deftype cl-struct-setf-expander defstruct define-modify-macro callf2 callf letf* letf rotatef shiftf remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method declare the locally multiple-value-setq multiple-value-bind lexical-let* lexical-let symbol-macrolet macrolet labels flet progv psetq do-all-symbols do-symbols dotimes dolist do* do loop return-from return block etypecase typecase ecase case load-time-value eval-when destructuring-bind function* defmacro* defun* gentemp gensym cl-compile-time-init) "cl-macs" "cl/cl-macs.el") @@ -327,5 +329,3 @@ (autoload 'compiler-macroexpand "cl-macs" nil nil nil) ;;;*** - -(provide 'cl-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/cl/cl-macs.el --- a/lisp/cl/cl-macs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/cl/cl-macs.el Mon Aug 13 10:03:52 2007 +0200 @@ -1599,7 +1599,7 @@ (defsetf elt (seq n) (store) (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store) (list 'aset seq n store))) -(defsetf get put) +(defsetf get (x y &optional d) (store) (list 'put x y store)) (defsetf get* (x y &optional d) (store) (list 'put x y store)) (defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h)) (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) @@ -1643,8 +1643,8 @@ (defsetf extent-data set-extent-data) ; obsolete (defsetf extent-face set-extent-face) (defsetf extent-priority set-extent-priority) -;; XEmacs change -(defsetf extent-property set-extent-property) +(defsetf extent-property (x y &optional d) (arg) + (list 'set-extent-property x y arg)) (defsetf extent-end-position (ext) (store) (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) store) store)) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/comint/auto-autoloads.el --- a/lisp/comint/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -47,7 +47,7 @@ ;;;*** -;;;### (autoloads (gdb) "gdb" "comint/gdb.el") +;;;### (autoloads (gdb-with-core gdb) "gdb" "comint/gdb.el") (defvar gdb-command-name "gdb" "\ Pathname for executing gdb.") @@ -58,6 +58,9 @@ and source-file directory for GDB. If you wish to change this, use the GDB commands `cd DIR' and `directory'." t nil) +(autoload 'gdb-with-core "gdb" "\ +Debug a program using a corefile." t nil) + ;;;*** ;;;### (autoloads (gdbsrc) "gdbsrc" "comint/gdbsrc.el") diff -r d3e9274cbc4e -r e45d5e7c476e lisp/comint/comint.el --- a/lisp/comint/comint.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/comint.el Mon Aug 13 10:03:52 2007 +0200 @@ -228,7 +228,8 @@ See also `comint-read-input-ring' and `comint-write-input-ring'. This variable is buffer-local, and is a good thing to set in mode hooks." - :type 'boolean + :type '(choice (const :tag "None" nil) + (file)) :group 'comint) (defcustom comint-scroll-to-bottom-on-input nil @@ -262,14 +263,21 @@ (const others)) :group 'comint) -;; XEmacs - Default this to nil: this is just horrible -(defcustom comint-scroll-show-maximum-output nil +(defcustom comint-scroll-show-maximum-output t "*Controls how interpreter output causes window to scroll. If non-nil, then show the maximum output when the window is scrolled. +You may set this to an integer number of lines to keep shown, or a +floating point percentage of the window size to keep filled. +A negative number expresses a distance from the bottom, as when using +a prefix argument with `recenter' (bound to `\\[recenter]'). + See variable `comint-scroll-to-bottom-on-output' and function `comint-postoutput-scroll-to-bottom'. This variable is buffer-local." - :type 'boolean + :type '(choice (const :tag "Off" nil) + (const :tag "On" t) + (integer :tag "Number of lines" 20) + (number :tag "Decimal Percent of window" .85)) :group 'comint) (defcustom comint-buffer-maximum-size 1024 @@ -1584,14 +1592,15 @@ (set-window-point window (point-max)) (recenter ;; XEmacs - lemacs addition -;; (cond ((integerp comint-scroll-show-maximum-output) -;; comint-scroll-show-maximum-output) -;; ((floatp comint-scroll-show-maximum-output) -;; (floor (* (window-height window) -;; comint-scroll-show-maximum-output) -;; 1)) -;; (t -;; -1)) + (cond ((integerp comint-scroll-show-maximum-output) + comint-scroll-show-maximum-output) + ((floatp comint-scroll-show-maximum-output) + (floor (* (window-height window) + comint-scroll-show-maximum-output) + 1)) + (t + -1)) + window ))) )))) nil t)))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/comint/custom-load.el --- a/lisp/comint/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,20 +1,19 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Oct 4 18:11:23 1997 ;;; Code: -(custom-put 'ssh 'custom-loads '("ssh")) -(custom-put 'telnet 'custom-loads '("telnet")) -(custom-put 'shell 'custom-loads '("shell")) -(custom-put 'comint-completion 'custom-loads '("comint")) -(custom-put 'comint 'custom-loads '("comint-xemacs" "comint" "telnet")) -(custom-put 'rlogin 'custom-loads '("rlogin")) -(custom-put 'shell-faces 'custom-loads '("shell")) -(custom-put 'shell-directories 'custom-loads '("shell")) -(custom-put 'comint-source 'custom-loads '("comint")) -(custom-put 'processes 'custom-loads '("background" "comint" "rlogin" "shell" "ssh")) -(custom-put 'background 'custom-loads '("background")) -(custom-put 'unix 'custom-loads '("rlogin" "shell" "ssh")) +(custom-add-loads 'ssh '("ssh")) +(custom-add-loads 'telnet '("telnet")) +(custom-add-loads 'shell '("shell")) +(custom-add-loads 'comint-completion '("comint")) +(custom-add-loads 'comint '("comint-xemacs" "comint" "telnet")) +(custom-add-loads 'rlogin '("rlogin")) +(custom-add-loads 'shell-faces '("shell")) +(custom-add-loads 'shell-directories '("shell")) +(custom-add-loads 'comint-source '("comint")) +(custom-add-loads 'processes '("background" "comint" "rlogin" "shell" "ssh")) +(custom-add-loads 'background '("background")) +(custom-add-loads 'unix '("rlogin" "shell" "ssh")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/comint/gdb.el --- a/lisp/comint/gdb.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/gdb.el Mon Aug 13 10:03:52 2007 +0200 @@ -331,7 +331,7 @@ (gdb-mode) (gdb-set-buffer))) -;;;####autoload +;;;###autoload (defun gdb-with-core (file corefile) "Debug a program using a corefile." (interactive "fProgram to debug: \nfCore file to use: ") diff -r d3e9274cbc4e -r e45d5e7c476e lisp/custom/auto-autoloads.el --- a/lisp/custom/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -138,7 +138,7 @@ (autoload 'customize-menu-create "cus-edit" "\ Return a customize menu for customization group SYMBOL. -If optional NAME is given, use that as the name of the menu. +If optional NAME is given, use that as the name of the menu. Otherwise the menu will be named `Customize'. The format is suitable for use with `easy-menu-define'." nil nil) @@ -186,7 +186,7 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil." nil nil) (autoload 'widget-create "wid-edit" "\ -Create widget of TYPE. +Create widget of TYPE. The optional ARGS are additional keyword arguments." nil nil) (autoload 'widget-delete "wid-edit" "\ diff -r d3e9274cbc4e -r e45d5e7c476e lisp/custom/cus-dep.el --- a/lisp/custom/cus-dep.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-dep.el Mon Aug 13 10:03:52 2007 +0200 @@ -33,7 +33,7 @@ ;; This file generates the custom-load files, loaded by cus-load.el. ;; The only entry point is `Custom-make-dependencies'. -;; It works so that it scans all the `.el' files in a directory, and +;; It works by scanning all the `.el' files in a directory, and ;; evaluates any `defcustom', `defgroup', or `defface' expression that ;; it finds. The symbol changed by this expression is stored to a ;; hash table as the hash key, file name being the value. @@ -50,14 +50,20 @@ ;; custom-loads around, and have them loaded by `cus-load.el' (as ;; invoked by `cus-edit.el'). -;; A trivial, but crucial optimization is that if cusload-file exists, +;; A trivial, but useful optimization is that if cusload-file exists, ;; and no .el files in the directory are newer than cusload-file, it ;; will not be generated. This means that the directories where ;; nothing has changed will be skipped. -;; The `custom-put' function, generated by this file, is a specialized -;; form of `put' that deals with lists, eliminating the duplicates. -;; For instance: +;; The `custom-put' function, used by files generated by +;; `Custom-make-dependencies', is a specialized function that updates +;; a property (which must be a list of strings) with a new list of +;; strings, eliminating the duplicates. As it also adds an +;; appropriate entry to a custom hash-table, *do not* use it outside +;; of custom. Its inner workings can change anytime, without prior +;; notice. `custom-put' is defined in `cus-load.el'. + +;; Example: ;; (custom-put 'foo 'custom-loads '("bar" "baz")) ;; (get 'foo 'custom-loads) @@ -83,6 +89,10 @@ ;; cus-start.el, too. (defconst cusload-base-file "custom-load.el") +;; Be very careful when changing this function. It looks easy to +;; understand, but is in fact very easy to break. Be sure to read and +;; understand the commentary above! + ;;;###autoload (defun Custom-make-dependencies (&optional subdirs) "Extract custom dependencies from .el files in SUBDIRS. @@ -106,7 +116,7 @@ (princ (format "Processing %s\n" dir)) (let ((cusload-file (expand-file-name cusload-base-file dir)) (files (directory-files dir t "\\`[^=].*\\.el\\'"))) - ;; A trivial optimization: if no files in the directory is + ;; A trivial optimization: if no file in the directory is ;; newer than custom-load.el, no need to do anything! (if (and (file-exists-p cusload-file) (dolist (file files t) @@ -121,15 +131,17 @@ (goto-char (point-min)) (let ((name (file-name-sans-extension (file-name-nondirectory file)))) - (condition-case nil - (while (re-search-forward - "^(defcustom\\|^(defface\\|^(defgroup" - nil t) - (beginning-of-line) - (let ((expr (read (current-buffer)))) - (eval expr) - (setf (gethash (nth 1 expr) hash) name))) - (error nil))))) + ;; Search for defcustom/defface/defgroup + ;; expressions, and evaluate them. + (ignore-errors + (while (re-search-forward + "^(defcustom\\|^(defface\\|^(defgroup" + nil t) + (beginning-of-line) + (let ((expr (read (current-buffer)))) + (eval expr) + ;; Hash the file of the affected symbol. + (setf (gethash (nth 1 expr) hash) name))))))) (cond ((zerop (hash-table-count hash)) (princ "(No customization dependencies") @@ -142,8 +154,7 @@ (with-temp-file cusload-file (insert ";;; " cusload-base-file " --- automatically extracted custom dependencies\n" - "\n;; Created by " (user-full-name) " on " - (current-time-string) "\n\n;;; Code:\n\n") + "\n\n;;; Code:\n\n") (mapatoms (lambda (sym) (let ((members (get sym 'custom-group)) @@ -157,8 +168,8 @@ (member where found)) (if found (insert " ") - (insert "(custom-put '" (symbol-name sym) - " 'custom-loads '(")) + (insert "(custom-add-loads '" + (symbol-name sym) " '(")) (prin1 where (current-buffer)) (push where found))) (when found diff -r d3e9274cbc4e -r e45d5e7c476e lisp/custom/cus-edit.el --- a/lisp/custom/cus-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-edit.el Mon Aug 13 10:03:52 2007 +0200 @@ -28,7 +28,7 @@ ;;; Commentary: ;; ;; This file implements the code to create and edit customize buffers. -;; +;; ;; See `custom.el'. ;; No commands should have names starting with `custom-' because @@ -235,7 +235,7 @@ (defgroup customize '((widgets custom-group)) "Customization of the Customization support." :link '(custom-manual "(custom)Top") - :link '(url-link :tag "Development Page" + :link '(url-link :tag "Development Page" "http://www.dina.kvl.dk/~abraham/custom/") :prefix "custom-" :group 'help) @@ -347,30 +347,22 @@ (defun custom-quote (sexp) "Quote SEXP iff it is not self quoting." (if (or (memq sexp '(t nil)) - (and (symbolp sexp) - (eq (aref (symbol-name sexp) 0) ?:)) - (and (listp sexp) - (memq (car sexp) '(lambda))) + (keywordp sexp) + (eq (car-safe sexp) 'lambda) (stringp sexp) (numberp sexp) - (and (fboundp 'characterp) - (characterp sexp))) + (characterp sexp)) sexp (list 'quote sexp))) (defun custom-split-regexp-maybe (regexp) "If REGEXP is a string, split it to a list at `\\|'. -You can get the original back with from the result with: +You can get the original back with from the result with: (mapconcat 'identity result \"\\|\") IF REGEXP is not a string, return it unchanged." (if (stringp regexp) - (let ((start 0) - all) - (while (string-match "\\\\|" regexp start) - (setq all (cons (substring regexp start (match-beginning 0)) all) - start (match-end 0))) - (nreverse (cons (substring regexp start) all))) + (split-string regexp "\\\\|") regexp)) (defun custom-variable-prompt () @@ -380,9 +372,9 @@ (let ((v (variable-at-point)) (enable-recursive-minibuffers t) val) - (setq val (completing-read + (setq val (completing-read (if (symbolp v) - (format "Customize option: (default %s) " v) + (format "Customize variable: (default %s) " v) "Customize variable: ") obarray (lambda (symbol) (and (boundp symbol) @@ -409,7 +401,7 @@ WIDGET is the widget to apply the filter entries of MENU on." (let ((result nil) current name action filter) - (while menu + (while menu (setq current (car menu) name (nth 0 current) action (nth 1 current) @@ -459,13 +451,13 @@ (while prefixes (setq prefix (car prefixes)) (if (search-forward prefix (+ (point) (length prefix)) t) - (progn + (progn (setq prefixes nil) (delete-region (point-min) (point))) (setq prefixes (cdr prefixes)))))) (subst-char-in-region (point-min) (point-max) ?- ?\ t) (capitalize-region (point-min) (point-max)) - (unless no-suffix + (unless no-suffix (goto-char (point-max)) (insert "...")) (buffer-string))))) @@ -491,7 +483,7 @@ (defcustom custom-guess-name-alist '(("-p\\'" boolean) - ("-hook\\'" hook) + ("-hooks?\\'" hook) ("-face\\'" face) ("-file\\'" file) ("-function\\'" function) @@ -500,10 +492,10 @@ ("-alist\\'" (repeat (cons sexp sexp)))) "Alist of (MATCH TYPE). -MATCH should be a regexp matching the name of a symbol, and TYPE should +MATCH should be a regexp matching the name of a symbol, and TYPE should be a widget suitable for editing the value of that symbol. The TYPE of the first entry where MATCH matches the name of the symbol will be -used. +used. This is used for guessing the type of variables not declared with customize." @@ -526,7 +518,7 @@ (defun custom-guess-type (symbol) "Guess a widget suitable for editing the value of SYMBOL. -This is done by matching SYMBOL with `custom-guess-name-alist' and +This is done by matching SYMBOL with `custom-guess-name-alist' and if that fails, the doc string with `custom-guess-doc-alist'." (let ((name (symbol-name symbol)) (names custom-guess-name-alist) @@ -540,7 +532,7 @@ (unless found (let ((doc (documentation-property symbol 'variable-documentation)) (docs custom-guess-doc-alist)) - (when doc + (when doc (while docs (setq current (car docs) docs (cdr docs)) @@ -651,7 +643,7 @@ children)) (custom-save-all)) -(defvar custom-reset-menu +(defvar custom-reset-menu '(("Current" . Custom-reset-current) ("Saved" . Custom-reset-saved) ("Standard Settings" . Custom-reset-standard)) @@ -741,10 +733,10 @@ it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value." +`:prompt-value' property of that widget will be used for reading the value." (interactive (custom-prompt-variable "Set variable: " "Set %s to value: ")) - + (set var val)) ;;;###autoload @@ -761,7 +753,7 @@ it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " +`:prompt-value' property of that widget will be used for reading the value. " (interactive (custom-prompt-variable "Set variable: " "Set customized value for %s to: ")) (funcall (or (get var 'custom-set) 'set-default) var val) @@ -780,7 +772,7 @@ it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " +`:prompt-value' property of that widget will be used for reading the value. " (interactive (custom-prompt-variable "Set and ave variable: " "Set and save value for %s as: ")) (funcall (or (get var 'custom-set) 'set-default) var val) @@ -853,7 +845,7 @@ (defun customize-face (&optional symbol) "Customize SYMBOL, which should be a face name or nil. If SYMBOL is nil, customize all faces." - (interactive (list (completing-read "Customize face: (default all) " + (interactive (list (completing-read "Customize face: (default all) " obarray 'find-face))) (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) (custom-buffer-create (custom-sort-items @@ -873,7 +865,7 @@ ;;;###autoload (defun customize-face-other-window (&optional symbol) "Show customization buffer for FACE in other window." - (interactive (list (completing-read "Customize face: " + (interactive (list (completing-read "Customize face: " obarray 'find-face))) (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) () @@ -881,7 +873,7 @@ (setq symbol (intern symbol))) (unless (symbolp symbol) (error "Should be a symbol %S" symbol)) - (custom-buffer-create-other-window + (custom-buffer-create-other-window (list (list symbol 'custom-face)) (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol))))) @@ -1014,7 +1006,7 @@ (custom-buffer-create-internal options description) (select-window window))) -(defcustom custom-reset-button-menu nil +(defcustom custom-reset-button-menu t "If non-nil, only show a single reset button in customize buffers. This button will have a menu with all three reset operations." :type 'boolean @@ -1031,7 +1023,7 @@ (widget-insert ".\n\ Type RET or click button2 on an active field to invoke its action. Invoke ") - (widget-create 'info-link + (widget-create 'info-link :tag "Help" :help-echo "Read the online help" "(XEmacs)Easy Customization") @@ -1040,6 +1032,7 @@ (widget-insert "Operate on everything in this buffer:\n ") (widget-create 'push-button :tag "Set" + :tag-glyph '("set-up" "set-down") :help-echo "\ Make your editing in this buffer take effect for this session" :action (lambda (widget &optional event) @@ -1047,6 +1040,7 @@ (widget-insert " ") (widget-create 'push-button :tag "Save" + :tag-glyph '("save-up" "save-down") :help-echo "\ Make your editing in this buffer take effect for future Emacs sessions" :action (lambda (widget &optional event) @@ -1056,6 +1050,7 @@ (widget-insert " ") (widget-create 'push-button :tag "Reset" + :tag-glyph '("reset-up" "reset-down") :help-echo "Show a menu with reset operations" :mouse-down-action (lambda (&rest junk) t) :action (lambda (widget &optional event) @@ -1081,12 +1076,13 @@ (widget-insert " ") (widget-create 'push-button :tag "Done" + :tag-glyph '("done-up" "done-down") :help-echo "Bury the buffer" :action (lambda (widget &optional event) (bury-buffer))) (widget-insert "\n\n") (message "Creating customization items...") - (setq custom-options + (setq custom-options (if (= (length options) 1) (mapcar (lambda (entry) (widget-create (nth 1 entry) @@ -1139,31 +1135,31 @@ (switch-to-buffer (get-buffer-create name))) (custom-mode) (widget-insert "\ -Square brackets show active fields; type RET or click mouse-2 +Square brackets show active fields; type RET or click button2 on an active field to invoke its action. Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n") (if custom-browse-only-groups (widget-insert "\ Invoke the [Group] button below to edit that item in another window.\n\n") - (widget-insert "Invoke the ") - (widget-create 'item + (widget-insert "Invoke the ") + (widget-create 'item :format "%t" :tag "[Group]" :tag-glyph "folder") (widget-insert ", ") - (widget-create 'item + (widget-create 'item :format "%t" :tag "[Face]" :tag-glyph "face") (widget-insert ", and ") - (widget-create 'item + (widget-create 'item :format "%t" :tag "[Option]" :tag-glyph "option") (widget-insert " buttons below to edit that item in another window.\n\n")) (let ((custom-buffer-style 'tree)) - (widget-create 'custom-group + (widget-create 'custom-group :custom-last t :custom-state 'unknown :tag (custom-unlispify-tag-name group) @@ -1219,7 +1215,7 @@ "Insert PREFIX. On XEmacs convert it to line graphics." ;; ### Unfinished. (if nil ; (string-match "XEmacs" emacs-version) - (progn + (progn (insert "*") (while (not (string-equal prefix "")) (let ((entry (substring prefix 0 3))) @@ -1278,21 +1274,21 @@ "Face used when the customize item is not defined for customization." :group 'custom-magic-faces) -(defface custom-modified-face '((((class color)) +(defface custom-modified-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t :bold))) "Face used when the customize item has been modified." :group 'custom-magic-faces) -(defface custom-set-face '((((class color)) +(defface custom-set-face '((((class color)) (:foreground "blue" :background "white")) (t (:italic t))) "Face used when the customize item has been set." :group 'custom-magic-faces) -(defface custom-changed-face '((((class color)) +(defface custom-changed-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t))) @@ -1308,8 +1304,8 @@ (unknown "?" italic "\ unknown, you should not see this.") (hidden "-" default "\ -hidden, invoke \"Show\" in the previous line to show." "\ -group now hidden, invoke \"Show\", above, to show contents.") +hidden, invoke \"Show\" button in the previous line to show." "\ +group now hidden, invoke the above \"Show\" button to show contents.") (invalid "x" custom-invalid-face "\ the value displayed for this %c is invalid and cannot be set.") (modified "*" custom-modified-face "\ @@ -1331,7 +1327,7 @@ this %c is unchanged from its standard setting." "\ visible group members are all at standard settings.")) "Alist of customize option states. -Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where +Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where STATE is one of the following symbols: @@ -1340,7 +1336,7 @@ `unknown' For internal use, should never occur. `hidden' - This item is not being displayed. + This item is not being displayed. `invalid' This item is modified, but has an invalid form. `modified' @@ -1402,7 +1398,7 @@ (defun widget-magic-mouse-down-action (widget &optional event) ;; Non-nil unless hidden. - (not (eq (widget-get (widget-get (widget-get widget :parent) :parent) + (not (eq (widget-get (widget-get (widget-get widget :parent) :parent) :custom-state) 'hidden))) @@ -1421,7 +1417,7 @@ (form (widget-get parent :custom-form)) children) (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text) - (setq text (concat (match-string 1 text) + (setq text (concat (match-string 1 text) (symbol-name category) (match-string 2 text)))) (when (and custom-magic-show @@ -1433,14 +1429,16 @@ (> (widget-get parent :custom-level) 1)))) (insert-char ?\ (* custom-buffer-indent (widget-get parent :custom-level)))) - (push (widget-create-child-and-convert - widget 'choice-item + (push (widget-create-child-and-convert + widget 'choice-item :help-echo "Change the state of this item" :format (if hidden "%t" "%[%t%]") :button-prefix 'widget-push-button-prefix :button-suffix 'widget-push-button-suffix :mouse-down-action 'widget-magic-mouse-down-action - :tag "State") + :tag "State" + ;;:tag-glyph (or hidden '("state-up" "state-down")) + ) children) (insert ": ") (let ((start (point))) @@ -1462,9 +1460,9 @@ (when custom-magic-show (let ((indent (widget-get parent :indent))) (when indent - (insert-char ? indent)))) - (push (widget-create-child-and-convert - widget 'choice-item + (insert-char ?\ indent)))) + (push (widget-create-child-and-convert + widget 'choice-item :mouse-down-action 'widget-magic-mouse-down-action :button-face face :button-prefix "" @@ -1521,7 +1519,7 @@ (defun custom-convert-widget (widget) ;; Initialize :value and :tag from :args in WIDGET. (let ((args (widget-get widget :args))) - (when args + (when args (widget-put widget :value (widget-apply widget :value-to-internal (car args))) (widget-put widget :tag (custom-unlispify-tag-name (car args))) @@ -1549,7 +1547,7 @@ (custom-redraw-magic widget)) (when (and (>= pos from) (<= pos to)) (condition-case nil - (progn + (progn (if (> column 0) (goto-line line) (goto-line (1+ line))) @@ -1558,9 +1556,9 @@ (defun custom-redraw-magic (widget) "Redraw WIDGET state with current settings." - (while widget + (while widget (let ((magic (widget-get widget :custom-magic))) - (cond (magic + (cond (magic (widget-value-set magic (widget-value magic)) (when (setq widget (widget-get widget :group)) (custom-group-state-update widget))) @@ -1584,7 +1582,7 @@ (defun custom-load-symbol (symbol) "Load all dependencies for SYMBOL." (unless custom-load-recursion - (let ((custom-load-recursion t) + (let ((custom-load-recursion t) (loads (get symbol 'custom-loads)) load) (while loads @@ -1625,6 +1623,7 @@ (setq found t))) ((assoc load load-history)) ((assoc (locate-library load) load-history) + ;; #### WTF??? (message nil)) (t (setq found t)))) @@ -1642,7 +1641,7 @@ (error "There are unset changes")) ((eq state 'hidden) (widget-put widget :custom-state 'unknown)) - (t + (t (widget-put widget :documentation-shown nil) (widget-put widget :custom-state 'hidden))) (custom-redraw widget) @@ -1676,7 +1675,7 @@ (if many (insert ", and ") (insert " and "))) - (t + (t (insert ", ")))) (widget-put widget :buttons buttons)))) @@ -1694,8 +1693,8 @@ (let ((entry (assq name (get group 'custom-group)))) (when (eq (nth 1 entry) type) (insert " ") - (push (widget-create-child-and-convert - widget 'custom-group-link + (push (widget-create-child-and-convert + widget 'custom-group-link :tag (custom-unlispify-tag-name group) group) buttons) @@ -1742,7 +1741,7 @@ (defun custom-variable-type (symbol) "Return a widget suitable for editing the value of SYMBOL. -If SYMBOL has a `custom-type' property, use that. +If SYMBOL has a `custom-type' property, use that. Otherwise, look up symbol in `custom-guess-type-alist'." (let* ((type (or (get symbol 'custom-type) (and (not (get symbol 'standard-value)) @@ -1794,14 +1793,14 @@ (widget-put widget :buttons buttons)) ((eq state 'hidden) ;; Indicate hidden value. - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'item :format "%{%t%}: " :sample-face 'custom-variable-tag-face :tag tag :parent widget) buttons) - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Show the value of this option" :action 'custom-toggle-parent @@ -1818,15 +1817,15 @@ (t (custom-quote (widget-get conv :value)))))) (insert (symbol-name symbol) ": ") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide the value of this option" :action 'custom-toggle-parent t) buttons) (insert " ") - (push (widget-create-child-and-convert - widget 'sexp + (push (widget-create-child-and-convert + widget 'sexp :button-face 'custom-variable-button-face :format "%v" :tag (symbol-name symbol) @@ -1842,7 +1841,7 @@ (setq tag-format (substring format 0 (match-end 0))) (setq value-format (substring format (match-end 0))) (push (widget-create-child-and-convert - widget 'item + widget 'item :format tag-format :action 'custom-tag-action :help-echo "Change value of this option" @@ -1852,14 +1851,14 @@ tag) buttons) (insert " ") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide the value of this option" :action 'custom-toggle-parent t) - buttons) + buttons) (push (widget-create-child-and-convert - widget type + widget type :format value-format :value value) children)))) @@ -1876,7 +1875,7 @@ (widget-put widget :custom-magic magic) (push magic buttons)) ;; Update properties. - (widget-put widget :custom-form form) + (widget-put widget :custom-form form) (widget-put widget :buttons buttons) (widget-put widget :children children) ;; Insert documentation. @@ -1926,7 +1925,7 @@ (t 'rogue)))) (widget-put widget :custom-state state))) -(defvar custom-variable-menu +(defvar custom-variable-menu '(("Set for Current Session" custom-variable-set (lambda (widget) (eq (widget-get widget :custom-state) 'modified))) @@ -1948,7 +1947,7 @@ (memq (widget-get widget :custom-state) '(modified set changed saved rogue))))) ("---" ignore ignore) - ("Don't show as Lisp expression" custom-variable-edit + ("Don't show as Lisp expression" custom-variable-edit (lambda (widget) (eq (widget-get widget :custom-form) 'lisp))) ("Show as Lisp expression" custom-variable-edit-lisp @@ -1968,7 +1967,8 @@ (custom-toggle-hide widget) (unless (eq (widget-get widget :custom-state) 'modified) (custom-variable-state-set widget)) - (custom-redraw-magic widget) + ;; Redrawing magic also depresses the state glyph. + ;(custom-redraw-magic widget) (let* ((completion-ignore-case t) (answer (widget-choose (concat "Operation on " (custom-unlispify-tag-name @@ -2075,10 +2075,10 @@ :extra-offset 12 :button-args '(:help-echo "Control whether this attribute have any effect") :args (mapcar (lambda (att) - (list 'group + (list 'group :inline t :sibling-args (widget-get (nth 1 att) :sibling-args) - (list 'const :format "" :value (nth 0 att)) + (list 'const :format "" :value (nth 0 att)) (nth 1 att))) custom-face-attributes)) @@ -2176,7 +2176,7 @@ :custom-reset-standard 'custom-face-reset-standard :custom-menu 'custom-face-menu-create) -(define-widget 'custom-face-all 'editable-list +(define-widget 'custom-face-all 'editable-list "An editable list of display specifications and attributes." :entry-format "%i %d %v" :insert-button-args '(:help-echo "Insert new display specification here") @@ -2195,7 +2195,7 @@ "Non-nil if VALUE is an unselected display specification." (not (face-spec-set-match-display value (selected-frame)))) -(define-widget 'custom-face-selected 'group +(define-widget 'custom-face-selected 'group "Edit the attributes of the selected display in a face specification." :args '((repeat :format "" :inline t @@ -2236,7 +2236,7 @@ ;; Sample. (and (not (find-face symbol)) ;; XEmacs cannot display uninitialized faces. - (copy-face 'custom-face-empty symbol)) + (make-face symbol)) (push (widget-create-child-and-convert widget 'item :format "(%{%t%})" :sample-face symbol @@ -2244,7 +2244,7 @@ buttons) ;; Visibility. (insert " ") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide or show this face" :action 'custom-toggle-parent @@ -2275,14 +2275,14 @@ (spec (or (get symbol 'saved-face) (get symbol 'face-defface-spec) ;; Attempt to construct it. - (list (list t (face-custom-attributes-get + (list (list t (face-custom-attributes-get symbol (selected-frame)))))) (form (widget-get widget :custom-form)) (indent (widget-get widget :indent)) (edit (widget-create-child-and-convert widget (cond ((and (eq form 'selected) - (widget-apply custom-face-selected + (widget-apply custom-face-selected :match spec)) (when indent (insert-char ?\ indent)) 'custom-face-selected) @@ -2290,7 +2290,7 @@ (widget-apply custom-face-all :match spec)) 'custom-face-all) - (t + (t (when indent (insert-char ?\ indent)) 'sexp)) :value spec))) @@ -2298,7 +2298,7 @@ (widget-put widget :children (list edit))) (message "Creating face editor...done")))))) -(defvar custom-face-menu +(defvar custom-face-menu '(("Set for Current Session" custom-face-set) ("Save for Future Sessions" custom-face-save) ("Reset to Saved" custom-face-reset-saved @@ -2351,7 +2351,7 @@ 'saved) ((get symbol 'face-defface-spec) 'standard) - (t + (t 'rogue))))) (defun custom-face-action (widget &optional event) @@ -2463,7 +2463,7 @@ (mapcar (lambda (face) (list (symbol-name face))) (face-list)) - nil nil nil + nil nil nil 'face-history))) (unless (zerop (length answer)) (widget-value-set widget (intern answer)) @@ -2480,14 +2480,14 @@ value)) :match (lambda (widget value) (or (symbolp value) - (widget-editable-list-match widget value))) + (widget-group-match widget value))) :convert-widget 'custom-hook-convert-widget :tag "Hook") (defun custom-hook-convert-widget (widget) ;; Handle `:custom-options'. (let* ((options (widget-get widget :options)) - (other `(editable-list :inline t + (other `(editable-list :inline t :entry-format "%i %d%v" (function :format " %v"))) (args (if options @@ -2603,7 +2603,7 @@ (or members (custom-unloaded-widget-p widget))) (custom-browse-insert-prefix prefix) (push (widget-create-child-and-convert - widget 'custom-browse-visibility + widget 'custom-browse-visibility ;; :tag-glyph "plus" :tag "+") buttons) @@ -2620,7 +2620,7 @@ (insert "[ ]-- ") ;; (widget-glyph-insert nil "[ ]" "empty") ;; (widget-glyph-insert nil "-- " "horizontal") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) (insert " " tag "\n") @@ -2629,24 +2629,24 @@ (custom-browse-insert-prefix prefix) (custom-load-widget widget) (if (zerop (length members)) - (progn + (progn (custom-browse-insert-prefix prefix) (insert "[ ]-- ") ;; (widget-glyph-insert nil "[ ]" "empty") ;; (widget-glyph-insert nil "-- " "horizontal") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) (insert " " tag "\n") (widget-put widget :buttons buttons)) - (push (widget-create-child-and-convert - widget 'custom-browse-visibility + (push (widget-create-child-and-convert + widget 'custom-browse-visibility ;; :tag-glyph "minus" :tag "-") buttons) (insert "-\\ ") ;; (widget-glyph-insert nil "-\\ " "top") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) (insert " " tag "\n") @@ -2683,19 +2683,25 @@ (unless (eq custom-buffer-style 'links) (insert-char ?\ (* custom-buffer-indent (1- level))) (insert "-- ")) + ;; Create link indicator. + (when (eq custom-buffer-style 'links) + (insert " ") + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag "Open" + :tag-glyph '("open-up" "open-down") + symbol) + buttons) + (insert " ")) ;; Create tag. (let ((begin (point))) (insert tag) (widget-specify-sample widget begin (point))) - (insert " group: ") - ;; Create link/visibility indicator. - (if (eq custom-buffer-style 'links) - (push (widget-create-child-and-convert - widget 'custom-group-link - :tag "Open" - symbol) - buttons) - (push (widget-create-child-and-convert + (insert " group") + ;; Create visibility indicator. + (unless (eq custom-buffer-style 'links) + (insert ": ") + (push (widget-create-child-and-convert widget 'custom-group-visibility :help-echo "Show members of this group" :action 'custom-toggle-parent @@ -2738,7 +2744,7 @@ ;; Create visibility indicator. (unless (eq custom-buffer-style 'links) (insert "--------") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide members of this group" :action 'custom-toggle-parent @@ -2747,13 +2753,13 @@ (insert " ")) ;; Create more dashes. ;; Use 76 instead of 75 to compensate for the temporary "<" - ;; added by `widget-insert'. + ;; added by `widget-insert'. (insert-char ?- (- 76 (current-column) (* custom-buffer-indent level))) (insert "\\\n") ;; Create magic button. (let ((magic (widget-create-child-and-convert - widget 'custom-magic + widget 'custom-magic :indent 0 nil))) (widget-put widget :custom-magic magic) @@ -2768,7 +2774,7 @@ (when (eq level 1) (insert-char ?\ custom-buffer-indent) (custom-add-parent-links widget))) - (custom-add-see-also widget + (custom-add-see-also widget (make-string (* custom-buffer-indent level) ?\ )) ;; Members. @@ -2815,7 +2821,7 @@ (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level))) (insert "/\n"))))) -(defvar custom-group-menu +(defvar custom-group-menu '(("Set for Current Session" custom-group-set (lambda (widget) (eq (widget-get widget :custom-state) 'modified))) @@ -3023,10 +3029,10 @@ (mapatoms (lambda (symbol) (let ((face (get symbol 'customized-face)) (value (get symbol 'customized-value))) - (when face + (when face (put symbol 'saved-face face) (put symbol 'customized-face nil)) - (when value + (when value (put symbol 'saved-value value) (put symbol 'customized-value nil))))) ;; We really should update all custom buffers here. @@ -3068,10 +3074,10 @@ ;; Add checkboxes to boolean variable entries. (widget-put (get 'boolean 'widget-type) :custom-menu (lambda (widget symbol) - (vector (custom-unlispify-menu-entry symbol) - `(customize-variable ',symbol) - ':style 'toggle - ':selected symbol))) + `[,(custom-unlispify-menu-entry symbol) + (customize-variable ',symbol) + :style toggle + :selected ,symbol])) ;; XEmacs can create menus dynamically. (defun custom-group-menu-create (widget symbol) @@ -3116,7 +3122,7 @@ ;;;###autoload (defun customize-menu-create (symbol &optional name) "Return a customize menu for customization group SYMBOL. -If optional NAME is given, use that as the name of the menu. +If optional NAME is given, use that as the name of the menu. Otherwise the menu will be named `Customize'. The format is suitable for use with `easy-menu-define'." (unless name @@ -3153,7 +3159,7 @@ (if button (widget-button-click event))))) -(easy-menu-define Custom-mode-menu +(easy-menu-define Custom-mode-menu custom-mode-map "Menu used in customization buffers." `("Custom" @@ -3163,7 +3169,7 @@ ["Reset to Current" Custom-reset-current t] ["Reset to Saved" Custom-reset-saved t] ["Reset to Standard Settings" Custom-reset-standard t] - ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) + ["Info" (Info-goto-node "(xemacs)Easy Customization") t])) (defun Custom-goto-parent () "Go to the parent group listed at the top of this buffer. @@ -3183,7 +3189,8 @@ (defun custom-state-buffer-message (widget) (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified) - (message "To install your edits, invoke [State] and choose the Set operation"))) + (message + "To install your edits, invoke [State] and choose the Set operation"))) (defun custom-mode () "Major mode for editing customization buffers. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/custom/cus-face.el --- a/lisp/custom/cus-face.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-face.el Mon Aug 13 10:03:52 2007 +0200 @@ -74,10 +74,11 @@ :value "" :help-echo "Set background color.") set-face-background face-background-name) -;; (:inverse-video (boolean :tag "Inverse" -;; :help-echo "\ -;;Control whether the text should be inverted.") -;; custom-inverse-face custom-face-inverse) + ;; #### Should make it work on X + (:inverse-video (boolean :tag "Inverse" + :help-echo "\ +Control whether the text should be inverted. Works only on TTY-s") + set-face-reverse-p face-reverse-p) (:stipple (editable-field :format "Stipple: %v" :help-echo "Name of background bitmap file.") set-face-background-pixmap custom-face-stipple) @@ -214,25 +215,6 @@ (fontobj (font-create-object font))) (font-family fontobj))) -;;(defun custom-reverse-face (face value &optional frame) -;; "Swap the foreground and background colors of face FACE. -;;If the colors are not specified in the face, use the default colors." -;; (interactive (list (read-face-name "Reverse face: "))) -;; (when value -;; (if (eq (frame-type) 'tty) -;; (set-face-reverse-p face value frame) -;; (let ((fg (face-foreground-instance face frame)) -;; (bg (face-background-instance face frame))) -;; (set-face-foreground face bg frame) -;; (set-face-background face fg frame))))) - -;;(defun custom-face-reverse (face &optional frame) -;; "Returns non-nil if the face is reverse." -;; (if (eq (frame-type) 'tty) -;; (face-reverse-p face frame) -;; ;;; ### Implement me -;; )) - ;;; Initializing. ;;;###autoload diff -r d3e9274cbc4e -r e45d5e7c476e lisp/custom/cus-load.el --- a/lisp/custom/cus-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -35,19 +35,35 @@ (require 'custom) -(defun custom-put (symbol property list) - (let ((loads (get symbol property))) + +(defun custom-add-loads (symbol list) + "Update the custom-loads list of a symbol. +This works by adding the elements from LIST to the SYMBOL's +`custom-loads' property, avoiding duplicates. Also, SYMBOL is +added to `custom-group-hash-table'." + (let ((loads (get symbol 'custom-loads))) (dolist (el list) (unless (member el loads) (setq loads (nconc loads (list el))))) - (put symbol property loads) + (put symbol 'custom-loads loads) (puthash symbol t custom-group-hash-table))) +;; custom-add-loads was named custom-put (and accepted different +;; arguments) during the 20.3 beta cycle. Support it for +;; compatibility. +(defun custom-put (symbol ignored list) + (custom-add-loads symbol list)) +(make-obsolete 'custom-put 'custom-add-loads) + + (message "Loading customization dependencies...") -(mapc (lambda (dir) - (load (expand-file-name "custom-load" dir) t t)) - load-path) +;; Garbage-collection seems to be very intensive here, and it slows +;; things down. Nuke it. +(let ((gc-cons-threshold 10000000)) + (mapc (lambda (dir) + (load (expand-file-name "custom-load" dir) t t)) + load-path)) (message "Loading customization dependencies...done") diff -r d3e9274cbc4e -r e45d5e7c476e lisp/custom/custom-load.el --- a/lisp/custom/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,37 +1,36 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:08 1997 ;;; Code: -(custom-put 'extensions 'custom-loads '("wid-edit")) -(custom-put 'custom-buffer 'custom-loads '("cus-edit")) -(custom-put 'custom-faces 'custom-loads '("cus-edit")) -(custom-put 'widgets 'custom-loads '("wid-browse" "wid-edit")) -(custom-put 'environment 'custom-loads '("cus-edit")) -(custom-put 'custom-menu 'custom-loads '("cus-edit")) -(custom-put 'internal 'custom-loads '("cus-edit")) -(custom-put 'hypermedia 'custom-loads '("wid-edit")) -(custom-put 'applications 'custom-loads '("cus-edit")) -(custom-put 'help 'custom-loads '("cus-edit")) -(custom-put 'widget-browse 'custom-loads '("wid-browse")) -(custom-put 'widget-documentation 'custom-loads '("wid-edit")) -(custom-put 'customize 'custom-loads '("cus-edit" "wid-edit")) -(custom-put 'custom-browse 'custom-loads '("cus-edit")) -(custom-put 'abbrev 'custom-loads '("cus-edit")) -(custom-put 'programming 'custom-loads '("cus-edit")) -(custom-put 'widget-button 'custom-loads '("wid-edit")) -(custom-put 'files 'custom-loads '("cus-edit")) -(custom-put 'external 'custom-loads '("cus-edit")) -(custom-put 'development 'custom-loads '("cus-edit")) -(custom-put 'widget-faces 'custom-loads '("wid-edit")) -(custom-put 'languages 'custom-loads '("cus-edit")) -(custom-put 'custom-magic-faces 'custom-loads '("cus-edit")) -(custom-put 'faces 'custom-loads '("cus-edit" "wid-edit")) -(custom-put 'emacs 'custom-loads '("cus-edit")) -(custom-put 'processes 'custom-loads '("cus-edit")) -(custom-put 'wp 'custom-loads '("cus-edit")) -(custom-put 'editing 'custom-loads '("cus-edit")) -(custom-put 'i18n 'custom-loads '("cus-edit")) +(custom-add-loads 'extensions '("wid-edit")) +(custom-add-loads 'custom-buffer '("cus-edit")) +(custom-add-loads 'custom-faces '("cus-edit")) +(custom-add-loads 'widgets '("wid-browse" "wid-edit")) +(custom-add-loads 'environment '("cus-edit")) +(custom-add-loads 'custom-menu '("cus-edit")) +(custom-add-loads 'internal '("cus-edit")) +(custom-add-loads 'hypermedia '("wid-edit")) +(custom-add-loads 'applications '("cus-edit")) +(custom-add-loads 'help '("cus-edit")) +(custom-add-loads 'widget-browse '("wid-browse")) +(custom-add-loads 'widget-documentation '("wid-edit")) +(custom-add-loads 'customize '("cus-edit" "wid-edit")) +(custom-add-loads 'custom-browse '("cus-edit")) +(custom-add-loads 'abbrev '("cus-edit")) +(custom-add-loads 'programming '("cus-edit")) +(custom-add-loads 'widget-button '("wid-edit")) +(custom-add-loads 'files '("cus-edit")) +(custom-add-loads 'external '("cus-edit")) +(custom-add-loads 'development '("cus-edit")) +(custom-add-loads 'widget-faces '("wid-edit")) +(custom-add-loads 'languages '("cus-edit")) +(custom-add-loads 'custom-magic-faces '("cus-edit")) +(custom-add-loads 'faces '("cus-edit" "wid-edit")) +(custom-add-loads 'emacs '("cus-edit")) +(custom-add-loads 'processes '("cus-edit")) +(custom-add-loads 'wp '("cus-edit")) +(custom-add-loads 'editing '("cus-edit")) +(custom-add-loads 'i18n '("cus-edit")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/custom/wid-edit.el --- a/lisp/custom/wid-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/wid-edit.el Mon Aug 13 10:03:52 2007 +0200 @@ -37,18 +37,12 @@ (autoload 'pp-to-string "pp") (autoload 'finder-commentary "finder" nil t) -(defun widget-event-point (event) - "Character position of the end of event if that exists, or nil." - (if (mouse-event-p event) - (event-point event) - nil)) - ;;; Customization. (defgroup widgets nil "Customization support for the Widget Library." :link '(custom-manual "(widget)Top") - :link '(url-link :tag "Development Page" + :link '(url-link :tag "Development Page" "http://www.dina.kvl.dk/~abraham/custom/") :link '(emacs-library-link :tag "Lisp File" "widget.el") :prefix "widget-" @@ -98,7 +92,7 @@ (((class grayscale color) (background dark)) (:background "dim gray")) - (t + (t (:italic t))) "Face used for editable fields." :group 'widget-faces) @@ -110,7 +104,7 @@ ; (((class grayscale color) ; (background dark)) ; (:background "dim gray")) -; (t +; (t ; (:italic t))) ; "Face used for editable fields spanning only a single line." ; :group 'widget-faces) @@ -200,7 +194,7 @@ (cons title (mapcar (lambda (x) (if (stringp x) - (vector x nil nil) + (vector x nil nil) (vector (car x) (list (car x)) t))) items))))) (setq val (and val @@ -249,7 +243,8 @@ (lookup-key overriding-terminal-local-map (read-key-sequence (concat title ": ") t))))) (message "") - (when (eq value 'keyboard-quit) + (when (or (eq value 'keyboard-quit) + (null value)) (error "Canceled")) value)) (t @@ -265,8 +260,8 @@ ;;; Widget text specifications. -;; -;; These functions are for specifying text properties. +;; +;; These functions are for specifying text properties. (defcustom widget-field-add-space t ;; Setting this to nil might be available, once some problems are resolved. @@ -282,7 +277,7 @@ (> emacs-major-version 19)) (not (string-match "XEmacs" emacs-version))) "Non-nil means use `before-change-functions' to track editable fields. -This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. +This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. Using before hooks also means that the :notify function can't know the new value." :type 'boolean @@ -305,14 +300,14 @@ (help-echo (widget-get widget :help-echo)) (extent (make-extent from to))) (unless (or (stringp help-echo) (null help-echo)) - (setq help-echo 'widget-mouse-help)) + (setq help-echo 'widget-mouse-help)) (widget-put widget :field-extent extent) (and (or (not widget-field-add-space) (widget-get widget :size)) (set-extent-property extent 'end-closed t)) (set-extent-property extent 'detachable nil) (set-extent-property extent 'field widget) - (set-extent-property extent 'tabable t) + (set-extent-property extent 'button-or-field t) (set-extent-property extent 'keymap map) (set-extent-property extent 'face face) (set-extent-property extent 'balloon-help help-echo) @@ -322,17 +317,19 @@ "Specify button for WIDGET between FROM and TO." (let ((face (widget-apply widget :button-face-get)) (help-echo (widget-get widget :help-echo)) - (extent (make-extent from to))) + (extent (make-extent from to)) + (map (widget-get widget :button-keymap))) (widget-put widget :button-extent extent) (unless (or (null help-echo) (stringp help-echo)) (setq help-echo 'widget-mouse-help)) (set-extent-property extent 'start-open t) (set-extent-property extent 'button widget) - (set-extent-property extent 'tabable t) + (set-extent-property extent 'button-or-field t) (set-extent-property extent 'mouse-face widget-mouse-face) (set-extent-property extent 'balloon-help help-echo) (set-extent-property extent 'help-echo help-echo) - (set-extent-property extent 'face face))) + (set-extent-property extent 'face face) + (set-extent-property extent 'keymap map))) (defun widget-mouse-help (extent) "Find mouse help string for button in extent." @@ -378,51 +375,112 @@ (delete-region (1- (point-max)) (point-max)) (goto-char (point-max)))))) +(put 'widget-specify-insert 'edebug-form-spec '(&rest form)) + + +;;; Inactive Widgets. + (defface widget-inactive-face '((((class grayscale color) (background dark)) (:foreground "light gray")) (((class grayscale color) (background light)) (:foreground "dim gray")) - (t + (t (:italic t))) "Face used for inactive widgets." :group 'widget-faces) +;; For inactiveness to work on complex structures, it is not +;; sufficient to keep track of whether a button/field/glyph is +;; inactive or not -- we must know how many time it was deactivated +;; (inactiveness level). Successive deactivations of the same button +;; increment its inactive-count, and activations decrement it. When +;; inactive-count reaches 0, the button/field/glyph is reactivated. + +(defun widget-activation-widget-mapper (extent action) + "Activate or deactivate EXTENT's widget (button or field). +Suitable for use with `map-extents'." + (ecase action + (:activate + (decf (extent-property extent :inactive-count)) + (when (zerop (extent-property extent :inactive-count)) + (set-extent-properties + extent (extent-property extent :inactive-plist)) + (set-extent-property extent :inactive-plist nil))) + (:deactivate + (incf (extent-property extent :inactive-count 0)) + ;; Store a plist of old properties, which will be fed to + ;; `set-extent-properties'. + (unless (extent-property extent :inactive-plist) + (set-extent-property + extent :inactive-plist + (list 'mouse-face (extent-property extent 'mouse-face) + 'help-echo (extent-property extent 'help-echo) + 'keymap (extent-property extent 'keymap))) + (set-extent-properties + extent '(mouse-face nil help-echo nil keymap nil))))) + nil) + +(defun widget-activation-glyph-mapper (extent action) + (let ((activate-p (if (eq action :activate) t nil))) + (if activate-p + (decf (extent-property extent :inactive-count)) + (incf (extent-property extent :inactive-count 0))) + (when (or (and activate-p + (zerop (extent-property extent :inactive-count))) + (and (not activate-p) + (not (zerop (extent-property extent :inactive-count))))) + (let* ((glyph-widget (extent-property extent 'glyph-widget)) + (up-glyph (widget-get glyph-widget :glyph-up)) + (inactive-glyph (widget-get glyph-widget :glyph-inactive)) + (new-glyph (if activate-p up-glyph inactive-glyph))) + ;; Check that the new glyph exists, and differs from the + ;; default one. + (and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph)) + ;; Check if the glyph is already installed. + (not (eq (extent-end-glyph extent) new-glyph)) + ;; Change it. + (set-extent-end-glyph extent new-glyph))))) + nil) + (defun widget-specify-inactive (widget from to) "Make WIDGET inactive for user modifications." (unless (widget-get widget :inactive) (let ((extent (make-extent from to))) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'face 'widget-inactive-face) - ;; This is disabled, as it makes the mouse cursor change shape. - ;(set-extent-property extent 'mouse-face 'widget-inactive-face) - ;; ...actually, in XEmacs, we can easily choose our own pointer - ;; shapes. However, the mouse-face of the "inner" extent will - ;; still be drawn. - (set-extent-property extent 'detachable t) - (set-extent-property extent 'priority 100) - (set-extent-property extent 'read-only 't) - (widget-put widget :inactive extent)))) - -;; We don't have modification functions, so this is unused. -;(defun widget-overlay-inactive (&rest junk) -; "Ignoring the arguments, signal an error." -; (unless inhibit-read-only -; (error "Attempt to modify inactive widget"))) - + ;; It is no longer necessary for the extent to be read-only, as + ;; the inactive editable fields now lose their keymaps. + (set-extent-properties + extent '(start-open t face widget-inactive-face + detachable t priority 2001 widget-inactive t)) + (widget-put widget :inactive extent)) + ;; Deactivate the buttons and fields within the range. In some + ;; cases, the fields are not yet setup at the time this function + ;; is called. Those fields are deactivated explicitly by + ;; `widget-setup'. + (map-extents 'widget-activation-widget-mapper + nil from to :deactivate nil 'button-or-field) + ;; Deactivate glyphs. + (map-extents 'widget-activation-glyph-mapper + nil from to :deactivate nil 'glyph-widget))) (defun widget-specify-active (widget) "Make WIDGET active for user modifications." (let ((inactive (widget-get widget :inactive))) (when inactive + ;; Reactivate the buttons and fields covered by the extent. + (map-extents 'widget-activation-widget-mapper + inactive nil nil :activate nil 'button-or-field) + ;; Reactivate the glyphs. + (map-extents 'widget-activation-glyph-mapper + inactive nil nil :activate nil 'end-glyph) (delete-extent inactive) (widget-put widget :inactive nil)))) ;;; Widget Properties. -(defun widget-type (widget) +(defsubst widget-type (widget) "Return the type of WIDGET, a symbol." (car widget)) @@ -448,13 +506,13 @@ missing nil)) ((setq tmp (car widget)) (setq widget (get tmp 'widget-type))) - (t + (t (setq missing nil)))) value))) (defun widget-get-indirect (widget property) "In WIDGET, get the value of PROPERTY. -If the value is a symbol, return its binding. +If the value is a symbol, return its binding. Otherwise, just return the value." (let ((value (widget-get widget property))) (if (symbolp value) @@ -583,9 +641,13 @@ xbm, gif, jpg, or png) located in `widget-glyph-directory', or in one of the data directories. It can also be a valid image instantiator, in which case it will be - used to make the glyph, with an additional TAG string fallback. -If IMAGE is a list, it will be given unchanged to `make-glyph'." - (cond ((not (and image widget-glyph-enable)) + used to make the glyph, with an additional TAG string fallback." + (cond ((not (and image widget-glyph-enable + ;; We don't use glyphs on TTY consoles, although we + ;; could. However, glyph faces aren't yet working + ;; properly, and movement through glyphs is + ;; unintuitive. + (console-on-window-system-p))) ;; We don't want to use glyphs. nil) ((glyphp image) @@ -601,6 +663,9 @@ (formats widget-image-conversion) file) (while (and formats (not file)) + ;; This dance is necessary, because XEmacs signals an + ;; error when it encounters an unrecognized image + ;; format. (when (valid-image-instantiator-format-p (caar formats)) (setq file (locate-file image dirlist (mapconcat 'identity (cdar formats) @@ -613,16 +678,12 @@ (let ((glyph (make-glyph `([,(caar formats) :file ,file] [string :data ,tag])))) ;; Cache the glyph - (setq widget-glyph-cache - (lax-plist-put widget-glyph-cache image glyph)) + (laxputf widget-glyph-cache image glyph) ;; ...and return it glyph))))) ((valid-instantiator-p image 'image) ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) (make-glyph `(,image [string :data ,tag]))) - ((consp image) - ;; This could be virtually anything. Let `make-glyph' sort it out. - (make-glyph image)) (t ;; Oh well. nil))) @@ -634,18 +695,30 @@ `widget-glyph-directory', or anything else allowed by `widget-glyph-find'. -Optional arguments DOWN and INACTIVE is used instead of IMAGE when the -glyph is pressed or inactive, respectively. - -Instead of an instantiator, you can also use a list of instantiators, -or whatever `make-glyph' will accept. However, in that case you must -provide the fallback TAG as a part of the instantiator yourself." +If IMAGE is a list, it will be taken as a list of (UP DOWN INACTIVE) +glyphs. The down and inactive glyphs are shown when glyph is pressed +or inactive, respectively. + +The optional DOWN and INACTIVE arguments are deprecated, and exist +only because of compatibility." + ;; Convert between IMAGE being a list, etc. Must use `psetq', + ;; because otherwise change to `image' screws up the rest. + (psetq image (or (and (consp image) + (car image)) + image) + down (or (and (consp image) + (nth 1 image)) + down) + inactive (or (and (consp image) + (nth 2 image)) + inactive)) (let ((glyph (widget-glyph-find image tag))) - (if glyph + (if glyph (widget-glyph-insert-glyph widget glyph (widget-glyph-find down tag) (widget-glyph-find inactive tag)) - (insert tag)))) + (insert tag)) + glyph)) (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) "In WIDGET, insert GLYPH. @@ -653,12 +726,19 @@ glyphs used when the widget is pushed and inactive, respectively." (insert "*") (let ((extent (make-extent (point) (1- (point)))) - (help-echo (and widget (widget-get widget :help-echo)))) - (set-extent-property extent 'widget widget) + (help-echo (and widget (widget-get widget :help-echo))) + (map (and widget (widget-get widget :button-keymap)))) + (set-extent-property extent 'glyph-widget widget) + ;; It would be fun if we could make this extent atomic, so it + ;; doesn't mess with cursor motion. But atomic-extents library is + ;; currently a mess, so I'd rather not use it. (set-extent-property extent 'invisible t) (set-extent-property extent 'start-open t) (set-extent-property extent 'end-open t) + (set-extent-property extent 'keymap map) (set-extent-end-glyph extent glyph) + (unless (or (stringp help-echo) (null help-echo)) + (setq help-echo 'widget-mouse-help)) (when help-echo (set-extent-property extent 'balloon-help help-echo) (set-extent-property extent 'help-echo help-echo))) @@ -689,7 +769,7 @@ ;;;###autoload (defun widget-create (type &rest args) - "Create widget of TYPE. + "Create widget of TYPE. The optional ARGS are additional keyword arguments." (let ((widget (apply 'widget-convert type args))) (widget-apply widget :create) @@ -736,10 +816,10 @@ (widget-apply widget :delete)) (defun widget-convert (type &rest args) - "Convert TYPE to a widget without inserting it in the buffer. + "Convert TYPE to a widget without inserting it in the buffer. The optional ARGS are additional keyword arguments." ;; Don't touch the type. - (let* ((widget (if (symbolp type) + (let* ((widget (if (symbolp type) (list type) (copy-sequence type))) (current widget) @@ -765,10 +845,10 @@ (setq widget (funcall convert-widget widget)))) (setq type (get (car type) 'widget-type))) ;; Finally set the keyword args. - (while keys + (while keys (let ((next (nth 0 keys))) (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (progn + (progn (widget-put widget next (nth 1 keys)) (setq keys (nthcdr 2 keys))) (setq keys nil)))) @@ -846,16 +926,12 @@ "Keymap containing useful binding for buffers containing widgets. Recommended as a parent keymap for modes using widgets.") -(unless widget-keymap +(unless widget-keymap (setq widget-keymap (make-sparse-keymap)) (define-key widget-keymap [tab] 'widget-forward) (define-key widget-keymap [(shift tab)] 'widget-backward) (define-key widget-keymap [(meta tab)] 'widget-backward) - (define-key widget-keymap [backtab] 'widget-backward) - ;;Glyph support. - (define-key widget-keymap [button1] 'widget-button1-click) - (define-key widget-keymap [button2] 'widget-button-click) - (define-key widget-keymap "\C-m" 'widget-button-press)) + (define-key widget-keymap [backtab] 'widget-backward)) (defvar widget-global-map global-map "Keymap used for events the widget does not handle themselves.") @@ -864,7 +940,7 @@ (defvar widget-field-keymap nil "Keymap used inside an editable field.") -(unless widget-field-keymap +(unless widget-field-keymap (setq widget-field-keymap (make-sparse-keymap)) (set-keymap-parents widget-field-keymap global-map) (define-key widget-field-keymap "\C-k" 'widget-kill-line) @@ -879,24 +955,38 @@ (defvar widget-text-keymap nil "Keymap used inside a text field.") -(unless widget-text-keymap +(unless widget-text-keymap (setq widget-text-keymap (make-sparse-keymap)) (set-keymap-parents widget-field-keymap global-map) (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) (define-key widget-text-keymap "\C-e" 'widget-end-of-line) (define-key widget-text-keymap "\C-t" 'widget-transpose-chars)) +(defvar widget-button-keymap nil + "Keymap used inside a button.") + +(unless widget-button-keymap + (setq widget-button-keymap (make-sparse-keymap)) + (set-keymap-parents widget-button-keymap widget-keymap) + (define-key widget-button-keymap "\C-m" 'widget-button-press) + (define-key widget-button-keymap [button2] 'widget-button-click) + ;; Ideally, button3 within a button should invoke a button-specific + ;; menu. + (define-key widget-button-keymap [button3] 'widget-button-click) + ;;Glyph support. + (define-key widget-button-keymap [button1] 'widget-button1-click)) + (defun widget-field-activate (pos &optional event) "Invoke the ediable field at point." (interactive "@d") - (let ((field (get-char-property pos 'field))) + (let ((field (widget-field-find pos))) (if field (widget-apply-action field event) (call-interactively (lookup-key widget-global-map (this-command-keys)))))) -(defface widget-button-pressed-face +(defface widget-button-pressed-face '((((class color)) (:foreground "red")) (t @@ -904,6 +994,11 @@ "Face used for pressed buttons." :group 'widget-faces) +(defun widget-event-point (event) + "Character position of the mouse event, or nil." + (and (mouse-event-p event) + (event-point event))) + (defun widget-button-click (event) "Invoke button below mouse pointer." (interactive "@e") @@ -915,56 +1010,46 @@ (if button (let* ((extent (widget-get button :button-extent)) (face (extent-property extent 'face)) - (mouse-face (extent-property extent 'mouse-face))) + (mouse-face (extent-property extent 'mouse-face)) + (help-echo (extent-property extent 'help-echo))) (unwind-protect (progn - (set-extent-property extent 'face - 'widget-button-pressed-face) - (set-extent-property extent 'mouse-face - 'widget-button-pressed-face) + ;; Merge relevant faces, and make the result mouse-face. + (let ((merge `(widget-button-pressed-face ,mouse-face))) + (nconc merge (if (listp face) + face (list face))) + (setq merge (delete-if-not 'find-face merge)) + (set-extent-property extent 'mouse-face merge)) (unless (widget-apply button :mouse-down-action event) - (while (not (button-release-event-p event)) - (setq event (next-event) - pos (widget-event-point event)) - (if (and pos - (eq (get-char-property pos 'button) - button)) - (progn - (set-extent-property extent 'face - 'widget-button-pressed-face) - (set-extent-property extent 'mouse-face - 'widget-button-pressed-face)) - (set-extent-property extent 'face face) - (set-extent-property extent - 'mouse-face mouse-face)))) - (when (and pos - (eq (get-char-property pos 'button) button)) + ;; Wait for button release. + (while (not (button-release-event-p + (setq event (next-event)))) + (dispatch-event event))) + ;; Disallow mouse-face and help-echo. + (set-extent-property extent 'mouse-face nil) + (set-extent-property extent 'help-echo nil) + (setq pos (widget-event-point event)) + (unless (eq (current-buffer) (extent-object extent)) + ;; Barf if dispatch-event tripped us by + ;; changing buffer. + (error "Buffer changed during mouse motion")) + ;; Do the associated action. + (when (and pos (extent-in-region-p extent pos pos)) (widget-apply-action button event))) - (set-extent-property extent 'face face) - (set-extent-property extent 'mouse-face mouse-face))) - (let ((up t) - command) - ;; Find the global command to run, and check whether it - ;; is bound to an up event. - (cond ((setq command ;down event - (lookup-key widget-global-map [button2])) - (setq up nil)) - ((setq command ;up event - (lookup-key widget-global-map [button2up])))) - (when up - ;; Don't execute up events twice. - (while (not (button-release-event-p event)) - (setq event (next-event)))) - (when command - (call-interactively command)))))) + ;; Unwinding: fully release the button. + (set-extent-property extent 'mouse-face mouse-face) + (set-extent-property extent 'help-echo help-echo))) + ;; This should not happen! + (error "`widget-button-click' called outside button")))) (t - (message "You clicked somewhere weird.")))) + (message "You clicked somewhere weird")))) (defun widget-button1-click (event) "Invoke glyph below mouse pointer." (interactive "@e") (if (event-glyph event) (widget-glyph-click event) + ;; Should somehow avoid this. (let ((command (lookup-key widget-global-map (this-command-keys)))) (and (commandp command) (call-interactively command))))) @@ -973,28 +1058,55 @@ "Handle click on a glyph." (let* ((glyph (event-glyph event)) (extent (event-glyph-extent event)) - (widget (extent-property extent 'widget)) + (widget (extent-property extent 'glyph-widget)) (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph)) (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph)) (last event)) - ;; Wait for the release. - (while (not (button-release-event-p last)) - (if (eq extent (event-glyph-extent last)) - (set-extent-property extent 'end-glyph down-glyph) - (set-extent-property extent 'end-glyph up-glyph)) - (setq last (next-event event))) - ;; Release glyph. - (when down-glyph - (set-extent-property extent 'end-glyph up-glyph)) - ;; Apply widget action. - (when (eq extent (event-glyph-extent last)) - (let ((widget (extent-property (event-glyph-extent event) 'widget))) - (cond ((null widget) - (message "You clicked on a glyph.")) - ((not (widget-apply widget :active)) - (message "This glyph is inactive.")) - (t - (widget-apply-action widget event))))))) + (unless (widget-apply widget :active) + (error "This widget is inactive")) + (let ((current-glyph 'down)) + ;; We always know what glyph is drawn currently, to avoid + ;; unnecessary extent changes. Is this any noticable gain? + (unwind-protect + (progn + ;; Press the glyph. + (set-extent-end-glyph extent down-glyph) + ;; Redisplay (shouldn't be needed, but...) + (sit-for 0) + (unless (widget-apply widget :mouse-down-action event) + ;; Wait for the release. + (while (not (button-release-event-p last)) + (unless (button-press-event-p last) + (dispatch-event last)) + (when (motion-event-p last) + ;; Update glyphs on mouse motion. + (if (eq extent (event-glyph-extent last)) + (unless (eq current-glyph 'down) + (set-extent-end-glyph extent down-glyph) + (setq current-glyph 'down)) + (unless (eq current-glyph 'up) + (set-extent-end-glyph extent up-glyph) + (setq current-glyph 'up)))) + (setq last (next-event event)))) + (unless (eq (current-buffer) (extent-object extent)) + ;; Barf if dispatch-event tripped us by changing buffer. + (error "Buffer changed during mouse motion")) + ;; Apply widget action. + (when (eq extent (event-glyph-extent last)) + (let ((widget (extent-property (event-glyph-extent event) + 'glyph-widget))) + (cond ((null widget) + (message "You clicked on a glyph")) + ((not (widget-apply widget :active)) + (error "This glyph is inactive")) + (t + (widget-apply-action widget event)))))) + ;; Release the glyph. + (and (eq current-glyph 'down) + ;; The extent might have been detached or deleted + (extent-live-p extent) + (not (extent-detached-p extent)) + (set-extent-end-glyph extent up-glyph)))))) (defun widget-button-press (pos &optional event) "Invoke button at POS." @@ -1015,7 +1127,8 @@ (if widget (let ((order (widget-get widget :tab-order))) (if order - (if last-tab (and (= order (if backwardp (1- last-tab) + (if last-tab (and (= order (if backwardp + (1- last-tab) (1+ last-tab))) widget) (and (> order 0) widget)) @@ -1039,10 +1152,11 @@ (lambda (ext ignore) ext) nil (if at-point (extent-end-position at-point) pos) - nil nil 'start-open 'tabable))) + nil nil 'start-open 'button-or-field))) (and extent (extent-start-position extent)))) +;; This is too slow in buffers with many buttons (W3). (defun widget-previous-button-or-field (pos) "Find the previous button, or field, and return its start position, or nil. Internal function, don't use it outside `wid-edit'." @@ -1051,10 +1165,13 @@ (map-extents (lambda (ext ignore) (if (eq ext at-point) - previous-extent + ;; We reached the extent we were on originally + (if (= pos (extent-start-position at-point)) + previous-extent + (setq previous-extent at-point)) (setq previous-extent ext) nil)) - nil nil pos nil 'start-open 'tabable) + nil nil pos nil 'start-open 'button-or-field) (and previous-extent (extent-start-position previous-extent)))) @@ -1070,7 +1187,8 @@ (if nextpos (progn (goto-char nextpos) - (when (widget-tabable-at nil last-tab t) + (when (and (not (get-char-property nextpos 'widget-inactive)) + (widget-tabable-at nil last-tab t)) (incf arg) (setq found t last-tab (widget-get (widget-at (point)) @@ -1086,7 +1204,8 @@ (if nextpos (progn (goto-char nextpos) - (when (widget-tabable-at nil last-tab) + (when (and (not (get-char-property nextpos 'widget-inactive)) + (widget-tabable-at nil last-tab)) (decf arg) (setq found t last-tab (widget-get (widget-at (point)) @@ -1154,14 +1273,19 @@ (goto-char end) (skip-chars-backward " \t\n" start) (point))))) - (if (and last-non-space - (= last-non-space (1+ start))) - ;; 1-character field - nil - (when (and (null arg) - (= last-non-space (point))) - (forward-char -1)) - (transpose-chars arg)))) + (cond ((and last-non-space + (or (= last-non-space start) + (= last-non-space (1+ start)))) + ;; empty or one-character field + nil) + ((= (point) start) + ;; at the beginning of the field -- we would get an error here. + (error "Cannot transpose at beginning of field")) + (t + (when (and (null arg) + (= last-non-space (point))) + (forward-char -1)) + (transpose-chars arg))))) (defcustom widget-complete-field (lookup-key global-map "\M-\t") "Default function to call for completion inside fields." @@ -1199,11 +1323,17 @@ (setq field (car widget-field-new) widget-field-new (cdr widget-field-new) widget-field-list (cons field widget-field-list)) - (let ((extent (widget-get field :field-extent))) + (let ((from (car (widget-get field :field-extent))) + (to (cdr (widget-get field :field-extent)))) (widget-specify-field field - (extent-start-position extent) - (extent-end-position extent)) - (delete-extent extent)))) + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil)) + ;; If the field is placed within the inactive zone, deactivate it. + (let ((extent (widget-get field :field-extent))) + (when (get-char-property (extent-start-position extent) + 'widget-inactive) + (widget-activation-widget-mapper extent :deactivate))))) (widget-clear-undo) (widget-add-change)) @@ -1237,32 +1367,45 @@ (defun widget-field-find (pos) "Return the field at POS. Unlike (get-char-property POS 'field) this, works with empty fields too." - (let ((fields widget-field-list) - field found) - (while fields - (setq field (car fields) - fields (cdr fields)) - (let ((start (widget-field-start field)) - (end (widget-field-end field))) - (when (and (<= start pos) (<= pos end)) - (when found - (debug "Overlapping fields")) - (setq found field)))) - found)) + (let ((field-extent (map-extents (lambda (extent ignore) + extent) + nil pos pos nil nil 'field))) + (and field-extent + (extent-property field-extent 'field)))) + +;; Old version, without `map-extents'. +;(defun widget-field-find (pos) +; (let ((fields widget-field-list) +; field found) +; (while fields +; (setq field (car fields) +; fields (cdr fields)) +; (let ((start (widget-field-start field)) +; (end (widget-field-end field))) +; (when (and (<= start pos) (<= pos end)) +; (when found +; (debug "Overlapping fields")) +; (setq found field)))) +; found)) (defun widget-before-change (from to) - ;; This is how, for example, a variable changes its state to `modified'. - ;; when it is being edited. + ;; Barf if the text changed is outside the editable fields. (unless inhibit-read-only (let ((from-field (widget-field-find from)) (to-field (widget-field-find to))) - (cond ((not (eq from-field to-field)) + (cond ((or (null from-field) + (null to-field)) + ;; Either end of change is not within a field. + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Attempt to change text outside editable field")) + ((not (eq from-field to-field)) + ;; The change begins in one fields, and ends in another one. (add-hook 'post-command-hook 'widget-add-change nil t) (error "Change should be restricted to a single field")) - ((null from-field) - (add-hook 'post-command-hook 'widget-add-change nil t) - (error "Attempt to change text outside editable field")) (widget-field-use-before-change + ;; #### Bletch! This loses because XEmacs get confused + ;; if before-change-functions change the contents of + ;; buffer before from/to. (condition-case nil (widget-apply from-field :notify from-field) (error (debug "Before Change")))))))) @@ -1277,6 +1420,9 @@ (defun widget-after-change (from to old) ;; Adjust field size and text properties. + + ;; Also, notify the widgets (so, for example, a variable changes its + ;; state to `modified'. when it is being edited.) (condition-case nil (let ((field (widget-field-find from)) (other (widget-field-find to))) @@ -1285,7 +1431,7 @@ (debug "Change in different fields")) (let ((size (widget-get field :size)) (secret (widget-get field :secret))) - (when size + (when size (let ((begin (widget-field-start field)) (end (widget-field-end field))) (cond ((< (- end begin) size) @@ -1309,7 +1455,7 @@ (when secret (let ((begin (widget-field-start field)) (end (widget-field-end field))) - (when size + (when size (while (and (> end begin) (eq (char-after (1- end)) ?\ )) (setq end (1- end)))) @@ -1325,7 +1471,7 @@ ;;; Widget Functions ;; -;; These functions are used in the definition of multiple widgets. +;; These functions are used in the definition of multiple widgets. (defun widget-parent-action (widget &optional event) "Tell :parent of WIDGET to handle the :action. @@ -1357,11 +1503,11 @@ (defun widget-value-convert-widget (widget) "Initialize :value from :args in WIDGET." (let ((args (widget-get widget :args))) - (when args + (when args (widget-put widget :value (car args)) ;; Don't convert :value here, as this is done in `widget-convert'. ;; (widget-put widget :value (widget-apply widget - ;; :value-to-internal (car args))) + ;; :value-to-internal (car args))) (widget-put widget :args nil))) widget) @@ -1377,13 +1523,14 @@ :value-to-external (lambda (widget value) value) :button-prefix 'widget-button-prefix :button-suffix 'widget-button-suffix - :complete 'widget-default-complete + :complete 'widget-default-complete :create 'widget-default-create :indent nil :offset 0 :format-handler 'widget-default-format-handler - :button-face-get 'widget-default-button-face-get - :sample-face-get 'widget-default-sample-face-get + :button-face-get 'widget-default-button-face-get + :sample-face-get 'widget-default-sample-face-get + :button-keymap widget-button-keymap :delete 'widget-default-delete :value-set 'widget-default-value-set :value-inline 'widget-default-value-inline @@ -1407,24 +1554,25 @@ "Create WIDGET at point in the current buffer." (widget-specify-insert (let ((from (point)) - button-begin button-end + button-begin button-end button-glyph sample-begin sample-end doc-begin doc-end value-pos) (insert (widget-get widget :format)) (goto-char from) - ;; Parse escapes in format. + ;; Parse escapes in format. Coding this in C would speed up + ;; things *a lot*. (while (re-search-forward "%\\(.\\)" nil t) (let ((escape (aref (match-string 1) 0))) (replace-match "" t t) (cond ((eq escape ?%) (insert "%")) ((eq escape ?\[) - (setq button-begin (point)) - (insert (widget-get-indirect widget :button-prefix))) + (setq button-begin (point-marker)) + (set-marker-insertion-type button-begin nil)) ((eq escape ?\]) - (insert (widget-get-indirect widget :button-suffix)) - (setq button-end (point))) + (setq button-end (point-marker)) + (set-marker-insertion-type button-end nil)) ((eq escape ?\{) (setq sample-begin (point))) ((eq escape ?\}) @@ -1434,10 +1582,12 @@ (insert "\n") (insert-char ?\ (widget-get widget :indent)))) ((eq escape ?t) - (let ((glyph (widget-get widget :tag-glyph)) - (tag (widget-get widget :tag))) - (cond (glyph - (widget-glyph-insert widget (or tag "image") glyph)) + (let* ((tag (widget-get widget :tag)) + (glyph (widget-get widget :tag-glyph))) + (cond (glyph + (setq button-glyph + (widget-glyph-insert + widget (or tag "Image") glyph))) (tag (insert tag)) (t @@ -1455,12 +1605,21 @@ ((eq escape ?v) (if (and button-begin (not button-end)) (widget-apply widget :value-create) - (setq value-pos (point)))) + (setq value-pos (point-marker)))) (t (widget-apply widget :format-handler escape))))) ;; Specify button, sample, and doc, and insert value. - (and button-begin button-end - (widget-specify-button widget button-begin button-end)) + (when (and button-begin button-end) + (unless button-glyph + (goto-char button-begin) + (insert (widget-get-indirect widget :button-prefix)) + (goto-char button-end) + (set-marker-insertion-type button-end t) + (insert (widget-get-indirect widget :button-suffix))) + (widget-specify-button widget button-begin button-end) + ;; Is this necessary? + (set-marker button-begin nil) + (set-marker button-end nil)) (and sample-begin sample-end (widget-specify-sample widget sample-begin sample-end)) (and doc-begin doc-end @@ -1468,8 +1627,8 @@ (when value-pos (goto-char value-pos) (widget-apply widget :value-create))) - (let ((from (copy-marker (point-min))) - (to (copy-marker (point-max)))) + (let ((from (point-min-marker)) + (to (point-max-marker))) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) @@ -1483,7 +1642,7 @@ (let* ((doc-property (widget-get widget :documentation-property)) (doc-try (cond ((widget-get widget :doc)) ((symbolp doc-property) - (documentation-property + (documentation-property (widget-get widget :value) doc-property)) (t @@ -1496,7 +1655,7 @@ (when doc-text (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) ;; The `*' in the beginning is redundant. (when (eq (aref doc-text 0) ?*) (setq doc-text (substring doc-text 1))) @@ -1505,14 +1664,14 @@ (setq doc-text (substring doc-text 0 (match-beginning 0)))) (push (widget-create-child-and-convert widget 'documentation-string - :indent (cond ((numberp doc-indent ) + :indent (cond ((numberp doc-indent) doc-indent) ((null doc-indent) nil) (t 0)) doc-text) buttons)))) - (t + (t (error "Unknown escape `%c'" escape))) (widget-put widget :buttons buttons))) @@ -1565,17 +1724,17 @@ (- old-pos to 1) (- old-pos from))))) ;;??? Bug: this ought to insert the new value before deleting the old one, - ;; so that markers on either side of the value automatically + ;; so that markers on either side of the value automatically ;; stay on the same side. -- rms. (save-excursion (goto-char (widget-get widget :from)) (widget-apply widget :delete) (widget-put widget :value value) (widget-apply widget :create)) - (if offset - (if (< offset 0) - (goto-char (+ (widget-get widget :to) offset 1)) - (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) + (when offset + (if (< offset 0) + (goto-char (+ (widget-get widget :to) offset 1)) + (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) (defun widget-default-value-inline (widget) ;; Wrap value in a list unless it is inline. @@ -1593,7 +1752,7 @@ "Return t iff this widget active (user modifiable)." (and (not (widget-get widget :inactive)) (let ((parent (widget-get widget :parent))) - (or (null parent) + (or (null parent) (widget-apply parent :active))))) (defun widget-default-deactivate (widget) @@ -1710,15 +1869,15 @@ ((and widget-push-button-gui (console-on-window-system-p)) (unless gui-glyphs - (let ((gui (make-gui-button tag 'widget-gui-action widget))) + (let* ((gui-button-shadow-thickness 1) + (gui (make-gui-button tag 'widget-gui-action widget))) (setq gui-glyphs (list (make-glyph `(,(nth 0 (aref gui 1)) [string :data ,text])) (make-glyph `(,(nth 1 (aref gui 1)) [string :data ,text])) (make-glyph `(,(nth 2 (aref gui 1)) [string :data ,text])))) - (setq widget-push-button-cache - (lax-plist-put widget-push-button-cache tag gui-glyphs)))) + (laxputf widget-push-button-cache tag gui-glyphs))) (widget-glyph-insert-glyph widget (nth 0 gui-glyphs) (nth 1 gui-glyphs) (nth 2 gui-glyphs))) (t @@ -1744,7 +1903,7 @@ "An embedded link." :button-prefix 'widget-link-prefix :button-suffix 'widget-link-suffix - :help-echo "Follow the link." + :help-echo "Follow the link" :format "%[%t%]") ;;; The `info-link' Widget. @@ -1769,7 +1928,7 @@ :action 'widget-url-link-action) (defun widget-url-link-help-echo (widget) - (concat "Go to ")) + (concat "Visit ")) (defun widget-url-link-action (widget &optional event) "Open the url specified by WIDGET." @@ -1874,15 +2033,27 @@ (defun widget-field-action (widget &optional event) ;; Edit the value in the minibuffer. - (let ((invalid (widget-apply widget :validate))) - (let ((prompt (concat (widget-apply widget :menu-tag-get) ": ")) - (value (unless invalid - (widget-value widget)))) - (let ((answer (widget-apply widget :prompt-value prompt value invalid))) - (widget-value-set widget answer))) - (widget-apply widget :notify widget event) - (widget-setup)) - (run-hook-with-args 'widget-edit-functions widget)) + (let* ((invalid (widget-apply widget :validate)) + (prompt (concat (widget-apply widget :menu-tag-get) ": ")) + (value (unless invalid + (widget-value widget))) + (answer (widget-apply widget :prompt-value prompt value invalid))) + (unless (equal value answer) + ;; This is a hack. We can't properly validate the widget + ;; because validation requires the new value to be in the field. + ;; However, widget-field-value-create will not function unless + ;; the new value matches. So, we check whether the thing + ;; matches, and if it does, use either the real or a dummy error + ;; message. + (unless (widget-apply widget :match answer) + (let ((error-message (or (widget-get widget :type-error) + "Invalid field contents"))) + (widget-put widget :error error-message) + (error error-message))) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup)) + (run-hook-with-args 'widget-edit-functions widget))) ;(defun widget-field-action (widget &optional event) ; ;; Move to next field. @@ -1903,23 +2074,24 @@ (let ((size (widget-get widget :size)) (value (widget-get widget :value)) (from (point)) - ;; This used to make `field-overlay' a cons of two markers, - ;; and revert them to a real overlay in `widget-setup', - ;; because you can't change overlay insertion type. However, - ;; we can do that with extents. - extent) + ;; This is changed to a real extent in `widget-setup'. We + ;; need the end points to behave differently until + ;; `widget-setup' is called. Should probably be replaced with + ;; a genuine extent, but some things break, then. + (extent (cons (make-marker) (make-marker)))) + (widget-put widget :field-extent extent) (insert value) (and size (< (length value) size) (insert-char ?\ (- size (length value)))) (unless (memq widget widget-field-list) (push widget widget-field-new)) - (setq extent (make-extent from (point))) - (set-extent-property extent 'end-open t) - (widget-put widget :field-extent extent) + (move-marker (cdr extent) (point)) + (set-marker-insertion-type (cdr extent) nil) (when (null size) (insert ?\n)) - (set-extent-property extent 'start-open t))) + (move-marker (car extent) from) + (set-marker-insertion-type (car extent) t))) (defun widget-field-value-delete (widget) ;; Remove the widget from the list of active editing fields. @@ -1937,24 +2109,25 @@ (size (widget-get widget :size)) (secret (widget-get widget :secret)) (old (current-buffer))) - (if (and from to) - (progn - (set-buffer buffer) - (while (and size - (not (zerop size)) - (> to from) - (eq (char-after (1- to)) ?\ )) - (setq to (1- to))) - (let ((result (buffer-substring-no-properties from to))) - (when secret - (let ((index 0)) - (while (< (+ from index) to) - (aset result index - (get-char-property (+ from index) 'secret)) - (incf index)))) - (set-buffer old) - result)) - (widget-get widget :value)))) + (cond + ((and from to) + (set-buffer buffer) + (while (and size + (not (zerop size)) + (> to from) + (eq (char-after (1- to)) ?\ )) + (setq to (1- to))) + (let ((result (buffer-substring-no-properties from to))) + (when secret + (let ((index 0)) + (while (< (+ from index) to) + (aset result index + (get-char-property (+ from index) 'secret)) + (incf index)))) + (set-buffer old) + result)) + (t + (widget-get widget :value))))) (defun widget-field-match (widget value) ;; Match any string. @@ -2078,7 +2251,7 @@ choices))) (widget-choose tag (reverse choices) event)))) (when current - (widget-value-set widget + (widget-value-set widget (widget-apply current :value-to-external (widget-get current :value))) (widget-setup) @@ -2128,12 +2301,12 @@ (defun widget-toggle-value-create (widget) ;; Insert text representing the `on' and `off' states. (if (widget-value widget) - (widget-glyph-insert widget - (widget-get widget :on) + (widget-glyph-insert widget + (widget-get widget :on) (widget-get widget :on-glyph)) - (widget-glyph-insert widget - (widget-get widget :off) - (widget-get widget :off-glyph)))) + (widget-glyph-insert widget + (widget-get widget :off) + (widget-get widget :off-glyph)))) (defun widget-toggle-action (widget &optional event) ;; Toggle value. @@ -2184,7 +2357,7 @@ ;; Insert all values (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) (args (widget-get widget :args))) - (while args + (while args (widget-checklist-add-item widget (car args) (assq (car args) alist)) (setq args (cdr args))) (widget-put widget :children (nreverse (widget-get widget :children))))) @@ -2194,8 +2367,8 @@ ;; If the item is checked, CHOSEN is a cons whose cdr is the value. (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (widget-specify-insert + (insert-char ?\ (widget-get widget :indent))) + (widget-specify-insert (let* ((children (widget-get widget :children)) (buttons (widget-get widget :buttons)) (button-args (or (widget-get type :sibling-args) @@ -2227,7 +2400,7 @@ (t (widget-create-child-value widget type (car (cdr chosen))))))) - (t + (t (error "Unknown escape `%c'" escape))))) ;; Update properties. (and button child (widget-put child :button button)) @@ -2267,14 +2440,14 @@ found) (while vals (let ((answer (widget-checklist-match-up args vals))) - (cond (answer + (cond (answer (let ((match (widget-match-inline answer vals))) (setq found (cons (cons answer (car match)) found) vals (cdr match) args (delq answer args)))) (greedy (setq vals (cdr vals))) - (t + (t (setq vals nil))))) found)) @@ -2293,7 +2466,7 @@ ;; The values of all selected items. (let ((children (widget-get widget :children)) child result) - (while children + (while children (setq child (car children) children (cdr children)) (if (widget-value (widget-get child :button)) @@ -2334,7 +2507,7 @@ :button-suffix "" :button-prefix "" :on "(*)" - :on-glyph "radio1" + :on-glyph '("radio1" nil "radio0") :off "( )" :off-glyph "radio0") @@ -2366,7 +2539,7 @@ ;; Insert all values (let ((args (widget-get widget :args)) arg) - (while args + (while args (setq arg (car args) args (cdr args)) (widget-radio-add-item widget arg)))) @@ -2376,8 +2549,8 @@ ;; (setq type (widget-convert type)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (widget-specify-insert + (insert-char ?\ (widget-get widget :indent))) + (widget-specify-insert (let* ((value (widget-get widget :value)) (children (widget-get widget :children)) (buttons (widget-get widget :buttons)) @@ -2397,7 +2570,7 @@ (insert "%")) ((eq escape ?b) (setq button (apply 'widget-create-child-and-convert - widget 'radio-button + widget 'radio-button :value (not (null chosen)) button-args))) ((eq escape ?v) @@ -2405,14 +2578,14 @@ (widget-create-child-value widget type value) (widget-create-child widget type))) - (unless chosen + (unless chosen (widget-apply child :deactivate))) - (t + (t (error "Unknown escape `%c'" escape))))) ;; Update properties. (when chosen (widget-put widget :choice type)) - (when button + (when button (widget-put child :button button) (widget-put widget :buttons (nconc buttons (list button)))) (when child @@ -2465,8 +2638,8 @@ (match (and (not found) (widget-apply current :match value)))) (widget-value-set button match) - (if match - (progn + (if match + (progn (widget-value-set current value) (widget-apply current :activate)) (widget-apply current :deactivate)) @@ -2509,12 +2682,12 @@ (define-widget 'insert-button 'push-button "An insert button for the `editable-list' widget." :tag "INS" - :help-echo "Insert a new item into the list at this position." + :help-echo "Insert a new item into the list at this position" :action 'widget-insert-button-action) (defun widget-insert-button-action (widget &optional event) ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) + (widget-apply (widget-get widget :parent) :insert-before (widget-get widget :widget))) ;;; The `delete-button' Widget. @@ -2522,12 +2695,12 @@ (define-widget 'delete-button 'push-button "A delete button for the `editable-list' widget." :tag "DEL" - :help-echo "Delete this item from the list." + :help-echo "Delete this item from the list" :action 'widget-delete-button-action) (defun widget-delete-button-action (widget &optional event) ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) + (widget-apply (widget-get widget :parent) :delete-at (widget-get widget :widget))) ;;; The `editable-list' Widget. @@ -2559,11 +2732,11 @@ (let ((widget-push-button-gui widget-editable-list-gui)) (cond ((eq escape ?i) (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (apply 'widget-create-child-and-convert + (insert-char ?\ (widget-get widget :indent))) + (apply 'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) - (t + (t (widget-default-format-handler widget escape))))) (defun widget-editable-list-value-create (widget) @@ -2617,11 +2790,11 @@ (inhibit-read-only t) before-change-functions after-change-functions) - (cond (before + (cond (before (goto-char (widget-get before :entry-from))) (t (goto-char (widget-get widget :value-pos)))) - (let ((child (widget-editable-list-entry-create + (let ((child (widget-editable-list-entry-create widget nil nil))) (when (< (widget-get child :entry-from) (widget-get widget :from)) (set-marker (widget-get widget :from) @@ -2667,10 +2840,10 @@ (let ((type (nth 0 (widget-get widget :args))) (widget-push-button-gui widget-editable-list-gui) child delete insert) - (widget-specify-insert + (widget-specify-insert (save-excursion (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) (insert (widget-get widget :entry-format))) ;; Parse % escapes in format. (while (re-search-forward "%\\(.\\)" nil t) @@ -2688,13 +2861,13 @@ (widget-get widget :delete-button-args)))) ((eq escape ?v) (if conv - (setq child (widget-create-child-value + (setq child (widget-create-child-value widget type value)) (setq child (widget-create-child widget type)))) - (t + (t (error "Unknown escape `%c'" escape))))) - (widget-put widget - :buttons (cons delete + (widget-put widget + :buttons (cons delete (cons insert (widget-get widget :buttons)))) (let ((entry-from (copy-marker (point-min))) @@ -2732,7 +2905,7 @@ value (cdr answer)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) (push (cond ((null answer) (widget-create-child widget arg)) ((widget-get arg :inline) @@ -2793,8 +2966,8 @@ widget-push-button-suffix)) (setq off "")) (if (widget-value widget) - (widget-glyph-insert widget on "down" "down-pushed") - (widget-glyph-insert widget off "right" "right-pushed")))) + (widget-glyph-insert widget on '("down" "down-pushed")) + (widget-glyph-insert widget off '("right" "right-pushed"))))) ;;; The `documentation-link' Widget. ;; @@ -2865,7 +3038,7 @@ (widget-put widget :buttons buttons))) (let ((indent (widget-get widget :indent))) (when (and indent (not (zerop indent))) - (save-excursion + (save-excursion (save-restriction (narrow-to-region from to) (goto-char (point-min)) @@ -2896,24 +3069,17 @@ (push (widget-create-child-and-convert widget 'visibility :help-echo (lambda (widget) - ;; This can get called directly from - ;; default-mouse-motion-handler, with an - ;; extent argument. - (and (extentp widget) - (setq - widget (widget-at - (extent-start-position widget)))) (concat (if (widget-value widget) "Hide" "Show") - " the rest of the documentation.")) + " the rest of the documentation")) :off "More" :action 'widget-parent-action shown) buttons) (when shown (setq start (point)) - (when (and indent (not (zerop indent))) + (when indent (insert-char ?\ indent)) (insert after) (widget-documentation-link-add widget start (point))) @@ -2925,7 +3091,7 @@ (defun widget-documentation-string-action (widget &rest ignore) ;; Toggle documentation. (let ((parent (widget-get widget :parent))) - (widget-put parent :documentation-shown + (widget-put parent :documentation-shown (not (widget-get parent :documentation-shown)))) ;; Redraw. (widget-value-set widget (widget-value widget))) @@ -2982,15 +3148,15 @@ (defun widget-regexp-validate (widget) "Check that the value of WIDGET is a valid regexp." - (let ((val (widget-value widget))) + (let ((value (widget-value widget))) (condition-case data (prog1 nil - (string-match val "")) + (string-match value "")) (error (widget-put widget :error (error-message-string data)) widget)))) (define-widget 'file 'string - "A file widget. + "A file widget. It will read a file name from the minibuffer when invoked." :complete-function 'widget-file-complete :prompt-value 'widget-file-prompt-value @@ -3050,7 +3216,7 @@ ;;; (widget-apply widget :notify widget event))) (define-widget 'directory 'file - "A directory widget. + "A directory widget. It will read a directory name from the minibuffer when invoked." :tag "Directory") @@ -3078,7 +3244,7 @@ (defun widget-symbol-prompt-internal (widget prompt initial history) ;; Read file from minibuffer. - (let ((answer (completing-read prompt obarray + (let ((answer (completing-read prompt obarray (widget-get widget :prompt-match) nil initial history))) (if (and (stringp answer) @@ -3251,12 +3417,12 @@ "A character." :tag "Character" :value 0 - :size 1 + :size 1 :format "%{%t%}: %v\n" - :valid-regexp "\\`.\\'" + :valid-regexp "\\`[\0-\377]\\'" :error "This field should contain a single character" :value-to-internal (lambda (widget value) - (if (stringp value) + (if (stringp value) value (char-to-string value))) :value-to-external (lambda (widget value) @@ -3279,7 +3445,7 @@ :value-to-internal (lambda (widget value) (append value nil)) :value-to-external (lambda (widget value) (vconcat value))) -(defun widget-vector-match (widget value) +(defun widget-vector-match (widget value) (and (vectorp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) @@ -3294,7 +3460,7 @@ :value-to-external (lambda (widget value) (cons (car value) (cadr value)))) -(defun widget-cons-match (widget value) +(defun widget-cons-match (widget value) (and (consp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) @@ -3308,7 +3474,7 @@ :prompt-value 'widget-choice-prompt-value) (defun widget-choice-prompt-value (widget prompt value unbound) - "Make a choice." + "Make a choice." (let ((args (widget-get widget :args)) (completion-ignore-case (widget-get widget :case-fold)) current choices old) @@ -3381,7 +3547,7 @@ ;;; The `color' Widget. -(define-widget 'color 'editable-field +(define-widget 'color 'editable-field "Choose a color name (with sample)." :format "%[%t%]: %v (%{sample%})\n" :size 10 @@ -3403,7 +3569,7 @@ ((null completion) (error "Can't find completion for \"%s\"" prefix)) ((not (string-equal prefix completion)) - (insert-and-inherit (substring completion (length prefix)))) + (insert (substring completion (length prefix)))) (t (message "Making completion list...") (let ((list (all-completions prefix list nil))) @@ -3412,13 +3578,17 @@ (message "Making completion list...done"))))) (defun widget-color-sample-face-get (widget) - (let* ((value (condition-case nil - (widget-value widget) - (error (widget-get widget :value)))) - (symbol (intern (concat "fg:" value)))) - (prog1 symbol - (or (find-face symbol) - (set-face-foreground (make-face symbol) value))))) + (or (widget-get widget :sample-face) + (let ((color (widget-value widget)) + (face (make-face (gensym "sample-face-") nil t))) + ;; Use the face object, not its name, to prevent lossage if gc + ;; happens before applying the face. + (widget-put widget :sample-face face) + (and color + (not (equal color "")) + (valid-color-name-p color) + (set-face-foreground face color)) + face))) (defvar widget-color-choice-list nil) ;; Variable holding the possible colors. @@ -3441,10 +3611,14 @@ (defun widget-color-notify (widget child &optional event) "Update the sample, and notify the parent." - (set-extent-property (widget-get widget :sample-extent) - 'face (widget-apply widget :sample-face-get)) + (let* ((face (widget-apply widget :sample-face-get)) + (color (widget-value widget))) + (if (valid-color-name-p color) + (set-face-foreground face color) + (remove-face-property face 'foreground))) (widget-default-notify widget child event)) +;; Is this a misnomer? (defun widget-at (pos) "The button or field at POS." (or (get-char-property pos 'button) @@ -3454,11 +3628,10 @@ "Display the help echo for widget at POS." (let* ((widget (widget-at pos)) (help-echo (and widget (widget-get widget :help-echo)))) - (cond ((stringp help-echo) - (message "%s" help-echo)) - ((and (functionp help-echo) - (stringp (setq help-echo (funcall help-echo widget)))) - (message "%s" help-echo))))) + (and (functionp help-echo) + (setq help-echo (funcall help-echo widget))) + (when (stringp help-echo) + (display-message 'no-log help-echo)))) ;;; The End: diff -r d3e9274cbc4e -r e45d5e7c476e lisp/default.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/default.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1 @@ +;; default.el --- Site-wide file run after User's init file is run. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/edebug/custom-load.el --- a/lisp/edebug/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/edebug/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,10 +1,9 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Sep 27 08:13:42 1997 ;;; Code: -(custom-put 'lisp 'custom-loads '("edebug")) -(custom-put 'edebug 'custom-loads '("edebug")) +(custom-add-loads 'lisp '("edebug")) +(custom-add-loads 'edebug '("edebug")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/Makefile --- a/lisp/ediff/Makefile Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -# -# Makefile for compiling and installing EDIFF -# - -# -------- USER MAY NEED TO CHANGE THESE --------------------- -# To compile under XEmacs, uncomment XEmacs-specific versions of the -# variables VERSION, EMACS, DATADIR and comment out the Emacs-specific -# versions. - -VERSION = 20.0 -EMACS = emacs-$(VERSION) -#VERSION = 20.3 -#EMACS = xemacs-$(VERSION) -PREFIX = /usr/local -DATADIR = $(PREFIX)/share -#DATADIR = $(PREFIX)/lib -LISPDIR = $(DATADIR)/emacs/site-lisp -INFODIR = $(PREFIX)/info -ETCDIR = $(DATADIR)/emacs/$(VERSION)/etc -COMPDIR = - -# --------- YOU PROBABLY DON'T WANT TO CHANGE THESE ---------------- -TeX = tex -TEXINDEX = texindex -MAKEINFO = makeinfo -INSTALL = install - -# --------- ONLY AUTHORIZED PERSONNEL BEYOND THIS POINT!!! ------------ -EDIFF = ediff-init.el ediff-help.el ediff-diff.el ediff-merg.el \ - ediff-wind.el ediff-util.el ediff-mult.el ediff-vers.el \ - ediff-ptch.el ediff.el ediff-hook.el ediff-tbar.el -EDIFFelc = $(COMPDIR)ediff-init.elc \ - $(COMPDIR)ediff-help.elc \ - $(COMPDIR)ediff-diff.elc \ - $(COMPDIR)ediff-merg.elc \ - $(COMPDIR)ediff-wind.elc \ - $(COMPDIR)ediff-util.elc \ - $(COMPDIR)ediff-mult.elc \ - $(COMPDIR)ediff-vers.elc \ - $(COMPDIR)ediff-ptch.elc \ - $(COMPDIR)ediff.elc \ - $(COMPDIR)ediff-hook.elc \ - $(COMPDIR)ediff-tbar.elc - -COMPILE_ARGS = -batch -f batch-byte-compile - - -all: hello elc goodbye dvi info - -elc: $(EDIFFelc) - -goodbye: - @echo "" - @echo "" - @echo "" - @echo " The above compiler warnings were normal -- don't panic!" - @echo "" - @echo " Please report bugs via M-x ediff-submit-report" - @echo "" - @echo "" - @echo "" - -hello: - @echo "" - @echo "" - @echo "Byte compiling using Emacs" - @echo "Use make EMACS=xemacs to compile under XEmacs" - @echo "" - @echo "" - @echo " The following compiler warnings are normal -- don't panic!" - @echo "" - @echo "" - @echo "" - -$(COMPDIR)ediff-init.elc: ediff-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-init.el - -$(COMPDIR)ediff-help.elc: ediff-help.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-help.el - -$(COMPDIR)ediff-hook.elc: ediff-hook.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-hook.el - -$(COMPDIR)ediff-tbar.elc: ediff-tbar.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-tbar.el - -$(COMPDIR)ediff-diff.elc: ediff-init.el ediff-diff.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-diff.el - -$(COMPDIR)ediff-merg.elc: ediff-init.el ediff-merg.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-merg.el - -$(COMPDIR)ediff-mult.elc: ediff-init.el ediff-mult.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-mult.el - -$(COMPDIR)ediff-vers.elc: ediff-init.el ediff-vers.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-vers.el - -$(COMPDIR)ediff-ptch.elc: ediff-init.el ediff-ptch.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-ptch.el - -$(COMPDIR)ediff.elc: ediff-init.el ediff.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff.el - -$(COMPDIR)ediff-util.elc: ediff-init.el ediff-util.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-util.el - -$(COMPDIR)ediff-wind.elc: ediff-init.el ediff-wind.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-wind.el - -ediff.dvi: ediff.texi - @echo "" - @echo "" - @echo "Making ediff.dvi --- a Printable Version of the Ediff Manual"; - @echo "" - $(TeX) ediff.texi - @echo "" - @echo "Indexing " - $(TEXINDEX) ediff.cp - $(TEXINDEX) ediff.fn - $(TEXINDEX) ediff.pg - $(TEXINDEX) ediff.vr - @echo "" - @echo "Texing Again"; - $(TeX) ediff.texi - @echo "" - -ediff: ediff.texi - @echo "" - @echo "" - @echo "Making Info Files for the Ediff Manual" - @echo "" - $(MAKEINFO) ediff.texi - @echo "Info done" - -dvi: ediff.dvi - -info: ediff - -install: all - $(INSTALL) -m444 $(EDIFF) $(LISPDIR) - $(INSTALL) -m644 ediff*.elc $(LISPDIR) - $(INSTALL) -m644 ediff.dvi $(ETCDIR) - $(INSTALL) -m444 ediff ediff-? $(INFODIR) - @echo "" - @echo "Please move ediff.texi to emacs-distribution-directory/man/" - @echo "" - -clean: - rm -f ediff*.elc *~ core - -distclean: clean - -realclean: clean - rm -f *.dvi ../info/ediff ../info/ediff-? - rm -f ediff.aux ediff.cp ediff.cps ediff.fn ediff.fns ediff.ky \ - ediff.kys ediff.log ediff.pg ediff.pgs ediff.toc ediff.tp \ - ediff.tps ediff.vr ediff.vrs diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/README --- a/lisp/ediff/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ -**** EDIFF -- a comprehensive interface to diff for Emacs 19 and XEmacs 19 - -**** This version of Ediff requires *at least* Emacs 19.34 or XEmacs 19.14 - -This directory: - -README -- This file -Makefile -- Automated installation file -ediff.texi -- Manual in Texinfo format -ediff, ediff-? -- The Info files -ediff.dvi -- Manual in DVI format - -ediff.el -- Ediff Emacs Lisp code -ediff-init.el -- Ediff Emacs Lisp code -ediff-help.el -- Ediff Emacs Lisp code -ediff-wind.el -- Ediff Emacs Lisp code -ediff-util.el -- Ediff Emacs Lisp code -ediff-diff.el -- Ediff Emacs Lisp code -ediff-merg.el -- Ediff Emacs Lisp code -ediff-mult.el -- Ediff Emacs Lisp code -ediff-vers.el -- Ediff Emacs Lisp code -ediff-ptch.el -- Ediff Emacs Lisp code -ediff-tbar.el -- Ediff Emacs Lisp code -- for XEmacs only -ediff-hook.el -- Ediff Emacs Lisp code -toolbar/ -- Ediff toolbar icons -- for XEmacs only - - -To install Ediff do: - - uncompress ediff.tar.Z - tar xf ediff.tar - - -Then do the following: - -1. To compile Lisp: - - make (or 'make all') - -2. You can also type - - make install - - to do what "make all" does plus it will copy the files ediff*.elc - into a suitable Lisp directory. - - To make this happen, you will most likely have to change the PREFIX - variable in Makefile and, possibly, one or more of these variables: - - DATADIR, LISPDIR, INFODIR, ETCDIR, and VERSION - - if they don't point to the right directories in your installation. - You also need to have a write permission for all directories - mentioned in LISPDIR, INFODIR, and ETCDIR. - -3. XEmacs users must invoke `make' with the parameter EMACS=xemacs - or whatever name is used to invoke XEmacs (some sites still use xemacs - for Emacs 18). An even better thing would be to edit Makefile directly - as indicated in the comments there. - -4. Under XEmacs, copy the icons in the `toolbar' directory into - the-directory-where-xemacs-installed/etc/toolbar/ - -Normally, all Ediff menus and autoloads are already defined in Emacs, so you -don't need to define anything in your .emacs to run Ediff. -However, if it was announced that this distribution of Ediff contains -new features, you may need to put - -(require 'ediff-hook) - -in your .emacs to take advantage of these new features. This doesn't load -Ediff, but readies Emacs for the things to come. When this version of -Ediff gets installed in the standard Emacs distribution, you can remove -the above require-statement (but leaving it in does no harm). diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/auto-autoloads.el --- a/lisp/ediff/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'ediff-autoloads) (error "Already loaded")) - -;;;### (autoloads (ediff-show-registry) "ediff-mult" "ediff/ediff-mult.el") - -(autoload 'ediff-show-registry "ediff-mult" "\ -Display Ediff's registry." t nil) - -(defalias 'eregistry 'ediff-show-registry) - -;;;*** - -;;;### (autoloads (ediff-toggle-use-toolbar ediff-toggle-multiframe) "ediff-util" "ediff/ediff-util.el") - -(autoload 'ediff-toggle-multiframe "ediff-util" "\ -Switch from multiframe display to single-frame display and back. -To change the default, set the variable `ediff-window-setup-function', -which see." t nil) - -(autoload 'ediff-toggle-use-toolbar "ediff-util" "\ -Enable or disable Ediff toolbar. -Works only in versions of Emacs that support toolbars. -To change the default, set the variable `ediff-use-toolbar-p', which see." t nil) - -;;;*** - -;;;### (autoloads (ediff-documentation ediff-version ediff-revision ediff-patch-buffer ediff-patch-file run-ediff-from-cvs-buffer ediff-merge-revisions-with-ancestor ediff-merge-revisions ediff-merge-buffers-with-ancestor ediff-merge-buffers ediff-merge-files-with-ancestor ediff-merge-files ediff-regions-linewise ediff-regions-wordwise ediff-windows-linewise ediff-windows-wordwise ediff-merge-directory-revisions-with-ancestor ediff-merge-directory-revisions ediff-merge-directories-with-ancestor ediff-merge-directories ediff-directories3 ediff-directory-revisions ediff-directories ediff-buffers3 ediff-buffers ediff-files3 ediff-files) "ediff" "ediff/ediff.el") - -(autoload 'ediff-files "ediff" "\ -Run Ediff on a pair of files, FILE-A and FILE-B." t nil) - -(autoload 'ediff-files3 "ediff" "\ -Run Ediff on three files, FILE-A, FILE-B, and FILE-C." t nil) - -(defalias 'ediff3 'ediff-files3) - -(defalias 'ediff 'ediff-files) - -(autoload 'ediff-buffers "ediff" "\ -Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B." t nil) - -(defalias 'ebuffers 'ediff-buffers) - -(autoload 'ediff-buffers3 "ediff" "\ -Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C." t nil) - -(defalias 'ebuffers3 'ediff-buffers3) - -(autoload 'ediff-directories "ediff" "\ -Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." t nil) - -(defalias 'edirs 'ediff-directories) - -(autoload 'ediff-directory-revisions "ediff" "\ -Run Ediff on a directory, DIR1, comparing its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." t nil) - -(defalias 'edir-revisions 'ediff-directory-revisions) - -(autoload 'ediff-directories3 "ediff" "\ -Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that -have the same name in all three. The last argument, REGEXP, is a regular -expression that can be used to filter out certain file names." t nil) - -(defalias 'edirs3 'ediff-directories3) - -(autoload 'ediff-merge-directories "ediff" "\ -Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." t nil) - -(defalias 'edirs-merge 'ediff-merge-directories) - -(autoload 'ediff-merge-directories-with-ancestor "ediff" "\ -Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors. -Ediff merges files that have identical names in DIR1, DIR2. If a pair of files -in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge -without ancestor. The fourth argument, REGEXP, is a regular expression that -can be used to filter out certain file names." t nil) - -(autoload 'ediff-merge-directory-revisions "ediff" "\ -Run Ediff on a directory, DIR1, merging its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." t nil) - -(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions) - -(autoload 'ediff-merge-directory-revisions-with-ancestor "ediff" "\ -Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." t nil) - -(defalias 'edir-merge-revisions-with-ancestor 'ediff-merge-directory-revisions-with-ancestor) - -(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor) - -(autoload 'ediff-windows-wordwise "ediff" "\ -Compare WIND-A and WIND-B, which are selected by clicking, wordwise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." t nil) - -(autoload 'ediff-windows-linewise "ediff" "\ -Compare WIND-A and WIND-B, which are selected by clicking, linewise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." t nil) - -(autoload 'ediff-regions-wordwise "ediff" "\ -Run Ediff on a pair of regions in two different buffers. -Regions (i.e., point and mark) are assumed to be set in advance. -This function is effective only for relatively small regions, up to 200 -lines. For large regions, use `ediff-regions-linewise'." t nil) - -(autoload 'ediff-regions-linewise "ediff" "\ -Run Ediff on a pair of regions in two different buffers. -Regions (i.e., point and mark) are assumed to be set in advance. -Each region is enlarged to contain full lines. -This function is effective for large regions, over 100-200 -lines. For small regions, use `ediff-regions-wordwise'." t nil) - -(defalias 'ediff-merge 'ediff-merge-files) - -(autoload 'ediff-merge-files "ediff" "\ -Merge two files without ancestor." t nil) - -(autoload 'ediff-merge-files-with-ancestor "ediff" "\ -Merge two files with ancestor." t nil) - -(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor) - -(autoload 'ediff-merge-buffers "ediff" "\ -Merge buffers without ancestor." t nil) - -(autoload 'ediff-merge-buffers-with-ancestor "ediff" "\ -Merge buffers with ancestor." t nil) - -(autoload 'ediff-merge-revisions "ediff" "\ -Run Ediff by merging two revisions of a file. -The file is the optional FILE argument or the file visited by the current -buffer." t nil) - -(autoload 'ediff-merge-revisions-with-ancestor "ediff" "\ -Run Ediff by merging two revisions of a file with a common ancestor. -The file is the the optional FILE argument or the file visited by the current -buffer." t nil) - -(autoload 'run-ediff-from-cvs-buffer "ediff" "\ -Run Ediff-merge on appropriate revisions of the selected file. -First run after `M-x cvs-update'. Then place the cursor on a line describing a -file and then run `run-ediff-from-cvs-buffer'." t nil) - -(autoload 'ediff-patch-file "ediff" "\ -Run Ediff by patching SOURCE-FILENAME." t nil) - -(autoload 'ediff-patch-buffer "ediff" "\ -Run Ediff by patching BUFFER-NAME." t nil) - -(defalias 'epatch 'ediff-patch-file) - -(defalias 'epatch-buffer 'ediff-patch-buffer) - -(autoload 'ediff-revision "ediff" "\ -Run Ediff by comparing versions of a file. -The file is an optional FILE argument or the file visited by the current -buffer. Use `vc.el' or `rcs.el' depending on `ediff-version-control-package'." t nil) - -(defalias 'erevision 'ediff-revision) - -(autoload 'ediff-version "ediff" "\ -Return string describing the version of Ediff. -When called interactively, displays the version." t nil) - -(autoload 'ediff-documentation "ediff" "\ -Display Ediff's manual. -With optional NODE, goes to that node." t nil) - -;;;*** - -(provide 'ediff-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/custom-load.el --- a/lisp/ediff/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sat Oct 4 18:11:25 1997 - -;;; Code: - -(custom-put 'tools 'custom-loads '("ediff")) -(custom-put 'ediff-diff 'custom-loads '("ediff-diff")) -(custom-put 'frames 'custom-loads '("ediff-wind")) -(custom-put 'ediff-ptch 'custom-loads '("ediff-ptch")) -(custom-put 'ediff-merge 'custom-loads '("ediff-merg")) -(custom-put 'ediff-mult 'custom-loads '("ediff-mult")) -(custom-put 'ediff 'custom-loads '("ediff-diff" "ediff-init" "ediff-merg" "ediff-mult" "ediff-ptch" "ediff-wind" "ediff")) - -;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-diff.el --- a/lisp/ediff/ediff-diff.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1246 +0,0 @@ -;;; ediff-diff.el --- diff-related utilities - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-diff) - -;; compiler pacifier -(defvar ediff-default-variant) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defgroup ediff-diff nil - "Diff related utilities" - :prefix "ediff-" - :group 'ediff) - - -(defcustom ediff-shell - (cond ((eq system-type 'emx) "cmd") ; OS/2 - ((memq system-type '(ms-dos windows-nt windows-95)) - shell-file-name) ; no standard name on MS-DOS - ((memq system-type '(vax-vms axp-vms)) "*dcl*") ; VMS - (t "sh")) ; UNIX - "*The shell used to run diff and patch. If user's .profile or -.cshrc files are set up correctly, any shell will do. However, some people -set $prompt or other things incorrectly, which leads to undesirable output -messages. These may cause Ediff to fail. In such a case, set ediff-shell -to a shell that you are not using or, better, fix your shell's startup file." - :type 'string - :group 'ediff-diff) - - -(defcustom ediff-diff-program "diff" - "*Program to use for generating the differential of the two files." - :type 'string - :group 'ediff-diff) -(defcustom ediff-diff-options "" - "*Options to pass to `ediff-diff-program'. -If diff\(1\) is used as `ediff-diff-program', then the most useful options are -`-w', to ignore space, and `-i', to ignore case of letters. -At present, the option `-c' is not allowed." - :type 'string - :group 'ediff-diff) - -(defcustom ediff-custom-diff-program ediff-diff-program - "*Program to use for generating custom diff output for saving it in a file. -This output is not used by Ediff internally." - :type 'string - :group 'ediff-diff) -(defcustom ediff-custom-diff-options "-c" - "*Options to pass to `ediff-custom-diff-program'." - :type 'string - :group 'ediff-diff) - -;;; Support for diff3 - -(defvar ediff-match-diff3-line "^====\\(.?\\)$" - "Pattern to match lines produced by diff3 that describe differences.") -(defcustom ediff-diff3-program "diff3" - "*Program to be used for three-way comparison. -Must produce output compatible with Unix's diff3 program." - :type 'string - :group 'ediff-diff) -(defcustom ediff-diff3-options "" - "*Options to pass to `ediff-diff3-program'." - :type 'string - :group 'ediff-diff) -(defcustom ediff-diff3-ok-lines-regexp - "^\\([1-3]:\\|====\\| \\|.*Warning *:\\|.*No newline\\|.*missing newline\\|^\C-m$\\)" - "*Regexp that matches normal output lines from `ediff-diff3-program'. -Lines that do not match are assumed to be error messages." - :type 'regexp - :group 'ediff-diff) - -;; keeps the status of the current diff in 3-way jobs. -;; the status can be =diff(A), =diff(B), or =diff(A+B) -(ediff-defvar-local ediff-diff-status "" "") - - -;;; Fine differences - -(ediff-defvar-local ediff-auto-refine (if (ediff-has-face-support-p) 'on 'nix) - "If `on', Ediff auto-highlights fine diffs for the current diff region. -If `off', auto-highlighting is not used. If `nix', no fine diffs are shown -at all, unless the user force-refines the region by hitting `*'. - -This variable can be set either in .emacs or toggled interactively. -Use `setq-default' if setting it in .emacs") - -(ediff-defvar-local ediff-ignore-similar-regions nil - "*If t, skip over difference regions that differ only in the white space and line breaks. -This variable can be set either in .emacs or toggled interactively. -Use `setq-default' if setting it in .emacs") - -(ediff-defvar-local ediff-auto-refine-limit 1400 - "*Auto-refine only the regions of this size \(in bytes\) or less.") - -;;; General - -(defvar ediff-diff-ok-lines-regexp - "^\\([0-9,]+[acd][0-9,]+$\\|[<>] \\|---\\|.*Warning *:\\|.*No +newline\\|.*missing +newline\\|^\C-m$\\)" - "Regexp that matches normal output lines from `ediff-diff-program'. -This is mostly lifted from Emerge, except that Ediff also considers -warnings and `Missing newline'-type messages to be normal output. -Lines that do not match are assumed to be error messages.") - -(defvar ediff-match-diff-line (let ((x "\\([0-9]+\\)\\(\\|,\\([0-9]+\\)\\)")) - (concat "^" x "\\([acd]\\)" x "$")) - "Pattern to match lines produced by diff that describe differences.") - -(ediff-defvar-local ediff-setup-diff-regions-function nil - "value is a function symbol depending on the kind of job is to be done. -For 2-way jobs and for ediff-merge, it should be `ediff-setup-diff-regions'. -For jobs requiring diff3, it should be `ediff-setup-diff-regions3'. - -The function should take three mandatory arguments, file-A, file-B, and -file-C. It may ignore file C for diff2 jobs. It should also take -one optional arguments, diff-number to refine.") - - -;;; Functions - -;; Generate the difference vector and overlays for the two files -;; With optional arg REG-TO-REFINE, refine this region. -;; File-C argument is not used here. It is there just because -;; ediff-setup-diff-regions is called via a funcall to -;; ediff-setup-diff-regions-function, which can also have the value -;; ediff-setup-diff-regions3, which takes 4 arguments. -(defun ediff-setup-diff-regions (file-A file-B file-C) - (if (string-match "c" ediff-diff-options) - (error "Option `-c' is not allowed in `ediff-diff-options'")) - - ;; create, if it doesn't exist - (or (ediff-buffer-live-p ediff-diff-buffer) - (setq ediff-diff-buffer - (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*")))) - (ediff-make-diff2-buffer ediff-diff-buffer file-A file-B) - (ediff-prepare-error-list ediff-diff-ok-lines-regexp ediff-diff-buffer) - (ediff-convert-diffs-to-overlays - (ediff-extract-diffs - ediff-diff-buffer ediff-word-mode ediff-narrow-bounds))) - -;; Run the diff program on FILE1 and FILE2 and put the output in DIFF-BUFFER -;; Return the size of DIFF-BUFFER -(defun ediff-make-diff2-buffer (diff-buffer file1 file2) - (let ((file1-size (ediff-file-size file1)) - (file2-size (ediff-file-size file2))) - (cond ((not (numberp file1-size)) - (message "Can't find file: %s" - (ediff-abbreviate-file-name file1)) - (sit-for 2) - ;; 1 is an error exit code - 1) - ((not (numberp file2-size)) - (message "Can't find file: %s" - (ediff-abbreviate-file-name file2)) - (sit-for 2) - ;; 1 is an error exit code - 1) - ((< file1-size 0) - (message "Can't diff remote files: %s" - (ediff-abbreviate-file-name file1)) - (sit-for 2) - ;; 1 is an error exit code - 1) - ((< file2-size 0) - (message "Can't diff remote file: %s" - (ediff-abbreviate-file-name file2)) - (sit-for 2) - (message "") - ;; 1 is an error exit code - 1) - (t (message "Computing differences between %s and %s ..." - (file-name-nondirectory file1) - (file-name-nondirectory file2)) - ;; this erases the diff buffer automatically - (ediff-exec-process ediff-diff-program - diff-buffer - 'synchronize - ediff-diff-options file1 file2) - (message "") - (ediff-with-current-buffer diff-buffer - (buffer-size)))))) - - - -;; If file-A/B/C is nil, do 2-way comparison with the non-nil buffers -;; This function works for diff3 and diff2 jobs -(defun ediff-setup-fine-diff-regions (file-A file-B file-C reg-num) - (or (ediff-buffer-live-p ediff-fine-diff-buffer) - (setq ediff-fine-diff-buffer - (get-buffer-create - (ediff-unique-buffer-name "*ediff-fine-diff" "*")))) - - (let (diff3-job diff-program diff-options ok-regexp diff-list) - (setq diff3-job ediff-3way-job - diff-program (if diff3-job ediff-diff3-program ediff-diff-program) - diff-options (if diff3-job ediff-diff3-options ediff-diff-options) - ok-regexp (if diff3-job - ediff-diff3-ok-lines-regexp - ediff-diff-ok-lines-regexp)) - - (ediff-message-if-verbose "Refining difference region %d ..." (1+ reg-num)) - (ediff-exec-process diff-program ediff-fine-diff-buffer 'synchronize - diff-options - ;; The shuffle below is because we can compare 3-way - ;; or in several 2-way fashions, like fA fC, fA fB, - ;; or fB fC. - (if file-A file-A file-B) - (if file-B file-B file-A) - (if diff3-job - (if file-C file-C file-B)) - ) ; exec process - - (ediff-prepare-error-list ok-regexp ediff-fine-diff-buffer) - (ediff-message-if-verbose - "") - ;; "Refining difference region %d ... done" (1+ reg-num)) - - (setq diff-list - (if diff3-job - (ediff-extract-diffs3 - ediff-fine-diff-buffer '3way-comparison 'word-mode) - (ediff-extract-diffs ediff-fine-diff-buffer 'word-mode))) - ;; fixup diff-list - (if diff3-job - (cond ((not file-A) - (mapcar (function (lambda (elt) - (aset elt 0 nil) - (aset elt 1 nil))) - (cdr diff-list))) - ((not file-B) - (mapcar (function (lambda (elt) - (aset elt 2 nil) - (aset elt 3 nil))) - (cdr diff-list))) - ((not file-C) - (mapcar (function (lambda (elt) - (aset elt 4 nil) - (aset elt 5 nil))) - (cdr diff-list))) - )) - - (ediff-convert-fine-diffs-to-overlays diff-list reg-num) - )) - - -(defun ediff-prepare-error-list (ok-regexp diff-buff) - (or (ediff-buffer-live-p ediff-error-buffer) - (setq ediff-error-buffer - (get-buffer-create (ediff-unique-buffer-name - "*ediff-errors" "*")))) - (ediff-with-current-buffer ediff-error-buffer - (erase-buffer) - (insert (ediff-with-current-buffer diff-buff (buffer-string))) - (goto-char (point-min)) - (delete-matching-lines ok-regexp) - (if (memq system-type '(vax-vms axp-vms)) - (delete-matching-lines "^$"))) - ;; If diff reports errors, show them then quit. - (if (/= 0 (ediff-with-current-buffer ediff-error-buffer (buffer-size))) - (let ((ctl-buf ediff-control-buffer) - (error-buf ediff-error-buffer)) - (ediff-skip-unsuitable-frames) - (switch-to-buffer error-buf) - (ediff-kill-buffer-carefully ctl-buf) - (error "Errors in diff output. Diff output is in %S" diff-buff)))) - -;; BOUNDS specifies visibility bounds to use. -;; WORD-MODE tells whether we are in the word-mode or not. -;; If WORD-MODE, also construct vector of diffs using word numbers. -;; Else, use point values. -;; This function handles diff-2 jobs including the case of -;; merging buffers and files without ancestor. -(defun ediff-extract-diffs (diff-buffer word-mode &optional bounds) - (let ((A-buffer ediff-buffer-A) - (B-buffer ediff-buffer-B) - (C-buffer ediff-buffer-C) - (a-prev 1) ; this is needed to set the first diff line correctly - (b-prev 1) - (c-prev 1) - diff-list shift-A shift-B - ) - - ;; diff list contains word numbers, unless changed later - (setq diff-list (cons (if word-mode 'words 'points) - diff-list)) - ;; we don't use visibility bounds for buffer C when merging - (if bounds - (setq shift-A - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'A bounds)) - shift-B - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'B bounds)))) - - ;; reset point in buffers A/B/C - (ediff-with-current-buffer A-buffer - (goto-char (if shift-A shift-A (point-min)))) - (ediff-with-current-buffer B-buffer - (goto-char (if shift-B shift-B (point-min)))) - (if (ediff-buffer-live-p C-buffer) - (ediff-with-current-buffer C-buffer - (goto-char (point-min)))) - - (ediff-with-current-buffer diff-buffer - (goto-char (point-min)) - (while (re-search-forward ediff-match-diff-line nil t) - (let* ((a-begin (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (a-end (let ((b (match-beginning 3)) - (e (match-end 3))) - (if b - (string-to-int (buffer-substring b e)) - a-begin))) - (diff-type (buffer-substring (match-beginning 4) (match-end 4))) - (b-begin (string-to-int (buffer-substring (match-beginning 5) - (match-end 5)))) - (b-end (let ((b (match-beginning 7)) - (e (match-end 7))) - (if b - (string-to-int (buffer-substring b e)) - b-begin))) - a-begin-pt a-end-pt b-begin-pt b-end-pt - c-begin c-end c-begin-pt c-end-pt) - ;; fix the beginning and end numbers, because diff is somewhat - ;; strange about how it numbers lines - (if (string-equal diff-type "a") - (setq b-end (1+ b-end) - a-begin (1+ a-begin) - a-end a-begin) - (if (string-equal diff-type "d") - (setq a-end (1+ a-end) - b-begin (1+ b-begin) - b-end b-begin) - ;; (string-equal diff-type "c") - (setq a-end (1+ a-end) - b-end (1+ b-end)))) - - (if (eq ediff-default-variant 'default-B) - (setq c-begin b-begin - c-end b-end) - (setq c-begin a-begin - c-end a-end)) - - ;; compute main diff vector - (if word-mode - ;; make diff-list contain word numbers - (setq diff-list - (nconc diff-list - (list - (if (ediff-buffer-live-p C-buffer) - (vector (- a-begin a-prev) (- a-end a-begin) - (- b-begin b-prev) (- b-end b-begin) - (- c-begin c-prev) (- c-end c-begin) - nil nil ; dummy ancestor - nil ; state of diff - nil ; state of merge - nil ; state of ancestor - ) - (vector (- a-begin a-prev) (- a-end a-begin) - (- b-begin b-prev) (- b-end b-begin) - nil nil ; dummy buf C - nil nil ; dummy ancestor - nil ; state of diff - nil ; state of merge - nil ; state of ancestor - )) - )) - a-prev a-end - b-prev b-end - c-prev c-end) - ;; else convert lines to points - (ediff-with-current-buffer A-buffer - (forward-line (- a-begin a-prev)) - (setq a-begin-pt (point)) - (forward-line (- a-end a-begin)) - (setq a-end-pt (point) - a-prev a-end)) - (ediff-with-current-buffer B-buffer - (forward-line (- b-begin b-prev)) - (setq b-begin-pt (point)) - (forward-line (- b-end b-begin)) - (setq b-end-pt (point) - b-prev b-end)) - (if (ediff-buffer-live-p C-buffer) - (ediff-with-current-buffer C-buffer - (forward-line (- c-begin c-prev)) - (setq c-begin-pt (point)) - (forward-line (- c-end c-begin)) - (setq c-end-pt (point) - c-prev c-end))) - (setq diff-list - (nconc - diff-list - (list - (if (ediff-buffer-live-p C-buffer) - (vector - a-begin-pt a-end-pt b-begin-pt b-end-pt - c-begin-pt c-end-pt - nil nil ; dummy ancestor - ;; state of diff - ;; shows which buff is different from the other two - (if (eq ediff-default-variant 'default-B) 'A 'B) - ediff-default-variant ; state of merge - nil ; state of ancestor - ) - (vector a-begin-pt a-end-pt - b-begin-pt b-end-pt - nil nil ; dummy buf C - nil nil ; dummy ancestor - nil nil ; dummy state of diff & merge - nil ; dummy state of ancestor - ))) - ))) - - ))) ; end ediff-with-current-buffer - diff-list - )) - - -(defun ediff-convert-diffs-to-overlays (diff-list) - (ediff-set-diff-overlays-in-one-buffer 'A diff-list) - (ediff-set-diff-overlays-in-one-buffer 'B diff-list) - (if ediff-3way-job - (ediff-set-diff-overlays-in-one-buffer 'C diff-list)) - (if ediff-merge-with-ancestor-job - (ediff-set-diff-overlays-in-one-buffer 'Ancestor diff-list)) - ;; set up vector showing the status of merge regions - (if ediff-merge-job - (setq ediff-state-of-merge - (vconcat - (mapcar (function - (lambda (elt) - (let ((state-of-merge (aref elt 9)) - (state-of-ancestor (aref elt 10))) - (vector - (if state-of-merge (format "%S" state-of-merge)) - state-of-ancestor)))) - ;; the first elt designates type of list - (cdr diff-list)) - ))) - (message "Processing difference regions ... done")) - - -(defun ediff-set-diff-overlays-in-one-buffer (buf-type diff-list) - (let* ((current-diff -1) - (buff (ediff-get-buffer buf-type)) - ;; ediff-extract-diffs puts the type of diff-list as the first elt - ;; of this list. The type is either 'points or 'words - (diff-list-type (car diff-list)) - (shift (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - buf-type ediff-narrow-bounds))) - (limit (ediff-overlay-end - (ediff-get-value-according-to-buffer-type - buf-type ediff-narrow-bounds))) - diff-overlay-list list-element total-diffs - begin end pt-saved overlay state-of-diff) - - (setq diff-list (cdr diff-list)) ; discard diff list type - (setq total-diffs (length diff-list)) - - ;; shift, if necessary - (ediff-with-current-buffer buff (setq pt-saved shift)) - - (while diff-list - (setq current-diff (1+ current-diff) - list-element (car diff-list) - begin (aref list-element (cond ((eq buf-type 'A) 0) - ((eq buf-type 'B) 2) - ((eq buf-type 'C) 4) - (t 6))) ; Ancestor - end (aref list-element (cond ((eq buf-type 'A) 1) - ((eq buf-type 'B) 3) - ((eq buf-type 'C) 5) - (t 7))) ; Ancestor - state-of-diff (aref list-element 8) - ) - - (cond ((and (not (eq buf-type state-of-diff)) - (not (eq buf-type 'Ancestor)) - (memq state-of-diff '(A B C))) - (setq state-of-diff - (car (delq buf-type (delq state-of-diff (list 'A 'B 'C))))) - (setq state-of-diff (format "=diff(%S)" state-of-diff)) - ) - (t (setq state-of-diff nil))) - - ;; Put overlays at appropriate places in buffer - ;; convert word numbers to points, if necessary - (if (eq diff-list-type 'words) - (progn - (ediff-with-current-buffer buff (goto-char pt-saved)) - (setq begin (ediff-goto-word (1+ begin) buff) - end (ediff-goto-word end buff 'end)) - (if (> end limit) (setq end limit)) - (if (> begin end) (setq begin end)) - (setq pt-saved (ediff-with-current-buffer buff (point))))) - (setq overlay (ediff-make-bullet-proof-overlay begin end buff)) - - (ediff-overlay-put overlay 'priority ediff-shadow-overlay-priority) - (ediff-overlay-put overlay 'ediff-diff-num current-diff) - (if (and (ediff-has-face-support-p) - ediff-use-faces ediff-highlight-all-diffs) - (ediff-set-overlay-face - overlay (ediff-background-face buf-type current-diff))) - - (if (= 0 (mod current-diff 10)) - (message "Buffer %S: Processing difference region %d of %d" - buf-type current-diff total-diffs)) - ;; record all overlays for this difference - ;; the second elt, nil, is a place holder for the fine diff vector. - ;; the third elt, nil, is a place holder for no-fine-diffs flag. - (setq diff-overlay-list - (nconc - diff-overlay-list - (list (vector overlay nil nil state-of-diff))) - diff-list - (cdr diff-list)) - ) ; while - - (set (ediff-get-symbol-from-alist buf-type ediff-difference-vector-alist) - (vconcat diff-overlay-list)) - )) - -;; `n' is the diff region to work on. Default is ediff-current-difference. -;; if `flag' is 'noforce then make fine-diffs only if this region's fine -;; diffs have not been computed before. -;; if `flag' is 'skip then don't compute fine diffs for this region. -(defun ediff-make-fine-diffs (&optional n flag) - (or n (setq n ediff-current-difference)) - - (if (< ediff-number-of-differences 1) - (error ediff-NO-DIFFERENCES)) - - (if ediff-word-mode - (setq flag 'skip - ediff-auto-refine 'nix)) - - (or (< n 0) - (>= n ediff-number-of-differences) - ;; n is within the range - (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer)) - (file-A ediff-temp-file-A) - (file-B ediff-temp-file-B) - (file-C ediff-temp-file-C) - (empty-A (ediff-empty-diff-region-p n 'A)) - (empty-B (ediff-empty-diff-region-p n 'B)) - (empty-C (ediff-empty-diff-region-p n 'C)) - (whitespace-A (ediff-whitespace-diff-region-p n 'A)) - (whitespace-B (ediff-whitespace-diff-region-p n 'B)) - (whitespace-C (ediff-whitespace-diff-region-p n 'C)) - cumulative-fine-diff-length) - - (cond ;; If one of the regions is empty (or 2 in 3way comparison) - ;; then don't refine. - ;; If the region happens to be entirely whitespace or empty then - ;; mark as such. - ((> (length (delq nil (list empty-A empty-B empty-C))) 1) - (if (and (ediff-looks-like-combined-merge n) - ediff-merge-job) - (ediff-set-fine-overlays-in-one-buffer 'C nil n)) - (if ediff-3way-comparison-job - (ediff-message-if-verbose - "Region %d is empty in all buffers but %S" - (1+ n) - (cond ((not empty-A) 'A) - ((not empty-B) 'B) - ((not empty-C) 'C))) - (ediff-message-if-verbose - "Region %d in buffer %S is empty" - (1+ n) - (cond (empty-A 'A) - (empty-B 'B) - (empty-C 'C))) - ) - ;; if all regions happen to be whitespace - (if (and whitespace-A whitespace-B whitespace-C) - ;; mark as space only - (ediff-mark-diff-as-space-only n t) - ;; if some regions are white and others don't, then mark as - ;; non-white-space-only - (ediff-mark-diff-as-space-only n nil))) - - ;; don't compute fine diffs if diff vector exists - ((and (eq flag 'noforce) (ediff-get-fine-diff-vector n 'A)) - (if (ediff-no-fine-diffs-p n) - (message - "Only white-space differences in region %d %s" - (1+ n) - (cond ((eq (ediff-no-fine-diffs-p n) 'A) - "in buffers B & C") - ((eq (ediff-no-fine-diffs-p n) 'B) - "in buffers A & C") - ((eq (ediff-no-fine-diffs-p n) 'C) - "in buffers A & B") - (t ""))))) - ;; don't compute fine diffs for this region - ((eq flag 'skip) - (or (ediff-get-fine-diff-vector n 'A) - (memq ediff-auto-refine '(off nix)) - (ediff-message-if-verbose - "Region %d exceeds auto-refine limit. Type `%s' to refine" - (1+ n) - (substitute-command-keys - "\\[ediff-make-or-kill-fine-diffs]") - ))) - (t - ;; recompute fine diffs - (ediff-wordify - (ediff-get-diff-posn 'A 'beg n) - (ediff-get-diff-posn 'A 'end n) - ediff-buffer-A - tmp-buffer - ediff-control-buffer) - (setq file-A - (ediff-make-temp-file tmp-buffer "fineDiffA" file-A)) - - (ediff-wordify - (ediff-get-diff-posn 'B 'beg n) - (ediff-get-diff-posn 'B 'end n) - ediff-buffer-B - tmp-buffer - ediff-control-buffer) - (setq file-B - (ediff-make-temp-file tmp-buffer "fineDiffB" file-B)) - - (if ediff-3way-job - (progn - (ediff-wordify - (ediff-get-diff-posn 'C 'beg n) - (ediff-get-diff-posn 'C 'end n) - ediff-buffer-C - tmp-buffer - ediff-control-buffer) - (setq file-C - (ediff-make-temp-file - tmp-buffer "fineDiffC" file-C)))) - - ;; save temp file names. - (setq ediff-temp-file-A file-A - ediff-temp-file-B file-B - ediff-temp-file-C file-C) - - ;; set the new vector of fine diffs, if none exists - (cond ((and ediff-3way-job whitespace-A) - (ediff-setup-fine-diff-regions nil file-B file-C n)) - ((and ediff-3way-job whitespace-B) - (ediff-setup-fine-diff-regions file-A nil file-C n)) - ((and ediff-3way-job - ;; In merge-jobs, whitespace-C is t, since - ;; ediff-empty-diff-region-p returns t in this case - whitespace-C) - (ediff-setup-fine-diff-regions file-A file-B nil n)) - (t - (ediff-setup-fine-diff-regions file-A file-B file-C n))) - - (setq cumulative-fine-diff-length - (+ (length (ediff-get-fine-diff-vector n 'A)) - (length (ediff-get-fine-diff-vector n 'B)) - ;; in merge jobs, the merge buffer is never refined - (if (and file-C (not ediff-merge-job)) - (length (ediff-get-fine-diff-vector n 'C)) - 0))) - - (cond ((or - ;; all regions are white space - (and whitespace-A whitespace-B whitespace-C) - ;; none is white space and no fine diffs detected - (and (not whitespace-A) - (not whitespace-B) - (not (and ediff-3way-job whitespace-C)) - (eq cumulative-fine-diff-length 0))) - (ediff-mark-diff-as-space-only n t) - (ediff-message-if-verbose - "Only white-space differences in region %d" (1+ n))) - ((eq cumulative-fine-diff-length 0) - (ediff-message-if-verbose - "Only white-space differences in region %d %s" - (1+ n) - (cond (whitespace-A (ediff-mark-diff-as-space-only n 'A) - "in buffers B & C") - (whitespace-B (ediff-mark-diff-as-space-only n 'B) - "in buffers A & C") - (whitespace-C (ediff-mark-diff-as-space-only n 'C) - "in buffers A & B")))) - (t - (ediff-mark-diff-as-space-only n nil))) - ) - ) ; end cond - (ediff-set-fine-diff-properties n) - ))) - -;; Interface to ediff-make-fine-diffs. Checks for auto-refine limit, etc. -(defun ediff-install-fine-diff-if-necessary (n) - (cond ((eq ediff-auto-refine 'on) - (if (and - (> ediff-auto-refine-limit - (- (ediff-get-diff-posn 'A 'end n) - (ediff-get-diff-posn 'A 'beg n))) - (> ediff-auto-refine-limit - (- (ediff-get-diff-posn 'B 'end n) - (ediff-get-diff-posn 'B 'beg n)))) - (ediff-make-fine-diffs n 'noforce) - (ediff-make-fine-diffs n 'skip))) - - ;; highlight iff fine diffs already exist - ((eq ediff-auto-refine 'off) - (ediff-make-fine-diffs n 'skip)))) - - -;; if fine diff vector is not set for diff N, then do nothing -(defun ediff-set-fine-diff-properties (n &optional default) - (or (not (ediff-has-face-support-p)) - (< n 0) - (>= n ediff-number-of-differences) - ;; when faces are supported, set faces and priorities of fine overlays - (progn - (ediff-set-fine-diff-properties-in-one-buffer 'A n default) - (ediff-set-fine-diff-properties-in-one-buffer 'B n default) - (if ediff-3way-job - (ediff-set-fine-diff-properties-in-one-buffer 'C n default))))) - -(defun ediff-set-fine-diff-properties-in-one-buffer (buf-type - n &optional default) - (let ((fine-diff-vector (ediff-get-fine-diff-vector n buf-type)) - (face (if default - 'default - (face-name - (ediff-get-symbol-from-alist - buf-type ediff-fine-diff-face-alist)))) - (priority (if default - 0 - (1+ (or (ediff-overlay-get - (symbol-value - (ediff-get-symbol-from-alist - buf-type - ediff-current-diff-overlay-alist)) - 'priority) - 0))))) - (mapcar - (function (lambda (overl) - (ediff-set-overlay-face overl face) - (ediff-overlay-put overl 'priority priority))) - fine-diff-vector))) - -;; This assumes buffer C and that the region looks like a combination of -;; regions in buffer A and C. -(defun ediff-set-fine-overlays-for-combined-merge (diff-list reg-num) - (let (overlay1 overlay2 overlay3) - (setq overlay1 (ediff-make-bullet-proof-overlay (nth 0 diff-list) - (nth 1 diff-list) - ediff-buffer-C) - overlay2 (ediff-make-bullet-proof-overlay (nth 2 diff-list) - (nth 3 diff-list) - ediff-buffer-C) - overlay3 (ediff-make-bullet-proof-overlay (nth 4 diff-list) - (nth 5 diff-list) - ediff-buffer-C)) - (ediff-set-fine-diff-vector reg-num 'C (vector overlay1 overlay2 overlay3)) - )) - - -;; Convert diff list to overlays for a given DIFF-REGION -;; in buffer of type BUF-TYPE -(defun ediff-set-fine-overlays-in-one-buffer (buf-type diff-list region-num) - (let* ((current-diff -1) - (reg-start (ediff-get-diff-posn buf-type 'beg region-num)) - (buff (ediff-get-buffer buf-type)) - combined-merge-diff-list - diff-overlay-list list-element - begin end overlay) - - (ediff-clear-fine-differences-in-one-buffer region-num buf-type) - (setq diff-list (cdr diff-list)) ; discard list type (words or points) - (ediff-with-current-buffer buff (goto-char reg-start)) - - ;; if it is a combined merge then set overlays in buff C specially - (if (and ediff-merge-job (eq buf-type 'C) - (setq combined-merge-diff-list - (ediff-looks-like-combined-merge region-num))) - (ediff-set-fine-overlays-for-combined-merge - combined-merge-diff-list region-num) - ;; regular fine diff - (while diff-list - (setq current-diff (1+ current-diff) - list-element (car diff-list) - begin (aref list-element (cond ((eq buf-type 'A) 0) - ((eq buf-type 'B) 2) - (t 4))) ; buf C - end (aref list-element (cond ((eq buf-type 'A) 1) - ((eq buf-type 'B) 3) - (t 5)))) ; buf C - (if (not (or begin end)) - () ; skip this diff - ;; Put overlays at appropriate places in buffers - ;; convert lines to points, if necessary - (setq begin (ediff-goto-word (1+ begin) buff) - end (ediff-goto-word end buff 'end)) - (setq overlay (ediff-make-bullet-proof-overlay begin end buff)) - ;; record all overlays for this difference region - (setq diff-overlay-list (nconc diff-overlay-list (list overlay)))) - - (setq diff-list (cdr diff-list)) - ) ; while - ;; convert the list of difference information into a vector - ;; for fast access - (ediff-set-fine-diff-vector - region-num buf-type (vconcat diff-overlay-list)) - ))) - - -;; Stolen from emerge.el -(defun ediff-get-diff3-group (file) - ;; This save-excursion allows ediff-get-diff3-group to be called for the - ;; various groups of lines (1, 2, 3) in any order, and for the lines to - ;; appear in any order. The reason this is necessary is that Gnu diff3 - ;; can produce the groups in the order 1, 2, 3 or 1, 3, 2. - (save-excursion - (re-search-forward - (concat "^" file ":\\([0-9]+\\)\\(,\\([0-9]+\\)\\)?\\([ac]\\)$")) - (beginning-of-line 2) - ;; treatment depends on whether it is an "a" group or a "c" group - (if (string-equal (buffer-substring (match-beginning 4) (match-end 4)) "c") - ;; it is a "c" group - (if (match-beginning 2) - ;; it has two numbers - (list (string-to-int - (buffer-substring (match-beginning 1) (match-end 1))) - (1+ (string-to-int - (buffer-substring (match-beginning 3) (match-end 3))))) - ;; it has one number - (let ((x (string-to-int - (buffer-substring (match-beginning 1) (match-end 1))))) - (list x (1+ x)))) - ;; it is an "a" group - (let ((x (1+ (string-to-int - (buffer-substring (match-beginning 1) (match-end 1)))))) - (list x x))))) - - -;; If WORD-MODE, construct vector of diffs using word numbers. -;; Else, use point values. -;; WORD-MODE also tells if we are in the word-mode or not. -;; If THREE-WAY-COMP, then it is a 3-way comparison. Else, it is merging -;; with ancestor, in which case buffer-C contents is identical to buffer-A/B, -;; contents (unless buffer-A is narrowed) depending on ediff-default-variant's -;; value. -;; BOUNDS specifies visibility bounds to use. -(defun ediff-extract-diffs3 (diff-buffer word-mode three-way-comp - &optional bounds) - (let ((A-buffer ediff-buffer-A) - (B-buffer ediff-buffer-B) - (C-buffer ediff-buffer-C) - (anc-buffer ediff-ancestor-buffer) - (a-prev 1) ; needed to set the first diff line correctly - (b-prev 1) - (c-prev 1) - (anc-prev 1) - diff-list shift-A shift-B shift-C - ) - - ;; diff list contains word numbers or points, depending on word-mode - (setq diff-list (cons (if word-mode 'words 'points) - diff-list)) - (if bounds - (setq shift-A - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'A bounds)) - shift-B - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'B bounds)) - shift-C - (if three-way-comp - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'C bounds))))) - - ;; reset point in buffers A, B, C - (ediff-with-current-buffer A-buffer - (goto-char (if shift-A shift-A (point-min)))) - (ediff-with-current-buffer B-buffer - (goto-char (if shift-B shift-B (point-min)))) - (if three-way-comp - (ediff-with-current-buffer C-buffer - (goto-char (if shift-C shift-C (point-min))))) - (if (ediff-buffer-live-p anc-buffer) - (ediff-with-current-buffer anc-buffer - (goto-char (point-min)))) - - (ediff-with-current-buffer diff-buffer - (goto-char (point-min)) - (while (re-search-forward ediff-match-diff3-line nil t) - ;; leave point after matched line - (beginning-of-line 2) - (let ((agreement (buffer-substring (match-beginning 1) (match-end 1)))) - ;; if the files A and B are the same and not 3way-comparison, - ;; ignore the difference - (if (or three-way-comp (not (string-equal agreement "3"))) - (let* ((a-begin (car (ediff-get-diff3-group "1"))) - (a-end (nth 1 (ediff-get-diff3-group "1"))) - (b-begin (car (ediff-get-diff3-group "2"))) - (b-end (nth 1 (ediff-get-diff3-group "2"))) - (c-or-anc-begin (car (ediff-get-diff3-group "3"))) - (c-or-anc-end (nth 1 (ediff-get-diff3-group "3"))) - (state-of-merge - (cond ((string-equal agreement "1") 'prefer-A) - ((string-equal agreement "2") 'prefer-B) - (t ediff-default-variant))) - (state-of-diff-merge - (if (memq state-of-merge '(default-A prefer-A)) 'B 'A)) - (state-of-diff-comparison - (cond ((string-equal agreement "1") 'A) - ((string-equal agreement "2") 'B) - ((string-equal agreement "3") 'C))) - state-of-ancestor - c-begin c-end - a-begin-pt a-end-pt - b-begin-pt b-end-pt - c-begin-pt c-end-pt - anc-begin-pt anc-end-pt) - - (setq state-of-ancestor - (= c-or-anc-begin c-or-anc-end)) - - (cond (three-way-comp - (setq c-begin c-or-anc-begin - c-end c-or-anc-end)) - ((eq ediff-default-variant 'default-B) - (setq c-begin b-begin - c-end b-end)) - (t - (setq c-begin a-begin - c-end a-end))) - - ;; compute main diff vector - (if word-mode - ;; make diff-list contain word numbers - (setq diff-list - (nconc diff-list - (list (vector - (- a-begin a-prev) (- a-end a-begin) - (- b-begin b-prev) (- b-end b-begin) - (- c-begin c-prev) (- c-end c-begin) - nil nil ; dummy ancestor - nil ; state of diff - nil ; state of merge - nil ; state of ancestor - ))) - a-prev a-end - b-prev b-end - c-prev c-end) - ;; else convert lines to points - (ediff-with-current-buffer A-buffer - (forward-line (- a-begin a-prev)) - (setq a-begin-pt (point)) - (forward-line (- a-end a-begin)) - (setq a-end-pt (point) - a-prev a-end)) - (ediff-with-current-buffer B-buffer - (forward-line (- b-begin b-prev)) - (setq b-begin-pt (point)) - (forward-line (- b-end b-begin)) - (setq b-end-pt (point) - b-prev b-end)) - (ediff-with-current-buffer C-buffer - (forward-line (- c-begin c-prev)) - (setq c-begin-pt (point)) - (forward-line (- c-end c-begin)) - (setq c-end-pt (point) - c-prev c-end)) - (if (ediff-buffer-live-p anc-buffer) - (ediff-with-current-buffer anc-buffer - (forward-line (- c-or-anc-begin anc-prev)) - (setq anc-begin-pt (point)) - (forward-line (- c-or-anc-end c-or-anc-begin)) - (setq anc-end-pt (point) - anc-prev c-or-anc-end))) - (setq diff-list - (nconc - diff-list - ;; if comparing with ancestor, then there also is a - ;; state-of-difference marker - (if three-way-comp - (list (vector - a-begin-pt a-end-pt - b-begin-pt b-end-pt - c-begin-pt c-end-pt - nil nil ; ancestor begin/end - state-of-diff-comparison - nil ; state of merge - nil ; state of ancestor - )) - (list (vector a-begin-pt a-end-pt - b-begin-pt b-end-pt - c-begin-pt c-end-pt - anc-begin-pt anc-end-pt - state-of-diff-merge - state-of-merge - state-of-ancestor - ))) - ))) - )) - - ))) ; end ediff-with-current-buffer - diff-list - )) - -;; Generate the difference vector and overlays for three files -;; File-C is either the third file to compare (in case of 3-way comparison) -;; or it is the ancestor file. -(defun ediff-setup-diff-regions3 (file-A file-B file-C) - (or (ediff-buffer-live-p ediff-diff-buffer) - (setq ediff-diff-buffer - (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*")))) - - (message "Computing differences ...") - (ediff-exec-process ediff-diff3-program ediff-diff-buffer 'synchronize - ediff-diff3-options file-A file-B file-C) - - (ediff-prepare-error-list ediff-diff3-ok-lines-regexp ediff-diff-buffer) - ;;(message "Computing differences ... done") - (ediff-convert-diffs-to-overlays - (ediff-extract-diffs3 - ediff-diff-buffer - ediff-word-mode ediff-3way-comparison-job ediff-narrow-bounds) - )) - - -;; Execute PROGRAM asynchronously, unless OS/2, Windows-*, or DOS, or unless -;; SYNCH is non-nil. BUFFER must be a buffer object, and must be alive. The -;; OPTIONS arg is a list of options to pass to PROGRAM. It may be a blank -;; string. All elements in FILES must be strings. We also delete nil from -;; args. -(defun ediff-exec-process (program buffer synch options &rest files) - (let ((data (match-data)) - args) - (setq args (append (split-string options) files)) - (setq args (delete "" (delq nil args))) ; delete nil and "" from arguments - (unwind-protect - (let ((directory default-directory) - proc) - (save-excursion - (set-buffer buffer) - (erase-buffer) - (setq default-directory directory) - (if (or (memq system-type '(emx ms-dos windows-nt windows-95)) - synch) - ;; In OS/2 (emx) do it synchronously, since OS/2 doesn't let us - ;; delete files used by other processes. Thus, in ediff-buffers - ;; and similar functions, we can't delete temp files because - ;; they might be used by the asynch process that computes - ;; custom diffs. So, we have to wait till custom diff - ;; subprocess is done. - ;; Similarly for Windows-* - ;; In DOS, must synchronize because DOS doesn't have - ;; asynchronous processes. - (apply 'call-process program nil buffer nil args) - ;; On other systems, do it asynchronously. - (setq proc (get-buffer-process buffer)) - (if proc (kill-process proc)) - (setq proc - (apply 'start-process "Custom Diff" buffer program args)) - (setq mode-line-process '(":%s")) - (set-process-sentinel proc 'ediff-process-sentinel) - (set-process-filter proc 'ediff-process-filter) - ))) - (store-match-data data)))) - -;; This is shell-command-filter from simple.el in FSF Emacs. -;; Copied here because XEmacs doesn't have it. -(defun ediff-process-filter (proc string) - ;; Do save-excursion by hand so that we can leave point numerically unchanged - ;; despite an insertion immediately after it. - (let* ((obuf (current-buffer)) - (buffer (process-buffer proc)) - opoint - (window (get-buffer-window buffer)) - (pos (window-start window))) - (unwind-protect - (progn - (set-buffer buffer) - (or (= (point) (point-max)) - (setq opoint (point))) - (goto-char (point-max)) - (insert-before-markers string)) - ;; insert-before-markers moved this marker: set it back. - (set-window-start window pos) - ;; Finish our save-excursion. - (if opoint - (goto-char opoint)) - (set-buffer obuf)))) - -;; like shell-command-sentinel but doesn't print an exit status message -;; we do this because diff always exits with status 1, if diffs are found -;; so shell-command-sentinel displays a confusing message to the user -(defun ediff-process-sentinel (process signal) - (if (and (memq (process-status process) '(exit signal)) - (buffer-name (process-buffer process))) - (progn - (save-excursion - (set-buffer (process-buffer process)) - (setq mode-line-process nil)) - (delete-process process)))) - - -;;; Word functions used to refine the current diff - -(defvar ediff-forward-word-function 'ediff-forward-word - "*Function to call to move to the next word. -Used for splitting difference regions into individual words.") - -(defvar ediff-whitespace " \n\t\f" - "*Characters constituting white space. -These characters are ignored when differing regions are split into words.") - -;;(defvar ediff-word-1 "a-zA-Z---_`'.?!:" -(defvar ediff-word-1 "a-zA-Z---_" - "*Characters that constitute words of type 1. -More precisely, [ediff-word-1] is a regexp that matches type 1 words. -See `ediff-forward-word' for more details.") - -(defvar ediff-word-2 "0-9.," - "*Characters that constitute words of type 2. -More precisely, [ediff-word-2] is a regexp that matches type 2 words. -See `ediff-forward-word' for more details.") - -(defvar ediff-word-3 "`'?!:;\"{}[]()" - "*Characters that constitute words of type 3. -More precisely, [ediff-word-3] is a regexp that matches type 3 words. -See `ediff-forward-word' for more details.") - -(defvar ediff-word-4 - (concat "^" ediff-word-1 ediff-word-2 ediff-word-3 ediff-whitespace) - "*Characters that constitute words of type 4. -More precisely, [ediff-word-4] is a regexp that matches type 4 words. -See `ediff-forward-word' for more details.") - -;; Split region along word boundaries. Each word will be on its own line. -;; Output to buffer out-buffer. -(defun ediff-forward-word () - "Move point one word forward. -There are four types of words, each of which consists entirely of -characters in `ediff-word-1', `ediff-word-2', `ediff-word-3', or -`ediff-word-4'. Words are recognized by passing these in turn as the -argument to `skip-chars-forward'." - (or (> (skip-chars-forward ediff-word-1) 0) - (> (skip-chars-forward ediff-word-2) 0) - (> (skip-chars-forward ediff-word-3) 0) - (> (skip-chars-forward ediff-word-4) 0) - )) - -(defun ediff-wordify (beg end in-buffer out-buffer &optional control-buf) - (let (sv-point string) - (save-excursion - (set-buffer in-buffer) - (setq string (buffer-substring-no-properties beg end)) - - (set-buffer out-buffer) - (erase-buffer) - (insert string) - (goto-char (point-min)) - (skip-chars-forward ediff-whitespace) - (delete-region (point-min) (point)) - - (while (not (eobp)) - ;; eval incontrol buf to let user create local versions for - ;; different invocations - (if control-buf - (funcall - (ediff-with-current-buffer control-buf ediff-forward-word-function)) - (funcall ediff-forward-word-function)) - (setq sv-point (point)) - (skip-chars-forward ediff-whitespace) - (delete-region sv-point (point)) - (insert "\n"))))) - -;; copy string from BEG END from IN-BUF to OUT-BUF -(defun ediff-copy-to-buffer (beg end in-buffer out-buffer) - (let (string) - (save-excursion - (set-buffer in-buffer) - (setq string (buffer-substring beg end)) - - (set-buffer out-buffer) - (erase-buffer) - (insert string) - (goto-char (point-min))))) - - -;; goto word #n starting at current position in buffer `buf' -;; For ediff, a word is either a string of a-z,A-Z, incl `-' and `_'; -;; or a string of other non-blanks. A blank is a \n\t\f -;; If `flag' is non-nil, goto the end of the n-th word. -(defun ediff-goto-word (n buf &optional flag) - ;; remember val ediff-forward-word-function has in ctl buf - (let ((fwd-word-fun ediff-forward-word-function)) - (ediff-with-current-buffer buf - (skip-chars-forward ediff-whitespace) - (while (> n 1) - (funcall fwd-word-fun) - (skip-chars-forward ediff-whitespace) - (setq n (1- n))) - (if (and flag (> n 0)) - (funcall fwd-word-fun)) - (point)))) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - - -;; ediff-diff.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-help.el --- a/lisp/ediff/ediff-help.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,313 +0,0 @@ -;;; ediff-help.el --- Code related to the contents of Ediff help buffers - -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-help) - -;; Compiler pacifier start -(defvar ediff-multiframe) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -;; Help messages - -(defconst ediff-long-help-message-head - " Move around | Toggle features | Manipulate -=====================|===========================|=============================" - "The head of the full help message.") -(defconst ediff-long-help-message-tail - "=====================|===========================|============================= - R -show registry | = -compare regions | M -show session group - D -diff output | E -browse Ediff manual| G -send bug report - i -status info | ? -help off | z/q -suspend/quit -------------------------------------------------------------------------------- -For help on a specific command: Click Button 2 over it; or - Put the cursor over it and type RET." - "The tail of the full-help message.") - -(defconst ediff-long-help-message-compare3 - " -p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| | ! -update diff regions - C-l -recenter | ## -ignore whitespace | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -rotate buffers| m -wide display | -" - "Help message usually used for 3-way comparison. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-compare2 - " -p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| | ! -update diff regions - C-l -recenter | ## -ignore whitespace | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -swap variants | m -wide display | -" - "Help message usually used for 2-way comparison. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-narrow2 - " -p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| % -narrow/widen buffs | ! -update diff regions - C-l -recenter | ## -ignore whitespace | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -swap variants | m -wide display | -" - "Help message when comparing windows or regions line-by-line. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-word-mode - " -p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | | - gx -goto X's point| % -narrow/widen buffs | ! -recompute diffs - C-l -recenter | | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -swap variants | m -wide display | -" - "Help message when comparing windows or regions word-by-word. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-merge - " -p,DEL -previous diff | | -vert/horiz split | x -copy buf X's region to C -n,SPC -next diff | h -hilighting | r -restore buf C's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| ## -ignore whitespace | ! -update diff regions - C-l -recenter | #f/#h -focus/hide regions | + -combine diff regions - v/V -scroll up/dn | X -read-only in buf X | wx -save buf X - -scroll lt/rt | m -wide display | wd -save diff output - ~ -swap variants | s -shrink window C | / -show ancestor buff - | $ -show clashes only | & -merge w/new default -" - "Help message during merging. -Normally, not a user option. See `ediff-help-message' for details.") - -;; The actual long help message. -(ediff-defvar-local ediff-long-help-message "" - "Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-brief-message-string - "? -quick help " - "Contents of the brief help message.") -;; The actual brief help message -(ediff-defvar-local ediff-brief-help-message "" - "Normally, not a user option. See `ediff-help-message' for details.") - -(ediff-defvar-local ediff-brief-help-message-function nil - "The brief help message that the user can customize. -If the user sets this to a parameter-less function, Ediff will use it to -produce the brief help message. This function must return a string.") -(ediff-defvar-local ediff-long-help-message-function nil - "The long help message that the user can customize. -See `ediff-brief-help-message-function' for more.") - -(defvar ediff-use-long-help-message nil - "*If t, Ediff displays a long help message. Short help message otherwise.") - -;; The actual help message. -(ediff-defvar-local ediff-help-message "" - "The actual help message. -Normally, the user shouldn't touch this. However, if you want Ediff to -start up with different help messages for different jobs, you can change -the value of this variable and the variables `ediff-help-message-*' in -`ediff-startup-hook'.") - - -;; the keymap that defines clicks over the quick help regions -(defvar ediff-help-region-map (make-sparse-keymap)) - -(define-key - ediff-help-region-map - (if ediff-emacs-p [mouse-2] [button2]) - 'ediff-help-for-quick-help) - -;; runs in the control buffer -(defun ediff-set-help-overlays () - (goto-char (point-min)) - (let (overl beg end cmd) - (while (re-search-forward " *\\([^ \t\n|]+\\||\\) +-[^|\n]+" nil 'noerror) - (setq beg (match-beginning 0) - end (match-end 0) - cmd (buffer-substring (match-beginning 1) (match-end 1))) - (setq overl (ediff-make-overlay beg end)) - (if ediff-emacs-p - (ediff-overlay-put overl 'mouse-face 'highlight) - (ediff-overlay-put overl 'highlight t)) - (ediff-overlay-put overl 'ediff-help-info cmd)))) - - -(defun ediff-help-for-quick-help () - "Explain Ediff commands in more detail." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((pos (ediff-event-point last-command-event)) - overl cmd) - - (if ediff-xemacs-p - (setq overl (extent-at pos (current-buffer) 'ediff-help-info) - cmd (ediff-overlay-get overl 'ediff-help-info)) - (setq cmd (car (mapcar (function (lambda (elt) - (overlay-get elt 'ediff-help-info))) - (overlays-at pos))))) - - (if (not (stringp cmd)) - (error "Hmm... I don't see an Ediff command around here...")) - - (ediff-documentation "Quick Help Commands") - - (let (case-fold-search) - (cond ((string= cmd "?") (re-search-forward "^`\\?'")) - ((string= cmd "G") (re-search-forward "^`G'")) - ((string= cmd "E") (re-search-forward "^`E'")) - ((string= cmd "wd") (re-search-forward "^`wd'")) - ((string= cmd "wx") (re-search-forward "^`wa'")) - ((string= cmd "a/b") (re-search-forward "^`a'")) - ((string= cmd "x") (re-search-forward "^`a'")) - ((string= cmd "xy") (re-search-forward "^`ab'")) - ((string= cmd "p,DEL") (re-search-forward "^`p'")) - ((string= cmd "n,SPC") (re-search-forward "^`n'")) - ((string= cmd "j") (re-search-forward "^`j'")) - ((string= cmd "gx") (re-search-forward "^`ga'")) - ((string= cmd "!") (re-search-forward "^`!'")) - ((string= cmd "*") (re-search-forward "^`\\*'")) - ((string= cmd "m") (re-search-forward "^`m'")) - ((string= cmd "|") (re-search-forward "^`|'")) - ((string= cmd "@") (re-search-forward "^`@'")) - ((string= cmd "h") (re-search-forward "^`h'")) - ((string= cmd "r") (re-search-forward "^`r'")) - ((string= cmd "rx") (re-search-forward "^`ra'")) - ((string= cmd "##") (re-search-forward "^`##'")) - ((string= cmd "#f/#h") (re-search-forward "^`#f'")) - ((string= cmd "X") (re-search-forward "^`A'")) - ((string= cmd "v/V") (re-search-forward "^`v'")) - ((string= cmd "") (re-search-forward "^`<'")) - ((string= cmd "~") (re-search-forward "^`~'")) - ((string= cmd "i") (re-search-forward "^`i'")) - ((string= cmd "D") (re-search-forward "^`D'")) - ((string= cmd "R") (re-search-forward "^`R'")) - ((string= cmd "M") (re-search-forward "^`M'")) - ((string= cmd "z/q") (re-search-forward "^`z'")) - ((string= cmd "%") (re-search-forward "^`%'")) - ((string= cmd "C-l") (re-search-forward "^`C-l'")) - ((string= cmd "$") (re-search-forward "^`\\$'")) - ((string= cmd "/") (re-search-forward "^`/'")) - ((string= cmd "&") (re-search-forward "^`&'")) - ((string= cmd "s") (re-search-forward "^`s'")) - ((string= cmd "+") (re-search-forward "^`\\+'")) - ((string= cmd "=") (re-search-forward "^`='")) - (t (error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer"))) - ) ; let case-fold-search - )) - - -;; assuming we are in control window, calculate length of the first line in -;; help message -(defun ediff-help-message-line-length () - (save-excursion - (goto-char (point-min)) - (if ediff-use-long-help-message - (next-line 1)) - (end-of-line) - (current-column))) - - -(defun ediff-indent-help-message () - (let* ((shift (/ (max 0 (- (window-width (selected-window)) - (ediff-help-message-line-length))) - 2)) - (str (make-string shift ?\ ))) - (save-excursion - (goto-char (point-min)) - (while (< (point) (point-max)) - (insert str) - (beginning-of-line) - (forward-line 1))))) - - -;; compose the help message as a string -(defun ediff-set-help-message () - (setq ediff-long-help-message - (cond ((and ediff-long-help-message-function - (or (symbolp ediff-long-help-message-function) - (consp ediff-long-help-message-function))) - (funcall ediff-long-help-message-function)) - (ediff-word-mode - (concat ediff-long-help-message-head - ediff-long-help-message-word-mode - ediff-long-help-message-tail)) - (ediff-narrow-job - (concat ediff-long-help-message-head - ediff-long-help-message-narrow2 - ediff-long-help-message-tail)) - (ediff-merge-job - (concat ediff-long-help-message-head - ediff-long-help-message-merge - ediff-long-help-message-tail)) - (ediff-diff3-job - (concat ediff-long-help-message-head - ediff-long-help-message-compare3 - ediff-long-help-message-tail)) - (t - (concat ediff-long-help-message-head - ediff-long-help-message-compare2 - ediff-long-help-message-tail)))) - (setq ediff-brief-help-message - (cond ((and ediff-brief-help-message-function - (or (symbolp ediff-brief-help-message-function) - (consp ediff-brief-help-message-function))) - (funcall ediff-brief-help-message-function)) - ((stringp ediff-brief-help-message-function) - ediff-brief-help-message-function) - ((ediff-multiframe-setup-p) ediff-brief-message-string) - (t ; long brief msg, not multiframe --- put in the middle - ediff-brief-message-string) - )) - (setq ediff-help-message (if ediff-use-long-help-message - ediff-long-help-message - ediff-brief-help-message)) - (run-hooks 'ediff-display-help-hook)) - - -;;; ediff-help.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-hook.el --- a/lisp/ediff/ediff-hook.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,349 +0,0 @@ -;;; ediff-hook.el --- setup for Ediff's menus and autoloads - -;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; These must be placed in menu-bar.el in Emacs -;; -;; (define-key menu-bar-tools-menu [ediff-misc] -;; '("Ediff Miscellanea" . menu-bar-ediff-misc-menu)) -;; (define-key menu-bar-tools-menu [epatch] -;; '("Apply Patch" . menu-bar-epatch-menu)) -;; (define-key menu-bar-tools-menu [ediff-merge] -;; '("Merge" . menu-bar-ediff-merge-menu)) -;; (define-key menu-bar-tools-menu [ediff] -;; '("Compare" . menu-bar-ediff-menu)) - -;; Compiler pacifier -(defvar ediff-menu) -(defvar ediff-merge-menu) -(defvar epatch-menu) -(defvar ediff-misc-menu) -;; end pacifier - -;; allow menus to be set up without ediff-wind.el being loaded -(defvar ediff-window-setup-function) - - -(defun ediff-xemacs-init-menus () - (if (featurep 'menubar) - (progn - (add-submenu - '("Tools") ediff-menu "OO-Browser...") - (add-submenu - '("Tools") ediff-merge-menu "OO-Browser...") - (add-submenu - '("Tools") epatch-menu "OO-Browser...") - (add-submenu - '("Tools") ediff-misc-menu "OO-Browser...") - (add-menu-button - '("Tools") - ["-------" nil nil] "OO-Browser...") - ))) - - -;; explicit string-match is needed: ediff-xemacs-p is not defined at build time -(cond ((string-match "XEmacs" emacs-version) - (defvar ediff-menu - '("Compare" - ["Two Files..." ediff-files t] - ["Two Buffers..." ediff-buffers t] - ["Three Files..." ediff-files3 t] - ["Three Buffers..." ediff-buffers3 t] - "---" - ["Two Directories..." ediff-directories t] - ["Three Directories..." ediff-directories3 t] - "---" - ["File with Revision..." ediff-revision t] - ["Directory Revisions..." ediff-directory-revisions t] - "---" - ["Windows Word-by-word..." ediff-windows-wordwise t] - ["Windows Line-by-line..." ediff-windows-linewise t] - "---" - ["Regions Word-by-word..." ediff-regions-wordwise t] - ["Regions Line-by-line..." ediff-regions-linewise t] - )) - (defvar ediff-merge-menu - '("Merge" - ["Files..." ediff-merge-files t] - ["Files with Ancestor..." ediff-merge-files-with-ancestor t] - ["Buffers..." ediff-merge-buffers t] - ["Buffers with Ancestor..." - ediff-merge-buffers-with-ancestor t] - "---" - ["Directories..." ediff-merge-directories t] - ["Directories with Ancestor..." - ediff-merge-directories-with-ancestor t] - "---" - ["Revisions..." ediff-merge-revisions t] - ["Revisions with Ancestor..." - ediff-merge-revisions-with-ancestor t] - ["Directory Revisions..." ediff-merge-directory-revisions t] - ["Directory Revisions with Ancestor..." - ediff-merge-directory-revisions-with-ancestor t] - )) - (defvar epatch-menu - '("Apply Patch" - ["To a file..." ediff-patch-file t] - ["To a buffer..." ediff-patch-buffer t] - )) - (defvar ediff-misc-menu - '("Ediff Miscellanea" - ["Ediff Manual..." ediff-documentation t] - ["List Ediff Sessions..." ediff-show-registry t] - ["Use separate frame for Ediff control buffer..." - ediff-toggle-multiframe - :style toggle - :selected (if (and (featurep 'ediff-util) - (boundp 'ediff-window-setup-function)) - (eq ediff-window-setup-function - 'ediff-setup-windows-multiframe))] - ["Use a toolbar with Ediff control buffer" - ediff-toggle-use-toolbar - :style toggle - :selected (if (featurep 'ediff-tbar) - (ediff-use-toolbar-p))] - )) - - ;; put these menus before Object-Oriented-Browser in Tools menu -;; (add-hook 'before-init-hook 'ediff-xemacs-init-menus) -;; (if (not purify-flag) -;; (ediff-xemacs-init-menus)) -;; ) - (ediff-xemacs-init-menus)) - - ;; Emacs--only if menu-bar is loaded - ((featurep 'menu-bar) - ;; initialize menu bar keymaps - (defvar menu-bar-ediff-misc-menu - (make-sparse-keymap "Ediff Miscellanea")) - (fset 'menu-bar-ediff-misc-menu - (symbol-value 'menu-bar-ediff-misc-menu)) - (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch")) - (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu)) - (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge")) - (fset 'menu-bar-ediff-merge-menu - (symbol-value 'menu-bar-ediff-merge-menu)) - (defvar menu-bar-ediff-menu (make-sparse-keymap "Compare")) - (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu)) - - ;; define ediff-menu - (define-key menu-bar-ediff-menu [window] - '("This Window and Next Window" . compare-windows)) - (define-key menu-bar-ediff-menu [ediff-windows-linewise] - '("Windows Line-by-line..." . ediff-windows-linewise)) - (define-key menu-bar-ediff-menu [ediff-windows-wordwise] - '("Windows Word-by-word..." . ediff-windows-wordwise)) - (define-key menu-bar-ediff-menu [separator-ediff-windows] '("--")) - (define-key menu-bar-ediff-menu [ediff-regions-linewise] - '("Regions Line-by-line..." . ediff-regions-linewise)) - (define-key menu-bar-ediff-menu [ediff-regions-wordwise] - '("Regions Word-by-word..." . ediff-regions-wordwise)) - (define-key menu-bar-ediff-menu [separator-ediff-regions] '("--")) - (define-key menu-bar-ediff-menu [ediff-dir-revision] - '("Directory Revisions..." . ediff-directory-revisions)) - (define-key menu-bar-ediff-menu [ediff-revision] - '("File with Revision..." . ediff-revision)) - (define-key menu-bar-ediff-menu [separator-ediff-directories] '("--")) - (define-key menu-bar-ediff-menu [ediff-directories3] - '("Three Directories..." . ediff-directories3)) - (define-key menu-bar-ediff-menu [ediff-directories] - '("Two Directories..." . ediff-directories)) - (define-key menu-bar-ediff-menu [separator-ediff-files] '("--")) - (define-key menu-bar-ediff-menu [ediff-buffers3] - '("Three Buffers..." . ediff-buffers3)) - (define-key menu-bar-ediff-menu [ediff-files3] - '("Three Files..." . ediff-files3)) - (define-key menu-bar-ediff-menu [ediff-buffers] - '("Two Buffers..." . ediff-buffers)) - (define-key menu-bar-ediff-menu [ediff-files] - '("Two Files..." . ediff-files)) - - ;; define merge menu - (define-key - menu-bar-ediff-merge-menu [ediff-merge-dir-revisions-with-ancestor] - '("Directory Revisions with Ancestor..." - . ediff-merge-directory-revisions-with-ancestor)) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-dir-revisions] - '("Directory Revisions..." . ediff-merge-directory-revisions)) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-revisions-with-ancestor] - '("Revisions with Ancestor..." - . ediff-merge-revisions-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-revisions] - '("Revisions..." . ediff-merge-revisions)) - (define-key menu-bar-ediff-merge-menu [separator-ediff-merge] '("--")) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-directories-with-ancestor] - '("Directories with Ancestor..." - . ediff-merge-directories-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-directories] - '("Directories..." . ediff-merge-directories)) - (define-key - menu-bar-ediff-merge-menu [separator-ediff-merge-dirs] '("--")) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-buffers-with-ancestor] - '("Buffers with Ancestor..." . ediff-merge-buffers-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-buffers] - '("Buffers..." . ediff-merge-buffers)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-files-with-ancestor] - '("Files with Ancestor..." . ediff-merge-files-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-files] - '("Files..." . ediff-merge-files)) - - ;; define epatch menu - (define-key menu-bar-epatch-menu [ediff-patch-buffer] - '("To a Buffer..." . ediff-patch-buffer)) - (define-key menu-bar-epatch-menu [ediff-patch-file] - '("To a File..." . ediff-patch-file)) - - ;; define ediff miscellanea - (define-key menu-bar-ediff-misc-menu [emultiframe] - '("Toggle use of separate control buffer frame..." - . ediff-toggle-multiframe)) - (define-key menu-bar-ediff-misc-menu [eregistry] - '("List Ediff Sessions..." . ediff-show-registry)) - (define-key menu-bar-ediff-misc-menu [ediff-doc] - '("Ediff Manual..." . ediff-documentation)) - ) - - ) ; cond - -;; arrange for autoloads -(if purify-flag - () ; if dumping, autoloads are set up in loaddefs.el - ;; if the user decides to load this file, set up autoloads - ;; compare files and buffers - (autoload 'ediff "ediff" "Compare two files" t) - (autoload 'ediff-files "ediff" "Compare two files" t) - (autoload 'ediff-buffers "ediff" "Compare two bufers" t) - (autoload 'ebuffers "ediff" "Compare two bufers" t) - (autoload 'ediff3 "ediff" "Compare three files" t) - (autoload 'ediff-files3 "ediff" "Compare three files" t) - (autoload 'ediff-buffers3 "ediff" "Compare three bufers" t) - (autoload 'ebuffers3 "ediff" "Compare three bufers" t) - - (autoload 'erevision "ediff" "Compare versions of a file" t) - (autoload 'ediff-revision "ediff" "Compare versions of a file" t) - - ;; compare regions and windows - (autoload 'ediff-windows-wordwise - "ediff" "Compare two windows word-by-word." t) - (autoload 'ediff-regions-wordwise - "ediff" "Compare two regions word-by-word." t) - (autoload 'ediff-windows-linewise - "ediff" "Compare two windows line-by-line." t) - (autoload 'ediff-regions-linewise - "ediff" "Compare two regions line-by-line." t) - - ;; patch - (autoload 'ediff-patch-file "ediff" "Patch a file." t) - (autoload 'epatch "ediff" "Patch a file." t) - (autoload 'ediff-patch-buffer "ediff" "Patch a buffer.") - (autoload 'epatch-buffer "ediff" "Patch a buffer." t) - - ;; merge - (autoload 'ediff-merge "ediff" "Merge two files." t) - (autoload 'ediff-merge-files "ediff" "Merge two files." t) - (autoload 'ediff-merge-files-with-ancestor - "ediff" "Merge two files using a third file as an ancestor." t) - (autoload 'ediff-merge-buffers "ediff" "Merge two buffers." t) - (autoload 'ediff-merge-buffers-with-ancestor - "ediff" "Merge two buffers using a third buffer as an ancestor." t) - - (autoload 'ediff-merge-revisions "ediff" "Merge two versions of a file." t) - (autoload 'ediff-merge-revisions-with-ancestor - "ediff" "Merge two versions of a file." t) - - ;; compare directories - (autoload 'edirs "ediff" "Compare files in two directories." t) - (autoload 'ediff-directories "ediff" "Compare files in two directories." t) - (autoload 'edirs3 "ediff" "Compare files in three directories." t) - (autoload - 'ediff-directories3 "ediff" "Compare files in three directories." t) - - (autoload 'edir-revisions - "ediff" "Compare two versions of a file." t) - (autoload 'ediff-directory-revisions - "ediff" "Compare two versions of a file." t) - - ;; merge directories - (autoload 'edirs-merge "ediff" "Merge files in two directories." t) - (autoload 'ediff-merge-directories - "ediff" "Merge files in two directories." t) - (autoload 'edirs-merge-with-ancestor - "ediff" - "Merge files in two directories using files in a third dir as ancestors." - t) - (autoload 'ediff-merge-directories-with-ancestor - "ediff" - "Merge files in two directories using files in a third dir as ancestors." - t) - - (autoload 'edir-merge-revisions - "ediff" "Merge versions of files in a directory." t) - (autoload 'ediff-merge-directory-revisions - "ediff" "Merge versions of files in a directory." t) - (autoload 'ediff-merge-directory-revisions-with-ancestor - "ediff" - "Merge versions of files in a directory using other versions as ancestors." - t) - (autoload 'edir-merge-revisions-with-ancestor - "ediff" - "Merge versions of files in a directory using other versions as ancestors." - t) - - ;; misc - (autoload 'ediff-show-registry - "ediff-mult" - "Display the registry of active Ediff sessions." - t) - (autoload 'eregistry - "ediff-mult" - "Display the registry of active Ediff sessions." - t) - (autoload 'ediff-documentation - "ediff" - "Display Ediff's manual." - t) - (autoload 'ediff-version - "ediff" - "Show Ediff's version and last modification date." - t) - (autoload 'ediff-toggle-multiframe - "ediff-util" - "Toggle the use of separate frame for Ediff control buffer." - t) - (autoload 'ediff-toggle-use-toolbar - "ediff-util" - "Toggle the use of Ediff toolbar." - t) - - ) ; if purify-flag - - -(provide 'ediff-hook) - - -;;; ediff-hook.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-init.el --- a/lisp/ediff/ediff-init.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2058 +0,0 @@ -;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;; Start compiler pacifier -(defvar ediff-metajob-name) -(defvar ediff-meta-buffer) -(defvar pm-color-alist) -(defvar ediff-grab-mouse) -(defvar ediff-mouse-pixel-position) -(defvar ediff-mouse-pixel-threshold) -(defvar ediff-whitespace) -(defvar ediff-multiframe) - -(and noninteractive - (eval-when-compile - (load "ange-ftp" 'noerror))) -;; end pacifier - -;; Is it XEmacs? -(defconst ediff-xemacs-p (string-match "XEmacs" emacs-version)) -;; Is it Emacs? -(defconst ediff-emacs-p (not ediff-xemacs-p)) - -(defvar ediff-force-faces nil - "If t, Ediff will think that it is running on a display that supports faces. -This is provided as a temporary relief for users of face-capable displays -that Ediff doesn't know about.") - -;; Are we running as a window application or on a TTY? -(defsubst ediff-device-type () - (if ediff-emacs-p - window-system - (device-type (selected-device)))) - -;; in XEmacs: device-type is tty on tty and stream in batch. -(defun ediff-window-display-p () - (and (ediff-device-type) (not (memq (ediff-device-type) '(tty pc stream))))) - -;; test if supports faces -;; ediff-force-faces is for those devices that support faces, but we don't know -;; this yet -(defun ediff-has-face-support-p () - (cond ((ediff-window-display-p)) - (ediff-force-faces) - (ediff-emacs-p (memq (ediff-device-type) '(pc))) - (ediff-xemacs-p (memq (ediff-device-type) '(tty pc))))) - - -;; Defines SYMBOL as an advertised local variable. -;; Performs a defvar, then executes `make-variable-buffer-local' on -;; the variable. Also sets the `permanent-local' property, -;; so that `kill-all-local-variables' (called by major-mode setting -;; commands) won't destroy Ediff control variables. -;; -;; Plagiarised from `emerge-defvar-local' for XEmacs. -(defmacro ediff-defvar-local (var value doc) - (` (progn - (defvar (, var) (, value) (, doc)) - (make-variable-buffer-local '(, var)) - (put '(, var) 'permanent-local t)))) - - - -;; Variables that control each Ediff session---local to the control buffer. - -;; Mode variables -;; The buffer in which the A variant is stored. -(ediff-defvar-local ediff-buffer-A nil "") -;; The buffer in which the B variant is stored. -(ediff-defvar-local ediff-buffer-B nil "") -;; The buffer in which the C variant is stored. -(ediff-defvar-local ediff-buffer-C nil "") -;; Ancestor buffer -(ediff-defvar-local ediff-ancestor-buffer nil "") -;; The Ediff control buffer -(ediff-defvar-local ediff-control-buffer nil "") - - -;; Association between buff-type and ediff-buffer-* -(defconst ediff-buffer-alist - '((?A . ediff-buffer-A) - (?B . ediff-buffer-B) - (?C . ediff-buffer-C))) - -;;; Macros -(defmacro ediff-odd-p (arg) - (` (eq (logand (, arg) 1) 1))) - -(defmacro ediff-buffer-live-p (buf) - (` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf)))))) - -(defmacro ediff-get-buffer (arg) - (` (cond ((eq (, arg) 'A) ediff-buffer-A) - ((eq (, arg) 'B) ediff-buffer-B) - ((eq (, arg) 'C) ediff-buffer-C) - ((eq (, arg) 'Ancestor) ediff-ancestor-buffer) - ) - )) - -(defmacro ediff-get-value-according-to-buffer-type (buf-type list) - (` (cond ((eq (, buf-type) 'A) (nth 0 (, list))) - ((eq (, buf-type) 'B) (nth 1 (, list))) - ((eq (, buf-type) 'C) (nth 2 (, list)))))) - -(defmacro ediff-char-to-buftype (arg) - (` (cond ((memq (, arg) '(?a ?A)) 'A) - ((memq (, arg) '(?b ?B)) 'B) - ((memq (, arg) '(?c ?C)) 'C) - ) - )) - - -;; A-list is supposed to be of the form (A . symb) (B . symb)...) -;; where the first part of any association is a buffer type and the second is -;; an appropriate symbol. Given buffer-type, this function returns the -;; symbol. This is used to avoid using `intern' -(defsubst ediff-get-symbol-from-alist (buf-type alist) - (cdr (assoc buf-type alist))) - -(defconst ediff-difference-vector-alist - '((A . ediff-difference-vector-A) - (B . ediff-difference-vector-B) - (C . ediff-difference-vector-C) - (Ancestor . ediff-difference-vector-Ancestor))) - -(defmacro ediff-get-difference (n buf-type) - (` (aref - (symbol-value - (ediff-get-symbol-from-alist - (, buf-type) ediff-difference-vector-alist)) - (, n)))) - -;; Tell if it has been previously determined that the region has -;; no diffs other than the white space and newlines -;; The argument, N, is the diff region number used by Ediff to index the -;; diff vector. It is 1 less than the number seen by the user. -;; Returns: -;; t if the diffs are whitespace in all buffers -;; 'A (in 3-buf comparison only) if there are only whitespace -;; diffs in bufs B and C -;; 'B (in 3-buf comparison only) if there are only whitespace -;; diffs in bufs A and C -;; 'C (in 3-buf comparison only) if there are only whitespace -;; diffs in bufs A and B -;; -;; A difference vector has the form: -;; [diff diff diff ...] -;; where each diff has the form: -;; [overlay fine-diff-vector no-fine-diffs-flag] -;; fine-diff-vector is a vector [fine-diff fine-diff fine-diff ...] -(defmacro ediff-no-fine-diffs-p (n) - (` (aref (ediff-get-difference (, n) 'A) 2))) - -(defmacro ediff-get-diff-overlay-from-diff-record (diff-rec) - (` (aref (, diff-rec) 0))) - -(defmacro ediff-get-diff-overlay (n buf-type) - (` (ediff-get-diff-overlay-from-diff-record - (ediff-get-difference (, n) (, buf-type))))) - -(defmacro ediff-get-fine-diff-vector-from-diff-record (diff-rec) - (` (aref (, diff-rec) 1))) - -(defmacro ediff-set-fine-diff-vector (n buf-type fine-vec) - (` (aset (ediff-get-difference (, n) (, buf-type)) 1 (, fine-vec)))) - -(defmacro ediff-get-state-of-diff (n buf-type) - (` (if (ediff-buffer-live-p ediff-buffer-C) - (aref (ediff-get-difference (, n) (, buf-type)) 3)))) -(defmacro ediff-set-state-of-diff (n buf-type val) - (` (aset (ediff-get-difference (, n) (, buf-type)) 3 (, val)))) -(defmacro ediff-get-state-of-merge (n) - (` (if ediff-state-of-merge - (aref (aref ediff-state-of-merge (, n)) 0)))) -(defmacro ediff-get-state-of-ancestor (n) - (` (if ediff-state-of-merge - (aref (aref ediff-state-of-merge (, n)) 1)))) -(defmacro ediff-set-state-of-merge (n val) - (` (if ediff-state-of-merge - (aset (aref ediff-state-of-merge (, n)) 0 (, val))))) - -;; if flag is t, puts a mark on diff region saying that -;; the differences are in white space only. If flag is nil, -;; the region is marked as essential (i.e., differences are -;; not just in the white space and newlines.) -(defmacro ediff-mark-diff-as-space-only (n flag) - (` (aset (ediff-get-difference (, n) 'A) 2 (, flag)))) - -(defmacro ediff-get-fine-diff-vector (n buf-type) - (` (ediff-get-fine-diff-vector-from-diff-record - (ediff-get-difference (, n) (, buf-type))))) - -;; Macro to switch to BUFFER, evaluate BODY, returns to original buffer. -;; Doesn't save the point and mark. -;; This is `with-current-buffer' with the added test for live buffers." -(defmacro ediff-with-current-buffer (buffer &rest body) - (` (if (ediff-buffer-live-p (, buffer)) - (save-current-buffer - (set-buffer (, buffer)) - (,@ body)) - (or (eq this-command 'ediff-quit) - (error ediff-KILLED-VITAL-BUFFER)) - ))) - - -(defsubst ediff-multiframe-setup-p () - (and (ediff-window-display-p) ediff-multiframe)) - -(defmacro ediff-narrow-control-frame-p () - (` (and (ediff-multiframe-setup-p) - (equal ediff-help-message ediff-brief-message-string)))) - -(defmacro ediff-3way-comparison-job () - (` (memq - ediff-job-name - '(ediff-files3 ediff-buffers3)))) -(ediff-defvar-local ediff-3way-comparison-job nil "") - -(defmacro ediff-merge-job () - (` (memq - ediff-job-name - '(ediff-merge-files - ediff-merge-buffers - ediff-merge-files-with-ancestor - ediff-merge-buffers-with-ancestor - ediff-merge-revisions - ediff-merge-revisions-with-ancestor)))) -(ediff-defvar-local ediff-merge-job nil "") - -(defmacro ediff-merge-with-ancestor-job () - (` (memq - ediff-job-name - '(ediff-merge-files-with-ancestor - ediff-merge-buffers-with-ancestor - ediff-merge-revisions-with-ancestor)))) -(ediff-defvar-local ediff-merge-with-ancestor-job nil "") - -(defmacro ediff-3way-job () - (` (or ediff-3way-comparison-job ediff-merge-job))) -(ediff-defvar-local ediff-3way-job nil "") - -;; A diff3 job is like a 3way job, but ediff-merge doesn't require the use -;; of diff3. -(defmacro ediff-diff3-job () - (` (or ediff-3way-comparison-job - ediff-merge-with-ancestor-job))) -(ediff-defvar-local ediff-diff3-job nil "") - -(defmacro ediff-windows-job () - (` (memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise)))) -(ediff-defvar-local ediff-windows-job nil "") - -(defmacro ediff-word-mode-job () - (` (memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise)))) -(ediff-defvar-local ediff-word-mode-job nil "") - -(defmacro ediff-narrow-job () - (` (memq ediff-job-name '(ediff-windows-wordwise - ediff-regions-wordwise - ediff-windows-linewise - ediff-regions-linewise)))) -(ediff-defvar-local ediff-narrow-job nil "") - -;; Note: ediff-merge-directory-revisions-with-ancestor is not treated as an -;; ancestor metajob, since it behaves differently. -(defsubst ediff-ancestor-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-merge-directories-with-ancestor - ediff-merge-filegroups-with-ancestor))) -(defsubst ediff-revision-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-directory-revisions - ediff-merge-directory-revisions - ediff-merge-directory-revisions-with-ancestor))) -(defsubst ediff-patch-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-multifile-patch))) -;; metajob involving only one group of files, such as multipatch or directory -;; revision -(defsubst ediff-one-filegroup-metajob (&optional metajob) - (or (ediff-revision-metajob metajob) - (ediff-patch-metajob metajob) - ;; add more here - )) -(defsubst ediff-collect-diffs-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-directories - ediff-directory-revisions - ediff-merge-directories - ediff-merge-directories-with-ancestor - ediff-merge-directory-revisions - ediff-merge-directory-revisions-with-ancestor - ;; add more here - ))) -(defsubst ediff-merge-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-merge-directories - ediff-merge-directories-with-ancestor - ediff-merge-directory-revisions - ediff-merge-directory-revisions-with-ancestor - ediff-merge-filegroups-with-ancestor - ;; add more here - ))) - -(defsubst ediff-metajob3 (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-merge-directories-with-ancestor - ediff-merge-filegroups-with-ancestor - ediff-directories3 - ediff-filegroups3))) -(defsubst ediff-comparison-metajob3 (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-directories3 ediff-filegroups3))) - -;; with no argument, checks if we are in ediff-control-buffer -;; with argument, checks if we are in ediff-meta-buffer -(defun ediff-in-control-buffer-p (&optional meta-buf-p) - (and (boundp 'ediff-control-buffer) - (eq (if meta-buf-p ediff-meta-buffer ediff-control-buffer) - (current-buffer)))) - -(defsubst ediff-barf-if-not-control-buffer (&optional meta-buf-p) - (or (ediff-in-control-buffer-p meta-buf-p) - (error "%S: This command runs in Ediff Control Buffer only!" - this-command))) - -;; Hook variables - -(defcustom ediff-before-setup-windows-hook nil - "*Hooks to run before Ediff sets its window configuration. -This can be used to save the previous window config, which can be restored -on ediff-quit or ediff-suspend." - :type 'hook - :group 'ediff) -(defcustom ediff-after-setup-windows-hook nil - "*Hooks to run after Ediff sets its window configuration. -This can be used to set up control window or icon in a desired place." - :type 'hook - :group 'ediff) -(defcustom ediff-before-setup-control-frame-hook nil - "*Hooks run before setting up the frame to display Ediff Control Panel. -Can be used to change control frame parameters to position it where it -is desirable." - :type 'hook - :group 'ediff) -(defcustom ediff-after-setup-control-frame-hook nil - "*Hooks run after setting up the frame to display Ediff Control Panel. -Can be used to move the frame where it is desired." - :type 'hook - :group 'ediff) -(defcustom ediff-startup-hook nil - "*Hooks to run in the control buffer after Ediff has been set up." - :type 'hook - :group 'ediff) -(defcustom ediff-select-hook nil - "*Hooks to run after a difference has been selected." - :type 'hook - :group 'ediff) -(defcustom ediff-unselect-hook nil - "*Hooks to run after a difference has been unselected." - :type 'hook - :group 'ediff) -(defcustom ediff-prepare-buffer-hook nil - "*Hooks called after buffers A, B, and C are set up." - :type 'hook - :group 'ediff) -(defcustom ediff-load-hook nil - "*Hook run after Ediff is loaded. Can be used to change defaults." - :type 'hook - :group 'ediff) - -(defcustom ediff-mode-hook nil - "*Hook run just after ediff-mode is set up in the control buffer. -This is done before any windows or frames are created. One can use it to -set local variables that determine how the display looks like." - :type 'hook - :group 'ediff) -(defcustom ediff-keymap-setup-hook nil - "*Hook run just after the default bindings in Ediff keymap are set up." - :type 'hook - :group 'ediff) - -(defcustom ediff-display-help-hook nil - "*Hooks run after preparing the help message." - :type 'hook - :group 'ediff) - -(defcustom ediff-suspend-hook (list 'ediff-default-suspend-function) - "*Hooks to run in the Ediff control buffer when Ediff is suspended." - :type 'hook - :group 'ediff) -(defcustom ediff-quit-hook (list 'ediff-cleanup-mess) - "*Hooks to run in the Ediff control buffer after finishing Ediff." - :type 'hook - :group 'ediff) -(defcustom ediff-cleanup-hook nil - "*Hooks to run on exiting Ediff but before killing the control buffer. -This is a place to do various cleanups, such as deleting the variant buffers. -Ediff provides a function, `ediff-janitor', as one such possible hook." - :type 'hook - :group 'ediff) - -;; Error messages -(defconst ediff-KILLED-VITAL-BUFFER - "You have killed a vital Ediff buffer---you must leave Ediff now!") -(defconst ediff-NO-DIFFERENCES - "Sorry, comparison of identical variants is not what I am made for...") -(defconst ediff-BAD-DIFF-NUMBER - ;; %S stands for this-command, %d - diff number, %d - max diff - "%S: Bad diff region number, %d. Valid numbers are 1 to %d") -(defconst ediff-BAD-INFO (format " -*** The Info file for Ediff, a part of the standard distribution -*** of %sEmacs, does not seem to be properly installed. -*** -*** Please contact your system administrator. " - (if ediff-xemacs-p "X" ""))) - -;; Selective browsing - -(ediff-defvar-local ediff-skip-diff-region-function 'ediff-show-all-diffs - "Function that determines the next/previous diff region to show. -Should return t for regions to be ignored and nil otherwise. -This function gets a region number as an argument. The region number -is the one used internally by Ediff. It is 1 less than the number seen -by the user.") - -(ediff-defvar-local ediff-hide-regexp-matches-function - 'ediff-hide-regexp-matches - "Function to use in determining which regions to hide. -See the documentation string of `ediff-hide-regexp-matches' for details.") -(ediff-defvar-local ediff-focus-on-regexp-matches-function - 'ediff-focus-on-regexp-matches - "Function to use in determining which regions to focus on. -See the documentation string of `ediff-focus-on-regexp-matches' for details.") - -;; Regexp that determines buf A regions to focus on when skipping to diff -(ediff-defvar-local ediff-regexp-focus-A "" "") -;; Regexp that determines buf B regions to focus on when skipping to diff -(ediff-defvar-local ediff-regexp-focus-B "" "") -;; Regexp that determines buf C regions to focus on when skipping to diff -(ediff-defvar-local ediff-regexp-focus-C "" "") -;; connective that determines whether to focus regions that match both or -;; one of the regexps -(ediff-defvar-local ediff-focus-regexp-connective 'and "") - -;; Regexp that determines buf A regions to ignore when skipping to diff -(ediff-defvar-local ediff-regexp-hide-A "" "") -;; Regexp that determines buf B regions to ignore when skipping to diff -(ediff-defvar-local ediff-regexp-hide-B "" "") -;; Regexp that determines buf C regions to ignore when skipping to diff -(ediff-defvar-local ediff-regexp-hide-C "" "") -;; connective that determines whether to hide regions that match both or -;; one of the regexps -(ediff-defvar-local ediff-hide-regexp-connective 'and "") - - -;;; Copying difference regions between buffers. - -;; A list of killed diffs. -;; A diff is saved here if it is replaced by a diff -;; from another buffer. This alist has the form: -;; \((num (buff-object . diff) (buff-object . diff) (buff-object . diff)) ...), -;; where some buffer-objects may be missing. -(ediff-defvar-local ediff-killed-diffs-alist nil "") - - -;; Highlighting -(defcustom ediff-before-flag-bol (if ediff-xemacs-p (make-glyph "->>") "->>") - "*Flag placed before a highlighted block of differences, if block starts at beginning of a line." - :type 'string - :tag "Region before-flag at beginning of line" - :group 'ediff) - -(defcustom ediff-after-flag-eol (if ediff-xemacs-p (make-glyph "<<-") "<<-") - "*Flag placed after a highlighted block of differences, if block ends at end of a line." - :type 'string - :tag "Region after-flag at end of line" - :group 'ediff) - -(defcustom ediff-before-flag-mol (if ediff-xemacs-p (make-glyph "->>") "->>") - "*Flag placed before a highlighted block of differences, if block starts in mid-line." - :type 'string - :tag "Region before-flag in the middle of line" - :group 'ediff) -(defcustom ediff-after-flag-mol (if ediff-xemacs-p (make-glyph "<<-") "<<-") - "*Flag placed after a highlighted block of differences, if block ends in mid-line." - :type 'string - :tag "Region after-flag in the middle of line" - :group 'ediff) - - -(ediff-defvar-local ediff-use-faces t - "If t, differences are highlighted using faces, if device supports faces. -If nil, differences are highlighted using ASCII flags, ediff-before-flag -and ediff-after-flag. On a non-window system, differences are always -highlighted using ASCII flags. -This variable can be set either in .emacs or toggled interactively. -Use `setq-default' if setting it in .emacs") - -;; this indicates that diff regions are word-size, so fine diffs are -;; permanently nixed; used in ediff-windows-wordwise and ediff-regions-wordwise -(ediff-defvar-local ediff-word-mode nil "") -;; Name of the job (ediff-files, ediff-windows, etc.) -(ediff-defvar-local ediff-job-name nil "") - -;; Narrowing and ediff-region/windows support -;; This is a list (overlay-A overlay-B overlay-C) -;; If set, Ediff compares only those parts of buffers A/B/C that lie within -;; the bounds of these overlays. -(ediff-defvar-local ediff-narrow-bounds nil "") - -;; List (overlay-A overlay-B overlay-C), where each overlay spans the -;; entire corresponding buffer. -(ediff-defvar-local ediff-wide-bounds nil "") - -;; Current visibility boundaries in buffers A, B, and C. -;; This is also a list of overlays. When the user toggles narrow/widen, -;; this list changes from ediff-wide-bounds to ediff-narrow-bounds. -;; and back. -(ediff-defvar-local ediff-visible-bounds nil "") - -(ediff-defvar-local ediff-start-narrowed t - "Non-nil means start narrowed, if doing ediff-windows-* or ediff-regions-*") -(ediff-defvar-local ediff-quit-widened t - "*Non-nil means: when finished, Ediff widens buffers A/B. -Actually, Ediff restores the scope of visibility that existed at startup.") - -(defcustom ediff-keep-variants t - "*Nil means that non-modified variant buffers should be removed at the end of the session after some interrogation. -Supplying a prefix argument to the quit command `q' temporarily reverses the -meaning of this variable." - :type 'boolean - :group 'ediff) - -(ediff-defvar-local ediff-highlight-all-diffs t - "If nil, only the selected differences are highlighted. -This variable can be set either in .emacs or toggled interactively, using -ediff-toggle-hilit. Use `setq-default' to set it.") - -;; A var local to each control panel buffer. Indicates highlighting style -;; in effect for this buffer: `face', `ascii', nil -- temporarily -;; unhighlighted, `off' -- turned off \(on a dumb terminal only\). -(ediff-defvar-local ediff-highlighting-style nil "") - - -;; The suffix of the control buffer name. -(ediff-defvar-local ediff-control-buffer-suffix nil "") -;; Same as ediff-control-buffer-suffix, but without <,>. -;; It's a number rather than string. -(ediff-defvar-local ediff-control-buffer-number nil "") - - -;; The original values of ediff-protected-variables for buffer A -(ediff-defvar-local ediff-buffer-values-orig-A nil "") -;; The original values of ediff-protected-variables for buffer B -(ediff-defvar-local ediff-buffer-values-orig-B nil "") -;; The original values of ediff-protected-variables for buffer C -(ediff-defvar-local ediff-buffer-values-orig-C nil "") -;; The original values of ediff-protected-variables for buffer Ancestor -(ediff-defvar-local ediff-buffer-values-orig-Ancestor nil "") - -;; association between buff-type and ediff-buffer-values-orig-* -(defconst ediff-buffer-values-orig-alist - '((A . ediff-buffer-values-orig-A) - (B . ediff-buffer-values-orig-B) - (C . ediff-buffer-values-orig-C) - (Ancestor . ediff-buffer-values-orig-Ancestor))) - -;; Buffer-local variables to be saved then restored during Ediff sessions -(defconst ediff-protected-variables '( - ;;buffer-read-only - mode-line-format)) - -;; Vector of differences between the variants. Each difference is -;; represented by a vector of two overlays plus a vector of fine diffs, -;; plus a no-fine-diffs flag. The first overlay spans the -;; difference region in the A buffer and the second overlays the diff in -;; the B buffer. If a difference section is empty, the corresponding -;; overlay's endpoints coincide. -;; -;; The precise form of a difference vector for one buffer is: -;; [diff diff diff ...] -;; where each diff has the form: -;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-difference] -;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...] -;; no-fine-diffs-flag says if there are fine differences. -;; state-of-difference is A, B, C, or nil, indicating which buffer is -;; different from the other two (used only in 3-way jobs. -(ediff-defvar-local ediff-difference-vector-A nil "") -(ediff-defvar-local ediff-difference-vector-B nil "") -(ediff-defvar-local ediff-difference-vector-C nil "") -(ediff-defvar-local ediff-difference-vector-Ancestor nil "") -;; A-list of diff vector types associated with buffer types -(defconst ediff-difference-vector-alist - '((A . ediff-difference-vector-A) - (B . ediff-difference-vector-B) - (C . ediff-difference-vector-C) - (Ancestor . ediff-difference-vector-Ancestor))) - -;; [ status status status ...] -;; Each status: [state-of-merge state-of-ancestor] -;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It -;; indicates the way a diff region was created in buffer C. -;; state-of-ancestor says if the corresponding region in ancestor buffer is -;; empty. -(ediff-defvar-local ediff-state-of-merge nil "") - -;; The difference that is currently selected. -(ediff-defvar-local ediff-current-difference -1 "") -;; Number of differences found. -(ediff-defvar-local ediff-number-of-differences nil "") - -;; Buffer containing the output of diff, which is used by Ediff to step -;; through files. -(ediff-defvar-local ediff-diff-buffer nil "") -;; Like ediff-diff-buffer, but contains context diff. It is not used by -;; Ediff, but it is saved in a file, if user requests so. -(ediff-defvar-local ediff-custom-diff-buffer nil "") -;; Buffer used for diff-style fine differences between regions. -(ediff-defvar-local ediff-fine-diff-buffer nil "") -;; Temporary buffer used for computing fine differences. -(defconst ediff-tmp-buffer " *ediff-tmp*" "") -;; Buffer used for messages -(defconst ediff-msg-buffer " *ediff-message*" "") -;; Buffer containing the output of diff when diff returns errors. -(ediff-defvar-local ediff-error-buffer nil "") -;; Buffer to display debug info -(ediff-defvar-local ediff-debug-buffer "*ediff-debug*" "") - -;; List of ediff control panels associated with each buffer A/B/C/Ancestor. -;; Not used any more, but may be needed in the future. -(ediff-defvar-local ediff-this-buffer-ediff-sessions nil "") - -;; to be deleted in due time -;; List of difference overlays disturbed by working with the current diff. -(defvar ediff-disturbed-overlays nil "") - -;; Priority of non-selected overlays. -(defvar ediff-shadow-overlay-priority 100 "") - -(defcustom ediff-version-control-package 'vc - "Version control package used. -Currently, Ediff supports vc.el, rcs.el, pcl-cvs.el, and generic-sc.el. The -standard Emacs interface to RCS, CVS, SCCS, etc., is vc.el. However, some -people find the other two packages more convenient. Set this variable to the -appropriate symbol: `rcs', `pcl-cvs', or `generic-sc' if you so desire." - :type 'symbol - :group 'ediff) - - -(if ediff-xemacs-p - (progn - (fset 'ediff-read-event (symbol-function 'next-command-event)) - (fset 'ediff-overlayp (symbol-function 'extentp)) - (fset 'ediff-make-overlay (symbol-function 'make-extent)) - (fset 'ediff-delete-overlay (symbol-function 'delete-extent))) - (fset 'ediff-read-event (symbol-function 'read-event)) - (fset 'ediff-overlayp (symbol-function 'overlayp)) - (fset 'ediff-make-overlay (symbol-function 'make-overlay)) - (fset 'ediff-delete-overlay (symbol-function 'delete-overlay))) - -;; Check the current version against the major and minor version numbers -;; using op: cur-vers op major.minor If emacs-major-version or -;; emacs-minor-version are not defined, we assume that the current version -;; is hopelessly outdated. We assume that emacs-major-version and -;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the -;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value -;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be -;; incorrect. However, this gives correct result in our cases, since we are -;; testing for sufficiently high Emacs versions. -(defun ediff-check-version (op major minor &optional type-of-emacs) - (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) - (and (cond ((eq type-of-emacs 'xemacs) ediff-xemacs-p) - ((eq type-of-emacs 'emacs) ediff-emacs-p) - (t t)) - (cond ((eq op '=) (and (= emacs-minor-version minor) - (= emacs-major-version major))) - ((memq op '(> >= < <=)) - (and (or (funcall op emacs-major-version major) - (= emacs-major-version major)) - (if (= emacs-major-version major) - (funcall op emacs-minor-version minor) - t))) - (t - (error "%S: Invalid op in ediff-check-version" op)))) - (cond ((memq op '(= > >=)) nil) - ((memq op '(< <=)) t)))) - - - -;; A fix for NeXT Step -;; Should probably be eliminated in later versions. -(if (and (ediff-window-display-p) (eq (ediff-device-type) 'ns)) - (progn - (fset 'x-display-color-p (symbol-function 'ns-display-color-p)) - (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p)) - (fset 'x-display-pixel-height (symbol-function 'ns-display-pixel-height)) - (fset 'x-display-pixel-width (symbol-function 'ns-display-pixel-width)) - )) - - -(defsubst ediff-color-display-p () - (if ediff-emacs-p - (x-display-color-p) - (eq (device-class (selected-device)) 'color))) - - -(if (ediff-has-face-support-p) - (if ediff-xemacs-p - (progn - (fset 'ediff-valid-color-p (symbol-function 'valid-color-name-p)) - (fset 'ediff-get-face (symbol-function 'get-face))) - ;; Temporary fix for OS/2 port of Emacs - ;; pm-win.el in PM-Emacs should be fixed. - (if (eq (ediff-device-type) 'pm) - (fset 'ediff-valid-color-p - (function (lambda (color) (assoc color pm-color-alist)))) - (fset 'ediff-valid-color-p (symbol-function 'x-color-defined-p))) - (fset 'ediff-get-face (symbol-function 'internal-get-face)))) - -(if (ediff-window-display-p) - (if ediff-xemacs-p - (progn - (fset 'ediff-display-pixel-width - (symbol-function 'device-pixel-width)) - (fset 'ediff-display-pixel-height - (symbol-function 'device-pixel-height))) - (fset 'ediff-display-pixel-width - (symbol-function 'x-display-pixel-width)) - (fset 'ediff-display-pixel-height - (symbol-function 'x-display-pixel-height)))) - -;; A-list of current-diff-overlay symbols asssociated with buf types -(defconst ediff-current-diff-overlay-alist - '((A . ediff-current-diff-overlay-A) - (B . ediff-current-diff-overlay-B) - (C . ediff-current-diff-overlay-C) - (Ancestor . ediff-current-diff-overlay-Ancestor))) - -;; A-list of current-diff-face-* symbols asssociated with buf types -(defconst ediff-current-diff-face-alist - '((A . ediff-current-diff-face-A) - (B . ediff-current-diff-face-B) - (C . ediff-current-diff-face-C) - (Ancestor . ediff-current-diff-face-Ancestor))) - - -(defun ediff-make-current-diff-overlay (type) - (if (ediff-has-face-support-p) - (let ((overlay (ediff-get-symbol-from-alist - type ediff-current-diff-overlay-alist)) - (buffer (ediff-get-buffer type)) - (face (face-name - (symbol-value - (ediff-get-symbol-from-alist - type ediff-current-diff-face-alist))))) - (set overlay - (ediff-make-bullet-proof-overlay (point-max) (point-max) buffer)) - (ediff-set-overlay-face (symbol-value overlay) face) - (ediff-overlay-put (symbol-value overlay) 'ediff ediff-control-buffer)) - )) - -(defun ediff-set-overlay-face (extent face) - (ediff-overlay-put extent 'face face) - (ediff-overlay-put extent 'help-echo 'ediff-region-help-echo)) - -;; This does nothing in Emacs, since overlays there have no help-echo property -(defun ediff-region-help-echo (extent) - (let ((is-current (ediff-overlay-get extent 'ediff)) - (face (ediff-overlay-get extent 'face)) - (diff-num (ediff-overlay-get extent 'ediff-diff-num)) - face-help) - - ;; This happens only for refinement overlays - (setq face-help (and face (get face 'ediff-help-echo))) - - (cond ((and is-current diff-num) ; current diff region - (format "Difference region %S -- current" (1+ diff-num))) - (face-help) ; refinement of current diff region - (diff-num ; non-current - (format "Difference region %S -- non-current" (1+ diff-num))) - (t "")) ; none - )) - -;;(defun ediff-set-face (ground face color) -;; "Set face foreground/background." -;; (if (ediff-has-face-support-p) -;; (if (ediff-valid-color-p color) -;; (if (eq ground 'foreground) -;; (set-face-foreground face color) -;; (set-face-background face color)) -;; (cond ((memq face -;; '(ediff-current-diff-face-A -;; ediff-current-diff-face-B -;; ediff-current-diff-face-C -;; ediff-current-diff-face-Ancestor)) -;; (copy-face 'highlight face)) -;; ((memq face -;; '(ediff-fine-diff-face-A -;; ediff-fine-diff-face-B -;; ediff-fine-diff-face-C -;; ediff-fine-diff-face-Ancestor)) -;; (copy-face 'secondary-selection face) -;; (set-face-underline-p face t)) -;; ((memq face -;; '(ediff-even-diff-face-A -;; ediff-odd-diff-face-A -;; ediff-even-diff-face-B ediff-odd-diff-face-B -;; ediff-even-diff-face-C ediff-odd-diff-face-C -;; ediff-even-diff-face-Ancestor -;; ediff-odd-diff-face-Ancestor)) -;; (copy-face 'secondary-selection face)))) -;; )) - -(defun ediff-set-face-pixmap (face pixmap) - "Set face pixmap on a monochrome display." - (if (and (ediff-window-display-p) (not (ediff-color-display-p))) - (condition-case nil - (set-face-background-pixmap face pixmap) - (error - (message "Pixmap not found for %S: %s" (face-name face) pixmap) - (sit-for 1))))) - -(defun ediff-hide-face (face) - (if (and (ediff-has-face-support-p) ediff-emacs-p) - (add-to-list 'facemenu-unlisted-faces face))) - -(defgroup ediff-highlighting nil - "Hilighting of difference regions in Ediff" - :prefix "ediff-" - :group 'ediff) - -;;(defvar ediff-current-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-current-diff-face-A "firebrick") -;; (ediff-set-face -;; 'background 'ediff-current-diff-face-A "pale green")) -;; (t -;; (if ediff-xemacs-p -;; (copy-face 'modeline 'ediff-current-diff-face-A) -;; (copy-face 'highlight 'ediff-current-diff-face-A)) -;; ))) -;; 'ediff-current-diff-face-A)) -;; "Face for highlighting the selected difference in buffer A.") - -(defface ediff-current-diff-face-A - '((((class color)) (:foreground "firebrick" :background "pale green")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-A 'ediff-current-diff-face-A - "Face for highlighting the selected difference in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-current-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-A) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-A)) - - - -;;(defvar ediff-current-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-current-diff-face-B "DarkOrchid") -;; (ediff-set-face -;; 'background 'ediff-current-diff-face-B "Yellow")) -;; (t -;; (if ediff-xemacs-p -;; (copy-face 'modeline 'ediff-current-diff-face-B) -;; (copy-face 'highlight 'ediff-current-diff-face-B)) -;; ))) -;; 'ediff-current-diff-face-B)) -;; "Face for highlighting the selected difference in buffer B.") - -(defface ediff-current-diff-face-B - '((((class color)) (:foreground "DarkOrchid" :background "Yellow")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-B 'ediff-current-diff-face-B - "Face for highlighting the selected difference in buffer B. - this variable. Instead, use the customization -widget to customize the actual face `ediff-current-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-B) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-B)) - -;;(defvar ediff-current-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-C) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-current-diff-face-C "Navy") -;; (ediff-set-face -;; 'background 'ediff-current-diff-face-C "Pink")) -;; (t -;; (if ediff-xemacs-p -;; (copy-face 'modeline 'ediff-current-diff-face-C) -;; (copy-face 'highlight 'ediff-current-diff-face-C)) -;; ))) -;; 'ediff-current-diff-face-C)) -;; "Face for highlighting the selected difference in buffer C.") - -(defface ediff-current-diff-face-C - '((((class color)) (:foreground "Navy" :background "Pink")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-C 'ediff-current-diff-face-C - "Face for highlighting the selected difference in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-current-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-C) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-C)) - -;;(defvar ediff-current-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-Ancestor) -;; (copy-face -;; 'ediff-current-diff-face-C 'ediff-current-diff-face-Ancestor)) -;; 'ediff-current-diff-face-Ancestor)) -;; "Face for highlighting the selected difference in the ancestor buffer.") - -(defface ediff-current-diff-face-Ancestor - '((((class color)) (:foreground "Black" :background "VioletRed")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer Ancestor." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-Ancestor 'ediff-current-diff-face-Ancestor - "Face for highlighting the selected difference in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-current-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-Ancestor)) - -;;(defvar ediff-fine-diff-pixmap "gray3" -;; "Pixmap to use for highlighting fine differences.") -;;(defvar ediff-odd-diff-pixmap "gray1" -;; "Pixmap to use for highlighting odd differences.") -;;(defvar ediff-even-diff-pixmap "Stipple" -;; "Pixmap to use for highlighting even differences.") - -;;(defvar ediff-fine-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face 'foreground 'ediff-fine-diff-face-A -;; "Navy") -;; (ediff-set-face 'background 'ediff-fine-diff-face-A -;; "sky blue")) -;; (t -;; (set-face-underline-p 'ediff-fine-diff-face-A t) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-A -;; ediff-fine-diff-pixmap) -;; ))) -;; 'ediff-fine-diff-face-A)) -;; "Face for highlighting the refinement of the selected diff in buffer A.") - - -(defface ediff-fine-diff-face-A - '((((class color)) (:foreground "Navy" :background "sky blue")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-A 'ediff-fine-diff-face-A - "Face for highlighting the fine differences in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-A) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-fine-diff-face-A "gray3")) - -;;(defvar ediff-fine-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face 'foreground 'ediff-fine-diff-face-B "Black") -;; (ediff-set-face 'background 'ediff-fine-diff-face-B "cyan")) -;; (t -;; (set-face-underline-p 'ediff-fine-diff-face-B t) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-B -;; ediff-fine-diff-pixmap) -;; ))) -;; 'ediff-fine-diff-face-B)) -;; "Face for highlighting the refinement of the selected diff in buffer B.") - -(defface ediff-fine-diff-face-B - '((((class color)) (:foreground "Black" :background "cyan")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-B 'ediff-fine-diff-face-B - "Face for highlighting the fine differences in buffer B. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-B) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-fine-diff-face-B "gray3")) - -;;(defvar ediff-fine-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-C) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face 'foreground 'ediff-fine-diff-face-C "black") -;; (ediff-set-face -;; 'background 'ediff-fine-diff-face-C "Turquoise")) -;; (t -;; (set-face-underline-p 'ediff-fine-diff-face-C t) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-C -;; ediff-fine-diff-pixmap) -;; ))) -;; 'ediff-fine-diff-face-C)) -;; "Face for highlighting the refinement of the selected diff in buffer C.") - -(defface ediff-fine-diff-face-C - '((((class color)) (:foreground "Black" :background "Turquoise")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-C 'ediff-fine-diff-face-C - "Face for highlighting the fine differences in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-C) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-fine-diff-face-C "gray3")) - -;;(defvar ediff-fine-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-Ancestor) -;; (ediff-hide-face 'ediff-fine-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-Ancestor) -;; (progn -;; (copy-face -;; 'ediff-fine-diff-face-C 'ediff-fine-diff-face-Ancestor) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-Ancestor -;; ediff-fine-diff-pixmap)) -;; ))) -;; "Face highlighting refinements of the selected diff in ancestor buffer. -;;Presently, this is not used, as difference regions are not refined in the -;;ancestor buffer.") - -(defface ediff-fine-diff-face-Ancestor - '((((class color)) (:foreground "Black" :background "Green")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in the ancestor buffer. -At present, this face is not used and no fine differences are computed for the -ancestor buffer." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-Ancestor 'ediff-fine-diff-face-Ancestor - "Face for highlighting the fine differences in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap - 'ediff-fine-diff-face-Ancestor "gray3")) - -;;(defvar ediff-even-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-even-diff-face-A "black") -;; (ediff-set-face -;; 'background 'ediff-even-diff-face-A "light grey")) -;; (t -;; (copy-face 'italic 'ediff-even-diff-face-A) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-A -;; ediff-even-diff-pixmap) -;; ))) -;; 'ediff-even-diff-face-A)) -;; "Face used for highlighting even-numbered differences in buffer A.") - -(defface ediff-even-diff-face-A - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-A 'ediff-even-diff-face-A - "Face for highlighting even-numbered non-current differences in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-A) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-even-diff-face-A "Stipple")) - -;;(defvar ediff-even-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-even-diff-face-B "White") -;; (ediff-set-face -;; 'background 'ediff-even-diff-face-B "Gray")) -;; (t -;; (copy-face 'italic 'ediff-even-diff-face-B) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-B -;; ediff-even-diff-pixmap) -;; ))) -;; 'ediff-even-diff-face-B)) -;; "Face used for highlighting even-numbered differences in buffer B.") - -(defface ediff-even-diff-face-B - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-B 'ediff-even-diff-face-B - "Face for highlighting even-numbered non-current differences in buffer B. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-B) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-even-diff-face-B "Stipple")) - -;;(defvar ediff-even-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-C) -;; (ediff-hide-face 'ediff-even-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-C) -;; (progn -;; (copy-face 'ediff-even-diff-face-A 'ediff-even-diff-face-C) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-C -;; ediff-even-diff-pixmap))) -;; 'ediff-even-diff-face-C)) -;; "Face used for highlighting even-numbered differences in buffer C.") - -(defface ediff-even-diff-face-C - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-C 'ediff-even-diff-face-C - "Face for highlighting even-numbered non-current differences in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-C) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-even-diff-face-C "Stipple")) - -;;(defvar ediff-even-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-Ancestor) -;; (ediff-hide-face 'ediff-even-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-Ancestor) -;; (progn -;; (copy-face -;; 'ediff-even-diff-face-C 'ediff-even-diff-face-Ancestor) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-Ancestor -;; ediff-even-diff-pixmap))) -;; 'ediff-even-diff-face-Ancestor)) -;; "Face highlighting even-numbered differences in the ancestor buffer.") - -(defface ediff-even-diff-face-Ancestor - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in the ancestor buffer." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-Ancestor 'ediff-even-diff-face-Ancestor - "Face for highlighting even-numbered non-current differences in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap - 'ediff-even-diff-face-Ancestor "Stipple")) - -;; Association between buffer types and even-diff-face symbols -(defconst ediff-even-diff-face-alist - '((A . ediff-even-diff-face-A) - (B . ediff-even-diff-face-B) - (C . ediff-even-diff-face-C) - (Ancestor . ediff-even-diff-face-Ancestor))) - -;;(defvar ediff-odd-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-odd-diff-face-A "White") -;; (ediff-set-face -;; 'background 'ediff-odd-diff-face-A "Gray")) -;; (t -;; (copy-face 'italic 'ediff-odd-diff-face-A) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-A -;; ediff-odd-diff-pixmap) -;; ))) -;; 'ediff-odd-diff-face-A)) -;; "Face used for highlighting odd-numbered differences in buffer A.") - -(defface ediff-odd-diff-face-A - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-A 'ediff-odd-diff-face-A - "Face for highlighting odd-numbered non-current differences in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-A) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-A "gray1")) - -;;(defvar ediff-odd-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-B) -;; (ediff-hide-face 'ediff-odd-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-odd-diff-face-B "Black") -;; (ediff-set-face -;; 'background 'ediff-odd-diff-face-B "light grey")) -;; (t -;; (copy-face 'italic 'ediff-odd-diff-face-B) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-B -;; ediff-odd-diff-pixmap) -;; ))) -;; 'ediff-odd-diff-face-B)) -;; "Face used for highlighting odd-numbered differences in buffer B.") - -(defface ediff-odd-diff-face-B - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-B 'ediff-odd-diff-face-B - "Face for highlighting odd-numbered non-current differences in buffer B. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-B) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-B "gray1")) - -;;(defvar ediff-odd-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-C) -;; (progn -;; (copy-face 'ediff-odd-diff-face-A 'ediff-odd-diff-face-C) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-C -;; ediff-odd-diff-pixmap))) -;; 'ediff-odd-diff-face-C)) -;; "Face used for highlighting odd-numbered differences in buffer C.") - -(defface ediff-odd-diff-face-C - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-C 'ediff-odd-diff-face-C - "Face for highlighting odd-numbered non-current differences in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-C) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-C "gray1")) - -;;(defvar ediff-odd-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-Ancestor) -;; (progn -;; (copy-face 'ediff-odd-diff-face-C 'ediff-odd-diff-face-Ancestor) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-Ancestor -;; ediff-odd-diff-pixmap))) -;; 'ediff-odd-diff-face-Ancestor)) -;; "Face used for highlighting even-numbered differences in the ancestor buffer.") - -(defface ediff-odd-diff-face-Ancestor - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in the ancestor buffer." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-Ancestor 'ediff-odd-diff-face-Ancestor - "Face for highlighting odd-numbered non-current differences in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-Ancestor "gray1")) - -;; Association between buffer types and odd-diff-face symbols -(defconst ediff-odd-diff-face-alist - '((A . ediff-odd-diff-face-A) - (B . ediff-odd-diff-face-B) - (C . ediff-odd-diff-face-C) - (Ancestor . ediff-odd-diff-face-Ancestor))) - -;; A-list of fine-diff face symbols associated with buffer types -(defconst ediff-fine-diff-face-alist - '((A . ediff-fine-diff-face-A) - (B . ediff-fine-diff-face-B) - (C . ediff-fine-diff-face-C) - (Ancestor . ediff-fine-diff-face-Ancestor))) - -;; Help echo -(put 'ediff-fine-diff-face-A 'ediff-help-echo - "A `refinement' of the current difference region") -(put 'ediff-fine-diff-face-B 'ediff-help-echo - "A `refinement' of the current difference region") -(put 'ediff-fine-diff-face-C 'ediff-help-echo - "A `refinement' of the current difference region") -(put 'ediff-fine-diff-face-Ancestor 'ediff-help-echo - "A `refinement' of the current difference region") - - -;;; Overlays - -(ediff-defvar-local ediff-current-diff-overlay-A nil - "Overlay for the current difference region in buffer A.") -(ediff-defvar-local ediff-current-diff-overlay-B nil - "Overlay for the current difference region in buffer B.") -(ediff-defvar-local ediff-current-diff-overlay-C nil - "Overlay for the current difference region in buffer C.") -(ediff-defvar-local ediff-current-diff-overlay-Ancestor nil - "Overlay for the current difference region in the ancestor buffer.") - -;; Compute priority of ediff overlay. -(defun ediff-highest-priority (start end buffer) - (let ((pos (max 1 (1- start))) - ovr-list) - (if ediff-xemacs-p - (1+ ediff-shadow-overlay-priority) - (ediff-with-current-buffer buffer - (while (< pos (min (point-max) (1+ end))) - (setq ovr-list (append (overlays-at pos) ovr-list)) - (setq pos (next-overlay-change pos))) - (1+ (apply '+ - (mapcar (function - (lambda (ovr) - (if ovr - (or (ediff-overlay-get ovr 'priority) 0) - 0))) - ovr-list) - )) - )))) - - -(defvar ediff-toggle-read-only-function nil - "*Specifies the function to be used to toggle read-only. -If nil, Ediff tries to deduce the function from the binding of C-x C-q. -Normally, this is the `toggle-read-only' function, but, if version -control is used, it could be `vc-toggle-read-only' or `rcs-toggle-read-only'.") - -(defcustom ediff-make-buffers-readonly-at-startup nil - "*Make all variant buffers read-only when Ediff starts up. -This property can be toggled interactively." - :type 'boolean - :group 'ediff) - - -;;; Misc - -;; if nil, this silences some messages -(defconst ediff-verbose-p t) - -(ediff-defvar-local ediff-autostore-merges 'group-jobs-only - "*Save the results of merge jobs automatically. -Nil means don't save automatically. t means always save. Anything but nil or t -means save automatically only if the merge job is part of a group of jobs, such -as `ediff-merge-directory' or `ediff-merge-directory-revisions'.") - -;; file where the result of the merge is to be saved. used internally -(ediff-defvar-local ediff-merge-store-file nil "") - -(defcustom ediff-no-emacs-help-in-control-buffer nil - "*Non-nil means C-h should not invoke Emacs help in control buffer. -Instead, C-h would jump to previous difference." - :type 'boolean - :group 'ediff) - -(defvar ediff-temp-file-prefix - (let ((env (or (getenv "TMPDIR") - (getenv "TMP") - (getenv "TEMP"))) - d) - (setq d (if (and env (> (length env) 0)) - env - (cond ((memq system-type '(vax-vms axp-vms)) "SYS$SCRATCH:") - ((eq system-type 'ms-dos) "c:/") - (t "/tmp")))) - ;; The following is to make sure we get something to which we can - ;; add directory levels on VMS. - (setq d (file-name-as-directory (directory-file-name d))) - ) - "*Prefix to put on Ediff temporary file names. -Do not start with `~/' or `~user-name/'.") - -(defvar ediff-temp-file-mode 384 ; u=rw only - "*Mode for Ediff temporary files.") - -;; Metacharacters that have to be protected from the shell when executing -;; a diff/diff3 command. -(defvar ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]" - "Characters that must be quoted with \\ when used in a shell command line. -More precisely, a regexp to match any one such character.") - -;; needed to simulate frame-char-width in XEmacs. -(defvar ediff-H-glyph (if ediff-xemacs-p (make-glyph "H"))) - - -;; Temporary file used for refining difference regions in buffer A. -(ediff-defvar-local ediff-temp-file-A nil "") -;; Temporary file used for refining difference regions in buffer B. -(ediff-defvar-local ediff-temp-file-B nil "") -;; Temporary file used for refining difference regions in buffer C. -(ediff-defvar-local ediff-temp-file-C nil "") - - -;;; In-line functions - -(or (fboundp 'ediff-file-remote-p) ; user supplied his own function: use it - (defun ediff-file-remote-p (file-name) - (car (cond ((featurep 'efs-auto) (efs-ftp-path file-name)) - ((fboundp 'file-remote-p) (file-remote-p file-name)) - (t (require 'ange-ftp) - ;; Can happen only in Emacs, since XEmacs has file-remote-p - (ange-ftp-ftp-name file-name)))))) - - -(defsubst ediff-frame-unsplittable-p (frame) - (cdr (assq 'unsplittable (frame-parameters frame)))) - -(defsubst ediff-get-next-window (wind prev-wind) - (or (window-live-p wind) - (setq wind (if prev-wind - (next-window wind) - (selected-window))))) - - -(defsubst ediff-kill-buffer-carefully (buf) - "Kill buffer BUF if it exists." - (if (ediff-buffer-live-p buf) - (kill-buffer (get-buffer buf)))) - -(defsubst ediff-background-face (buf-type dif-num) - ;; The value of dif-num is always 1- the one that user sees. - ;; This is why even face is used when dif-num is odd. - (ediff-get-symbol-from-alist - buf-type (if (ediff-odd-p dif-num) - ediff-even-diff-face-alist - ediff-odd-diff-face-alist) - )) - - -;; activate faces on diff regions in buffer -(defun ediff-paint-background-regions-in-one-buffer (buf-type unhighlight) - (let ((diff-vector - (eval (ediff-get-symbol-from-alist - buf-type ediff-difference-vector-alist))) - overl diff-num) - (mapcar (function - (lambda (rec) - (setq overl (ediff-get-diff-overlay-from-diff-record rec) - diff-num (ediff-overlay-get overl 'ediff-diff-num)) - (if (ediff-overlay-buffer overl) - ;; only if overlay is alive - (ediff-set-overlay-face - overl - (if (not unhighlight) - (ediff-background-face buf-type diff-num)))) - )) - diff-vector))) - - -;; activate faces on diff regions in all buffers -(defun ediff-paint-background-regions (&optional unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'A unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'B unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'C unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'Ancestor unhighlight)) - -(defun ediff-highlight-diff-in-one-buffer (n buf-type) - (if (ediff-buffer-live-p (ediff-get-buffer buf-type)) - (let* ((buff (ediff-get-buffer buf-type)) - (last (ediff-with-current-buffer buff (point-max))) - (begin (ediff-get-diff-posn buf-type 'beg n)) - (end (ediff-get-diff-posn buf-type 'end n)) - (xtra (if (equal begin end) 1 0)) - (end-hilit (min last (+ end xtra))) - (current-diff-overlay - (symbol-value - (ediff-get-symbol-from-alist - buf-type ediff-current-diff-overlay-alist)))) - - (if ediff-xemacs-p - (ediff-move-overlay current-diff-overlay begin end-hilit) - (ediff-move-overlay current-diff-overlay begin end-hilit buff)) - (ediff-overlay-put current-diff-overlay 'priority - (ediff-highest-priority begin end-hilit buff)) - (ediff-overlay-put current-diff-overlay 'ediff-diff-num n) - - ;; unhighlight the background overlay for diff n so it won't - ;; interfere with the current diff overlay - (ediff-set-overlay-face (ediff-get-diff-overlay n buf-type) nil) - ))) - - -(defun ediff-unhighlight-diff-in-one-buffer (buf-type) - (if (ediff-buffer-live-p (ediff-get-buffer buf-type)) - (let ((current-diff-overlay - (symbol-value - (ediff-get-symbol-from-alist - buf-type ediff-current-diff-overlay-alist))) - (overlay - (ediff-get-diff-overlay ediff-current-difference buf-type)) - ) - - (ediff-move-overlay current-diff-overlay 1 1) - - ;; rehighlight the overlay in the background of the - ;; current difference region - (ediff-set-overlay-face - overlay - (if (and (ediff-has-face-support-p) - ediff-use-faces ediff-highlight-all-diffs) - (ediff-background-face buf-type ediff-current-difference))) - ))) - -(defun ediff-unhighlight-diffs-totally-in-one-buffer (buf-type) - (ediff-unselect-and-select-difference -1) - (if (and (ediff-has-face-support-p) ediff-use-faces) - (let* ((inhibit-quit t) - (current-diff-overlay-var - (ediff-get-symbol-from-alist - buf-type ediff-current-diff-overlay-alist)) - (current-diff-overlay (symbol-value current-diff-overlay-var))) - (ediff-paint-background-regions 'unhighlight) - (if (ediff-overlayp current-diff-overlay) - (ediff-delete-overlay current-diff-overlay)) - (set current-diff-overlay-var nil) - ))) - - -(defsubst ediff-highlight-diff (n) - "Put face on diff N. Invoked for X displays only." - (ediff-highlight-diff-in-one-buffer n 'A) - (ediff-highlight-diff-in-one-buffer n 'B) - (ediff-highlight-diff-in-one-buffer n 'C) - (ediff-highlight-diff-in-one-buffer n 'Ancestor) - ) - - -(defsubst ediff-unhighlight-diff () - "Remove overlays from buffers A, B, and C." - (ediff-unhighlight-diff-in-one-buffer 'A) - (ediff-unhighlight-diff-in-one-buffer 'B) - (ediff-unhighlight-diff-in-one-buffer 'C) - (ediff-unhighlight-diff-in-one-buffer 'Ancestor) - ) - -;; delete highlighting overlays, restore faces to their original form -(defsubst ediff-unhighlight-diffs-totally () - (ediff-unhighlight-diffs-totally-in-one-buffer 'A) - (ediff-unhighlight-diffs-totally-in-one-buffer 'B) - (ediff-unhighlight-diffs-totally-in-one-buffer 'C) - (ediff-unhighlight-diffs-totally-in-one-buffer 'Ancestor) - ) - - -;; arg is a record for a given diff in a difference vector -;; this record is itself a vector -(defsubst ediff-clear-fine-diff-vector (diff-record) - (if diff-record - (mapcar 'ediff-delete-overlay - (ediff-get-fine-diff-vector-from-diff-record diff-record)))) - -(defsubst ediff-clear-fine-differences-in-one-buffer (n buf-type) - (ediff-clear-fine-diff-vector (ediff-get-difference n buf-type)) - (ediff-set-fine-diff-vector n buf-type nil)) - -(defsubst ediff-clear-fine-differences (n) - (ediff-clear-fine-differences-in-one-buffer n 'A) - (ediff-clear-fine-differences-in-one-buffer n 'B) - (if ediff-3way-job - (ediff-clear-fine-differences-in-one-buffer n 'C))) - - -(defsubst ediff-convert-fine-diffs-to-overlays (diff-list region-num) - (ediff-set-fine-overlays-in-one-buffer 'A diff-list region-num) - (ediff-set-fine-overlays-in-one-buffer 'B diff-list region-num) - (if ediff-3way-job - (ediff-set-fine-overlays-in-one-buffer 'C diff-list region-num) - )) - -(defsubst ediff-mouse-event-p (event) - (if ediff-xemacs-p - (button-event-p event) - (string-match "mouse" (format "%S" (event-basic-type event))) - )) - - -(defsubst ediff-key-press-event-p (event) - (if ediff-xemacs-p - (key-press-event-p event) - (or (char-or-string-p event) (symbolp event)))) - -(defun ediff-event-point (event) - (cond ((ediff-mouse-event-p event) - (if ediff-xemacs-p - (event-point event) - (posn-point (event-start event)))) - ((ediff-key-press-event-p event) - (point)) - (t (error)))) - -(defun ediff-event-buffer (event) - (cond ((ediff-mouse-event-p event) - (if ediff-xemacs-p - (event-buffer event) - (window-buffer (posn-window (event-start event))))) - ((ediff-key-press-event-p event) - (current-buffer)) - (t (error)))) - - -(defsubst ediff-frame-iconified-p (frame) - (if (and (ediff-window-display-p) (frame-live-p frame)) - (if ediff-xemacs-p - (frame-iconified-p frame) - (eq (frame-visible-p frame) 'icon)))) - -(defsubst ediff-window-visible-p (wind) - ;; under TTY, window-live-p also means window is visible - (and (window-live-p wind) - (or (not (ediff-window-display-p)) - (frame-visible-p (window-frame wind))))) - - -(defsubst ediff-frame-char-width (frame) - (if ediff-xemacs-p - (/ (frame-pixel-width frame) (frame-width frame)) - (frame-char-width frame))) - -(defun ediff-reset-mouse (&optional frame do-not-grab-mouse) - (or frame (setq frame (selected-frame))) - (if (ediff-window-display-p) - (let ((frame-or-wind frame)) - (if ediff-xemacs-p - (setq frame-or-wind (frame-selected-window frame))) - (or do-not-grab-mouse - ;; don't set mouse if the user said to never do this - (not ediff-grab-mouse) - ;; Don't grab on quit, if the user doesn't want to. - ;; If ediff-grab-mouse = t, then mouse won't be grabbed for - ;; sessions that are not part of a group (this is done in - ;; ediff-recenter). The condition below affects only terminating - ;; sessions in session groups (in which case mouse is warped into - ;; a meta buffer). - (and (eq ediff-grab-mouse 'maybe) - (memq this-command '(ediff-quit ediff-update-diffs))) - (set-mouse-position frame-or-wind 1 0)) - ))) - -(defsubst ediff-spy-after-mouse () - (setq ediff-mouse-pixel-position (mouse-pixel-position))) - -;; It is not easy to find out when the user grabs the mouse, since emacs and -;; xemacs behave differently when mouse is not in any frame. Also, this is -;; sensitive to when the user grabbed mouse. Not used for now. -(defun ediff-user-grabbed-mouse () - (if ediff-mouse-pixel-position - (cond ((not (eq (car ediff-mouse-pixel-position) - (car (mouse-pixel-position))))) - ((and (car (cdr ediff-mouse-pixel-position)) - (car (cdr (mouse-pixel-position))) - (cdr (cdr ediff-mouse-pixel-position)) - (cdr (cdr (mouse-pixel-position)))) - (not (and (< (abs (- (car (cdr ediff-mouse-pixel-position)) - (car (cdr (mouse-pixel-position))))) - ediff-mouse-pixel-threshold) - (< (abs (- (cdr (cdr ediff-mouse-pixel-position)) - (cdr (cdr (mouse-pixel-position))))) - ediff-mouse-pixel-threshold)))) - (t nil)))) - -(defsubst ediff-frame-char-height (frame) - (if ediff-xemacs-p - (glyph-height ediff-H-glyph (selected-window frame)) - (frame-char-height frame))) - -;; Some overlay functions - -(defsubst ediff-overlay-start (overl) - (if (ediff-overlayp overl) - (if ediff-emacs-p - (overlay-start overl) - (extent-start-position overl)))) - -(defsubst ediff-overlay-end (overl) - (if (ediff-overlayp overl) - (if ediff-emacs-p - (overlay-end overl) - (extent-end-position overl)))) - -(defsubst ediff-empty-overlay-p (overl) - (= (ediff-overlay-start overl) (ediff-overlay-end overl))) - -;; like overlay-buffer in Emacs. In XEmacs, returns nil if the extent is -;; dead. Otherwise, works like extent-buffer -(defun ediff-overlay-buffer (overl) - (if ediff-emacs-p - (overlay-buffer overl) - (and (extent-live-p overl) (extent-object overl)))) - -;; like overlay-get in Emacs. In XEmacs, returns nil if the extent is -;; dead. Otherwise, like extent-property -(defun ediff-overlay-get (overl property) - (if ediff-emacs-p - (overlay-get overl property) - (and (extent-live-p overl) (extent-property overl property)))) - - -;; These two functions are here because XEmacs refuses to -;; handle overlays whose buffers were deleted. -(defun ediff-move-overlay (overlay beg end &optional buffer) - "Calls `move-overlay' in Emacs and `set-extent-endpoints' in Lemacs. -Checks if overlay's buffer exists before actually doing the move." - (let ((buf (and overlay (ediff-overlay-buffer overlay)))) - (if (ediff-buffer-live-p buf) - (if ediff-xemacs-p - (set-extent-endpoints overlay beg end) - (move-overlay overlay beg end buffer)) - ;; buffer's dead - (if overlay - (ediff-delete-overlay overlay))))) - -(defun ediff-overlay-put (overlay prop value) - "Calls `overlay-put' or `set-extent-property' depending on Emacs version. -Checks if overlay's buffer exists." - (if (ediff-buffer-live-p (ediff-overlay-buffer overlay)) - (if ediff-xemacs-p - (set-extent-property overlay prop value) - (overlay-put overlay prop value)) - (ediff-delete-overlay overlay))) - -;; Some diff region tests - -;; t if diff region is empty. -;; In case of buffer C, t also if it is not a 3way -;; comparison job (merging jobs return t as well). -(defun ediff-empty-diff-region-p (n buf-type) - (if (eq buf-type 'C) - (or (not ediff-3way-comparison-job) - (= (ediff-get-diff-posn 'C 'beg n) - (ediff-get-diff-posn 'C 'end n))) - (= (ediff-get-diff-posn buf-type 'beg n) - (ediff-get-diff-posn buf-type 'end n)))) - -;; Test if diff region is white space only. -;; If 2-way job and buf-type = C, then returns t. -(defun ediff-whitespace-diff-region-p (n buf-type) - (or (and (eq buf-type 'C) (not ediff-3way-job)) - (ediff-empty-diff-region-p n buf-type) - (let ((beg (ediff-get-diff-posn buf-type 'beg n)) - (end (ediff-get-diff-posn buf-type 'end n))) - (ediff-with-current-buffer (ediff-get-buffer buf-type) - (save-excursion - (goto-char beg) - (skip-chars-forward ediff-whitespace) - (>= (point) end)))))) - -;; temporarily uses DIR to abbreviate file name -;; if DIR is nil, use default-directory -(defun ediff-abbreviate-file-name (file &optional dir) - (cond ((stringp dir) - (let ((directory-abbrev-alist (list (cons dir "")))) - (abbreviate-file-name file))) - (ediff-emacs-p (abbreviate-file-name file)) - (t ; XEmacs requires addl argument - (abbreviate-file-name file t)))) - -;; Takes a directory and returns the parent directory. -;; does nothing to `/'. If the ARG is a regular file, -;; strip the file AND the last dir. -(defun ediff-strip-last-dir (dir) - (if (not (stringp dir)) (setq dir default-directory)) - (setq dir (expand-file-name dir)) - (or (file-directory-p dir) (setq dir (file-name-directory dir))) - (let* ((pos (1- (length dir))) - (last-char (aref dir pos))) - (if (and (> pos 0) (= last-char ?/)) - (setq dir (substring dir 0 pos))) - (ediff-abbreviate-file-name (file-name-directory dir)))) - -(defun ediff-truncate-string-left (str newlen) - ;; leave space for ... on the left - (let ((len (length str)) - substr) - (if (<= len newlen) - str - (setq newlen (max 0 (- newlen 3))) - (setq substr (substring str (max 0 (- len 1 newlen)))) - (concat "..." substr)))) - -(defun ediff-abbrev-jobname (jobname) - (cond ((eq jobname 'ediff-directories) - "Compare two directories") - ((eq jobname 'ediff-files) - "Compare two files") - ((eq jobname 'ediff-buffers) - "Compare two buffers") - ((eq jobname 'ediff-directories3) - "Compare three directories") - ((eq jobname 'ediff-files3) - "Compare three files") - ((eq jobname 'ediff-buffers3) - "Compare three buffers") - ((eq jobname 'ediff-revision) - "Compare file with a version") - ((eq jobname 'ediff-directory-revisions) - "Compare dir files with versions") - ((eq jobname 'ediff-merge-directory-revisions) - "Merge dir files with versions") - ((eq jobname 'ediff-merge-directory-revisions-with-ancestor) - "Merge dir versions via ancestors") - (t - (let* ((str (substring (symbol-name jobname) 6)) - (len (length str)) - (pos 0)) - (while (< pos len) - (if (= pos 0) - (aset str pos (upcase (aref str pos)))) - (if (= (aref str pos) ?-) - (aset str pos ?\ )) - (setq pos (1+ pos))) - str)))) - - - -(defsubst ediff-get-region-contents (n buf-type ctrl-buf &optional start end) - (ediff-with-current-buffer - (ediff-with-current-buffer ctrl-buf (ediff-get-buffer buf-type)) - (buffer-substring - (or start (ediff-get-diff-posn buf-type 'beg n ctrl-buf)) - (or end (ediff-get-diff-posn buf-type 'end n ctrl-buf))))) - -;; If ediff modified mode line, strip the modification -(defsubst ediff-strip-mode-line-format () - (if (member (car mode-line-format) '(" A: " " B: " " C: " " Ancestor: ")) - (setq mode-line-format (nth 2 mode-line-format)))) - -;; Verify that we have a difference selected. -(defsubst ediff-valid-difference-p (&optional n) - (or n (setq n ediff-current-difference)) - (and (>= n 0) (< n ediff-number-of-differences))) - -(defsubst ediff-show-all-diffs (n) - "Don't skip difference regions." - nil) - -(defsubst Xor (a b) - (or (and a (not b)) (and (not a) b))) - -(defsubst ediff-message-if-verbose (string &rest args) - (if ediff-verbose-p - (apply 'message string args))) - -(defun ediff-file-attributes (filename attr-number) - (if (ediff-file-remote-p filename) - -1 - (nth attr-number (file-attributes filename)))) - -(defsubst ediff-file-size (filename) - (ediff-file-attributes filename 7)) -(defsubst ediff-file-modtime (filename) - (ediff-file-attributes filename 5)) - - -(defun ediff-convert-standard-filename (fname) - (if (fboundp 'convert-standard-filename) - (convert-standard-filename fname) - fname)) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -(provide 'ediff-init) - - -;;; ediff-init.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-merg.el --- a/lisp/ediff/ediff-merg.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,313 +0,0 @@ -;;; ediff-merg.el --- merging utilities - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-merg) - -(defgroup ediff-merge nil - "Merging utilities" - :prefix "ediff-" - :group 'ediff) - - -;; compiler pacifier -(defvar ediff-window-A) -(defvar ediff-window-B) -(defvar ediff-window-C) -(defvar ediff-merge-window-share) -(defvar ediff-window-config-saved) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defcustom ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge - "*Hooks to run before quitting a merge job. -The most common use is to save and delete the merge buffer." - :type 'hook - :group 'ediff-merge) - - -(defcustom ediff-default-variant 'combined - "*The variant to be used as a default for buffer C in merging. -Valid values are the symbols `default-A', `default-B', and `combined'." - :type '(radio (const default-A) (const default-B) (const combined)) - :group 'ediff-merge) - -(defcustom ediff-combination-pattern - '("<<<<<<<<<<<<<< variant A" ">>>>>>>>>>>>>> variant B" "======= end of combination") - "*Pattern to be used for combining difference regions in buffers A and B. -The value is (STRING1 STRING2 STRING3). The combined text will look like this: - -STRING1 -diff region from variant A -STRING2 -diff region from variant B -STRING3 -" - :type '(list string string string) - :group 'ediff-merge) - -(ediff-defvar-local ediff-show-clashes-only nil - "*If t, show only those diff regions where both buffers disagree with the ancestor. -This means that regions that have status prefer-A or prefer-B will be -skiped over. Nil means show all regions.") - -;; If ediff-show-clashes-only, check if there is no clash between the ancestor -;; and one of the variants. -(defsubst ediff-merge-region-is-non-clash (n) - (and ediff-show-clashes-only - (string-match "prefer" (or (ediff-get-state-of-merge n) "")))) - - -(defsubst ediff-get-combined-region (n) - (concat (nth 0 ediff-combination-pattern) "\n" - (ediff-get-region-contents n 'A ediff-control-buffer) - (nth 1 ediff-combination-pattern) "\n" - (ediff-get-region-contents n 'B ediff-control-buffer) - (nth 2 ediff-combination-pattern) "\n")) - -(defsubst ediff-make-combined-diff (regA regB) - (concat (nth 0 ediff-combination-pattern) "\n" - regA - (nth 1 ediff-combination-pattern) "\n" - regB - (nth 2 ediff-combination-pattern) "\n")) - -(defsubst ediff-set-state-of-all-diffs-in-all-buffers (ctl-buf) - (let ((n 0)) - (while (< n ediff-number-of-differences) - (ediff-set-state-of-diff-in-all-buffers n ctl-buf) - (setq n (1+ n))))) - -(defun ediff-set-state-of-diff-in-all-buffers (n ctl-buf) - (let ((regA (ediff-get-region-contents n 'A ctl-buf)) - (regB (ediff-get-region-contents n 'B ctl-buf)) - (regC (ediff-get-region-contents n 'C ctl-buf))) - (cond ((and (string= regA regB) (string= regA regC)) - (ediff-set-state-of-diff n 'A "=diff(B)") - (ediff-set-state-of-diff n 'B "=diff(C)") - (ediff-set-state-of-diff n 'C "=diff(A)")) - ((string= regA regB) - (ediff-set-state-of-diff n 'A "=diff(B)") - (ediff-set-state-of-diff n 'B "=diff(A)") - (ediff-set-state-of-diff n 'C nil)) - ((string= regA regC) - (ediff-set-state-of-diff n 'A "=diff(C)") - (ediff-set-state-of-diff n 'C "=diff(A)") - (ediff-set-state-of-diff n 'B nil)) - ((string= regB regC) - (ediff-set-state-of-diff n 'C "=diff(B)") - (ediff-set-state-of-diff n 'B "=diff(C)") - (ediff-set-state-of-diff n 'A nil)) - ((string= regC (ediff-get-combined-region n)) - (ediff-set-state-of-diff n 'A nil) - (ediff-set-state-of-diff n 'B nil) - (ediff-set-state-of-diff n 'C "=diff(A+B)")) - (t (ediff-set-state-of-diff n 'A nil) - (ediff-set-state-of-diff n 'B nil) - (ediff-set-state-of-diff n 'C nil))) - )) - -(defun ediff-set-merge-mode () - ;; by Stig@hackvan.com - (normal-mode t) - (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode)) - - -;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C -;; according to the state of the difference. -;; Since ediff-copy-diff refuses to copy identical diff regions, there is -;; no need to optimize ediff-do-merge any further. -;; -;; If re-merging, change state of merge in all diffs starting with -;; DIFF-NUM, except those where the state is prefer-* or where it is -;; `default-*' or `combined' but the buf C region appears to be modified -;; since last set by default. -(defun ediff-do-merge (diff-num &optional remerging) - (if (< diff-num 0) (setq diff-num 0)) - (let ((n diff-num) - ;;(default-state-of-merge (format "%S" ediff-default-variant)) - do-not-copy state-of-merge) - (while (< n ediff-number-of-differences) - (setq do-not-copy nil) ; reset after each cycle - (if (= (mod n 10) 0) - (message "%s buffers A & B into C ... region %d of %d" - (if remerging "Re-merging" "Merging") - n - ediff-number-of-differences)) - - (setq state-of-merge (ediff-get-state-of-merge n)) - - (if remerging - (let ((reg-A (ediff-get-region-contents n 'A ediff-control-buffer)) - (reg-B (ediff-get-region-contents n 'B ediff-control-buffer)) - (reg-C (ediff-get-region-contents n 'C ediff-control-buffer))) - - ;; if region was edited since it was first set by default - (if (or (and (string= state-of-merge "default-A") - (not (string= reg-A reg-C))) - ;; was edited since first set by default - (and (string= state-of-merge "default-B") - (not (string= reg-B reg-C))) - ;; was edited since first set by default - (and (string= state-of-merge "combined") - (not (string= - (ediff-make-combined-diff reg-A reg-B) reg-C))) - ;; was preferred--ignore - (string-match "prefer" state-of-merge)) - (setq do-not-copy t)) - - ;; change state of merge for this diff, if necessary - (if (and (string-match "\\(default\\|combined\\)" state-of-merge) - (not do-not-copy)) - (ediff-set-state-of-merge - n (format "%S" ediff-default-variant))) - )) - - ;; state-of-merge may have changed via ediff-set-state-of-merge, so - ;; check it once again - (setq state-of-merge (ediff-get-state-of-merge n)) - - (or do-not-copy - (if (string= state-of-merge "combined") - ;; use n+1 because ediff-combine-diffs works via user numbering - ;; of diffs, which is 1+ to what ediff uses internally - (ediff-combine-diffs (1+ n) 'batch) - (ediff-copy-diff - n (if (string-match "-A" state-of-merge) 'A 'B) 'C 'batch))) - (setq n (1+ n))) - (message "Merging buffers A & B into C ... Done") - )) - - -(defun ediff-re-merge () - "Remerge unmodified diff regions using a new default. Start with the current region." - (interactive) - (let* ((default-variant-alist - (list '("default-A") '("default-B") '("combined"))) - (actual-alist - (delete (list (symbol-name ediff-default-variant)) - default-variant-alist))) - (setq ediff-default-variant - (intern - (completing-read - (format "Current merge default is `%S'. New default: " - ediff-default-variant) - actual-alist nil 'must-match))) - (ediff-do-merge ediff-current-difference 'remerge) - (ediff-recenter) - )) - -(defun ediff-shrink-window-C (arg) - "Shrink window C to just one line. -With a prefix argument, returns window C to its normal size. -Used only for merging jobs." - (interactive "P") - (if (not ediff-merge-job) - (error "ediff-shrink-window-C can be used only for merging jobs")) - (cond ((eq arg '-) (setq arg -1)) - ((not (numberp arg)) (setq arg nil))) - (cond ((null arg) - (let ((ediff-merge-window-share - (if (< (window-height ediff-window-C) 3) - ediff-merge-window-share 0))) - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight))) - ((and (< arg 0) (> (window-height ediff-window-C) 2)) - (setq ediff-merge-window-share (* ediff-merge-window-share 0.9)) - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight)) - ((and (> arg 0) (> (window-height ediff-window-A) 2)) - (setq ediff-merge-window-share (* ediff-merge-window-share 1.1)) - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight)))) - - -;; N here is the user's region number. It is 1+ what Ediff uses internally. -(defun ediff-combine-diffs (n &optional batch-invocation) - "Combine Nth diff regions of buffers A and B and place the combination in C. -N is a prefix argument. If nil, combine the current difference regions. -Combining is done according to the specifications in variable -`ediff-combination-pattern'." - (interactive "P") - (setq n (if (numberp n) (1- n) ediff-current-difference)) - - (let (regA regB reg-combined) - (setq regA (ediff-get-region-contents n 'A ediff-control-buffer) - regB (ediff-get-region-contents n 'B ediff-control-buffer)) - - (setq reg-combined (ediff-make-combined-diff regA regB)) - - (ediff-copy-diff n nil 'C batch-invocation reg-combined)) - (or batch-invocation (ediff-jump-to-difference (1+ n)))) - - -;; Checks if the region in buff C looks like a combination of the regions -;; in buffers A and B. Returns a list (reg-a-beg reg-a-end reg-b-beg reg-b-end) -;; These refer to where the copies of region A and B start and end in buffer C -(defun ediff-looks-like-combined-merge (region-num) - (if ediff-merge-job - (let ((combined (string-match (regexp-quote "(A+B)") - (or (ediff-get-state-of-diff region-num 'C) - ""))) - (reg-beg (ediff-get-diff-posn 'C 'beg region-num)) - (reg-end (ediff-get-diff-posn 'C 'end region-num)) - (pat1 (nth 0 ediff-combination-pattern)) - (pat2 (nth 1 ediff-combination-pattern)) - (pat3 (nth 2 ediff-combination-pattern)) - reg-a-beg reg-a-end reg-b-beg reg-b-end reg-c-beg reg-c-end) - - (if combined - (ediff-with-current-buffer ediff-buffer-C - (goto-char reg-beg) - (search-forward pat1 reg-end 'noerror) - (setq reg-a-beg (match-beginning 0)) - (setq reg-a-end (match-end 0)) - (search-forward pat2 reg-end 'noerror) - (setq reg-b-beg (match-beginning 0)) - (setq reg-b-end (match-end 0)) - (search-forward pat3 reg-end 'noerror) - (setq reg-c-beg (match-beginning 0)) - (setq reg-c-end (match-end 0)))) - - (if (and reg-a-beg reg-a-end reg-b-beg reg-b-end) - (list reg-a-beg reg-a-end reg-b-beg reg-b-end reg-c-beg reg-c-end)) - ))) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;; ediff-merg.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-mult.el --- a/lisp/ediff/ediff-mult.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1777 +0,0 @@ -;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff - -;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Users are encouraged to add functionality to this file. -;; The present file contains all the infrastructure needed for that. -;; -;; Generally, to to implement a new multisession capability within Ediff, -;; you need to tell it -;; -;; 1. How to display the session group buffer. -;; This function must indicate which Ediff sessions are active (+) and -;; which are finished (-). -;; See ediff-redraw-directory-group-buffer for an example. -;; In all likelihood, ediff-redraw-directory-group-buffer can be used -;; directly or after a small modification. -;; 2. What action to take when the user clicks button 2 or types v,e, or -;; RET. See ediff-filegroup-action. -;; 3. Provide a list of pairs or triples of file names (or buffers, -;; depending on the particular Ediff operation you want to invoke) -;; in the following format: -;; (descriptor (obj1 obj2 obj3) (...) ...) -;; Actually, the format of this list is pretty much up to the -;; developer. The only thing is that it must be a list of lists, -;; and the first list must describe the meta session, and subsequent -;; elements must describe individual sessions. -;; This descriptor must be a list of two, three, or four elements (nil -;; or string). The function ediff-redraw-registry-buffer displays the -;; second through last of these in the registry buffer. -;; Also, keep in mind that the function ediff-prepare-meta-buffer -;; (which see) prepends the session group buffer to the descriptor and -;; nil in front of each subsequent list (i.e., the above list -;; will become -;; ((meta-buf descriptor) (nil obj1 obj2 obj3) (nil ...) ...) -;; Ediff expects that your function (in 2 above) will arrange to -;; replace this prepended nil (via setcar) with the actual ediff -;; control buffer associated with an appropriate Ediff session. -;; This is arranged through internal startup hooks that can be passed -;; to any of Ediff major entries (such as ediff-files, epatch, etc.). -;; See how this is done in ediff-filegroup-action. -;; -;; Session descriptions are of the form (obj1 obj2 obj3), which -;; describe objects relevant to the session. Usually they are names of -;; files, but sometimes they may be other things. For instance, obj3 is -;; nil for jobs that involve only two files. For patch jobs, obj2 and -;; obj3 are markers that specify the patch corresponding to the file -;; (whose name is obj1). -;; 4. Write a function that makes a call to ediff-prepare-meta-buffer -;; passing all this info. -;; You may be able to use ediff-directories-internal as a template. -;; 5. If you intend to add several related pieces of functionality, -;; you may want to keep the function in 4 as an internal version -;; and then write several top-level interactive functions that call it -;; with different parameters. -;; See how ediff-directories, ediff-merge-directories, and -;; ediff-merge-directories-with-ancestor all use -;; ediff-directories-internal. -;; -;; A useful addition here could be session groups selected by patterns -;; (which are different in each directory). For instance, one may want to -;; compare files of the form abc{something}.c to files old{something}.d -;; which may be in the same or different directories. Or, one may want to -;; compare all files of the form {something} to files of the form {something}~. -;; -;; Implementing this requires writing an collating function, which should pair -;; up appropriate files. It will also require a generalization of the functions -;; that do the layout of the meta- and differences buffers and of -;; ediff-filegroup-action. - -;;; Code: - -(provide 'ediff-mult) - -(defgroup ediff-mult nil - "Multi-file and multi-buffer processing in Ediff" - :prefix "ediff-" - :group 'ediff) - - -;; compiler pacifier -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) -(require 'ediff-util) - -;; meta-buffer -(ediff-defvar-local ediff-meta-buffer nil "") -(ediff-defvar-local ediff-parent-meta-buffer nil "") -;; the registry buffer -(defvar ediff-registry-buffer nil) - -(defconst ediff-meta-buffer-message "This is an Ediff Session Group Panel: %s - -Useful commands: - button2, `v', RET over a session line: start that Ediff session - `M':\tin any session invoked from here, brings back this group panel - `R':\tdisplay the registry of active Ediff sessions - `h':\tmark session for hiding (toggle) - `x':\thide marked sessions; with prefix arg--unhide hidden sessions - `m':\tmark session for a non-hiding operation (toggle) - SPC:\tnext session - DEL:\tprevious session - `E':\tbrowse Ediff on-line manual - `q':\tquit this session group -") - -(ediff-defvar-local ediff-meta-buffer-map nil - "The keymap for the meta buffer.") -(defvar ediff-dir-diffs-buffer-map (make-sparse-keymap) - "The keymap to be installed in the buffer showing differences between -directories.") - -;; Variable specifying the action to take when the use invokes ediff in the -;; meta buffer. This is usually ediff-registry-action or ediff-filegroup-action -(ediff-defvar-local ediff-meta-action-function nil "") -;; Tells ediff-update-meta-buffer how to redraw it -(ediff-defvar-local ediff-meta-redraw-function nil "") -;; Tells ediff-filegroup-action and similar procedures how to invoke Ediff for -;; the sessions in a given session group -(ediff-defvar-local ediff-session-action-function nil "") - -(ediff-defvar-local ediff-metajob-name nil "") - -;; buffer used to collect custom diffs from individual sessions in the group -(ediff-defvar-local ediff-meta-diff-buffer nil "") - -;; history var to use for filtering groups -(defvar ediff-filtering-regexp-history nil "") - -;; This has the form ((meta-buf regexp dir1 dir2 dir3 merge-auto-store-dir) -;; (ctl-buf session-status (file1 . eq-status) (file2 . eq-status) (file3 -;; . eq-status)) (ctl-buf session-status (file1 . eq-status) (file2 -;; . eq-status)) ...) -;; If ctl-buf is nil, the file-pair hasn't processed yet. If it is -;; killed-buffer object, the file pair has been processed. If it is a live -;; buffer, this means ediff is still working on the pair. -;; Eq-status of a file is t if the file equals some other file in the same -;; group. -(ediff-defvar-local ediff-meta-list nil "") - - -;; the difference list between directories in a directory session group -(ediff-defvar-local ediff-dir-difference-list nil "") -(ediff-defvar-local ediff-dir-diffs-buffer nil "") - -;; The registry of Ediff sessions. A list of control buffers. -(defvar ediff-session-registry nil) - -(defcustom ediff-registry-setup-hook nil - "*Hooks run just after the registry control panel is set up." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-session-group-setup-hook nil - "*Hooks run just after a meta-buffer controlling a session group, such as -ediff-directories, is run." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-quit-session-group-hook nil - "*Hooks run just before exiting a session group." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-show-registry-hook nil - "*Hooks run just after the registry buffer is shown." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-show-session-group-hook nil - "*Hooks run just after a session group buffer is shown." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-meta-buffer-keymap-setup-hook nil - "*Hooks run just after setting up the ediff-meta-buffer-map. -This keymap controls key bindings in the meta buffer and is a local variable. -This means that you can set different bindings for different kinds of meta -buffers." - :type 'hook - :group 'ediff-mult) - -;; buffer holding the multi-file patch. local to the meta buffer -(ediff-defvar-local ediff-meta-patchbufer nil "") - -;;; API for ediff-meta-list - -;; group buffer/regexp -(defsubst ediff-get-group-buffer (meta-list) - (nth 0 (car meta-list))) - -(defsubst ediff-get-group-regexp (meta-list) - (nth 1 (car meta-list))) -;; group objects -(defsubst ediff-get-group-objA (meta-list) - (nth 2 (car meta-list))) -(defsubst ediff-get-group-objB (meta-list) - (nth 3 (car meta-list))) -(defsubst ediff-get-group-objC (meta-list) - (nth 4 (car meta-list))) -(defsubst ediff-get-group-merge-autostore-dir (meta-list) - (nth 5 (car meta-list))) - -;; session buffer -(defsubst ediff-get-session-buffer (elt) - (nth 0 elt)) -(defsubst ediff-get-session-status (elt) - (nth 1 elt)) -(defsubst ediff-set-session-status (session-info new-status) - (setcar (cdr session-info) new-status)) -;; session objects -(defsubst ediff-get-session-objA (elt) - (nth 2 elt)) -(defsubst ediff-get-session-objB (elt) - (nth 3 elt)) -(defsubst ediff-get-session-objC (elt) - (nth 4 elt)) -(defsubst ediff-get-session-objA-name (elt) - (car (nth 2 elt))) -(defsubst ediff-get-session-objB-name (elt) - (car (nth 3 elt))) -(defsubst ediff-get-session-objC-name (elt) - (car (nth 4 elt))) -;; equality indicators -(defsubst ediff-get-file-eqstatus (elt) - (nth 1 elt)) -(defsubst ediff-set-file-eqstatus (elt value) - (setcar (cdr elt) value)) - -;; checks if the session is a meta session -(defun ediff-meta-session-p (session-info) - (and (stringp (ediff-get-session-objA-name session-info)) - (file-directory-p (ediff-get-session-objA-name session-info)) - (stringp (ediff-get-session-objB-name session-info)) - (file-directory-p (ediff-get-session-objB-name session-info)) - (if (stringp (ediff-get-session-objC-name session-info)) - (file-directory-p (ediff-get-session-objC-name session-info)) t))) - -;; set up the keymap in the meta buffer -(defun ediff-setup-meta-map() - (setq ediff-meta-buffer-map (make-sparse-keymap)) - (suppress-keymap ediff-meta-buffer-map) - (define-key ediff-meta-buffer-map "q" 'ediff-quit-meta-buffer) - (define-key ediff-meta-buffer-map "R" 'ediff-show-registry) - (define-key ediff-meta-buffer-map "E" 'ediff-documentation) - (define-key ediff-meta-buffer-map "v" ediff-meta-action-function) - (define-key ediff-meta-buffer-map "\C-m" ediff-meta-action-function) - (define-key ediff-meta-buffer-map " " 'ediff-next-meta-item) - (define-key ediff-meta-buffer-map "\C-?" 'ediff-previous-meta-item) - (define-key ediff-meta-buffer-map [delete] 'ediff-previous-meta-item) - (define-key ediff-meta-buffer-map [backspace] 'ediff-previous-meta-item) - (or (ediff-one-filegroup-metajob) - (define-key ediff-meta-buffer-map "=" 'ediff-meta-mark-equal-files)) - (if ediff-no-emacs-help-in-control-buffer - (define-key ediff-meta-buffer-map "\C-h" 'ediff-previous-meta-item)) - (if ediff-emacs-p - (define-key ediff-meta-buffer-map [mouse-2] ediff-meta-action-function) - (define-key ediff-meta-buffer-map [button2] ediff-meta-action-function)) - - (use-local-map ediff-meta-buffer-map) - ;; modify ediff-meta-buffer-map here - (run-hooks 'ediff-meta-buffer-keymap-setup-hook)) - -(defun ediff-meta-mode () - "This mode controls all operations on Ediff session groups. -It is entered through one of the following commands: - `ediff-directories' - `edirs' - `ediff-directories3' - `edirs3' - `ediff-merge-directories' - `edirs-merge' - `ediff-merge-directories-with-ancestor' - `edirs-merge-with-ancestor' - `ediff-directory-revisions' - `edir-revisions' - `ediff-merge-directory-revisions' - `edir-merge-revisions' - `ediff-merge-directory-revisions-with-ancestor' - `edir-merge-revisions-with-ancestor' - -Commands: -\\{ediff-meta-buffer-map}" - (kill-all-local-variables) - (setq major-mode 'ediff-meta-mode) - (setq mode-name "MetaEdiff")) - - -;; the keymap for the buffer showing directory differences -(suppress-keymap ediff-dir-diffs-buffer-map) -(define-key ediff-dir-diffs-buffer-map "q" 'ediff-bury-dir-diffs-buffer) -(define-key ediff-dir-diffs-buffer-map " " 'next-line) -(define-key ediff-dir-diffs-buffer-map "\C-?" 'previous-line) -(define-key ediff-dir-diffs-buffer-map [delete] 'previous-line) -(define-key ediff-dir-diffs-buffer-map [backspace] 'previous-line) - -(defun ediff-next-meta-item (count) - "Move to the next item in Ediff registry or session group buffer. -Moves in circular fashion. With numeric prefix arg, skip this many items." - (interactive "p") - (or count (setq count 1)) - (while (< 0 count) - (setq count (1- count)) - (ediff-next-meta-item1))) - -;; Move to the next meta item -(defun ediff-next-meta-item1 () - (let (pos) - (setq pos (ediff-next-meta-overlay-start (point))) -;;; ;; skip deleted -;;; (while (memq (ediff-get-session-status -;;; (ediff-get-meta-info (current-buffer) pos 'noerror)) -;;; '(?H ?I)) -;;; (setq pos (ediff-next-meta-overlay-start pos))) - - (if pos (goto-char pos)) - (if (eq ediff-metajob-name 'ediff-registry) - (if (and (ediff-get-meta-info (current-buffer) pos 'noerror) - (search-forward "*Ediff" nil t)) - (skip-chars-backward "a-zA-Z*")) - (if (> (skip-chars-forward "-+?H* \t0-9") 0) - (backward-char 1))))) - - -(defun ediff-previous-meta-item (count) - "Move to the previous item in Ediff registry or session group buffer. -Moves in circular fashion. With numeric prefix arg, skip this many items." - (interactive "p") - (or count (setq count 1)) - (while (< 0 count) - (setq count (1- count)) - (ediff-previous-meta-item1))) - -(defun ediff-previous-meta-item1 () - (let (pos) - (setq pos (ediff-previous-meta-overlay-start (point))) -;;; ;; skip deleted -;;; (while (ediff-get-session-status -;;; (ediff-get-meta-info (current-buffer) pos 'noerror)) -;;; (setq pos (ediff-previous-meta-overlay-start pos))) - - (if pos (goto-char pos)) - (if (eq ediff-metajob-name 'ediff-registry) - (if (and (ediff-get-meta-info (current-buffer) pos 'noerror) - (search-forward "*Ediff" nil t)) - (skip-chars-backward "a-zA-Z*")) - (if (> (skip-chars-forward "-+?H* \t0-9") 0) - (backward-char 1))) - )) - -(defsubst ediff-add-slash-if-directory (dir file) - (if (file-directory-p (concat dir file)) - (file-name-as-directory file) - file)) - - -;; DIR1, DIR2, DIR3 are directories. DIR3 can be nil. -;; OUTPUT-DIR is a directory for auto-storing the results of merge jobs. -;; Can be nil. -;; REGEXP is a regexp used to filter out files in the directories. -;; If a file is a directory in dir1 but not dir2 (or vice versa), it is not -;; included in the intersection. However, a regular file that is a dir in dir3 -;; is included, since dir3 files are supposed to be ancestors for merging. -;; Returns a list of the form: -;; ((dir1 dir2 dir3) (f1 f2 f3) (f1 f2 f3) ...) -;; dir3, f3 can be nil if intersecting only 2 directories. -;; If COMPARISON-FUNC is given, use it. Otherwise, use string= -;; DIFF-VAR contains the name of the variable in which to return the -;; difference list (which represents the differences among the contents of -;; directories). The diff list is of the form: -;; ((dir1 dir2 dir3) (file . num) (file . num)...) -;; where num encodes the set of dirs where the file is found: -;; 2 - only dir1; 3 - only dir2; 5 - only dir3; 6 - dir1&2; 10 - dir1&3; etc. -(defun ediff-intersect-directories (jobname - diff-var regexp dir1 dir2 - &optional - dir3 merge-autostore-dir comparison-func) - (setq comparison-func (or comparison-func 'string=)) - (let (lis1 lis2 lis3 common auxdir1 auxdir2 auxdir3 difflist) - - (setq auxdir1 (file-name-as-directory dir1) - lis1 (directory-files auxdir1 nil regexp) - lis1 (delete "." lis1) - lis1 (delete ".." lis1) - lis1 (mapcar - (function - (lambda (elt) - (ediff-add-slash-if-directory auxdir1 elt))) - lis1) - auxdir2 (file-name-as-directory dir2) - lis2 (mapcar - (function - (lambda (elt) - (ediff-add-slash-if-directory auxdir2 elt))) - (directory-files auxdir2 nil regexp))) - - (if (stringp dir3) - (setq auxdir3 (file-name-as-directory dir3) - lis3 (mapcar - (function - (lambda (elt) - (ediff-add-slash-if-directory auxdir3 elt))) - (directory-files auxdir3 nil regexp)))) - - (if (stringp merge-autostore-dir) - (setq merge-autostore-dir - (file-name-as-directory merge-autostore-dir))) - (setq common (ediff-intersection lis1 lis2 comparison-func)) - - ;; In merge with ancestor jobs, we don't intersect with lis3. - ;; If there is no ancestor, we'll offer to merge without the ancestor. - ;; So, we intersect with lis3 only when we are doing 3-way file comparison - (if (and lis3 (ediff-comparison-metajob3 jobname)) - (setq common (ediff-intersection common lis3 comparison-func))) - - ;; copying is needed because sort sorts via side effects - (setq common (sort (ediff-copy-list common) 'string-lessp)) - - ;; compute difference list - (setq difflist (ediff-set-difference - (ediff-union (ediff-union lis1 lis2 comparison-func) - lis3 - comparison-func) - common - comparison-func) - difflist (delete "." difflist) - ;; copying is needed because sort sorts via side effects - difflist (sort (ediff-copy-list (delete ".." difflist)) - 'string-lessp)) - - (setq difflist (mapcar (function (lambda (elt) (cons elt 1))) difflist)) - - ;; check for files belonging to lis1/2/3 - (mapcar (function (lambda (elt) - (if (member (car elt) lis1) - (setcdr elt (* (cdr elt) 2))) - (if (member (car elt) lis2) - (setcdr elt (* (cdr elt) 3))) - (if (member (car elt) lis3) - (setcdr elt (* (cdr elt) 5))) - )) - difflist) - (setq difflist (cons (list regexp auxdir1 auxdir2 auxdir3) difflist)) - - ;; return the difference list back to the calling function - (set diff-var difflist) - - ;; return result - (cons (list regexp auxdir1 auxdir2 auxdir3 merge-autostore-dir) - (mapcar - (function - (lambda (elt) - (list (concat auxdir1 elt) - (concat auxdir2 elt) - (if lis3 - (progn - ;; The following is done because: - ;; In merging with ancestor, we don't intersect - ;; with lis3. So, it is possible that elt is a - ;; file in auxdir1/2 but a directory in auxdir3 - ;; Or elt may not exist in auxdir3 at all. - ;; In the first case, we add a slash at the end. - ;; In the second case, we insert nil. - (setq elt (ediff-add-slash-if-directory auxdir3 elt)) - (if (file-exists-p (concat auxdir3 elt)) - (concat auxdir3 elt))))))) - common)) - )) - -;; find directory files that are under revision. -;; Include subdirectories, since we may visit them recursively. -;; DIR1 is the directory to inspect. -;; OUTPUT-DIR is the directory where to auto-store the results of merges. Can -;; be nil. -(defun ediff-get-directory-files-under-revision (jobname - regexp dir1 - &optional merge-autostore-dir) - (let (lis1 elt common auxdir1) - (setq auxdir1 (file-name-as-directory dir1) - lis1 (directory-files auxdir1 nil regexp)) - - (if (stringp merge-autostore-dir) - (setq merge-autostore-dir - (file-name-as-directory merge-autostore-dir))) - - (while lis1 - (setq elt (car lis1) - lis1 (cdr lis1)) - ;; take files under revision control - (cond ((file-directory-p (concat auxdir1 elt)) - (setq common (cons elt common))) - ((file-exists-p (concat auxdir1 elt ",v")) - (setq common (cons elt common))) - ((file-exists-p (concat auxdir1 "RCS/" elt ",v")) - (setq common (cons elt common))) - ) ; cond - ) ; while - - (setq common (delete "." common) - common (delete ".." common) - common (delete "RCS" common)) - - ;; copying is needed because sort sorts via side effects - (setq common (sort (ediff-copy-list common) 'string-lessp)) - - ;; return result - (cons (list regexp auxdir1 nil nil merge-autostore-dir) - (mapcar (function (lambda (elt) - (list (concat auxdir1 elt) - nil nil))) - common)) - )) - - -;; If file groups selected by patterns will ever be implemented, this -;; comparison function might become useful. -;;;; uses external variables PAT1 PAT2 to compare str1/2 -;;;; patterns must be of the form ???*???? where ??? are strings of chars -;;;; containing no *. -;;(defun ediff-pattern= (str1 str2) -;; (let (pos11 pos12 pos21 pos22 len1 len2) -;; (setq pos11 0 -;; len (length epat1) -;; pos12 len) -;; (while (and (< pos11 len) (not (= (aref epat1 pos11) ?*))) -;; (setq pos11 (1+ pos11))) -;; (while (and (> pos12 0) (not (= (aref epat1 (1- pos12)) ?*))) -;; (setq pos12 (1- pos12))) -;; -;; (setq pos21 0 -;; len (length epat2) -;; pos22 len) -;; (while (and (< pos21 len) (not (= (aref epat2 pos21) ?*))) -;; (setq pos21 (1+ pos21))) -;; (while (and (> pos22 0) (not (= (aref epat2 (1- pos22)) ?*))) -;; (setq pos22 (1- pos22))) -;; -;; (if (and (> (length str1) pos12) (>= pos12 pos11) (> pos11 -1) -;; (> (length str2) pos22) (>= pos22 pos21) (> pos21 -1)) -;; (string= (substring str1 pos11 pos12) -;; (substring str2 pos21 pos22))) -;; )) - - -;; Prepare meta-buffer in accordance with the argument-function and -;; redraw-function. Must return the created meta-buffer. -(defun ediff-prepare-meta-buffer (action-func meta-list - meta-buffer-name redraw-function - jobname &optional startup-hooks) - (let* ((meta-buffer-name - (ediff-unique-buffer-name meta-buffer-name "*")) - (meta-buffer (get-buffer-create meta-buffer-name))) - (ediff-with-current-buffer meta-buffer - - ;; comes first - (ediff-meta-mode) - - (setq ediff-meta-action-function action-func - ediff-meta-redraw-function redraw-function - ediff-metajob-name jobname - ediff-meta-buffer meta-buffer) - - ;; comes after ediff-meta-action-function is set - (ediff-setup-meta-map) - - (if (eq ediff-metajob-name 'ediff-registry) - (progn - (setq ediff-registry-buffer meta-buffer - ediff-meta-list meta-list) - ;; this func is used only from registry buffer, not from other - ;; meta-buffs. - (define-key - ediff-meta-buffer-map "M" 'ediff-show-meta-buff-from-registry)) - ;; Initialize the meta list -- don't do this for registry. - ;; - ;; We prepend '(nil nil) to all elts of meta-list, except the first. - ;; The first nil will later be replaced by the session buffer. The - ;; second is reserved for session status. - ;; - ;; (car ediff-meta-list) gets cons'ed with the session group buffer. - ;; Also, session objects A/B/C are turned into lists of the form - ;; (obj eq-indicator). Eq-indicator is either nil or =. Initialized to - ;; nil. If later it is discovered that this file is = to some other - ;; file in the same session, eq-indicator is changed to `='. - ;; For now, the eq-indicator is used only for 2 and 3-file jobs. - (setq ediff-meta-list - (cons (cons meta-buffer (car meta-list)) - (mapcar - (function - (lambda (elt) - (cons nil - (cons nil - ;; convert each obj to (obj nil), - ;; where nil is the initial value - ;; for eq-indicator -- see above - (mapcar - (function (lambda (obj) (list obj nil))) - elt))))) - (cdr meta-list))))) - - (or (eq meta-buffer ediff-registry-buffer) - (setq ediff-session-registry - (cons meta-buffer ediff-session-registry))) - - ;; redraw-function uses ediff-meta-list - (funcall redraw-function ediff-meta-list) - - ;; set read-only/non-modified - (setq buffer-read-only t) - (set-buffer-modified-p nil) - - (run-hooks 'startup-hooks) - - ;; Arrange to show directory contents differences - ;; Must be after run startup-hooks, since ediff-dir-difference-list is - ;; set inside these hooks - (if (eq action-func 'ediff-filegroup-action) - (progn - ;; put meta buffer in (car ediff-dir-difference-list) - (setq ediff-dir-difference-list - (cons (cons meta-buffer (car ediff-dir-difference-list)) - (cdr ediff-dir-difference-list))) - - (or (ediff-one-filegroup-metajob jobname) - (ediff-draw-dir-diffs ediff-dir-difference-list)) - (define-key ediff-meta-buffer-map "h" 'ediff-mark-for-hiding) - (define-key - ediff-meta-buffer-map "x" 'ediff-hide-marked-sessions) - (define-key ediff-meta-buffer-map "m" 'ediff-mark-for-operation) - (cond ((ediff-collect-diffs-metajob jobname) - (define-key - ediff-meta-buffer-map "P" 'ediff-collect-custom-diffs)) - ((ediff-patch-metajob jobname) - (define-key - ediff-meta-buffer-map "P" 'ediff-meta-show-patch))) - (define-key ediff-meta-buffer-map "u" 'ediff-up-meta-hierarchy) - (define-key ediff-meta-buffer-map "D" 'ediff-show-dir-diffs))) - - (if (eq ediff-metajob-name 'ediff-registry) - (run-hooks 'ediff-registry-setup-hook) - (run-hooks 'ediff-session-group-setup-hook)) - ) ; eval in meta-buffer - meta-buffer)) - - -;; this is a setup function for ediff-directories -;; must return meta-buffer -(defun ediff-redraw-directory-group-buffer (meta-list) - ;; extract directories - (let ((meta-buf (ediff-get-group-buffer meta-list)) - (empty t) - (sessionNum 0) - regexp elt session-buf f1 f2 f3 pt - merge-autostore-dir - point tmp-list buffer-read-only) - (ediff-with-current-buffer meta-buf - (setq point (point)) - (erase-buffer) - (insert (format ediff-meta-buffer-message - (ediff-abbrev-jobname ediff-metajob-name))) - - (setq regexp (ediff-get-group-regexp meta-list) - merge-autostore-dir (ediff-get-group-merge-autostore-dir meta-list)) - - (cond ((ediff-collect-diffs-metajob) - (insert - " `P':\tcollect custom diffs of all marked sessions\n")) - ((ediff-patch-metajob) - (insert - " `P':\tshow patch appropriately for the context (session or group)\n"))) - (insert - " `u':\tshow parent session group\n") - (or (ediff-one-filegroup-metajob) - (insert - " `D':\tshow differences among directories\n" - " `=':\tmark identical files in each session\n\n")) - - (if (and (stringp regexp) (> (length regexp) 0)) - (insert - (format "\n*** Filter-through regular expression: %s\n" regexp))) - (if (and ediff-autostore-merges (ediff-merge-metajob) - (stringp merge-autostore-dir)) - (insert (format - "\nMerges are automatically stored in directory: %s\n" - merge-autostore-dir))) - (insert "\n - Size Last modified Name - ----------------------------------------------------------------------- - -") - - ;; discard info on directories and regexp - (setq meta-list (cdr meta-list) - tmp-list meta-list) - (while (and tmp-list empty) - (if (and (car tmp-list) - (not (eq (ediff-get-session-status (car tmp-list)) ?I))) - (setq empty nil)) - (setq tmp-list (cdr tmp-list))) - - (if empty - (insert - " ****** ****** This session group has no members\n")) - - ;; now organize file names like this: - ;; use-mark sizeA dateA sizeB dateB filename - ;; make sure directories are displayed with a trailing slash. - (while meta-list - (setq elt (car meta-list) - meta-list (cdr meta-list) - sessionNum (1+ sessionNum)) - (if (eq (ediff-get-session-status elt) ?I) - () - (setq session-buf (ediff-get-session-buffer elt) - f1 (ediff-get-session-objA elt) - f2 (ediff-get-session-objB elt) - f3 (ediff-get-session-objC elt)) - (setq pt (point)) - ;; insert markers - (insert (cond ((null session-buf) " ") ; virgin session - ((ediff-buffer-live-p session-buf) "+") ;active session - (t "-"))) ; finished session - (insert (cond ((ediff-get-session-status elt)) ; session has status, - ;;; e.g., ?H, ?I - (t " "))) ; normal session - (insert " Session " (int-to-string sessionNum) ":\n") - (ediff-meta-insert-file-info f1) - (ediff-meta-insert-file-info f2) - (ediff-meta-insert-file-info f3) - (ediff-set-meta-overlay pt (point) elt))) - (set-buffer-modified-p nil) - (goto-char point) - meta-buf))) - -;; Check if this is a problematic session. -;; Return nil if not. Otherwise, return symbol representing the problem -;; At present, problematic sessions occur only in -with-ancestor comparisons -;; when the ancestor is a directory rather than a file, or when there is no -;; suitable ancestor file in the ancestor directory -(defun ediff-problematic-session-p (session) - (let ((f1 (ediff-get-session-objA-name session)) - (f2 (ediff-get-session-objB-name session)) - (f3 (ediff-get-session-objC-name session))) - (cond ((and (stringp f1) (not (file-directory-p f1)) - (stringp f2) (not (file-directory-p f2)) - ;; either invalid file name or a directory - (or (not (stringp f3)) (file-directory-p f3)) - (ediff-ancestor-metajob)) - ;; more may be added later - 'ancestor-is-dir) - (t nil)))) - -(defun ediff-meta-insert-file-info (fileinfo) - (let ((fname (car fileinfo)) - (feq (ediff-get-file-eqstatus fileinfo)) - file-modtime file-size) - - (cond ((not (stringp fname)) (setq file-size -2)) ; file doesn't exits - ((not (ediff-file-remote-p fname)) - (if (file-exists-p fname) - ;; set real size and modtime - (setq file-size (ediff-file-size fname) - file-modtime (ediff-file-modtime fname)) - (setq file-size -2))) ; file doesn't exist - ( t (setq file-size -1))) ; remote file - (if (stringp fname) - (insert - (format - "%s %s %-20s %s\n" - (if feq "=" " ") ; equality indicator - (format "%10s" (cond ((= file-size -1) "--") - ((< file-size -1) "--") - (t file-size))) - (cond ((= file-size -1) "*remote file*") - ((< file-size -1) "*file doesn't exist*") - (t (ediff-format-date (decode-time file-modtime)))) - - ;; dir names in meta lists have training slashes, so we just - ;; abbreviate the file name, if file exists - (if (and (not (stringp fname)) (< file-size -1)) - "-------" ; file doesn't exist - (ediff-abbreviate-file-name fname))))))) - -(defconst ediff-months '((1 . "Jan") (2 . "Feb") (3 . "Mar") (4 . "Apr") - (5 . "May") (6 . "Jun") (7 . "Jul") (8 . "Aug") - (9 . "Sep") (10 . "Oct") (11 . "Nov") (12 . "Dec")) - "Months' associative array.") - -;; returns 2char string -(defsubst ediff-fill-leading-zero (num) - (if (< num 10) - (format "0%d" num) - (number-to-string num))) - -;; TIME is like the output of decode-time -(defun ediff-format-date (time) - (format "%s %2d %4d %s:%s:%s" - (cdr (assoc (nth 4 time) ediff-months)) ; month - (nth 3 time) ; day - (nth 5 time) ; year - (ediff-fill-leading-zero (nth 2 time)) ; hour - (ediff-fill-leading-zero (nth 1 time)) ; min - (ediff-fill-leading-zero (nth 0 time)) ; sec - )) - -(defun ediff-draw-dir-diffs (diff-list) - (if (null diff-list) (error "Lost difference info on these directories")) - (let* ((buf-name (ediff-unique-buffer-name - "*Ediff File Group Differences" "*")) - (regexp (ediff-get-group-regexp diff-list)) - (dir1 (ediff-abbreviate-file-name (ediff-get-group-objA diff-list))) - (dir2 (ediff-abbreviate-file-name (ediff-get-group-objB diff-list))) - (dir3 (ediff-get-group-objC diff-list)) - (dir3 (if (stringp dir3) (ediff-abbreviate-file-name dir3))) - (meta-buf (ediff-get-group-buffer diff-list)) - (underline (make-string 26 ?-)) - file code - buffer-read-only) - ;; skip the directory part - (setq diff-list (cdr diff-list)) - (setq ediff-dir-diffs-buffer (get-buffer-create buf-name)) - (ediff-with-current-buffer ediff-dir-diffs-buffer - (use-local-map ediff-dir-diffs-buffer-map) - (erase-buffer) - (setq ediff-meta-buffer meta-buf) - (insert "\t\t*** Directory Differences ***\n") - (insert " -Useful commands: - `q': hide this buffer - SPC: next line - DEL: previous line\n\n") - - (if (and (stringp regexp) (> (length regexp) 0)) - (insert - (format "\n*** Filter-through regular expression: %s\n" regexp))) - (insert "\n") - (insert (format "\n%-27s%-26s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (file-name-as-directory dir1)) - 25) - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (file-name-as-directory dir2)) - 25))) - (if dir3 - (insert (format " %-25s\n" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (file-name-as-directory dir3)) - 25))) - (insert "\n")) - (insert (format "%s%s" underline underline)) - (if (stringp dir3) - (insert (format "%s\n\n" underline)) - (insert "\n\n")) - - (if (null diff-list) - (insert "\n\t*** No differences ***\n")) - - (while diff-list - (setq file (car (car diff-list)) - code (cdr (car diff-list)) - diff-list (cdr diff-list)) - (if (= (mod code 2) 0) ; dir1 - (insert (format "%-27s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (if (file-directory-p (concat dir1 file)) - (file-name-as-directory file) - file)) - 24))) - (insert (format "%-27s" "---"))) - (if (= (mod code 3) 0) ; dir2 - (insert (format "%-26s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (if (file-directory-p (concat dir2 file)) - (file-name-as-directory file) - file)) - 24))) - (insert (format "%-26s" "---"))) - (if (stringp dir3) - (if (= (mod code 5) 0) ; dir3 - (insert (format " %-25s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (if (file-directory-p (concat dir3 file)) - (file-name-as-directory file) - file)) - 24))) - (insert (format " %-25s" "---")))) - (insert "\n")) - (setq buffer-read-only t) - (set-buffer-modified-p nil)) ; eval in diff buffer - )) - -(defun ediff-bury-dir-diffs-buffer () - "Bury the directory difference buffer. Display the meta buffer instead." - (interactive) - (let ((buf ediff-meta-buffer) - wind) - (bury-buffer) - (if (setq wind (ediff-get-visible-buffer-window buf)) - (select-window wind) - (set-window-buffer (selected-window) buf)))) - -;; executes in dir session group buffer -;; show buffer differences -(defun ediff-show-dir-diffs () - "Display differences among the directories involved in session group." - (interactive) - (if (ediff-one-filegroup-metajob) - (error "This command is inapplicable in the present context")) - (or (ediff-buffer-live-p ediff-dir-diffs-buffer) - (ediff-draw-dir-diffs ediff-dir-difference-list)) - (let ((buf ediff-dir-diffs-buffer)) - (other-window 1) - (set-window-buffer (selected-window) buf) - (goto-char (point-min)))) - -(defun ediff-up-meta-hierarchy () - "Go to the parent session group buffer." - (interactive) - (if (ediff-buffer-live-p ediff-parent-meta-buffer) - (ediff-show-meta-buffer ediff-parent-meta-buffer) - (error "This session group has no parent"))) - - -;; argument is ignored -(defun ediff-redraw-registry-buffer (&optional ignore) - (ediff-with-current-buffer ediff-registry-buffer - (let ((point (point)) - elt bufAname bufBname bufCname cur-diff total-diffs pt - job-name meta-list registry-list buffer-read-only) - (erase-buffer) - (insert "This is a registry of all active Ediff sessions. - -Useful commands: - button2, `v', RET over a session record: switch to that session - `M' over a session record: display the associated session group - `R' in any Ediff session: display session registry - SPC:\tnext session - DEL:\tprevious session - `E':\tbrowse Ediff on-line manual - `q':\tbury registry - - -\t\tActive Ediff Sessions: -\t\t---------------------- - -") - ;; purge registry list from dead buffers - (mapcar (function (lambda (elt) - (if (not (ediff-buffer-live-p elt)) - (setq ediff-session-registry - (delq elt ediff-session-registry))))) - ediff-session-registry) - - (if (null ediff-session-registry) - (insert " ******* No active Ediff sessions *******\n")) - - (setq registry-list ediff-session-registry) - (while registry-list - (setq elt (car registry-list) - registry-list (cdr registry-list)) - - (if (ediff-buffer-live-p elt) - (if (ediff-with-current-buffer elt - (setq job-name ediff-metajob-name - meta-list ediff-meta-list) - (and ediff-metajob-name - (not (eq ediff-metajob-name 'ediff-registry)))) - (progn - (setq pt (point)) - (insert (format " *group*\t%s: %s\n" - (buffer-name elt) - (ediff-abbrev-jobname job-name))) - (insert (format "\t\t %s %s %s\n" - (ediff-abbreviate-file-name - (ediff-get-group-objA meta-list)) - (ediff-abbreviate-file-name - (if (stringp - (ediff-get-group-objB meta-list)) - (ediff-get-group-objB meta-list) - "")) - (ediff-abbreviate-file-name - (if (stringp - (ediff-get-group-objC meta-list)) - (ediff-get-group-objC meta-list) - "")))) - (ediff-set-meta-overlay pt (point) elt)) - (progn - (ediff-with-current-buffer elt - (setq bufAname (if (ediff-buffer-live-p ediff-buffer-A) - (buffer-name ediff-buffer-A) - "!!!killed buffer!!!") - bufBname (if (ediff-buffer-live-p ediff-buffer-B) - (buffer-name ediff-buffer-B) - "!!!killed buffer!!!") - bufCname (cond ((not (ediff-3way-job)) - "") - ((ediff-buffer-live-p ediff-buffer-C) - (buffer-name ediff-buffer-C)) - (t "!!!killed buffer!!!"))) - (setq total-diffs (format "%-4d" ediff-number-of-differences) - cur-diff - (cond ((= ediff-current-difference -1) " _") - ((= ediff-current-difference - ediff-number-of-differences) - " $") - (t (format - "%4d" (1+ ediff-current-difference)))) - job-name ediff-job-name)) - ;; back in the meta buf - (setq pt (point)) - (insert cur-diff "/" total-diffs "\t" - (buffer-name elt) - (format ": %s" (ediff-abbrev-jobname job-name))) - (insert - "\n\t\t " bufAname " " bufBname " " bufCname "\n") - (ediff-set-meta-overlay pt (point) elt)))) - ) ; while - (set-buffer-modified-p nil) - (goto-char point) - ))) - -;; sets overlay around a meta record with 'ediff-meta-info property PROP -(defun ediff-set-meta-overlay (b e prop) - (let (overl) - (setq overl (ediff-make-overlay b e)) - (if ediff-emacs-p - (ediff-overlay-put overl 'mouse-face 'highlight) - (ediff-overlay-put overl 'highlight t)) - (ediff-overlay-put overl 'ediff-meta-info prop))) - -(defun ediff-mark-for-hiding (unmark) - "Mark session for hiding. With prefix arg, unmark." - (interactive "P") - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos)) - (session-buf (ediff-get-session-buffer info))) - - (if (eq (ediff-get-session-status info) ?H) - (setq unmark t)) - (if unmark - (ediff-set-session-status info nil) - (if (ediff-buffer-live-p session-buf) - (error "Can't hide active session, %s" (buffer-name session-buf))) - (ediff-set-session-status info ?H)) - (or unmark - (ediff-next-meta-item 1)) - (ediff-update-meta-buffer meta-buf) - )) - -(defun ediff-mark-for-operation (unmark) - "Mark session for a group operation. With prefix arg, unmark." - (interactive "P") - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos))) - - (if (eq (ediff-get-session-status info) ?*) - (setq unmark t)) - (if unmark - (ediff-set-session-status info nil) - (ediff-set-session-status info ?*)) - (or unmark - (ediff-next-meta-item 1)) - (ediff-update-meta-buffer meta-buf) - )) - -(defun ediff-hide-marked-sessions (unhide) - "Hide marked sessions. With prefix arg, unhide." - (interactive "P") - (let ((grp-buf (ediff-get-group-buffer ediff-meta-list)) - (meta-list (cdr ediff-meta-list)) - (from (if unhide ?I ?H)) - (to (if unhide ?H ?I)) - (numMarked 0) - active-sessions-exist session-buf elt) - (while meta-list - (setq elt (car meta-list) - meta-list (cdr meta-list) - session-buf (ediff-get-session-buffer elt)) - - (if (eq (ediff-get-session-status elt) from) - (progn - (setq numMarked (1+ numMarked)) - (if (and (eq to ?I) (buffer-live-p session-buf)) - ;; shouldn't hide active sessions - (setq active-sessions-exist t) - (ediff-set-session-status elt to))))) - (if (> numMarked 0) - (ediff-update-meta-buffer grp-buf) - (beep) - (if unhide - (message "Nothing to reveal...") - (message "Nothing to hide..."))) - (if active-sessions-exist - (message "Note: didn't hide active sessions!")) - )) - -;; Apply OPERATION to marked sessions. Operation expects one argument of type -;; meta-list member (not the first one), i.e., a regular session description. -;; Returns number of marked sessions on which operation was performed -(defun ediff-operate-on-marked-sessions (operation) - (let ((grp-buf (ediff-get-group-buffer ediff-meta-list)) - (meta-list (cdr ediff-meta-list)) - (marksym ?*) - (numMarked 0) - (sessionNum 0) - (diff-buffer ediff-meta-diff-buffer) - session-buf elt) - (while meta-list - (setq elt (car meta-list) - meta-list (cdr meta-list) - sessionNum (1+ sessionNum)) - (cond ((eq (ediff-get-session-status elt) marksym) - (save-excursion - (setq numMarked (1+ numMarked)) - (funcall operation elt sessionNum))) - ((and (ediff-meta-session-p elt) - (ediff-buffer-live-p - (setq session-buf (ediff-get-session-buffer elt)))) - (setq numMarked - (+ numMarked - (ediff-with-current-buffer session-buf - ;; pass meta-diff along - (setq ediff-meta-diff-buffer diff-buffer) - ;; collect diffs in child group - (ediff-operate-on-marked-sessions operation))))))) - (ediff-update-meta-buffer grp-buf) ; just in case - numMarked - )) - -(defun ediff-append-custom-diff (session sessionNum) - (or (ediff-collect-diffs-metajob) - (error "Hmm, I'd hate to do it to you ...")) - (let ((session-buf (ediff-get-session-buffer session)) - (meta-diff-buff ediff-meta-diff-buffer) - (metajob ediff-metajob-name) - tmp-buf custom-diff-buf) - (if (ediff-buffer-live-p session-buf) - (ediff-with-current-buffer session-buf - (if (eq ediff-control-buffer session-buf) ; individual session - (progn - (ediff-compute-custom-diffs-maybe) - (setq custom-diff-buf ediff-custom-diff-buffer))))) - - (or (ediff-buffer-live-p meta-diff-buff) - (error "Ediff: something wrong--no multiple diffs buffer")) - - (cond ((ediff-buffer-live-p custom-diff-buf) - (save-excursion - (set-buffer meta-diff-buff) - (goto-char (point-max)) - (insert-buffer custom-diff-buf) - (insert "\n"))) - ((memq metajob '(ediff-directories - ediff-merge-directories - ediff-merge-directories-with-ancestor)) - ;; get diffs by calling shell command on ediff-custom-diff-program - (save-excursion - (set-buffer (setq tmp-buf (get-buffer-create ediff-tmp-buffer))) - (erase-buffer) - (shell-command - (format "%s %s %s %s" - ediff-custom-diff-program ediff-custom-diff-options - (ediff-get-session-objA-name session) - (ediff-get-session-objB-name session)) - t)) - (save-excursion - (set-buffer meta-diff-buff) - (goto-char (point-max)) - (insert-buffer tmp-buf) - (insert "\n"))) - (t - (error "Can't make context diff for Session %d" sessionNum ))) - )) - -(defun ediff-collect-custom-diffs () - "Collect custom diffs of marked sessions in buffer `*Ediff Multifile Diffs*'. -This operation is defined only for `ediff-directories' and -`ediff-directory-revisions', since its intent is to produce -multifile patches. For `ediff-directory-revisions', we insist that -all marked sessions must be active." - (interactive) - (or (ediff-buffer-live-p ediff-meta-diff-buffer) - (setq ediff-meta-diff-buffer - (get-buffer-create - (ediff-unique-buffer-name "*Ediff Multifile Diffs" "*")))) - (ediff-with-current-buffer ediff-meta-diff-buffer - (erase-buffer)) - (if (> (ediff-operate-on-marked-sessions 'ediff-append-custom-diff) 0) - ;; did something - (display-buffer ediff-meta-diff-buffer 'not-this-window) - (beep) - (message "No marked sessions found"))) - -(defun ediff-meta-show-patch () - "Show the multi-file patch associated with this group session." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - (info (ediff-get-meta-info meta-buf pos 'noerror)) - (patchbuffer ediff-meta-patchbufer)) - (if (ediff-buffer-live-p patchbuffer) - (ediff-with-current-buffer patchbuffer - (save-restriction - (if (not info) - (widen) - (narrow-to-region - (ediff-get-session-objB-name info) - (ediff-get-session-objC-name info))) - (set-buffer (get-buffer-create ediff-tmp-buffer)) - (erase-buffer) - (insert-buffer patchbuffer) - (display-buffer ediff-tmp-buffer 'not-this-window) - )) - (error "The patch buffer wasn't found")))) - - -;; This function executes in meta buffer. It knows where event happened. -(defun ediff-filegroup-action () - "Execute appropriate action for the selected session." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos)) - merge-autostore-dir - session-buf file1 file2 file3 regexp) - - (setq session-buf (ediff-get-session-buffer info) - file1 (ediff-get-session-objA-name info) - file2 (ediff-get-session-objB-name info) - file3 (ediff-get-session-objC-name info)) - - ;; make sure we don't start on hidden sessions - ;; ?H means marked for hiding. ?I means invalid (hidden). - (if (memq (ediff-get-session-status info) '(?I)) - (progn - (beep) - (if (y-or-n-p "This session is marked as hidden, unmark? ") - (progn - (ediff-set-session-status info nil) - (ediff-update-meta-buffer meta-buf)) - (error "Aborted")))) - - (ediff-with-current-buffer meta-buf - (setq merge-autostore-dir - (ediff-get-group-merge-autostore-dir ediff-meta-list)) - (goto-char pos) ; if the user clicked on session--move point there - ;; First handle sessions involving directories (which are themselves - ;; session groups) - ;; After that handle individual sessions - (cond ((ediff-meta-session-p info) - ;; do ediff/ediff-merge on subdirectories - (if (ediff-buffer-live-p session-buf) - (ediff-show-meta-buffer session-buf) - (setq regexp (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history)) - (ediff-directories-internal - file1 file2 file3 regexp - ediff-session-action-function - ediff-metajob-name - ;; make it update car info after startup - (` (list (lambda () - ;; child session group should know its parent - (setq ediff-parent-meta-buffer - (quote (, ediff-meta-buffer))) - ;; and parent will know its child - (setcar (quote (, info)) ediff-meta-buffer))))))) - - ;; Do ediff-revision on a subdirectory - ((and (ediff-one-filegroup-metajob) - (ediff-revision-metajob) - (file-directory-p file1)) - (if (ediff-buffer-live-p session-buf) - (ediff-show-meta-buffer session-buf) - (setq regexp (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history)) - (ediff-directory-revisions-internal - file1 regexp - ediff-session-action-function ediff-metajob-name - ;; make it update car info after startup - (` (list (lambda () - ;; child session group should know its parent - (setq ediff-parent-meta-buffer - (quote (, ediff-meta-buffer))) - ;; and parent will know its child - (setcar (quote (, info)) ediff-meta-buffer))))))) - - ;; From here on---only individual session handlers - - ;; handle an individual session with a live control buffer - ((ediff-buffer-live-p session-buf) - (ediff-with-current-buffer session-buf - (setq ediff-mouse-pixel-position (mouse-pixel-position)) - (ediff-recenter 'no-rehighlight))) - - ((ediff-problematic-session-p info) - (beep) - (if (y-or-n-p - "This session has no ancestor. Merge without the ancestor? ") - (ediff-merge-files - file1 file2 - ;; provide startup hooks - (` (list (lambda () - (setq ediff-meta-buffer (, (current-buffer))) - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - ;; make ediff-startup pass - ;; ediff-control-buffer back to the meta - ;; level; see below - (setcar - (quote (, info)) ediff-control-buffer))))) - (error "Aborted"))) - ((ediff-one-filegroup-metajob) ; needs 1 file arg - (funcall ediff-session-action-function - file1 - ;; provide startup hooks - (` (list (lambda () - (setq ediff-meta-buffer (, (current-buffer))) - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - ;; make ediff-startup pass - ;; ediff-control-buffer back to the meta - ;; level; see below - (setcar - (quote (, info)) ediff-control-buffer)))))) - ((not (ediff-metajob3)) ; need 2 file args - (funcall ediff-session-action-function - file1 file2 - ;; provide startup hooks - (` (list (lambda () - (setq ediff-meta-buffer (, (current-buffer))) - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - ;; make ediff-startup pass - ;; ediff-control-buffer back to the meta - ;; level; see below - (setcar - (quote (, info)) ediff-control-buffer)))))) - ((ediff-metajob3) ; need 3 file args - (funcall ediff-session-action-function - file1 file2 file3 - ;; arrange startup hooks - (` (list (lambda () - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - (setq ediff-meta-buffer (, (current-buffer))) - ;; this arranges that ediff-startup will pass - ;; the value of ediff-control-buffer back to - ;; the meta level, to the record in the meta - ;; list containing the information about the - ;; session associated with that - ;; ediff-control-buffer - (setcar - (quote (, info)) ediff-control-buffer)))))) - ) ; cond - ) ; eval in meta-buf - )) - -(defun ediff-registry-action () - "Switch to a selected session." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (buf (ediff-event-buffer last-command-event)) - (ctl-buf (ediff-get-meta-info buf pos))) - - (if (ediff-buffer-live-p ctl-buf) - ;; check if this is ediff-control-buffer or ediff-meta-buffer - (if (ediff-with-current-buffer ctl-buf - (eq (key-binding "q") 'ediff-quit-meta-buffer)) - ;; it's a meta-buffer -- last action should just display it - (ediff-show-meta-buffer ctl-buf) - ;; it's a session buffer -- invoke go back to session - (ediff-with-current-buffer ctl-buf - (setq ediff-mouse-pixel-position (mouse-pixel-position)) - (ediff-recenter 'no-rehighlight))) - (beep) - (message "You've selected a stale session --- try again") - (ediff-update-registry)) - (ediff-with-current-buffer buf - (goto-char pos)) - )) - - -(defun ediff-show-meta-buffer (&optional meta-buf) - "Show the session group buffer." - (interactive) - (let (wind frame silent) - (if meta-buf (setq silent t)) - - (setq meta-buf (or meta-buf ediff-meta-buffer)) - (cond ((not (bufferp meta-buf)) - (error "This Ediff session is not part of a session group")) - ((not (ediff-buffer-live-p meta-buf)) - (error - "Can't find this session's group panel -- session itself is ok"))) - - (ediff-cleanup-meta-buffer meta-buf) - (ediff-with-current-buffer meta-buf - (save-excursion - (cond ((setq wind (ediff-get-visible-buffer-window meta-buf)) - (or silent - (message - "Already showing the group panel for this session")) - (set-window-buffer wind meta-buf) - (select-window wind)) - ((window-live-p (setq wind ediff-window-C)) ;in merge--merge buf - (set-window-buffer ediff-window-C meta-buf) - (select-window wind)) - ((window-live-p (setq wind ediff-window-A)) - (set-window-buffer ediff-window-A meta-buf) - (select-window wind)) - ((window-live-p (setq wind ediff-window-B)) - (set-window-buffer ediff-window-B meta-buf) - (select-window wind)) - ((and - (setq wind - (ediff-get-visible-buffer-window ediff-registry-buffer)) - (ediff-window-display-p)) - (select-window wind) - (other-window 1) - (set-window-buffer (selected-window) meta-buf)) - (t (ediff-skip-unsuitable-frames 'ok-unsplittable) - (set-window-buffer (selected-window) meta-buf))) - )) - (if (and (ediff-window-display-p) - (window-live-p - (setq wind (ediff-get-visible-buffer-window meta-buf)))) - (progn - (setq frame (window-frame wind)) - (raise-frame frame) - (ediff-reset-mouse frame))) - (run-hooks 'ediff-show-session-group-hook) - )) - -(defun ediff-show-meta-buff-from-registry () - "Display the session group buffer for a selected session group." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - (info (ediff-get-meta-info meta-buf pos)) - (meta-or-session-buf info)) - (ediff-with-current-buffer meta-or-session-buf - (ediff-show-meta-buffer)))) - -;;;###autoload -(defun ediff-show-registry () - "Display Ediff's registry." - (interactive) - (ediff-update-registry) - (if (not (ediff-buffer-live-p ediff-registry-buffer)) - (error "No active Ediff sessions or corrupted session registry")) - (let (wind frame) - ;; for some reason, point moves in ediff-registry-buffer, so we preserve it - ;; explicitly - (ediff-with-current-buffer ediff-registry-buffer - (save-excursion - (cond ((setq wind - (ediff-get-visible-buffer-window ediff-registry-buffer)) - (message "Already showing the registry") - (set-window-buffer wind ediff-registry-buffer) - (select-window wind)) - ((window-live-p ediff-window-C) - (set-window-buffer ediff-window-C ediff-registry-buffer) - (select-window ediff-window-C)) - ((window-live-p ediff-window-A) - (set-window-buffer ediff-window-A ediff-registry-buffer) - (select-window ediff-window-A)) - ((window-live-p ediff-window-B) - (set-window-buffer ediff-window-B ediff-registry-buffer) - (select-window ediff-window-B)) - ((and (setq wind - (ediff-get-visible-buffer-window ediff-meta-buffer)) - (ediff-window-display-p)) - (select-window wind) - (other-window 1) - (set-window-buffer (selected-window) ediff-registry-buffer)) - (t (ediff-skip-unsuitable-frames 'ok-unsplittable) - (set-window-buffer (selected-window) ediff-registry-buffer))) - )) - (if (ediff-window-display-p) - (progn - (setq frame - (window-frame - (ediff-get-visible-buffer-window ediff-registry-buffer))) - (raise-frame frame) - (ediff-reset-mouse frame))) - (run-hooks 'ediff-show-registry-hook) - )) - -;;;###autoload -(defalias 'eregistry 'ediff-show-registry) - -;; If meta-buf doesn't exist, it is created. In that case, id doesn't have a -;; parent meta-buf -;; Check if META-BUF exists before calling this function -(defun ediff-update-meta-buffer (meta-buf) - (ediff-with-current-buffer (current-buffer) - (if (ediff-buffer-live-p meta-buf) - (ediff-with-current-buffer meta-buf - (funcall ediff-meta-redraw-function ediff-meta-list)) - ))) - -(defun ediff-update-registry () - (ediff-with-current-buffer (current-buffer) - (if (ediff-buffer-live-p ediff-registry-buffer) - (ediff-redraw-registry-buffer) - (ediff-prepare-meta-buffer - 'ediff-registry-action - ediff-session-registry - "*Ediff Registry" - 'ediff-redraw-registry-buffer - 'ediff-registry)) - )) - -;; If meta-buf exists, it is redrawn along with parent. -;; Otherwise, nothing happens. -(defun ediff-cleanup-meta-buffer (meta-buffer) - (if (ediff-buffer-live-p meta-buffer) - (ediff-with-current-buffer meta-buffer - (ediff-update-meta-buffer meta-buffer) - (if (ediff-buffer-live-p ediff-parent-meta-buffer) - (ediff-update-meta-buffer ediff-parent-meta-buffer))))) - -;; t if no session in progress -(defun ediff-safe-to-quit (meta-buffer) - (if (ediff-buffer-live-p meta-buffer) - (let ((lis ediff-meta-list) - (cont t) - buffer-read-only) - (ediff-update-meta-buffer meta-buffer) - (ediff-with-current-buffer meta-buffer - (setq lis (cdr lis)) ; discard the description part of meta-list - (while (and cont lis) - (if (ediff-buffer-live-p - (ediff-get-group-buffer lis)) ; in progress - (setq cont nil)) - (setq lis (cdr lis))) - cont)))) - -(defun ediff-quit-meta-buffer () - "If the group has no active session, delete the meta buffer. -If no session is in progress, ask to confirm before deleting meta buffer. -Otherwise, bury the meta buffer. -If this is a session registry buffer then just bury it." - (interactive) - (let* ((buf (current-buffer)) - (dir-diffs-buffer ediff-dir-diffs-buffer) - (meta-diff-buffer ediff-meta-diff-buffer) - (parent-buf ediff-parent-meta-buffer) - (dont-show-registry (eq buf ediff-registry-buffer))) - (if dont-show-registry - (bury-buffer) - (ediff-cleanup-meta-buffer buf) - (cond ((and (ediff-safe-to-quit buf) - (y-or-n-p "Quit this session group? ")) - (run-hooks 'ediff-quit-session-group-hook) - (message "") - (ediff-dispose-of-meta-buffer buf)) - ((ediff-safe-to-quit buf) - (bury-buffer)) - (t - (error - "This session group has active sessions---cannot exit"))) - (ediff-cleanup-meta-buffer parent-buf) - (ediff-kill-buffer-carefully dir-diffs-buffer) - (ediff-kill-buffer-carefully meta-diff-buffer) - (if (ediff-buffer-live-p parent-buf) - (progn - (setq dont-show-registry t) - (ediff-show-meta-buffer parent-buf))) - ) - (or dont-show-registry - (ediff-show-registry)))) - -(defun ediff-dispose-of-meta-buffer (buf) - (setq ediff-session-registry (delq buf ediff-session-registry)) - (ediff-with-current-buffer buf - (if (ediff-buffer-live-p ediff-dir-diffs-buffer) - (kill-buffer ediff-dir-diffs-buffer))) - (kill-buffer buf)) - - -;; Obtain information on a meta record where the user clicked or typed -;; BUF is the buffer where this happened and POINT is the position -;; If optional NOERROR arg is given, don't report error and return nil if no -;; meta info is found on line. -(defun ediff-get-meta-info (buf point &optional noerror) - (let (result olist tmp) - (if (and point (ediff-buffer-live-p buf)) - (ediff-with-current-buffer buf - (if ediff-xemacs-p - (setq result - (if (setq tmp (extent-at point buf 'ediff-meta-info)) - (ediff-overlay-get tmp 'ediff-meta-info))) - (setq olist (overlays-at point)) - (setq olist - (mapcar (function (lambda (elt) - (overlay-get elt 'ediff-meta-info))) - olist)) - (while (and olist (null (car olist)) - (overlay-get (car olist) 'invisible)) - (setq olist (cdr olist))) - (setq result (car olist))))) - (if result - result - (if noerror - nil - (ediff-update-registry) - (error "No session info in this line"))))) - -;; return location of the next meta overlay after point -(defun ediff-next-meta-overlay-start (point) - (if (eobp) - (goto-char (point-min)) - (let (overl) - (if ediff-xemacs-p - (progn - (setq overl (extent-at point (current-buffer) 'ediff-meta-info)) - (if overl - (setq overl (next-extent overl)) - (setq overl (next-extent (current-buffer)))) - (if overl - (extent-start-position overl) - (point-max))) - (setq overl (car (overlays-at point))) - (if (and overl (overlay-get overl 'ediff-meta-info)) - ;; note: end of current overlay is the beginning of the next one - (overlay-end overl) - (next-overlay-change point)))) - )) - -(defun ediff-previous-meta-overlay-start (point) - (if (bobp) - (goto-char (point-max)) - (let (overl) - (if ediff-xemacs-p - (progn - (setq overl (extent-at point (current-buffer) 'ediff-meta-info)) - (if overl - (setq overl (previous-extent overl)) - (setq overl (previous-extent (current-buffer)))) - (if overl - (extent-start-position overl) - (point-min))) - (setq overl (car (overlays-at point))) - (if (and overl (overlay-get overl 'ediff-meta-info)) - (setq point (overlay-start overl))) - ;; to get to the beginning of prev overlay - (if (not (bobp)) - ;; trickery to overcome an emacs bug--doesn't always find previous - ;; overlay change correctly - (setq point (1- point))) - (setq point (previous-overlay-change point)) - ;; If we are not over an overlay after subtracting 1, it means we are - ;; in the description area preceding session records. In this case, - ;; goto the top of the registry buffer. - (or (car (overlays-at point)) - (setq point (point-min))) - point - )))) - -;; this is the action invoked when the user selects a patch from the meta -;; buffer. -(defun ediff-patch-file-form-meta (file &optional startup-hooks) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos)) - (meta-patchbuf ediff-meta-patchbufer) - session-buf beg-marker end-marker) - - (if (or (file-directory-p file) (string-match "/dev/null" file)) - (error "`%s' is not an ordinary file" (file-name-as-directory file))) - (setq session-buf (ediff-get-session-buffer info) - beg-marker (ediff-get-session-objB-name info) - end-marker (ediff-get-session-objC-name info)) - - (or (ediff-buffer-live-p session-buf) ; either an active patch session - (null session-buf) ; or it is a virgin session - (error - "Patch has been already applied to this file--cannot be repeated!")) - - (ediff-with-current-buffer meta-patchbuf - (save-restriction - (widen) - (narrow-to-region beg-marker end-marker) - (ediff-patch-file-internal meta-patchbuf file startup-hooks))))) - - -(defun ediff-meta-mark-equal-files () - "Run though the session list and mark identical files. -This is used only for sessions that involve 2 or 3 files at the same time." - (interactive) - (let ((list (cdr ediff-meta-list)) - fileinfo1 fileinfo2 fileinfo3 elt) - (while (setq elt (car list)) - (setq fileinfo1 (ediff-get-session-objA elt) - fileinfo2 (ediff-get-session-objB elt) - fileinfo3 (ediff-get-session-objC elt)) - (ediff-set-file-eqstatus fileinfo1 nil) - (ediff-set-file-eqstatus fileinfo2 nil) - (ediff-set-file-eqstatus fileinfo3 nil) - - (ediff-mark-if-equal fileinfo1 fileinfo2) - (if (ediff-metajob3) - (progn - (ediff-mark-if-equal fileinfo1 fileinfo3) - (ediff-mark-if-equal fileinfo2 fileinfo3))) - (setq list (cdr list)))) - (ediff-update-meta-buffer (current-buffer))) - -;; mark files 1 and 2 as equal, if they are. -(defun ediff-mark-if-equal (fileinfo1 fileinfo2) - (get-buffer-create ediff-tmp-buffer) - (or (file-directory-p (car fileinfo1)) - (file-directory-p (car fileinfo2)) - (if (= (ediff-make-diff2-buffer - ediff-tmp-buffer (car fileinfo1) (car fileinfo2)) - 0) - (progn - (ediff-set-file-eqstatus fileinfo1 t) - (ediff-set-file-eqstatus fileinfo2 t))))) - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-mult.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-ptch.el --- a/lisp/ediff/ediff-ptch.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,710 +0,0 @@ -;;; ediff-ptch.el --- Ediff's patch support - -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;;; Code: - -(provide 'ediff-ptch) - -(defgroup ediff-ptch nil - "Ediff patch support" - :tag "Patch" - :prefix "ediff-" - :group 'ediff) - -;; compiler pacifier -(defvar ediff-window-A) -(defvar ediff-window-B) -(defvar ediff-window-C) -(defvar ediff-use-last-dir) -(defvar ediff-shell) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff) - (load "ediff.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defcustom ediff-patch-program "patch" - "*Name of the program that applies patches. -It is recommended to use GNU-compatible versions." - :type 'string - :group 'ediff-ptch) -(defcustom ediff-patch-options "-f" - "*Options to pass to ediff-patch-program. - -Note: the `-b' option should be specified in `ediff-backup-specs'. - -It is recommended to pass the `-f' option to the patch program, so it won't ask -questions. However, some implementations don't accept this option, in which -case the default value for this variable should be changed." - :type 'string - :group 'ediff-ptch) - -(defvar ediff-last-dir-patch nil - "Last directory used by an Ediff command for file to patch.") - -;; the default backup extension -(defconst ediff-default-backup-extension - (if (memq system-type '(vax-vms axp-vms emx ms-dos)) - "_orig" ".orig")) - - -(defcustom ediff-backup-extension ediff-default-backup-extension - "Backup extension used by the patch program. -See also `ediff-backup-specs'." - :type 'string - :group 'ediff-ptch) - -(defun ediff-test-patch-utility () - (cond ((zerop (call-process ediff-patch-program nil nil nil "-z." "-b")) - ;; GNU `patch' v. >= 2.2 - 'gnu) - ((zerop (call-process ediff-patch-program nil nil nil "-b")) - 'posix) - (t 'traditional))) - -(defcustom ediff-backup-specs - (let ((type (ediff-test-patch-utility))) - (cond ((eq type 'gnu) - ;; GNU `patch' v. >= 2.2 - (format "-z%s -b" ediff-backup-extension)) - ((eq type 'posix) - ;; POSIX `patch' -- ediff-backup-extension must be ".orig" - (setq ediff-backup-extension ediff-default-backup-extension) - "-b") - (t - ;; traditional `patch' - (format "-b %s" ediff-backup-extension)))) - "*Backup directives to pass to the patch program. -Ediff requires that the old version of the file \(before applying the patch\) -be saved in a file named `the-patch-file.extension'. Usually `extension' is -`.orig', but this can be changed by the user and may depend on the system. -Therefore, Ediff needs to know the backup extension used by the patch program. - -Some versions of the patch program let you specify `-b backup-extension'. -Other versions only permit `-b', which assumes the extension `.orig' -\(in which case ediff-backup-extension MUST be also `.orig'\). The latest -versions of GNU patch require `-b -z backup-extension'. - -Note that both `ediff-backup-extension' and `ediff-backup-specs' -must be set properly. If your patch program takes the option `-b', -but not `-b extension', the variable `ediff-backup-extension' must -still be set so Ediff will know which extension to use. - -Ediff tries to guess the appropriate value for this variables. It is believed -to be working for `traditional' patch, all versions of GNU patch, and for POSIX -patch. So, don't change these variables, unless the default doesn't work." - :type 'string - :group 'ediff-ptch) - - -(defcustom ediff-patch-default-directory nil - "*Default directory to look for patches." - :type '(choice (const nil) string) - :group 'ediff-ptch) - -(defcustom ediff-context-diff-label-regexp - (concat "\\(" ; context diff 2-liner - "^\\*\\*\\* \\([^ \t]+\\)[^*]+[\t ]*\n--- \\([^ \t]+\\)" - "\\|" ; GNU unified format diff 2-liner - "^--- \\([^ \t]+\\)[\t ]+.*\n\\+\\+\\+ \\([^ \t]+\\)" - "\\)") - "*Regexp matching filename 2-liners at the start of each context diff. -You probably don't want to change that, unless you are using an obscure patch -program." - :type 'regexp - :group 'ediff-ptch) - -;; The buffer of the patch file. Local to control buffer. -(ediff-defvar-local ediff-patchbufer nil "") - -;; The buffer where patch displays its diagnostics. -(ediff-defvar-local ediff-patch-diagnostics nil "") - -;; Map of patch buffer. Has the form: -;; ((filename1 marker1 marker2) (filename2 marker1 marker2) ...) -;; where filenames are files to which patch would have applied the patch; -;; marker1 delimits the beginning of the corresponding patch and marker2 does -;; it for the end. -(ediff-defvar-local ediff-patch-map nil "") - -;; strip prefix from filename -;; returns /dev/null, if can't strip prefix -(defsubst ediff-file-name-sans-prefix (filename prefix) - (save-match-data - (if (string-match (concat "^" prefix) filename) - (substring filename (match-end 0)) - (concat "/null/" filename)))) - - - -;; no longer used -;; return the number of matches of regexp in buf starting from the beginning -(defun ediff-count-matches (regexp buf) - (ediff-with-current-buffer buf - (let ((count 0) opoint) - (save-excursion - (goto-char (point-min)) - (while (and (not (eobp)) - (progn (setq opoint (point)) - (re-search-forward regexp nil t))) - (if (= opoint (point)) - (forward-char 1) - (setq count (1+ count))))) - count))) - -;; Scan BUF (which is supposed to contain a patch) and make a list of the form -;; ((filename1 marker1 marker2) (filename2 marker1 marker2) ...) -;; where filenames are files to which patch would have applied the patch; -;; marker1 delimits the beginning of the corresponding patch and marker2 does -;; it for the end. This list is then assigned to ediff-patch-map. -;; Returns the number of elements in the list ediff-patch-map -(defun ediff-map-patch-buffer (buf) - (ediff-with-current-buffer buf - (let ((count 0) - (mark1 (move-marker (make-marker) (point-min))) - (mark1-end (point-min)) - (possible-file-names '("/dev/null" . "/dev/null")) - mark2-end mark2 filenames - beg1 beg2 end1 end2 - patch-map opoint) - (save-excursion - (goto-char (point-min)) - (setq opoint (point)) - (while (and (not (eobp)) - (re-search-forward ediff-context-diff-label-regexp nil t)) - (if (= opoint (point)) - (forward-char 1) ; ensure progress towards the end - (setq mark2 (move-marker (make-marker) (match-beginning 0)) - mark2-end (match-end 0) - beg1 (or (match-beginning 2) (match-beginning 4)) - end1 (or (match-end 2) (match-end 4)) - beg2 (or (match-beginning 3) (match-beginning 5)) - end2 (or (match-end 3) (match-end 5))) - ;; possible-file-names is holding the new file names until we - ;; insert the old file name in the patch map - ;; It is a pair (filename from 1st header line . fn from 2nd line) - (setq possible-file-names - (cons (if (and beg1 end1) - (buffer-substring beg1 end1) - "/dev/null") - (if (and beg2 end2) - (buffer-substring beg2 end2) - "/dev/null"))) - ;; check for any `Index:' or `Prereq:' lines, but don't use them - (if (re-search-backward "^Index:" mark1-end 'noerror) - (move-marker mark2 (match-beginning 0))) - (if (re-search-backward "^Prereq:" mark1-end 'noerror) - (move-marker mark2 (match-beginning 0))) - - (goto-char mark2-end) - - (if filenames - (setq patch-map (cons (list filenames mark1 mark2) patch-map))) - (setq mark1 mark2 - mark1-end mark2-end - filenames possible-file-names)) - (setq opoint (point) - count (1+ count)))) - (setq mark2 (point-max-marker) - patch-map (cons (list possible-file-names mark1 mark2) patch-map)) - (setq ediff-patch-map (nreverse patch-map)) - count))) - -;; Fix up the file names in the list using the argument FILENAME -;; Algorithm: find the first file's directory and cut it out from each file -;; name in the patch. Prepend the directory of FILENAME to each file in the -;; patch. In addition, the first file in the patch is replaced by FILENAME. -;; Each file is actually a file-pair of files found in the context diff header -;; In the end, for each pair, we select the shortest existing file. -;; Note: Ediff doesn't recognize multi-file patches that are separated -;; with the `Index:' line. It treats them as a single-file patch. -;; -;; Executes inside the patch buffer -(defun ediff-fixup-patch-map (filename) - (setq filename (expand-file-name filename)) - (let ((actual-dir (if (file-directory-p filename) - ;; directory part of filename - (file-name-as-directory filename) - (file-name-directory filename))) - ;; directory part of the first file in the patch - (base-dir1 (file-name-directory (car (car (car ediff-patch-map))))) - (base-dir2 (file-name-directory (cdr (car (car ediff-patch-map))))) - ) - - ;; chop off base-dirs - (mapcar (function (lambda (triple) - (or (string= (car (car triple)) "/dev/null") - (setcar (car triple) - (ediff-file-name-sans-prefix - (car (car triple)) base-dir1))) - (or (string= (cdr (car triple)) "/dev/null") - (setcdr (car triple) - (ediff-file-name-sans-prefix - (cdr (car triple)) base-dir2))) - )) - ediff-patch-map) - - ;; take the given file name into account - (or (file-directory-p filename) - (string= "/dev/null" filename) - (progn - (setcar (car ediff-patch-map) - (cons (file-name-nondirectory filename) - (file-name-nondirectory filename))))) - - ;; prepend actual-dir - (mapcar (function (lambda (triple) - (if (and (string-match "^/null/" (car (car triple))) - (string-match "^/null/" (cdr (car triple)))) - ;; couldn't strip base-dir1 and base-dir2 - ;; hence, something wrong - (progn - (with-output-to-temp-buffer ediff-msg-buffer - (princ - (format " -The patch file contains a context diff for - %s - %s -However, Ediff cannot infer the name of the actual file -to be patched on your system. If you know the correct file name, -please enter it now. - -If you don't know and still would like to apply patches to -other files, enter /dev/null -" - (substring (car (car triple)) 6) - (substring (cdr (car triple)) 6)))) - (let ((directory t) - user-file) - (while directory - (setq user-file - (read-file-name - "Please enter file name: " - actual-dir actual-dir t)) - (if (not (file-directory-p user-file)) - (setq directory nil) - (setq directory t) - (beep) - (message "%s is a directory" user-file) - (sit-for 2))) - (setcar triple (cons user-file user-file)))) - (setcar (car triple) - (expand-file-name - (concat actual-dir (car (car triple))))) - (setcdr (car triple) - (expand-file-name - (concat actual-dir (cdr (car triple)))))) - )) - ediff-patch-map) - ;; check for the shorter existing file in each pair and discard the other - ;; one - (mapcar (function (lambda (triple) - (let* ((file1 (car (car triple))) - (file2 (cdr (car triple))) - (f1-exists (file-exists-p file1)) - (f2-exists (file-exists-p file2))) - (cond - ((and (< (length file2) (length file1)) - f2-exists) - (setcar triple file2)) - ((and (< (length file1) (length file2)) - f1-exists) - (setcar triple file1)) - ((and f1-exists f2-exists - (string= file1 file2)) - (setcar triple file1)) - ((and f1-exists f2-exists) - (with-output-to-temp-buffer ediff-msg-buffer - (princ (format " -Ediff has inferred that - %s - %s -are two possible targets for applying the patch. -Both files seem to be plausible alternatives. - -Please advice: - Type `y' to use %s as the target; - Type `n' to use %s as the target. -" - file1 file2 file2 file1))) - (setcar triple - (if (y-or-n-p (format "Use %s ? " file2)) - file2 file1))) - (f2-exists (setcar triple file2)) - (f1-exists (setcar triple file1)) - (t - (with-output-to-temp-buffer ediff-msg-buffer - (princ "\nEdiff has inferred that") - (if (string= file1 file2) - (princ (format " - %s -is the target for this patch. However, this file does not exist." - file1)) - (princ (format " - %s - %s -are two possible targets for this patch. However, these files do not exist." - file1 file2))) - (princ " -\nPlease enter an alternative patch target ...\n")) - (let ((directory t) - target) - (while directory - (setq target (read-file-name - "Please enter a patch target: " - actual-dir actual-dir t)) - (if (not (file-directory-p target)) - (setq directory nil) - (beep) - (message "%s is a directory" target) - (sit-for 2))) - (setcar triple target))))))) - ediff-patch-map) - )) - -(defun ediff-show-patch-diagnostics () - (interactive) - (cond ((window-live-p ediff-window-A) - (set-window-buffer ediff-window-A ediff-patch-diagnostics)) - ((window-live-p ediff-window-B) - (set-window-buffer ediff-window-B ediff-patch-diagnostics)) - (t (display-buffer ediff-patch-diagnostics 'not-this-window)))) - -(defun ediff-get-patch-buffer () - "Obtain patch buffer. If patch is already in a buffer---use it. -Else, read patch file into a new buffer." - (let ((dir (cond (ediff-patch-default-directory) ; try patch default dir - (ediff-use-last-dir ediff-last-dir-patch) - (t default-directory))) - patch-buf) - (if (let ((last-nonmenu-event t) ; Emacs: don't use dialog box - last-command-event) ; XEmacs: don't use dialog box - (y-or-n-p "Is the patch already in a buffer? ")) - (setq patch-buf - (get-buffer - (read-buffer - "Which buffer contains the patch? " - (ediff-other-buffer - (if (eq (next-window (selected-window)) (selected-window)) - ;; only one window in frame --- don't skip current buff - "" - ;; >1 window --- skip current buff, assuming this is the one - ;; to patch, not the one that has the patch - (current-buffer))) - 'must-match))) - (setq patch-buf - (find-file-noselect - (read-file-name "Which file contains the patch? " - dir nil 'must-match)))) - - (ediff-with-current-buffer patch-buf - (goto-char (point-min)) - (or (ediff-get-visible-buffer-window patch-buf) - (progn - (pop-to-buffer patch-buf 'other-window) - (select-window (previous-window))))) - (ediff-map-patch-buffer patch-buf) - patch-buf)) - -;; Dispatch the right patch file function: regular or meta-level, -;; depending on how many patches are in the patch file. -;; At present, there is no support for meta-level patches. -;; Should return either the ctl buffer or the meta-buffer -(defun ediff-dispatch-file-patching-job (patch-buf filename - &optional startup-hooks) - (ediff-with-current-buffer patch-buf - ;; relativize names in the patch with respect to source-file - (ediff-fixup-patch-map filename) - (if (< (length ediff-patch-map) 2) - (ediff-patch-file-internal - patch-buf - (if (and (not (string-match "^/dev/null" (car (car ediff-patch-map)))) - (> (length (car (car ediff-patch-map))) 1)) - (car (car ediff-patch-map)) - filename) - startup-hooks) - (ediff-multi-patch-internal patch-buf startup-hooks)) - )) - - -;; When patching a buffer, never change the orig file. Instead, create a new -;; buffer, ***_patched, even if the buff visits a file. -;; Users who want to actually patch the buffer should use -;; ediff-patch-file, not ediff-patch-buffer. -(defun ediff-patch-buffer-internal (patch-buf - buf-to-patch-name - &optional startup-hooks) - (let* ((buf-to-patch (get-buffer buf-to-patch-name)) - (visited-file (if buf-to-patch (buffer-file-name buf-to-patch))) - (buf-mod-status (buffer-modified-p buf-to-patch)) - (multifile-patch-p (> (length (ediff-with-current-buffer patch-buf - ediff-patch-map)) 1)) - default-dir file-name ctl-buf) - (if multifile-patch-p - (error - "Can't apply multi-file patches to buffers that visit no files")) - - ;; create a temp file to patch - (ediff-with-current-buffer buf-to-patch - (setq default-dir default-directory) - (setq file-name (ediff-make-temp-file buf-to-patch)) - ;; temporarily switch visited file name, if any - (set-visited-file-name file-name) - ;; don't create auto-save file, if buff was visiting a file - (or visited-file - (setq buffer-auto-save-file-name nil)) - ;; don't confuse the user with a new bufname - (rename-buffer buf-to-patch-name) - (set-buffer-modified-p nil) - (set-visited-file-modtime) ; sync buffer and temp file - (setq default-directory default-dir) - ) - - ;; dispatch a patch function - (setq ctl-buf (ediff-dispatch-file-patching-job - patch-buf file-name startup-hooks)) - - (ediff-with-current-buffer ctl-buf - (delete-file (buffer-file-name ediff-buffer-A)) - (delete-file (buffer-file-name ediff-buffer-B)) - (ediff-with-current-buffer ediff-buffer-A - (if default-dir (setq default-directory default-dir)) - (set-visited-file-name visited-file) ; visited-file might be nil - (rename-buffer buf-to-patch-name) - (set-buffer-modified-p buf-mod-status)) - (ediff-with-current-buffer ediff-buffer-B - (setq buffer-auto-save-file-name nil) ; don't create auto-save file - (if default-dir (setq default-directory default-dir)) - (set-visited-file-name nil) - (rename-buffer (ediff-unique-buffer-name - (concat buf-to-patch-name "_patched") "")) - (set-buffer-modified-p t))) - )) - - -;; Traditional patch has weird return codes. -;; GNU and Posix return 1 if some hanks failed and 2 in case of trouble. -;; 0 is a good code in all cases. -;; We'll do the concervative thing. -(defun ediff-patch-return-code-ok (code) - (eq code 0)) -;;; (if (eq (ediff-test-patch-utility) 'traditional) -;;; (eq code 0) -;;; (not (eq code 2)))) - -(defun ediff-patch-file-internal (patch-buf source-filename - &optional startup-hooks) - (setq source-filename (expand-file-name source-filename)) - - (let* ((shell-file-name ediff-shell) - (patch-diagnostics (get-buffer-create "*ediff patch diagnostics*")) - ;; ediff-find-file may use a temp file to do the patch - ;; so, we save source-filename and true-source-filename as a var - ;; that initially is source-filename but may be changed to a temp - ;; file for the purpose of patching. - (true-source-filename source-filename) - (target-filename source-filename) - target-buf buf-to-patch file-name-magic-p - patch-return-code ctl-buf backup-style aux-wind) - - (if (string-match "V" ediff-patch-options) - (error - "Ediff doesn't take the -V option in `ediff-patch-options'--sorry")) - - ;; Make a temp file, if source-filename has a magic file handler (or if - ;; it is handled via auto-mode-alist and similar magic). - ;; Check if there is a buffer visiting source-filename and if they are in - ;; sync; arrange for the deletion of temp file. - (ediff-find-file 'true-source-filename 'buf-to-patch - 'ediff-last-dir-patch 'startup-hooks) - - ;; Check if source file name has triggered black magic, such as file name - ;; handlers or auto mode alist, and make a note of it. - ;; true-source-filename should be either the original name or a - ;; temporary file where we put the after-product of the file handler. - (setq file-name-magic-p (not (equal (file-truename true-source-filename) - (file-truename source-filename)))) - - ;; Checkout orig file, if necessary, so that the patched file - ;; could be checked back in. - (ediff-maybe-checkout buf-to-patch) - - (ediff-with-current-buffer patch-diagnostics - (insert-buffer patch-buf) - (message "Applying patch ... ") - ;; fix environment for gnu patch, so it won't make numbered extensions - (setq backup-style (getenv "VERSION_CONTROL")) - (setenv "VERSION_CONTROL" nil) - (setq patch-return-code - (call-process-region - (point-min) (point-max) - shell-file-name - t ; delete region (which contains the patch - t ; insert output (patch diagnostics) in current buffer - nil ; don't redisplay - shell-command-switch ; usually -c - (format "%s %s %s %s" - ediff-patch-program - ediff-patch-options - ediff-backup-specs - (expand-file-name true-source-filename)) - )) - - ;; restore environment for gnu patch - (setenv "VERSION_CONTROL" backup-style)) - - (message "Applying patch ... done") - (message "") - - (switch-to-buffer patch-diagnostics) - (sit-for 0) ; synchronize - let the user see diagnostics - - (or (and (ediff-patch-return-code-ok patch-return-code) - (file-exists-p - (concat true-source-filename ediff-backup-extension))) - (progn - (with-output-to-temp-buffer ediff-msg-buffer - (princ (format - "Patch program has failed due to a bad patch file, -it couldn't apply all hunks, OR -it couldn't create the backup for the file being patched. - -The former could be caused by a corrupt patch file or because the %S -program doesn't understand the format of the patch file in use. - -The second problem might be due to an incompatibility among these settings: - ediff-patch-program = %S ediff-patch-options = %S - ediff-backup-extension = %S ediff-backup-specs = %S - -See Ediff on-line manual for more details on these variables. -In particular, check the documentation for `ediff-backup-specs'. - -In any of the above cases, Ediff doesn't compare files automatically. -However, if the patch was applied partially and the backup file was created, -you can still examine the changes via M-x ediff-files" - ediff-patch-program - ediff-patch-program - ediff-patch-options - ediff-backup-extension - ediff-backup-specs - ))) - (beep 1) - (if (setq aux-wind (get-buffer-window ediff-msg-buffer)) - (progn - (select-window aux-wind) - (goto-char (point-max)))) - (switch-to-buffer-other-window patch-diagnostics) - (error "Patch appears to have failed"))) - - ;; If black magic is involved, apply patch to a temp copy of the - ;; file. Otherwise, apply patch to the orig copy. If patch is applied - ;; to temp copy, we name the result old-name_patched for local files - ;; and temp-copy_patched for remote files. The orig file name isn't - ;; changed, and the temp copy of the original is later deleted. - ;; Without magic, the original file is renamed (usually into - ;; old-name_orig) and the result of patching will have the same name as - ;; the original. - (if (not file-name-magic-p) - (ediff-with-current-buffer buf-to-patch - (set-visited-file-name - (concat source-filename ediff-backup-extension)) - (set-buffer-modified-p nil)) - - ;; Black magic in effect. - ;; If orig file was remote, put the patched file in the temp directory. - ;; If orig file is local, put the patched file in the directory of - ;; the orig file. - (setq target-filename - (concat - (if (ediff-file-remote-p (file-truename source-filename)) - true-source-filename - source-filename) - "_patched")) - - (rename-file true-source-filename target-filename t) - - ;; arrange that the temp copy of orig will be deleted - (rename-file (concat true-source-filename ediff-backup-extension) - true-source-filename t)) - - ;; make orig buffer read-only - (setq startup-hooks - (cons 'ediff-set-read-only-in-buf-A startup-hooks)) - - ;; set up a buf for the patched file - (setq target-buf (find-file-noselect target-filename)) - - (setq ctl-buf - (ediff-buffers-internal - buf-to-patch target-buf nil - startup-hooks 'epatch)) - (ediff-with-current-buffer ctl-buf - (setq ediff-patchbufer patch-buf - ediff-patch-diagnostics patch-diagnostics)) - - (bury-buffer patch-diagnostics) - (message "Type `P', if you need to see patch diagnostics") - ctl-buf)) - -(defun ediff-multi-patch-internal (patch-buf &optional startup-hooks) - (let (meta-buf) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons (` (lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function - 'ediff-patch-file-form-meta - ediff-meta-patchbufer patch-buf) - )) - startup-hooks)) - (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action - (ediff-with-current-buffer patch-buf - ;; nil replaces a regular expression - (cons (list nil (format "%S" patch-buf)) - ediff-patch-map)) - "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer - 'ediff-multifile-patch - startup-hooks)) - (ediff-show-meta-buffer meta-buf) - )) - - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-ptch.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-tbar.el --- a/lisp/ediff/ediff-tbar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,371 +0,0 @@ -;;; ediff-tbar.el --- A toolbar for Ediff control buffer - -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. - -;; Author: Marc Paquette - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-tbar) - -;; compiler pacifier -(defvar toolbar-icon-directory) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defvar ediff-use-toolbar-p nil - "If t, Ediff will use a toolbar for the control frame. -This has an effect only if your emacs supports Toolbars. -Currently, XEmacs does, but not Emacs. -Do not change the value of this variable interactively. -This should be done only via the menu bar or by executing -`ediff-toggle-use-toolbar'.") - -(defvar ediff-toolbar-height 21 - "The height of the Ediff toolbar. -The value must match the actual size of the toolbar icons.") - -(defvar ediff-toolbar-width 200.0 - "The width of the Ediff toolbar. -The value must match the actual width of the toolbar. -Here's an example: - There are 10 buttons, each 15 pixels large, and the shadows occupy 2 - pixels each side, and the last button is right-justified (so we reserve - about 30 pixels for fill space) = 200 pixels.") - -(defun ediff-has-toolbar-support-p () - (and ediff-xemacs-p - (featurep 'toolbar) - (console-on-window-system-p))) - -(defun ediff-use-toolbar-p () - (and (ediff-has-toolbar-support-p) ;Can it do it ? - ediff-use-toolbar-p)) ;Does the user want it ? - -;; Here the toolbar width is not the same width talked about in XEmacs -;; lispref info documentation : it is the minimal width needed by -;; ediff's toolbar to display all buttons, for an horizontal toolbar. -;; Ideally, we would query the toolbar for the width of each button -;; and add them, but I didn't find query functions in the doc on -;; toolbars. Therefore, I use a static number of pixels that should -;; be adjusted if the toolbar gets more or loses some buttons. --marcpa -(defun ediff-compute-toolbar-width () - (if (not (ediff-use-toolbar-p)) - 0 - (ceiling (/ ediff-toolbar-width (font-instance-width (face-font-instance 'default)))))) - -(defvar ediff-toolbar-next-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-next.xpm" "ediff-next.xbm") - toolbar-icon-directory))) - "Next difference icon in toolbar.") - -(defvar ediff-toolbar-previous-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-prev.xpm" "ediff-prev.xbm") - toolbar-icon-directory))) - "Previous difference icon in toolbar.") - -(defvar ediff-toolbar-A-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-A-up.xpm" "ediff-A-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DOWN - (if (featurep 'xpm) "ediff-A-up.xpm" "ediff-A-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DISABLED - (if (featurep 'xpm) "ediff-A-xx.xpm" "ediff-A-up.xbm") - toolbar-icon-directory) - )) - "Select diff A icon in toolbar.") - -(defvar ediff-toolbar-B-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-B-up.xpm" "ediff-B-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DOWN - (if (featurep 'xpm) "ediff-B-up.xpm" "ediff-B-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DISABLED - (if (featurep 'xpm) "ediff-B-xx.xpm" "ediff-B-up.xbm") - toolbar-icon-directory) - )) - "Select diff B icon in toolbar.") - -(defvar ediff-toolbar-toggle-split-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) - "ediff-toggle-split-up.xpm" "ediff-toggle-split-up.xbm") - toolbar-icon-directory) - )) - "Toggle split mode between side-to-side and one-on-top-of-another.") - -(defvar ediff-toolbar-save-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-save.xpm" "ediff-save.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DOWN - (if (featurep 'xpm) "ediff-save.xpm" "ediff-save.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DISABLED - (if (featurep 'xpm) "ediff-save-xx.xpm" "ediff-save-xx.xbm") - toolbar-icon-directory) - )) - "Save merge buffer.") - -(defvar ediff-toolbar-quit-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-quit.xpm" "ediff-quit.xbm") - toolbar-icon-directory))) - "Exit Ediff session.") - -(defvar ediff-toolbar-help-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-help.xpm" "ediff-help.xbm") - toolbar-icon-directory))) - "Show Ediff help.") - -(defvar ediff-toolbar-refresh-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-update.xpm" "ediff-update.xbm") - toolbar-icon-directory))) - "Refresh Ediff display (aka recenter).") - -(defvar ediff-toolbar-refine-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-refine.xpm" "ediff-refine.xbm") - toolbar-icon-directory) - )) - "Refine current difference region by computing fine diffs.") - -(defun ediff-toolbar-previous-difference () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-previous-difference 1))) - -(defun ediff-toolbar-next-difference () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-next-difference 1))) - -(defun ediff-toolbar-select/copy-A () - (interactive) - (let ((ediff-grab-mouse nil)) - (cond ((or (ediff-merge-job) - (ediff-merge-with-ancestor-job)) - (ediff-copy-A-to-C nil)) - (t - (ediff-copy-A-to-B nil))))) - -(defun ediff-toolbar-select/copy-B () - (interactive) - (let ((ediff-grab-mouse nil)) - (cond ((or (ediff-merge-job) - (ediff-merge-with-ancestor-job)) - (ediff-copy-B-to-C nil)) - (t - (ediff-copy-B-to-A nil))))) - -(defun ediff-toolbar-toggle-split () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-toggle-split))) - - -(defun ediff-toolbar-save () - (interactive) - (ediff-barf-if-not-control-buffer) - (if (ediff-merge-job) - (ediff-maybe-save-and-delete-merge 'save-and-continue) - ;; 2-way or 3-way compare: save modified buffers - (mapcar (function - (lambda (type) - (let ((ebuf (ediff-get-buffer type))) - (and (ediff-buffer-live-p ebuf) - (ediff-with-current-buffer ebuf - (and (buffer-modified-p) - (save-buffer))))))) - '(A B C)))) - - -(defun ediff-toolbar-quit () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-quit nil))) - -(defun ediff-toolbar-help () - (interactive) - (ediff-toggle-help)) - -(defun ediff-toolbar-refresh () - "Recenter" - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-recenter))) - -(defun ediff-toolbar-refine () - "Refine current difference region by computing fine diffs." - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-make-or-kill-fine-diffs 'make-them))) - -(defun ediff-toolbar-refine-needed-p () - (and (> ediff-current-difference 0) - (> ediff-auto-refine-limit - (- (ediff-get-diff-posn 'A 'end ediff-current-difference) - (ediff-get-diff-posn 'A 'beg ediff-current-difference))))) - -(defvar ediff-toolbar - (if (featurep 'toolbar) - '([ediff-toolbar-refine-icon - ediff-toolbar-refine - t - ;;; The toolbar is not automatically refreshed (in 19.14) - ;;; when :activep changes state. - ;;(ediff-toolbar-refine-needed-p) - "Refine current difference region by computing fine diffs."] - [ediff-toolbar-previous-icon - ediff-toolbar-previous-difference - t - "Go to the previous difference."] - [ediff-toolbar-next-icon - ediff-toolbar-next-difference - t - "Advance to the next difference."] - [ediff-toolbar-A-icon - ediff-toolbar-select/copy-A - (not (ediff-3way-comparison-job)) - "Select/Copy difference A."] - [ediff-toolbar-B-icon - ediff-toolbar-select/copy-B - (not (ediff-3way-comparison-job)) - "Select/Copy difference B."] - [ediff-toolbar-save-icon - ediff-toolbar-save - t - "Save buffers modified in this session."] - [ediff-toolbar-refresh-icon - ediff-toolbar-refresh - t - "Refresh Ediff display (aka recenter)."] - [ediff-toolbar-toggle-split-icon - ediff-toolbar-toggle-split - t - "Toggle split mode between side-to-side and one-on-top-of-another."] - [ediff-toolbar-help-icon - ediff-toolbar-help - t - "Toggle short/long help."] - nil - [ediff-toolbar-quit-icon - ediff-toolbar-quit - t - "Quit this ediff session."] - ))) - -(defvar ediff-toolbar-3way - (if (featurep 'toolbar) - '([ediff-toolbar-refine-icon - ediff-toolbar-refine - t - ;;; The toolbar is not automatically refreshed (in 19.14) - ;;; when :activep changes state. - ;;(ediff-toolbar-refine-needed-p) - "Refine current difference region by computing fine diffs."] - [ediff-toolbar-previous-icon - ediff-toolbar-previous-difference - t - "Go to the previous difference."] - [ediff-toolbar-next-icon - ediff-toolbar-next-difference - t - "Advance to the next difference."] - [ediff-toolbar-save-icon - ediff-toolbar-save - t - "Save buffers modified in this session."] - [ediff-toolbar-refresh-icon - ediff-toolbar-refresh - t - "Refresh Ediff display (aka recenter)."] - [ediff-toolbar-toggle-split-icon - ediff-toolbar-toggle-split - t - "Toggle split mode between side-to-side and one-on-top-of-another."] - [ediff-toolbar-help-icon - ediff-toolbar-help - t - "Toggle short/long help."] - nil - [ediff-toolbar-quit-icon - ediff-toolbar-quit - t - "Quit this ediff session."] - ))) - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-tbar.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-util.el --- a/lisp/ediff/ediff-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3729 +0,0 @@ -;;; ediff-util.el --- the core commands and utilities of ediff - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-util) - -;; Compiler pacifier -(defvar ediff-patch-diagnostics) -(defvar ediff-patchbufer) -(defvar ediff-toolbar) -(defvar ediff-toolbar-3way) -(defvar bottom-toolbar) -(defvar bottom-toolbar-visible-p) -(defvar bottom-toolbar-height) -(defvar mark-active) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-help) - (load "ediff-help.el" nil nil 'nosuffix)) - (or (featurep 'ediff-mult) - (load "ediff-mult.el" nil nil 'nosuffix)) - (or (featurep 'ediff-wind) - (load "ediff-wind.el" nil nil 'nosuffix)) - (or (featurep 'ediff-diff) - (load "ediff-diff.el" nil nil 'nosuffix)) - (or (featurep 'ediff-merg) - (load "ediff-merg.el" nil nil 'nosuffix)) - (or (featurep 'ediff) - (load "ediff.el" nil nil 'nosuffix)) - (or (featurep 'ediff-tbar) - (load "ediff-tbar.el" 'noerror nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) -(require 'ediff-help) -(require 'ediff-mult) -(require 'ediff-wind) -(require 'ediff-diff) -(require 'ediff-merg) - - -;; be careful with ediff-tbar -(if ediff-xemacs-p - (condition-case nil - (require 'ediff-tbar) - (error - (defun ediff-use-toolbar-p () nil))) - (defun ediff-use-toolbar-p () nil)) - - -;;; Functions - -(defun ediff-mode () - "Ediff mode controls all operations in a single Ediff session. -This mode is entered through one of the following commands: - `ediff' - `ediff-files' - `ediff-buffers' - `ebuffers' - `ediff3' - `ediff-files3' - `ediff-buffers3' - `ebuffers3' - `ediff-merge' - `ediff-merge-files' - `ediff-merge-files-with-ancestor' - `ediff-merge-buffers' - `ediff-merge-buffers-with-ancestor' - `ediff-merge-revisions' - `ediff-merge-revisions-with-ancestor' - `ediff-windows-wordwise' - `ediff-windows-linewise' - `ediff-regions-wordwise' - `ediff-regions-linewise' - `epatch' - `ediff-patch-file' - `ediff-patch-buffer' - `epatch-buffer' - `erevision' - `ediff-revision' - -Commands: -\\{ediff-mode-map}" - (kill-all-local-variables) - (setq major-mode 'ediff-mode) - (setq mode-name "Ediff") - (run-hooks 'ediff-mode-hook)) - - - -;;; Build keymaps - -(ediff-defvar-local ediff-mode-map nil - "Local keymap used in Ediff mode. -This is local to each Ediff Control Panel, so they may vary from invocation -to invocation.") - -;; Set up the keymap in the control buffer -(defun ediff-set-keys () - "Set up Ediff keymap, if necessary." - (if (null ediff-mode-map) - (ediff-setup-keymap)) - (use-local-map ediff-mode-map)) - -;; Reload Ediff keymap. For debugging only. -(defun ediff-reload-keymap () - (interactive) - (setq ediff-mode-map nil) - (ediff-set-keys)) - - -(defun ediff-setup-keymap () - "Set up the keymap used in the control buffer of Ediff." - (setq ediff-mode-map (make-sparse-keymap)) - (suppress-keymap ediff-mode-map) - - (define-key ediff-mode-map - (if ediff-emacs-p [mouse-2] [button2]) 'ediff-help-for-quick-help) - (define-key ediff-mode-map "\C-m" 'ediff-help-for-quick-help) - - (define-key ediff-mode-map "p" 'ediff-previous-difference) - (define-key ediff-mode-map "\C-?" 'ediff-previous-difference) - (define-key ediff-mode-map [delete] 'ediff-previous-difference) - (define-key ediff-mode-map "\C-h" (if ediff-no-emacs-help-in-control-buffer - 'ediff-previous-difference nil)) - ;; must come after C-h, or else C-h wipes out backspace's binding in XEmacs - (define-key ediff-mode-map [backspace] 'ediff-previous-difference) - (define-key ediff-mode-map "n" 'ediff-next-difference) - (define-key ediff-mode-map " " 'ediff-next-difference) - (define-key ediff-mode-map "j" 'ediff-jump-to-difference) - (define-key ediff-mode-map "g" nil) - (define-key ediff-mode-map "ga" 'ediff-jump-to-difference-at-point) - (define-key ediff-mode-map "gb" 'ediff-jump-to-difference-at-point) - (define-key ediff-mode-map "q" 'ediff-quit) - (define-key ediff-mode-map "D" 'ediff-show-diff-output) - (define-key ediff-mode-map "z" 'ediff-suspend) - (define-key ediff-mode-map "\C-l" 'ediff-recenter) - (define-key ediff-mode-map "|" 'ediff-toggle-split) - (define-key ediff-mode-map "h" 'ediff-toggle-hilit) - (or ediff-word-mode - (define-key ediff-mode-map "@" 'ediff-toggle-autorefine)) - (if ediff-narrow-job - (define-key ediff-mode-map "%" 'ediff-toggle-narrow-region)) - (define-key ediff-mode-map "~" 'ediff-swap-buffers) - (define-key ediff-mode-map "v" 'ediff-scroll-vertically) - (define-key ediff-mode-map "\C-v" 'ediff-scroll-vertically) - (define-key ediff-mode-map "^" 'ediff-scroll-vertically) - (define-key ediff-mode-map "\M-v" 'ediff-scroll-vertically) - (define-key ediff-mode-map "V" 'ediff-scroll-vertically) - (define-key ediff-mode-map "<" 'ediff-scroll-horizontally) - (define-key ediff-mode-map ">" 'ediff-scroll-horizontally) - (define-key ediff-mode-map "i" 'ediff-status-info) - (define-key ediff-mode-map "E" 'ediff-documentation) - (define-key ediff-mode-map "?" 'ediff-toggle-help) - (define-key ediff-mode-map "!" 'ediff-update-diffs) - (define-key ediff-mode-map "M" 'ediff-show-meta-buffer) - (define-key ediff-mode-map "R" 'ediff-show-registry) - (or ediff-word-mode - (define-key ediff-mode-map "*" 'ediff-make-or-kill-fine-diffs)) - (define-key ediff-mode-map "a" nil) - (define-key ediff-mode-map "b" nil) - (define-key ediff-mode-map "r" nil) - (cond (ediff-merge-job - ;; Will barf if no ancestor - (define-key ediff-mode-map "/" 'ediff-show-ancestor) - ;; In merging, we allow only A->C and B->C copying. - (define-key ediff-mode-map "a" 'ediff-copy-A-to-C) - (define-key ediff-mode-map "b" 'ediff-copy-B-to-C) - (define-key ediff-mode-map "r" 'ediff-restore-diff-in-merge-buffer) - (define-key ediff-mode-map "s" 'ediff-shrink-window-C) - (define-key ediff-mode-map "+" 'ediff-combine-diffs) - (define-key ediff-mode-map "$" 'ediff-toggle-show-clashes-only) - (define-key ediff-mode-map "&" 'ediff-re-merge)) - (ediff-3way-comparison-job - (define-key ediff-mode-map "ab" 'ediff-copy-A-to-B) - (define-key ediff-mode-map "ba" 'ediff-copy-B-to-A) - (define-key ediff-mode-map "ac" 'ediff-copy-A-to-C) - (define-key ediff-mode-map "bc" 'ediff-copy-B-to-C) - (define-key ediff-mode-map "c" nil) - (define-key ediff-mode-map "ca" 'ediff-copy-C-to-A) - (define-key ediff-mode-map "cb" 'ediff-copy-C-to-B) - (define-key ediff-mode-map "ra" 'ediff-restore-diff) - (define-key ediff-mode-map "rb" 'ediff-restore-diff) - (define-key ediff-mode-map "rc" 'ediff-restore-diff) - (define-key ediff-mode-map "C" 'ediff-toggle-read-only)) - (t ; 2-way comparison - (define-key ediff-mode-map "a" 'ediff-copy-A-to-B) - (define-key ediff-mode-map "b" 'ediff-copy-B-to-A) - (define-key ediff-mode-map "ra" 'ediff-restore-diff) - (define-key ediff-mode-map "rb" 'ediff-restore-diff)) - ) ; cond - (define-key ediff-mode-map "G" 'ediff-submit-report) - (define-key ediff-mode-map "#" nil) - (define-key ediff-mode-map "#h" 'ediff-toggle-regexp-match) - (define-key ediff-mode-map "#f" 'ediff-toggle-regexp-match) - (or ediff-word-mode - (define-key ediff-mode-map "##" 'ediff-toggle-skip-similar)) - (define-key ediff-mode-map "o" nil) - (define-key ediff-mode-map "A" 'ediff-toggle-read-only) - (define-key ediff-mode-map "B" 'ediff-toggle-read-only) - (define-key ediff-mode-map "w" nil) - (define-key ediff-mode-map "wa" 'ediff-save-buffer) - (define-key ediff-mode-map "wb" 'ediff-save-buffer) - (define-key ediff-mode-map "wd" 'ediff-save-buffer) - (define-key ediff-mode-map "=" 'ediff-inferior-compare-regions) - (if (fboundp 'ediff-show-patch-diagnostics) - (define-key ediff-mode-map "P" 'ediff-show-patch-diagnostics)) - (if ediff-3way-job - (progn - (define-key ediff-mode-map "wc" 'ediff-save-buffer) - (define-key ediff-mode-map "gc" 'ediff-jump-to-difference-at-point) - )) - - (define-key ediff-mode-map "m" 'ediff-toggle-wide-display) - - ;; Allow ediff-mode-map to be referenced indirectly - (fset 'ediff-mode-map ediff-mode-map) - (run-hooks 'ediff-keymap-setup-hook)) - - -;;; Setup functions - -;; Common startup entry for all Ediff functions It now returns control buffer -;; so other functions can do post-processing SETUP-PARAMETERS is a list of the -;; form ((param .val) (param . val)...) This serves a similar purpose to -;; STARTUP-HOOKS, but these parameters are set in the new control buffer right -;; after this buf is created and before any windows are set and such. -(defun ediff-setup (buffer-A file-A buffer-B file-B buffer-C file-C - startup-hooks setup-parameters) - ;; ediff-convert-standard-filename puts file names in the form appropriate - ;; for the OS at hand. - (setq file-A (ediff-convert-standard-filename (expand-file-name file-A))) - (setq file-B (ediff-convert-standard-filename (expand-file-name file-B))) - (if (stringp file-C) - (setq file-C - (ediff-convert-standard-filename (expand-file-name file-C)))) - (let* ((control-buffer-name - (ediff-unique-buffer-name "*Ediff Control Panel" "*")) - (control-buffer (ediff-with-current-buffer buffer-A - (get-buffer-create control-buffer-name)))) - (ediff-with-current-buffer control-buffer - (ediff-mode) - - (make-local-variable 'ediff-use-long-help-message) - (make-local-variable 'ediff-prefer-iconified-control-frame) - (make-local-variable 'ediff-split-window-function) - (make-local-variable 'ediff-default-variant) - (make-local-variable 'ediff-merge-window-share) - (make-local-variable 'ediff-window-setup-function) - (make-local-variable 'ediff-keep-variants) - - ;; unwrap set up parameters passed as argument - (while setup-parameters - (set (car (car setup-parameters)) (cdr (car setup-parameters))) - (setq setup-parameters (cdr setup-parameters))) - - ;; set variables classifying the current ediff job - ;; must come AFTER setup-parameters - (setq ediff-3way-comparison-job (ediff-3way-comparison-job) - ediff-merge-job (ediff-merge-job) - ediff-merge-with-ancestor-job (ediff-merge-with-ancestor-job) - ediff-3way-job (ediff-3way-job) - ediff-diff3-job (ediff-diff3-job) - ediff-narrow-job (ediff-narrow-job) - ediff-windows-job (ediff-windows-job) - ediff-word-mode-job (ediff-word-mode-job)) - - ;; Don't delete variants in case of ediff-buffer-* jobs without asking. - ;; This is because u may loose work---dangerous. - (if (string-match "buffer" (symbol-name ediff-job-name)) - (setq ediff-keep-variants t)) - - (make-local-hook 'pre-command-hook) - (if (ediff-window-display-p) - (add-hook 'pre-command-hook 'ediff-spy-after-mouse nil t)) - (setq ediff-mouse-pixel-position (mouse-pixel-position)) - - ;; adjust for merge jobs - (if ediff-merge-job - (let ((buf - ;; If default variant is `combined', the right stuff is - ;; inserted by ediff-do-merge - ;; Note: at some point, we tried to put ancestor buffer here - ;; (which is currently buffer C. This didn't work right - ;; because the merge buffer will contain lossage: diff regions - ;; in the ancestor, which correspond to revisions that agree - ;; in both buf A and B. - (cond ((eq ediff-default-variant 'default-B) - buffer-B) - (t buffer-A)))) - - (setq ediff-split-window-function - ediff-merge-split-window-function) - - ;; remember the ancestor buffer, if any - (setq ediff-ancestor-buffer buffer-C) - - (setq buffer-C - (get-buffer-create - (ediff-unique-buffer-name "*ediff-merge" "*"))) - (save-excursion - (set-buffer buffer-C) - (insert-buffer buf) - (funcall (ediff-with-current-buffer buf major-mode)) - ;; after Stig@hackvan.com - (add-hook 'local-write-file-hooks 'ediff-set-merge-mode nil t) - ))) - (setq buffer-read-only nil - ediff-buffer-A buffer-A - ediff-buffer-B buffer-B - ediff-buffer-C buffer-C - ediff-control-buffer control-buffer) - - (setq ediff-control-buffer-suffix - (if (string-match "<[0-9]*>" control-buffer-name) - (substring control-buffer-name - (match-beginning 0) (match-end 0)) - "") - ediff-control-buffer-number - (max - 0 - (1- - (string-to-number - (substring - ediff-control-buffer-suffix - (or - (string-match "[0-9]+" ediff-control-buffer-suffix) - 0)))))) - - (setq ediff-error-buffer - (get-buffer-create (ediff-unique-buffer-name "*ediff-errors" "*"))) - - (ediff-with-current-buffer buffer-A (ediff-strip-mode-line-format)) - (ediff-with-current-buffer buffer-B (ediff-strip-mode-line-format)) - (if ediff-3way-job - (ediff-with-current-buffer buffer-C (ediff-strip-mode-line-format))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-strip-mode-line-format))) - - (ediff-save-protected-variables) ; save variables to be restored on exit - - ;; ediff-setup-diff-regions-function must be set after setup - ;; parameters are processed. - (setq ediff-setup-diff-regions-function - (if ediff-diff3-job - 'ediff-setup-diff-regions3 - 'ediff-setup-diff-regions)) - - (setq ediff-wide-bounds - (list (ediff-make-bullet-proof-overlay - '(point-min) '(point-max) ediff-buffer-A) - (ediff-make-bullet-proof-overlay - '(point-min) '(point-max) ediff-buffer-B) - (ediff-make-bullet-proof-overlay - '(point-min) '(point-max) ediff-buffer-C))) - - ;; This has effect only on ediff-windows/regions - ;; In all other cases, ediff-visible-region sets visibility bounds to - ;; ediff-wide-bounds, and ediff-narrow-bounds are ignored. - (if ediff-start-narrowed - (setq ediff-visible-bounds ediff-narrow-bounds) - (setq ediff-visible-bounds ediff-wide-bounds)) - - (ediff-set-keys) ; comes after parameter setup - - ;; set up ediff-narrow-bounds, if not set - (or ediff-narrow-bounds - (setq ediff-narrow-bounds ediff-wide-bounds)) - - ;; All these must be inside ediff-with-current-buffer control-buffer, - ;; since these vars are local to control-buffer - ;; These won't run if there are errors in diff - (ediff-with-current-buffer ediff-buffer-A - (ediff-nuke-selective-display) - (run-hooks 'ediff-prepare-buffer-hook) - (if (ediff-with-current-buffer control-buffer ediff-merge-job) - (setq buffer-read-only t)) - ;; add control-buffer to the list of sessions--no longer used, but may - ;; be used again in the future - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer ediff-this-buffer-ediff-sessions))) - (if ediff-make-buffers-readonly-at-startup - (setq buffer-read-only t)) - ) - - (ediff-with-current-buffer ediff-buffer-B - (ediff-nuke-selective-display) - (run-hooks 'ediff-prepare-buffer-hook) - (if (ediff-with-current-buffer control-buffer ediff-merge-job) - (setq buffer-read-only t)) - ;; add control-buffer to the list of sessions - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer ediff-this-buffer-ediff-sessions))) - (if ediff-make-buffers-readonly-at-startup - (setq buffer-read-only t)) - ) - - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (ediff-nuke-selective-display) - (run-hooks 'ediff-prepare-buffer-hook) - ;; add control-buffer to the list of sessions - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer - ediff-this-buffer-ediff-sessions))) - (if ediff-make-buffers-readonly-at-startup - (setq buffer-read-only t)) - )) - - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-nuke-selective-display) - (setq buffer-read-only t) - (run-hooks 'ediff-prepare-buffer-hook) - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer - ediff-this-buffer-ediff-sessions))) - )) - - ;; must come after setting up ediff-narrow-bounds AND after - ;; nuking selective display - (funcall ediff-setup-diff-regions-function file-A file-B file-C) - (setq ediff-number-of-differences (length ediff-difference-vector-A)) - (setq ediff-current-difference -1) - - (ediff-make-current-diff-overlay 'A) - (ediff-make-current-diff-overlay 'B) - (if ediff-3way-job - (ediff-make-current-diff-overlay 'C)) - (if ediff-merge-with-ancestor-job - (ediff-make-current-diff-overlay 'Ancestor)) - - (ediff-setup-windows buffer-A buffer-B buffer-C control-buffer) - - (let ((shift-A (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds))) - (shift-B (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds))) - (shift-C (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'C ediff-narrow-bounds)))) - ;; position point in buf A - (save-excursion - (select-window ediff-window-A) - (goto-char shift-A)) - ;; position point in buf B - (save-excursion - (select-window ediff-window-B) - (goto-char shift-B)) - (if ediff-3way-job - (save-excursion - (select-window ediff-window-C) - (goto-char shift-C))) - ) - - (select-window ediff-control-window) - (ediff-visible-region) - - (run-hooks 'startup-hooks) - (ediff-refresh-mode-lines) - (setq buffer-read-only t) - (setq ediff-session-registry - (cons control-buffer ediff-session-registry)) - (ediff-update-registry) - (if (ediff-buffer-live-p ediff-meta-buffer) - (ediff-update-meta-buffer ediff-meta-buffer)) - (run-hooks 'ediff-startup-hook) - ) ; eval in control-buffer - control-buffer)) - - -;; This function assumes that we are in the window where control buffer is -;; to reside. -(defun ediff-setup-control-buffer (ctl-buf) - "Set up window for control buffer." - (if (window-dedicated-p (selected-window)) - (set-buffer ctl-buf) ; we are in control frame but just in case - (switch-to-buffer ctl-buf)) - (let ((window-min-height 2)) - (erase-buffer) - (ediff-set-help-message) - (insert ediff-help-message) - (shrink-window-if-larger-than-buffer) - (or (ediff-multiframe-setup-p) - (ediff-indent-help-message)) - (ediff-set-help-overlays) - - (set-buffer-modified-p nil) - (ediff-refresh-mode-lines) - (setq ediff-control-window (selected-window)) - (setq ediff-window-config-saved - (format "%S%S%S%S%S%S%S" - ediff-control-window - ediff-window-A - ediff-window-B - ediff-window-C - ediff-split-window-function - (ediff-multiframe-setup-p) - ediff-wide-display-p)) - - ;; In multiframe, toolbar is set in ediff-setup-control-frame - (if (not (ediff-multiframe-setup-p)) - (ediff-make-bottom-toolbar)) ; this checks if toolbar is requested - (goto-char (point-min)) - (skip-chars-forward ediff-whitespace))) - - - - -;;; Commands for working with Ediff - -(defun ediff-update-diffs () - "Recompute difference regions in buffers A, B, and C. -Buffers are not synchronized with their respective files, so changes done -to these buffers are not saved at this point---the user can do this later, -if necessary." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (and (ediff-buffer-live-p ediff-ancestor-buffer) - (not - (y-or-n-p - "Ancestor buffer will not be used. Recompute diffs anyway? "))) - (error "Recomputation of differences canceled")) - - (let ((point-A (ediff-with-current-buffer ediff-buffer-A (point))) - ;;(point-B (ediff-with-current-buffer ediff-buffer-B (point))) - (tmp-buffer (get-buffer-create ediff-tmp-buffer)) - (buf-A-file-name (buffer-file-name ediff-buffer-A)) - (buf-B-file-name (buffer-file-name ediff-buffer-B)) - ;; (null ediff-buffer-C) is no problem, as we later check if - ;; ediff-buffer-C is alive - (buf-C-file-name (buffer-file-name ediff-buffer-C)) - (overl-A (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds)) - (overl-B (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds)) - (overl-C (ediff-get-value-according-to-buffer-type - 'C ediff-narrow-bounds)) - beg-A end-A beg-B end-B beg-C end-C - file-A file-B file-C) - - (if (stringp buf-A-file-name) - (setq buf-A-file-name (file-name-nondirectory buf-A-file-name))) - (if (stringp buf-B-file-name) - (setq buf-B-file-name (file-name-nondirectory buf-B-file-name))) - (if (stringp buf-C-file-name) - (setq buf-C-file-name (file-name-nondirectory buf-C-file-name))) - - (ediff-unselect-and-select-difference -1) - - (setq beg-A (ediff-overlay-start overl-A) - beg-B (ediff-overlay-start overl-B) - beg-C (ediff-overlay-start overl-C) - end-A (ediff-overlay-end overl-A) - end-B (ediff-overlay-end overl-B) - end-C (ediff-overlay-end overl-C)) - - (if ediff-word-mode - (progn - (ediff-wordify beg-A end-A ediff-buffer-A tmp-buffer) - (setq file-A (ediff-make-temp-file tmp-buffer "regA")) - (ediff-wordify beg-B end-B ediff-buffer-B tmp-buffer) - (setq file-B (ediff-make-temp-file tmp-buffer "regB")) - (if ediff-3way-job - (progn - (ediff-wordify beg-C end-C ediff-buffer-C tmp-buffer) - (setq file-C (ediff-make-temp-file tmp-buffer "regC")))) - ) - ;; not word-mode - (setq file-A (ediff-make-temp-file ediff-buffer-A buf-A-file-name)) - (setq file-B (ediff-make-temp-file ediff-buffer-B buf-B-file-name)) - (if ediff-3way-job - (setq file-C (ediff-make-temp-file ediff-buffer-C buf-C-file-name))) - ) - - (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also) - (ediff-clear-diff-vector - 'ediff-difference-vector-Ancestor 'fine-diffs-also) - ;; let them garbage collect. we can't use the ancestor after recomputing - ;; the diffs. - (setq ediff-difference-vector-Ancestor nil - ediff-ancestor-buffer nil - ediff-state-of-merge nil) - - (setq ediff-killed-diffs-alist nil) ; invalidate saved killed diff regions - - ;; In case of merge job, fool it into thinking that it is just doing - ;; comparison - (let ((ediff-setup-diff-regions-function ediff-setup-diff-regions-function) - (ediff-3way-comparison-job ediff-3way-comparison-job) - (ediff-merge-job ediff-merge-job) - (ediff-merge-with-ancestor-job ediff-merge-with-ancestor-job) - (ediff-job-name ediff-job-name)) - (if ediff-merge-job - (setq ediff-setup-diff-regions-function 'ediff-setup-diff-regions3 - ediff-3way-comparison-job t - ediff-merge-job nil - ediff-merge-with-ancestor-job nil - ediff-job-name 'ediff-files3)) - (funcall ediff-setup-diff-regions-function file-A file-B file-C)) - - (setq ediff-number-of-differences (length ediff-difference-vector-A)) - (delete-file file-A) - (delete-file file-B) - (if file-C - (delete-file file-C)) - - (if ediff-3way-job - (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer)) - - (ediff-jump-to-difference (ediff-diff-at-point 'A point-A)) - (message "") - )) - -;; Not bound to any key---to dangerous. A user can do it if necessary. -(defun ediff-revert-buffers-then-recompute-diffs (noconfirm) - "Revert buffers A, B and C. Then rerun Ediff on file A and file B." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (let ((bufA ediff-buffer-A) - (bufB ediff-buffer-B) - (bufC ediff-buffer-C) - (ctl-buf ediff-control-buffer) - (keep-variants ediff-keep-variants) - (ancestor-buf ediff-ancestor-buffer) - (ancestor-job ediff-merge-with-ancestor-job) - (merge ediff-merge-job) - (comparison ediff-3way-comparison-job)) - (ediff-with-current-buffer bufA - (revert-buffer t noconfirm)) - (ediff-with-current-buffer bufB - (revert-buffer t noconfirm)) - ;; this should only be executed in a 3way comparison, not in merge - (if comparison - (ediff-with-current-buffer bufC - (revert-buffer t noconfirm))) - (if merge - (progn - (set-buffer ctl-buf) - ;; the argument says whether to reverse the meaning of - ;; ediff-keep-variants, i.e., ediff-really-quit runs here with - ;; variants kept. - (ediff-really-quit (not keep-variants)) - (kill-buffer bufC) - (if ancestor-job - (ediff-merge-buffers-with-ancestor bufA bufB ancestor-buf) - (ediff-merge-buffers bufA bufB))) - (ediff-update-diffs)))) - - -;; optional NO-REHIGHLIGHT says to not rehighlight buffers -(defun ediff-recenter (&optional no-rehighlight) - "Bring the highlighted region of all buffers being compared into view. -Reestablish the default three-window display." - (interactive) - (ediff-barf-if-not-control-buffer) - (let (buffer-read-only) - (if (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C))) - (ediff-setup-windows - ediff-buffer-A ediff-buffer-B ediff-buffer-C ediff-control-buffer) - (or (eq this-command 'ediff-quit) - (message ediff-KILLED-VITAL-BUFFER - (beep 1))) - )) - - ;; set visibility range appropriate to this invocation of Ediff. - (ediff-visible-region) - ;; raise - (if (and (ediff-window-display-p) - (symbolp this-command) - (symbolp last-command) - ;; Either one of the display-changing commands - (or (memq this-command - '(ediff-recenter - ediff-dir-action ediff-registry-action - ediff-patch-action - ediff-toggle-wide-display ediff-toggle-multiframe)) - ;; Or one of the movement cmds and prev cmd was an Ediff cmd - ;; This avoids raising frames unnecessarily. - (and (memq this-command - '(ediff-next-difference - ediff-previous-difference - ediff-jump-to-difference - ediff-jump-to-difference-at-point)) - (not (string-match "^ediff-" (symbol-name last-command))) - ))) - (progn - (if (window-live-p ediff-window-A) - (raise-frame (window-frame ediff-window-A))) - (if (window-live-p ediff-window-B) - (raise-frame (window-frame ediff-window-B))) - (if (window-live-p ediff-window-C) - (raise-frame (window-frame ediff-window-C))))) - (if (and (ediff-window-display-p) - (frame-live-p ediff-control-frame) - (not ediff-use-long-help-message) - (not (ediff-frame-iconified-p ediff-control-frame))) - (raise-frame ediff-control-frame)) - - ;; Redisplay whatever buffers are showing, if there is a selected difference - (let ((control-frame ediff-control-frame) - (control-buf ediff-control-buffer)) - (if (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C))) - (progn - (or no-rehighlight - (ediff-select-difference ediff-current-difference)) - - (ediff-recenter-one-window 'A) - (ediff-recenter-one-window 'B) - (if ediff-3way-job - (ediff-recenter-one-window 'C)) - - (ediff-with-current-buffer control-buf - (ediff-recenter-ancestor) ; check if ancestor is alive - - (if (and (ediff-multiframe-setup-p) - (not ediff-use-long-help-message) - (not (ediff-frame-iconified-p ediff-control-frame))) - ;; never grab mouse on quit in this place - (ediff-reset-mouse - control-frame - (eq this-command 'ediff-quit)))) - )) - - (ediff-restore-highlighting) - (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines)) - )) - -;; this function returns to the window it was called from -;; (which was the control window) -(defun ediff-recenter-one-window (buf-type) - (if (ediff-valid-difference-p) - ;; context must be saved before switching to windows A/B/C - (let* ((ctl-wind (selected-window)) - (shift (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - buf-type ediff-narrow-bounds))) - (job-name ediff-job-name) - (control-buf ediff-control-buffer) - (window-name (ediff-get-symbol-from-alist - buf-type ediff-window-alist)) - (window (if (window-live-p (symbol-value window-name)) - (symbol-value window-name)))) - - (if (and window ediff-windows-job) - (set-window-start window shift)) - (if window - (progn - (select-window window) - (ediff-deactivate-mark) - (ediff-position-region - (ediff-get-diff-posn buf-type 'beg nil control-buf) - (ediff-get-diff-posn buf-type 'end nil control-buf) - (ediff-get-diff-posn buf-type 'beg nil control-buf) - job-name - ))) - (select-window ctl-wind) - ))) - -(defun ediff-recenter-ancestor () - ;; do half-hearted job by recentering the ancestor buffer, if it is alive and - ;; visible. - (if (and (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-valid-difference-p)) - (let ((window (ediff-get-visible-buffer-window ediff-ancestor-buffer)) - (ctl-wind (selected-window)) - (job-name ediff-job-name) - (ctl-buf ediff-control-buffer)) - (ediff-with-current-buffer ediff-ancestor-buffer - (goto-char (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf)) - (if window - (progn - (select-window window) - (ediff-position-region - (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf) - (ediff-get-diff-posn 'Ancestor 'end nil ctl-buf) - (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf) - job-name)))) - (select-window ctl-wind) - ))) - - -;; This will have to be refined for 3way jobs -(defun ediff-toggle-split () - "Toggle vertical/horizontal window split. -Does nothing if file-A and file-B are in different frames." - (interactive) - (ediff-barf-if-not-control-buffer) - (let* ((wind-A (if (window-live-p ediff-window-A) ediff-window-A)) - (wind-B (if (window-live-p ediff-window-B) ediff-window-B)) - (wind-C (if (window-live-p ediff-window-C) ediff-window-C)) - (frame-A (if wind-A (window-frame wind-A))) - (frame-B (if wind-B (window-frame wind-B))) - (frame-C (if wind-C (window-frame wind-C)))) - (if (or (eq frame-A frame-B) - (not (frame-live-p frame-A)) - (not (frame-live-p frame-B)) - (if ediff-3way-comparison-job - (or (not (frame-live-p frame-C)) - (eq frame-A frame-C) (eq frame-B frame-C)))) - (setq ediff-split-window-function - (if (eq ediff-split-window-function 'split-window-vertically) - 'split-window-horizontally - 'split-window-vertically)) - (message "Buffers being compared are in different frames")) - (ediff-recenter 'no-rehighlight))) - -(defun ediff-toggle-hilit () - "Switch between highlighting using ASCII flags and highlighting using faces. -On a dumb terminal, switches between ASCII highlighting and no highlighting." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (not (ediff-has-face-support-p)) - (if (eq ediff-highlighting-style 'ascii) - (progn - (message "ASCII highlighting flags removed") - (ediff-unselect-and-select-difference ediff-current-difference - 'unselect-only) - (setq ediff-highlighting-style 'off)) - (ediff-unselect-and-select-difference ediff-current-difference - 'select-only)) - (ediff-unselect-and-select-difference ediff-current-difference - 'unselect-only) - ;; cycle through highlighting - (cond ((and ediff-use-faces ediff-highlight-all-diffs) - (message "Unhighlighting unselected difference regions") - (setq ediff-highlight-all-diffs nil)) - (ediff-use-faces - (message "Highlighting with ASCII flags") - (setq ediff-use-faces nil)) - (t - (message "Re-highlighting all difference regions") - (setq ediff-use-faces t - ediff-highlight-all-diffs t))) - - (if (and ediff-use-faces ediff-highlight-all-diffs) - (ediff-paint-background-regions) - (ediff-paint-background-regions 'unhighlight)) - - (ediff-unselect-and-select-difference - ediff-current-difference 'select-only)) - ) - - -(defun ediff-toggle-autorefine () - "Toggle auto-refine mode." - (interactive) - (ediff-barf-if-not-control-buffer) - (if ediff-word-mode - (error "No fine differences in this mode")) - (cond ((eq ediff-auto-refine 'nix) - (setq ediff-auto-refine 'on) - (ediff-make-fine-diffs ediff-current-difference 'noforce) - (message "Auto-refining is ON")) - ((eq ediff-auto-refine 'on) - (message "Auto-refining is OFF") - (setq ediff-auto-refine 'off)) - (t ;; nix 'em - (ediff-set-fine-diff-properties ediff-current-difference 'default) - (message "Refinements are HIDDEN") - (setq ediff-auto-refine 'nix)) - )) - -(defun ediff-show-ancestor () - "Show the ancestor buffer in a suitable window." - (interactive) - (ediff-recenter) - (or (ediff-buffer-live-p ediff-ancestor-buffer) - (if ediff-merge-with-ancestor-job - (error "Lost connection to ancestor buffer...sorry") - (error "Not merging with ancestor"))) - (let (wind) - (cond ((setq wind (ediff-get-visible-buffer-window ediff-ancestor-buffer)) - (raise-frame (window-frame wind))) - (t (set-window-buffer ediff-window-C ediff-ancestor-buffer))))) - -(defun ediff-make-or-kill-fine-diffs (arg) - "Compute fine diffs. With negative prefix arg, kill fine diffs. -In both cases, operates on the currrent difference region." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (cond ((eq arg '-) - (ediff-clear-fine-differences ediff-current-difference)) - ((and (numberp arg) (< arg 0)) - (ediff-clear-fine-differences ediff-current-difference)) - (t (ediff-make-fine-diffs)))) - - -(defun ediff-toggle-help () - "Toggle short/long help message." - (interactive) - (ediff-barf-if-not-control-buffer) - (let (buffer-read-only) - (erase-buffer) - (setq ediff-use-long-help-message (not ediff-use-long-help-message)) - (ediff-set-help-message)) - ;; remember the icon status of the control frame when the user requested - ;; full control message - (if (and ediff-use-long-help-message (ediff-multiframe-setup-p)) - (setq ediff-prefer-iconified-control-frame - (ediff-frame-iconified-p ediff-control-frame))) - - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight)) - - -;; If BUF, this is the buffer to toggle, not current buffer. -(defun ediff-toggle-read-only (&optional buf) - "Toggle read-only in current buffer. -If buffer is under version control and locked, check it out first. -If optional argument BUF is specified, toggle read-only in that buffer instead -of the current buffer." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((ctl-buf (if (null buf) (current-buffer))) - (buf-type (ediff-char-to-buftype last-command-char))) - (or buf (ediff-recenter)) - (or buf - (setq buf (ediff-get-buffer buf-type))) - - (ediff-with-current-buffer buf ; eval in buf A/B/C - (let* ((file (buffer-file-name buf)) - (file-writable (and file - (file-exists-p file) - (file-writable-p file))) - (toggle-ro-cmd (cond (ediff-toggle-read-only-function) - ((ediff-file-checked-out-p file) - 'toggle-read-only) - (file-writable 'toggle-read-only) - (t (key-binding "\C-x\C-q"))))) - ;; If the file is checked in, make sure we don't make buffer modifiable - ;; without warning the user. The user can fool our checks by making the - ;; buffer non-RO without checking the file out. We regard this as a - ;; user problem. - (if (and (ediff-file-checked-in-p file) - ;; If ctl-buf is null, this means we called this - ;; non-interactively, in which case don't ask questions - ctl-buf) - (cond ((not buffer-read-only) - (setq toggle-ro-cmd 'toggle-read-only)) - ((and (or (beep 1) t) ; always beep - (y-or-n-p - (format - "File %s is under version control. Check it out? " - (ediff-abbreviate-file-name file)))) - ;; if we checked the file out, we should also change the - ;; original state of buffer-read-only to nil. If we don't - ;; do this, the mode line will show %%, since the file was - ;; RO before ediff started, so the user will think the file - ;; is checked in. - (ediff-with-current-buffer ctl-buf - (ediff-change-saved-variable - 'buffer-read-only nil buf-type))) - (t - (setq toggle-ro-cmd 'toggle-read-only) - (beep 1) (beep 1) - (message - "Boy, this is risky! Don't modify this file...") - (sit-for 3)))) ; let the user see the warning - (if (and toggle-ro-cmd - (string-match "toggle-read-only" (symbol-name toggle-ro-cmd))) - (save-excursion - (save-window-excursion - (select-window (ediff-get-visible-buffer-window buf)) - (command-execute toggle-ro-cmd))) - (error "Don't know how to toggle read-only in buffer %S" buf)) - - ;; Check if we made the current buffer updatable, but its file is RO. - ;; Signal a warning in this case. - (if (and file (not buffer-read-only) - (eq this-command 'ediff-toggle-read-only) - (file-exists-p file) - (not (file-writable-p file))) - (message "Warning: file %s is read-only" - (ediff-abbreviate-file-name file) (beep 1))) - )))) - -;; checkout if visited file is checked in -(defun ediff-maybe-checkout (buf) - (let ((file (buffer-file-name buf)) - (checkout-function (key-binding "\C-x\C-q"))) - (if (and (ediff-file-checked-in-p file) - (or (beep 1) t) - (y-or-n-p - (format - "File %s is under version control. Check it out? " - (ediff-abbreviate-file-name file)))) - (ediff-with-current-buffer buf - (command-execute checkout-function))))) - - -;; This is a simple-minded check for whether a file is under version control. -;; If file,v exists but file doesn't, this file is considered to be not checked -;; in and not checked out for the purpose of patching (since patch won't be -;; able to read such a file anyway). -;; FILE is a string representing file name -(defun ediff-file-under-version-control (file) - (let* ((filedir (file-name-directory file)) - (file-nondir (file-name-nondirectory file)) - (trial (concat file-nondir ",v")) - (full-trial (concat filedir trial)) - (full-rcs-trial (concat filedir "RCS/" trial))) - (and (stringp file) - (file-exists-p file) - (or - (and - (file-exists-p full-trial) - ;; in FAT FS, `file,v' and `file' may turn out to be the same! - ;; don't be fooled by this! - (not (equal (file-attributes file) - (file-attributes full-trial)))) - ;; check if a version is in RCS/ directory - (file-exists-p full-rcs-trial))) - )) - -(defun ediff-file-checked-out-p (file) - (and (ediff-file-under-version-control file) - (file-writable-p file))) -(defun ediff-file-checked-in-p (file) - (and (ediff-file-under-version-control file) - (not (file-writable-p file)))) - -(defun ediff-swap-buffers () - "Rotate the display of buffers A, B, and C." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)) - (let ((buf ediff-buffer-A) - (values ediff-buffer-values-orig-A) - (diff-vec ediff-difference-vector-A) - (hide-regexp ediff-regexp-hide-A) - (focus-regexp ediff-regexp-focus-A) - (wide-visibility-p (eq ediff-visible-bounds ediff-wide-bounds)) - (overlay (if (ediff-has-face-support-p) - ediff-current-diff-overlay-A))) - (if ediff-3way-comparison-job - (progn - (set-window-buffer ediff-window-A ediff-buffer-C) - (set-window-buffer ediff-window-B ediff-buffer-A) - (set-window-buffer ediff-window-C ediff-buffer-B) - ) - (set-window-buffer ediff-window-A ediff-buffer-B) - (set-window-buffer ediff-window-B ediff-buffer-A)) - ;; swap diff buffers - (if ediff-3way-comparison-job - (setq ediff-buffer-A ediff-buffer-C - ediff-buffer-C ediff-buffer-B - ediff-buffer-B buf) - (setq ediff-buffer-A ediff-buffer-B - ediff-buffer-B buf)) - - ;; swap saved buffer characteristics - (if ediff-3way-comparison-job - (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-C - ediff-buffer-values-orig-C ediff-buffer-values-orig-B - ediff-buffer-values-orig-B values) - (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-B - ediff-buffer-values-orig-B values)) - - ;; swap diff vectors - (if ediff-3way-comparison-job - (setq ediff-difference-vector-A ediff-difference-vector-C - ediff-difference-vector-C ediff-difference-vector-B - ediff-difference-vector-B diff-vec) - (setq ediff-difference-vector-A ediff-difference-vector-B - ediff-difference-vector-B diff-vec)) - - ;; swap hide/focus regexp - (if ediff-3way-comparison-job - (setq ediff-regexp-hide-A ediff-regexp-hide-C - ediff-regexp-hide-C ediff-regexp-hide-B - ediff-regexp-hide-B hide-regexp - ediff-regexp-focus-A ediff-regexp-focus-C - ediff-regexp-focus-C ediff-regexp-focus-B - ediff-regexp-focus-B focus-regexp) - (setq ediff-regexp-hide-A ediff-regexp-hide-B - ediff-regexp-hide-B hide-regexp - ediff-regexp-focus-A ediff-regexp-focus-B - ediff-regexp-focus-B focus-regexp)) - - ;; The following is needed for XEmacs, since there one can't move - ;; overlay to another buffer. In Emacs, this swap is redundant. - (if (ediff-has-face-support-p) - (if ediff-3way-comparison-job - (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-C - ediff-current-diff-overlay-C ediff-current-diff-overlay-B - ediff-current-diff-overlay-B overlay) - (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-B - ediff-current-diff-overlay-B overlay))) - - ;; swap wide bounds - (setq ediff-wide-bounds - (cond (ediff-3way-comparison-job - (list (nth 2 ediff-wide-bounds) - (nth 0 ediff-wide-bounds) - (nth 1 ediff-wide-bounds))) - (ediff-3way-job - (list (nth 1 ediff-wide-bounds) - (nth 0 ediff-wide-bounds) - (nth 2 ediff-wide-bounds))) - (t - (list (nth 1 ediff-wide-bounds) - (nth 0 ediff-wide-bounds))))) - ;; swap narrow bounds - (setq ediff-narrow-bounds - (cond (ediff-3way-comparison-job - (list (nth 2 ediff-narrow-bounds) - (nth 0 ediff-narrow-bounds) - (nth 1 ediff-narrow-bounds))) - (ediff-3way-job - (list (nth 1 ediff-narrow-bounds) - (nth 0 ediff-narrow-bounds) - (nth 2 ediff-narrow-bounds))) - (t - (list (nth 1 ediff-narrow-bounds) - (nth 0 ediff-narrow-bounds))))) - (if wide-visibility-p - (setq ediff-visible-bounds ediff-wide-bounds) - (setq ediff-visible-bounds ediff-narrow-bounds)) - )) - (if ediff-3way-job - (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer)) - (ediff-recenter 'no-rehighlight) - ) - - -(defun ediff-toggle-wide-display () - "Toggle wide/regular display. -This is especially useful when comparing buffers side-by-side." - (interactive) - (ediff-barf-if-not-control-buffer) - (or (ediff-window-display-p) - (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) - (ediff-recenter 'no-rehighlight) ; make sure buffs are displayed in windows - (let ((ctl-buf ediff-control-buffer)) - (setq ediff-wide-display-p (not ediff-wide-display-p)) - (if (not ediff-wide-display-p) - (ediff-with-current-buffer ctl-buf - (modify-frame-parameters - ediff-wide-display-frame ediff-wide-display-orig-parameters) - ;;(sit-for (if ediff-xemacs-p 0.4 0)) - ;; restore control buf, since ctl window may have been deleted - ;; during resizing - (set-buffer ctl-buf) - (setq ediff-wide-display-orig-parameters nil - ediff-window-B nil) ; force update of window config - (ediff-recenter 'no-rehighlight)) - (funcall ediff-make-wide-display-function) - ;;(sit-for (if ediff-xemacs-p 0.4 0)) - (ediff-with-current-buffer ctl-buf - (setq ediff-window-B nil) ; force update of window config - (ediff-recenter 'no-rehighlight))))) - -;;;###autoload -(defun ediff-toggle-multiframe () - "Switch from multiframe display to single-frame display and back. -To change the default, set the variable `ediff-window-setup-function', -which see." - (interactive) - (let (window-setup-func) - (or (ediff-window-display-p) - (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) - - (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe) - (setq window-setup-func 'ediff-setup-windows-plain)) - ((eq ediff-window-setup-function 'ediff-setup-windows-plain) - (if (ediff-in-control-buffer-p) - (ediff-kill-bottom-toolbar)) - (setq window-setup-func 'ediff-setup-windows-multiframe))) - - ;; change default - (setq-default ediff-window-setup-function window-setup-func) - ;; change in all active ediff sessions - (mapcar (function (lambda(buf) - (ediff-with-current-buffer buf - (setq ediff-window-setup-function window-setup-func - ediff-window-B nil)))) - ediff-session-registry) - (if (ediff-in-control-buffer-p) - (ediff-recenter 'no-rehighlight)))) - - -;;;###autoload -(defun ediff-toggle-use-toolbar () - "Enable or disable Ediff toolbar. -Works only in versions of Emacs that support toolbars. -To change the default, set the variable `ediff-use-toolbar-p', which see." - (interactive) - (if (featurep 'ediff-tbar) - (progn - (or (ediff-window-display-p) - (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) - (if (ediff-use-toolbar-p) - (ediff-kill-bottom-toolbar)) - ;; do this only after killing the toolbar - (setq ediff-use-toolbar-p (not ediff-use-toolbar-p)) - - (mapcar (function (lambda(buf) - (ediff-with-current-buffer buf - ;; force redisplay - (setq ediff-window-config-saved "") - ))) - ediff-session-registry) - (if (ediff-in-control-buffer-p) - (ediff-recenter 'no-rehighlight))))) - - -;; if was using toolbar, kill it -(defun ediff-kill-bottom-toolbar () - ;; Using ctl-buffer or ediff-control-window for LOCALE does not - ;; work properly in XEmacs 19.14: we have to use - ;;(selected-frame). - ;; The problem with this is that any previous bottom-toolbar - ;; will not re-appear after our cleanup here. Is there a way - ;; to do "push" and "pop" toolbars ? --marcpa - (if (ediff-use-toolbar-p) - (progn - (set-specifier bottom-toolbar (list (selected-frame) nil)) - (set-specifier bottom-toolbar-visible-p (list (selected-frame) nil))))) - -;; If wants to use toolbar, make it. -;; If not, zero the toolbar for XEmacs. -;; Do nothing for Emacs. -(defun ediff-make-bottom-toolbar (&optional frame) - (if (ediff-window-display-p) - (progn - (setq frame (or frame (selected-frame))) - (cond ((ediff-use-toolbar-p) ; this checks for XEmacs - (set-specifier - bottom-toolbar - (list frame (if (ediff-3way-comparison-job) - ediff-toolbar-3way ediff-toolbar))) - (set-specifier bottom-toolbar-visible-p (list frame t)) - (set-specifier bottom-toolbar-height - (list frame ediff-toolbar-height))) - (ediff-xemacs-p - (set-specifier bottom-toolbar-height (list frame 0))) - )) - )) - -;; Merging - -(defun ediff-toggle-show-clashes-only () - "Toggle the mode where only the regions where both buffers differ with the ancestor are shown." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (not ediff-merge-with-ancestor-job) - (error "This command makes sense only when merging with an ancestor")) - (setq ediff-show-clashes-only (not ediff-show-clashes-only)) - (if ediff-show-clashes-only - (message "Focus on regions where both buffers differ from the ancestor") - (message "Canceling focus on regions where changes clash"))) - -;; Widening/narrowing - -(defun ediff-toggle-narrow-region () - "Toggle narrowing in buffers A, B, and C. -Used in ediff-windows/regions only." - (interactive) - (if (eq ediff-buffer-A ediff-buffer-B) - (error ediff-NO-DIFFERENCES)) - (if (eq ediff-visible-bounds ediff-wide-bounds) - (setq ediff-visible-bounds ediff-narrow-bounds) - (setq ediff-visible-bounds ediff-wide-bounds)) - (ediff-recenter 'no-rehighlight)) - -;; Narrow bufs A/B/C to ediff-visible-bounds. If this is currently set to -;; ediff-wide-bounds, then this actually widens. -;; This function does nothing if job-name is not -;; ediff-regions-wordwise/linewise or ediff-windows-wordwise/linewise. -;; Does nothing if buffer-A = buffer-B since we can't narrow -;; to two different regions in one buffer. -(defun ediff-visible-region () - (if (or (eq ediff-buffer-A ediff-buffer-B) - (eq ediff-buffer-A ediff-buffer-C) - (eq ediff-buffer-C ediff-buffer-B)) - () - ;; If ediff-*-regions/windows, ediff-visible-bounds is already set - ;; Otherwise, always use full range. - (if (not ediff-narrow-job) - (setq ediff-visible-bounds ediff-wide-bounds)) - (let ((overl-A (ediff-get-value-according-to-buffer-type - 'A ediff-visible-bounds)) - (overl-B (ediff-get-value-according-to-buffer-type - 'B ediff-visible-bounds)) - (overl-C (ediff-get-value-according-to-buffer-type - 'C ediff-visible-bounds)) - ) - (ediff-with-current-buffer ediff-buffer-A - (narrow-to-region - (ediff-overlay-start overl-A) (ediff-overlay-end overl-A))) - (ediff-with-current-buffer ediff-buffer-B - (narrow-to-region - (ediff-overlay-start overl-B) (ediff-overlay-end overl-B))) - - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (narrow-to-region - (ediff-overlay-start overl-C) (ediff-overlay-end overl-C)))) - ))) - - -;; Window scrolling operations - -;; Performs some operation on the two file windows (if they are showing). -;; Traps all errors on the operation in windows A/B/C. -;; Usually, errors come from scrolling off the -;; beginning or end of the buffer, and this gives error messages. -(defun ediff-operate-on-windows (operation arg) - - ;; make sure windows aren't dead - (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))) - (ediff-recenter 'no-rehighlight)) - (if (not (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) ediff-buffer-C) - )) - (error ediff-KILLED-VITAL-BUFFER)) - - (let* ((wind (selected-window)) - (wind-A ediff-window-A) - (wind-B ediff-window-B) - (wind-C ediff-window-C) - (coefA (ediff-get-region-size-coefficient 'A operation)) - (coefB (ediff-get-region-size-coefficient 'B operation)) - (three-way ediff-3way-job) - (coefC (if three-way - (ediff-get-region-size-coefficient 'C operation)))) - - (select-window wind-A) - (condition-case nil - (funcall operation (round (* coefA arg))) - (error)) - (select-window wind-B) - (condition-case nil - (funcall operation (round (* coefB arg))) - (error)) - (if three-way - (progn - (select-window wind-C) - (condition-case nil - (funcall operation (round (* coefC arg))) - (error)))) - (select-window wind))) - -(defun ediff-scroll-vertically (&optional arg) - "Vertically scroll buffers A, B \(and C if appropriate\). -With optional argument ARG, scroll ARG lines; otherwise scroll by nearly -the one half of the height of window-A." - (interactive "P") - (ediff-barf-if-not-control-buffer) - - ;; make sure windows aren't dead - (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))) - (ediff-recenter 'no-rehighlight)) - (if (not (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C)) - )) - (error ediff-KILLED-VITAL-BUFFER)) - - (ediff-operate-on-windows - (if (memq last-command-char '(?v ?\C-v)) - 'scroll-up - 'scroll-down) - ;; calculate argument to scroll-up/down - ;; if there is an explicit argument - (if (and arg (not (equal arg '-))) - ;; use it - (prefix-numeric-value arg) - ;; if not, see if we can determine a default amount (the window height) - (let (default-amount) - (setq default-amount - (- (/ (min (window-height ediff-window-A) - (window-height ediff-window-B) - (if ediff-3way-job - (window-height ediff-window-C) - 500)) ; some large number - 2) - 1 next-screen-context-lines)) - ;; window found - (if arg - ;; C-u as argument means half of default amount - (/ default-amount 2) - ;; no argument means default amount - default-amount))))) - - -(defun ediff-scroll-horizontally (&optional arg) - "Horizontally scroll buffers A, B \(and C if appropriate\). -If an argument is given, that is how many columns are scrolled, else nearly -the width of the A/B/C windows." - (interactive "P") - (ediff-barf-if-not-control-buffer) - - ;; make sure windows aren't dead - (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))) - (ediff-recenter 'no-rehighlight)) - (if (not (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C)) - )) - (error ediff-KILLED-VITAL-BUFFER)) - - (ediff-operate-on-windows - (if (= last-command-char ?<) - 'scroll-left - 'scroll-right) - ;; calculate argument to scroll-left/right - ;; if there is an explicit argument - (if (and arg (not (equal arg '-))) - ;; use it - (prefix-numeric-value arg) - ;; if not, see if we can determine a default amount - ;; (half the window width) - (if (null ediff-control-window) - ;; no control window, use nil - nil - (let ((default-amount - (- (/ (min (window-width ediff-window-A) - (window-width ediff-window-B) - (if ediff-3way-comparison-job - (window-width ediff-window-C) - 500) ; some large number - ) - 2) - 3))) - ;; window found - (if arg - ;; C-u as argument means half of default amount - (/ default-amount 2) - ;; no argument means default amount - default-amount)))))) - - -;;BEG, END show the region to be positioned. -;;JOB-NAME holds ediff-job-name. The ediff-windows job positions regions -;;differently. -(defun ediff-position-region (beg end pos job-name) - (if (> end (point-max)) - (setq end (point-max))) - (if ediff-windows-job - (if (pos-visible-in-window-p end) - () ; do nothing, wind is already positioned - ;; at this point, windows are positioned at the beginning of the - ;; file regions (not diff-regions) being compared. - (save-excursion - (move-to-window-line (- (window-height) 2)) - (let ((amount (+ 2 (count-lines (point) end)))) - (scroll-up amount)))) - (set-window-start (selected-window) beg) - (if (pos-visible-in-window-p end) - ;; Determine the number of lines that the region occupies - (let ((lines 0) - (prev-point 0)) - (while ( and (> end (progn - (move-to-window-line lines) - (point))) - ;; `end' may be beyond the window bottom, so check - ;; that we are making progress - (< prev-point (point))) - (setq prev-point (point)) - (setq lines (1+ lines))) - ;; And position the beginning on the right line - (goto-char beg) - (recenter (/ (1+ (max (- (1- (window-height (selected-window))) - lines) - 1) - ) - 2)))) - (goto-char pos) - )) - -;; get number of lines from window start to region end -(defun ediff-get-lines-to-region-end (buf-type &optional n ctl-buf) - (or n (setq n ediff-current-difference)) - (or ctl-buf (setq ctl-buf ediff-control-buffer)) - (ediff-with-current-buffer ctl-buf - (let* ((buf (ediff-get-buffer buf-type)) - (wind (eval (ediff-get-symbol-from-alist - buf-type ediff-window-alist))) - (beg (window-start wind)) - (end (ediff-get-diff-posn buf-type 'end)) - lines) - (ediff-with-current-buffer buf - (if (< beg end) - (setq lines (count-lines beg end)) - (setq lines 0)) - lines - )))) - -;; get number of lines from window end to region start -(defun ediff-get-lines-to-region-start (buf-type &optional n ctl-buf) - (or n (setq n ediff-current-difference)) - (or ctl-buf (setq ctl-buf ediff-control-buffer)) - (ediff-with-current-buffer ctl-buf - (let* ((buf (ediff-get-buffer buf-type)) - (wind (eval (ediff-get-symbol-from-alist - buf-type ediff-window-alist))) - (end (window-end wind)) - (beg (ediff-get-diff-posn buf-type 'beg))) - (ediff-with-current-buffer buf - (if (< beg end) (count-lines beg end) 0)) - ))) - - -;; region size coefficient is a coefficient by which to adjust scrolling -;; up/down of the window displaying buffer of type BUFTYPE. -;; The purpose of this coefficient is to make the windows scroll in sync, so -;; that it won't happen that one diff region is scrolled off while the other is -;; still seen. -;; -;; If the difference region is invalid, the coefficient is 1 -(defun ediff-get-region-size-coefficient (buf-type op &optional n ctl-buf) - (ediff-with-current-buffer (or ctl-buf ediff-control-buffer) - (if (ediff-valid-difference-p n) - (let* ((func (cond ((eq op 'scroll-down) - 'ediff-get-lines-to-region-start) - ((eq op 'scroll-up) - 'ediff-get-lines-to-region-end) - (t '(lambda (a b c) 0)))) - (max-lines (max (funcall func 'A n ctl-buf) - (funcall func 'B n ctl-buf) - (if (ediff-buffer-live-p ediff-buffer-C) - (funcall func 'C n ctl-buf) - 0)))) - ;; this covers the horizontal coefficient as well: - ;; if max-lines = 0 then coef = 1 - (if (> max-lines 0) - (/ (+ (funcall func buf-type n ctl-buf) 0.0) - (+ max-lines 0.0)) - 1)) - 1))) - - -(defun ediff-next-difference (&optional arg) - "Advance to the next difference. -With a prefix argument, go forward that many differences." - (interactive "p") - (ediff-barf-if-not-control-buffer) - (if (< ediff-current-difference ediff-number-of-differences) - (let ((n (min ediff-number-of-differences - (+ ediff-current-difference arg))) - non-clash-skip regexp-skip) - - (ediff-visible-region) - (or (>= n ediff-number-of-differences) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - (while (and (< n ediff-number-of-differences) - (or - ;; regexp skip - regexp-skip - ;; skip clashes, if necessary - non-clash-skip - ;; skip difference regions that differ in white space - (and ediff-ignore-similar-regions - (eq (ediff-no-fine-diffs-p n) t)))) - (setq n (1+ n)) - (if (= 0 (mod n 20)) - (message "Skipped over region %d and counting ..." n)) - (or (>= n ediff-number-of-differences) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - ) - (message "") - (ediff-unselect-and-select-difference n) - ) ; let - (ediff-visible-region) - (error "At end of the difference list"))) - -(defun ediff-previous-difference (&optional arg) - "Go to the previous difference. -With a prefix argument, go back that many differences." - (interactive "p") - (ediff-barf-if-not-control-buffer) - (if (> ediff-current-difference -1) - (let ((n (max -1 (- ediff-current-difference arg))) - non-clash-skip regexp-skip) - - (ediff-visible-region) - (or (< n 0) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - (while (and (> n -1) - (or - ;; regexp skip - regexp-skip - ;; skip clashes, if necessary - non-clash-skip - ;; skip difference regions that differ in white space - (and ediff-ignore-similar-regions - (eq (ediff-no-fine-diffs-p n) t)))) - (if (= 0 (mod (1+ n) 20)) - (message "Skipped over region %d and counting ..." (1+ n))) - (setq n (1- n)) - (or (< n 0) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - ) - (message "") - (ediff-unselect-and-select-difference n) - ) ; let - (ediff-visible-region) - (error "At beginning of the difference list"))) - -;; The diff number is as perceived by the user (i.e., 1+ the internal -;; representation) -(defun ediff-jump-to-difference (difference-number) - "Go to the difference specified as a prefix argument. -If the prefix is negative, count differences from the end." - (interactive "p") - (ediff-barf-if-not-control-buffer) - (setq difference-number - (cond ((< difference-number 0) - (+ ediff-number-of-differences difference-number)) - ((> difference-number 0) (1- difference-number)) - (t -1))) - ;; -1 is allowed by ediff-unselect-and-select-difference --- it is the - ;; position before the first one. - (if (and (>= difference-number -1) - (<= difference-number ediff-number-of-differences)) - (ediff-unselect-and-select-difference difference-number) - (error ediff-BAD-DIFF-NUMBER - this-command (1+ difference-number) ediff-number-of-differences))) - -(defun ediff-jump-to-difference-at-point (arg) - "Go to difference closest to the point in buffer A, B, or C. -The buffer depends on last command character \(a, b, or c\) that invoked this -command. For instance, if the command was `ga' then the point value in buffer A -is used. -With a prefix argument, synchronize all files around the current point position -in the specified buffer." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (let* ((buf-type (ediff-char-to-buftype last-command-char)) - (buffer (ediff-get-buffer buf-type)) - (pt (ediff-with-current-buffer buffer (point))) - (diff-no (ediff-diff-at-point buf-type nil (if arg 'after))) - (past-last-diff (< ediff-number-of-differences diff-no)) - (beg (if past-last-diff - (ediff-with-current-buffer buffer (point-max)) - (ediff-get-diff-posn buf-type 'beg (1- diff-no)))) - ctl-wind wind-A wind-B wind-C - shift) - (if past-last-diff - (ediff-jump-to-difference -1) - (ediff-jump-to-difference diff-no)) - (setq ctl-wind (selected-window) - wind-A ediff-window-A - wind-B ediff-window-B - wind-C ediff-window-C) - (if arg - (progn - (ediff-with-current-buffer buffer - (setq shift (- beg pt))) - (select-window wind-A) - (if past-last-diff (goto-char (point-max))) - (condition-case nil - (backward-char shift) ; noerror, if beginning of buffer - (error)) - (recenter) - (select-window wind-B) - (if past-last-diff (goto-char (point-max))) - (condition-case nil - (backward-char shift) ; noerror, if beginning of buffer - (error)) - (recenter) - (if (window-live-p wind-C) - (progn - (select-window wind-C) - (if past-last-diff (goto-char (point-max))) - (condition-case nil - (backward-char shift) ; noerror, if beginning of buffer - (error)) - (recenter) - )) - (select-window ctl-wind) - )) - )) - - -;; find region most related to the current point position (or POS, if given) -;; returns diff number as seen by the user (i.e., 1+ the internal -;; representation) -;; The optional argument WHICH-DIFF can be `after' or `before'. If `after', -;; find the diff after the point. If `before', find the diff before the -;; point. If the point is inside a diff, return that diff. -(defun ediff-diff-at-point (buf-type &optional pos which-diff) - (let ((buffer (ediff-get-buffer buf-type)) - (ctl-buffer ediff-control-buffer) - (max-dif-num (1- ediff-number-of-differences)) - (diff-no -1) - (prev-beg 0) - (prev-end 0) - (beg 0) - (end 0)) - - (ediff-with-current-buffer buffer - (setq pos (or pos (point))) - (while (and (or (< pos prev-beg) (> pos beg)) - (< diff-no max-dif-num)) - (setq diff-no (1+ diff-no)) - (setq prev-beg beg - prev-end end) - (setq beg (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer) - end (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer)) - ) - - ;; boost diff-no by 1, if past the last diff region - (if (and (memq which-diff '(after before)) - (> pos beg) (= diff-no max-dif-num)) - (setq diff-no (1+ diff-no))) - - (cond ((eq which-diff 'after) (1+ diff-no)) - ((eq which-diff 'before) diff-no) - ((< (abs (count-lines pos (max 1 prev-end))) - (abs (count-lines pos (max 1 beg)))) - diff-no) ; choose prev difference - (t - (1+ diff-no))) ; choose next difference - ))) - - -;;; Copying diffs. - -(defun ediff-diff-to-diff (arg &optional keys) - "Copy buffer-X'th difference region to buffer Y \(X,Y are A, B, or C\). -If numerical prefix argument, copy the difference specified in the arg. -Otherwise, copy the difference given by `ediff-current-difference'. -This command assumes it is bound to a 2-character key sequence, `ab', `ba', -`ac', etc., which is used to determine the types of buffers to be used for -copying difference regions. The first character in the sequence specifies -the source buffer and the second specifies the target. - -If the second optional argument, a 2-character string, is given, use it to -determine the source and the target buffers instead of the command keys." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (or keys (setq keys (this-command-keys))) - (if (eq arg '-) (setq arg -1)) ; translate neg arg to -1 - (if (numberp arg) (ediff-jump-to-difference arg)) - - (let* ((key1 (aref keys 0)) - (key2 (aref keys 1)) - (char1 (if (and ediff-xemacs-p (eventp key1)) (event-key key1) key1)) - (char2 (if (and ediff-xemacs-p (eventp key1)) (event-key key2) key2)) - ediff-verbose-p) - (ediff-copy-diff ediff-current-difference - (ediff-char-to-buftype char1) - (ediff-char-to-buftype char2)) - ;; recenter with rehighlighting, but no messages - (ediff-recenter))) - -(defun ediff-copy-A-to-B (arg) - "Copy ARGth difference region from buffer A to B. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ab")) - -(defun ediff-copy-B-to-A (arg) - "Copy ARGth difference region from buffer B to A. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ba")) - -(defun ediff-copy-A-to-C (arg) - "Copy ARGth difference region from buffer A to buffer C. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ac")) - -(defun ediff-copy-B-to-C (arg) - "Copy ARGth difference region from buffer B to buffer C. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "bc")) - -(defun ediff-copy-C-to-B (arg) - "Copy ARGth difference region from buffer C to B. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "cb")) - -(defun ediff-copy-C-to-A (arg) - "Copy ARGth difference region from buffer C to A. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ca")) - - - -;; Copy diff N from FROM-BUF-TYPE \(given as A, B or C\) to TO-BUF-TYPE. -;; If optional DO-NOT-SAVE is non-nil, do not save the old value of the -;; target diff. This is used in merging, when constructing the merged -;; version. -(defun ediff-copy-diff (n from-buf-type to-buf-type - &optional batch-invocation reg-to-copy) - (let* ((to-buf (ediff-get-buffer to-buf-type)) - ;;(from-buf (if (not reg-to-copy) (ediff-get-buffer from-buf-type))) - (ctrl-buf ediff-control-buffer) - (saved-p t) - (three-way ediff-3way-job) - messg - ediff-verbose-p - reg-to-delete reg-to-delete-beg reg-to-delete-end) - - (setq reg-to-delete-beg - (ediff-get-diff-posn to-buf-type 'beg n ctrl-buf)) - (setq reg-to-delete-end - (ediff-get-diff-posn to-buf-type 'end n ctrl-buf)) - - (if reg-to-copy - (setq from-buf-type nil) - (setq reg-to-copy (ediff-get-region-contents n from-buf-type ctrl-buf))) - - (setq reg-to-delete (ediff-get-region-contents - n to-buf-type ctrl-buf - reg-to-delete-beg reg-to-delete-end)) - - (if (string= reg-to-delete reg-to-copy) - (setq saved-p nil) ; don't copy identical buffers - ;; seems ok to copy - (if (or batch-invocation (ediff-test-save-region n to-buf-type)) - (condition-case conds - (progn - (ediff-with-current-buffer to-buf - ;; to prevent flags from interfering if buffer is writable - (let ((inhibit-read-only (null buffer-read-only))) - - (goto-char reg-to-delete-end) - (insert reg-to-copy) - - (if (> reg-to-delete-end reg-to-delete-beg) - (kill-region reg-to-delete-beg reg-to-delete-end)) - )) - (or batch-invocation - (setq - messg - (ediff-save-diff-region n to-buf-type reg-to-delete)))) - (error (message "ediff-copy-diff: %s %s" - (car conds) - (mapconcat 'prin1-to-string (cdr conds) " ")) - (beep 1) - (sit-for 2) ; let the user see the error msg - (setq saved-p nil) - ))) - ) - - ;; adjust state of difference in case 3-way and diff was copied ok - (if (and saved-p three-way) - (ediff-set-state-of-diff-in-all-buffers n ctrl-buf)) - - (if batch-invocation - (ediff-clear-fine-differences n) - ;; If diff3 job, we should recompute fine diffs so we clear them - ;; before reinserting flags (and thus before ediff-recenter). - (if (and saved-p three-way) - (ediff-clear-fine-differences n)) - - (ediff-refresh-mode-lines) - - ;; For diff2 jobs, don't recompute fine diffs, since we know there - ;; aren't any. So we clear diffs after ediff-recenter. - (if (and saved-p (not three-way)) - (ediff-clear-fine-differences n)) - ;; Make sure that the message about saving and how to restore is seen - ;; by the user - (message messg)) - )) - -;; Save Nth diff of buffer BUF-TYPE \(A, B, or C\). -;; That is to say, the Nth diff on the `ediff-killed-diffs-alist'. REG -;; is the region to save. It is redundant here, but is passed anyway, for -;; convenience. -(defun ediff-save-diff-region (n buf-type reg) - (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist)) - (buf (ediff-get-buffer buf-type)) - (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved)))) - - (if this-buf-n-th-diff-saved - ;; either nothing saved for n-th diff and buffer or we OK'ed - ;; overriding - (setcdr this-buf-n-th-diff-saved reg) - (if n-th-diff-saved ;; n-th diff saved, but for another buffer - (nconc n-th-diff-saved (list (cons buf reg))) - (setq ediff-killed-diffs-alist ;; create record for n-th diff - (cons (list n (cons buf reg)) - ediff-killed-diffs-alist)))) - (message "Saving old diff region #%d of buffer %S. To recover, type `r%s'" - (1+ n) buf-type - (if ediff-merge-job - "" (downcase (symbol-name buf-type)))) - )) - -;; Test if saving Nth difference region of buffer BUF-TYPE is possible. -(defun ediff-test-save-region (n buf-type) - (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist)) - (buf (ediff-get-buffer buf-type)) - (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved)))) - - (if this-buf-n-th-diff-saved - (if (yes-or-no-p - (format - "You've previously copied diff region %d to buffer %S. Confirm " - (1+ n) buf-type)) - t - (error "Quit")) - t))) - -(defun ediff-pop-diff (n buf-type) - "Pop last killed Nth diff region from buffer BUF-TYPE." - (let* ((n-th-record (assoc n ediff-killed-diffs-alist)) - (buf (ediff-get-buffer buf-type)) - (saved-rec (assoc buf (cdr n-th-record))) - (three-way ediff-3way-job) - (ctl-buf ediff-control-buffer) - ediff-verbose-p - saved-diff reg-beg reg-end recovered) - - (if (cdr saved-rec) - (setq saved-diff (cdr saved-rec)) - (if (> ediff-number-of-differences 0) - (error "Nothing saved for diff %d in buffer %S" (1+ n) buf-type) - (error ediff-NO-DIFFERENCES))) - - (setq reg-beg (ediff-get-diff-posn buf-type 'beg n ediff-control-buffer)) - (setq reg-end (ediff-get-diff-posn buf-type 'end n ediff-control-buffer)) - - (condition-case conds - (ediff-with-current-buffer buf - (let ((inhibit-read-only (null buffer-read-only))) - - (goto-char reg-end) - (insert saved-diff) - - (if (> reg-end reg-beg) - (kill-region reg-beg reg-end)) - - (setq recovered t) - )) - (error (message "ediff-pop-diff: %s %s" - (car conds) - (mapconcat 'prin1-to-string (cdr conds) " ")) - (beep 1))) - - ;; Clearing fine diffs is necessary for - ;; ediff-unselect-and-select-difference to properly recompute them. We - ;; can't rely on ediff-copy-diff to clear this vector, as the user might - ;; have modified diff regions after copying and, thus, may have recomputed - ;; fine diffs. - (if recovered - (ediff-clear-fine-differences n)) - - ;; adjust state of difference - (if (and three-way recovered) - (ediff-set-state-of-diff-in-all-buffers n ctl-buf)) - - (ediff-refresh-mode-lines) - - (if recovered - (progn - (setq n-th-record (delq saved-rec n-th-record)) - (message "Diff region %d in buffer %S restored" (1+ n) buf-type) - )) - )) - -(defun ediff-restore-diff (arg &optional key) - "Restore ARGth diff from `ediff-killed-diffs-alist'. -ARG is a prefix argument. If ARG is nil, restore the current-difference. -If the second optional argument, a character, is given, use it to -determine the target buffer instead of last-command-char" - (interactive "P") - (ediff-barf-if-not-control-buffer) - (if (numberp arg) - (ediff-jump-to-difference arg)) - (ediff-pop-diff ediff-current-difference - (ediff-char-to-buftype (or key last-command-char))) - ;; recenter with rehighlighting, but no messages - (let (ediff-verbose-p) - (ediff-recenter))) - -(defun ediff-restore-diff-in-merge-buffer (arg) - "Restore ARGth diff in the merge buffer. -ARG is a prefix argument. If nil, restore the current diff." - (interactive "P") - (ediff-restore-diff arg ?c)) - - -(defun ediff-toggle-regexp-match () - "Toggle between focusing and hiding of difference regions that match -a regular expression typed in by the user." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((regexp-A "") - (regexp-B "") - (regexp-C "") - msg-connective alt-msg-connective alt-connective) - (cond - ((or (and (eq ediff-skip-diff-region-function - ediff-focus-on-regexp-matches-function) - (eq last-command-char ?f)) - (and (eq ediff-skip-diff-region-function - ediff-hide-regexp-matches-function) - (eq last-command-char ?h))) - (message "Selective browsing by regexp turned off") - (setq ediff-skip-diff-region-function 'ediff-show-all-diffs)) - ((eq last-command-char ?h) - (setq ediff-skip-diff-region-function ediff-hide-regexp-matches-function - regexp-A - (read-string - (format - "Ignore A-regions matching this regexp (default \"%s\"): " - ediff-regexp-hide-A)) - regexp-B - (read-string - (format - "Ignore B-regions matching this regexp (default \"%s\"): " - ediff-regexp-hide-B))) - (if ediff-3way-comparison-job - (setq regexp-C - (read-string - (format - "Ignore C-regions matching this regexp (default \"%s\"): " - ediff-regexp-hide-C)))) - (if (eq ediff-hide-regexp-connective 'and) - (setq msg-connective "BOTH" - alt-msg-connective "ONE OF" - alt-connective 'or) - (setq msg-connective "ONE OF" - alt-msg-connective "BOTH" - alt-connective 'and)) - (if (y-or-n-p - (format - "Ignore regions that match %s regexps, OK? " - msg-connective alt-msg-connective)) - (message "Will ignore regions that match %s regexps" msg-connective) - (setq ediff-hide-regexp-connective alt-connective) - (message "Will ignore regions that match %s regexps" - alt-msg-connective)) - - (or (string= regexp-A "") (setq ediff-regexp-hide-A regexp-A)) - (or (string= regexp-B "") (setq ediff-regexp-hide-B regexp-B)) - (or (string= regexp-C "") (setq ediff-regexp-hide-C regexp-C))) - - ((eq last-command-char ?f) - (setq ediff-skip-diff-region-function - ediff-focus-on-regexp-matches-function - regexp-A - (read-string - (format - "Focus on A-regions matching this regexp (default \"%s\"): " - ediff-regexp-focus-A)) - regexp-B - (read-string - (format - "Focus on B-regions matching this regexp (default \"%s\"): " - ediff-regexp-focus-B))) - (if ediff-3way-comparison-job - (setq regexp-C - (read-string - (format - "Focus on C-regions matching this regexp (default \"%s\"): " - ediff-regexp-focus-C)))) - (if (eq ediff-focus-regexp-connective 'and) - (setq msg-connective "BOTH" - alt-msg-connective "ONE OF" - alt-connective 'or) - (setq msg-connective "ONE OF" - alt-msg-connective "BOTH" - alt-connective 'and)) - (if (y-or-n-p - (format - "Focus on regions that match %s regexps, OK? " - msg-connective alt-msg-connective)) - (message "Will focus on regions that match %s regexps" - msg-connective) - (setq ediff-focus-regexp-connective alt-connective) - (message "Will focus on regions that match %s regexps" - alt-msg-connective)) - - (or (string= regexp-A "") (setq ediff-regexp-focus-A regexp-A)) - (or (string= regexp-B "") (setq ediff-regexp-focus-B regexp-B)) - (or (string= regexp-C "") (setq ediff-regexp-focus-C regexp-C)))))) - -(defun ediff-toggle-skip-similar () - (interactive) - (ediff-barf-if-not-control-buffer) - (if (not (eq ediff-auto-refine 'on)) - (error - "Can't skip over whitespace regions: first turn auto-refining on")) - (setq ediff-ignore-similar-regions (not ediff-ignore-similar-regions)) - (if ediff-ignore-similar-regions - (message - "Skipping regions that differ only in white space & line breaks") - (message "Skipping over white-space differences turned off"))) - -(defun ediff-focus-on-regexp-matches (n) - "Focus on diffs that match regexp `ediff-regexp-focus-A/B'. -Regions to be ignored according to this function are those where -buf A region doesn't match `ediff-regexp-focus-A' and buf B region -doesn't match `ediff-regexp-focus-B'. -This function returns nil if the region number N (specified as -an argument) is not to be ignored and t if region N is to be ignored. - -N is a region number used by Ediff internally. It is 1 less -the number seen by the user." - (if (ediff-valid-difference-p n) - (let* ((ctl-buf ediff-control-buffer) - (regex-A ediff-regexp-focus-A) - (regex-B ediff-regexp-focus-B) - (regex-C ediff-regexp-focus-C) - (reg-A-match (ediff-with-current-buffer ediff-buffer-A - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'A 'beg n ctl-buf) - (ediff-get-diff-posn 'A 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-A nil t)))) - (reg-B-match (ediff-with-current-buffer ediff-buffer-B - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'B 'beg n ctl-buf) - (ediff-get-diff-posn 'B 'end n ctl-buf)) - (re-search-forward regex-B nil t)))) - (reg-C-match (if ediff-3way-comparison-job - (ediff-with-current-buffer ediff-buffer-C - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'C 'beg n ctl-buf) - (ediff-get-diff-posn 'C 'end n ctl-buf)) - (re-search-forward regex-C nil t)))))) - (not (eval (if ediff-3way-comparison-job - (list ediff-focus-regexp-connective - reg-A-match reg-B-match reg-C-match) - (list ediff-focus-regexp-connective - reg-A-match reg-B-match)))) - ))) - -(defun ediff-hide-regexp-matches (n) - "Hide diffs that match regexp `ediff-regexp-hide-A/B/C'. -Regions to be ignored are those where buf A region matches -`ediff-regexp-hide-A' and buf B region matches `ediff-regexp-hide-B'. -This function returns nil if the region number N (specified as -an argument) is not to be ignored and t if region N is to be ignored. - -N is a region number used by Ediff internally. It is 1 less -the number seen by the user." - (if (ediff-valid-difference-p n) - (let* ((ctl-buf ediff-control-buffer) - (regex-A ediff-regexp-hide-A) - (regex-B ediff-regexp-hide-B) - (regex-C ediff-regexp-hide-C) - (reg-A-match (ediff-with-current-buffer ediff-buffer-A - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'A 'beg n ctl-buf) - (ediff-get-diff-posn 'A 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-A nil t)))) - (reg-B-match (ediff-with-current-buffer ediff-buffer-B - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'B 'beg n ctl-buf) - (ediff-get-diff-posn 'B 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-B nil t)))) - (reg-C-match (if ediff-3way-comparison-job - (ediff-with-current-buffer ediff-buffer-C - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'C 'beg n ctl-buf) - (ediff-get-diff-posn 'C 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-C nil t)))))) - (eval (if ediff-3way-comparison-job - (list ediff-hide-regexp-connective - reg-A-match reg-B-match reg-C-match) - (list ediff-hide-regexp-connective reg-A-match reg-B-match))) - ))) - - - -;;; Quitting, suspending, etc. - -(defun ediff-quit (reverse-default-keep-variants) - "Finish an Ediff session and exit Ediff. -Unselects the selected difference, if any, restores the read-only and modified -flags of the compared file buffers, kills Ediff buffers for this session -\(but not buffers A, B, C\). - -If `ediff-keep-variants' is nil, the user will be asked whether the buffers -containing the variants should be removed \(if they haven't been modified\). -If it is t, they will be preserved unconditionally. A prefix argument, -temporarily reverses the meaning of this variable." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (let ((ctl-buf (current-buffer))) - (if (y-or-n-p (format "Quit this Ediff session%s? " - (if (ediff-buffer-live-p ediff-meta-buffer) - " & show containing session group" ""))) - (progn - (message "") - (set-buffer ctl-buf) - (ediff-really-quit reverse-default-keep-variants)) - (message "")))) - - -;; Perform the quit operations. -(defun ediff-really-quit (reverse-default-keep-variants) - (ediff-unhighlight-diffs-totally) - (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-Ancestor 'fine-diffs-also) - - (ediff-delete-temp-files) - - ;; Restore visibility range. This affects only ediff-*-regions/windows. - ;; Since for other job names ediff-visible-region sets - ;; ediff-visible-bounds to ediff-wide-bounds, the settings below are - ;; ignored for such jobs. - (if ediff-quit-widened - (setq ediff-visible-bounds ediff-wide-bounds) - (setq ediff-visible-bounds ediff-narrow-bounds)) - - ;; Apply selective display to narrow or widen - (ediff-visible-region) - (mapcar (function (lambda (overl) - (if (ediff-overlayp overl) - (ediff-delete-overlay overl)))) - ediff-wide-bounds) - (mapcar (function (lambda (overl) - (if (ediff-overlayp overl) - (ediff-delete-overlay overl)))) - ediff-narrow-bounds) - - ;; restore buffer mode line id's in buffer-A/B/C - (let ((control-buffer ediff-control-buffer) - (meta-buffer ediff-meta-buffer) - ;; suitable working frame - (warp-frame (if (and (ediff-window-display-p) (eq ediff-grab-mouse t)) - (cond ((window-live-p ediff-window-A) - (window-frame ediff-window-A)) - ((window-live-p ediff-window-B) - (window-frame ediff-window-B)) - (t (next-frame)))))) - (condition-case nil - (ediff-with-current-buffer ediff-buffer-A - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (condition-case nil - (ediff-with-current-buffer ediff-buffer-B - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (condition-case nil - (ediff-with-current-buffer ediff-buffer-C - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (condition-case nil - (ediff-with-current-buffer ediff-ancestor-buffer - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (setq ediff-session-registry - (delq ediff-control-buffer ediff-session-registry)) - (ediff-update-registry) - ;; restore state of buffers to what it was before ediff - (ediff-restore-protected-variables) - - ;; If the user interrupts (canceling saving the merge buffer), continue - ;; normally. - (condition-case nil - (if (ediff-merge-job) - (run-hooks 'ediff-quit-merge-hook)) - (quit)) - - ;; good place to kill buffers A/B/C - (run-hooks 'ediff-cleanup-hook) - (let ((ediff-keep-variants ediff-keep-variants)) - (if reverse-default-keep-variants - (setq ediff-keep-variants (not ediff-keep-variants))) - (or ediff-keep-variants (ediff-janitor 'ask))) - - (run-hooks 'ediff-quit-hook) - (ediff-cleanup-meta-buffer meta-buffer) - - ;; warp mouse into a working window - (setq warp-frame ; if mouse is over a reasonable frame, use it - (cond ((ediff-good-frame-under-mouse)) - (t warp-frame))) - (if (frame-live-p warp-frame) - (set-mouse-position (if ediff-emacs-p - warp-frame - (frame-selected-window warp-frame)) - 2 1)) - - (if (ediff-buffer-live-p meta-buffer) - (ediff-show-meta-buffer meta-buffer)) - )) - -;; Returns frame under mouse, if this frame is not a minibuffer -;; frame. Otherwise: nil -(defun ediff-good-frame-under-mouse () - (let ((frame-or-win (car (mouse-position))) - (buf-name "") - frame obj-ok) - (setq obj-ok - (if ediff-emacs-p - (frame-live-p frame-or-win) - (window-live-p frame-or-win))) - (if obj-ok - (setq frame (if ediff-emacs-p frame-or-win (window-frame frame-or-win)) - buf-name - (buffer-name (window-buffer (frame-selected-window frame))))) - (if (string-match "Minibuf" buf-name) - nil - frame))) - - -(defun ediff-delete-temp-files () - (if (stringp ediff-temp-file-A) - (delete-file ediff-temp-file-A)) - (if (stringp ediff-temp-file-B) - (delete-file ediff-temp-file-B)) - (if (stringp ediff-temp-file-C) - (delete-file ediff-temp-file-C))) - - -;; Kill control buffer, other auxiliary Ediff buffers. -;; Leave one of the frames split between buffers A/B/C -(defun ediff-cleanup-mess () - (let ((buff-A ediff-buffer-A) - (buff-B ediff-buffer-B) - (buff-C ediff-buffer-C) - (ctl-buf ediff-control-buffer) - (ctl-frame ediff-control-frame) - (three-way-job ediff-3way-job)) - - (ediff-kill-buffer-carefully ediff-diff-buffer) - (ediff-kill-buffer-carefully ediff-custom-diff-buffer) - (ediff-kill-buffer-carefully ediff-fine-diff-buffer) - (ediff-kill-buffer-carefully ediff-tmp-buffer) - (ediff-kill-buffer-carefully ediff-error-buffer) - (ediff-kill-buffer-carefully ediff-msg-buffer) - (ediff-kill-buffer-carefully ediff-debug-buffer) - (if (boundp 'ediff-patch-diagnostics) - (ediff-kill-buffer-carefully ediff-patch-diagnostics)) - - (if (and (ediff-window-display-p) (frame-live-p ctl-frame)) - (delete-frame ctl-frame)) - ;; Hide bottom toolbar. --marcpa - (if (not (ediff-multiframe-setup-p)) - (ediff-kill-bottom-toolbar)) - - (ediff-kill-buffer-carefully ctl-buf) - - (delete-other-windows) - - ;; display only if not visible - (condition-case nil - (or (ediff-get-visible-buffer-window buff-B) - (switch-to-buffer buff-B)) - (error)) - (condition-case nil - (or (ediff-get-visible-buffer-window buff-A) - (progn - (if (ediff-get-visible-buffer-window buff-B) - (funcall ediff-split-window-function)) - (switch-to-buffer buff-A))) - (error)) - (if three-way-job - (condition-case nil - (or (ediff-get-visible-buffer-window buff-C) - (progn - (if (or (ediff-get-visible-buffer-window buff-A) - (ediff-get-visible-buffer-window buff-B)) - (funcall ediff-split-window-function)) - (switch-to-buffer buff-C) - (balance-windows))) - (error))) - (message "") - )) - -(defun ediff-janitor (&optional ask) - "Kill buffers A, B, and, possibly, C, if these buffers aren't modified. -In merge jobs, buffer C is never deleted. -However, the side effect of cleaning up may be that you cannot compare the same -buffer in two separate Ediff sessions: quitting one of them will delete this -buffer in another session as well." - (or (not (ediff-buffer-live-p ediff-buffer-A)) - (buffer-modified-p ediff-buffer-A) - (and ask - (not (y-or-n-p (format "Kill buffer A [%s]? " - (buffer-name ediff-buffer-A))))) - (ediff-kill-buffer-carefully ediff-buffer-A)) - (or (not (ediff-buffer-live-p ediff-buffer-B)) - (buffer-modified-p ediff-buffer-B) - (and ask - (not (y-or-n-p (format "Kill buffer B [%s]? " - (buffer-name ediff-buffer-B))))) - (ediff-kill-buffer-carefully ediff-buffer-B)) - (if ediff-merge-job ; don't del buf C if merging--del ancestor buf instead - (or (not (ediff-buffer-live-p ediff-ancestor-buffer)) - (buffer-modified-p ediff-ancestor-buffer) - (and ask - (not (y-or-n-p (format "Kill the ancestor buffer [%s]? " - (buffer-name ediff-ancestor-buffer))))) - (ediff-kill-buffer-carefully ediff-ancestor-buffer)) - (or (not (ediff-buffer-live-p ediff-buffer-C)) - (buffer-modified-p ediff-buffer-C) - (and ask (not (y-or-n-p (format "Kill buffer C [%s]? " - (buffer-name ediff-buffer-C))))) - (ediff-kill-buffer-carefully ediff-buffer-C)))) - -(defun ediff-maybe-save-and-delete-merge (&optional save-and-continue) - "Default hook to run on quitting a merge job. -This can also be used to save merge buffer in the middle of an Ediff session. - -If the optional SAVE-AND-CONTINUE argument is non-nil, save merge buffer and -continue. Otherwise: -If `ediff-autostore-merges' is nil, this does nothing. -If it is t, it saves the merge buffer in the file `ediff-merge-store-file' -or asks the user, if the latter is nil. It then asks the user whether to -delete the merge buffer. -If `ediff-autostore-merges' is neither nil nor t, the merge buffer is saved -only if this merge job is part of a group, i.e., was invoked from within -`ediff-merge-directories', `ediff-merge-directory-revisions', and such." - (let ((merge-store-file ediff-merge-store-file) - (ediff-autostore-merges ; fake ediff-autostore-merges, if necessary - (if save-and-continue t ediff-autostore-merges))) - (if ediff-autostore-merges - (cond ((stringp ediff-merge-store-file) - ;; store, ask to delete - (ediff-write-merge-buffer-and-maybe-kill - ediff-buffer-C merge-store-file 'show-file save-and-continue)) - ((eq ediff-autostore-merges t) - ;; ask for file name - (setq merge-store-file - (read-file-name "Save the merge buffer in file: ")) - (ediff-write-merge-buffer-and-maybe-kill - ediff-buffer-C merge-store-file nil save-and-continue)) - ((and (ediff-buffer-live-p ediff-meta-buffer) - (ediff-with-current-buffer ediff-meta-buffer - (ediff-merge-metajob))) - ;; This case shouldn't occur, as the parent metajob must pass on - ;; a file name, ediff-merge-store-file, where to save the result - ;; of the merge. - ;; Ask where to save anyway--will decide what to do here later. - (setq merge-store-file - (read-file-name "Save the merge buffer in file: ")) - (ediff-write-merge-buffer-and-maybe-kill - ediff-buffer-C merge-store-file nil save-and-continue)))) - )) - -;; write merge buffer. If the optional argument save-and-continue is non-nil, -;; then don't kill the merge buffer -(defun ediff-write-merge-buffer-and-maybe-kill (buf file - &optional - show-file save-and-continue) - (ediff-with-current-buffer buf - (if (or (not (file-exists-p file)) - (y-or-n-p (format "File %s exists, overwrite? " file))) - (progn - (write-region (point-min) (point-max) file) - (if show-file - (progn - (message "Merge buffer saved in: %s" file) - (sit-for 2))) - (if (and - (not save-and-continue) - (y-or-n-p "Merge buffer saved in file. Now kill the buffer? ")) - (ediff-kill-buffer-carefully buf)))))) - -;; The default way of suspending Ediff. -;; Buries Ediff buffers, kills all windows. -(defun ediff-default-suspend-function () - (let* ((buf-A ediff-buffer-A) - (buf-B ediff-buffer-B) - (buf-C ediff-buffer-C) - (buf-A-wind (ediff-get-visible-buffer-window buf-A)) - (buf-B-wind (ediff-get-visible-buffer-window buf-B)) - (buf-C-wind (ediff-get-visible-buffer-window buf-C)) - (buf-patch (if (boundp 'ediff-patchbufer) ediff-patchbufer nil)) - (buf-patch-diag (if (boundp 'ediff-patch-diagnostics) - ediff-patch-diagnostics nil)) - (buf-err ediff-error-buffer) - (buf-diff ediff-diff-buffer) - (buf-custom-diff ediff-custom-diff-buffer) - (buf-fine-diff ediff-fine-diff-buffer)) - - ;; hide the control panel - (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame)) - (iconify-frame ediff-control-frame) - (bury-buffer)) - (if buf-err (bury-buffer buf-err)) - (if buf-diff (bury-buffer buf-diff)) - (if buf-custom-diff (bury-buffer buf-custom-diff)) - (if buf-fine-diff (bury-buffer buf-fine-diff)) - (if buf-patch (bury-buffer buf-patch)) - (if buf-patch-diag (bury-buffer buf-patch-diag)) - (if (window-live-p buf-A-wind) - (progn - (select-window buf-A-wind) - (delete-other-windows) - (bury-buffer)) - (if (ediff-buffer-live-p buf-A) - (progn - (set-buffer buf-A) - (bury-buffer)))) - (if (window-live-p buf-B-wind) - (progn - (select-window buf-B-wind) - (delete-other-windows) - (bury-buffer)) - (if (ediff-buffer-live-p buf-B) - (progn - (set-buffer buf-B) - (bury-buffer)))) - (if (window-live-p buf-C-wind) - (progn - (select-window buf-C-wind) - (delete-other-windows) - (bury-buffer)) - (if (ediff-buffer-live-p buf-C) - (progn - (set-buffer buf-C) - (bury-buffer)))) - )) - - -(defun ediff-suspend () - "Suspend Ediff. -To resume, switch to the appropriate `Ediff Control Panel' -buffer and then type \\[ediff-recenter]. Ediff will automatically set -up an appropriate window config." - (interactive) - (ediff-barf-if-not-control-buffer) - (run-hooks 'ediff-suspend-hook) - (message - "To resume, type M-x eregistry and select the desired Ediff session")) - - -(defun ediff-status-info () - "Show the names of the buffers or files being operated on by Ediff. -Hit \\[ediff-recenter] to reset the windows afterward." - (interactive) - (ediff-barf-if-not-control-buffer) - (save-excursion - (ediff-skip-unsuitable-frames)) - (with-output-to-temp-buffer ediff-msg-buffer - (raise-frame (selected-frame)) - (princ (ediff-version)) - (princ "\n\n") - (ediff-with-current-buffer ediff-buffer-A - (if buffer-file-name - (princ - (format "File A = %S\n" buffer-file-name)) - (princ - (format "Buffer A = %S\n" (buffer-name))))) - (ediff-with-current-buffer ediff-buffer-B - (if buffer-file-name - (princ - (format "File B = %S\n" buffer-file-name)) - (princ - (format "Buffer B = %S\n" (buffer-name))))) - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (if buffer-file-name - (princ - (format "File C = %S\n" buffer-file-name)) - (princ - (format "Buffer C = %S\n" (buffer-name)))))) - (princ (format "Customized diff output %s\n" - (if (ediff-buffer-live-p ediff-custom-diff-buffer) - (concat "\tin buffer " - (buffer-name ediff-custom-diff-buffer)) - " is not available"))) - (princ (format "Plain diff output %s\n" - (if (ediff-buffer-live-p ediff-diff-buffer) - (concat "\tin buffer " - (buffer-name ediff-diff-buffer)) - " is not available"))) - - (let* ((A-line (ediff-with-current-buffer ediff-buffer-A - (1+ (count-lines (point-min) (point))))) - (B-line (ediff-with-current-buffer ediff-buffer-B - (1+ (count-lines (point-min) (point))))) - C-line) - (princ (format "\Buffer A's point is on line %d\n" A-line)) - (princ (format "Buffer B's point is on line %d\n" B-line)) - (if ediff-3way-job - (progn - (setq C-line (ediff-with-current-buffer ediff-buffer-C - (1+ (count-lines (point-min) (point))))) - (princ (format "Buffer C's point is on line %d\n" C-line))))) - - (princ (format "\nCurrent difference number = %S\n" - (cond ((< ediff-current-difference 0) 'start) - ((>= ediff-current-difference - ediff-number-of-differences) 'end) - (t (1+ ediff-current-difference))))) - - (princ - (format "\n%s regions that differ in white space & line breaks only" - (if ediff-ignore-similar-regions - "Ignoring" "Showing"))) - (if (and ediff-merge-job ediff-show-clashes-only) - (princ - "\nFocusing on regions where both buffers differ from the ancestor")) - - (cond ((eq ediff-skip-diff-region-function 'ediff-show-all-diffs) - (princ "\nSelective browsing by regexp is off\n")) - ((eq ediff-skip-diff-region-function - ediff-hide-regexp-matches-function) - (princ - "\nIgnoring regions that match") - (princ - (format - "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n" - ediff-regexp-hide-A ediff-hide-regexp-connective - ediff-regexp-hide-B))) - ((eq ediff-skip-diff-region-function - ediff-focus-on-regexp-matches-function) - (princ - "\nFocusing on regions that match") - (princ - (format - "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n" - ediff-regexp-focus-A ediff-focus-regexp-connective - ediff-regexp-focus-B))) - (t (princ "\nSelective browsing via a user-defined method.\n"))) - - (princ - (format "\nBugs/suggestions: type `%s' while in Ediff Control Panel." - (substitute-command-keys "\\[ediff-submit-report]"))) - ) ; with output - (if (frame-live-p ediff-control-frame) - (ediff-reset-mouse ediff-control-frame)) - (if (window-live-p ediff-control-window) - (select-window ediff-control-window))) - - - - -;;; Support routines - -;; Select a difference by placing the ASCII flags around the appropriate -;; group of lines in the A, B buffers -;; This may have to be modified for buffer C, when it will be supported. -(defun ediff-select-difference (n) - (if (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (ediff-valid-difference-p n)) - (progn - (if (and (ediff-has-face-support-p) ediff-use-faces) - (progn - (ediff-highlight-diff n) - (setq ediff-highlighting-style 'face)) - (setq ediff-highlighting-style 'ascii) - (ediff-place-flags-in-buffer - 'A ediff-buffer-A ediff-control-buffer n) - (ediff-place-flags-in-buffer - 'B ediff-buffer-B ediff-control-buffer n) - (if ediff-3way-job - (ediff-place-flags-in-buffer - 'C ediff-buffer-C ediff-control-buffer n)) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-place-flags-in-buffer - 'Ancestor ediff-ancestor-buffer - ediff-control-buffer n)) - ) - - (ediff-install-fine-diff-if-necessary n) - (run-hooks 'ediff-select-hook)))) - - -;; Unselect a difference by removing the ASCII flags in the buffers. -;; This may have to be modified for buffer C, when it will be supported. -(defun ediff-unselect-difference (n) - (if (ediff-valid-difference-p n) - (progn - (cond ((and (ediff-has-face-support-p) ediff-use-faces) - (ediff-unhighlight-diff)) - ((eq ediff-highlighting-style 'ascii) - (ediff-remove-flags-from-buffer - ediff-buffer-A - (ediff-get-diff-overlay n 'A)) - (ediff-remove-flags-from-buffer - ediff-buffer-B - (ediff-get-diff-overlay n 'B)) - (if ediff-3way-job - (ediff-remove-flags-from-buffer - ediff-buffer-C - (ediff-get-diff-overlay n 'C))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-remove-flags-from-buffer - ediff-ancestor-buffer - (ediff-get-diff-overlay n 'Ancestor))) - )) - (setq ediff-highlighting-style nil) - - ;; unhighlight fine diffs - (ediff-set-fine-diff-properties ediff-current-difference 'default) - (run-hooks 'ediff-unselect-hook)))) - - -;; Unselects prev diff and selects a new one, if FLAG has value other than -;; 'select-only or 'unselect-only. If FLAG is 'select-only, the -;; next difference is selected, but the current selection is not -;; unselected. If FLAG is 'unselect-only then the current selection is -;; unselected, but the next one is not selected. If NO-RECENTER is non-nil, -;; don't recenter buffers after selecting/unselecting. -(defun ediff-unselect-and-select-difference (n &optional flag no-recenter) - (let ((ediff-current-difference n)) - (or no-recenter - (ediff-recenter 'no-rehighlight))) - - (let ((control-buf ediff-control-buffer)) - (unwind-protect - (progn - (or (eq flag 'select-only) - (ediff-unselect-difference ediff-current-difference)) - - (or (eq flag 'unselect-only) - (ediff-select-difference n)) - (setq ediff-current-difference n) - ) ; end protected section - - (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines)) - ))) - - -(defun ediff-read-file-name (prompt default-dir default-file) -; This is a modified version of a similar function in `emerge.el'. -; PROMPT should not have trailing ': ', so that it can be modified -; according to context. -; If default-file is set, it should be used as the default value. -; If default-dir is non-nil, use it as the default directory. -; Otherwise, use the value of Emacs' variable `default-directory.' - - ;; hack default-dir if it is not set - (setq default-dir - (file-name-as-directory - (ediff-abbreviate-file-name - (expand-file-name (or default-dir - (and default-file - (file-name-directory default-file)) - default-directory))))) - - ;; strip the directory from default-file - (if default-file - (setq default-file (file-name-nondirectory default-file))) - (if (string= default-file "") - (setq default-file nil)) - - (let (f) - (setq f (expand-file-name - (read-file-name - (format "%s%s " - prompt - (cond (default-file - (concat " (default " default-file "):")) - (t (concat " (default " default-dir "):")))) - default-dir - (or default-file default-dir) - t ; must match, no-confirm - (if default-file (file-name-directory default-file)) - ) - default-dir - )) - ;; If user enters a directory name, expand the default file in that - ;; directory. This allows the user to enter a directory name for the - ;; B-file and diff against the default-file in that directory instead - ;; of a DIRED listing! - (if (and (file-directory-p f) default-file) - (setq f (expand-file-name - (file-name-nondirectory default-file) f))) - f)) - -;; If PREFIX is given, then it is used as a prefix for the temp file -;; name. Otherwise, `ediff_' is used. If FILE is given, use this -;; file and don't create a new one. -;; On MS-DOS, make sure the prefix isn't longer than 7 characters, or -;; else `make-temp-name' isn't guaranteed to return a unique filename. -;; Also, save buffer from START to END in the file. -;; START defaults to (point-min), END to (point-max) -(defun ediff-make-temp-file (buff &optional prefix given-file start end) - (let ((p (or prefix "ediff")) - f) - (if (and (eq system-type 'ms-dos) (> (length p) 7)) - (setq p (substring p 0 7))) - - (setq f (concat ediff-temp-file-prefix p) - f (cond (given-file) - ((find-file-name-handler f 'find-file-noselect) - ;; to thwart file handlers in write-region, e.g., if file - ;; name ends with .Z or .gz - ;; This is needed so that patches produced by ediff will - ;; have more meaningful names - (make-temp-name f)) - ;; Prefix is most often the same as the file name for the - ;; variant. Here we are trying to use the original file name - ;; but in the temp directory. - ((and prefix (not (file-exists-p f))) f) - ;; If a file with the orig name exists, add some random stuff - ;; to it. - (t (make-temp-name f)))) - - ;; create the file - (ediff-with-current-buffer buff - (write-region (if start start (point-min)) - (if end end (point-max)) - f - nil ; don't append---erase - 'no-message) - (set-file-modes f ediff-temp-file-mode) - (ediff-convert-standard-filename (expand-file-name f))))) - -;; Quote metacharacters (using \) when executing diff in Unix, but not in -;; EMX OS/2 -;;(defun ediff-protect-metachars (str) -;; (or (memq system-type '(emx vax-vms axp-vms)) -;; (let ((limit 0)) -;; (while (string-match ediff-metachars str limit) -;; (setq str (concat (substring str 0 (match-beginning 0)) -;; "\\" -;; (substring str (match-beginning 0)))) -;; (setq limit (1+ (match-end 0)))))) -;; str) - -;; Make sure the current buffer (for a file) has the same contents as the -;; file on disk, and attempt to remedy the situation if not. -;; Signal an error if we can't make them the same, or the user doesn't want -;; to do what is necessary to make them the same. -;; Also, Ediff always offers to revert obsolete buffers, whether they -;; are modified or not. -(defun ediff-verify-file-buffer (&optional file-magic) - ;; First check if the file has been modified since the buffer visited it. - (if (verify-visited-file-modtime (current-buffer)) - (if (buffer-modified-p) - ;; If buffer is not obsolete and is modified, offer to save - (if (yes-or-no-p - (format "Buffer out of sync with visited file. Save file %s? " - buffer-file-name)) - (condition-case nil - (save-buffer) - (error - (beep) - (message "Couldn't save %s" buffer-file-name))) - (error "Buffer is out of sync for file %s" buffer-file-name)) - ;; If buffer is not obsolete and is not modified, do nothing - nil) - ;; If buffer is obsolete, offer to revert - (if (yes-or-no-p - (format "Buffer is out of sync with visited file. REVERT file %s? " - buffer-file-name)) - (progn - (if file-magic - (erase-buffer)) - (revert-buffer t t)) - (error "Buffer out of sync for file %s" buffer-file-name)))) - - -(defun ediff-file-compressed-p (file) - (require 'jka-compr) - (string-match (jka-compr-build-file-regexp) file)) - -(defun ediff-filename-magic-p (file) - (or (ediff-file-compressed-p file) - (ediff-file-remote-p file))) - - -(defun ediff-save-buffer (arg) - "Safe way of saving buffers A, B, C, and the diff output. -`wa' saves buffer A, `wb' saves buffer B, `wc' saves buffer C, -and `wd' saves the diff output. - -With prefix argument, `wd' saves plain diff output. -Without an argument, it saves customized diff argument, if available -\(and plain output, if customized output was not generated\)." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (ediff-compute-custom-diffs-maybe) - (ediff-with-current-buffer - (cond ((memq last-command-char '(?a ?b ?c)) - (ediff-get-buffer - (ediff-char-to-buftype last-command-char))) - ((eq last-command-char ?d) - (message "Saving diff output ...") - (sit-for 1) ; let the user see the message - (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer)) - ediff-diff-buffer) - ((ediff-buffer-live-p ediff-custom-diff-buffer) - ediff-custom-diff-buffer) - ((ediff-buffer-live-p ediff-diff-buffer) - ediff-diff-buffer) - (t (error "Output from `diff' not found")))) - ) - (save-buffer))) - -(defun ediff-compute-custom-diffs-maybe () - (let ((buf-A-file-name (buffer-file-name ediff-buffer-A)) - (buf-B-file-name (buffer-file-name ediff-buffer-B)) - file-A file-B) - (if (stringp buf-A-file-name) - (setq buf-A-file-name (file-name-nondirectory buf-A-file-name))) - (if (stringp buf-B-file-name) - (setq buf-B-file-name (file-name-nondirectory buf-B-file-name))) - (setq file-A (ediff-make-temp-file ediff-buffer-A buf-A-file-name) - file-B (ediff-make-temp-file ediff-buffer-B buf-B-file-name)) - - (or (ediff-buffer-live-p ediff-custom-diff-buffer) - (setq ediff-custom-diff-buffer - (get-buffer-create - (ediff-unique-buffer-name "*ediff-custom-diff" "*")))) - (ediff-exec-process - ediff-custom-diff-program ediff-custom-diff-buffer 'synchronize - ediff-custom-diff-options file-A file-B) - (delete-file file-A) - (delete-file file-B) - )) - -(defun ediff-show-diff-output (arg) - (interactive "P") - (ediff-barf-if-not-control-buffer) - (ediff-compute-custom-diffs-maybe) - (save-excursion - (ediff-skip-unsuitable-frames ' ok-unsplittable)) - (let ((buf (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer)) - ediff-diff-buffer) - ((ediff-buffer-live-p ediff-custom-diff-buffer) - ediff-custom-diff-buffer) - ((ediff-buffer-live-p ediff-diff-buffer) - ediff-diff-buffer) - (t - (beep) - (message "Output from `diff' not found") - nil)))) - (if buf - (progn - (ediff-with-current-buffer buf - (goto-char (point-min))) - (switch-to-buffer buf) - (raise-frame (selected-frame))))) - (if (frame-live-p ediff-control-frame) - (ediff-reset-mouse ediff-control-frame)) - (if (window-live-p ediff-control-window) - (select-window ediff-control-window))) - - -(defun ediff-inferior-compare-regions () - "Compare regions in an active Ediff session. -Like ediff-regions-linewise but is called from under an active Ediff session on -the files that belong to that session. - -After quitting the session invoked via this function, type C-l to the parent -Ediff Control Panel to restore highlighting." - (interactive) - (let ((answer "") - (possibilities (list ?A ?B ?C)) - (zmacs-regions t) - (ctl-buf (current-buffer)) - quit-now - begA begB endA endB bufA bufB) - - (cond ((ediff-merge-job) - (setq bufB ediff-buffer-C) - (while (cond ((eq answer ?A) - (setq bufA ediff-buffer-A - possibilities '(?B)) - nil) - ((eq answer ?B) - (setq bufA ediff-buffer-B - possibilities '(?A)) - nil) - ((equal answer "")) - (t (beep 1) - (message "Valid values are A or B") - (sit-for 2) - t)) - (let ((cursor-in-echo-area t)) - (message "Which buffer to compare to the merge buffer (A/B)? ") - (setq answer (capitalize (read-char-exclusive)))))) - - ((ediff-3way-comparison-job) - (while (cond ((memq answer possibilities) - (setq possibilities (delq answer possibilities)) - (setq bufA - (eval - (ediff-get-symbol-from-alist - answer ediff-buffer-alist))) - nil) - ((equal answer "")) - (t (beep 1) - (message - "Valid values are %s" - (mapconcat 'char-to-string possibilities " or ")) - (sit-for 2) - t)) - (let ((cursor-in-echo-area t)) - (message "Enter the 1st buffer you want to compare (%s): " - (mapconcat 'char-to-string possibilities "/")) - (setq answer (capitalize (read-char-exclusive))))) - (setq answer "") ; silence error msg - (while (cond ((memq answer possibilities) - (setq possibilities (delq answer possibilities)) - (setq bufB - (eval - (ediff-get-symbol-from-alist - answer ediff-buffer-alist))) - nil) - ((equal answer "")) - (t (beep 1) - (message - "Valid values are %s" - (mapconcat 'char-to-string possibilities " or ")) - (sit-for 2) - t)) - (let ((cursor-in-echo-area t)) - (message "Enter the 2nd buffer you want to compare (%s): " - (mapconcat 'char-to-string possibilities "/")) - (setq answer (capitalize (read-char-exclusive)))))) - (t ; 2way comparison - (setq bufA ediff-buffer-A - bufB ediff-buffer-B - possibilities nil))) - - (ediff-with-current-buffer bufA - (or (mark t) - (error "You forgot to specify a region in buffer %s" (buffer-name))) - (setq begA (region-beginning) - endA (region-end)) - (goto-char begA) - (beginning-of-line) - (setq begA (point)) - (goto-char endA) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq endA (point))) - (ediff-with-current-buffer bufB - (or (mark t) - (error "You forgot to specify a region in buffer %s" (buffer-name))) - (setq begB (region-beginning) - endB (region-end)) - (goto-char begB) - (beginning-of-line) - (setq begB (point)) - (goto-char endB) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq endB (point))) - - (ediff-unselect-and-select-difference - ediff-current-difference 'unselect-only) - (ediff-paint-background-regions 'unhighlight) - - (ediff-with-current-buffer bufA - (goto-char begA) - (set-mark endA) - (narrow-to-region begA endA) - ;; (ediff-activate-mark) - ) - ;; (sit-for 0) - (ediff-with-current-buffer bufB - (goto-char begB) - (set-mark endB) - (narrow-to-region begB endB) - ;; (ediff-activate-mark) - ) - ;; (sit-for 0) - - ;; At this point, possibilities contains either the window char A/B/C - ;; that was not selected, or it is nil. We delete the window that is not - ;; selected. - (if possibilities - (ediff-with-current-buffer ctl-buf - (let* ((wind-to-delete (eval - (ediff-get-symbol-from-alist - (car possibilities) - ediff-window-alist))) - (frame (window-frame wind-to-delete))) - (delete-window wind-to-delete) - (select-frame frame) - (balance-windows)))) - (or (y-or-n-p - "Please check regions selected for comparison. Continue? ") - (setq quit-now t)) - - (ediff-with-current-buffer bufA - (widen)) - (ediff-with-current-buffer bufB - (widen)) - (if quit-now - (ediff-with-current-buffer ctl-buf - (ediff-recenter) - (sit-for 0) - (error "All right. Make up your mind and come back..."))) - - (ediff-regions-internal - bufA begA endA bufB begB endB - nil ; setup-hook - 'ediff-regions-linewise ; job name - nil ; no word mode - ;; setup param to pass to ediff-setup - (list (cons 'ediff-split-window-function ediff-split-window-function))) - )) - - - -(defun ediff-remove-flags-from-buffer (buffer overlay) - (ediff-with-current-buffer buffer - (let ((inhibit-read-only t)) - (if ediff-xemacs-p - (ediff-overlay-put overlay 'begin-glyph nil) - (ediff-overlay-put overlay 'before-string nil)) - - (if ediff-xemacs-p - (ediff-overlay-put overlay 'end-glyph nil) - (ediff-overlay-put overlay 'after-string nil)) - ))) - - - -(defun ediff-place-flags-in-buffer (buf-type buffer ctl-buffer diff) - (ediff-with-current-buffer buffer - (ediff-place-flags-in-buffer1 buf-type ctl-buffer diff))) - - -(defun ediff-place-flags-in-buffer1 (buf-type ctl-buffer diff-no) - (let* ((curr-overl (ediff-with-current-buffer ctl-buffer - (ediff-get-diff-overlay diff-no buf-type))) - (before (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer)) - after beg-of-line flag) - - ;; insert flag before the difference - (goto-char before) - (setq beg-of-line (bolp)) - - (setq flag (ediff-with-current-buffer ctl-buffer - (if (eq ediff-highlighting-style 'ascii) - (if beg-of-line - ediff-before-flag-bol ediff-before-flag-mol)))) - - ;; insert the flag itself - (if ediff-xemacs-p - (ediff-overlay-put curr-overl 'begin-glyph flag) - (ediff-overlay-put curr-overl 'before-string flag)) - - ;; insert the flag after the difference - ;; `after' must be set here, after the before-flag was inserted - (setq after (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer)) - (goto-char after) - (setq beg-of-line (bolp)) - - (setq flag (ediff-with-current-buffer ctl-buffer - (if (eq ediff-highlighting-style 'ascii) - (if beg-of-line - ediff-after-flag-eol ediff-after-flag-mol)))) - - ;; insert the flag itself - (if ediff-xemacs-p - (ediff-overlay-put curr-overl 'end-glyph flag) - (ediff-overlay-put curr-overl 'after-string flag)) - )) - - -;; Returns positions of difference sectors in the BUF-TYPE buffer. -;; BUF-TYPE should be a symbol -- `A', `B', or `C'. -;; POS is either `beg' or `end'--it specifies whether you want the position at -;; the beginning of a difference or at the end. -;; -;; The optional argument N says which difference (default: -;; `ediff-current-difference'). N is the internal difference number (1- what -;; the user sees). The optional argument CONTROL-BUF says -;; which control buffer is in effect in case it is not the current -;; buffer. -(defun ediff-get-diff-posn (buf-type pos &optional n control-buf) - (let (diff-overlay) - (or control-buf - (setq control-buf (current-buffer))) - - (ediff-with-current-buffer control-buf - (or n (setq n ediff-current-difference)) - (if (or (< n 0) (>= n ediff-number-of-differences)) - (if (> ediff-number-of-differences 0) - (error ediff-BAD-DIFF-NUMBER - this-command (1+ n) ediff-number-of-differences) - (error ediff-NO-DIFFERENCES))) - (setq diff-overlay (ediff-get-diff-overlay n buf-type))) - (if (not (ediff-buffer-live-p (ediff-overlay-buffer diff-overlay))) - (error ediff-KILLED-VITAL-BUFFER)) - (if (eq pos 'beg) - (ediff-overlay-start diff-overlay) - (ediff-overlay-end diff-overlay)) - )) - - -;; Restore highlighting to what it should be according to ediff-use-faces, -;; ediff-highlighting-style, and ediff-highlight-all-diffs variables. -(defun ediff-restore-highlighting (&optional ctl-buf) - (ediff-with-current-buffer (or ctl-buf (current-buffer)) - (if (and (ediff-has-face-support-p) - ediff-use-faces - ediff-highlight-all-diffs) - (ediff-paint-background-regions)) - (ediff-select-difference ediff-current-difference))) - - - -;; null out difference overlays so they won't slow down future -;; editing operations -;; VEC is either a difference vector or a fine-diff vector -(defun ediff-clear-diff-vector (vec-var &optional fine-diffs-also) - (if (vectorp (symbol-value vec-var)) - (mapcar (function - (lambda (elt) - (ediff-delete-overlay - (ediff-get-diff-overlay-from-diff-record elt)) - (if fine-diffs-also - (ediff-clear-fine-diff-vector elt)) - )) - (symbol-value vec-var))) - ;; allow them to be garbage collected - (set vec-var nil)) - - - -;;; Misc - -;; In Emacs, this just makes overlay. In the future, when Emacs will start -;; supporting sticky overlays, this function will make a sticky overlay. -;; BEG and END are expressions telling where overlay starts. -;; If they are numbers or buffers, then all is well. Otherwise, they must -;; be expressions to be evaluated in buffer BUF in order to get the overlay -;; bounds. -;; If BUFF is not a live buffer, then return nil; otherwise, return the -;; newly created overlay. -(defun ediff-make-bullet-proof-overlay (beg end buff) - (if (ediff-buffer-live-p buff) - (let (overl) - (ediff-with-current-buffer buff - (or (number-or-marker-p beg) - (setq beg (eval beg))) - (or (number-or-marker-p end) - (setq end (eval end))) - (setq overl - (if ediff-xemacs-p - (make-extent beg end buff) - ;; advance front and rear of the overlay - (make-overlay beg end buff nil 'rear-advance))) - - ;; never detach - (ediff-overlay-put - overl (if ediff-emacs-p 'evaporate 'detachable) nil) - ;; make vip-minibuffer-overlay open-ended - ;; In emacs, it is made open ended at creation time - (if ediff-xemacs-p - (progn - (ediff-overlay-put overl 'start-open nil) - (ediff-overlay-put overl 'end-open nil))) - (ediff-overlay-put overl 'ediff-diff-num 0) - overl)))) - - -;; Like other-buffer, but prefers visible buffers and ignores temporary or -;; other insignificant buffers (those beginning with "^[ *]"). -;; Gets one arg--buffer name or a list of buffer names (it won't return -;; these buffers). -(defun ediff-other-buffer (buff-lst) - (or (listp buff-lst) (setq buff-lst (list buff-lst))) - (let* ((frame-buffers (buffer-list)) - (buff-name-list - (mapcar - (function (lambda (b) - (cond ((stringp b) b) - ((bufferp b) (buffer-name b))))) - buff-lst)) - (significant-buffers - (mapcar - (function (lambda (x) - (cond ((member (buffer-name x) buff-name-list) nil) - ((not (ediff-get-visible-buffer-window x)) nil) - ((string-match "^[ *]" (buffer-name x)) nil) - ((memq (ediff-with-current-buffer x major-mode) - '(dired-mode)) - nil) - (t x)))) - frame-buffers)) - (buffers (delq nil significant-buffers)) - less-significant-buffers) - - (cond (buffers (car buffers)) - ;; try also buffers that are not displayed in windows - ((setq less-significant-buffers - (delq nil - (mapcar - (function - (lambda (x) - (cond ((member (buffer-name x) buff-name-list) nil) - ((string-match "^[ *]" (buffer-name x)) nil) - ((memq - (ediff-with-current-buffer x major-mode) - '(dired-mode)) - nil) - (t x)))) - frame-buffers))) - (car less-significant-buffers)) - (t (other-buffer (current-buffer)))) - )) - - -;; Construct a unique buffer name. -;; The first one tried is prefixsuffix, then prefix<2>suffix, -;; prefix<3>suffix, etc. -(defun ediff-unique-buffer-name (prefix suffix) - (if (null (get-buffer (concat prefix suffix))) - (concat prefix suffix) - (let ((n 2)) - (while (get-buffer (format "%s<%d>%s" prefix n suffix)) - (setq n (1+ n))) - (format "%s<%d>%s" prefix n suffix)))) - - -(defun ediff-submit-report () - "Submit bug report on Ediff." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((reporter-prompt-for-summary-p t) - (ctl-buf ediff-control-buffer) - (ediff-device-type (ediff-device-type)) - varlist salutation buffer-name) - (setq varlist '(ediff-diff-program ediff-diff-options - ediff-patch-program ediff-patch-options - ediff-shell - ediff-use-faces - ediff-auto-refine ediff-highlighting-style - ediff-buffer-A ediff-buffer-B ediff-control-buffer - ediff-forward-word-function - ediff-control-frame - ediff-control-frame-parameters - ediff-control-frame-position-function - ediff-prefer-iconified-control-frame - ediff-window-setup-function - ediff-split-window-function - ediff-job-name - ediff-word-mode - buffer-name - ediff-device-type - )) - (setq salutation " -Congratulations! You may have unearthed a bug in Ediff! - -Please make a concise and accurate summary of what happened -and mail it to the address above. ------------------------------------------------------------ -") - - (ediff-skip-unsuitable-frames) - (ediff-reset-mouse) - - (switch-to-buffer ediff-msg-buffer) - (erase-buffer) - (delete-other-windows) - (insert " -Please read this first: ----------------------- - -Some ``bugs'' may actually be no bugs at all. For instance, if you are -reporting that certain difference regions are not matched as you think they -should, this is most likely due to the way Unix diff program decides what -constitutes a difference region. Ediff is an Emacs interface to diff, and -it has nothing to do with those decisions---it only takes the output from -diff and presents it in a way that is better suited for human browsing and -manipulation. - -If Emacs happens to dump core, this is NOT an Ediff problem---it is -an Emacs bug. Report this to Emacs maintainers. - -Another popular topic for reports is compilation messages. Because Ediff -interfaces to several other packages and runs under Emacs and XEmacs, -byte-compilation may produce output like this: - - While compiling toplevel forms in file ediff.el: - ** reference to free variable pm-color-alist - ........................ - While compiling the end of the data: - ** The following functions are not known to be defined: - ediff-valid-color-p, ediff-set-face, - ........................ - -These are NOT errors, but inevitable warnings, which ought to be ignored. - -Please do not report those and similar things. However, comments and -suggestions are always welcome. - -Mail anyway? (y or n) ") - - (if (y-or-n-p "Mail anyway? ") - (progn - (if (ediff-buffer-live-p ctl-buf) - (set-buffer ctl-buf)) - (setq buffer-name (buffer-name)) - (require 'reporter) - (reporter-submit-bug-report "kifer@cs.sunysb.edu" - (ediff-version) - varlist - nil - 'delete-other-windows - salutation)) - (bury-buffer) - (beep 1)(message "Bug report aborted") - (if (ediff-buffer-live-p ctl-buf) - (ediff-with-current-buffer ctl-buf - (ediff-recenter 'no-rehighlight)))) - )) - - -(defun ediff-deactivate-mark () - (if ediff-xemacs-p - (zmacs-deactivate-region) - (deactivate-mark))) -(defun ediff-activate-mark () - (if ediff-emacs-p - (setq mark-active t) - (zmacs-activate-region))) - -(cond ((fboundp 'nuke-selective-display) - ;; XEmacs 19.12 has nuke-selective-display - (fset 'ediff-nuke-selective-display 'nuke-selective-display)) - (t - (defun ediff-nuke-selective-display () - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((mod-p (buffer-modified-p)) - buffer-read-only end) - (and (eq t selective-display) - (while (search-forward "\^M" nil t) - (end-of-line) - (setq end (point)) - (beginning-of-line) - (while (search-forward "\^M" end t) - (delete-char -1) - (insert "\^J")))) - (set-buffer-modified-p mod-p) - (setq selective-display nil))))) - )) - - -;; The next two are modified versions from emerge.el. -;; VARS must be a list of symbols -;; ediff-save-variables returns an association list: ((var . val) ...) -(defsubst ediff-save-variables (vars) - (mapcar (function (lambda (v) (cons v (symbol-value v)))) - vars)) -;; VARS is a list of variable symbols. -(defun ediff-restore-variables (vars assoc-list) - (while vars - (set (car vars) (cdr (assoc (car vars) assoc-list))) - (setq vars (cdr vars)))) - -(defun ediff-change-saved-variable (var value buf-type) - (let* ((assoc-list - (symbol-value (ediff-get-symbol-from-alist - buf-type - ediff-buffer-values-orig-alist))) - (assoc-elt (assoc var assoc-list))) - (if assoc-elt - (setcdr assoc-elt value)))) - - -;; must execute in control buf -(defun ediff-save-protected-variables () - (setq ediff-buffer-values-orig-A - (ediff-with-current-buffer ediff-buffer-A - (ediff-save-variables ediff-protected-variables))) - (setq ediff-buffer-values-orig-B - (ediff-with-current-buffer ediff-buffer-B - (ediff-save-variables ediff-protected-variables))) - (if ediff-3way-comparison-job - (setq ediff-buffer-values-orig-C - (ediff-with-current-buffer ediff-buffer-C - (ediff-save-variables ediff-protected-variables)))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (setq ediff-buffer-values-orig-Ancestor - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-save-variables ediff-protected-variables))))) - -;; must execute in control buf -(defun ediff-restore-protected-variables () - (let ((values-A ediff-buffer-values-orig-A) - (values-B ediff-buffer-values-orig-B) - (values-C ediff-buffer-values-orig-C) - (values-Ancestor ediff-buffer-values-orig-Ancestor)) - (ediff-with-current-buffer ediff-buffer-A - (ediff-restore-variables ediff-protected-variables values-A)) - (ediff-with-current-buffer ediff-buffer-B - (ediff-restore-variables ediff-protected-variables values-B)) - (if ediff-3way-comparison-job - (ediff-with-current-buffer ediff-buffer-C - (ediff-restore-variables ediff-protected-variables values-C))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-restore-variables ediff-protected-variables values-Ancestor))) - )) - -;; save BUFFER in FILE. used in hooks. -(defun ediff-save-buffer-in-file (buffer file) - (ediff-with-current-buffer buffer - (write-file file))) - - -;;; Debug - -(ediff-defvar-local ediff-command-begin-time '(0 0 0) "") - -;; calculate time used by command -(defun ediff-calc-command-time () - (let ((end (current-time)) - micro sec) - (setq micro - (if (>= (nth 2 end) (nth 2 ediff-command-begin-time)) - (- (nth 2 end) (nth 2 ediff-command-begin-time)) - (+ (nth 2 end) (- 1000000 (nth 2 ediff-command-begin-time))))) - (setq sec (- (nth 1 end) (nth 1 ediff-command-begin-time))) - (or (equal ediff-command-begin-time '(0 0 0)) - (message "Elapsed time: %d second(s) + %d microsecond(s)" sec micro)))) - -(defsubst ediff-save-time () - (setq ediff-command-begin-time (current-time))) - -(defun ediff-profile () - "Toggle profiling Ediff commands." - (interactive) - (ediff-barf-if-not-control-buffer) - (make-local-hook 'post-command-hook) - (let ((pre-hook 'pre-command-hook) - (post-hook 'post-command-hook)) - (if (not (equal ediff-command-begin-time '(0 0 0))) - (progn (remove-hook pre-hook 'ediff-save-time) - (remove-hook post-hook 'ediff-calc-command-time) - (setq ediff-command-begin-time '(0 0 0)) - (message "Ediff profiling disabled")) - (add-hook pre-hook 'ediff-save-time t t) - (add-hook post-hook 'ediff-calc-command-time nil t) - (message "Ediff profiling enabled")))) - -(defun ediff-print-diff-vector (diff-vector-var) - (princ (format "\n*** %S ***\n" diff-vector-var)) - (mapcar (function - (lambda (overl-vec) - (princ - (format - "Diff %d: \tOverlay: %S -\t\tFine diffs: %s -\t\tNo-fine-diff-flag: %S -\t\tState-of-diff:\t %S -\t\tState-of-merge:\t %S -" - (1+ (ediff-overlay-get (aref overl-vec 0) 'ediff-diff-num)) - (aref overl-vec 0) - ;; fine-diff-vector - (if (= (length (aref overl-vec 1)) 0) - "none\n" - (mapconcat 'prin1-to-string - (aref overl-vec 1) "\n\t\t\t ")) - (aref overl-vec 2) ; no fine diff flag - (aref overl-vec 3) ; state-of-diff - (aref overl-vec 4) ; state-of-merge - )))) - (eval diff-vector-var))) - - - -(defun ediff-debug-info () - (interactive) - (ediff-barf-if-not-control-buffer) - (with-output-to-temp-buffer ediff-debug-buffer - (princ (format "\nCtl buffer: %S\n" ediff-control-buffer)) - (ediff-print-diff-vector (intern "ediff-difference-vector-A")) - (ediff-print-diff-vector (intern "ediff-difference-vector-B")) - (ediff-print-diff-vector (intern "ediff-difference-vector-C")) - (ediff-print-diff-vector (intern "ediff-difference-vector-Ancestor")) - )) - - -;;; General utilities - -;; this uses comparison-func to decide who is a member -(defun ediff-member (elt lis comparison-func) - (while (and lis (not (funcall comparison-func (car lis) elt))) - (setq lis (cdr lis))) - lis) - -;; this uses comparison-func to decide who is a member, and this determines how -;; intersection looks like -(defun ediff-intersection (lis1 lis2 comparison-func) - (let ((result (list 'a))) - (while lis1 - (if (ediff-member (car lis1) lis2 comparison-func) - (nconc result (list (car lis1)))) - (setq lis1 (cdr lis1))) - (cdr result))) - - -;; eliminates duplicates using comparison-func -(defun ediff-union (lis1 lis2 comparison-func) - (let ((result (list 'a))) - (while lis1 - (or (ediff-member (car lis1) (cdr result) comparison-func) - (nconc result (list (car lis1)))) - (setq lis1 (cdr lis1))) - (while lis2 - (or (ediff-member (car lis2) (cdr result) comparison-func) - (nconc result (list (car lis2)))) - (setq lis2 (cdr lis2))) - (cdr result))) - -;; eliminates duplicates using comparison-func -(defun ediff-set-difference (lis1 lis2 comparison-func) - (let ((result (list 'a))) - (while lis1 - (or (ediff-member (car lis1) (cdr result) comparison-func) - (ediff-member (car lis1) lis2 comparison-func) - (nconc result (list (car lis1)))) - (setq lis1 (cdr lis1))) - (cdr result))) - -(defun ediff-copy-list (list) - (if (consp list) - ;;;(let ((res nil)) - ;;; (while (consp list) (push (pop list) res)) - ;;; (prog1 (nreverse res) (setcdr res list))) - (let (res elt) - (while (consp list) - (setq elt (car list) - res (cons elt res) - list (cdr list))) - (nreverse res)) - (car list))) - - -;; don't report error if version control package wasn't found -;;(ediff-load-version-control 'silent) - -(run-hooks 'ediff-load-hook) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-util.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-vers.el --- a/lisp/ediff/ediff-vers.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -;;; ediff-vers.el --- version control interface to Ediff - -;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;;; Code: - -;; Compiler pacifier -(defvar rcs-default-co-switches) -(defvar sc-mode) -(defvar cvs-shell) -(defvar cvs-program) -(defvar cvs-cookie-handle) -(defvar ediff-temp-file-prefix) - -(and noninteractive - (eval-when-compile - (load "pcl-cvs" 'noerror) - (load "rcs" 'noerror) - (load "generic-sc" 'noerror) - (load "vc" 'noerror))) -;; end pacifier - -;; VC.el support -(defun ediff-vc-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on versions of the current buffer. -;; If REV2 is "" then compare current buffer with REV1. -;; If the current buffer is named `F', the version is named `F.~REV~'. -;; If `F.~REV~' already exists, it is used instead of being re-created. - (let (file1 file2 rev1buf rev2buf) - (save-excursion - (vc-version-other-window rev1) - (setq rev1buf (current-buffer) - file1 (buffer-file-name))) - (save-excursion - (or (string= rev2 "") ; use current buffer - (vc-version-other-window rev2)) - (setq rev2buf (current-buffer) - file2 (buffer-file-name))) - (setq startup-hooks - (cons (` (lambda () - (delete-file (, file1)) - (or (, (string= rev2 "")) (delete-file (, file2))) - )) - startup-hooks)) - (ediff-buffers - rev1buf rev2buf - startup-hooks - 'ediff-revision))) - -;; RCS.el support -(defun rcs-ediff-view-revision (&optional rev) -;; View previous RCS revision of current file. -;; With prefix argument, prompts for a revision name. - (interactive (list (if current-prefix-arg - (read-string "Revision: ")))) - (let* ((filename (buffer-file-name (current-buffer))) - (switches (append '("-p") - (if rev (list (concat "-r" rev)) nil))) - (buff (concat (file-name-nondirectory filename) ".~" rev "~"))) - (message "Working ...") - (setq filename (expand-file-name filename)) - (with-output-to-temp-buffer buff - (let ((output-buffer (ediff-rcs-get-output-buffer filename buff))) - (delete-windows-on output-buffer) - (save-excursion - (set-buffer output-buffer) - (apply 'call-process "co" nil t nil - ;; -q: quiet (no diagnostics) - (append switches rcs-default-co-switches - (list "-q" filename))))) - (message "") - buff))) - -(defun ediff-rcs-get-output-buffer (file name) - ;; Get a buffer for RCS output for FILE, make it writable and clean it up. - ;; Optional NAME is name to use instead of `*RCS-output*'. - ;; This is a modified version from rcs.el v1.1. I use it here to make - ;; Ediff immune to changes in rcs.el - (let* ((default-major-mode 'fundamental-mode) ; no frills! - (buf (get-buffer-create name))) - (save-excursion - (set-buffer buf) - (setq buffer-read-only nil - default-directory (file-name-directory (expand-file-name file))) - (erase-buffer)) - buf)) - -(defun ediff-rcs-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on versions of the current buffer. -;; If REV2 is "" then use current buffer. - (let ((rev2buf (if (string= rev2 "") - (current-buffer) - (rcs-ediff-view-revision rev2))) - (rev1buf (rcs-ediff-view-revision rev1))) - - ;; rcs.el doesn't create temp version files, so we don't have to delete - ;; anything in startup hooks to ediff-buffers - (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision) - )) - - -;; GENERIC-SC.el support - -(defun generic-sc-get-latest-rev () - (cond ((eq sc-mode 'CCASE) - (eval "main/LATEST")) - (t (eval "")))) - -(defun ediff-generic-sc-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on versions of the current buffer. -;; If REV2 is "" then compare current buffer with REV1. -;; If the current buffer is named `F', the version is named `F.~REV~'. -;; If `F.~REV~' already exists, it is used instead of being re-created. - (let (rev1buf rev2buf) - (save-excursion - (if (or (not rev1) (string= rev1 "")) - (setq rev1 (generic-sc-get-latest-rev))) - (sc-visit-previous-revision rev1) - (setq rev1buf (current-buffer))) - (save-excursion - (or (string= rev2 "") ; use current buffer - (sc-visit-previous-revision rev2)) - (setq rev2buf (current-buffer))) - (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision))) - - -;;; Merge with Version Control - -(defun ediff-vc-merge-internal (rev1 rev2 ancestor-rev &optional startup-hooks) -;; If ANCESTOR-REV non-nil, merge with ancestor - (let (buf1 buf2 ancestor-buf) - (save-excursion - (vc-version-other-window rev1) - (setq buf1 (current-buffer))) - (save-excursion - (or (string= rev2 "") - (vc-version-other-window rev2)) - (setq buf2 (current-buffer))) - (if ancestor-rev - (save-excursion - (or (string= ancestor-rev "") - (vc-version-other-window ancestor-rev)) - (setq ancestor-buf (current-buffer)))) - (setq startup-hooks - (cons - (` (lambda () - (delete-file (, (buffer-file-name buf1))) - (or (, (string= rev2 "")) - (delete-file (, (buffer-file-name buf2)))) - (or (, (string= ancestor-rev "")) - (, (not ancestor-rev)) - (delete-file (, (buffer-file-name ancestor-buf)))) - )) - startup-hooks)) - (if ancestor-rev - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf - startup-hooks 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers buf1 buf2 startup-hooks 'ediff-merge-revisions)) - )) - -(defun ediff-rcs-merge-internal (rev1 rev2 ancestor-rev - &optional startup-hooks) - ;; If ANCESTOR-REV non-nil, merge with ancestor - (let (buf1 buf2 ancestor-buf) - (setq buf1 (rcs-ediff-view-revision rev1) - buf2 (if (string= rev2 "") - (current-buffer) - (rcs-ediff-view-revision rev2)) - ancestor-buf (if ancestor-rev - (if (string= ancestor-rev "") - (current-buffer) - (rcs-ediff-view-revision ancestor-rev)))) - ;; rcs.el doesn't create temp version files, so we don't have to delete - ;; anything in startup hooks to ediff-buffers - (if ancestor-rev - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf - startup-hooks 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers buf1 buf2 startup-hooks 'ediff-merge-revisions)))) - -(defun ediff-generic-sc-merge-internal (rev1 rev2 ancestor-rev - &optional startup-hooks) - ;; If ANCESTOR-REV non-nil, merge with ancestor - (let (buf1 buf2 ancestor-buf) - (save-excursion - (if (string= rev1 "") - (setq rev1 (generic-sc-get-latest-rev))) - (sc-visit-previous-revision rev1) - (setq buf1 (current-buffer))) - (save-excursion - (or (string= rev2 "") - (sc-visit-previous-revision rev2)) - (setq buf2 (current-buffer))) - (if ancestor-rev - (save-excursion - (or (string= ancestor-rev "") - (sc-visit-previous-revision ancestor-rev)) - (setq ancestor-buf (current-buffer)))) - (if ancestor-rev - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf - startup-hooks 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers buf1 buf2 startup-hooks 'ediff-merge-revisions)))) - - -;; PCL-CVS.el support - -(defun ediff-pcl-cvs-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on a pair of revisions of the current buffer. -;; If REV1 is "", use the latest revision. -;; If REV2 is "", use the current buffer as the second file to compare. - (let ((orig-buf (current-buffer)) - orig-file-name buf1 buf2 file1 file2) - - (or (setq orig-file-name (buffer-file-name (current-buffer))) - (error "Current buffer is not visiting any file")) - (if (string= rev1 "") (setq rev1 nil)) ; latest revision - (setq buf1 (ediff-pcl-cvs-view-revision orig-file-name rev1) - buf2 (if (string= rev2 "") - orig-buf - (ediff-pcl-cvs-view-revision orig-file-name rev2)) - file1 (buffer-file-name buf1) - file2 (buffer-file-name buf2)) - (setq startup-hooks - (cons (` (lambda () - (delete-file (, file1)) - (or (, (string= rev2 "")) (delete-file (, file2))) - )) - startup-hooks)) - (ediff-buffers buf1 buf2 startup-hooks 'ediff-revision))) - -;; This function is the standard Ediff's interface to pcl-cvs. -;; Works like with other interfaces: runs ediff on versions of the file in the -;; current buffer. -(defun ediff-pcl-cvs-merge-internal (rev1 rev2 ancestor-rev - &optional startup-hooks) -;; Ediff-merge appropriate revisions of the selected file. -;; If REV1 is "" then use the latest revision. -;; If REV2 is "" then merge current buffer's file with REV1. -;; If ANCESTOR-REV is "" then use current buffer's file as ancestor. -;; If ANCESTOR-REV is nil, then merge without the ancestor. - (let ((orig-buf (current-buffer)) - orig-file-name buf1 buf2 ancestor-buf) - - (or (setq orig-file-name (buffer-file-name (current-buffer))) - (error "Current buffer is not visiting any file")) - (if (string= rev1 "") (setq rev1 nil)) ; latest revision - - (setq buf1 (ediff-pcl-cvs-view-revision orig-file-name rev1)) - (setq buf2 (if (string= rev2 "") - orig-buf - (ediff-pcl-cvs-view-revision orig-file-name rev2))) - (if (stringp ancestor-rev) - (setq ancestor-buf - (if (string= ancestor-rev "") - orig-buf - (ediff-pcl-cvs-view-revision orig-file-name ancestor-rev)))) - - (setq startup-hooks - (cons - (` (lambda () - (delete-file (, (buffer-file-name buf1))) - (or (, (string= rev2 "")) - (delete-file (, (buffer-file-name buf2)))) - (or (, (string= ancestor-rev "")) - (, (not ancestor-rev)) - (delete-file (, (buffer-file-name ancestor-buf)))) - )) - startup-hooks)) - - (if ancestor-buf - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf startup-hooks - 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers - buf1 buf2 startup-hooks 'ediff-merge-revisions)) - )) - -(defun ediff-pcl-cvs-view-revision (file rev) -;; if rev = "", get the latest revision - (let ((temp-name (make-temp-name - (concat ediff-temp-file-prefix - "ediff_" rev)))) - (cvs-kill-buffer-visiting temp-name) - (if rev - (message "Retrieving revision %s..." rev) - (message "Retrieving latest revision...")) - (let ((res (call-process cvs-shell nil nil nil "-c" - (concat cvs-program " update -p " - (if rev - (concat "-r " rev " ") - "") - file - " > " temp-name)))) - (if (and res (not (and (integerp res) (zerop res)))) - (error "Failed to retrieve revision: %s" res)) - - (if rev - (message "Retrieving revision %s... Done." rev) - (message "Retrieving latest revision... Done.")) - (find-file-noselect temp-name)))) - - -(defun cvs-run-ediff-on-file-descriptor (tin) -;; This is a replacement for cvs-emerge-mode -;; Run after cvs-update. -;; Ediff-merge appropriate revisions of the selected file. - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo)) - (tmp-file - (cvs-retrieve-revision-to-tmpfile fileinfo)) - ancestor-file) - - (or (memq type '(MERGED CONFLICT MODIFIED)) - (error - "Can only merge `Modified', `Merged' or `Conflict' files")) - - (cond ((memq type '(MERGED CONFLICT)) - (setq ancestor-file - (cvs-retrieve-revision-to-tmpfile - fileinfo - ;; revision - (cvs-fileinfo->base-revision fileinfo))) - (ediff-merge-buffers-with-ancestor - (find-file-noselect tmp-file) - (find-file-noselect (cvs-fileinfo->backup-file fileinfo)) - (find-file-noselect ancestor-file) - nil ; startup-hooks - 'ediff-merge-revisions-with-ancestor)) - ((eq type 'MODIFIED) - (ediff-merge-buffers - (find-file-noselect tmp-file) - (find-file-noselect (cvs-fileinfo->full-path fileinfo)) - nil ; startup-hooks - 'ediff-merge-revisions))) - (if (stringp tmp-file) (delete-file tmp-file)) - (if (stringp ancestor-file) (delete-file ancestor-file)))) - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -(provide 'ediff-vers) - -;;; ediff-vers.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff-wind.el --- a/lisp/ediff/ediff-wind.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1276 +0,0 @@ -;;; ediff-wind.el --- window manipulation utilities - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-wind) - -;; Compiler pacifier -(defvar icon-title-format) -(defvar top-toolbar-height) -(defvar bottom-toolbar-height) -(defvar left-toolbar-height) -(defvar right-toolbar-height) -(defvar left-toolbar-width) -(defvar right-toolbar-width) -(defvar default-menubar) -(defvar frame-icon-title-format) -(defvar ediff-diff-status) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - (or (featurep 'ediff-help) - (load "ediff-help.el" nil nil 'nosuffix)) - (or (featurep 'ediff-tbar) - (load "ediff-tbar.el" 'noerror nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -;; be careful with ediff-tbar -(if ediff-xemacs-p - (condition-case nil - (require 'ediff-tbar) - (error - (defun ediff-compute-toolbar-width () 0))) - (defun ediff-compute-toolbar-width () 0)) - -(defgroup ediff-window nil - "Ediff window manipulation" - :prefix "ediff-" - :group 'ediff - :group 'frames) - - -(defcustom ediff-window-setup-function (if (ediff-window-display-p) - 'ediff-setup-windows-multiframe - 'ediff-setup-windows-plain) - "*Function called to set up windows. -Ediff provides a choice of two functions: ediff-setup-windows-plain, for -doing everything in one frame, and ediff-setup-windows-multiframe, -which sets the control panel in a separate frame. Also, if the latter -function detects that one of the buffers A/B is seen in some other frame, -it will try to keep that buffer in that frame. - -If you don't like the two functions provided---write your own one. -The basic guidelines: - 1. It should leave the control buffer current and the control window - selected. - 2. It should set ediff-window-A, ediff-window-B, ediff-window-C, - and ediff-control-window to contain window objects that display - the corresponding buffers. - 3. It should accept the following arguments: - buffer-A, buffer-B, buffer-C, control-buffer - Buffer C may not be used in jobs that compare only two buffers. -If you plan to do something fancy, take a close look at how the two -provided functions are written." - :type 'function - :group 'ediff-window) - -;; indicates if we are in a multiframe setup -(ediff-defvar-local ediff-multiframe nil "") - -;; Share of the frame occupied by the merge window (buffer C) -(ediff-defvar-local ediff-merge-window-share 0.45 "") - -;; The control window. -(ediff-defvar-local ediff-control-window nil "") -;; Official window for buffer A -(ediff-defvar-local ediff-window-A nil "") -;; Official window for buffer B -(ediff-defvar-local ediff-window-B nil "") -;; Official window for buffer C -(ediff-defvar-local ediff-window-C nil "") -;; Ediff's window configuration. -;; Used to minimize the need to rearrange windows. -(ediff-defvar-local ediff-window-config-saved "" "") - -;; Association between buff-type and ediff-window-* -(defconst ediff-window-alist - '((A . ediff-window-A) - (?A . ediff-window-A) - (B . ediff-window-B) - (?B . ediff-window-B) - (C . ediff-window-C) - (?C . ediff-window-C))) - - -(defcustom ediff-split-window-function 'split-window-vertically - "*The function used to split the main window between buffer-A and buffer-B. -You can set it to a horizontal split instead of the default vertical split -by setting this variable to `split-window-horizontally'. -You can also have your own function to do fancy splits. -This variable has no effect when buffer-A/B are shown in different frames. -In this case, Ediff will use those frames to display these buffers." - :type 'function - :group 'ediff-window) - -(defcustom ediff-merge-split-window-function 'split-window-horizontally - "*The function used to split the main window between buffer-A and buffer-B. -You can set it to a vertical split instead of the default horizontal split -by setting this variable to `split-window-vertically'. -You can also have your own function to do fancy splits. -This variable has no effect when buffer-A/B/C are shown in different frames. -In this case, Ediff will use those frames to display these buffers." - :type 'function - :group 'ediff-window) - -(defconst ediff-control-frame-parameters - (list - '(name . "Ediff") - ;;'(unsplittable . t) - '(minibuffer . nil) - '(user-position . t) ; Emacs only - '(vertical-scroll-bars . nil) ; Emacs only - '(scrollbar-width . 0) ; XEmacs only - '(menu-bar-lines . 0) ; Emacs only - ;; don't lower and auto-raise - '(auto-lower . nil) - '(auto-raise . t) - ;; this blocks queries from window manager as to where to put - ;; ediff's control frame. we put the frame outside the display, - ;; so the initial frame won't jump all over the screen - (cons 'top (if (fboundp 'ediff-display-pixel-height) - (1+ (ediff-display-pixel-height)) - 3000)) - (cons 'left (if (fboundp 'ediff-display-pixel-width) - (1+ (ediff-display-pixel-width)) - 3000)) - ) - "Frame parameters for displaying Ediff Control Panel. -Do not specify width and height here. These are computed automatically.") - -;; position of the mouse; used to decide whether to warp the mouse into ctl -;; frame -(ediff-defvar-local ediff-mouse-pixel-position nil "") - -;; not used for now -(defvar ediff-mouse-pixel-threshold 30 - "If the user moves mouse more than this many pixels, Ediff won't warp mouse into control window.") - -(defcustom ediff-grab-mouse t - "*If t, Ediff will always grab the mouse and put it in the control frame. -If 'maybe, Ediff will do it sometimes, but not after operations that require -relatively long time. If nil, the mouse will be entirely user's -responsibility." - :type 'boolean - :group 'ediff-window) - -(defcustom ediff-control-frame-position-function 'ediff-make-frame-position - "Function to call to determine the desired location for the control panel. -Expects three parameters: the control buffer, the desired width and height -of the control frame. It returns an association list -of the form \(\(top . \) \(left . \)\)" - :type 'function - :group 'ediff-window) - -(defcustom ediff-control-frame-upward-shift (if ediff-xemacs-p 42 14) - "*The upward shift of control frame from the top of buffer A's frame. -Measured in pixels. -This is used by the default control frame positioning function, -`ediff-make-frame-position'. This variable is provided for easy -customization of the default." - :type 'integer - :group 'ediff-window) - -(defcustom ediff-narrow-control-frame-leftward-shift (if ediff-xemacs-p 7 3) - "*The leftward shift of control frame from the right edge of buf A's frame. -Measured in characters. -This is used by the default control frame positioning function, -`ediff-make-frame-position' to adjust the position of the control frame -when it shows the short menu. This variable is provided for easy -customization of the default." - :type 'integer - :group 'ediff-window) - -(defcustom ediff-wide-control-frame-rightward-shift 7 - "*The rightward shift of control frame from the left edge of buf A's frame. -Measured in characters. -This is used by the default control frame positioning function, -`ediff-make-frame-position' to adjust the position of the control frame -when it shows the full menu. This variable is provided for easy -customization of the default." - :type 'integer - :group 'ediff-window) - - -;; Wide frame display - -;; t means Ediff is using wide display -(ediff-defvar-local ediff-wide-display-p nil "") -;; keeps frame config for toggling wide display -(ediff-defvar-local ediff-wide-display-orig-parameters nil - "Frame parameters to be restored when the user wants to toggle the wide -display off.") -(ediff-defvar-local ediff-wide-display-frame nil - "Frame to be used for wide display.") -(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display - "The value is a function that is called to create a wide display. -The function is called without arguments. It should resize the frame in -which buffers A, B, and C are to be displayed, and it should save the old -frame parameters in `ediff-wide-display-orig-parameters'. -The variable `ediff-wide-display-frame' should be set to contain -the frame used for the wide display.") - -;; Frame used for the control panel in a windowing system. -(ediff-defvar-local ediff-control-frame nil "") - -(defcustom ediff-prefer-iconified-control-frame nil - "*If t, keep control panel iconified when help message is off. -This has effect only on a windowing system. -If t, hitting `?' to toggle control panel off iconifies it. - -This is only useful in Emacs and only for certain kinds of window managers, -such as TWM and its derivatives, since the window manager must permit -keyboard input to go into icons. XEmacs completely ignores keyboard input -into icons, regardless of the window manager." - :type 'boolean - :group 'ediff-window) - -;;; Functions - -(defun ediff-get-window-by-clicking (wind prev-wind wind-number) - (let (event) - (message - "Select windows by clicking. Please click on Window %d " wind-number) - (while (not (ediff-mouse-event-p (setq event (ediff-read-event)))) - (if (sit-for 1) ; if sequence of events, wait till the final word - (beep 1)) - (message "Please click on Window %d " wind-number)) - (ediff-read-event) ; discard event - (setq wind (if ediff-xemacs-p - (event-window event) - (posn-window (event-start event)))) - )) - - -;; Select the lowest window on the frame. -(defun ediff-select-lowest-window () - (if ediff-xemacs-p - (select-window (frame-lowest-window)) - (let* ((lowest-window (selected-window)) - (bottom-edge (car (cdr (cdr (cdr (window-edges)))))) - (last-window (save-excursion - (other-window -1) (selected-window))) - (window-search t)) - (while window-search - (let* ((this-window (next-window)) - (next-bottom-edge - (car (cdr (cdr (cdr (window-edges this-window))))))) - (if (< bottom-edge next-bottom-edge) - (progn - (setq bottom-edge next-bottom-edge) - (setq lowest-window this-window))) - - (select-window this-window) - (if (eq last-window this-window) - (progn - (select-window lowest-window) - (setq window-search nil)))))))) - - -;;; Common window setup routines - -;; Set up the window configuration. If POS is given, set the points to -;; the beginnings of the buffers. -;; When 3way comparison is added, this will have to choose the appropriate -;; setup function based on ediff-job-name -(defun ediff-setup-windows (buffer-A buffer-B buffer-C control-buffer) - ;; Make sure we are not in the minibuffer window when we try to delete - ;; all other windows. - (run-hooks 'ediff-before-setup-windows-hook) - (if (eq (selected-window) (minibuffer-window)) - (other-window 1)) - - ;; in case user did a no-no on a tty - (or (ediff-window-display-p) - (setq ediff-window-setup-function 'ediff-setup-windows-plain)) - - (or (ediff-keep-window-config control-buffer) - (funcall - (ediff-with-current-buffer control-buffer ediff-window-setup-function) - buffer-A buffer-B buffer-C control-buffer)) - (run-hooks 'ediff-after-setup-windows-hook)) - -;; Just set up 3 windows. -;; Usually used without windowing systems -;; With windowing, we want to use dedicated frames. -(defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer) - (ediff-with-current-buffer control-buffer - (setq ediff-multiframe nil)) - (if ediff-merge-job - (ediff-setup-windows-plain-merge - buffer-A buffer-B buffer-C control-buffer) - (ediff-setup-windows-plain-compare - buffer-A buffer-B buffer-C control-buffer))) - -(defun ediff-setup-windows-plain-merge (buf-A buf-B buf-C control-buffer) - ;; skip dedicated and unsplittable frames - (ediff-destroy-control-frame control-buffer) - (let ((window-min-height 1) - split-window-function - merge-window-share merge-window-lines - wind-A wind-B wind-C) - (ediff-with-current-buffer control-buffer - (setq merge-window-share ediff-merge-window-share - ;; this lets us have local versions of ediff-split-window-function - split-window-function ediff-split-window-function)) - (delete-other-windows) - (split-window-vertically) - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - - ;; go to the upper window and split it betw A, B, and possibly C - (other-window 1) - (setq merge-window-lines - (max 2 (round (* (window-height) merge-window-share)))) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - - ;; XEmacs used to have a lot of trouble with display - ;; It did't set things right unless we tell it to sit still - ;; 19.12 seems ok. - ;;(if ediff-xemacs-p (sit-for 0)) - - (split-window-vertically (max 2 (- (window-height) merge-window-lines))) - (if (eq (selected-window) wind-A) - (other-window 1)) - (setq wind-C (selected-window)) - (switch-to-buffer buf-C) - - (select-window wind-A) - (funcall split-window-function) - - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (ediff-with-current-buffer control-buffer - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C)) - - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - )) - - -;; This function handles all comparison jobs, including 3way jobs -(defun ediff-setup-windows-plain-compare (buf-A buf-B buf-C control-buffer) - ;; skip dedicated and unsplittable frames - (ediff-destroy-control-frame control-buffer) - (let ((window-min-height 1) - split-window-function wind-width-or-height - three-way-comparison - wind-A-start wind-B-start wind-A wind-B wind-C) - (ediff-with-current-buffer control-buffer - (setq wind-A-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds)) - wind-B-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds)) - ;; this lets us have local versions of ediff-split-window-function - split-window-function ediff-split-window-function - three-way-comparison ediff-3way-comparison-job)) - (delete-other-windows) - (split-window-vertically) - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - - ;; go to the upper window and split it betw A, B, and possibly C - (other-window 1) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - (if three-way-comparison - (setq wind-width-or-height - (/ (if (eq split-window-function 'split-window-vertically) - (window-height wind-A) - (window-width wind-A)) - 3))) - - ;; XEmacs used to have a lot of trouble with display - ;; It did't set things right unless we told it to sit still - ;; 19.12 seems ok. - ;;(if ediff-xemacs-p (sit-for 0)) - - (funcall split-window-function wind-width-or-height) - - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (if three-way-comparison - (progn - (funcall split-window-function) ; equally - (if (eq (selected-window) wind-B) - (other-window 1)) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)))) - - (ediff-with-current-buffer control-buffer - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C)) - - ;; It is unlikely that we will want to implement 3way window comparison. - ;; So, only buffers A and B are used here. - (if ediff-windows-job - (progn - (set-window-start wind-A wind-A-start) - (set-window-start wind-B wind-B-start))) - - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - )) - - -;; dispatch an appropriate window setup function -(defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf) - (ediff-with-current-buffer control-buf - (setq ediff-multiframe t)) - (if ediff-merge-job - (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf) - (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf))) - -(defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; 1. Never use frames that have dedicated windows in them---it is bad to -;;; destroy dedicated windows. -;;; 2. If A and B are in the same frame but C's frame is different--- use one -;;; frame for A and B and use a separate frame for C. -;;; 3. If C's frame is non-existent, then: if the first suitable -;;; non-dedicated frame is different from A&B's, then use it for C. -;;; Otherwise, put A,B, and C in one frame. -;;; 4. If buffers A, B, C are is separate frames, use them to display these -;;; buffers. - - ;; Skip dedicated or iconified frames. - ;; Unsplittable frames are taken care of later. - (ediff-skip-unsuitable-frames 'ok-unsplittable) - - (let* ((window-min-height 1) - (wind-A (ediff-get-visible-buffer-window buf-A)) - (wind-B (ediff-get-visible-buffer-window buf-B)) - (wind-C (ediff-get-visible-buffer-window buf-C)) - (frame-A (if wind-A (window-frame wind-A))) - (frame-B (if wind-B (window-frame wind-B))) - (frame-C (if wind-C (window-frame wind-C))) - ;; on wide display, do things in one frame - (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) - ;; this lets us have local versions of ediff-split-window-function - (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) - (orig-wind (selected-window)) - (orig-frame (selected-frame)) - (use-same-frame (or force-one-frame - ;; A and C must be in one frame - (eq frame-A (or frame-C orig-frame)) - ;; B and C must be in one frame - (eq frame-B (or frame-C orig-frame)) - ;; A or B is not visible - (not (frame-live-p frame-A)) - (not (frame-live-p frame-B)) - ;; A or B is not suitable for display - (not (ediff-window-ok-for-display wind-A)) - (not (ediff-window-ok-for-display wind-B)) - ;; A and B in the same frame, and no good frame - ;; for C - (and (eq frame-A frame-B) - (not (frame-live-p frame-C))) - )) - ;; use-same-frame-for-AB implies wind A and B are ok for display - (use-same-frame-for-AB (and (not use-same-frame) - (eq frame-A frame-B))) - (merge-window-share (ediff-with-current-buffer control-buf - ediff-merge-window-share)) - merge-window-lines - designated-minibuffer-frame - done-A done-B done-C) - - ;; buf-A on its own - (if (and (window-live-p wind-A) - (null use-same-frame) ; implies wind-A is suitable - (null use-same-frame-for-AB)) - (progn ; bug A on its own - ;; buffer buf-A is seen in live wind-A - (select-window wind-A) - (delete-other-windows) - (setq wind-A (selected-window)) - (setq done-A t))) - - ;; buf-B on its own - (if (and (window-live-p wind-B) - (null use-same-frame) ; implies wind-B is suitable - (null use-same-frame-for-AB)) - (progn ; buf B on its own - ;; buffer buf-B is seen in live wind-B - (select-window wind-B) - (delete-other-windows) - (setq wind-B (selected-window)) - (setq done-B t))) - - ;; buf-C on its own - (if (and (window-live-p wind-C) - (ediff-window-ok-for-display wind-C) - (null use-same-frame)) ; buf C on its own - (progn - ;; buffer buf-C is seen in live wind-C - (select-window wind-C) - (delete-other-windows) - (setq wind-C (selected-window)) - (setq done-C t))) - - (if (and use-same-frame-for-AB ; implies wind A and B are suitable - (window-live-p wind-A)) - (progn - ;; wind-A must already be displaying buf-A - (select-window wind-A) - (delete-other-windows) - (setq wind-A (selected-window)) - - (funcall split-window-function) - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (setq done-A t - done-B t))) - - (if use-same-frame - (let ((window-min-height 1)) - (if (and (eq frame-A frame-B) - (eq frame-B frame-C) - (frame-live-p frame-A)) - (select-frame frame-A) - ;; avoid dedicated and non-splittable windows - (ediff-skip-unsuitable-frames)) - (delete-other-windows) - (setq merge-window-lines - (max 2 (round (* (window-height) merge-window-share)))) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - - (split-window-vertically - (max 2 (- (window-height) merge-window-lines))) - (if (eq (selected-window) wind-A) - (other-window 1)) - (setq wind-C (selected-window)) - (switch-to-buffer buf-C) - - (select-window wind-A) - - (funcall split-window-function) - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (setq done-A t - done-B t - done-C t) - )) - - (or done-A ; Buf A to be set in its own frame, - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-A was not set up yet as it wasn't visible, - ;; and use-same-frame = nil, use-same-frame-for-AB = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - )) - (or done-B ; Buf B to be set in its own frame, - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-B was not set up yet as it wasn't visible - ;; and use-same-frame = nil, use-same-frame-for-AB = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - )) - - (or done-C ; Buf C to be set in its own frame, - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-C was not set up yet as it wasn't visible - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)) - )) - - (ediff-with-current-buffer control-buf - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C) - (setq frame-A (window-frame ediff-window-A) - designated-minibuffer-frame - (window-frame (minibuffer-window frame-A)))) - - (ediff-setup-control-frame control-buf designated-minibuffer-frame) - )) - - -;; Window setup for all comparison jobs, including 3way comparisons -(defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; If a buffer is seen in a frame, use that frame for that buffer. -;;; If it is not seen, use the current frame. -;;; If both buffers are not seen, they share the current frame. If one -;;; of the buffers is not seen, it is placed in the current frame (where -;;; ediff started). If that frame is displaying the other buffer, it is -;;; shared between the two buffers. -;;; However, if we decide to put both buffers in one frame -;;; and the selected frame isn't splittable, we create a new frame and -;;; put both buffers there, event if one of this buffers is visible in -;;; another frame. - - ;; Skip dedicated or iconified frames. - ;; Unsplittable frames are taken care of later. - (ediff-skip-unsuitable-frames 'ok-unsplittable) - - (let* ((window-min-height 1) - (wind-A (ediff-get-visible-buffer-window buf-A)) - (wind-B (ediff-get-visible-buffer-window buf-B)) - (wind-C (ediff-get-visible-buffer-window buf-C)) - (frame-A (if wind-A (window-frame wind-A))) - (frame-B (if wind-B (window-frame wind-B))) - (frame-C (if wind-C (window-frame wind-C))) - (ctl-frame-exists-p (ediff-with-current-buffer control-buf - (frame-live-p ediff-control-frame))) - ;; on wide display, do things in one frame - (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) - ;; this lets us have local versions of ediff-split-window-function - (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) - (three-way-comparison - (ediff-with-current-buffer control-buf ediff-3way-comparison-job)) - (orig-wind (selected-window)) - (use-same-frame (or force-one-frame - (eq frame-A frame-B) - (not (ediff-window-ok-for-display wind-A)) - (not (ediff-window-ok-for-display wind-B)) - (if three-way-comparison - (or (eq frame-A frame-C) - (eq frame-B frame-C) - (not (ediff-window-ok-for-display wind-C)) - (not (frame-live-p frame-A)) - (not (frame-live-p frame-B)) - (not (frame-live-p frame-C)))) - (and (not (frame-live-p frame-B)) - (or ctl-frame-exists-p - (eq frame-A (selected-frame)))) - (and (not (frame-live-p frame-A)) - (or ctl-frame-exists-p - (eq frame-B (selected-frame)))))) - wind-A-start wind-B-start - designated-minibuffer-frame - done-A done-B done-C) - - (ediff-with-current-buffer control-buf - (setq wind-A-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds)) - wind-B-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds)))) - - (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own - (progn - ;; buffer buf-A is seen in live wind-A - (select-window wind-A) ; must be displaying buf-A - (delete-other-windows) - (setq wind-A (selected-window)) - (setq done-A t))) - - (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own - (progn - ;; buffer buf-B is seen in live wind-B - (select-window wind-B) ; must be displaying buf-B - (delete-other-windows) - (setq wind-B (selected-window)) - (setq done-B t))) - - (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own - (progn - ;; buffer buf-C is seen in live wind-C - (select-window wind-C) ; must be displaying buf-C - (delete-other-windows) - (setq wind-C (selected-window)) - (setq done-C t))) - - (if use-same-frame - (let (wind-width-or-height) ; this affects 3way setups only - (if (and (eq frame-A frame-B) (frame-live-p frame-A)) - (select-frame frame-A) - ;; avoid dedicated and non-splittable windows - (ediff-skip-unsuitable-frames)) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - - (if three-way-comparison - (setq wind-width-or-height - (/ - (if (eq split-window-function 'split-window-vertically) - (window-height wind-A) - (window-width wind-A)) - 3))) - - (funcall split-window-function wind-width-or-height) - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (if three-way-comparison - (progn - (funcall split-window-function) ; equally - (if (memq (selected-window) (list wind-A wind-B)) - (other-window 1)) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)))) - (setq done-A t - done-B t - done-C t) - )) - - (or done-A ; Buf A to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-A was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - )) - (or done-B ; Buf B to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-B was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - )) - - (if three-way-comparison - (or done-C ; Buf C to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-C was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)) - ))) - - (ediff-with-current-buffer control-buf - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C) - - (setq frame-A (window-frame ediff-window-A) - designated-minibuffer-frame - (window-frame (minibuffer-window frame-A)))) - - ;; It is unlikely that we'll implement a version of ediff-windows that - ;; would compare 3 windows at once. So, we don't use buffer C here. - (if ediff-windows-job - (progn - (set-window-start wind-A wind-A-start) - (set-window-start wind-B wind-B-start))) - - (ediff-setup-control-frame control-buf designated-minibuffer-frame) - )) - -;; skip unsplittable frames and frames that have dedicated windows. -;; create a new splittable frame if none is found -(defun ediff-skip-unsuitable-frames (&optional ok-unsplittable) - (if (ediff-window-display-p) - (let (last-window) - (while (and (not (eq (selected-window) last-window)) - (or - (ediff-frame-has-dedicated-windows (selected-frame)) - (ediff-frame-iconified-p (selected-frame)) - (< (frame-height (selected-frame)) - (* 3 window-min-height)) - (if ok-unsplittable - nil - (ediff-frame-unsplittable-p (selected-frame))))) - ;; remember where started - (or last-window (setq last-window (selected-window))) - ;; try new window - (other-window 1 t)) - (if (eq (selected-window) last-window) - ;; fed up, no appropriate frame - (progn - (select-frame (make-frame '((unsplittable))))))))) - -(defun ediff-frame-has-dedicated-windows (frame) - (let ((cur-fr (selected-frame)) - ans) - (select-frame frame) - (walk-windows - (function (lambda (wind) - (if (window-dedicated-p wind) - (setq ans t)))) - 'ignore-minibuffer - frame) - (select-frame cur-fr) - ans)) - -;; window is ok, if it is only one window on the frame, not counting the -;; minibuffer, or none of the frame's windows is dedicated. -;; The idea is that it is bad to destroy dedicated windows while creating an -;; ediff window setup -(defun ediff-window-ok-for-display (wind) - (and - (window-live-p wind) - (or - ;; only one window - (eq wind (next-window wind 'ignore-minibuffer (window-frame wind))) - ;; none is dedicated - (not (ediff-frame-has-dedicated-windows (window-frame wind))) - ))) - -;; Prepare or refresh control frame -(defun ediff-setup-control-frame (ctl-buffer designated-minibuffer-frame) - (let ((window-min-height 1) - ctl-frame-iconified-p dont-iconify-ctl-frame deiconify-ctl-frame - ctl-frame old-ctl-frame lines - ;; user-grabbed-mouse - fheight fwidth adjusted-parameters) - - (ediff-with-current-buffer ctl-buffer - (if ediff-xemacs-p (set-buffer-menubar nil)) - ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse)) - (run-hooks 'ediff-before-setup-control-frame-hook)) - - (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame)) - (ediff-with-current-buffer ctl-buffer - (setq ctl-frame (if (frame-live-p old-ctl-frame) - old-ctl-frame - (make-frame ediff-control-frame-parameters)) - ediff-control-frame ctl-frame)) - - (setq ctl-frame-iconified-p (ediff-frame-iconified-p ctl-frame)) - (select-frame ctl-frame) - (if (window-dedicated-p (selected-window)) - () - (delete-other-windows) - (switch-to-buffer ctl-buffer)) - - ;; must be before ediff-setup-control-buffer - ;; just a precaution--we should be in ctl-buffer already - (ediff-with-current-buffer ctl-buffer - (make-local-variable 'frame-title-format) - (make-local-variable 'frame-icon-title-format) ; XEmacs - (make-local-variable 'icon-title-format)) ; Emacs - - (ediff-setup-control-buffer ctl-buffer) - (setq dont-iconify-ctl-frame - (not (string= ediff-help-message ediff-brief-help-message))) - (setq deiconify-ctl-frame - (and (eq this-command 'ediff-toggle-help) - dont-iconify-ctl-frame)) - - ;; 1 more line for the modeline - (setq lines (1+ (count-lines (point-min) (point-max))) - fheight lines - fwidth (max (+ (ediff-help-message-line-length) 2) - (ediff-compute-toolbar-width)) - adjusted-parameters - (list - ;; possibly change surrogate minibuffer - (cons 'minibuffer - (minibuffer-window - designated-minibuffer-frame)) - (cons 'width fwidth) - (cons 'height fheight)) - ) - (if ediff-use-long-help-message - (setq adjusted-parameters - (cons '(auto-raise . nil) adjusted-parameters))) - - ;; In XEmacs, buffer menubar needs to be killed before frame parameters - ;; are changed. - (if ediff-xemacs-p - (progn - (set-specifier top-toolbar-height (list ctl-frame 2)) - (sit-for 0) - (set-specifier top-toolbar-height (list ctl-frame 0)) - ;;(set-specifier bottom-toolbar-height (list ctl-frame 0)) - (set-specifier left-toolbar-width (list ctl-frame 0)) - (set-specifier right-toolbar-width (list ctl-frame 0)) - )) - - ;; Under OS/2 (emx) we have to call modify frame parameters twice, in order - ;; to make sure that at least once we do it for non-iconified frame. If - ;; appears that in the OS/2 port of Emacs, one can't modify frame - ;; parameters of iconified frames. As a precaution, we do likewise for - ;; windows-nt. - (if (memq system-type '(emx windows-nt windows-95)) - (modify-frame-parameters ctl-frame adjusted-parameters)) - - ;; make or zap toolbar (if not requested) - (ediff-make-bottom-toolbar ctl-frame) - - (goto-char (point-min)) - - (modify-frame-parameters ctl-frame adjusted-parameters) - (make-frame-visible ctl-frame) - - ;; This works around a bug in 19.25 and earlier. There, if frame gets - ;; iconified, the current buffer changes to that of the frame that - ;; becomes exposed as a result of this iconification. - ;; So, we make sure the current buffer doesn't change. - (select-frame ctl-frame) - (ediff-refresh-control-frame) - - (cond ((and ediff-prefer-iconified-control-frame - (not ctl-frame-iconified-p) (not dont-iconify-ctl-frame)) - (iconify-frame ctl-frame)) - ((or deiconify-ctl-frame (not ctl-frame-iconified-p)) - (raise-frame ctl-frame))) - - (set-window-dedicated-p (selected-window) t) - - ;; Now move the frame. We must do it separately due to an obscure bug in - ;; XEmacs - (modify-frame-parameters - ctl-frame - (funcall ediff-control-frame-position-function ctl-buffer fwidth fheight)) - - ;; synchronize so the cursor will move to control frame - ;; per RMS suggestion - (if (ediff-window-display-p) - (let ((count 7)) - (sit-for .1) - (while (and (not (frame-visible-p ctl-frame)) (> count 0)) - (setq count (1- count)) - (sit-for .3)))) - - (or (ediff-frame-iconified-p ctl-frame) - ;; don't warp the mouse, unless ediff-grab-mouse = t - (ediff-reset-mouse ctl-frame - (or (eq this-command 'ediff-quit) - (not (eq ediff-grab-mouse t))))) - - (if ediff-xemacs-p - (ediff-with-current-buffer ctl-buffer - (make-local-hook 'select-frame-hook) - (add-hook 'select-frame-hook 'ediff-xemacs-select-frame-hook nil t) - )) - - (ediff-with-current-buffer ctl-buffer - (run-hooks 'ediff-after-setup-control-frame-hook)) - )) - - -(defun ediff-destroy-control-frame (ctl-buffer) - (ediff-with-current-buffer ctl-buffer - (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame)) - (let ((ctl-frame ediff-control-frame)) - (if ediff-xemacs-p - (set-buffer-menubar default-menubar)) - (setq ediff-control-frame nil) - (delete-frame ctl-frame) - ))) - (ediff-skip-unsuitable-frames) - ;;(ediff-reset-mouse nil) - ) - - -;; finds a good place to clip control frame -(defun ediff-make-frame-position (ctl-buffer ctl-frame-width ctl-frame-height) - (ediff-with-current-buffer ctl-buffer - (let* ((frame-A (window-frame ediff-window-A)) - (frame-A-parameters (frame-parameters frame-A)) - (frame-A-top (eval (cdr (assoc 'top frame-A-parameters)))) - (frame-A-left (eval (cdr (assoc 'left frame-A-parameters)))) - (frame-A-width (frame-width frame-A)) - (ctl-frame ediff-control-frame) - horizontal-adjustment upward-adjustment - ctl-frame-top ctl-frame-left) - - ;; Multiple control frames are clipped based on the value of - ;; ediff-control-buffer-number. This is done in order not to obscure - ;; other active control panels. - (setq horizontal-adjustment (* 2 ediff-control-buffer-number) - upward-adjustment (* -14 ediff-control-buffer-number)) - - (setq ctl-frame-top - (- frame-A-top upward-adjustment ediff-control-frame-upward-shift) - ctl-frame-left - (+ frame-A-left - (if ediff-use-long-help-message - (* (ediff-frame-char-width ctl-frame) - (+ ediff-wide-control-frame-rightward-shift - horizontal-adjustment)) - (- (* frame-A-width (ediff-frame-char-width frame-A)) - (* (ediff-frame-char-width ctl-frame) - (+ ctl-frame-width - ediff-narrow-control-frame-leftward-shift - horizontal-adjustment)))))) - (setq ctl-frame-top - (min ctl-frame-top - (- (ediff-display-pixel-height) - (* 2 ctl-frame-height - (ediff-frame-char-height ctl-frame)))) - ctl-frame-left - (min ctl-frame-left - (- (ediff-display-pixel-width) - (* ctl-frame-width (ediff-frame-char-width ctl-frame))))) - ;; keep ctl frame within the visible bounds - (setq ctl-frame-top (max ctl-frame-top 1) - ctl-frame-left (max ctl-frame-left 1)) - - (list (cons 'top ctl-frame-top) - (cons 'left ctl-frame-left)) - ))) - -(defun ediff-xemacs-select-frame-hook () - (if (and (equal (selected-frame) ediff-control-frame) - (not ediff-use-long-help-message)) - (raise-frame ediff-control-frame))) - -(defun ediff-make-wide-display () - "Construct an alist of parameters for the wide display. -Saves the old frame parameters in `ediff-wide-display-orig-parameters'. -The frame to be resized is kept in `ediff-wide-display-frame'. -This function modifies only the left margin and the width of the display. -It assumes that it is called from within the control buffer." - (if (not (fboundp 'ediff-display-pixel-width)) - (error "Can't determine display width.")) - (let* ((frame-A (window-frame ediff-window-A)) - (frame-A-params (frame-parameters frame-A)) - (cw (ediff-frame-char-width frame-A)) - (wd (- (/ (ediff-display-pixel-width) cw) 5))) - (setq ediff-wide-display-orig-parameters - (list (cons 'left (max 0 (eval (cdr (assoc 'left frame-A-params))))) - (cons 'width (cdr (assoc 'width frame-A-params)))) - ediff-wide-display-frame frame-A) - (modify-frame-parameters frame-A (list (cons 'left cw) - (cons 'width wd))))) - - - -;; Revise the mode line to display which difference we have selected -;; Also resets modelines of buffers A/B, since they may be clobbered by -;; anothe invocations of Ediff. -(defun ediff-refresh-mode-lines () - (let (buf-A-state-diff buf-B-state-diff buf-C-state-diff buf-C-state-merge) - - (if (ediff-valid-difference-p) - (setq - buf-C-state-diff (ediff-get-state-of-diff ediff-current-difference 'C) - buf-C-state-merge (ediff-get-state-of-merge ediff-current-difference) - buf-A-state-diff (ediff-get-state-of-diff ediff-current-difference 'A) - buf-B-state-diff (ediff-get-state-of-diff ediff-current-difference 'B) - buf-A-state-diff (if buf-A-state-diff - (format "[%s] " buf-A-state-diff) - "") - buf-B-state-diff (if buf-B-state-diff - (format "[%s] " buf-B-state-diff) - "") - buf-C-state-diff (if (and (ediff-buffer-live-p ediff-buffer-C) - (or buf-C-state-diff buf-C-state-merge)) - (format "[%s%s%s] " - (or buf-C-state-diff "") - (if buf-C-state-merge - (concat " " buf-C-state-merge) - "") - (if (ediff-get-state-of-ancestor - ediff-current-difference) - " AncestorEmpty" - "") - ) - "")) - (setq buf-A-state-diff "" - buf-B-state-diff "" - buf-C-state-diff "")) - - ;; control buffer format - (setq mode-line-format - (if (ediff-narrow-control-frame-p) - (list " " mode-line-buffer-identification) - (list "-- " mode-line-buffer-identification " Quick Help"))) - ;; control buffer id - (setq mode-line-buffer-identification - (if (ediff-narrow-control-frame-p) - (ediff-make-narrow-control-buffer-id 'skip-name) - (ediff-make-wide-control-buffer-id))) - ;; Force mode-line redisplay - (force-mode-line-update) - - (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame)) - (ediff-refresh-control-frame)) - - (ediff-with-current-buffer ediff-buffer-A - (setq ediff-diff-status buf-A-state-diff) - (ediff-strip-mode-line-format) - (setq mode-line-format - (list " A: " 'ediff-diff-status mode-line-format)) - (force-mode-line-update)) - (ediff-with-current-buffer ediff-buffer-B - (setq ediff-diff-status buf-B-state-diff) - (ediff-strip-mode-line-format) - (setq mode-line-format - (list " B: " 'ediff-diff-status mode-line-format)) - (force-mode-line-update)) - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (setq ediff-diff-status buf-C-state-diff) - (ediff-strip-mode-line-format) - (setq mode-line-format - (list " C: " 'ediff-diff-status mode-line-format)) - (force-mode-line-update))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-strip-mode-line-format) - ;; we keep the second dummy string in the mode line format of the - ;; ancestor, since for other buffers Ediff prepends 2 strings and - ;; ediff-strip-mode-line-format expects that. - (setq mode-line-format - (list " Ancestor: " - (cond ((not (stringp buf-C-state-merge)) - "") - ((string-match "prefer-A" buf-C-state-merge) - "[=diff(B)] ") - ((string-match "prefer-B" buf-C-state-merge) - "[=diff(A)] ") - (t "")) - mode-line-format)))) - )) - - -(defun ediff-refresh-control-frame () - (if ediff-emacs-p - ;; set frame/icon titles for Emacs - (modify-frame-parameters - ediff-control-frame - (list (cons 'title (ediff-make-base-title)) - (cons 'icon-name (ediff-make-narrow-control-buffer-id)) - )) - ;; set frame/icon titles for XEmacs - (setq frame-title-format (ediff-make-base-title) - frame-icon-title-format (ediff-make-narrow-control-buffer-id)) - ;; force an update of the frame title - (modify-frame-parameters ediff-control-frame '(())))) - - -(defun ediff-make-narrow-control-buffer-id (&optional skip-name) - (concat - (if skip-name - " " - (ediff-make-base-title)) - (cond ((< ediff-current-difference 0) - (format " _/%d" ediff-number-of-differences)) - ((>= ediff-current-difference ediff-number-of-differences) - (format " $/%d" ediff-number-of-differences)) - (t - (format " %d/%d" - (1+ ediff-current-difference) - ediff-number-of-differences))))) - -(defun ediff-make-base-title () - (concat - (cdr (assoc 'name ediff-control-frame-parameters)) - ediff-control-buffer-suffix)) - -(defun ediff-make-wide-control-buffer-id () - (cond ((< ediff-current-difference 0) - (list (format "%%b At start of %d diffs" - ediff-number-of-differences))) - ((>= ediff-current-difference ediff-number-of-differences) - (list (format "%%b At end of %d diffs" - ediff-number-of-differences))) - (t - (list (format "%%b diff %d of %d" - (1+ ediff-current-difference) - ediff-number-of-differences))))) - - - -;; If buff is not live, return nil -(defun ediff-get-visible-buffer-window (buff) - (if (ediff-buffer-live-p buff) - (if ediff-xemacs-p - (get-buffer-window buff t) - (get-buffer-window buff 'visible)))) - - -;;; Functions to decide when to redraw windows - -(defun ediff-keep-window-config (control-buf) - (and (eq control-buf (current-buffer)) - (/= (buffer-size) 0) - (ediff-with-current-buffer control-buf - (let ((ctl-wind ediff-control-window) - (A-wind ediff-window-A) - (B-wind ediff-window-B) - (C-wind ediff-window-C)) - - (and - (ediff-window-visible-p A-wind) - (ediff-window-visible-p B-wind) - ;; if buffer C is defined then take it into account - (or (not ediff-3way-job) - (ediff-window-visible-p C-wind)) - (eq (window-buffer A-wind) ediff-buffer-A) - (eq (window-buffer B-wind) ediff-buffer-B) - (or (not ediff-3way-job) - (eq (window-buffer C-wind) ediff-buffer-C)) - (string= ediff-window-config-saved - (format "%S%S%S%S%S%S%S" - ctl-wind A-wind B-wind C-wind - ediff-split-window-function - (ediff-multiframe-setup-p) - ediff-wide-display-p))))))) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-wind.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/ediff/ediff.el --- a/lisp/ediff/ediff.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1304 +0,0 @@ -;;; ediff.el --- a comprehensive visual interface to diff & patch - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer -;; Created: February 2, 1994 -;; Keywords: comparing, merging, patching, version control. - -(defconst ediff-version "2.671" "The current version of Ediff") -(defconst ediff-date "September 23, 1997" "Date of last update") - - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Never read that diff output again! -;; Apply patch interactively! -;; Merge with ease! - -;; This package provides a convenient way of simultaneous browsing through -;; the differences between a pair (or a triple) of files or buffers. The -;; files being compared, file-A, file-B, and file-C (if applicable) are -;; shown in separate windows (side by side, one above the another, or in -;; separate frames), and the differences are highlighted as you step -;; through them. You can also copy difference regions from one buffer to -;; another (and recover old differences if you change your mind). - -;; Ediff also supports merging operations on files and buffers, including -;; merging using ancestor versions. Both comparison and merging operations can -;; be performed on directories, i.e., by pairwise comparison of files in those -;; directories. - -;; In addition, Ediff can apply a patch to a file and then let you step -;; though both files, the patched and the original one, simultaneously, -;; difference-by-difference. You can even apply a patch right out of a -;; mail buffer, i.e., patches received by mail don't even have to be saved. -;; Since Ediff lets you copy differences between buffers, you can, in -;; effect, apply patches selectively (i.e., you can copy a difference -;; region from file_orig to file, thereby undoing any particular patch that -;; you don't like). - -;; Ediff is aware of version control, which lets the user compare -;; files with their older versions. Ediff can also work with remote and -;; compressed files. Details are given below. - -;; Finally, Ediff supports directory-level comparison, merging and patching. -;; See the on-line manual for details. - -;; This package builds upon the ideas borrowed from emerge.el and several -;; Ediff's functions are adaptations from emerge.el. Much of the functionality -;; Ediff provides is also influenced by emerge.el. - -;; The present version of Ediff supersedes Emerge. It provides a superior user -;; interface and has numerous major features not found in Emerge. In -;; particular, it can do patching, and 2-way and 3-way file comparison, -;; merging, and directory operations. - - - -;;; Bugs: - -;; 1. The undo command doesn't restore deleted regions well. That is, if -;; you delete all characters in a difference region and then invoke -;; `undo', the reinstated text will most likely be inserted outside of -;; what Ediff thinks is the current difference region. (This problem -;; doesn't seem to exist with XEmacs.) -;; -;; If at any point you feel that difference regions are no longer correct, -;; you can hit '!' to recompute the differences. - -;; 2. On a monochrome display, the repertoire of faces with which to -;; highlight fine differences is limited. By default, Ediff is using -;; underlining. However, if the region is already underlined by some other -;; overlays, there is no simple way to temporarily remove that residual -;; underlining. This problem occurs when a buffer is highlighted with -;; hilit19.el or font-lock.el packages. If this residual highlighting gets -;; in the way, you can do the following. Both font-lock.el and hilit19.el -;; provide commands for unhighlighting buffers. You can either place these -;; commands in `ediff-prepare-buffer-hook' (which will unhighlight every -;; buffer used by Ediff) or you can execute them interactively, at any time -;; and on any buffer. - - -;;; Acknowledgements: - -;; Ediff was inspired by Dale R. Worley's emerge.el. -;; Ediff would not have been possible without the help and encouragement of -;; its many users. See Ediff on-line Info for the full list of those who -;; helped. Improved defaults in Ediff file-name reading commands. - -;;; Code: - -(provide 'ediff) - -;; Compiler pacifier -(defvar cvs-cookie-handle) -(defvar ediff-last-dir-patch) -(defvar ediff-patch-default-directory) - -(and noninteractive - (eval-when-compile - (load-library "dired") - (load-library "info") - (load "pcl-cvs" 'noerror))) -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-mult) - (load "ediff-mult.el" nil nil 'nosuffix)) - (or (featurep 'ediff-ptch) - (load "ediff-ptch.el" nil nil 'nosuffix)) - (or (featurep 'ediff-vers) - (load "ediff-vers.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) -(require 'ediff-mult) ; required because of the registry stuff - -(defgroup ediff nil - "A comprehensive visual interface to diff & patch" - :tag "Ediff" - :group 'tools) - - -(defcustom ediff-use-last-dir nil - "*If t, Ediff will use previous directory as default when reading file name." - :type 'boolean - :group 'ediff) - -;; Last directory used by an Ediff command for file-A. -(defvar ediff-last-dir-A nil) -;; Last directory used by an Ediff command for file-B. -(defvar ediff-last-dir-B nil) -;; Last directory used by an Ediff command for file-C. -(defvar ediff-last-dir-C nil) -;; Last directory used by an Ediff command for the ancestor file. -(defvar ediff-last-dir-ancestor nil) -;; Last directory used by an Ediff command as the output directory for merge. -(defvar ediff-last-merge-autostore-dir) - - -;; Used as a startup hook to set `_orig' patch file read-only. -(defun ediff-set-read-only-in-buf-A () - (ediff-with-current-buffer ediff-buffer-A - (toggle-read-only 1))) - -;; Return a plausible default for ediff's first file: -;; In dired, return the file name under the point, unless it is a directory -;; If the buffer has a file name, return that file name. -(defun ediff-get-default-file-name () - (cond ((eq major-mode 'dired-mode) - (let ((f (dired-get-filename nil 'no-error))) - (if (and (stringp f) (not (file-directory-p f))) - f))) - ((buffer-file-name (current-buffer)) - (file-name-nondirectory (buffer-file-name (current-buffer)))) - )) - -;;; Compare files/buffers - -;;;###autoload -(defun ediff-files (file-A file-B &optional startup-hooks) - "Run Ediff on a pair of files, FILE-A and FILE-B." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B f) - (list (setq f (ediff-read-file-name - "File A to compare" dir-A - (ediff-get-default-file-name))) - (ediff-read-file-name "File B to compare" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f)) - ))) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - nil ; file-C - startup-hooks - 'ediff-files)) - -;;;###autoload -(defun ediff-files3 (file-A file-B file-C &optional startup-hooks) - "Run Ediff on three files, FILE-A, FILE-B, and FILE-C." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B dir-C f ff) - (list (setq f (ediff-read-file-name - "File A to compare" dir-A - (ediff-get-default-file-name))) - (setq ff (ediff-read-file-name "File B to compare" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons - (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f))) - (ediff-read-file-name "File C to compare" - (setq dir-C (if ediff-use-last-dir - ediff-last-dir-C - (file-name-directory ff))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory ff) - dir-C)) - file-name-history)) - ff)) - ))) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - (if (file-directory-p file-C) - (expand-file-name - (file-name-nondirectory file-A) file-C) - file-C) - startup-hooks - 'ediff-files3)) - -;;;###autoload -(defalias 'ediff3 'ediff-files3) - - -;; Visit FILE and arrange its buffer to Ediff's liking. -;; FILE is actually a variable symbol that must contain a true file name. -;; BUFFER-NAME is a variable symbol, which will get the buffer object into -;; which FILE is read. -;; LAST-DIR is the directory variable symbol where FILE's -;; directory name should be returned. HOOKS-VAR is a variable symbol that will -;; be assigned the hook to be executed after `ediff-startup' is finished. -;; `ediff-find-file' arranges that the temp files it might create will be -;; deleted. -(defun ediff-find-file (file-var buffer-name &optional last-dir hooks-var) - (let* ((file (symbol-value file-var)) - (file-magic (ediff-filename-magic-p file)) - (temp-file-name-prefix (file-name-nondirectory file))) - (cond ((not (file-readable-p file)) - (error "File `%s' does not exist or is not readable" file)) - ((file-directory-p file) - (error "File `%s' is a directory" file))) - - ;; some of the commands, below, require full file name - (setq file (expand-file-name file)) - - ;; Record the directory of the file - (if last-dir - (set last-dir (expand-file-name (file-name-directory file)))) - - ;; Setup the buffer - (set buffer-name (find-file-noselect file)) - - (ediff-with-current-buffer (symbol-value buffer-name) - (widen) ; Make sure the entire file is seen - (cond (file-magic ; file has a handler, such as jka-compr-handler or - ;;; ange-ftp-hook-function--arrange for temp file - (ediff-verify-file-buffer 'magic) - (setq file - (ediff-make-temp-file - (current-buffer) temp-file-name-prefix)) - (set hooks-var (cons (` (lambda () (delete-file (, file)))) - (symbol-value hooks-var)))) - ;; file processed via auto-mode-alist, a la uncompress.el - ((not (equal (file-truename file) - (file-truename (buffer-file-name)))) - (setq file - (ediff-make-temp-file - (current-buffer) temp-file-name-prefix)) - (set hooks-var (cons (` (lambda () (delete-file (, file)))) - (symbol-value hooks-var)))) - (t ;; plain file---just check that the file matches the buffer - (ediff-verify-file-buffer)))) - (set file-var file))) - -(defun ediff-files-internal (file-A file-B file-C startup-hooks job-name) - (let (buf-A buf-B buf-C) - (message "Reading file %s ... " file-A) - ;;(sit-for 0) - (ediff-find-file 'file-A 'buf-A 'ediff-last-dir-A 'startup-hooks) - (message "Reading file %s ... " file-B) - ;;(sit-for 0) - (ediff-find-file 'file-B 'buf-B 'ediff-last-dir-B 'startup-hooks) - (if (stringp file-C) - (progn - (message "Reading file %s ... " file-C) - ;;(sit-for 0) - (ediff-find-file - 'file-C 'buf-C - (if (eq job-name 'ediff-merge-files-with-ancestor) - 'ediff-last-dir-ancestor 'ediff-last-dir-C) - 'startup-hooks))) - (ediff-setup buf-A file-A - buf-B file-B - buf-C file-C - startup-hooks - (list (cons 'ediff-job-name job-name))))) - - -;;;###autoload -(defalias 'ediff 'ediff-files) - - -;;;###autoload -(defun ediff-buffers (buffer-A buffer-B &optional startup-hooks job-name) - "Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B." - (interactive - (let (bf) - (list (setq bf (read-buffer "Buffer A to compare: " - (ediff-other-buffer "") t)) - (read-buffer "Buffer B to compare: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - (or job-name (setq job-name 'ediff-buffers)) - (ediff-buffers-internal buffer-A buffer-B nil startup-hooks job-name)) - -;;;###autoload -(defalias 'ebuffers 'ediff-buffers) - - -;;;###autoload -(defun ediff-buffers3 (buffer-A buffer-B buffer-C - &optional startup-hooks job-name) - "Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C." - (interactive - (let (bf bff) - (list (setq bf (read-buffer "Buffer A to compare: " - (ediff-other-buffer "") t)) - (setq bff (read-buffer "Buffer B to compare: " - (progn - ;; realign buffers so that two visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)) - (read-buffer "Buffer C to compare: " - (progn - ;; realign buffers so that three visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer (list bf bff))) - t) - ))) - (or job-name (setq job-name 'ediff-buffers3)) - (ediff-buffers-internal buffer-A buffer-B buffer-C startup-hooks job-name)) - -;;;###autoload -(defalias 'ebuffers3 'ediff-buffers3) - - - -(defun ediff-buffers-internal (buf-A buf-B buf-C startup-hooks job-name) - (let* ((buf-A-file-name (buffer-file-name (get-buffer buf-A))) - (buf-B-file-name (buffer-file-name (get-buffer buf-B))) - (buf-C-is-alive (ediff-buffer-live-p buf-C)) - (buf-C-file-name (if buf-C-is-alive - (buffer-file-name (get-buffer buf-B)))) - file-A file-B file-C) - (if (not (ediff-buffer-live-p buf-A)) - (error "Buffer %S doesn't exist" buf-A)) - (if (not (ediff-buffer-live-p buf-B)) - (error "Buffer %S doesn't exist" buf-B)) - (let ((ediff-job-name job-name)) - (if (and ediff-3way-comparison-job - (not buf-C-is-alive)) - (error "Buffer %S doesn't exist" buf-C))) - (if (stringp buf-A-file-name) - (setq buf-A-file-name (file-name-nondirectory buf-A-file-name))) - (if (stringp buf-B-file-name) - (setq buf-B-file-name (file-name-nondirectory buf-B-file-name))) - (if (stringp buf-C-file-name) - (setq buf-C-file-name (file-name-nondirectory buf-C-file-name))) - - (setq file-A (ediff-make-temp-file buf-A buf-A-file-name) - file-B (ediff-make-temp-file buf-B buf-B-file-name)) - (if buf-C-is-alive - (setq file-C (ediff-make-temp-file buf-C buf-C-file-name))) - - (ediff-setup (get-buffer buf-A) file-A - (get-buffer buf-B) file-B - (if buf-C-is-alive (get-buffer buf-C)) - file-C - (cons (` (lambda () - (delete-file (, file-A)) - (delete-file (, file-B)) - (if (stringp (, file-C)) (delete-file (, file-C))) - )) - startup-hooks) - (list (cons 'ediff-job-name job-name)) - ))) - - -;;; Directory and file group operations - -;; Get appropriate default name for directory: -;; If ediff-use-last-dir, use ediff-last-dir-A. -;; In dired mode, use the directory that is under the point (if any); -;; otherwise, use default-directory -(defun ediff-get-default-directory-name () - (cond (ediff-use-last-dir ediff-last-dir-A) - ((eq major-mode 'dired-mode) - (let ((f (dired-get-filename nil 'noerror))) - (if (and (stringp f) (file-directory-p f)) - f - default-directory))) - (t default-directory))) - - -;;;###autoload -(defun ediff-directories (dir1 dir2 regexp) - "Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to compare:" dir-A nil)) - (ediff-read-file-name "Directory B to compare:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 nil regexp 'ediff-files 'ediff-directories - )) - -;;;###autoload -(defalias 'edirs 'ediff-directories) - - -;;;###autoload -(defun ediff-directory-revisions (dir1 regexp) - "Run Ediff on a directory, DIR1, comparing its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." - (interactive - (let ((dir-A (ediff-get-default-directory-name))) - (list (ediff-read-file-name - "Directory to compare with revision:" dir-A nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directory-revisions-internal - dir1 regexp 'ediff-revision 'ediff-directory-revisions - )) - -;;;###autoload -(defalias 'edir-revisions 'ediff-directory-revisions) - - -;;;###autoload -(defun ediff-directories3 (dir1 dir2 dir3 regexp) - "Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that -have the same name in all three. The last argument, REGEXP, is a regular -expression that can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to compare:" dir-A nil)) - (setq f (ediff-read-file-name "Directory B to compare:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil)) - (ediff-read-file-name "Directory C to compare:" - (if ediff-use-last-dir - ediff-last-dir-C - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 dir3 regexp 'ediff-files3 'ediff-directories3 - )) - -;;;###autoload -(defalias 'edirs3 'ediff-directories3) - -;;;###autoload -(defun ediff-merge-directories (dir1 dir2 regexp) - "Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to merge:" dir-A nil)) - (ediff-read-file-name "Directory B to merge:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 nil regexp 'ediff-merge-files 'ediff-merge-directories - )) - -;;;###autoload -(defalias 'edirs-merge 'ediff-merge-directories) - -;;;###autoload -(defun ediff-merge-directories-with-ancestor (dir1 dir2 ancestor-dir regexp) - "Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors. -Ediff merges files that have identical names in DIR1, DIR2. If a pair of files -in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge -without ancestor. The fourth argument, REGEXP, is a regular expression that -can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to merge:" dir-A nil)) - (setq f (ediff-read-file-name "Directory B to merge:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil)) - (ediff-read-file-name "Ancestor directory:" - (if ediff-use-last-dir - ediff-last-dir-C - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 ancestor-dir regexp - 'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor - )) - -;;;###autoload -(defun ediff-merge-directory-revisions (dir1 regexp) - "Run Ediff on a directory, DIR1, merging its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." - (interactive - (let ((dir-A (ediff-get-default-directory-name))) - (list (ediff-read-file-name - "Directory to merge with revisions:" dir-A nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directory-revisions-internal - dir1 regexp 'ediff-merge-revisions 'ediff-merge-directory-revisions - )) - -;;;###autoload -(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions) - -;;;###autoload -(defun ediff-merge-directory-revisions-with-ancestor (dir1 regexp) - "Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." - (interactive - (let ((dir-A (ediff-get-default-directory-name))) - (list (ediff-read-file-name - "Directory to merge with revisions and ancestors:" dir-A nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directory-revisions-internal - dir1 regexp 'ediff-merge-revisions-with-ancestor - 'ediff-merge-directory-revisions-with-ancestor - )) - -;;;###autoload -(defalias - 'edir-merge-revisions-with-ancestor - 'ediff-merge-directory-revisions-with-ancestor) - -;;;###autoload -(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor) - -;; Run ediff-action (ediff-files, ediff-merge, ediff-merge-with-ancestors) -;; on a pair of directories (three directories, in case of ancestor). -;; The third argument, REGEXP, is a regular expression that can be used to -;; filter out certain file names. -;; JOBNAME is the symbol indicating the meta-job to be performed. -;; MERGE-DIR is the directory in which to store merged files. -(defun ediff-directories-internal (dir1 dir2 dir3 regexp action jobname - &optional startup-hooks) - ;; ediff-read-file-name is set to attach a previously entered file name if - ;; the currently entered file is a directory. This code takes care of that. - (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1)) - dir2 (if (file-directory-p dir2) dir2 (file-name-directory dir2))) - - (if (stringp dir3) - (setq dir3 (if (file-directory-p dir3) dir3 (file-name-directory dir3)))) - - (cond ((string= dir1 dir2) - (error "Directories A and B are the same: %s" dir1)) - ((and (eq jobname 'ediff-directories3) - (string= dir1 dir3)) - (error "Directories A and C are the same: %s" dir1)) - ((and (eq jobname 'ediff-directories3) - (string= dir2 dir3)) - (error "Directories B and C are the same: %s" dir1))) - - (let (diffs ; var where ediff-intersect-directories returns the diff list - merge-autostore-dir - file-list meta-buf) - (if (and ediff-autostore-merges (ediff-merge-metajob jobname)) - (setq merge-autostore-dir - (ediff-read-file-name "Directory to save merged files:" - (if ediff-use-last-dir - ediff-last-merge-autostore-dir - (ediff-strip-last-dir dir1)) - nil))) - ;; verify we are not merging into an orig directory - (if (stringp merge-autostore-dir) - (cond ((and (stringp dir1) (string= merge-autostore-dir dir1)) - (or (y-or-n-p "Merge directory same as directory A, sure? ") - (error "Directory merge aborted"))) - ((and (stringp dir2) (string= merge-autostore-dir dir2)) - (or (y-or-n-p "Merge directory same as directory B, sure? ") - (error "Directory merge aborted"))) - ((and (stringp dir3) (string= merge-autostore-dir dir3)) - (or (y-or-n-p - "Merge directory same as ancestor directory, sure? ") - (error "Directory merge aborted"))))) - - (setq file-list (ediff-intersect-directories - jobname 'diffs - regexp dir1 dir2 dir3 merge-autostore-dir)) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons (` (lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function (quote (, action))) - ;; set ediff-dir-difference-list - (setq ediff-dir-difference-list (quote (, diffs))))) - startup-hooks)) - (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action - file-list - "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer - jobname - startup-hooks)) - (ediff-show-meta-buffer meta-buf) - )) - -(defun ediff-directory-revisions-internal (dir1 regexp action jobname - &optional startup-hooks) - (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1))) - - (let (file-list meta-buf merge-autostore-dir) - (if (and ediff-autostore-merges (ediff-merge-metajob jobname)) - (setq merge-autostore-dir - (ediff-read-file-name "Directory to save merged files:" - (if ediff-use-last-dir - ediff-last-merge-autostore-dir - (ediff-strip-last-dir dir1)) - nil))) - ;; verify merge-autostore-dir != dir1 - (if (and (stringp merge-autostore-dir) - (stringp dir1) - (string= merge-autostore-dir dir1)) - (or (y-or-n-p - "Directory for saving merges is the same as directory A. Sure? ") - (error "Merge of directory revisions aborted"))) - - (setq file-list - (ediff-get-directory-files-under-revision - jobname regexp dir1 merge-autostore-dir)) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons (` (lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function (quote (, action))) - )) - startup-hooks)) - (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action - file-list - "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer - jobname - startup-hooks)) - (ediff-show-meta-buffer meta-buf) - )) - - -;;; Compare regions and windows - -;;;###autoload -(defun ediff-windows-wordwise (dumb-mode &optional wind-A wind-B startup-hooks) - "Compare WIND-A and WIND-B, which are selected by clicking, wordwise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." - (interactive "P") - (ediff-windows dumb-mode wind-A wind-B - startup-hooks 'ediff-windows-wordwise 'word-mode)) - -;;;###autoload -(defun ediff-windows-linewise (dumb-mode &optional wind-A wind-B startup-hooks) - "Compare WIND-A and WIND-B, which are selected by clicking, linewise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." - (interactive "P") - (ediff-windows dumb-mode wind-A wind-B - startup-hooks 'ediff-windows-linewise nil)) - -;; Compare WIND-A and WIND-B, which are selected by clicking. -;; With prefix argument, DUMB-MODE, or on a non-windowing display, -;; works as follows: -;; If WIND-A is nil, use selected window. -;; If WIND-B is nil, use window next to WIND-A. -(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode) - (if (or dumb-mode (not (ediff-window-display-p))) - (setq wind-A (ediff-get-next-window wind-A nil) - wind-B (ediff-get-next-window wind-B wind-A)) - (setq wind-A (ediff-get-window-by-clicking wind-A nil 1) - wind-B (ediff-get-window-by-clicking wind-B wind-A 2))) - - (let ((buffer-A (window-buffer wind-A)) - (buffer-B (window-buffer wind-B)) - beg-A end-A beg-B end-B) - - (save-excursion - (save-window-excursion - (sit-for 0) ; sync before using window-start/end -- a precaution - (select-window wind-A) - (setq beg-A (window-start) - end-A (window-end)) - (select-window wind-B) - (setq beg-B (window-start) - end-B (window-end)))) - (ediff-regions-internal - buffer-A beg-A end-A buffer-B beg-B end-B - startup-hooks job-name word-mode nil))) - -;;;###autoload -(defun ediff-regions-wordwise (buffer-A buffer-B &optional startup-hooks) - "Run Ediff on a pair of regions in two different buffers. -Regions \(i.e., point and mark\) are assumed to be set in advance. -This function is effective only for relatively small regions, up to 200 -lines. For large regions, use `ediff-regions-linewise'." - (interactive - (let (bf) - (list (setq bf (read-buffer "Region's A buffer: " - (ediff-other-buffer "") t)) - (read-buffer "Region's B buffer: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - (if (not (ediff-buffer-live-p buffer-A)) - (error "Buffer %S doesn't exist" buffer-A)) - (if (not (ediff-buffer-live-p buffer-B)) - (error "Buffer %S doesn't exist" buffer-B)) - - - (let (reg-A-beg reg-A-end reg-B-beg reg-B-end) - (save-excursion - (set-buffer buffer-A) - (setq reg-A-beg (region-beginning) - reg-A-end (region-end)) - (set-buffer buffer-B) - (setq reg-B-beg (region-beginning) - reg-B-end (region-end))) - - (ediff-regions-internal - (get-buffer buffer-A) reg-A-beg reg-A-end - (get-buffer buffer-B) reg-B-beg reg-B-end - startup-hooks 'ediff-regions-wordwise 'word-mode nil))) - -;;;###autoload -(defun ediff-regions-linewise (buffer-A buffer-B &optional startup-hooks) - "Run Ediff on a pair of regions in two different buffers. -Regions \(i.e., point and mark\) are assumed to be set in advance. -Each region is enlarged to contain full lines. -This function is effective for large regions, over 100-200 -lines. For small regions, use `ediff-regions-wordwise'." - (interactive - (let (bf) - (list (setq bf (read-buffer "Region A's buffer: " - (ediff-other-buffer "") t)) - (read-buffer "Region B's buffer: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - (if (not (ediff-buffer-live-p buffer-A)) - (error "Buffer %S doesn't exist" buffer-A)) - (if (not (ediff-buffer-live-p buffer-B)) - (error "Buffer %S doesn't exist" buffer-B)) - - (let (reg-A-beg reg-A-end reg-B-beg reg-B-end) - (save-excursion - (set-buffer buffer-A) - (setq reg-A-beg (region-beginning) - reg-A-end (region-end)) - ;; enlarge the region to hold full lines - (goto-char reg-A-beg) - (beginning-of-line) - (setq reg-A-beg (point)) - (goto-char reg-A-end) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq reg-A-end (point)) - - (set-buffer buffer-B) - (setq reg-B-beg (region-beginning) - reg-B-end (region-end)) - ;; enlarge the region to hold full lines - (goto-char reg-B-beg) - (beginning-of-line) - (setq reg-B-beg (point)) - (goto-char reg-B-end) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq reg-B-end (point)) - ) ; save excursion - - (ediff-regions-internal - (get-buffer buffer-A) reg-A-beg reg-A-end - (get-buffer buffer-B) reg-B-beg reg-B-end - startup-hooks 'ediff-regions-linewise nil nil))) ; no word mode - -;; compare region beg-A to end-A of buffer-A -;; to regions beg-B -- end-B in buffer-B. -(defun ediff-regions-internal (buffer-A beg-A end-A buffer-B beg-B end-B - startup-hooks job-name word-mode - setup-parameters) - (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer)) - overl-A overl-B - file-A file-B) - - ;; in case beg/end-A/B aren't markers--make them into markers - (ediff-with-current-buffer buffer-A - (setq beg-A (move-marker (make-marker) beg-A) - end-A (move-marker (make-marker) end-A))) - (ediff-with-current-buffer buffer-B - (setq beg-B (move-marker (make-marker) beg-B) - end-B (move-marker (make-marker) end-B))) - - (if (and (eq buffer-A buffer-B) - (or (and (< beg-A end-B) (<= beg-B beg-A)) ; b-B b-A e-B - (and (< beg-B end-A) (<= end-A end-B)))) ; b-B e-A e-B - (progn - (with-output-to-temp-buffer ediff-msg-buffer - (princ " -You have requested to compare overlapping regions of the same buffer. - -In this case, Ediff's highlighting may be confusing---in the same window, -you may see highlighted regions that belong to different regions. - -Continue anyway? (y/n) ")) - - (if (y-or-n-p "Continue anyway? ") - () - (error "%S aborted" job-name)))) - - ;; make file-A - (if word-mode - (ediff-wordify beg-A end-A buffer-A tmp-buffer) - (ediff-copy-to-buffer beg-A end-A buffer-A tmp-buffer)) - (setq file-A (ediff-make-temp-file tmp-buffer "regA")) - - ;; make file-B - (if word-mode - (ediff-wordify beg-B end-B buffer-B tmp-buffer) - (ediff-copy-to-buffer beg-B end-B buffer-B tmp-buffer)) - (setq file-B (ediff-make-temp-file tmp-buffer "regB")) - - (setq overl-A (ediff-make-bullet-proof-overlay beg-A end-A buffer-A)) - (setq overl-B (ediff-make-bullet-proof-overlay beg-B end-B buffer-B)) - (ediff-setup buffer-A file-A - buffer-B file-B - nil nil ; buffer & file C - (cons (` (lambda () - (delete-file (, file-A)) - (delete-file (, file-B)))) - startup-hooks) - (append - (list (cons 'ediff-word-mode word-mode) - (cons 'ediff-narrow-bounds (list overl-A overl-B)) - (cons 'ediff-job-name job-name)) - setup-parameters) - ) - )) - - -;;; Merge files and buffers - -;;;###autoload -(defalias 'ediff-merge 'ediff-merge-files) - -(defsubst ediff-merge-on-startup () - (ediff-do-merge 0) - (ediff-with-current-buffer ediff-buffer-C - (set-buffer-modified-p nil))) - -;;;###autoload -(defun ediff-merge-files (file-A file-B &optional startup-hooks) - "Merge two files without ancestor." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B f) - (list (setq f (ediff-read-file-name - "File A to merge" dir-A - (ediff-get-default-file-name))) - (ediff-read-file-name "File B to merge" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f)) - ))) - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - nil ; file-C - startup-hooks - 'ediff-merge-files)) - -;;;###autoload -(defun ediff-merge-files-with-ancestor (file-A file-B file-ancestor - &optional startup-hooks) - "Merge two files with ancestor." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B dir-ancestor f ff) - (list (setq f (ediff-read-file-name - "File A to merge" dir-A - (ediff-get-default-file-name))) - (setq ff (ediff-read-file-name "File B to merge" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons - (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f))) - (ediff-read-file-name "Ancestor file" - (setq dir-ancestor - (if ediff-use-last-dir - ediff-last-dir-ancestor - (file-name-directory ff))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory ff) - dir-ancestor)) - file-name-history)) - ff)) - ))) - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - file-ancestor - startup-hooks - 'ediff-merge-files-with-ancestor)) - -;;;###autoload -(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor) - -;;;###autoload -(defun ediff-merge-buffers (buffer-A buffer-B &optional startup-hooks job-name) - "Merge buffers without ancestor." - (interactive - (let (bf) - (list (setq bf (read-buffer "Buffer A to merge: " - (ediff-other-buffer "") t)) - (read-buffer "Buffer B to merge: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (or job-name (setq job-name 'ediff-merge-buffers)) - (ediff-buffers-internal - buffer-A buffer-B nil startup-hooks job-name)) - -;;;###autoload -(defun ediff-merge-buffers-with-ancestor (buffer-A - buffer-B buffer-ancestor - &optional startup-hooks job-name) - "Merge buffers with ancestor." - (interactive - (let (bf bff) - (list (setq bf (read-buffer "Buffer A to merge: " - (ediff-other-buffer "") t)) - (setq bff (read-buffer "Buffer B to merge: " - (progn - ;; realign buffers so that two visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)) - (read-buffer "Ancestor buffer: " - (progn - ;; realign buffers so that three visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer (list bf bff))) - t) - ))) - - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (or job-name (setq job-name 'ediff-merge-buffers-with-ancestor)) - (ediff-buffers-internal - buffer-A buffer-B buffer-ancestor startup-hooks job-name)) - - -;;;###autoload -(defun ediff-merge-revisions (&optional file startup-hooks) - "Run Ediff by merging two revisions of a file. -The file is the optional FILE argument or the file visited by the current -buffer." - (interactive) - (if (stringp file) (find-file file)) - (let (rev1 rev2) - (setq rev1 - (read-string - (format - "Version 1 to merge (default: %s's latest version): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - rev2 - (read-string - (format - "Version 2 to merge (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer")))) - (ediff-load-version-control) - ;; ancestor-revision=nil - (funcall - (intern (format "ediff-%S-merge-internal" ediff-version-control-package)) - rev1 rev2 nil startup-hooks))) - - -;;;###autoload -(defun ediff-merge-revisions-with-ancestor (&optional file startup-hooks) - "Run Ediff by merging two revisions of a file with a common ancestor. -The file is the the optional FILE argument or the file visited by the current -buffer." - (interactive) - (if (stringp file) (find-file file)) - (let (rev1 rev2 ancestor-rev) - (setq rev1 - (read-string - (format - "Version 1 to merge (default: %s's latest version): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - rev2 - (read-string - (format - "Version 2 to merge (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - ancestor-rev - (read-string - (format - "Ancestor version (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer")))) - (ediff-load-version-control) - (funcall - (intern (format "ediff-%S-merge-internal" ediff-version-control-package)) - rev1 rev2 ancestor-rev startup-hooks))) - -;;;###autoload -(defun run-ediff-from-cvs-buffer (pos) - "Run Ediff-merge on appropriate revisions of the selected file. -First run after `M-x cvs-update'. Then place the cursor on a line describing a -file and then run `run-ediff-from-cvs-buffer'." - (interactive "d") - (ediff-load-version-control) - (let ((tin (tin-locate cvs-cookie-handle pos))) - (if tin - (cvs-run-ediff-on-file-descriptor tin) - (error "There is no file to merge")))) - - -;;; Apply patch - -;;;###autoload -(defun ediff-patch-file () - "Run Ediff by patching SOURCE-FILENAME." - ;; This now returns the control buffer - (interactive) - (let (source-dir source-file patch-buf) - (require 'ediff-ptch) - (setq patch-buf (ediff-get-patch-buffer)) - (setq source-dir (cond (ediff-use-last-dir ediff-last-dir-patch) - ((and (not ediff-patch-default-directory) - (buffer-file-name patch-buf)) - (file-name-directory - (expand-file-name - (buffer-file-name patch-buf)))) - (t default-directory))) - (setq source-file - ;; the default is the directory, not the visited file name - (ediff-read-file-name - "Which file to patch? " source-dir (ediff-get-default-file-name))) - (ediff-dispatch-file-patching-job patch-buf source-file))) - -;;;###autoload -(defun ediff-patch-buffer () - "Run Ediff by patching BUFFER-NAME." - (interactive) - (let (patch-buf) - (require 'ediff-ptch) - (setq patch-buf (ediff-get-patch-buffer)) - (ediff-patch-buffer-internal - patch-buf - (read-buffer "Which buffer to patch? " - (cond ((eq patch-buf (current-buffer)) - (ediff-other-buffer (current-buffer))) - (t (current-buffer))) - 'must-match)))) - -;;;###autoload -(defalias 'epatch 'ediff-patch-file) -;;;###autoload -(defalias 'epatch-buffer 'ediff-patch-buffer) - - - - -;;; Versions Control functions - -;;;###autoload -(defun ediff-revision (&optional file startup-hooks) - "Run Ediff by comparing versions of a file. -The file is an optional FILE argument or the file visited by the current -buffer. Use `vc.el' or `rcs.el' depending on `ediff-version-control-package'." - ;; if buffer is non-nil, use that buffer instead of the current buffer - (interactive "P") - (if (stringp file) (find-file file)) - (let (rev1 rev2) - (setq rev1 - (read-string - (format "Version 1 to compare (default: %s's latest version): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - rev2 - (read-string - (format "Version 2 to compare (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer")))) - (ediff-load-version-control) - (funcall - (intern (format "ediff-%S-internal" ediff-version-control-package)) - rev1 rev2 startup-hooks) - )) - - -;;;###autoload -(defalias 'erevision 'ediff-revision) - - -;; Test if version control package is loaded and load if not -;; Is SILENT is non-nil, don't report error if package is not found. -(defun ediff-load-version-control (&optional silent) - (require 'ediff-vers) - (or (featurep ediff-version-control-package) - (if (locate-library (symbol-name ediff-version-control-package)) - (progn - (message "") ; kill the message from `locate-library' - (require ediff-version-control-package)) - (or silent - (error "Version control package %S.el not found. Use vc.el instead" - ediff-version-control-package))))) - - -;;;###autoload -(defun ediff-version () - "Return string describing the version of Ediff. -When called interactively, displays the version." - (interactive) - (if (interactive-p) - (message (ediff-version)) - (format "Ediff %s of %s" ediff-version ediff-date))) - - -;;;###autoload -(defun ediff-documentation (&optional node) - "Display Ediff's manual. -With optional NODE, goes to that node." - (interactive) - (let ((ctl-window ediff-control-window) - (ctl-buf ediff-control-buffer)) - - (ediff-skip-unsuitable-frames) - (condition-case nil - (progn - (pop-to-buffer (get-buffer-create "*info*")) - (info (if ediff-xemacs-p "ediff.info" "ediff")) - (if node - (Info-goto-node node) - (message "Type `i' to search for a specific topic")) - (raise-frame (selected-frame))) - (error (beep 1) - (with-output-to-temp-buffer ediff-msg-buffer - (princ ediff-BAD-INFO)) - (if (window-live-p ctl-window) - (progn - (select-window ctl-window) - (set-window-buffer ctl-window ctl-buf))))))) - - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -(require 'ediff-util) - -;;; ediff.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/Makefile --- a/lisp/efs/Makefile Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,314 +0,0 @@ -############################################################################### -# -# File: Makefile -# Release: $efs release: 1.15 $ -# Version: $Revision: 1.9 $ -# RCS: -# Description: Makefile for byte-compiling efs and dired. -# Author: Andy Norman, HPLabs, Bristol, UK. -# Created: Sat Jan 30 00:18:56 1993 -# Language: Text (make script) -# -############################################################################### - -## Installation Instructions -############################ -# 1. Edit the configuration variables below. -# EMACS should be the name of the emacs program on your system. -# VERSION should be the emacs version. This must be one of: -# 18 for all versions of Emacs 18. -# 19 for all versions of the original GNU Emacs from FSF between -# 19.1 and 19.22, inclusive. -# 19.23 for version 19.23 and later of the original GNU Emacs from FSF -# l19.11 for XEmacs 19.11 trhu 19.14 -# x19.15 for XEmacs 19.15 -# x20 for XEmacs 20.1 and later -# LISPDIR should be the directory in which you want the .elc -# files installed. -# BDIR should be the directory containing the .elc files for the -# byte-compiler. Although efs byte-compiles and works with the -# Emacs V18 byte-compiler, it is strongly recommended to use -# Jamie Zawinski's V19 byte-compiler. This byte-compiler is -# standard with Lucid Emacs, XEmacs, and GNU Emacs V19, so in this -# case you can set BDIR to nothing. -# VMDIR should be set to the directory containing the .elc files for -# VM. If you aren't using VM, then set this to nothing. -# -# 2. To byte-compile the entire package, except for VM support (efs-vm.el), -# run make VERSION, where VERSION is the emacs version that you are -# compiling for. It must be one of: -# 18 for Emacs 18 -# 19 for the original GNU Emacs from FSF, versions 19.1 through -# 19.22, inclusive -# 19.23 for the original GNU Emacs from FSF, version 19.23 and later. -# l19.11 for Lucid XEmacs 19.11 thru 19.14 -# x19.15 for XEmacs 19.15 -# x20 for XEmacs 20.1 and later -# -# If you have set the VERSION variable correctly, then typing just -# make will suffice. -# -# 3. To byte-compile everything, including VM support, run make all. -# -# 4. To byte-compile all the efs files, except for VM support, -# run make efs. -# -# 5. To byte-compile only the core efs files run make core. -# -# 6. To byte compile an efs-XXX.el file, run make XXX. -# This means that VM support can be compiled by running make vm. -# -# 7. To byte compile only dired, run make dired. -# -# 8. To byte-compile only efs-auto.el, for autoloading efs, run make auto. -# - -## Edit these variables according to your configuration. - -# Name of Emacs program -EMACS=xemacs -# Emacs version. This must be set to one of 18, 19, 19.23, -# l19.11, x19.15 -VERSION=x19.15 -# Current working directory -CWD=`pwd` -# Directory in which to install the lisp files -LISPDIR= -# Directory in which to install the info files -INFODIR= -# Directory in which to install the Texinfo file -TEXIDIR= -# Directory containing byte-compiler. This is used by fixup.el -BDIR= -# Directory containing VM's .elc files. -VMDIR= -# Bourne shell executable, please. -SHELL=/bin/sh - -###### It should not be necessary to edit anything below this line. ###### - -COREOBJS = efs-defun.elc efs-ovwrt.elc efs-fnh.elc efs-cu.elc efs-netrc.elc \ - efs.elc efs-dired.elc efs-report.elc \ - efs-cp-p.elc \ - efs-dump.elc -CORESRC = efs-defun.el efs-ovwrt.el efs-fnh.el efs-cu.el efs-netrc.el \ - efs.el efs-dired.el efs-report.el \ - efs-cp-p.el \ - efs-dump.el -DOBJS = default-dir.elc dired.elc dired-mob.elc dired-oas.elc \ - dired-rgxp.elc dired-shell.elc dired-vir.elc dired-xy.elc \ - dired-grep.elc dired-uu.elc \ - dired-cmpr.elc dired-diff.elc dired-help.elc dired-sex.elc -DSRC = default-dir.el dired.el dired-mob.el dired-oas.el \ - dired-rgxp.el dired-shell.el dired-vir.el dired-xy.el \ - dired-grep.el dired-uu.el \ - dired-cmpr.el dired-diff.el dired-help.el dired-sex.el -EFSOBJS = $(COREOBJS) efs-auto.elc \ - efs-cms.elc efs-cms-knet.elc efs-dos-distinct.elc efs-nos-ve.elc \ - efs-gwp.elc efs-kerberos.elc efs-hell.elc efs-ka9q.elc \ - efs-mpe.elc efs-mts.elc efs-mvs.elc efs-netware.elc \ - efs-pc.elc efs-ti-explorer.elc efs-ti-twenex.elc \ - efs-tops-20.elc efs-dl.elc efs-guardian.elc efs-coke.elc \ - efs-vms.elc efs-vos.elc efs-plan9.elc efs-ms-unix.elc -EFSSRC = $(CORESRC) efs-auto.el \ - efs-cms.el efs-cms-knet.el efs-dos-distinct.el efs-nos-ve.el \ - efs-gwp.el efs-kerberos.el efs-hell.el efs-ka9q.el \ - efs-mpe.el efs-mts.el efs-mvs.el efs-netware.el \ - efs-pc.el efs-ti-explorer.el efs-ti-twenex.el \ - efs-tops-20.el efs-dl.el efs-guardian.el efs-coke.el \ - efs-vms.el efs-vos.el efs-plan9.el efs-ms-unix.el -VMOBJS = efs-vm.elc -VMSRC = efs-vm.el -MULEOBJS = dired-mule.elc efs-dired-mule.elc -MULESRC = dired-mule.el efs-dired-mule.el -GEOBJS = dired-fsf.elc \ - passwd.elc diff.elc auto-save.elc \ - $(MULEOBJS) -GESRC = dired-fsf.el \ - passwd.el diff.el auto-save.el \ - $(MULESRC) -XEOBJS = dired-faces.elc dired-xemacs.elc \ - $(VMOBJS) -XESRC = dired-faces.el dired-xemacs.el \ - $(VMSRC) $(MULESRC) -OBJS = $(DOBJS) $(EFSOBJS) $(VMOBJS) $(GEOBJS) $(XEOBJS) \ - efs-18.elc efs-19.elc efs-19.23.elc \ - efs-l19.11.elc efs-x19.15.elc \ - emacs-19.elc fn-handler.elc \ - reporter.elc - -# fixup.el is never byte-compiled. It would do no harm, but be a waste -# of time. - -## Specify new rules. - -.SUFFIXES: .elc .el .texi .info - -.el.elc: - BDIR=$(BDIR) CWD=$(CWD) VMDIR=$(VMDIR) \ - $(EMACS) -batch -no-site-file -l $(CWD)/fixup -f batch-byte-compile $(CWD)/$< - -.texi.info: - $(EMACS) -batch -f batch-texinfo-format $(CWD)/$< - -## targets - -# What lazy fingers buys you -default: $(VERSION) dired - -# .elc files depend on .el source -# Do this in this brain-dead way because different makes do pattern -# rules differently. grumble grumble... -# -# dired -dired.elc: dired.el -dired-mob.elc: dired-mob.el -dired-oas.elc: dired-oas.el -dired-rgxp.elc: dired-rgxp.el -dired-shell.elc: dired-shell.el -dired-vir.elc: dired-vir.el -dired-xy.elc: dired-xy.el -dired-grep.elc: dired-grep.el -dired-uu.elc: dired-uu.el -dired-fsf.elc: dired-fsf.el -dired-cmpr.elc: dired-cmpr.el -dired-help.elc: dired-help.el -dired-diff.elc: dired-diff.el -dired-sex.elc: dired-sex.el -dired-mule.elc: dired-mule.el -dired-xemacs.elc: dired-xemacs.el -dired-faces.elc: dired-faces.el -default-dir.elc: default-dir.el -diff.elc: diff.el -# efs core files -efs.elc: efs.el -efs-defun.elc: efs-defun.el -efs-cp-p.elc: efs-cp-p.el -efs-cu.elc: efs-cu.el -efs-netrc.elc: efs-netrc.el -efs-auto.elc: efs-auto.el -efs-dired.elc: efs-dired.el -efs-dired-mule.elc: efs-dired-mule.el -efs-report.elc: efs-report.el -efs-ovwrt.elc: efs-ovwrt.el -efs-fnh.elc: efs-fnh.el -# efs multi-OS and FTP server support -efs-cms.elc: efs-cms.el -efs-cms-knet.elc: efs-cms-knet.el -efs-coke.elc: efs-coke.el -efs-dos-distinct.elc: efs-dos-distinct.el -efs-nos-ve.elc: efs-nos-ve.el -efs-gwp.elc: efs-gwp.el -efs-hell.elc: efs-hell.el -efs-ka9q.elc: efs-ka9q.el -efs-kerberos.elc: efs-kerberos.el -efs-mpe.elc: efs-mpe.el -efs-mts.elc: efs-mts.el -efs-mvs.elc: efs-mvs.el -efs-netware.elc: efs-netware.el -efs-pc.elc: efs-pc.el -efs-ti-explorer.elc: efs-ti-explorer.el -efs-ti-twenex.elc: efs-ti-twenex.el -efs-tops-20.elc: efs-tops-20.el -efs-dl.elc: efs-dl.el -efs-vms.elc: efs-vms.el -efs-vos.elc: efs-vos.el -efs-guardian.elc: efs-guardian.el -efs-plan9.elc: efs-plan9.el -efs-ms-unix.elc: efs-ms-unix.el -# efs support for different Emacs versions -efs-18.elc: efs-18.el -efs-19.elc: efs-19.el -efs-19.23.elc: efs-19.23.el -efs-l19.11.elc: efs-l19.11.el -efs-x19.15.elc: efs-x19.15.el -# efs vm support -efs-vm.elc: efs-vm.el -# backward compatibility files -fn-handler.elc: fn-handler.el -emacs-19.elc: emacs-19.el -# auto-save package -auto-save.elc: auto-save.el - -# Core targets -core: $(COREOBJS) - -# Extra perks -auto: core efs-auto.elc -cms: core efs-cms.elc -cms-knet: core efs-cms-knet.elc -dos-distinct: core efs-dos-distinct.elc -nos-ve: core efs-nos-ve.elc -gwp: core efs-gwp.elc -hell: core efs-hell.elc -ka9q: core efs-ka9q.elc -kerberos: core efs-kerberos.elc -mpe: core efs-mpe.elc -mts: core efs-mts.elc -mvs: core efs-mvs.elc -netware: core efs-netware.elc -pc: core efs-pc.elc -ti-explorer: core efs-ti-explorer.elc -ti-twenex: core efs-ti-twenex.elc -tops-20: core efs-tops-20.elc -dl: core efs-dl.elc -vms: core efs-vms.elc -vos: core efs-vos.elc -guardian: core efs-guardian.elc -plan9: core efs-plan9.elc -coke: core efs-coke.elc -vm: core $(VMOBJS) - -# The grand tour -efs: $(EFSOBJS) -dired: $(DOBJS) -all: $(OBJS) -info: efs.info - -# Making for a specific emacs version -18: emacs-19.elc fn-handler.elc efs dired efs-18.elc dired-mule.elc \ - efs-dired-mule.elc reporter.elc passwd.elc diff.elc auto-save.elc -19: fn-handler.elc efs dired efs-19.elc $(GEOBJS) -19.23: efs dired efs-19.23.elc $(GEOBJS) -l19.11: efs dired efs-l19.11.elc $(XEOBJS) -x19.15: efs dired efs-x19.15.elc $(XEOBJS) -x20: efs dired efs-x19.15.elc $(XEOBJS) $(MULEOBJS) - -# Installation -install: - @echo "Installing in $(LISPDIR)..." - cp *.elc $(LISPDIR) - cp efs.info $(INFODIR) -install_src: - @echo "Installing in $(LISPDIR)..." - cp `ls *.el | grep -v "fixup"` $(LISPDIR) - cp efs.texi $(TEXIDIR) -install_xemacs: - @echo "Installing source in $(LISPDIR)..." - cp $(EFSSRC) $(DSRC) $(XESRC) efs-x19.15.el $(LISPDIR) - cp Makefile README fixup.el $(LISPDIR) - cp efs.texi $(TEXIDIR) -diff_xemacs: - for f in $(EFSSRC) $(DSRC) $(XESRC) efs-x19.15.el \ - Makefile README fixup.el; do \ - if [ -e $(LISPDIR)/$$f ]; \ - then\ - diff -c $(LISPDIR)/$$f $$f; \ - else \ - diff -c /dev/null $$f; \ - fi \ - done -install_all: install_src install -clean: - rm -f $(OBJS) - -autoloads: auto-autoloads.el - -auto-autoloads.el: $(EFSSRC) $(DSRC) efs-x19.15.el $(XESRC) $(MULESRC) - $(EMACS) -batch -q -no-site-file \ - -eval '(setq autoload-target-directory "'`pwd`'/")' \ - -eval '(setq autoload-package-name "efs")' \ - -l autoload \ - -f batch-update-autoloads $? - -## end of Makefile ## diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/README --- a/lisp/efs/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -This version of EFS was modified for integration with XEmacs by -Mike Sperber . -He is the current maintainer of this version of EFS. - -A Few Things That You Should Know About EFS: --------------------------------------------- - -For documentation, see the first page of the file efs.el. If you -access FTP via a gateway, then be sure to read the documentation in -efs.el on how to configure efs to use a gateway. To find the section -on user customization variables in efs.el, search for the first -occurrence of the string ">>>>". TeXinfo documentation is -forthcoming. - -The file CHANGES contains a description of changes to EFS from the -previous release to this release. It also tells you where you can get -the latest version of efs. - -The file LISTS contains a description of mailing lists relevant to -efs. It too tells you where you can get the latest version of efs. -We encourage users to join these lists. - -EFS and archie.el: ------------------- - -To use archie.el (by Jack Repenning) with efs, you need at least -archie.el V3.0.1. Problems using efs with archie may be posted to the -efs mailing lists. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/auto-autoloads.el --- a/lisp/efs/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,268 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'efs-autoloads) (error "Already loaded")) - -;;;### (autoloads nil "default-dir" "efs/default-dir.el") - -(defvar default-directory-function nil "\ -A function to call to compute the default-directory for the current buffer. -If this is nil, the function default-directory will return the value of the -variable default-directory. -Buffer local.") - -;;;*** - -;;;### (autoloads (dired-jump-back-other-frame dired-jump-back-other-window dired-jump-back dired-noselect dired-other-frame dired-other-window dired default-directory) "dired" "efs/dired.el") - -(autoload 'default-directory "dired" "\ - Returns the default-directory for the current buffer. -Will use the variable default-directory-function if it non-nil." nil nil) - -(defvar dired-compression-method 'compress "\ -*Type of compression program to use. -Give as a symbol. -Currently-recognized methods are: gzip pack compact compress. -To change this variable use \\[dired-do-compress] with a zero prefix.") - -(defvar dired-compression-method-alist '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") (pack ".z" ("pack" "-f") ("unpack")) (compact ".C" ("compact") ("uncompact"))) "\ -*Association list of compression method descriptions. - Each element of the table should be a list of the form - - (compress-type extension (compress-args) (decompress-args) force-flag) - - where - `compress-type' is a unique symbol in the alist to which - `dired-compression-method' can be set; - `extension' is the file extension (as a string) used by files compressed - by this method; - `compress-args' is a list of the path of the compression program and - flags to pass as separate arguments; - `decompress-args' is a list of the path of the decompression - program and flags to pass as separate arguments. - `force-flag' is the switch to pass to the command to force overwriting - of existing files. - - For example: - - (setq dired-compression-method-alist - (cons '(frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\") \"-f\") - dired-compression-method-alist)) - => ((frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\")) - (gzip \".gz\" (\"gzip\") (\"gunzip\")) - ...) - - See also: dired-compression-method ") - -(defvar dired-ls-program "ls" "\ -*Absolute or relative name of the ls program used by dired.") - -(defvar dired-listing-switches "-al" "\ -*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -(defvar dired-chown-program (if (memq system-type '(hpux dgux usg-unix-v linux)) "chown" "/etc/chown") "\ -*Name of chown command (usually `chown' or `/etc/chown').") - -(defvar dired-gnutar-program nil "\ -*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") - -(defvar dired-unshar-program nil "\ -*Set to the name of the unshar program, if you have it.") - -(defvar dired-local-variables-file ".dired" "\ -*If non-nil, filename for local variables for Dired. -If Dired finds a file with that name in the current directory, it will -temporarily insert it into the dired buffer and run `hack-local-variables'. - -Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on -local variables.") - -(defvar dired-kept-versions 2 "\ -*When cleaning directory, number of versions to keep.") - -(defvar dired-find-subdir nil "\ -*Determines whether dired tries to lookup a subdir in existing buffers. -If non-nil, dired does not make a new buffer for a directory if it can be -found (perhaps as subdir) in some existing dired buffer. If there are several -dired buffers for a directory, then the most recently used one is chosen. - -Dired avoids switching to the current buffer, so that if you have -a normal and a wildcard buffer for the same directory, C-x d RET will -toggle between those two.") - -(defvar dired-use-file-transformers t "\ -*Determines whether dired uses file transformers. -If non-nil `dired-do-shell-command' will apply file transformers to file names. -See \\[describe-function] for dired-do-shell-command for more information.") - -(defvar dired-dwim-target nil "\ -*If non-nil, dired tries to guess a default target directory. -This means that if there is a dired buffer displayed in the next window, -use its current subdir, instead of the current subdir of this dired buffer. -The target is put in the prompt for file copy, rename, etc.") - -(defvar dired-copy-preserve-time nil "\ -*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\ -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -(defvar dired-no-confirm nil "\ -*If non-nil, a list of symbols for commands dired should not confirm. -It can be a sublist of - - '(byte-compile chgrp chmod chown compress copy delete hardlink load - move print shell symlink uncompress recursive-delete kill-file-buffer - kill-dired-buffer patch create-top-dir revert-subdirs) - -The meanings of most of the symbols are obvious. A few exceptions: - - 'compress applies to compression or decompression by any of the - compression program in `dired-compression-method-alist'. - - 'kill-dired-buffer applies to offering to kill dired buffers for - directories which have been deleted. - - 'kill-file-buffer applies to offering to kill buffers visiting files - which have been deleted. - - 'recursive-delete applies to recursively deleting non-empty - directories, and all of their contents. - - 'create-top-dir applies to `dired-up-directory' creating a new top level - directory for the dired buffer. - - 'revert-subdirs applies to re-reading subdirectories which have - been modified on disk. - -Note that this list also applies to remote files accessed with efs -or ange-ftp.") - -(defvar dired-backup-if-overwrite nil "\ -*Non-nil if Dired should ask about making backups before overwriting files. -Special value 'always suppresses confirmation.") - -(defvar dired-omit-files nil "\ -*If non-nil un-interesting files will be omitted from this dired buffer. -Use \\[dired-omit-toggle] to see these files. (buffer local)") - -(defvar dired-mail-reader 'vm "\ -*Mail reader used by dired for dired-read-mail (\\[dired-read-mail]). -The symbols 'rmail and 'vm are the only two allowed values.") - -(defvar dired-refresh-automatically t "\ -*If non-nil, refresh dired buffers automatically after file operations.") - -(define-key ctl-x-map "d" 'dired) - -(autoload 'dired "dired" "\ -\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -Optional second argument SWITCHES specifies the `ls' options used. -\(Interactively, use a prefix argument to be able to specify SWITCHES.) -Dired displays a list of files in DIRNAME (which may also have -shell wildcards appended to select certain files). If DIRNAME is a cons, -its first element is taken as the directory name and the resr as an explicit -list of files to make directory entries for. -\\You can move around in it with the usual commands. -You can flag files for deletion with \\[dired-flag-file-deletion] and then -delete them by typing \\[dired-expunge-deletions]. -Type \\[dired-describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." t nil) - -(define-key ctl-x-4-map "d" 'dired-other-window) - -(autoload 'dired-other-window "dired" "\ -\"Edit\" directory DIRNAME. Like `dired' but selects in another window." t nil) - -(define-key ctl-x-5-map "d" 'dired-other-frame) - -(autoload 'dired-other-frame "dired" "\ -\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." t nil) - -(autoload 'dired-noselect "dired" "\ -Like `dired' but returns the dired buffer as value, does not select it." nil nil) - -(define-key ctl-x-map "\C-j" 'dired-jump-back) - -(autoload 'dired-jump-back "dired" "\ -Jump back to dired. -If in a file, dired the current directory and move to file's line. -If in dired already, pop up a level and goto old directory's line. -In case the proper dired file line cannot be found, refresh the dired - buffer and try again." t nil) - -(define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) - -(autoload 'dired-jump-back-other-window "dired" "\ -Like \\[dired-jump-back], but to other window." t nil) - -(define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) - -(autoload 'dired-jump-back-other-frame "dired" "\ -Like \\[dired-jump-back], but in another frame." t nil) - -;;;*** - -;;;### (autoloads (efs-ftp-path) "efs-cu" "efs/efs-cu.el") - -(defvar efs-path-root-regexp "^/[^/:]+:" "\ -Regexp to match the `/user@host:' root of an efs full path.") - -(autoload 'efs-ftp-path "efs-cu" "\ -Parse PATH according to efs-path-regexp. -Returns a list (HOST USER PATH), or nil if PATH does not match the format." nil nil) - -;;;*** - -;;;### (autoloads (remote-path-file-handler-function) "efs-dump" "efs/efs-dump.el") - -(or (assoc efs-path-root-regexp file-name-handler-alist) (setq file-name-handler-alist (cons (cons efs-path-root-regexp 'remote-path-file-handler-function) file-name-handler-alist))) - -(autoload 'remote-path-file-handler-function "efs-dump" "\ -Function to call special file handlers for remote files." nil nil) - -;;;*** - -;;;### (autoloads nil "efs-fnh" "efs/efs-fnh.el") - -(defvar allow-remote-paths t "\ -*Set this to nil if you don't want remote paths to access -remote files.") - -;;;*** - -;;;### (autoloads (efs-root-file-name-completion efs-root-file-name-all-completions efs-set-passwd) "efs-netrc" "efs/efs-netrc.el") - -(autoload 'efs-set-passwd "efs-netrc" "\ -For a given HOST and USER, set or change the associated PASSWORD." t nil) - -(autoload 'efs-root-file-name-all-completions "efs-netrc" nil nil nil) - -(autoload 'efs-root-file-name-completion "efs-netrc" nil nil nil) - -;;;*** - -;;;### (autoloads (efs-report-bug) "efs-report" "efs/efs-report.el") - -(autoload 'efs-report-bug "efs-report" "\ -Submit a bug report for efs." t nil) - -;;;*** - -;;;### (autoloads (efs-file-handler-function efs-nslookup-host efs-display-ftp-activity) "efs" "efs/efs.el") - -(autoload 'efs-display-ftp-activity "efs" "\ -Displays the number of active background ftp sessions in the modeline. -Uses the variable `efs-mode-line-format' to determine how this will be -displayed." t nil) - -(autoload 'efs-nslookup-host "efs" "\ -Attempt to resolve the given HOSTNAME using nslookup if possible." t nil) - -(autoload 'efs-file-handler-function "efs" "\ -Function to call special file handlers for remote files." nil nil) - -;;;*** - -(provide 'efs-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/custom-load.el --- a/lisp/efs/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Thu Oct 9 20:52:10 1997 - -;;; Code: - -(custom-put 'environment 'custom-loads '("dired-faces")) -(custom-put 'dired 'custom-loads '("dired-faces")) - -;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/default-dir.el --- a/lisp/efs/default-dir.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,418 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: default-dir.el -;; RCS: -;; Version: #Revision: 1.5 $ -;; Description: Defines the function default-directory, for fancy handling -;; of the initial contents in the minibuffer when reading -;; file names. -;; Authors: Sebastian Kremer -;; Sandy Rutherford -;; Created: Sun Jul 18 11:38:06 1993 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'default-dir) -(require 'efs-ovwrt) - -(defconst default-dir-emacs-variant - (cond ((string-match "XEmacs" emacs-version) 'xemacs) - ((>= (string-to-int (substring emacs-version 0 2)) 19) 'fsf-19) - (t 'fsf-18))) - -(defconst default-dir-find-file-takes-coding-system - (and (eq default-dir-emacs-variant 'xemacs) - (>= (string-to-int (substring emacs-version 0 2)) 20))) - -;;;###autoload -(defvar default-directory-function nil - "A function to call to compute the default-directory for the current buffer. -If this is nil, the function default-directory will return the value of the -variable default-directory. -Buffer local.") -(make-variable-buffer-local 'default-directory-function) - -;; As a bonus we give shell-command history if possible. -(defvar shell-command-history nil - "History list of previous shell commands.") - -(defun default-directory () - " Returns the default-directory for the current buffer. -Will use the variable default-directory-function if it non-nil." - (if default-directory-function - (funcall default-directory-function) - (if (eq default-dir-emacs-variant 'xemacs) - (abbreviate-file-name default-directory t) - (abbreviate-file-name default-directory)))) - -;;; Overloads - -(cond - ((or (featurep 'mule) - (boundp 'MULE)) - - (defun default-dir-find-file (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file: " (default-directory))) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file file coding-system)) - - (defun default-dir-find-file-other-window (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other window: " (default-directory))) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-other-window file coding-system)) - - (defun default-dir-find-file-read-only (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only: " (default-directory) nil t)) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-read-only file coding-system)) - - (if (fboundp 'find-file-read-only-other-window) - (progn - (defun default-dir-find-file-read-only-other-window - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name - "Find file read-only in other window: " - (default-directory) nil t)) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-read-only-other-window file - coding-system)))) - - (if (fboundp 'find-file-other-frame) - (progn - (defun default-dir-find-file-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other frame: " - (default-directory))) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-other-frame file - coding-system)))) - - (if (fboundp 'find-file-read-only-other-frame) - (progn - (defun default-dir-find-file-read-only-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only in other frame: " - (default-directory) nil t)) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-read-only-other-frame file - coding-system))))) - - (default-dir-find-file-takes-coding-system - ;; This lossage is due to the fact that XEmacs 20.x without mule - ;; still accepts an optional argument for find-file related - ;; functions. Things like advice.el insist on passing nil for - ;; optional arguments, and the interaction screws things up. - ;; Therefore these functions accept an optional dummy coding-system - ;; argument. - - (defun default-dir-find-file (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file: " (default-directory))))) - (default-dir-real-find-file file)) - - (defun default-dir-find-file-other-window (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other window: " (default-directory))))) - (default-dir-real-find-file-other-window file)) - - (defun default-dir-find-file-read-only (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only: " (default-directory) nil t)))) - (default-dir-real-find-file-read-only file)) - - (if (fboundp 'find-file-read-only-other-window) - (progn - (defun default-dir-find-file-read-only-other-window - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name - "Find file read-only in other window: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-window file)))) - - (if (fboundp 'find-file-other-frame) - (progn - (defun default-dir-find-file-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other frame: " - (default-directory))))) - (default-dir-real-find-file-other-frame file)))) - - (if (fboundp 'find-file-read-only-other-frame) - (progn - (defun default-dir-find-file-read-only-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only in other frame: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-frame file))))) - - (t - - (defun default-dir-find-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file: " (default-directory))))) - (default-dir-real-find-file file)) - - (defun default-dir-find-file-other-window (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other window: " (default-directory))))) - (default-dir-real-find-file-other-window file)) - - (defun default-dir-find-file-read-only (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only: " (default-directory) nil t)))) - (default-dir-real-find-file-read-only file)) - - (if (fboundp 'find-file-read-only-other-window) - (progn - (defun default-dir-find-file-read-only-other-window (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name - "Find file read-only in other window: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-window file)))) - - (if (fboundp 'find-file-other-frame) - (progn - (defun default-dir-find-file-other-frame (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other frame: " - (default-directory))))) - (default-dir-real-find-file-other-frame file)))) - - (if (fboundp 'find-file-read-only-other-frame) - (progn - (defun default-dir-find-file-read-only-other-frame (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only in other frame: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-frame file)))))) - - - -(efs-overwrite-fn "default-dir" 'find-file 'default-dir-find-file) -(efs-overwrite-fn "default-dir" 'find-file-other-window - 'default-dir-find-file-other-window) -(if (fboundp 'find-file-other-frame) - (efs-overwrite-fn "default-dir" 'find-file-other-frame - 'default-dir-find-file-other-frame)) -(efs-overwrite-fn "default-dir" 'find-file-read-only - 'default-dir-find-file-read-only) -(if (fboundp 'find-file-read-only-other-window) - (efs-overwrite-fn "default-dir" 'find-file-read-only-other-window - 'default-dir-find-file-read-only-other-window)) -(if (fboundp 'find-file-read-only-other-frame) - (efs-overwrite-fn "default-dir" 'find-file-read-only-other-frame - 'default-dir-find-file-read-only-other-frame)) - - -(defun default-dir-load-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Load file: " (default-directory) nil t)))) - (default-dir-real-load-file file)) - -(efs-overwrite-fn "default-dir" 'load-file 'default-dir-load-file) - -(condition-case nil - (require 'view-less) - (error (require 'view))) - -(defun default-dir-view-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "View file: " (default-directory) nil t)))) - (default-dir-real-view-file file)) - -(efs-overwrite-fn "default-dir" 'view-file 'default-dir-view-file) - -(if (fboundp 'view-file-other-window) - (progn - (defun default-dir-view-file-other-window (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "View file in other window: " - (default-directory) nil t)))) - (default-dir-real-view-file-other-window file)) - (efs-overwrite-fn "default-dir" 'view-file-other-window - 'default-dir-view-file-other-window))) - -(if (fboundp 'view-file-other-frame) - (progn - (defun default-dir-view-file-other-frame (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "View file in other frame: " - (default-directory) nil t)))) - (default-dir-real-view-file-other-frame file)) - (efs-overwrite-fn "default-dir" 'view-file-other-frame - 'default-dir-view-file-other-frame))) - - -(defun default-dir-shell-command (command &optional output-buffer) - "Documented as original" - (interactive - (list - (let ((prompt (format "Shell command in %s: " (default-directory)))) - (cond - ((eq default-dir-emacs-variant 'xemacs) - (read-shell-command "Shell command: ")) - ((eq default-dir-emacs-variant 'fsf-19) - (read-from-minibuffer prompt nil nil nil 'shell-command-history)) - ((featurep 'gmhist) - (let ((minibuffer-history-symbol 'shell-command-history)) - (read-string prompt))) - (t (read-string prompt)))) - current-prefix-arg)) - (let ((default-directory (expand-file-name (default-directory)))) - (default-dir-real-shell-command command output-buffer))) - -(efs-overwrite-fn "default-dir" 'shell-command 'default-dir-shell-command) - -(defun default-dir-cd (dir) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Change default directory: " (default-directory))))) - (default-dir-real-cd dir)) - -(efs-overwrite-fn "default-dir" 'cd 'default-dir-cd) - -(defun default-dir-set-visited-file-name (filename) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Set visited file name: " (default-directory))))) - (default-dir-real-set-visited-file-name filename)) - -(efs-overwrite-fn "default-dir" 'set-visited-file-name - 'default-dir-set-visited-file-name) - -(defun default-dir-insert-file (filename &rest args) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Insert file: " (default-directory) nil t)))) - (apply 'default-dir-real-insert-file filename args)) - -(efs-overwrite-fn "default-dir" 'insert-file 'default-dir-insert-file) - -(defun default-dir-append-to-file (start end filename &rest args) - "Documented as original" - (interactive - (progn - (or (mark) (error "The mark is not set now")) - (list - (min (mark) (point)) - (max (mark) (point)) - (expand-file-name - (read-file-name "Append to file: " (default-directory)))))) - (apply 'default-dir-real-append-to-file start end filename args)) - -(efs-overwrite-fn "default-dir" 'append-to-file 'default-dir-append-to-file) - -(defun default-dir-delete-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Delete file: " (default-directory) nil t)))) - (default-dir-real-delete-file file)) - -(efs-overwrite-fn "default-dir" 'delete-file 'default-dir-delete-file) - -;;; end of default-dir.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-cmpr.el --- a/lisp/efs/dired-cmpr.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,315 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-cmpr.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for compressing marked files. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-cmpr) -(require 'dired) - -;;; Entry points. - -(defun dired-do-compress (&optional arg files) - "Compress or uncompress marked (or next ARG) files. -With a zero prefix, prompts for a new value of `dired-compression-method'." - (interactive - (let ((arg (prefix-numeric-value current-prefix-arg)) - files) - (if (zerop arg) - (let ((new (completing-read - (format "Set compression method (currently %s): " - dired-compression-method) - (mapcar - (function - (lambda (x) - (cons (symbol-name (car x)) nil))) - dired-compression-method-alist) - nil t))) - (or (string-equal new "") - (setq dired-compression-method (intern new)))) - (setq files (dired-get-marked-files nil current-prefix-arg)) - (or (memq 'compress dired-no-confirm) - (let* ((dir (dired-current-directory)) - (rfiles (mapcar (function - (lambda (fn) - (dired-make-relative fn dir t))) - files)) - (prompt "") - (comp 0) - (uncomp nil) - (total (length files)) - elt) - (mapcar (function - (lambda (fn) - (if (listp (setq elt - (dired-make-compressed-filename fn))) - (let* ((method (car (nth 3 elt))) - (count (assoc method uncomp))) - (if count - (setcdr count (1+ (cdr count))) - (setq uncomp (cons (cons method 1) uncomp)))) - (setq comp (1+ comp))))) - files) - (if (/= comp 0) - (setq prompt - (format "%s %d" - (car - (nth 2 - (assq dired-compression-method - dired-compression-method-alist))) - comp))) - (if uncomp - (let ((case-fold-search t) - method) - (or (string-equal prompt "") - (setq prompt (concat prompt "; "))) - (setq uncomp - (sort - (mapcar - (function - (lambda (elt) - (setq method (car elt)) - (if (string-equal method "gzip") - (setq method "gunzip") - (or (string-match "^un" method) - (setq method (concat "un" method)))) - (setcar elt method) - elt)) - uncomp) - (function - (lambda (x y) - (string< (car x) (car y)))))) - (setq prompt - (concat prompt - (mapconcat - (function - (lambda (elt) - (format "%s %d" (car elt) (cdr elt)))) - uncomp ", "))))) - (cond - ((= (length rfiles) 1) - (setq prompt (format "%s %s? " - ;; Don't need the number 1 - (substring prompt 0 -2) - (car rfiles)))) - ((or (> (length uncomp) 1) (and (/= 0 comp) uncomp)) - (setq prompt (format "%s? Total: %d file%s " prompt total - (dired-plural-s total)))) - ((setq prompt (format "%s file%s? " prompt - (dired-plural-s total))))) - (or (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) - (setq arg 0))))) - (list arg files))) - - (if (not (zerop arg)) - (dired-create-files - 'dired-compress-file - "Compress or Uncompress" - files - (function - (lambda (fn) - (let ((cfn (dired-make-compressed-filename fn))) - (if (stringp cfn) - cfn - (substring fn 0 (- (length (nth 1 cfn)))))))) - dired-keep-marker-compress nil t))) - -(defun dired-compress-subdir-files (&optional uncompress) - "Compress all uncompressed files in the current subdirectory. -With a prefix argument uncompresses all compressed files." - (interactive "P") - (let ((dir (dired-current-directory)) - files methods uncomp elt) - (save-excursion - (save-restriction - (narrow-to-region (dired-subdir-min) (dired-subdir-max)) - (dired-map-dired-file-lines - (function - (lambda (f) - (if uncompress - (and (listp (setq uncomp (dired-make-compressed-filename f))) - (let ((program (car (nth 3 uncomp)))) - (setq files (cons f files)) - (if (setq elt (assoc program methods)) - (setcdr elt (1+ (cdr elt))) - (setq methods (cons (cons program 1) methods))))) - (and (stringp (dired-make-compressed-filename f)) - (setq files (cons f files))))))))) - (if files - (let ((total (length files)) - (rfiles (mapcar - (function - (lambda (fn) - (dired-make-relative fn dir t))) - files)) - prompt) - (if uncompress - (progn - (setq prompt (mapconcat - (function - (lambda (x) - (format "%s %d" - (if (string-equal (car x) "gzip") - "gunzip" - (if (string-match "^un" (car x)) - (car x) - (concat "un" (car x)))) - (cdr x)))) - methods ", ")) - (cond - ((= total 1) - (setq prompt - (concat (substring prompt 0 -1) (car rfiles) "? "))) - ((= (length methods) 1) - (setq prompt - (format "%s file%s? " prompt (dired-plural-s total)))) - (t - (setq prompt (format "%s? Total: %d file%s " prompt total - (dired-plural-s total)))))) - (setq prompt - (if (= total 1) - (format "%s %s? " dired-compression-method (car rfiles)) - (format "%s %d file%s? " - dired-compression-method total - (dired-plural-s total))))) - (if (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) - (dired-create-files - 'dired-compress-file - "Compress or Uncompress" - files - (function - (lambda (fn) - (let ((cfn (dired-make-compressed-filename fn))) - (if (stringp cfn) - cfn - (substring fn 0 (- (length (nth 1 cfn)))))))) - dired-keep-marker-compress nil t))) - (message "No files need %scompressing in %s." - (if uncompress "un" "") - (dired-abbreviate-file-name dir))))) - -(defun dired-compress-file (file ok-flag) - ;; Compress or uncompress FILE. - ;; If ok-flag is non-nil, it is OK to overwrite an existing - ;; file. How well this actually works may depend on the compression - ;; program. - ;; Return the name of the compressed or uncompressed file. - (let ((handler (find-file-name-handler file 'dired-compress-file))) - (if handler - (funcall handler 'dired-compress-file file ok-flag) - (let ((compressed-fn (dired-make-compressed-filename file)) - (err-buff (get-buffer-create " *dired-check-process output*"))) - (save-excursion - (set-buffer err-buff) - (erase-buffer) - (cond ((file-symlink-p file) - (signal 'file-error (list "Error compressing file" - file "a symbolic link"))) - ((listp compressed-fn) - (message "Uncompressing %s..." file) - (let* ((data (nth 3 compressed-fn)) - (ret - (apply 'call-process - (car data) file t nil - (append (cdr data) - (and ok-flag - (list (nth 4 compressed-fn))) - (list file))))) - (if (or (and (integerp ret) (/= ret 0)) - (not (bobp))) - (signal 'file-error - (nconc - (list "Error uncompressing file" - file) - (and (not (bobp)) - (list - (progn - (goto-char (point-min)) - (buffer-substring - (point) (progn (end-of-line) - (point)))))))))) - (message "Uncompressing %s...done" file) - (dired-remove-file file) - (let ((to (substring file 0 - (- (length (nth 1 compressed-fn)))))) - ;; rename any buffers - (and (get-file-buffer file) - (save-excursion - (set-buffer (get-file-buffer file)) - (let ((modflag (buffer-modified-p))) - ;; kills write-file-hooks - (set-visited-file-name to) - (set-buffer-modified-p modflag)))) - to)) - ((stringp compressed-fn) - (message "Compressing %s..." file) - (let* ((data (assq dired-compression-method - dired-compression-method-alist)) - (compr-args (nth 2 data)) - (ret - (apply 'call-process - (car compr-args) file t nil - (append (cdr compr-args) - (and ok-flag - (list (nth 4 data))) - (list file))))) - (if (or (and (integerp ret) (/= ret 0)) - (not (bobp))) - (signal 'file-error - (nconc - (list "Error compressing file" - file) - (and (not (bobp)) - (list - (progn - (goto-char (point-min)) - (buffer-substring - (point) (progn (end-of-line) - (point)))))))))) - (message "Compressing %s...done" file) - (dired-remove-file file) - ;; rename any buffers - (and (get-file-buffer file) - (save-excursion - (set-buffer (get-file-buffer file)) - (let ((modflag (buffer-modified-p))) - ;; kills write-file-hooks - (set-visited-file-name compressed-fn) - (set-buffer-modified-p modflag)))) - compressed-fn) - (t (error "Strange error in dired-compress-file.")))))))) - -(defun dired-make-compressed-filename (name &optional method) - ;; If NAME is in the syntax of a compressed file (according to - ;; dired-compression-method-alist), return the data (a list) from this - ;; alist on how to uncompress it. Otherwise, return a string, the - ;; compressed form of this file name. This is computed using the optional - ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of - ;; dired-compression-method is used. - (let ((handler (find-file-name-handler - name 'dired-make-compressed-filename))) - (if handler - (funcall handler 'dired-make-compressed-filename name method) - (let ((alist dired-compression-method-alist) - (len (length name)) - ext ext-len result) - (while alist - (if (and (> len - (setq ext-len (length (setq ext (nth 1 (car alist)))))) - (string-equal ext (substring name (- ext-len)))) - (setq result (car alist) - alist nil) - (setq alist (cdr alist)))) - (or result - (concat name - (nth 1 (or (assq (or method dired-compression-method) - dired-compression-method-alist) - (error "Unknown compression method: %s" - (or method dired-compression-method)))))) - )))) - -;;; end of dired-cmpr.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-diff.el --- a/lisp/efs/dired-diff.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,164 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-diff.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: Support for diff and related commands. -;; Author: Sandy Rutherford -;; Created: Fri Jun 24 08:50:20 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or -;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -;;; MA 02139, USA. - -(provide 'dired-diff) -(require 'dired) - -(defvar emerge-last-dir-input) -(defvar emerge-last-dir-output) -(defvar emerge-last-dir-ancestor) -(defvar diff-switches) - -(defun dired-diff-read-file-name (prompt) - ;; Read and return a file name for diff. - (let* ((mark-active t) - (default (and (mark) - (save-excursion - (goto-char (mark)) - (dired-get-filename nil t))))) - (read-file-name (format "%s %s with: %s" - prompt (dired-get-filename 'no-dir) - (if default - (concat "[" - (dired-make-relative - default - (dired-current-directory) t) - "] ") - "")) - (default-directory) default t))) - -(defun dired-diff-read-switches (switchprompt) - ;; Read and return a list of switches - (or (boundp 'diff-switches) - (require 'diff)) ; Make sure that `diff-switches' is defined. - (let* ((default (if (listp diff-switches) - (mapconcat 'identity diff-switches " ") - diff-switches)) - (switches - (read-string (format switchprompt default) default))) - (let (result (start 0)) - (while (string-match "\\(\\S-+\\)" switches start) - (setq result (cons (substring switches (match-beginning 1) - (match-end 1)) - result) - start (match-end 0))) - (nreverse result)))) - -(defun dired-diff (file &optional switches) - "Compare file at point with file FILE using `diff'. -FILE defaults to the file at the mark. -The prompted-for file is the first file given to `diff'. -With a prefix allows the switches for the diff program to be edited." - (interactive - (list - (dired-diff-read-file-name "Diff") - (and current-prefix-arg (dired-diff-read-switches "Options for diff: ")))) - (if switches - (diff file (dired-get-filename) switches) - (diff file (dired-get-filename)))) - -(defun dired-backup-diff (&optional switches) - "Diff this file with its backup file or vice versa. -Uses the latest backup, if there are several numerical backups. -If this file is a backup, diff it with its original. -The backup file is the first file given to `diff'." - (interactive (list (and current-prefix-arg - (dired-diff-read-switches "Diff with switches: ")))) - (if switches - (diff-backup (dired-get-filename) switches) - (diff-backup (dired-get-filename)))) - -(defun dired-emerge (arg file out-file) - "Merge file at point with FILE using `emerge'. -FILE defaults to the file at the mark." - (interactive - (let ((file (dired-diff-read-file-name "Merge"))) - (list - current-prefix-arg - file - (and current-prefix-arg (emerge-read-file-name - "Output file" - emerge-last-dir-output - (dired-abbreviate-file-name file) file))))) - (emerge-files arg file (dired-get-filename) out-file)) - -(defun dired-emerge-with-ancestor (arg file ancestor file-out) - "Merge file at point with FILE, using a common ANCESTOR file. -FILE defaults to the file at the mark." - (interactive - (let ((file (dired-diff-read-file-name "Merge"))) - (list - current-prefix-arg - file - (emerge-read-file-name "Ancestor file" emerge-last-dir-ancestor nil file) - (and current-prefix-arg (emerge-read-file-name - "Output file" - emerge-last-dir-output - (dired-abbreviate-file-name file) file))))) - (emerge-files-with-ancestor arg file (dired-get-filename) - ancestor file-out)) - -(defun dired-ediff (file) - "Ediff file at point with FILE. -FILE defaults to the file at the mark." - (interactive (list (dired-diff-read-file-name "Ediff"))) - (ediff-files file (dired-get-filename))) - -(defun dired-epatch (file) - "Patch file at point using `epatch'." - (interactive - (let ((file (dired-get-filename))) - (list - (and (or (memq 'patch dired-no-confirm) - (y-or-n-p (format "Patch %s? " - (file-name-nondirectory file)))) - file)))) - (if file - (ediff-patch-file file) - (message "No file patched."))) - -;;; Autoloads - -;;; Diff (diff) - -(autoload 'diff "diff" "Diff two files." t) -(autoload 'diff-backup "diff" - "Diff this file with its backup or vice versa." t) - -;;; Emerge - -(autoload 'emerge-files "emerge" "Merge two files." t) -(autoload 'emerge-files-with-ancestor "emerge" - "Merge two files having a common ancestor." t) -(autoload 'emerge-read-file-name "emerge") - -;; Ediff - -(autoload 'ediff-files "ediff" "Ediff two files." t) -(autoload 'ediff-patch-file "ediff" "Patch a file." t) - -;;; end of dired-diff.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-faces.el --- a/lisp/efs/dired-faces.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-faces.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: rudimentary face customization support for dired -;; Author: Mike Sperber -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'dired-faces) - -(require 'custom) - -;;; Variables - -(defgroup dired nil - "Directory editing." - :group 'environment) - -(defcustom dired-do-highlighting t - "Set if we should use highlighting according to filetype." - :type 'boolean - :group 'dired) - -(defcustom dired-do-interactive-permissions t - "Set if we should allow interactive chmod." - :type 'boolean - :group 'dired) - -(defface dired-face-marked '((((class color)) - (:background "PaleVioletRed")) - (t (:underline t))) - "Face used for marked files." - :group 'dired) - -(defface dired-face-flagged '((((class color)) - (:background "LightSlateGray")) - (t (:underline t))) - "Face used for flagged files." - :group 'dired) - -(defface dired-face-directory '((t (:bold t))) - "Face used for directories." - :group 'dired) - -(defface dired-face-executable '((((class color)) - (:foreground "SeaGreen")) - (t (:bold t))) - "Face used for executables." - :group 'dired) - -(defface dired-face-setuid '((((class color)) - (:foreground "Red")) - (t (:bold t))) - "Face used for setuid executables." - :group 'dired) - -(defface dired-face-boring '((((class color)) - (:foreground "Gray65")) - (((class grayscale)) - (:foreground "Gray65"))) - "Face used for unimportant files." - :group 'dired) - -(defface dired-face-permissions '((t (:background "grey75" - :foreground "black"))) - "Face used for interactive permissions." - :group 'dired) - -(defface dired-face-socket '((((class color)) - (:foreground "magenta")) - (t (:bold nil))) - "Face used to indicate sockets." - :group 'dired) - -(defface dired-face-symlink '((((class color)) - (:foreground "cyan")) - (t (:bold t))) - "Face used to indicate symbolic links." - :group 'dired) - -;;; end of dired-faces.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-grep.el --- a/lisp/efs/dired-grep.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,482 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-grep.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: Support for running grep on marked files in a dired buffer. -;; Author: Sandy Rutherford -;; Created: Tue Jul 13 22:59:37 1993 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Copyright (C) 1993 Sandy Rutherford - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or -;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -;;; MA 02139, USA. - -;;; The user-level command in this file is dired-grep-file. The command -;;; grep is defined in compile.el. This file does not change that command. - -;;; Requirements and provisions - -(provide 'dired-grep) -(or (fboundp 'file-local-copy) (require 'emacs-19)) -(or (fboundp 'generate-new-buffer) (require 'emacs-19)) -(require 'dired) - -;;; Variables - -(defvar dired-grep-program "grep" - "Name of program to use to grep files. -When used with the \"-n\" flag, program must precede each match with \"###:\", -where \"###\" is the line number of the match. -If there are grep programs which don't do this, we'll try to think of -some way to accomodate them.") - -(defvar dired-grep-switches nil - "*Switches to pass to the grep program. -This may be either a string or a list of strings. It is not necessary to -include \"-n\" as that switch is always used.") - -(defvar dired-grep-zcat-program "zcat" - "Name of program to cat compressed files.") - -(defvar dired-grep-compressed-file ".\\.\\(gz\\|[zZ]\\)$" - "Regexp to match names of compressed files.") - -(defvar dired-grep-pop-up-buffer t - "*If non-nil, the grep output is displayed in the other window upon -completion of the grep process.") - -(defvar dired-grep-results-buffer "*Dired Grep*" - "Name of buffer where grep results are logged.") - -(defvar dired-grep-mode-hook nil - "Hook run after going into grep-mode") - -(defvar grep-history nil - "History of previous grep patterns used.") - -(defvar dired-grep-parse-flags-cache nil) -(defvar dired-grep-parse-flags-cache-result nil) - -(defvar dired-grep-mode-map nil - "Keymap for dired-grep-mode buffers.") - -(if dired-grep-mode-map - () - (setq dired-grep-mode-map (make-keymap)) - (suppress-keymap dired-grep-mode-map) - (define-key dired-grep-mode-map "[" 'backward-page) - (define-key dired-grep-mode-map "]" 'forward-page) - (define-key dired-grep-mode-map ">" 'dired-grep-next-hit) - (define-key dired-grep-mode-map "<" 'dired-grep-previous-hit) - (define-key dired-grep-mode-map "n" 'dired-grep-advertized-next-hit) - (define-key dired-grep-mode-map "p" 'dired-grep-advertized-previous-hit) - (define-key dired-grep-mode-map "k" 'dired-grep-delete-line) - (define-key dired-grep-mode-map "d" 'dired-grep-delete-page) - (define-key dired-grep-mode-map "^" 'dired-grep-delete-preceding-pages) - (define-key dired-grep-mode-map "f" 'dired-grep-find-file) - (define-key dired-grep-mode-map "e" 'dired-grep-find-file) - (define-key dired-grep-mode-map "m" 'dired-grep-delete-misses) - (define-key dired-grep-mode-map "o" 'dired-grep-find-file-other-window) - (define-key dired-grep-mode-map "v" 'dired-grep-view-file) - (define-key dired-grep-mode-map "w" 'dired-grep-delete-grep-for) - (define-key dired-grep-mode-map "\C-_" 'dired-grep-undo) - (define-key dired-grep-mode-map "\C-xu" 'dired-grep-undo)) - -;;; Entry functions from dired.el - -(defun dired-grep (pattern flags) - ;; grep the file on the current line for PATTERN, using grep flags FLAGS. - ;; Return nil on success. Offending filename otherwise. - (let* ((file (dired-get-filename)) - (result (dired-grep-file pattern file flags))) - (and result - (progn - (dired-log (buffer-name (current-buffer)) (concat result "\n")) - file)))) - -(defun dired-do-grep (pattern &optional flags arg) - "Grep marked files for a pattern. With a \C-u prefix prompts for grep flags." - (interactive - (let* ((switches (if (consp current-prefix-arg) - (read-string "Switches for grep: ") - dired-grep-switches)) - (prompt (format "grep %sfor pattern" - (if (stringp switches) - (if (string-equal switches "") - switches - (concat switches " ")) - (if switches - (concat (mapconcat 'identity switches " ") " ") - "")))) - (pattern (dired-read-with-history (concat prompt ": ") - nil 'grep-history))) - (list pattern switches - (and (not (consp current-prefix-arg)) current-prefix-arg)))) - (dired-map-over-marks-check - (function - (lambda () - (dired-grep pattern flags))) - arg 'grep (concat "grep " flags (if flags " \"" "\"") pattern "\"") t)) - -;;; Utility functions - -(defun dired-grep-get-results-buffer () - ;; Return the buffer object of the dired-grep-results-buffer, creating and - ;; initializing it if necessary. - (let ((buffer (get-buffer dired-grep-results-buffer))) - (or buffer - (save-excursion - (set-buffer (setq buffer (get-buffer-create dired-grep-results-buffer))) - (dired-grep-mode) - buffer)))) - -;; Only define if undefined, in case efs has got to it already. -(or (fboundp 'dired-grep-delete-local-temp-file) - (defun dired-grep-delete-local-temp-file (file) - (condition-case nil (delete-file file) (error nil)))) - -;;; Commands in the dired-grep-results-buffer buffer. - -(defun dired-grep-mode () - "\\Mode for perusing grep output generated from dired. -The output is divided into pages, one page per grepped file. - -Summary of commands: - -Move to next grep hit \\[dired-grep-advertized-next-hit], \\[dired-grep-next-hit] -Move to previous grep hit \\[dired-grep-advertized-previous-hit], \\[dired-grep-previous-hit] -Move to output for next file \\[forward-page] -Move to output for previous file \\[backward-page] - -Delete the current grep line \\[dired-grep-delete-line] -Delete all output for current file \\[dired-grep-delete-page] -Delete all preceding pages \\[dired-grep-delete-preceding-pages] -Delete all pages for files with no hits \\[dired-grep-delete-misses] -Delete all pages which grep for the - same pattern as the current page \\[dired-grep-delete-grep-for] - -Find current grep hit in file \\[dired-grep-find-file] -Find current grep hit in other window \\[dired-grep-find-file-other-window] -View current grep hit \\[dired-grep-view-file] - -Undo changes to the grep buffer \\[dired-grep-undo] - -Keybindings: -\\{dired-grep-mode-map}" - (kill-all-local-variables) - (use-local-map dired-grep-mode-map) - (setq major-mode 'dired-grep-mode - mode-name "Dired-Grep" - buffer-read-only t) - (set (make-local-variable 'page-delimiter) "\n\n") - (run-hooks 'dired-grep-mode-hook)) - -(defun dired-grep-current-file-and-line () - ;; Returns a list \(FILENAME . LINE\) corresponding to the filename - ;; and line number associated with the position of the point in a - ;; grep buffer. Returns nil if there is none. - (save-excursion - (let (file line) - (and - (progn - (beginning-of-line) - (looking-at "[0-9]+:")) - (progn - (setq line (string-to-int (buffer-substring (point) - (1- (match-end 0))))) - (if (search-backward "\n\n" nil 'move) (forward-char 2)) - (looking-at "Hits for ")) - (progn - (forward-line 1) - (looking-at " ")) - (progn - (setq file (buffer-substring (match-end 0) - (progn (end-of-line) (1- (point))))) - (cons file line)))))) - -(defun dired-grep-find-file () - (interactive) - (let ((file (dired-grep-current-file-and-line))) - (if file - (progn - (find-file (car file)) - (goto-line (cdr file)) - (recenter '(4))) - (error "No file specified by this line.")))) - -(defun dired-grep-find-file-other-window () - (interactive) - (let ((file (dired-grep-current-file-and-line))) - (if file - (progn - (find-file-other-window (car file)) - (goto-line (cdr file)) - (recenter '(4))) - (error "No file specified by this line.")))) - -(defun dired-grep-view-file () - (interactive) - (let ((file (dired-grep-current-file-and-line))) - (if file - (let* ((fun (function - (lambda () (goto-line (cdr file)) (recenter '(4))))) - (view-hook - (if (boundp 'view-hook) - (if (and (listp view-hook) - (not (eq (car view-hook) 'lambda))) - (cons fun view-hook) - (list fun view-hook)) - fun))) - (view-file (car file))) - (error "No file specified by this line.")))) - -(defun dired-grep-next-hit (arg) - "Moves to the next, or next ARGth, grep hit." - (interactive "p") - (forward-line 1) - (if (re-search-forward "^[0-9]" nil 'move arg) - (goto-char (match-beginning 0)) - (error "No further grep hits"))) - -(defun dired-grep-previous-hit (arg) - "Moves to the previous, or previous ARGth, grep hit." - (interactive "p") - (beginning-of-line) - (or (re-search-backward "^[0-9]" nil 'move arg) - (error "No further grep hits"))) - -;; These are only so we can get a decent looking help buffer. -(fset 'dired-grep-advertized-next-hit 'dired-grep-next-hit) -(fset 'dired-grep-advertized-previous-hit 'dired-grep-previous-hit) - -(defun dired-grep-delete-page (arg) - "Deletes the current and ARG - 1 following grep output pages. -If ARG is negative, deletes preceding pages." - (interactive "p") - (let ((done 0) - (buffer-read-only nil) - (backward (< arg 0)) - start) - (if backward (setq arg (- arg))) - (while (and (< done arg) (not (if backward (bobp) (eobp)))) - (or (looking-at "^\n") - (if (search-backward "\n\n" nil 'move) (forward-char 1))) - (setq start (point)) - (if (search-forward "\n\n" nil 'move) (forward-char -1)) - (delete-region start (point)) - (and (bobp) (not (eobp)) (delete-char 1)) - (if backward (skip-chars-backward "\n")) - (setq done (1+ done))))) - -(defun dired-grep-delete-preceding-pages () - "Deletes the current, and all preceding pages from the grep buffer." - (interactive) - (let ((buffer-read-only nil)) - (if (looking-at "^\n") - (forward-char 1) - (search-forward "\n\n" nil 'move)) - (delete-region (point-min) (point)))) - -(defun dired-grep-delete-line (arg) - "Deletes the current line and ARG following lines from the grep buffer. -Only operates on lines which correspond to file lines for grep hits." - (interactive "p") - (let ((opoint (point)) - (buffer-read-only nil) - (backward (< arg 0)) - (done 0)) - (beginning-of-line) - (if backward (setq arg (- arg))) - (if (looking-at "[0-9]+:") - (while (< done arg) - (delete-region (point) (progn (forward-line 1) (point))) - (if backward (forward-line -1)) - (if (looking-at "[0-9]+:") - (setq done (1+ done)) - (setq done arg))) - ;; Do nothing. - (goto-char opoint)))) - -(defun dired-grep-delete-grep-for () - "Deletes all pages which grep some file for the pattern of the current page." - (interactive) - (save-excursion - ;; In case we happen to be right at the beginning of a page. - (or (eobp) (eolp) (forward-char 1)) - (forward-page -1) ; gets to the beginning of the page. - (let* ((eol (save-excursion (end-of-line) (point))) - (line (and (search-forward " grep " eol t) - (buffer-substring (point) eol)))) - (if line - (progn - (goto-char (point-min)) - (while (not (eobp)) - (let* ((eol (save-excursion (end-of-line) (point))) - (this-line (and (search-forward " grep " eol t) - (buffer-substring (point) eol)))) - (if (equal line this-line) - (progn - (dired-grep-delete-page 1) - (skip-chars-forward "\n")) - (or (eobp) (forward-page 1)))))))))) - -(defun dired-grep-delete-misses () - "Delete all pages for which there were no grep hits. -Deletes pages for which grep failed because of an error too." - (interactive) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "Grep failed \\|No hits ") - (progn - (dired-grep-delete-page 1) - (skip-chars-forward "\n")) - (forward-page 1))))) - -(defun dired-grep-undo () - "Undoes deletions in a grep buffer." - (interactive) - (let (buffer-read-only) - (undo))) - -;;; Commands for grepping files. - -(defun dired-grep-parse-flags (string) - ;; Breaks a string of switches into a list. - (if (equal dired-grep-parse-flags-cache string) - dired-grep-parse-flags-cache-result - (let ((length (length string)) - (pointer 0) - (start 0) - (result nil)) - (while (and (< pointer length) (= (aref string pointer) ?\ )) - (setq pointer (1+ pointer))) - (while (< pointer length) - (setq start pointer) - (while (and (< pointer length) (/= (aref string pointer) ?\ )) - (setq pointer (1+ pointer))) - (setq result (cons (substring string start pointer) result)) - (while (and (< pointer length) (= (aref string pointer) ?\ )) - (setq pointer (1+ pointer)))) - (setq dired-grep-parse-flags-cache string - dired-grep-parse-flags-cache-result (nreverse result))))) - -(defun dired-grep-file (pattern file &optional flags) - "Grep for PATTERN in FILE. -Optional FLAGS are flags to pass to the grep program. -When used interactively, will prompt for FLAGS if a prefix argument is used." - (interactive - (let* ((switches (if (consp current-prefix-arg) - (read-string "Switches for grep: ") - dired-grep-switches)) - (prompt (format "grep %sfor pattern" - (if (stringp switches) - (if (string-match switches "^ *$") - "" - (concat switches " ")) - (if switches - (concat (mapconcat 'identity switches " ") " ") - "")))) - (pattern (dired-read-with-history (concat prompt ": ") - nil 'grep-history)) - (file (read-file-name (concat prompt " \"" pattern "\" in file :")))) - (list pattern file switches))) - (setq file (expand-file-name file)) - (if (listp flags) - (setq flags (mapconcat 'identity flags " ")) - (if (string-match "^ +$" flags) - (setq flags ""))) - (let ((file-buff (get-file-buffer file))) - (if (and file-buff (buffer-modified-p file-buff)) - (if (y-or-n-p (format "Save buffer %s? " (buffer-name file-buff))) - (save-excursion - (set-buffer file-buff) - (save-buffer))))) - (let ((buffer (dired-grep-get-results-buffer)) - (compressed (string-match dired-grep-compressed-file file)) - failed temp-file jka-compr-compression-info-list) - (setq temp-file - (condition-case err - (file-local-copy file) - (error (progn (setq failed (format "%s" err)) nil)))) - (or failed - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (let ((buffer-read-only nil) - pos-1 pos-2) - (or (bobp) (insert "\n")) - (setq pos-1 (point)) - (insert "Hits for grep ") - (or (string-equal flags "") (insert flags " ")) - (insert "\"" pattern "\" in\n " file ":\n") - (setq pos-2 (point)) - (condition-case err - (apply - 'call-process - (if compressed "sh" dired-grep-program) - (or temp-file file) - buffer t - (if compressed - (list "-c" (concat dired-grep-zcat-program - " |" dired-grep-program - " " flags " -n '" pattern "'")) - (append (dired-grep-parse-flags flags) - (list "-n" pattern)))) - (error (setq failed (format "%s" err)))) - (if failed - (progn - (if (= pos-2 (point-max)) - (progn - (goto-char (1- pos-2)) - (delete-char -1) - (insert "."))) - (goto-char pos-1) - (delete-char 4) - (insert "Grep failed") - failed) - (if (= pos-2 (point-max)) - (progn - (goto-char pos-1) - (delete-char 1) - (insert "No h") - (forward-line 1) - (end-of-line) - (delete-char -1) - (insert ".")) - (goto-char pos-2) - (or (looking-at "[0-9]+:") - (setq failed (buffer-substring pos-2 - (progn (end-of-line) - (point)))))))))) - (let ((curr-wind (selected-window))) - (unwind-protect - (progn - (pop-to-buffer buffer) - (goto-char (point-max))) - (select-window curr-wind))) - (if temp-file - (dired-grep-delete-local-temp-file temp-file)) - failed)) - -;;; Run the load hook - -(run-hooks 'dired-grep-load-hook) - -;;; end of dired-grep.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-help.el --- a/lisp/efs/dired-help.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,398 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-help.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Obtaining help for dired -;; Modified: Sun Nov 20 21:10:47 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-help) -(require 'dired) -(autoload 'reporter-submit-bug-report "reporter") -(defvar reporter-version) ; For the byte-compiler. - -;;; Constants - -(defconst dired-bug-address "efs-bugs@cuckoo.hpl.hp.com") - -(defvar dired-documentation nil) - -;;; Functions - -(defun dired-documentation () - (or dired-documentation - (let ((18-p (string-equal "18." (substring emacs-version 0 3))) - (var-help-key (substitute-command-keys - (if (featurep 'ehelp) - "\\[electric-describe-variable]" - "\\[describe-variable]"))) - (standard-output (get-buffer-create " dired-help-temp"))) - (save-excursion - (set-buffer standard-output) - (unwind-protect - (setq dired-documentation - (substitute-command-keys - (format "\\The Directory Editor: - -For more detailed help, type \\[universal-argument] \\[dired-describe-mode] to start the info -documentation browser. - -In dired, you can edit a list of the files in a directory \(and optionally -its subdirectories in the `ls -lR' format\). - -Editing a directory means that you can visit, rename, copy, compress, -load, byte-compile files. You can change files' attributes, run shell -commands on files, or insert subdirectories into the edit buffer. You can -\"flag\" files for deletion or \"mark\" files for later commands, either one -file at a time or by all files matching certain criteria \(e.g., files that -match a certain regexp\). - -You move throughout the buffer using the usual cursor motion commands. -Letters no longer insert themselves, but execute commands instead. The -digits (0-9) are prefix arguments. - -Most commands operate either on all marked files or on the current file if -no files are marked. Use a numeric prefix argument to operate on the next -ARG files (or previous ARG if ARG < 0). Use the prefix argument `1' to -operate on the current file only. Prefix arguments override marks. Commands -which run a sub-process on a group of files will display a list of files -for which the sub-process failed. Typing \\[dired-why] will try to tell -you what went wrong. - -When editing several directories in one buffer, each directory acts as a -page, so \\[backward-page] and \\[forward-page] can be used to move between directories. - -Summary of commands: - -Motion Commands - move up to previous line \\[dired-next-line] - move down to next line \\[dired-previous-line] - move up to previous directory line \\[dired-prev-dirline] - move down to next directory line \\[dired-next-dirline] - move up to previous subdirectory \\[dired-advertised-prev-subdir] - move down to next subdirectory \\[dired-advertised-next-subdir] - move to parent directory \\[dired-up-directory] - move to first child subdirectory \\[dired-down-directory] - -Immediate Actions on Files - visit current file \\[dired-advertised-find-file] - visit current file in other window \\[dired-find-file-other-window] - visit current file in other frame %s - display current file \\[universal-argument] \\[dired-find-file-other-window] - create a new subdirectory \\[dired-create-directory] - recover file from auto-save \\[dired-recover-file] - -Marking & Unmarking Files - mark a file or subdirectory for later commands \\[dired-mark] - unmark a file or all files of a subdirectory \\[dired-unmark] - unmark all marked files in a buffer \\[dired-unmark-all-files] - count marks in buffer 0 \\[dired-unmark-all-files] - mark all directories \\[dired-mark-directories] - mark all executable files \\[dired-mark-executables] - mark file names matching a regular expression \\[dired-mark-files-regexp] - -Commands on Files Marked or Specified by the Prefix - rename a file or move files to another directory \\[dired-do-rename] - copy files \\[dired-do-copy] - delete marked (as opposed to flagged) files \\[dired-do-delete] - compress or uncompress files \\[dired-do-compress] - uuencode or uudecode files \\[dired-do-uucode] - grep files \\[dired-do-grep] - search for regular expression \\[dired-do-tags-search] - query replace by regular expression \\[dired-do-tags-query-replace] - byte-compile files \\[dired-do-byte-compile] - load files \\[dired-do-load] - shell command on files \\[dired-do-shell-command] - operate shell command separately on each file \\[universal-argument] \\[dired-do-shell-command] - do as above, but in each file's directory \\[universal-argument] \\[universal-argument] \\[dired-do-shell-command] - -Flagging Files for Deletion (unmark commands remove delete flags) - flag file for deletion \\[dired-flag-file-deletion] - backup and remove deletion flag \\[dired-backup-unflag] - flag all backup files (file names ending in ~) \\[dired-flag-backup-files] - flag all auto-save files \\[dired-flag-auto-save-files] - clean directory of numeric backups \\[dired-clean-directory] - execute the deletions requested (flagged files) \\[dired-expunge-deletions] - -Modifying the Dired Buffer - insert a subdirectory in this buffer \\[dired-maybe-insert-subdir] - removing a subdir listing \\[dired-kill-subdir] - relist single file, marked files, or subdir \\[dired-do-redisplay] - re-read all directories (retains all marks) \\[revert-buffer] - toggle sorting of current subdir by name/date \\[dired-sort-toggle-or-edit] - report on current ls switches 0 \\[dired-sort-toggle-or-edit] - edit ls switches for current subdir 1 \\[dired-sort-toggle-or-edit] - edit default ls switches for new subdirs 2 \\[dired-sort-toggle-or-edit] - sort all subdirs by name/date \\[universal-argument] \\[dired-sort-toggle-or-edit] - edit the ls switches for all subdirs \\[universal-argument] \\[universal-argument] \\[dired-sort-toggle-or-edit] - -Hiding File Lines - toggle file omission in current subdir \\[dired-omit-toggle] - kill marked file lines \\[dired-do-kill-file-lines] - -Help on Dired - dired help (what you're reading) \\[dired-describe-mode] - dired summary (short help) \\[dired-summary] - dired info (full dired info manual) \\[universal-argument] \\[dired-describe-mode] - apropos for dired commands \\[dired-apropos] - apropos for dired variables \\[universal-argument] \\[dired-apropos] - -Regular Expression Commands - mark files with a regular expression \\[dired-mark-files-regexp] - copy marked files by regexp \\[dired-do-copy-regexp] - rename marked files by regexp \\[dired-do-rename-regexp] - omit files by regexp \\[dired-omit-expunge] - downcase file names (rename to lowercase) \\[dired-downcase] - upcase files names (rename to uppercase) \\[dired-upcase] - -Comparing Files - diff file at point with file at mark \\[dired-diff] - diff file with its backup \\[dired-backup-diff] - merge file at point with file at mark \\[dired-emerge] - same as above but use a common ancestor \\[dired-emerge-with-ancestor] - ediff file at point with file at mark \\[dired-ediff] - patch file at point \\[dired-epatch] - -Mouse Commands -%s - -Miscellaneous - quit dired \\[dired-quit] - insert current directory in minibuffer \\[dired-get-target-directory] - -If the dired buffer gets confused, you can either type \\[revert-buffer] to read all -directories again, type \\[dired-do-redisplay] to relist a single file, the marked -files, or a subdirectory, or type \\[dired-build-subdir-alist] to parse -the directory tree in the buffer again. - -Customization Variables: -Use %s to obtain more information. - -%s - -Hook Variables: -Use %s to obtain more information. - -%s - -Keybindings: -\\{dired-mode-map}" - - ;; arguments to format - (if 18-p - "Unavailable in Emacs 18" - " \\[dired-find-file-other-frame]") - (if 18-p - " Unavailable in Emacs 18" - "\ - find file with mouse \\[dired-mouse-find-file] - mark file at mouse \\[dired-mouse-mark] - flag for deletion file at mouse \\[dired-mouse-flag] - menu of commands to visit a file \\[dired-visit-popup-menu] - menu of operations to do on a file \\[dired-do-popup-menu] - insert directory of mouse in minibuffer \\[dired-mouse-get-target] -") - var-help-key - (progn - (erase-buffer) - (dired-format-columns-of-files - (sort - (all-completions - "dired-" obarray - (function - (lambda (sym) - (and (user-variable-p sym) - (not (dired-hook-variable-p - sym)))))) - 'string<) t) - (buffer-string)) - var-help-key - (progn - (erase-buffer) - (dired-format-columns-of-files - (sort - (all-completions - "dired-" obarray - (function - (lambda (sym) - (dired-hook-variable-p sym)))) - 'string<) t) - (buffer-string))))) - (kill-buffer " dired-help-temp")))))) - -;;; Commands - -(defun dired-describe-mode (&optional info) - "Detailed description of dired mode. -With a prefix, runs the info documentation browser for dired." - (interactive "P") - ;; Getting dired documentation can be a bit slow. - (if info - (info "dired") - (message "Building dired help...") - (let* ((buff (get-buffer-create "*Help*")) - (standard-output buff) - (mess (dired-documentation))) - (message "Building dired help... done") - (if (featurep 'ehelp) - (with-electric-help - (function - (lambda () - (princ mess) - nil))) ; return nil so ehelp puts us at the top of the buffer. - (with-output-to-temp-buffer (buffer-name buff) - (princ mess) - (print-help-return-message)))))) - -(defun dired-apropos (string &optional var-p) - "Does command apropos for dired commands. -With prefix does apropos for dired variables." - (interactive - (list - (if current-prefix-arg - (read-string "Dired variable apropos (regexp): ") - (read-string "Dired command apropos (regexp): ")) - current-prefix-arg)) - (message "Doing dired %s apropos..." (if var-p "variable" "command")) - (if (featurep 'ehelp) - (with-electric-help - (function - (lambda () - (dired-apropos-internal string var-p) - nil))) - (with-output-to-temp-buffer "*Help*" - (dired-apropos-internal string var-p) - (or (print-help-return-message) - (message "Doing dired %s apropos...done" - (if var-p "variable" "command")))))) - -(defun dired-apropos-internal (string &optional var-p) - (let ((case-fold-search t) - (names (sort (all-completions "dired-" obarray - (if var-p - 'user-variable-p - 'commandp)) - 'string<)) - doc) - (mapcar - (function - (lambda (x) - (and (if var-p (user-variable-p (intern x)) (commandp (intern x))) - (progn - (setq doc (if var-p - (get (intern x) 'variable-documentation) - (documentation (intern x)))) - (and doc (setq doc (substring doc 0 (string-match "\n" doc)))) - (or (string-match string x) - (and doc (string-match string doc)))) - (progn - (princ x) - (if var-p (princ " :") - (princ " :") - (princ (make-string (max 2 (- 30 (length x))) ?\ )) - (princ (dired-help-key-description (intern x)))) - (princ "\n ") - (princ doc) - (princ "\n"))))) - names))) - -(defun dired-help-key-description (fun) - ;; Returns a help string of keys for fun. - (let ((res (mapconcat 'key-description - (where-is-internal fun dired-mode-map) ", "))) - (if (string-equal res "") - "\(not on any keys\)" - res))) - -(defun dired-summary () - "Display summary of basic dired commands in the minibuffer." - (interactive) - (let ((del (where-is-internal 'dired-flag-file-deletion dired-mode-map)) - (und (where-is-internal 'dired-unmark dired-mode-map)) - (exp (where-is-internal 'dired-expunge-deletions dired-mode-map)) - (fin (where-is-internal 'dired-advertised-find-file dired-mode-map)) - (oth (where-is-internal 'dired-find-file-other-window dired-mode-map)) - (ren (where-is-internal 'dired-do-rename dired-mode-map)) - (cop (where-is-internal 'dired-do-copy dired-mode-map)) - (hel (where-is-internal 'dired-describe-mode dired-mode-map))) - (if (member "d" del) - (setq del "d-elete") - (setq del (substitute-command-keys - "\\\\[dired-flag-file-deletion] delete"))) - (if (member "u" und) - (setq und "u-ndelete") - (setq und (substitute-command-keys - "\\\\[dired-unmark] undelete"))) - (if (member "x" exp) - (setq exp "x-punge") - (setq exp (substitute-command-keys - "\\\\[dired-expunge-deletions] expunge"))) - (if (member "f" fin) - (setq fin "f-ind") - (setq fin (substitute-command-keys - "\\\\[dired-advertised-find-file] find"))) - (if (member "o" oth) - (setq oth "o-ther window") - (setq oth - (substitute-command-keys - "\\\\[dired-find-file-other-window] other window") - )) - (if (member "R" ren) - (setq ren "R-ename") - (setq ren (substitute-command-keys - "\\\\[dired-do-rename] rename"))) - (if (member "C" cop) - (setq cop "C-opy") - (setq cop (substitute-command-keys - "\\\\[dired-do-copy] copy"))) - (if (member "h" hel) - (setq hel "h-elp") - (setq hel (substitute-command-keys - "\\\\[describe-mode] help"))) - (message "%s, %s, %s, %s. %s, %s, %s, %s" - del und exp fin oth ren cop hel))) - -(defun dired-hook-variable-p (sym) - ;; Returns t if SYM is a hook variable. Just looks at its name. - (let ((name (symbol-name sym))) - (and (>= (length name) 6) - (or (string-equal (substring name -5) "-hook") - (string-equal (substring name -6) "-hooks"))))) - -;;; Submitting bug reports. - -(defun dired-report-bug () - "Submit a bug report for dired." - (interactive) - (let ((reporter-prompt-for-summary-p t)) - (or (boundp 'reporter-version) - (setq reporter-version - "Your version of reporter is obsolete. Please upgrade.")) - (reporter-submit-bug-report - dired-bug-address "Dired" - (cons - 'dired-version - (nconc - (mapcar - 'intern - (sort - (let (completion-ignore-case) - (all-completions "dired-" obarray 'user-variable-p)) - 'string-lessp)) - (list 'reporter-version))) - (function - (lambda () - (save-excursion - (mail-position-on-field "subject") - (beginning-of-line) - (skip-chars-forward "^:\n") - (if (looking-at ": Dired;") - (progn - (goto-char (match-end 0)) - (delete-char -1) - (insert " " dired-version " bug:"))))))))) - -;;; end of dired-help.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-mob.el --- a/lisp/efs/dired-mob.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-mob.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: Commands for marking files from another buffer. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-mob) -(require 'dired) -(autoload 'compilation-buffer-p "compile") -(autoload 'compile-reinitialize-errors "compile") - -;; For the byte-compiler -(defvar compilation-error-list) - -;;; Utilities - -(defun dired-mark-these-files (file-list from) - ;; Mark the files in FILE-LIST. Relative filenames are taken to be - ;; in the current dired directory. - ;; FROM is a string (used for logging) describing where FILE-LIST - ;; came from. - ;; Logs files that were not found and displays a success or failure - ;; message. - (message "Marking files %s..." from) - (let ((total (length file-list)) - (cur-dir (dired-current-directory)) - file failures) - (while file-list - (setq file (expand-file-name (car file-list) cur-dir) - file-list (cdr file-list)) - ;;(message "Marking file `%s'" file) - (save-excursion - (if (dired-goto-file file) - (dired-mark 1) ; supplying a prefix keeps it from checking - ; for a subdir. - (setq failures (cons (dired-make-relative file) failures)) - (dired-log (buffer-name (current-buffer)) - "Cannot mark this file (not found): %s\n" file)))) - (dired-update-mode-line-modified t) - (if failures - (dired-log-summary - (buffer-name (current-buffer)) - (format "Failed to mark %d of %d files %s %s" - (length failures) total from failures) failures) - (message "Marked %d file%s %s." total (dired-plural-s total) from)))) - -;;; User commands - -(defun dired-mark-files-from-other-dired-buffer (buf) - "Mark files that are marked in the other Dired buffer. -I.e, mark those files in this Dired buffer that have the same -non-directory part as the marked files in the Dired buffer in the other -window." - (interactive (list (window-buffer (next-window)))) - (if (eq (get-buffer buf) (current-buffer)) - (error "Other dired buffer is the same")) - (or (stringp buf) (setq buf (buffer-name buf))) - (let ((other-files (save-excursion - (set-buffer buf) - (or (eq major-mode 'dired-mode) - (error "%s is not a dired buffer" buf)) - (dired-get-marked-files 'no-dir)))) - (dired-mark-these-files other-files (concat "from buffer " buf)))) - -(defun dired-mark-files-compilation-buffer (&optional buf) - "Mark the files mentioned in the `*compilation*' buffer. -With a prefix, you may specify the other buffer." - (interactive - (list - (let ((buff (let ((owin (selected-window)) - found) - (unwind-protect - (progn - (other-window 1) - (while (null (or found (eq (selected-window) owin))) - (if (compilation-buffer-p - (window-buffer (selected-window))) - (setq found (current-buffer))) - (other-window 1))) - (select-window owin)) - found))) - (if (or current-prefix-arg (null buff)) - (let ((minibuffer-history - (delq nil - (mapcar - (function - (lambda (b) - (and (compilation-buffer-p b) (buffer-name b)))) - (buffer-list))))) - (read-buffer "Use buffer: " - (or buff (car minibuffer-history)))) - buff)))) - (let ((dired-dir (directory-file-name default-directory)) - files) - (save-window-excursion - (set-buffer buf) - (compile-reinitialize-errors nil (point-max)) - (let ((alist compilation-error-list) - f d elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (and (consp (setq elt (car (cdr elt)))) - (stringp (setq d (car elt))) - (stringp (setq f (cdr elt))) - (progn - (setq d (expand-file-name d)) - (dired-in-this-tree d dired-dir)) - (progn - (setq f (expand-file-name f d)) - (not (member f files))) - (setq files (cons f files)))))) - (dired-mark-these-files - files - (concat "From compilation buffer " - (if (stringp buf) buf (buffer-name buf)))))) - -;;; end of dired-mob.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-mule.el --- a/lisp/efs/dired-mule.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-mule.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: MULE support for dired. -;; Created: Sun Jul 17 14:45:12 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Acknowledgements: -;; -;; Ishikawa Ichiro for sending MULE patches and information. - -(require 'dired) - -(defun dired-find-file (&optional coding-system) - "In dired, visit the file or directory named on this line." - (interactive "ZCoding-system: ") - (find-file (dired-get-filename) coding-system)) - -(defun dired-find-file-other-window (&optional display coding-system) - "In dired, visit this file or directory in another window. -With a prefix, the file is displayed, but the window is not selected." - (interactive "P\nZCoding-system: ") - (if display - (dired-display-file coding-system) - (find-file-other-window (dired-get-filename) coding-system))) - -(defun dired-display-file (&optional coding-system) - "In dired, displays this file or directory in the other window." - (interactive "ZCoding-system: ") - (display-buffer - (find-file-noselect (dired-get-filename) coding-system))) - -;;; end of dired-mule.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-oas.el --- a/lisp/efs/dired-oas.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,58 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-oas.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: dired odds and sods. Dired functions not usually needed. -;; This file is not a reference to the Organization of -;; American States. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Don't require or provide anything, as this file is just an archive. - -(defun dired-sort-on-size () - "Sorts a dired listing on file size. -If your ls cannot sort on size, this is useful as `dired-after-readin-hook': - \(setq dired-after-readin-hook 'dired-sort-on-size\)" - (require 'sort) - (goto-char (point-min)) - (dired-goto-next-file) ; skip `total' line - (beginning-of-line) - (sort-subr t 'forward-line 'end-of-line 'dired-get-file-size)) - -(defun dired-directories-of (files) - ;; Return unique list of parent directories of FILES. - (let (dirs dir file) - (while files - (setq file (car files) - files (cdr files) - dir (file-name-directory file)) - (or (member dir dirs) - (setq dirs (cons dir dirs)))) - dirs)) - -(defun dired-parse-ls-show () - (interactive) - (let (inode s mode size uid gid nlink time name sym) - (if (dired-parse-ls) - (message "%s" (list inode s mode nlink uid gid size time name sym)) - (message "Not on a file line.")))) - -(defun dired-files-same-directory (file-list &optional absolute) - "If all files in LIST are in the same directory return it, otherwise nil. -Returned name has no trailing slash. \"Same\" means file-name-directory of -the files are string=. File names in LIST must all be absolute or all be -relative. Implicitly, relative file names are in default-directory. If -optional ABS is non-nil, the returned name will be absolute, otherwise the -returned name will be absolute or relative as per the files in LIST." - (let ((dir (file-name-directory (car file-list)))) - (if (memq nil (mapcar (function - (lambda (file) - (string= dir (file-name-directory file)))) - file-list)) - nil - (directory-file-name - (if (or (not absolute) (and dir (file-name-absolute-p dir))) - (or dir "") - (concat default-directory dir)))))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-rgxp.el --- a/lisp/efs/dired-rgxp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,267 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-rgxp.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for running commands on files whose names -;; match a regular expression. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-rgxp) -(require 'dired) - -;;; Variables - -(defvar dired-flagging-regexp nil) -;; Last regexp used to flag files. - -;;; Utility functions - -(defun dired-do-create-files-regexp - (file-creator operation arg regexp newname &optional whole-path marker-char) - ;; Create a new file for each marked file using regexps. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-get-marked-files. - ;; Matches each marked file against REGEXP and constructs the new - ;; filename from NEWNAME (like in function replace-match). - ;; Optional arg WHOLE-PATH means match/replace the whole pathname - ;; instead of only the non-directory part of the file. - ;; Optional arg MARKER-CHAR as in dired-create-files. - (let* ((fn-list (dired-get-marked-files nil arg)) - (name-constructor - (if whole-path - (list 'lambda '(from) - (list 'let - (list (list 'to - (list 'dired-string-replace-match - regexp 'from newname))) - (list 'or 'to - (list 'dired-log - '(buffer-name (current-buffer)) - "%s: %s did not match regexp %s\n" - operation 'from regexp)) - 'to)) - (list 'lambda '(from) - (list 'let - (list (list 'to - (list 'dired-string-replace-match regexp - '(file-name-nondirectory from) - newname))) - (list 'or 'to - (list 'dired-log '(buffer-name (current-buffer)) - "%s: %s did not match regexp %s\n" - operation '(file-name-nondirectory from) - regexp)) - '(and to - (expand-file-name - to (file-name-directory from))))))) - (operation-prompt (concat operation " `%s' to `%s'?")) - (rename-regexp-help-form (format "\ -Type SPC or `y' to %s one match, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation))) - (query (list 'lambda '(from to) - (list 'let - (list (list 'help-form - rename-regexp-help-form)) - (list 'dired-query - '(quote dired-file-creator-query) - operation-prompt - '(dired-abbreviate-file-name from) - '(dired-abbreviate-file-name to)))))) - (dired-create-files - file-creator operation fn-list name-constructor marker-char query))) - -(defun dired-mark-read-regexp (operation) - ;; Prompt user about performing OPERATION. - ;; Read and return list of: regexp newname arg whole-path. - (let* ((whole-path - (equal 0 (prefix-numeric-value current-prefix-arg))) - (arg - (if whole-path nil current-prefix-arg)) - (regexp - (dired-read-with-history - (concat (if whole-path "Path " "") operation " from (regexp): ") - dired-flagging-regexp 'dired-regexp-history)) - (newname - (read-string - (concat (if whole-path "Path " "") operation " " regexp " to: ") - (and (not whole-path) (dired-dwim-target-directory))))) - (list regexp newname arg whole-path))) - -;;; Marking file names matching a regexp. - -(defun dired-mark-files-regexp (regexp &optional marker-char omission-files-p) - "\\Mark all files matching REGEXP for use in later commands. - -A prefix argument \\[universal-argument] means to unmark them instead. - -A prefix argument 0 means to mark the files that would me omitted by \\[dired-omit-toggle]. -A prefix argument 1 means to unmark the files that would be omitted by \\[dired-omit-toggle]. - -REGEXP is an Emacs regexp, not a shell wildcard. Thus, use \"\\.o$\" for -object files--just `.o' will mark more than you might think. The files \".\" -and \"..\" are never marked. -" - (interactive - (let ((unmark (and (not (eq current-prefix-arg 0)) current-prefix-arg)) - (om-files-p (memq current-prefix-arg '(0 1))) - regexp) - (if om-files-p - (setq regexp (dired-omit-regexp)) - (setq regexp (dired-read-with-history - (concat (if unmark "Unmark" "Mark") - " files (regexp): ") nil - 'dired-regexp-history))) - (list regexp (if unmark ?\ ) om-files-p))) - (let ((dired-marker-char (or marker-char dired-marker-char))) - (dired-mark-if - (and (not (looking-at dired-re-dot)) - (not (eolp)) ; empty line - (let ((fn (dired-get-filename nil t))) - (and fn (string-match regexp (file-name-nondirectory fn))))) - (if omission-files-p - "omission candidate file" - "matching file")))) - -(defun dired-flag-files-regexp (regexp) - "In dired, flag all files containing the specified REGEXP for deletion. -The match is against the non-directory part of the filename. Use `^' - and `$' to anchor matches. Exclude subdirs by hiding them. -`.' and `..' are never flagged." - (interactive (list (dired-read-with-history - "Flag for deletion (regexp): " nil - 'dired-regexp-history))) - (dired-mark-files-regexp regexp dired-del-marker)) - -(defun dired-mark-extension (extension &optional marker-char) - "Mark all files with a certain extension for use in later commands. -A `.' is not prepended to the string entered." - ;; EXTENSION may also be a list of extensions instead of a single one. - ;; Optional MARKER-CHAR is marker to use. - (interactive "sMark files with extension: \nP") - (or (listp extension) - (setq extension (list extension))) - (dired-mark-files-regexp - (concat ".";; don't match names with nothing but an extension - "\\(" - (mapconcat 'regexp-quote extension "\\|") - "\\)$") - marker-char)) - -(defun dired-flag-extension (extension) - "In dired, flag all files with a certain extension for deletion. -A `.' is not prepended to the string entered." - (interactive "sFlag files with extension: ") - (dired-mark-extension extension dired-del-marker)) - -(defun dired-cleanup (program) - "Flag for deletion dispensable files created by PROGRAM. -See variable `dired-cleanup-alist'." - (interactive - (list - (let ((dired-cleanup-history (append dired-cleanup-history - (mapcar 'car dired-cleanup-alist)))) - (dired-completing-read - "Cleanup files for: " dired-cleanup-alist nil t nil - 'dired-cleanup-history)))) - (dired-flag-extension (cdr (assoc program dired-cleanup-alist)))) - -;;; Commands on marked files whose names also match a regexp. - -(defun dired-do-rename-regexp (regexp newname &optional arg whole-path) - "Rename marked files containing REGEXP to NEWNAME. -As each match is found, the user must type a character saying - what to do with it. For directions, type \\[help-command] at that time. -NEWNAME may contain \\=\\ or \\& as in `query-replace-regexp'. -REGEXP defaults to the last regexp used. -With a zero prefix arg, renaming by regexp affects the complete - pathname - usually only the non-directory part of file names is used - and changed." - (interactive (dired-mark-read-regexp "Rename")) - (dired-do-create-files-regexp - (function dired-rename-file) - "Rename" arg regexp newname whole-path dired-keep-marker-rename)) - -(defun dired-do-copy-regexp (regexp newname &optional arg whole-path) - "Copy all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "Copy")) - (dired-do-create-files-regexp - (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg regexp newname whole-path dired-keep-marker-copy)) - -(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path) - "Hardlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "HardLink")) - (dired-do-create-files-regexp - (function add-name-to-file) - "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink)) - -(defun dired-do-symlink-regexp (regexp newname &optional arg whole-path) - "Symlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "SymLink")) - (dired-do-create-files-regexp - (function make-symbolic-link) - "SymLink" arg regexp newname whole-path dired-keep-marker-symlink)) - -(defun dired-do-relsymlink-regexp (regexp newname &optional whole-path) - "RelSymlink all marked files containing REGEXP to NEWNAME. -See functions `dired-rename-regexp' and `dired-do-relsymlink' - for more info." - (interactive (dired-mark-read-regexp "RelSymLink")) - (dired-do-create-files-regexp - (function dired-make-relative-symlink) - "RelSymLink" nil regexp newname whole-path dired-keep-marker-symlink)) - -;;;; Modifying the case of file names. - -(defun dired-create-files-non-directory - (file-creator basename-constructor operation arg) - ;; Perform FILE-CREATOR on the non-directory part of marked files - ;; using function BASENAME-CONSTRUCTOR, with query for each file. - ;; OPERATION like in dired-create-files, ARG like in dired-get-marked-files. - (let (rename-non-directory-query) - (dired-create-files - file-creator - operation - (dired-get-marked-files nil arg) - (function - (lambda (from) - (let ((to (concat (file-name-directory from) - (funcall basename-constructor - (file-name-nondirectory from))))) - (and (let ((help-form (format "\ -Type SPC or `y' to %s one file, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation)))) - (dired-query 'rename-non-directory-query - (concat operation " `%s' to `%s'") - (dired-make-relative from) - (dired-make-relative to))) - to)))) - dired-keep-marker-rename))) - -(defun dired-rename-non-directory (basename-constructor operation arg) - (dired-create-files-non-directory - (function dired-rename-file) - basename-constructor operation arg)) - -(defun dired-upcase (&optional arg) - "Rename all marked (or next ARG) files to upper case." - (interactive "P") - (dired-rename-non-directory (function upcase) "Rename upcase" arg)) - -(defun dired-downcase (&optional arg) - "Rename all marked (or next ARG) files to lower case." - (interactive "P") - (dired-rename-non-directory (function downcase) "Rename downcase" arg)) - -;;; end of dired-rgxp.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-sex.el --- a/lisp/efs/dired-sex.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-sex.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Marking files according to sexpressions. Sorry. -;; Created: Wed Sep 14 01:30:43 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'dired-sex) -(require 'dired) - -(defvar dired-sexpr-history-symbol nil - "History of sexpr used to mark files in dired.") - -;;; Marking files according to sexpr's - -(defmacro dired-parse-ls () - ;; Sets vars - ;; inode s mode nlink uid gid size time name sym - ;; (probably let-bound in caller) according to current file line. - ;; Returns t for succes, nil if this is no file line. - ;; Upon success, all variables are set, either to nil or the - ;; appropriate value, so they need not be initialized. - ;; Moves point within the current line to the end of the file name. - '(let ((bol (progn (beginning-of-line) (point))) - (eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if (re-search-forward dired-re-month-and-time eol t) - (let ((mode-len 10) ; length of mode string - (tstart (progn (goto-char (match-beginning 0)) - (skip-chars-forward " ") - (point))) - (fstart (match-end 0)) - pos) - (goto-char (1+ bol)) - (skip-chars-forward " \t") - ;; This subdir had better have been created with the current - ;; setting of actual switches. Otherwise, we can't parse. - (cond - ((and (or (memq ?k dired-internal-switches) - (memq ?s dired-internal-switches)) - (memq ?i dired-internal-switches)) - (setq pos (point)) - (skip-chars-forward "0-9") - (if (setq inode (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point))))) - (progn - (skip-chars-forward " ") - (setq pos (point)) - (skip-chars-forward "0-9") - (setq s (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point)))))) - (setq s nil))) - ((or (memq ?s dired-internal-switches) - (memq ?k dired-internal-switches)) - (setq pos (point)) - (skip-chars-forward "0-9") - (setq s (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point)))) - inode nil)) - ((memq ?i dired-internal-switches) - (setq pos (point)) - (skip-chars-forward "0-9") - (setq inode (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point)))) - s nil)) - (t - (setq s nil - inode nil))) - (skip-chars-forward " 0-9") ; in case of junk - (setq mode (buffer-substring (point) (+ mode-len (point)))) - (forward-char mode-len) - (setq nlink (read (current-buffer))) - (or (integerp nlink) (setq nlink nil)) - (setq uid (buffer-substring (point) (progn - (skip-chars-forward "^ ") - (point)))) - (goto-char tstart) - (skip-chars-backward " ") - (setq pos (point)) - (skip-chars-backward "0-9") - (if (= pos (point)) - (setq size nil) - (setq size (string-to-int (buffer-substring (point) pos)))) - (skip-chars-backward " ") - ;; if no gid is displayed, gid will be set to uid - ;; but user will then not reference it anyway in PREDICATE. - (setq gid (buffer-substring (point) (progn - (skip-chars-backward "^ ") - (point))) - time (buffer-substring tstart - (progn - (goto-char fstart) - (skip-chars-backward " ") - (point))) - name (buffer-substring - fstart - (or (dired-move-to-end-of-filename t) - (point))) - sym (and (looking-at "[/*@#=|]? -> ") - (buffer-substring (match-end 0) - eol))) - t)))) ; return t if parsing was a success - - -(defun dired-mark-sexp (predicate &optional unflag-p) - "Mark files for which PREDICATE returns non-nil. -With a prefix arg, unflag those files instead. - -PREDICATE is a lisp expression that can refer to the following symbols: - - inode [integer] the inode of the file (only for ls -i output) - s [integer] the size of the file for ls -s output - (ususally in blocks or, with -k, in KByte) - mode [string] file permission bits, e.g. \"-rw-r--r--\" - nlink [integer] number of links to file - uid [string] owner - gid [string] group (If the gid is not displayed by ls, - this will still be set (to the same as uid)) - size [integer] file size in bytes - time [string] the time that ls displays, e.g. \"Feb 12 14:17\" - name [string] the name of the file - sym [string] if file is a symbolic link, the linked-to name, else nil. - -For example, use - - (equal 0 size) - -to mark all zero length files." - ;; Using sym="" instead of nil avoids the trap of - ;; (string-match "foo" sym) into which a user would soon fall. - ;; No! Want to be able look for symlinks pointing to the empty string. - ;; Can happen. Also, then I can do an (if sym ...) structure. --sandy - ;; Give `equal' instead of `=' in the example, as this works on - ;; integers and strings. - (interactive - (list - (read - (dired-read-with-history "Mark if (lisp expr): " nil - 'dired-sexpr-history)) - current-prefix-arg)) - (message "%s" predicate) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)) - inode s mode nlink uid gid size time name sym) - (dired-mark-if (save-excursion - (and (dired-parse-ls) - (eval predicate))) - (format "'%s file" predicate))) - (dired-update-mode-line-modified t)) - -;;; end of dired-sex.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-shell.el --- a/lisp/efs/dired-shell.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,861 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-shell.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for running shell commands on marked files. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-shell) -(require 'dired) -(autoload 'comint-mode "comint") - -;;; Variables - -(defvar dired-postscript-print-command - (condition-case nil - (progn - (require 'ps-print) - (concat ps-lpr-command - " " - (ps-flatten-list (mapcar 'ps-eval-switch ps-lpr-switches)))) - (error - (concat - (if (boundp 'lpr-command) - lpr-command - (if (memq system-type - '(usg-unix-v hpux silicon-graphics-unix)) - "lp" - "lpr")) - (if (and (boundp 'lpr-switches) lpr-switches) - (concat " " - (mapconcat 'identity lpr-switches " ") - " ") - " ")))) - "Command to print a postscript file.") - -(defvar dired-text-print-command (concat dired-postscript-print-command "-p ") - "Command to print a text file.") - -(defvar dired-print-program-alist - (list - (cons "\\.gif$" (concat "giftoppm * | ppmtopgm | pnmtops | " - dired-postscript-print-command)) - (cons "\\.\\(fts\\|FTS\\)$" (concat "fitstopgm * | pnmtops | " - dired-postscript-print-command)) - ;; People with colour printers won't want the g-flag in djpeg - (cons "\\.\\(JPG\\|jpg\\)$" (concat "djpeg -Pg * | pnmtops | " - dired-postscript-print-command)) - (cons "\\.ps\\.\\(gz\\|Z\\)$" (concat "zcat * | " - dired-postscript-print-command)) - (cons "\\.ps$" dired-postscript-print-command) - (cons "\\.\\(gz\\|Z\\)$" (concat "zcat * | " - dired-postscript-print-command)) - (cons "\\.dvi$" "dvips") - (cons ".*" dired-text-print-command)) - "Alist of regexps and print commands. -This is used by `dired-do-print' to determine the default print command for -printing the marked files.") - -(defvar dired-auto-shell-command-alist nil - "*Alist of regexps and command lists to guess shell commands. -Each element of this list should be a list of regular expression, and a list -of guesses for shell commands to be used if the file name matches the regular -expression. The list of guesses is evalled. This alist is appended to the front -of dired-default-auto-shell-command-alist before prompting for each shell -command.") - -(defvar dired-default-auto-shell-command-alist - (list - - ;; Archiving - '("\\.tar$" - (if dired-gnutar-program - (concat dired-gnutar-program " xvf") - "tar xvf") - (if dired-gnutar-program - (concat dired-gnutar-program " tvf") - "tar tvf")) - ;; regexps for compressed archives must come before the .Z rule to - ;; be recognized: - '("\\.tar\\.\\([zZ]\\|gz\\)\\|\\.tgz$" ; .tgz is for DOS - (if dired-gnutar-program - (concat dired-gnutar-program " zxvf") - "zcat * | tar xvf -") - (if dired-gnutar-program - (concat dired-gnutar-program " ztvf") - "zcat * | tar tvf -")) - '("\\.shar.[zZ]$" (if dired-unshar-program - (concat "zcat * | " dired-unshar-program) - "zcat * | sh")) - '("\\.zoo$" "zoo x//") - '("\\.zip$" "unzip" "unzip -v") - '("\\.lzh$" "lharc x") - '("\\.arc$" "arc x") - '("\\.shar$" (if dired-unshar-program dired-unshar-program "sh")) - - ;; Encoding/compressing - '("\\.uu$" "uudecode") - '("\\.hqx$" "mcvert") - - ;; Executing (in the generalized sense) - '("\\.sh$" "sh") ; execute shell scripts - '("^[Mm]akefile$" "make -f *") - '("\\.diff$" "patch -t <") - - ;; Displaying (assumes X) - '("\\.xbm$" "bitmap") ; view X11 bitmaps - '("\\.gp$" "gnuplot") - '("\\.gif$" "xv") ; view gif pictures - '("\\.fig$" "xfig") ; edit fig pictures - '("\\.ps$" "ghostview") - - ;; Typesetting. For printing documents, see dired-print-program-alist. - '("\\.tex$" "latex" "tex") - '("\\.texi\\(nfo\\)?$" "makeinfo" "texi2dvi") - (if (eq window-system 'x) - (if dired-use-file-transformers - '("\\.dvi$" "xdvi" "dvips -o *b.ps *") - '("\\.dvi$" "xdvi" "dvips")) - (if dired-use-file-transformers - '("\\.dvi$" "dvips -o *b.ps *") - '("\\.dvi$" "dvips"))) - - ;; The last word. Things that cannot be grokked with a regexp. - '("." (if (> (length files) 1) - "tar cvf " - (and (= (length files) 1) (file-directory-p - (expand-file-name - (car files) - (dired-current-directory))) - (concat "tar cvf " (file-name-nondirectory - (directory-file-name (car files))) - ".tar")))) - ) - "Default for variable `dired-auto-shell-command-alist' (which see). -Set this to nil to turn off shell command guessing.") - -;; Might use {,} for bash or csh: -(defvar dired-shell-prefix "" - "Prepended to marked files in dired shell commands.") -(defvar dired-shell-postfix "" - "Appended to marked files in dired shell commands.") -(defvar dired-shell-separator " " - "Separates marked files in dired shell commands.") - -(defvar dired-file-wildcard ?* - "Wildcard character used by dired shell commands. -Indicates where file names should be inserted.") - -(defvar dired-shell-command-separators '(?\ ?| ?> ?< ?& ?;) - "Defines the start of a string specifying a word in a shell command.") - -(defvar dired-trans-map - (list - (cons ?f 'identity) - (cons ?n 'file-name-nondirectory) - (cons ?d 'file-name-directory) - (cons ?b 'dired-file-name-base) - (cons ?e 'dired-file-name-extension) - (cons ?v 'dired-file-name-sans-rcs-extension) - (cons ?z 'dired-file-name-sans-compress-extension)) - "Alist that associates keys with file transformer functions -Each transformer function should be a funcion of one argument, the file name. -The keys are characters.") - -(defvar dired-shell-failure-marker ?! - "*A marker to mark files on which shell commands fail. -If nil, such files are not marked.") - -;;; Internal variables - -;; Make sure this gets defined. -(defvar shell-command-history nil - "History list of previous shell commands.") - -(defvar dired-print-history nil - "History of commands used to print files.") - -(defvar dired-shell-input-start) ; only defined in shell output buffers - -;;; Utility functions and Macros - -(defun dired-shell-quote (filename) - ;; Quote a file name for inferior shell (see variable shell-file-name). - ;; Quote everything except POSIX filename characters. - ;; This should be safe enough even for really weird shells. - (let ((result "") (start 0) end) - (while (string-match "[^---0-9a-zA-Z_./]" filename start) - (setq end (match-beginning 0) - result (concat result (substring filename start end) - "\\" (substring filename end (1+ end))) - start (1+ end))) - (concat result (substring filename start)))) - -(defun dired-uniquefy-list (list) - ;; Returns list, after removing 2nd and higher occurrences - ;; of all elements. Tests elements with equal. Retains the relative - ;; order of the elements. - ;; For small lists, this way is probably faster than sorting. - (let (result) - (while list - (or (member (car list) result) - (setq result (nconc result (list (car list))))) - (setq list (cdr list))) - result)) - -(defun dired-read-shell-command (prompt arg files) - ;; Read a dired shell command prompting with PROMPT (using read-string). - ;; ARG is the prefix arg and may be used to indicate in the prompt which - ;; files are affected. - (dired-mark-pop-up - nil 'shell files - (function - (lambda (prompt files) - (let* ((default (car shell-command-history)) - (guesses (dired-guess-default files)) - (len (length guesses)) - cmd) - (or (zerop len) - (setq prompt (format "%s{%d guess%s} " - prompt len (if (= len 1) "" "es")))) - (if default (setq prompt (concat prompt "[" default "] "))) - (put 'guesses 'no-default t) ; for gmhist, in case. - (setq guesses (nconc guesses (copy-sequence shell-command-history)) - cmd (dired-read-with-history prompt nil 'guesses)) - (if (string-match "^[ \t\n]*$" cmd) - (if default - (setq cmd default) - (error "No shell command given."))) - (setq shell-command-history - (dired-uniquefy-list - (cons cmd shell-command-history))) - cmd))) - (format prompt (dired-mark-prompt arg files)) files)) - -(defmacro dired-trans-subst (transformers filename dir) -;; Applies each transformer supplied in the string TRANSFORMERS in sequence -;; to FILE and returns the concatenation of the results. Also unquotes \\'s. -;; Returns a string if no file transformations were done, otherwise a list -;; consisting of a single string. - (` (let* ((transformers (, transformers)) - (filename (, filename)) - (len (length transformers)) - (pos 0) - (last 0) - (transformed nil) - (quoted nil) - char result trans) - (while (< pos len) - (setq char (aref transformers pos)) - (cond - (quoted (setq pos (1+ pos) - quoted nil)) - ((= ?\\ char) - (setq quoted t - result (concat result (substring transformers last pos)) - pos (1+ pos) - last pos)) - ((and (null quoted) (= char dired-file-wildcard)) - (setq pos (1+ pos) - trans (and (< pos len) - dired-use-file-transformers - (assq (aref transformers pos) - dired-trans-map)) - transformed t) - (if trans - (setq result (concat result - (substring transformers last (1- pos)) - (funcall (cdr trans) filename)) - pos (1+ pos) - last pos) - (setq result (concat result (substring transformers last (1- pos)) - (dired-make-relative filename (, dir) t)) - last pos))) - ((setq pos (1+ pos))))) - (if result - (progn - (setq result (dired-shell-quote - (concat result (substring transformers last)))) - (if transformed (list result) result)) - transformers)))) - -(defun dired-trans-filenames (transformers files dir) - ;; Applies a transformer string to a list of filenames, - ;; concatenating them into a string. The result will be prefixed - ;; by dired-shell-prefix, the filenames separated by dired-shell-separator, - ;; and postfixed by dired-shell-postfix. - ;; Returns a list if filename subst. was done. A string otherwise. - (let ((list files) - (res nil) - trans) - (while list - (setq trans (dired-trans-subst transformers (car list) dir)) - (if (listp trans) - (setq res (nconc res trans) - list (cdr list)) - (setq res trans - list nil))) - (if (listp res) - (list - (if (> (length files) 1) - (concat dired-shell-prefix - (mapconcat 'identity res dired-shell-separator) - dired-shell-postfix) - (car res))) - res))) - -(defun dired-trans-command (command files dir) - ;; Do all of the trans substitutions in COMMAND for the list - ;; of files FILES. FILES must be a list of *absolute* pathnames. - ;; DIR is an absolute directory wrto which filenames may be relativized. - (let ((len (length command)) - (start 0) - (pos 0) - (last 0) - result char transed transform) - (while (< pos len) - ;; read over word separators. - (while (and (< pos len) (memq (aref command pos) - dired-shell-command-separators)) - (setq pos (1+ pos))) - (setq start pos) - ;; read a word - (while (and (< pos len) (not (memq (setq char (aref command pos)) - dired-shell-command-separators))) - (setq pos (1+ pos)) - ;; look out for quoted separators - (and (= ?\\ char) (< pos len) (or (memq (setq char (aref command pos)) - dired-shell-command-separators) - (= ?\\ char)) - (setq pos (1+ pos)))) - (setq transform (if (= start pos) - "" - (dired-trans-filenames (substring command start pos) - files dir)) - ;; remember if we did any transforming - transed (or transed (listp transform)) - result (concat result - (substring command last start) - (if (listp transform) - (car transform) - transform)) - last pos)) - (if transed - ;; just return result - result - ;; add the filenames at the end. - (let ((fns (if (> (length files) 1) - (concat dired-shell-prefix - (mapconcat - (function - (lambda (fn) - (dired-shell-quote - (dired-make-relative fn dir t)))) - files dired-shell-separator) - dired-shell-postfix) - (dired-shell-quote - (dired-make-relative (car files) dir t))))) - (concat result " " fns))))) - -(defun dired-shell-stuff-it (command file-list dir on-each) - ;; Make up a shell command line from COMMAND and FILE-LIST. - ;; If ON-EACH is t, COMMAND should be applied to each file, else - ;; simply concat all files and apply COMMAND to this. - ;; If ON-EACH is 'dir, the command is run in the directory of each file - ;; In this case FILE-LIST must be a list of full paths. - ;; FILE-LIST's elements will be quoted for the shell. - (cond - ((eq on-each 'dir) - (let ((subshell-dir nil) - (list file-list) - (result nil)) - (while list - (let ((cmd (dired-trans-command command (list (car list)) - (file-name-directory (car list)))) - (fdir (dired-shell-quote (file-name-directory (car list))))) - (setq result - (apply 'concat - result - (if subshell-dir - (if (string-equal dir subshell-dir) - (list "\; " cmd) - (if (string-equal dir fdir) - (progn - (setq subshell-dir nil) - (list "\)\; " cmd)) - (setq subshell-dir fdir) - (list "\)\; \(cd " - fdir - "\; " - cmd))) - (if (string-equal fdir dir) - (list (and result "\; ") - cmd) - (setq subshell-dir fdir) - (list (and result "\; ") - "\(cd " - fdir - "\; " - cmd))))) - (setq list (cdr list)))) - (concat result (and subshell-dir ")")))) - (on-each - (mapconcat (function - (lambda (fn) - (dired-trans-command command (list fn) dir))) - file-list "; ")) - - (t (dired-trans-command command file-list dir)))) - -(defun dired-guess-default (files) - ;; Guess a list of possible shell commands for FILES. - (and dired-default-auto-shell-command-alist - files - (let ((alist (append dired-auto-shell-command-alist - dired-default-auto-shell-command-alist)) - guesses) - (while alist - (let* ((elt (car alist)) - (regexp (car elt))) - (setq guesses - (nconc guesses - (catch 'missed - (mapcar (function - (lambda (file) - (or (string-match regexp file) - (throw 'missed nil)))) - files) - (delq nil (mapcar 'eval (cdr elt))))))) - (setq alist (cdr alist))) - (dired-uniquefy-list guesses)))) - -(defun dired-shell-unhandle-file-name (filename) - "Turn a file name into a form that can be sent to a shell process. -This is particularly usefull if we are sending file names to a remote shell." - (let ((handler (find-file-name-handler filename 'dired-shell-unhandle-file-name))) - (if handler - (funcall handler 'dired-shell-unhandle-file-name filename) - filename))) - -;;; Actually running the shell command - -(defun dired-run-shell-command-closeout (buffer &optional message) - ;; Report on the number of lines produced by a shell command. - (if (get-buffer buffer) - (save-excursion - (set-buffer buffer) - (if (zerop (buffer-size)) - (progn - (if message - (message "Shell command completed with no output. %s" - message) - (message "Shell command completed with no output.")) - (kill-buffer buffer)) - (set-window-start (display-buffer buffer) 1) - (if message - (message "Shell command completed. %s" message) - (message "Shell command completed.")))))) - -(defun dired-rsc-filter (proc string) - ;; Do save-excursion by hand so that we can leave point - ;; numerically unchanged despite an insertion immediately - ;; after it. - (let* ((obuf (current-buffer)) - (buffer (process-buffer proc)) - opoint - (window (get-buffer-window buffer)) - (pos (window-start window))) - (unwind-protect - (progn - (set-buffer buffer) - (setq opoint (point)) - (goto-char (point-max)) - (insert-before-markers string)) - ;; insert-before-markers moved this marker: set it back. - (set-window-start window pos) - ;; Finish our save-excursion. - (goto-char opoint) - (set-buffer obuf)))) - -(defun dired-rsc-sentinel (process signal) - ;; Sentinel function used by dired-run-shell-command - (if (memq (process-status process) '(exit signal)) - (let ((buffer (get-buffer (process-buffer process)))) - (if buffer - (save-excursion - (set-buffer buffer) - (if (zerop (buffer-size)) - (message - "Dired & shell command completed with no output.") - (let ((lines (count-lines dired-shell-input-start - (point-max)))) - (message - "Dired & shell command completed with %d line%s of output." - lines (dired-plural-s lines)))) - (setq mode-line-process nil))) - (delete-process process)))) - -(defun dired-shell-call-process (command dir &optional in-background) - ;; Call a shell command as a process in the current buffer. - ;; The process should try to run in DIR. DIR is also - ;; used to lookup a file-name-handler. - ;; Must return the process object if IN-BACKGROUND is non-nil, - ;; otherwise the process exit status. - (let ((handler (find-file-name-handler dir 'dired-shell-call-process))) - (if handler - (funcall handler 'dired-shell-call-process command dir in-background) - (let ((process-connection-type ; don't waste pty's - (null (null in-background)))) - (setq default-directory dir) - (if in-background - (progn - (setq mode-line-process '(": %s")) - (start-process "Shell" (current-buffer) - shell-file-name "-c" command)) - (call-process shell-file-name nil t nil "-c" command)))))) - -(defun dired-run-shell-command (command dir in-background &optional append) - ;; COMMAND is shell command - ;; DIR is directory in which to do the shell command. - ;; If IN-BACKGROUND is non-nil, the shell command is run in the background. - ;; If it is a string, this is written as header into the output buffer - ;; before the command is run. - ;; If APPEND is non-nil, the results are appended to the contents - ;; of *shell-command* buffer, without erasing its previous contents. - (save-excursion - (if in-background - (let* ((buffer (get-buffer-create - "*Background Shell Command Output*")) - (n 2) - proc) - ;; No reason why we can't run two+ background commands. - (while (get-buffer-process buffer) - (setq buffer (get-buffer-create - (concat "*Background Shell Command Output*<" - (int-to-string n) ">")) - n (1+ n))) - (set-buffer buffer) - (or (eq major-mode 'comint-mode) - (progn - (comint-mode) - (set (make-local-variable 'comint-prompt-regexp) - "^[^\n]*\\? *"))) - (display-buffer buffer) - (barf-if-buffer-read-only) - ;; If will kill a process, query first. - - (set (make-local-variable 'dired-shell-input-start) (point-min)) - (if append - (progn - (goto-char (point-max)) - (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) - (erase-buffer) - (if (stringp in-background) - (progn - (insert in-background) - (set (make-local-variable 'dired-shell-input-start) - (point))))) - (setq proc (dired-shell-call-process command dir t)) - (set-marker (process-mark proc) (point)) - (set-process-sentinel proc 'dired-rsc-sentinel) - (set-process-filter proc 'dired-rsc-filter) - nil) ; return - (let ((buffer (get-buffer-create "*Shell Command Output*"))) - (set-buffer buffer) - (barf-if-buffer-read-only) - (set (make-local-variable 'dired-shell-input-start) (point-min)) - (if append - (progn - (goto-char (point-max)) - (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) - (erase-buffer)) - (dired-shell-call-process command dir))))) - -;;; User commands - -(defun dired-do-shell-command (command arg files &optional in-background) - ;; ARG = (16) means operate on each file, in its own directory. - ;; ARG = (4) means operate on each file, but in the current - ;; default-directory. - "Run a shell command COMMAND on the marked files. -If no files are marked or a non-zero numeric prefix arg is given, -the next ARG files are used. Use prefix 1 to indicate the current file. - -Normally the shell command is executed in the current dired subdirectory. -This is the directory in the dired buffer which currently contains the point. -One shell command is run for all of the files. -e.g. cmd file1 file2 file3 ... -If the total length of of the command exceeds 10000 characters, the files will -be bunched to forms commands shorter than this length, and successive commands -will be sent. - -With a prefix of \\[universal-argument], a separate command for each file will -be executed. - -With a prefix of \\[universal-argument] \\[universal-argument], a separate command will be sent for each file, -and the command will be executed in the directory of that file. The explicit -command will be of the form - - cd dir; cmd file - -When prompting for the shell command, dired will always indicate the directory -in which the command will be executed. - -The following documentation depends on the settings of `dired-file-wildcard', -`dired-shell-command-separators', `dired-trans-map', `dired-shell-prefix', -`dired-shell-separator', and `dired-shell-postfix'. See the documentation for -these variables. Below, I will assume default settings for these variables. - -If the shell command contains a *, then the list of files is substituted for *. -The filenames will be written as relative to the directory in which the shell -command is executing. If there is no *, and the command does not end in &, -then the files are appended to the end of the command. If the command ends in -a &, then the files are inserted before the &. - -If `dired-use-file-transformers' is non-nil, then certain 2-character -sequences represent parts of the file name. -The default transformers are: -*f = full file name -*n = file name without directory -*d = file name's directory - This will end in a \"/\" in unix. -*e = file names extension - By default this the part of the file name without directory, which - proceeds the first \".\". If \".\" is the first character of the name, - then this \".\" is ignored. The definition of extension can - be customized with `dired-filename-re-ext'. -*b = file base name - This is the part of the file name without directory that precedes - the extension. -*v = file name with out version control extension (i.e. \",v\") -*z = file name without compression extension - (i.e. \".Z\", \".z\", or \".gz\") - -Shell commands are divided into words separated by spaces. Then for each -word the file name transformers are applied to the list of files, the result -concatenated together and substituted for the word in the shell command. - -For example - cmd -a *f -b *d*b.fizzle applied to /foo/bar and /la/di/da results in - cmd -a /foo/bar /la/di/da -b /foo/bar.fizzle /la/di/da.fizzle - -The \"on-each\" prefixes \\[universal-argument] and 0, also apply while -using file transformers. As well, when using file-transformers * still -represents the file name relative to the current directory. Not that this -differs from *f, which always represents the full pathname. - -A \"\\\" can always be used to quote any character having special meaning. -For example, if the current directory is /la, then *n applied -to /la/di/da returns la, whereas *\\n returns di/dan. Similarly, -\"*d\\ *n\" returns \"/la/di da\". - -The prefix character for file name transformers is always the same as -`dired-file-wildcard'." - - (interactive - (let ((on-each (or (equal '(4) current-prefix-arg) - (equal '(16) current-prefix-arg))) - (files (dired-get-marked-files - nil (and (not (consp current-prefix-arg)) - current-prefix-arg))) - (dir (and (not (equal current-prefix-arg '(16))) - (dired-current-directory)))) - (list - (dired-read-shell-command - (concat (if dir - (format "! in %s " (dired-abbreviate-file-name dir)) - "cd

; ! ") - "on " - (if on-each "each ") - "%s: ") - (and (not on-each) current-prefix-arg) - (if dir - (mapcar (function - (lambda (fn) - (dired-make-relative fn dir t))) - files) - files)) - current-prefix-arg files nil))) - - ;; Check for background commands - (if (string-match "[ \t]*&[ \t]*$" command) - (setq command (substring command 0 (match-beginning 0)) - in-background t)) - - ;; Look out for remote file names. - - (let* ((on-each (or (equal arg '(4)) (and (equal arg '(16)) 'dir))) - (ufiles (mapcar 'dired-shell-unhandle-file-name files)) - (dir (dired-current-directory)) - (udir (dired-shell-unhandle-file-name dir))) - - (save-excursion ; in case `shell-command' changes buffer - (cond - - ((null ufiles) - ;; Just run as a command on no files. - (if in-background - (dired-run-shell-command command dir t) - (dired-run-shell-command command dir nil) - (dired-run-shell-command-closeout "*Shell Command Output*"))) - - (in-background - ;; Can't use dired-bunch-files for background shell commands. - ;; as we will create a bunch of process running simultaneously. - ;; A better solution needs to be found. - (dired-run-shell-command - (dired-shell-stuff-it command ufiles udir on-each) - dir (if (equal arg '(16)) - (concat "cd ; \"" command "\"\n\n") - (concat "\"" command "\" in " dir "\n\n")))) - (on-each - (let ((buff (get-buffer "*Shell Command Output*")) - failures this-command this-dir ufile return message) - (if buff - (save-excursion - (set-buffer buff) - (erase-buffer))) - (while ufiles - (setq ufile (car ufiles)) - (if (eq on-each 'dir) - (setq this-dir (dired-shell-quote (file-name-directory (directory-file-name ufile))) - this-command (concat "cd " this-dir "; " command)) - (setq this-command command) - (or this-dir (setq this-dir udir))) - (setq return - (dired-run-shell-command - (dired-shell-stuff-it this-command (list ufile) this-dir nil) - this-dir nil t)) - (if (and (integerp return) (/= return 0)) - (save-excursion - (let ((file (nth (- (length files) (length (member ufile ufiles))) files))) - (if (and dired-shell-failure-marker - (dired-goto-file file)) - (let ((dired-marker-char dired-shell-failure-marker)) - (dired-mark 1))) - (setq failures (cons file failures))))) - (setq ufiles (cdr ufiles))) - (if failures - (let ((num (length failures))) - (setq message - (if dired-shell-failure-marker - (format - "Marked %d failure%s with %c." - num (dired-plural-s num) - dired-shell-failure-marker) - "Failed on %d file%s." num - (dired-plural-s num))) - (dired-log - (current-buffer) - "Shell command %s failed (non-zero exit status) for:\n %s" - command failures) - (dired-log (current-buffer) t))) - (dired-run-shell-command-closeout "*Shell Command Output*" message))) - - (t - (dired-bunch-files - (- 10000 (length command)) - (function (lambda (&rest ufiles) - (dired-run-shell-command - (dired-shell-stuff-it command ufiles udir nil) - dir nil) - nil)) ; for the sake of nconc in dired-bunch-files - nil ufiles) - (dired-run-shell-command-closeout "*Shell Command Output*")))) - ;; Update any directories - (or in-background - (let ((dired-no-confirm '(revert-subdirs))) - (dired-verify-modtimes))))) - -(defun dired-do-background-shell-command (command arg files) - "Like \\[dired-do-shell-command], but starts command in background. -Note that you can type input to the command in its buffer. -This requires background.el from the comint package to work." - ;; With the version in emacs-19.el, you can alternatively just - ;; append an `&' to any shell command to make it run in the - ;; background, but you can't type input to it. - (interactive - (let ((on-each (or (equal '(4) current-prefix-arg) - (equal '(16) current-prefix-arg))) - (files (dired-get-marked-files - nil (and (not (consp current-prefix-arg)) - current-prefix-arg))) - (dir (and (not (equal current-prefix-arg '(16))) - (dired-current-directory)))) - (list - (dired-read-shell-command - (concat "& " - (if dir - (format "in %s " (dired-abbreviate-file-name dir)) - "cd ; ") - "on " - (if on-each "each ") - "%s: ") - (and (not on-each) current-prefix-arg) - (if dir - (mapcar (function - (lambda (fn) - (dired-make-relative fn dir t))) - files) - files)) - current-prefix-arg files))) - (dired-do-shell-command command arg files t)) - -;;; Printing files - -(defun dired-do-print (&optional arg command files) - "Print the marked (or next ARG) files. -Uses the shell command coming from variable `dired-print-program-alist'." - (interactive - (progn - (if dired-print-history - (setq dired-print-history (dired-uniquefy-list dired-print-history)) - (setq dired-print-history (mapcar 'cdr dired-print-program-alist))) - (let* ((files (dired-get-marked-files nil current-prefix-arg)) - (rel-files (mapcar (function - (lambda (fn) - (dired-make-relative - fn - (dired-current-directory) t))) - files)) - (alist dired-print-program-alist) - (first (car files)) - (dired-print-history (copy-sequence dired-print-history)) - elt initial command) - ;; For gmhist - (put 'dired-print-history 'no-default t) - (if first - (while (and alist (not initial)) - (if (string-match (car (car alist)) first) - (setq initial (cdr (car alist))) - (setq alist (cdr alist))))) - (if (and initial (setq elt (member initial dired-print-history))) - (setq dired-print-history (nconc - (delq (car elt) dired-print-history) - (list initial)))) - (setq command - (dired-mark-read-string - "Print %s with: " - initial 'print current-prefix-arg rel-files - 'dired-print-history)) - (list current-prefix-arg command files)))) - (or files - (setq files (dired-get-marked-files nil arg))) - (while files - (dired-print-file command (car files)) - (setq files (cdr files)))) - -(defun dired-print-file (command file) - ;; Using COMMAND, print FILE. - (let ((handler (find-file-name-handler file 'dired-print-file))) - (if handler - (funcall handler 'dired-print-file command file) - (let ((rel-file (dired-make-relative file (dired-current-directory) t))) - (message "Spooling %s..." rel-file) - (shell-command (dired-trans-command command (list file) "")) - (message "Spooling %s...done" rel-file))))) - -;;; end of dired-shell.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-uu.el --- a/lisp/efs/dired-uu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,116 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-uu.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for uuencoding/uudecoding marked files. -;; Author: Sandy Rutherford -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-uu) -(require 'dired) - -(defvar dired-uu-files-to-decode nil) -;; Fluid var to pass data inside dired-create-files. - -(defun dired-uucode-file (file ok-flag) - ;; uuencode or uudecode FILE. - ;; Don't really support the ok-flag, but needed for compatibility - (let ((handler (find-file-name-handler file 'dired-uucode-file))) - (cond (handler - (funcall handler 'dired-uucode-file file ok-flag)) - ((or (file-symlink-p file) (file-directory-p file)) - nil) - (t - (if (assoc file dired-uu-files-to-decode) - (let ((default-directory (file-name-directory file))) - (if (dired-check-process - (concat "Uudecoding " file) shell-file-name "-c" - (format "uudecode %s" file)) - (signal 'file-error (list "Error uudecoding" file)))) - (let ((nfile (concat file ".uu"))) - (if (dired-check-process - (concat "Uuencoding " file) shell-file-name "-c" - (format "uuencode %s %s > %s" - file (file-name-nondirectory file) nfile)) - (signal 'file-error (list "Error uuencoding" file))))))))) - -(defun dired-uucode-out-file (file) - ;; Returns the name of the output file for the uuencoded FILE. - (let ((buff (get-buffer-create " *dired-check-process output*")) - (case-fold-search t)) - (save-excursion - (set-buffer buff) - (erase-buffer) - (if (string-equal "18." (substring emacs-version 0 3)) - (call-process "head" file buff nil "-n" "1") - (insert-file-contents file nil 0 80)) - (goto-char (point-min)) - (if (looking-at "begin [0-9]+ \\([^\n]*\\)\n") - (expand-file-name - (buffer-substring (match-beginning 1) (match-end 1)) - (file-name-directory file)) - nil)))) - -(defun dired-do-uucode (&optional arg files to-decode) - "Uuencode or uudecode marked (or next ARG) files." - (interactive - (let* ((dir (dired-current-directory)) - (files (dired-get-marked-files nil current-prefix-arg)) - (arg (prefix-numeric-value current-prefix-arg)) - (total (length files)) - rfiles decoders ofile decode encode hint-p) - (mapcar - (function - (lambda (fn) - (if (setq ofile (dired-uucode-out-file fn)) - (setq decoders (cons (cons fn ofile) decoders))))) - files) - (setq decode (length decoders) - encode (- total decode) - hint-p (not (or (zerop decode) (zerop encode)))) - (setq rfiles - (mapcar - (function - (lambda (fn) - (if hint-p - (concat - (if (assoc fn decoders) " [de] " " [en] ") - (dired-make-relative fn dir t)) - (dired-make-relative fn dir t)))) - files)) - (or (memq 'uuencode dired-no-confirm) - (dired-mark-pop-up nil 'uuencode rfiles 'y-or-n-p - (cond - ((null decoders) - (if (= encode 1) - (format "Uuencode %s? " (car rfiles)) - (format "Uuencode %d file%s? " - encode (dired-plural-s encode)))) - ((zerop encode) - (if (= decode 1) - (format "Uudecode %s? " (car rfiles)) - (format "Uudecode %d file%s? " - decode (dired-plural-s decode)))) - (t - (format "Uudecode %d and uuencode %d file%s? " - decode encode (dired-plural-s encode))))) - (setq arg 0)) - (list arg files decoders))) - (let ((dired-uu-files-to-decode to-decode) - out-file) - (if (not (zerop arg)) - (dired-create-files - 'dired-uucode-file - "Uuencode or Uudecode" - files - (function - (lambda (fn) - (if (setq out-file (assoc fn dired-uu-files-to-decode)) - (cdr out-file) - (concat fn ".uu")))) - dired-keep-marker-uucode nil t)))) - -;;; end of dired-uu.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-vir.el --- a/lisp/efs/dired-vir.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-vir.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Virtual dired mode for browsing ls -lR listings. -;; Author: Sebastian Kremer -;; Created: 7-Mar-1991 16:00 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-vir) -(require 'dired) - -(defun dired-virtual (dirname &optional switches) - "Put this buffer into Virtual Dired mode. - -In Virtual Dired mode, all commands that do not actually consult the -filesystem will work. - -This is useful if you want to peruse and move around in an ls -lR -output file, for example one you got from an ftp server. With -efs, you can even dired a directory containing an ls-lR file, -visit that file and turn on virtual dired mode. But don't try to save -this file, as dired-virtual indents the listing and thus changes the -buffer. - -If you have save a Dired buffer in a file you can use \\[dired-virtual] to -resume it in a later session. - -Type \\\\[revert-buffer] in the -Virtual Dired buffer and answer `y' to convert the virtual to a real -dired buffer again. You don't have to do this, though: you can relist -single subdirs using \\[dired-do-redisplay]. -" - - ;; DIRNAME is the top level directory of the buffer. It will become - ;; its `default-directory'. If nil, the old value of - ;; default-directory is used. - - ;; Optional SWITCHES are the ls switches to use. - - ;; Shell wildcards will be used if there already is a `wildcard' - ;; line in the buffer (thus it is a saved Dired buffer), but there - ;; is no other way to get wildcards. Insert a `wildcard' line by - ;; hand if you want them. - - (interactive - (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir)))) - (goto-char (point-min)) - (or (looking-at " ") - ;; if not already indented, do it now: - (indent-region (point-min) (point-max) 2)) - (or dirname (setq dirname default-directory)) - (setq dirname (expand-file-name (file-name-as-directory dirname))) - (setq default-directory dirname) ; contains no wildcards - (let ((wildcard (save-excursion - (goto-char (point-min)) - (forward-line 1) - (and (looking-at "^ wildcard ") - (buffer-substring (match-end 0) - (progn (end-of-line) (point))))))) - (if wildcard - (setq dirname (expand-file-name wildcard default-directory)))) - ;; If raw ls listing (not a saved old dired buffer), give it a - ;; decent subdir headerline: - (goto-char (point-min)) - (or (looking-at dired-subdir-regexp) - (dired-insert-headerline default-directory)) - (dired-mode dirname (or switches dired-listing-switches)) - (setq mode-name "Virtual Dired" - revert-buffer-function 'dired-virtual-revert) - (set (make-local-variable 'dired-subdir-alist) nil) - (dired-build-subdir-alist) - (goto-char (point-min)) - (dired-insert-set-properties (point-min) (point-max)) - (dired-initial-position dirname)) - -(defun dired-virtual-guess-dir () - - ;; Guess and return appropriate working directory of this buffer, - ;; assumed to be in Dired or ls -lR format. - ;; The guess is based upon buffer contents. - ;; If nothing could be guessed, returns nil. - - (let ((regexp "^\\( \\)?\\([^ \n\r]*\\)\\(:\\)[\n\r]") - (subexpr 2)) - (goto-char (point-min)) - (cond ((looking-at regexp) - ;; If a saved dired buffer, look to which dir and - ;; perhaps wildcard it belongs: - (let ((dir (buffer-substring (match-beginning subexpr) - (match-end subexpr)))) - (file-name-as-directory dir))) - ;; Else no match for headerline found. It's a raw ls listing. - ;; In raw ls listings the directory does not have a headerline - ;; try parent of first subdir, if any - ((re-search-forward regexp nil t) - (file-name-directory - (directory-file-name - (file-name-as-directory - (buffer-substring (match-beginning subexpr) - (match-end subexpr)))))) - (t ; if all else fails - nil)))) - - -(defun dired-virtual-revert (&optional arg noconfirm) - (if (not - (y-or-n-p "Cannot revert a Virtual Dired buffer - switch to Real Dired mode? ")) - (error "Cannot revert a Virtual Dired buffer.") - (setq mode-name "Dired" - revert-buffer-function 'dired-revert) - (revert-buffer))) - -;; A zero-arg version of dired-virtual. -;; You need my modified version of set-auto-mode for the -;; `buffer-contents-mode-alist'. -;; Or you use infer-mode.el and infer-mode-alist, same syntax. -(defun dired-virtual-mode () - "Put current buffer into virtual dired mode (see `dired-virtual'). -Useful on `buffer-contents-mode-alist' (which see) with the regexp - - \"^ \\(/[^ /]+\\)/?+:$\" - -to put saved dired buffers automatically into virtual dired mode. - -Also useful for `auto-mode-alist' (which see) like this: - - \(setq auto-mode-alist (cons '(\"[^/]\\.dired$\" . dired-virtual-mode) - auto-mode-alist)\) -" - (interactive) - (dired-virtual (dired-virtual-guess-dir))) - -;;; end of dired-vir.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-xemacs.el --- a/lisp/efs/dired-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,752 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-xemacs.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: dired functions for XEmacs -;; Author: Mike Sperber -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'dired-xemacs) -(require 'dired) -(require 'dired-faces) - -(require 'backquote) - - -;;; Variables not meant for user editing - -;; kludge -(defun dired-demarkify-regexp (re) - (if (string-equal (substring re 0 (length dired-re-maybe-mark)) - dired-re-maybe-mark) - (concat "^" (substring re - (length dired-re-maybe-mark) - (length re))) - re)) - -(defvar dired-re-raw-dir (dired-demarkify-regexp dired-re-dir)) -(defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym)) -(defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe)) - -(defvar dired-re-raw-boring (dired-omit-regexp) - "Regexp to match backup, autosave and otherwise boring files.") - -(defvar dired-re-raw-socket (concat "^" dired-re-inode-size "s")) - -(defvar dired-re-raw-setuid - (concat "^" dired-re-inode-size - "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]") - "setuid plain file (even if not executable)") - -(defvar dired-re-raw-setgid - (concat "^" dired-re-inode-size - "-[-r][-w][-x][-r][-w][sS][-r][-w][xst]") - "setgid plain file (even if not executable)") - -(defvar dired-re-pre-permissions "^[^-d]? ?[0-9 ]*[-d]" - "Regexp matching the preamble to file permissions part of a dired line. -This shouldn't match socket or symbolic link lines (which aren't editable).") - -(defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-Ssx][-r][-w][-xstT]" - "Regexp matching the file permissions part of a dired line.") - -;;; Setup - -(setq dired-modeline-tracking-cmds '(mouse-track)) - - -;;; Menus - -(defvar dired-subdir-menu nil "The Subdir menu for dired") -(defvar dired-mark-menu nil "The Mark menu for dired") -(defvar dired-do-menu nil "The Do menu for dired") -(defvar dired-regexp-menu nil "The Regexp menu for dired") -(defvar dired-look-menu nil "The Look menu for dired") -(defvar dired-sort-menu nil "The Sort menu for dired") -(defvar dired-help-menu nil "The Help menu for dired") - -(defvar dired-menubar-menus - '(("Subdir" . dired-subdir-menu) - ("Mark" . dired-mark-menu) - ("Do" . dired-do-menu) - ("Regexp" . dired-regexp-menu) - ("Look" . dired-look-menu) - ("Sort" . dired-sort-menu)) - "All the dired menus.") - -(defvar dired-visit-popup-menu nil "The Visit popup for dired") -(defvar dired-do-popup-menu nil "The Do popup for dired") - -(defun dired-setup-menus () - (setq - dired-visit-popup-menu - '(["Find File" dired-find-file t] - ["Find in Other Window" dired-find-file-other-window t] - ["Find in Other Frame" dired-find-file-other-frame t] - ["View File" dired-view-file t] - ["Display in Other Window" dired-display-file t])) - - (setq - dired-do-popup-menu - '(["Copy to..." dired-do-copy t] - ["Rename to..." dired-do-rename t] - ["Compress/Uncompress" dired-do-compress t] - ["Uuencode/Uudecode" dired-do-uucode t] - ["Change Mode..." dired-do-chmod t] - ["Change Owner..." dired-do-chown t] - ["Change Group..." dired-do-chgrp t] - ["Load" dired-do-load t] - ["Byte-compile" dired-do-byte-compile t] - ["Hardlink to..." dired-do-hardlink t] - ["Symlink to..." dired-do-symlink t] - ["Shell Command..." dired-do-shell-command t] - ["Background Shell Command..." dired-do-background-shell-command t] - ["Delete" dired-do-delete t])) - - (setq - dired-subdir-menu - (list - ["Next Subdir" dired-next-subdir t] - ["Prev Subdir" dired-prev-subdir t] - ["Next Dirline" dired-next-dirline t] - ["Prev Dirline" dired-prev-dirline t] - ["Up Dir" dired-up-directory t] - ["Down Dir" dired-down-directory t] - ["Insert This Subdir" dired-maybe-insert-subdir t] - ["Create Directory..." dired-create-directory t] - ["Kill This Subdir" dired-kill-subdir t] - "-- Commands on All Files in Subdir --" - ["Redisplay Subdir" dired-redisplay-subdir t] - ["Mark Files" dired-mark-subdir-files t] - ["Flag Files for Deletion" dired-flag-subdir-files t] - ["Compress Uncompressed Files" dired-compress-subdir-files t] - (vector "Uncompress Compressed Files" - '(let ((current-prefix-arg t)) - (dired-compress-subdir-files)) - ':keys (dired-key-description 'dired-compress-subdir-files - 'universal-argument)))) - - (setq - dired-mark-menu - (list - ["Next Marked" dired-next-marked-file t] - ["Previous Marked" dired-prev-marked-file t] - ["Change Marks..." dired-change-marks t] - ["Unmark All" dired-unmark-all-files t] - (vector "Toggle marks..." - '(let ((current-prefix-arg t)) - (call-interactively 'dired-change-marks)) - ':keys (dired-key-description 'dired-change-marks - 'universal-argument)) - ["Mark Symlinks" dired-mark-symlinks t] - ["Mark Directories" dired-mark-directories t] - ["Mark Old Backups" dired-clean-directory t] - ["Mark Executables" dired-mark-executables t] - ["Flag Backup Files" dired-flag-backup-files t] - ["Flag Auto-save Files" dired-flag-auto-save-files t] - ["Set new marker char" dired-set-marker-char t] - ["Restore marker char" dired-restore-marker-char t] - ["Marker stack left" dired-marker-stack-left t] - ["Marker stack right" dired-marker-stack-right t] - "---" - ["Mark Files from Other Dired" dired-mark-files-from-other-dired-buffer t] - ["Mark Files from Compile Buffer..." dired-mark-files-compilation-buffer t])) - - (setq - dired-do-menu - '(["Copy to..." dired-do-copy t] - ["Rename to..." dired-do-rename t] - ["Expunge File Flagged for Deletion" dired-expunge-deletions t] - ["Compress/Uncompress" dired-do-compress t] - ["Uuencode/Uudecode" dired-do-uucode t] - ["Print..." dired-do-print t] - ["Change Mode..." dired-do-interactive-chmod t] - ["Change Owner..." dired-do-chown t] - ["Change Group..." dired-do-chgrp t] - ["Byte-compile" dired-do-byte-compile t] - ["Hardlink to..." dired-do-hardlink t] - ["Symlink to..." dired-do-symlink t] - ["Shell Command..." dired-do-shell-command t] - ["Background Shell Command..." dired-do-background-shell-command t] - ["Delete Marked Files" dired-do-delete t] - ["Visit file menu >" dired-visit-popup-menu-internal t] - ["Operate on file menu >" dired-do-popup-menu-internal t])) - - (setq - dired-regexp-menu - (list - ["Mark..." dired-mark-files-regexp t] - ["Mark Files with Extension..." dired-mark-extension t] - ["Flag..." dired-flag-files-regexp t] - ["Flag Files with Extension..." dired-flag-extension t] - ["Downcase" dired-downcase t] - ["Upcase" dired-upcase t] - ["Copy..." dired-do-copy-regexp t] - ["Rename..." dired-do-rename-regexp t] - ["Hardlink..." dired-do-hardlink-regexp t] - ["Symlink..." dired-do-symlink-regexp t] - ["Relative Symlink..." dired-do-relsymlink-regexp t] - "---" - ["Add Omit Regex..." dired-add-omit-regexp t] - (vector "Remove Omit Regex..." - '(let ((current-prefix-arg 1)) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp 1)) - (vector "Add Omit Extension..." - '(let ((current-prefix-arg '(4))) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp 'universal-argument)) - (vector "Remove Omit Extension..." - '(let ((current-prefix-arg '(16))) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp - 'universal-argument 'universal-argument)) - (vector "Show Omit Regex" - '(let ((current-prefix-arg 0)) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp 0)))) - - (setq - dired-look-menu - '(["Grep for..." dired-do-grep t] - ["Tags Search for..." dired-do-tags-search t] - ["Tags Query Replace..." dired-do-tags-query-replace t] - "---" - ["Diff File..." dired-diff t] - ["Diff with Backup" dired-backup-diff t] - ["Merge Files..." dired-emerge t] - ["Merge Files Having Common Ancestor..." dired-emerge-with-ancestor t] - ["Ediff Files..." dired-ediff t] - ["Patch File" dired-epatch t])) - - (setq - dired-sort-menu - (list - ["Toggle Current Subdir by Name/Date" dired-sort-toggle-or-edit t] - (vector "Show Current Switches" - '(dired-sort-toggle-or-edit 0) - ':keys (dired-key-description 'dired-sort-toggle-or-edit 0)) - (vector "Edit Switches for Current Subdir..." - '(dired-sort-toggle-or-edit 1) - ':keys (dired-key-description 'dired-sort-toggle-or-edit 1)) - (vector "Edit Default Switches for Inserted Subdirs..." - '(dired-sort-toggle-or-edit 2) - ':keys (dired-key-description 'dired-sort-toggle-or-edit 2)) - (vector "Sort Entire Buffer by Date" - '(dired-sort-toggle-or-edit 'date) - ':keys (dired-key-description 'dired-sort-toggle-or-edit - 'universal-argument)) - (vector "Sort Entire Buffer by Name" - '(dired-sort-toggle-or-edit 'name) - ':keys (dired-key-description 'dired-sort-toggle-or-edit - 'universal-argument)) - (vector "Edit Switches for Entire Buffer..." - '(dired-sort-toggle-or-edit '(16)) - ':keys (dired-key-description 'dired-sort-toggle-or-edit - 'universal-argument)) - "---" - ["Hide All Subdirs" dired-hide-all t] - ["Hide Subdir" dired-hide-subdir t] - ["Toggle Omit" dired-omit-toggle t] - ["Kill Marked Lines" dired-do-kill-file-lines t] - (vector "Redisplay Killed Lines" - '(dired-do-kill-file-lines 0) - ':keys (dired-key-description 'dired-do-kill-file-lines "0")))) - (setq - dired-help-menu - (list - ["Dired Summary Help" dired-summary t] - ["Describe Dired" dired-describe-mode t] - (vector "Dired Info Manual" - '(dired-describe-mode t) - ':keys (dired-key-description 'dired-describe-mode - 'universal-argument)) - ["Dired Command Apropos" dired-apropos t] - (vector "Dired Variable Apropos" - '(let ((current-prefix-arg t)) - (call-interactively 'dired-apropos)) - ':keys (dired-key-description 'dired-apropos 'universal-argument)) - ["Report Dired Bug" dired-report-bug t]))) - -(defun dired-install-menubar () - "Installs the Dired menu at the menubar." - (if (null dired-help-menu) - (dired-setup-menus)) - (if (and (featurep 'menubar) current-menubar) - (progn - (let ((buffer-menubar (copy-sequence current-menubar))) - (delete (assoc "Edit" buffer-menubar) buffer-menubar) - (set-buffer-menubar buffer-menubar) - (mapcar - (function - (lambda (pair) - (let ((name (car pair)) - (menu (symbol-value (cdr pair)))) - (add-submenu nil (cons name menu))))) - dired-menubar-menus)) - (add-menu-button '("Help") (list "---")) - (add-submenu '("Help") (cons "Dired" dired-help-menu))))) - -(add-hook 'dired-mode-hook 'dired-install-menubar) - -;;; Mouse functions - -(defun dired-mouse-file-action (event fun) - "In dired, apply function FUN to the file or directory name you click on." - (save-excursion - (set-buffer (window-buffer (event-window event))) - (if dired-subdir-alist - (save-excursion - (goto-char (event-point event)) - (funcall fun)) - (error - (concat "dired-subdir-alist seems to be mangled. " - (substitute-command-keys - "\\Try dired-revert (\\[dired-revert]).")))))) - -(defun dired-mouse-find-file (event) - "In dired, visit the file or directory name you click on." - (interactive "e") - (dired-mouse-file-action event 'dired-find-file)) - -(defun dired-mouse-display-file (event) - "In dired, display the file or directory name you click on." - (interactive "e") - (dired-mouse-file-action event 'dired-display-file)) - -(defun dired-mouse-find-file-other-window (event) - "In dired, visit the file or directory name you click on in another window." - (interactive "e") - (dired-mouse-file-action event 'dired-find-file-other-window)) - -(defun dired-mouse-find-file-other-frame (event) - "In dired, visit the file or directory name you click on in another frame." - (interactive "e") - (dired-mouse-file-action event 'dired-find-file-other-frame)) - -(defun dired-mouse-mark (event) - "In dired, mark the file name that you click on. -If the file name is already marked, this unmarks it." - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (if dired-subdir-alist - (save-excursion - (goto-char (event-point event)) - (beginning-of-line) - (if (looking-at dired-re-mark) - (dired-unmark 1) - (dired-mark 1))) - (error - (concat "dired-subdir-alist seems to be mangled. " - (substitute-command-keys - "\\Try dired-revert (\\[dired-revert]).")))))) - -(defun dired-mouse-flag (event) - "In dired, flag for deletion the file name that you click on. -If the file name is already flag, this unflags it." - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (if dired-subdir-alist - (save-excursion - (goto-char (event-point event)) - (beginning-of-line) - (if (char-equal (following-char) dired-del-marker) - (dired-unflag 1) - (dired-flag-file-deletion 1))) - (error - (concat "dired-subdir-alist seems to be mangled. " - (substitute-command-keys - "\\Try dired-revert (\\[dired-revert]).")))))) - -(defun dired-mouse-get-target (event) - "In dired, put a copy of the selected directory in the active minibuffer." - (interactive "e") - (let ((obuff (current-buffer)) - mb) - (set-buffer (window-buffer (event-window event))) - (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window))) - (let (dir) - (goto-char (event-point event)) - (setq dir (dired-current-directory)) - (select-window mb) - (set-buffer (window-buffer mb)) - (erase-buffer) - (insert dir)) - (set-buffer obuff) - (if mb - (error "No directory specified") - (error "No active minibuffer"))))) - -(defun dired-visit-popup-menu (event) - "Popup a menu to visit the moused file." - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (save-excursion - (goto-char (event-point event)) - (dired-visit-popup-menu-internal event)))) - -(defun dired-visit-popup-menu-internal (event) - (interactive "e") - (let ((fn (dired-get-filename 'no-dir))) - (popup-menu - (cons (concat "Visit " fn " with") dired-visit-popup-menu)) - ;; this looks like a kludge to me ... - (while (popup-up-p) - (dispatch-event (next-event))))) - -(defun dired-do-popup-menu (event) - "Pop up a menu to do an operation on the moused file." - (interactive "e") - (let ((obuff (current-buffer))) - (unwind-protect - (progn - (set-buffer (window-buffer (event-window event))) - (dired-save-excursion - (goto-char (event-point event)) - (dired-do-popup-menu-internal event))) - (set-buffer obuff)))) - -(defun dired-do-popup-menu-internal (event) - (interactive "e") - (let ((fn (dired-get-filename 'no-dir)) - (current-prefix-arg 1)) - (popup-menu - (cons (concat "Do operation on " fn) dired-do-popup-menu)) - (while (popup-up-p) - (dispatch-event (next-event))))) - -(defvar dired-filename-local-map - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'dired-filename-local-map) - (define-key map [button2] 'dired-mouse-find-file) - (define-key map [(shift button2)] 'dired-mouse-display-file) - (define-key map [(meta button2)] 'dired-mouse-find-file-other-frame) - (define-key map [button3] 'dired-visit-popup-menu) - (define-key map [(control button2)] 'dired-do-popup-menu) - (define-key map [(shift button1)] 'dired-mouse-mark) - (define-key map [(control shift button1)] 'dired-mouse-flag) - map) - "Keymap used to activate actions on files in dired.") - -;; Make this defined everywhere in the dired buffer. -(define-key dired-mode-map '(meta button3) 'dired-mouse-get-target) - -;;; Extent managment - -(defun dired-set-text-properties (start end &optional face) - (let ((filename-extent (make-extent start end))) - (set-extent-face filename-extent (or face 'default)) - (set-extent-property filename-extent 'dired-file-name t) - (set-extent-property filename-extent 'start-open t) - (set-extent-property filename-extent 'end-open t) - (set-extent-property filename-extent 'keymap dired-filename-local-map) - (set-extent-property filename-extent 'highlight t) - (set-extent-property - filename-extent 'help-echo - (concat - "button2 finds, button3 visits, " - "C-button2 file ops, [C-]shift-button1 marks/flags.")) - filename-extent)) - -(defun dired-insert-set-properties (beg end) - ;; Sets the extents for the file names and their properties - (save-excursion - (goto-char beg) - (beginning-of-line) - (let ((eol (save-excursion (end-of-line) (point))) - (bol (point)) - start) - (while (< (point) end) - (setq eol (save-excursion (end-of-line) (point))) - - (if dired-do-interactive-permissions - (dired-make-permissions-interactive (point))) - - (if (dired-manual-move-to-filename nil bol eol) - (progn - (setq start (point)) - (dired-manual-move-to-end-of-filename nil bol eol) - (dired-set-text-properties - start - (point) - (save-excursion - (beginning-of-line) - (cond - ((null dired-do-highlighting) nil) - ((looking-at dired-re-raw-dir) 'dired-face-directory) - ((looking-at dired-re-raw-sym) 'dired-face-symlink) - ((or (looking-at dired-re-raw-setuid) - (looking-at dired-re-raw-setgid)) 'dired-face-setuid) - ((looking-at dired-re-raw-exe) 'dired-face-executable) - ((looking-at dired-re-raw-socket) 'dired-face-socket) - ((save-excursion - (goto-char start) - (re-search-forward dired-re-raw-boring eol t)) - 'dired-face-boring)))))) - - (setq bol (1+ eol)) - (goto-char bol))))) - -(defun dired-remove-text-properties (start end) - ;; Removes text properties. Called in popup buffers. - (map-extents - (function - (lambda (extent maparg) - (if (extent-property extent 'dired-file-name) - (delete-extent extent)) - nil)) - nil start end)) - -(defun dired-highlight-filename-mark (extent) - (let ((mark - (save-excursion - (skip-chars-backward "^\n\r") - (following-char))) - (face (extent-face extent))) - (if (char-equal mark ?\ ) - (if (consp face) - (set-extent-face extent (cadr face))) - (let ((new-face - (cond - ((char-equal dired-default-marker mark) - 'dired-face-marked) - ((char-equal dired-del-marker mark) - 'dired-face-flagged) - (t 'default)))) - (set-extent-face - extent - (if (consp face) - (list new-face (cadr face)) - (list new-face face))))))) - -(defun dired-move-to-filename (&optional raise-error bol eol) - (or bol (setq bol (save-excursion - (skip-chars-backward "^\n\r") - (point)))) - (or eol (setq eol (save-excursion - (skip-chars-forward "^\n\r") - (point)))) - (goto-char bol) - (let ((extent - (map-extents - (function - (lambda (extent maparg) - (if (extent-property extent 'dired-file-name) - extent - nil))) - nil bol eol))) - (if extent - (progn - (if dired-do-highlighting - (dired-highlight-filename-mark extent)) - (goto-char (extent-start-position extent))) - (if raise-error - (error "No file on this line") - nil)))) - - -(defun dired-move-to-end-of-filename (&optional no-error bol eol) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* - ;; line if at all. So, it should be called only after - ;; (dired-move-to-filename t). - ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (and - (null no-error) - selective-display - (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) - (eq (char-after (1- bol)) ?\r) - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (let ((filename-extent (map-extents - (function - (lambda (e p) (and (extent-property e p) e))) - (current-buffer) bol eol 'dired-file-name))) - (if filename-extent - (goto-char (extent-end-position filename-extent)) - (and (null no-error) (error "No file on this line"))))) - -;;; Interactive chmod -;;; (based on ideas from Russell Ritchie's dired-chmod.el) - -(defun dired-do-interactive-chmod (new-attribute) - (let* ((file (dired-get-filename)) - (operation (concat "chmod " new-attribute " " file)) - (failure (apply (function dired-check-process) - operation - "chmod" new-attribute (list file)))) - (dired-do-redisplay) - (if failure - (dired-log-summary (buffer-name (current-buffer)) - (format "%s: error" operation) nil) - (forward-char 1)))) - -(defun dired-chmod-popup-menu (event menu) - (save-excursion - (set-buffer (window-buffer (event-window event))) - (save-excursion - (goto-char (event-point event)) - (popup-menu menu) - ;; this looks like a kludge to me ... - (while (popup-up-p) - (dispatch-event (next-event)))))) - -;; This is probably overdoing it. -;; Someone give me lexical scoping here ... - -(defun dired-setup-chmod-keymap (domain id keys &optional toggle-keys) - (let* ((names - (mapcar - (function - (lambda (key) - (let ((name (intern (concat "dired-" - (list domain ?- key))))) - (eval - `(defun ,name () - (interactive) - (dired-do-interactive-chmod ,(concat (list domain ?+ key))))) - name))) - keys)) - (prefix (concat "dired-" (list domain) "-" (list id))) - (remove-name (intern (concat prefix "-remove"))) - (toggle-name (intern (concat prefix "-toggle"))) - (mouse-toggle-name (intern (concat prefix "-mouse-toggle"))) - (mouse-menu-name (intern (concat prefix "-menu")))) - - (eval - `(defun ,remove-name () - (interactive) - (cond ,@(mapcar (function - (lambda (key) - `((looking-at ,(regexp-quote (char-to-string key))) - (dired-do-interactive-chmod - ,(concat (list domain ?- key)))))) - keys)))) - - (eval - `(defun ,toggle-name () - (interactive) - (cond ((looking-at "-") (dired-do-interactive-chmod - ,(concat (list domain ?+ (car keys))))) - ,@(let ((l (or toggle-keys keys)) - (c '())) - (while l - (setq c - (cons - `((looking-at (regexp-quote (char-to-string ,(car l)))) - (dired-do-interactive-chmod - ,(if (null (cdr l)) - (concat (list domain ?- (car l))) - (concat (list domain ?+ (cadr l)))))) - c)) - (setq l (cdr l))) - (reverse c)) - (t (dired-do-interactive-chmod - ,(concat (list domain ?+ (car keys)))))))) - - (eval - `(defun ,mouse-toggle-name (event) - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (save-excursion - (goto-char (event-point event)) - (,toggle-name))))) - - (let ((menu '()) - (loop-keys keys) - (loop-names names)) - (while loop-keys - (setq menu - (cons (vector (concat (list ?+ (car loop-keys))) - (car loop-names) - t) - menu)) - (setq loop-keys (cdr loop-keys) - loop-names (cdr loop-names))) - (setq menu (append menu (list (vector "Toggle" toggle-name t) - (vector "Clear" remove-name t)))) - (setq menu (cons (char-to-string domain) menu)) - - (eval - `(defun ,mouse-menu-name (event) - (interactive "e") - (dired-chmod-popup-menu event ',menu)))) - - (let ((keymap (make-sparse-keymap))) - (let ((loop-keys (cons ?. (cons ?- keys))) - (loop-names (cons toggle-name (cons remove-name names)))) - (while loop-keys - (define-key keymap (car loop-keys) (car loop-names)) - (setq loop-keys (cdr loop-keys) - loop-names (cdr loop-names)))) - - (define-key keymap 'button2 mouse-toggle-name) - (define-key keymap 'button3 mouse-menu-name) - keymap))) - -(defvar dired-u-r-keymap nil "internal keymap for dired") -(defvar dired-u-w-keymap nil "internal keymap for dired") -(defvar dired-u-x-keymap nil "internal keymap for dired") -(defvar dired-g-r-keymap nil "internal keymap for dired") -(defvar dired-g-w-keymap nil "internal keymap for dired") -(defvar dired-g-x-keymap nil "internal keymap for dired") -(defvar dired-o-r-keymap nil "internal keymap for dired") -(defvar dired-o-w-keymap nil "internal keymap for dired") -(defvar dired-o-x-keymap nil "internal keymap for dired") - - -(defun dired-setup-chmod-keymaps () - (setq - dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r)) - dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w)) - dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?x ?s) '(?x)) - dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r)) - dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w)) - dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?x ?s) '(?x)) - dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r)) - dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w)) - dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?x ?s ?t) '(?x)))) - -(defun dired-make-permissions-interactive (beg) - (save-excursion - (goto-char beg) - (buffer-substring (point) (save-excursion (end-of-line) (point))) - (if (and (re-search-forward dired-re-pre-permissions - (save-excursion (end-of-line) (point)) - t) - (looking-at dired-re-permissions)) - (let ((p (point))) - (dired-activate-permissions (make-extent p (+ 1 p)) dired-u-r-keymap) - (dired-activate-permissions (make-extent (+ 1 p) (+ 2 p)) dired-u-w-keymap) - (dired-activate-permissions (make-extent (+ 2 p) (+ 3 p)) dired-u-x-keymap) - (dired-activate-permissions (make-extent (+ 3 p) (+ 4 p)) dired-g-r-keymap) - (dired-activate-permissions (make-extent (+ 4 p) (+ 5 p)) dired-g-w-keymap) - (dired-activate-permissions (make-extent (+ 5 p) (+ 6 p)) dired-g-x-keymap) - (dired-activate-permissions (make-extent (+ 6 p) (+ 7 p)) dired-o-r-keymap) - (dired-activate-permissions (make-extent (+ 7 p) (+ 8 p)) dired-o-w-keymap) - (dired-activate-permissions (make-extent (+ 8 p) (+ 9 p)) dired-o-x-keymap))))) - -(defun dired-activate-permissions (extent keymap) - (set-extent-face extent 'dired-face-permissions) - (set-extent-property extent 'keymap keymap) - (set-extent-property extent 'highlight t) - (set-extent-property - extent 'help-echo - "button2 toggles, button3 changes otherwise.")) - -(dired-setup-chmod-keymaps) - -;;; end of dired-xemacs.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired-xy.el --- a/lisp/efs/dired-xy.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-xy.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for reading mail from dired. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-xy) -(require 'dired) - -;;; Special request: Will an mh-e user please write some mh support in here? - -(defun dired-read-mail (&optional arg) - "Reads the current file as a mail folder. -Uses the setting of `dired-mail-reader' to determine which reader to use. -Possibilities are VM or RMAIL. With a prefix arg, visits the folder read-only\; -this only works with VM." - (interactive "P") - (cond - ((eq dired-mail-reader 'vm) - (dired-vm arg)) - ((eq dired-mail-reader 'rmail) - (dired-rmail)) ; doesn't take read-only arg. - (t (error "Never heard of the mail reader %s" dired-mail-reader)))) - -;; Read-only folders only work in VM 5, not in VM 4. -(defun dired-vm (&optional read-only) - "Run VM on this file. -With prefix arg, visit folder read-only (this requires at least VM 5). -See also variable `dired-vm-read-only-folders'." - (interactive "P") - (let ((dir (dired-current-directory)) - (fil (dired-get-filename))) - ;; take care to supply 2nd arg only if requested - may still run VM 4! - (require 'vm) ; vm-visit-folder may not be an autoload - (setq this-command 'vm-visit-folder) ; for vm window config - (if read-only - (vm-visit-folder fil t) - (vm-visit-folder fil)) - ;; so that pressing `v' inside VM does prompt within current directory: - (set (make-local-variable 'vm-folder-directory) dir))) - -(defun dired-rmail () - "Run RMAIL on this file." - (interactive) - (rmail (dired-get-filename))) - -;; end of dired-xy.el - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/dired.el --- a/lisp/efs/dired.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6470 +0,0 @@ - ; -*- Emacs-Lisp -*- -;; DIRED commands for Emacs. -;; Copyright (C) 1985, 1986, 1991 Free Software Foundation, Inc. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: The DIRectory EDitor is for manipulating, and running -;; commands on files in a directory. -;; Authors: FSF, -;; Sebastian Kremer , -;; Sandy Rutherford -;; Cast of thousands... -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;; Rewritten in 1990/1991 to add tree features, file marking and -;; sorting by Sebastian Kremer . -;; 7-1993: Added special features for efs interaction and upgraded to Emacs 19. -;; Sandy Rutherford - -;;; Dired Version - -(defconst dired-version (substring "#Revision: 7.9 $" 11 -2) - "The revision number of Tree Dired (as a string). - -Don't forget to mention this when reporting bugs to: - - efs-bugs@cuckoo.hpl.hp.com") - -;; Global key bindings: -;; -------------------- -;; -;; By convention, dired uses the following global key-bindings. -;; These may or may not already be set up in your local emacs. If not -;; then you will need to add them to your .emacs file, or the system -;; default.el file. We don't set them automatically here, as users may -;; have individual preferences. -;; -;; (define-key ctl-x-map "d" 'dired) -;; (define-key ctl-x-4-map "d" 'dired-other-window) -;; (define-key ctl-x-map "\C-j" 'dired-jump-back) -;; (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) -;; -;; For V19 emacs only. (Make sure that the ctl-x-5-map exists.) -;; (define-key ctl-x-5-map "d" 'dired-other-frame) -;; (define-key Ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) - - -;;; Grok the current emacs version -;; -;; Hopefully these two variables provide us with enough version sensitivity. - -;; Make sure that we have a frame-width function -(or (fboundp 'frame-width) (fset 'frame-width 'screen-width)) - -;;; Requirements and provisions - -(provide 'dired) -(require 'backquote) ; For macros. - -;; Compatibility requirements for the file-name-handler-alist. -;; Testing against the string `Lucid' breaks InfoDock. How many years has -;; it been since Lucid went away? -(let ((lucid-p (string-match "XEmacs" emacs-version)) - ver subver) - (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) - (error "dired does not work with emacs version %s" emacs-version)) - (setq ver (string-to-int (substring emacs-version (match-beginning 1) - (match-end 1))) - subver (string-to-int (substring emacs-version (match-beginning 2) - (match-end 2)))) - (cond - ((= ver 18) - (require 'emacs-19) - (require 'fn-handler)) - ((and (= ver 19) (if lucid-p (< subver 10) (< subver 23))) - (require 'fn-handler)) - ((< ver 18) - (error "dired does not work with emacs version %s" emacs-version)))) - -;; We duplicate default-dir stuff to avoid its overwrites unless -;; they are explicitly requested. - -(defvar default-directory-function nil - "A function to call to compute the default-directory for the current buffer. -If this is nil, the function default-directory will return the value of the -variable default-directory. -Buffer local.") -(make-variable-buffer-local 'default-directory-function) - -;;;###autoload -(defun default-directory () - " Returns the default-directory for the current buffer. -Will use the variable default-directory-function if it non-nil." - (if default-directory-function - (funcall default-directory-function) - (if (string-match "XEmacs" emacs-version) - (abbreviate-file-name default-directory t) - (abbreviate-file-name default-directory)))) - -;;;;---------------------------------------------------------------- -;;;; Customizable variables -;;;;---------------------------------------------------------------- -;; -;; The funny comments are for autoload.el, to automagically update -;; loaddefs. - -;;; Variables for compressing files. - -;;;###autoload -(defvar dired-compression-method 'compress - "*Type of compression program to use. -Give as a symbol. -Currently-recognized methods are: gzip pack compact compress. -To change this variable use \\[dired-do-compress] with a zero prefix.") - -;;;###autoload -(defvar dired-compression-method-alist - '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") - ;; Put compress before pack, so that it wins out if we are using - ;; efs to work on a case insensitive OS. The -f flag does - ;; two things in compress. No harm in giving it twice. - (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") - ;; pack support may not work well. pack is too chatty and there is no way - ;; to force overwrites. - (pack ".z" ("pack" "-f") ("unpack")) - (compact ".C" ("compact") ("uncompact"))) - - "*Association list of compression method descriptions. - Each element of the table should be a list of the form - - \(compress-type extension (compress-args) (decompress-args) force-flag\) - - where - `compress-type' is a unique symbol in the alist to which - `dired-compression-method' can be set; - `extension' is the file extension (as a string) used by files compressed - by this method; - `compress-args' is a list of the path of the compression program and - flags to pass as separate arguments; - `decompress-args' is a list of the path of the decompression - program and flags to pass as separate arguments. - `force-flag' is the switch to pass to the command to force overwriting - of existing files. - - For example: - - \(setq dired-compression-method-alist - \(cons '\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\) \"-f\"\) - dired-compression-method-alist\)\) - => \(\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\)\) - \(gzip \".gz\" \(\"gzip\"\) \(\"gunzip\"\)\) - ...\) - - See also: dired-compression-method ") - -;;; Variables for the ls program. - -;;;###autoload -(defvar dired-ls-program "ls" - "*Absolute or relative name of the ls program used by dired.") - -;;;###autoload -(defvar dired-listing-switches "-al" - "*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -(defvar dired-ls-F-marks-symlinks - (memq system-type '(aix-v3 hpux silicon-graphics-unix)) - ;; Both SunOS and Ultrix have system-type berkeley-unix. But - ;; SunOS doesn't mark symlinks, but Ultrix does. Therefore, - ;; can't grok this case. - "*Informs dired about how ls -lF marks symbolic links. -Set this to t if `dired-ls-program' with -lF marks the name of the symbolic -link itself with a trailing @. - -For example: If foo is a link pointing to bar, and \"ls -F bar\" gives - - ... bar -> foo - -set this variable to nil. If it gives - - ... bar@ -> foo - -set this variable to t. - -Dired checks if there is really a @ appended. Thus, if you have a -marking ls program on one host and a non-marking on another host, and -don't care about symbolic links which really end in a @, you can -always set this variable to t. - -If you use efs, it will make this variable buffer-local, and control -it according to its assessment of how the remote host marks symbolic -links.") - -(defvar dired-show-ls-switches nil - "*If non-nil dired will show the dired ls switches on the modeline. -If nil, it will indicate how the files are sorted by either \"by name\" or -\"by date\". If it is unable to recognize the sorting defined by the switches, -then the switches will be shown explicitly on the modeline, regardless of the -setting of this variable.") - -;;; Variables for other unix utility programs. - -;; For most program names, don't use absolute paths so that dired -;; uses the user's value of the environment variable PATH. chown is -;; an exception as it is not always in the PATH. - -;;;###autoload -(defvar dired-chown-program - (if (memq system-type '(hpux dgux usg-unix-v linux)) "chown" "/etc/chown") - "*Name of chown command (usually `chown' or `/etc/chown').") - -;;;###autoload -(defvar dired-gnutar-program nil - "*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") - -;;;###autoload -(defvar dired-unshar-program nil - "*Set to the name of the unshar program, if you have it.") - -;;; Markers - -(defvar dired-keep-marker-rename t - ;; Use t as default so that moved files `take their markers with them' - "*Controls marking of renamed files. -If t, files keep their previous marks when they are renamed. -If a character, renamed files (whether previously marked or not) -are afterward marked with that character.") - -(defvar dired-keep-marker-compress t - "*Controls marking of compressed or uncompressed files. -If t, files keep their previous marks when they are compressed. -If a character, compressed or uncompressed files (whether previously -marked or not) are afterward marked with that character.") - -(defvar dired-keep-marker-uucode ?U - "*Controls marking of uuencoded or uudecoded files. -If t, files keep their previous marks when they are uuencoded. -If a character, uuencoded or uudecoded files (whether previously -marked or not) are afterward marked with that character.") - -(defvar dired-keep-marker-copy ?C - "*Controls marking of copied files. -If t, copied files are marked if and as the corresponding original files were. -If a character, copied files are unconditionally marked with that character.") - -(defvar dired-keep-marker-hardlink ?H - "*Controls marking of newly made hard links. -If t, they are marked if and as the files linked to were marked. -If a character, new links are unconditionally marked with that character.") - -(defvar dired-keep-marker-symlink ?S - "*Controls marking of newly made symbolic links. -If t, they are marked if and as the files linked to were marked. -If a character, new links are unconditionally marked with that character.") - -(defvar dired-keep-marker-kill ?K - "*When killed file lines are redisplayed, they will have this marker. -Setting this to nil means that they will not have any marker.") - -(defvar dired-failed-marker-shell ?! - "*If non-nil, a character with which to mark files of failed shell commands. -Applies to the command `dired-do-shell-command'. Files for which the shell -command has a nonzero exit status will be marked with this character") - -;;; Behavioral Variables - -;;;###autoload -(defvar dired-local-variables-file ".dired" - "*If non-nil, filename for local variables for Dired. -If Dired finds a file with that name in the current directory, it will -temporarily insert it into the dired buffer and run `hack-local-variables'. - -Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on -local variables.") - -;; Usually defined in files.el. Define here anyway, to be safe. -;;;###autoload -(defvar dired-kept-versions 2 - "*When cleaning directory, number of versions to keep.") - -;;;###autoload -(defvar dired-find-subdir nil - "*Determines whether dired tries to lookup a subdir in existing buffers. -If non-nil, dired does not make a new buffer for a directory if it can be -found (perhaps as subdir) in some existing dired buffer. If there are several -dired buffers for a directory, then the most recently used one is chosen. - -Dired avoids switching to the current buffer, so that if you have -a normal and a wildcard buffer for the same directory, C-x d RET will -toggle between those two.") - -;;;###autoload -(defvar dired-use-file-transformers t - "*Determines whether dired uses file transformers. -If non-nil `dired-do-shell-command' will apply file transformers to file names. -See \\[describe-function] for dired-do-shell-command for more information.") - -;;;###autoload -(defvar dired-dwim-target nil - "*If non-nil, dired tries to guess a default target directory. -This means that if there is a dired buffer displayed in the next window, -use its current subdir, instead of the current subdir of this dired buffer. -The target is put in the prompt for file copy, rename, etc.") - -;;;###autoload -(defvar dired-copy-preserve-time nil - "*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\ -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -;;;###autoload -(defvar dired-no-confirm nil - "*If non-nil, a list of symbols for commands dired should not confirm. -It can be a sublist of - - '(byte-compile chgrp chmod chown compress copy delete hardlink load - move print shell symlink uncompress recursive-delete kill-file-buffer - kill-dired-buffer patch create-top-dir revert-subdirs) - -The meanings of most of the symbols are obvious. A few exceptions: - - 'compress applies to compression or decompression by any of the - compression program in `dired-compression-method-alist'. - - 'kill-dired-buffer applies to offering to kill dired buffers for - directories which have been deleted. - - 'kill-file-buffer applies to offering to kill buffers visiting files - which have been deleted. - - 'recursive-delete applies to recursively deleting non-empty - directories, and all of their contents. - - 'create-top-dir applies to `dired-up-directory' creating a new top level - directory for the dired buffer. - - 'revert-subdirs applies to re-reading subdirectories which have - been modified on disk. - -Note that this list also applies to remote files accessed with efs -or ange-ftp.") - -;;;###autoload -(defvar dired-backup-if-overwrite nil - "*Non-nil if Dired should ask about making backups before overwriting files. -Special value 'always suppresses confirmation.") - -;;;###autoload -(defvar dired-omit-files nil - "*If non-nil un-interesting files will be omitted from this dired buffer. -Use \\[dired-omit-toggle] to see these files. (buffer local)") -(make-variable-buffer-local 'dired-omit-files) - -;;;###autoload -(defvar dired-mail-reader 'vm - "*Mail reader used by dired for dired-read-mail \(\\[dired-read-mail]\). -The symbols 'rmail and 'vm are the only two allowed values.") - -(defvar dired-verify-modtimes t - "*If non-nil dired will revert dired buffers for modified subdirectories. -See also dired-no-confirm .") - -;;;###autoload -(defvar dired-refresh-automatically t - "*If non-nil, refresh dired buffers automatically after file operations.") - -;;; File name regular expressions and extensions. - -(defvar dired-trivial-filenames "\\`\\.\\.?\\'\\|\\`#" - "*Regexp of files to skip when finding first file of a directory listing. -A value of nil means move to the subdir line. -A value of t means move to first file.") - -(defvar dired-cleanup-alist - (list - '("tex" ".toc" ".log" ".aux" ".dvi") - '("latex" ".toc" ".log" ".aux" ".idx" ".lof" ".lot" ".glo" ".dvi") - '("bibtex" ".blg" ".bbl") - '("texinfo" ".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" - ".tp" ".tps" ".vr" ".vrs") - '("patch" ".rej" ".orig") - '("backups" "~") - (cons "completion-ignored-extensions" completion-ignored-extensions)) - "*Alist of extensions for temporary files created by various programs. -Used by `dired-cleanup'.") - -(defvar dired-omit-extensions - (let ((alist dired-cleanup-alist) - x result) - (while alist - (setq x (cdr (car alist)) - alist (cdr alist)) - (while x - (or (member (car x) result) - (setq result (cons (car x) result))) - (setq x (cdr x)))) - result) - "*List of extensions for file names that will be omitted (buffer-local). -This only has effect when the subdirectory is in omission mode. -To make omission mode the default, set `dired-omit-files' to t. -See also `dired-omit-extensions'.") -(make-variable-buffer-local 'dired-omit-extensions) - -(defvar dired-omit-regexps '("\\`#" "\\`\\.") - "*File names matching these regexp may be omitted (buffer-local). -This only has effect when the subdirectory is in omission mode. -To make omission mode the default, set `dired-omit-files' to t. -This only has effect when `dired-omit-files' is t. -See also `dired-omit-extensions'.") -(make-variable-buffer-local 'dired-omit-regexps) - -(defvar dired-filename-re-ext "\\..+\\'" ; start from the first dot. last dot? - "*Defines what is the extension of a file name. -\(match-beginning 0\) for this regexp in the file name without directory will -be taken to be the start of the extension.") - -;;; Hook variables - -(defvar dired-load-hook nil - "Run after loading dired. -You can customize key bindings or load extensions with this.") - -(defvar dired-grep-load-hook nil - "Run after loading dired-grep.") - -(defvar dired-mode-hook nil - "Run at the very end of dired-mode.") - -(defvar dired-before-readin-hook nil - "Hook run before a dired buffer is newly read in, created,or reverted.") - -(defvar dired-after-readin-hook nil - "Hook run after each listing of a file or directory. -The buffer is narrowed to the new listing.") - -(defvar dired-setup-keys-hook nil - "Hook run when dired sets up its keymap. -This happens the first time that `dired-mode' is called, and runs after -`dired-mode-hook'. This hook can be used to make alterations to the -dired keymap.") - -;;; Internal variables -;; -;; If you set these, know what you are doing. - -;;; Marker chars. - -(defvar dired-marker-char ?* ; the answer is 42 - ; life the universe and everything - ;; so that you can write things like - ;; (let ((dired-marker-char ?X)) - ;; ;; great code using X markers ... - ;; ) - ;; For example, commands operating on two sets of files, A and B. - ;; Or marking files with digits 0-9. This could implicate - ;; concentric sets or an order for the marked files. - ;; The code depends on dynamic scoping on the marker char. - "In dired, character used to mark files for later commands.") -(make-variable-buffer-local 'dired-marker-char) - -(defconst dired-default-marker dired-marker-char) -;; Stores the default value of dired-marker-char when dynamic markers -;; are being used. - -(defvar dired-del-marker ?D - "Character used to flag files for deletion.") - -;; \017=^O for Omit - other packages can chose other control characters. -(defvar dired-omit-marker-char ?\017) -;; Marker used for omitted files. Shouldn't be used by anything else. - -(defvar dired-kill-marker-char ?\C-k) -;; Marker used by dired-do-kill. Shouldn't be used by anything else. - -;;; State variables - -(defvar dired-mode-line-modified "-%s%s%s-" - "*Format string to show the modification status of the buffer.") - -(defvar dired-del-flags-number 0) -(make-variable-buffer-local 'dired-del-flags-number) -(defvar dired-marks-number 0) -(make-variable-buffer-local 'dired-marks-number) -(defvar dired-other-marks-number 0) -(make-variable-buffer-local 'dired-other-marks-number) - -(defvar dired-marked-files nil - "List of filenames from last `dired-copy-filename-as-kill' call.") - -(defvar dired-directory nil - "The directory name or shell wildcard that was used as argument to `ls'. -Local to each dired buffer. May be a list, in which case the car is the -directory name and the cdr is the actual files to list.") -(make-variable-buffer-local 'dired-directory) - -(defvar dired-internal-switches nil - "The actual (buffer-local) value of `dired-listing-switches'. -The switches are represented as a list of characters.") -(make-variable-buffer-local 'dired-internal-switches) - -(defvar dired-subdir-alist nil - "Association list of subdirectories and their buffer positions. -Each subdirectory has an element: (DIRNAME . STARTMARKER). -The order of elements is the reverse of the order in the buffer.") -(make-variable-buffer-local 'dired-subdir-alist) - -(defvar dired-curr-subdir-min 0) -;; Cache for modeline tracking of the cursor -(make-variable-buffer-local 'dired-curr-subdir-min) - -(defvar dired-curr-subdir-max 0) -;; Cache for modeline tracking of the cursor -(make-variable-buffer-local 'dired-curr-subdir-max) - -(defvar dired-subdir-omit nil) -;; Controls whether the modeline shows Omit. -(make-variable-buffer-local 'dired-subdir-omit) - -(defvar dired-in-query nil) -;; let-bound to t when dired is in the process of querying the user. -;; This is to keep asynch messaging from clobbering the query prompt. - -(defvar dired-overwrite-confirmed nil) -;; Fluid variable used to remember if a bunch of overwrites have been -;; confirmed. - -(defvar dired-overwrite-backup-query nil) -;; Fluid var used to remember if backups have been requested for overwrites. - -(defvar dired-file-creator-query nil) -;; Fluid var to remember responses to file-creator queries. - -(defvar dired-omit-silent nil) -;; This is sometimes let-bound to t if messages would be annoying, -;; e.g., in dired-awrh.el. Binding to 0, only suppresses -;; \"(Nothing to omit)\" message. - -(defvar dired-buffers nil - ;; Enlarged by dired-advertise - ;; Queried by function dired-buffers-for-dir. When this detects a - ;; killed buffer, it is removed from this list. - "Alist of directories and their associated dired buffers.") - -(defvar dired-sort-mode nil - "Whether Dired sorts by name, date, etc. -\(buffer-local\)") -;; This is nil outside dired buffers so it can be used in the modeline -(make-variable-buffer-local 'dired-sort-mode) - -(defvar dired-marker-stack nil - "List of previously used dired marker characters.") -(make-variable-buffer-local 'dired-marker-stack) - -(defvar dired-marker-stack-pointer 0) -;; Points to the current marker in the stack -(make-variable-buffer-local 'dired-marker-stack-pointer) - -(defvar dired-marker-stack-cursor ?\ ; space - "Character to use as a cursor in the dired marker stack.") - -(defconst dired-marker-string "" - "String version of `dired-marker-stack'.") -(make-variable-buffer-local 'dired-marker-string) - -(defvar dired-modeline-tracking-cmds nil) -;; List of commands after which the modeline gets updated. - -;;; Config. variables not usually considered fair game for the user. - -(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p? - -(defvar dired-log-buffer "*Dired log*") -;; Name of buffer used to log dired messages and errors. - -;;; Assoc. lists - -;; For pop ups and user input for file marking -(defvar dired-query-alist - '((?\y . y) (?\040 . y) ; `y' or SPC means accept once - (?n . n) (?\177 . n) ; `n' or DEL skips once - (?! . yes) ; `!' accepts rest - (?q. no) (?\e . no) ; `q' or ESC skips rest - ;; None of these keys quit - use C-g for that. - )) - -(defvar dired-sort-type-alist - ;; alist of sort flags, and the sort type, as a symbol. - ;; Don't put ?r in here. It's handled separately. - '((?t . date) (?S . size) (?U . unsort) (?X . ext))) - -;;; Internal regexps for examining ls listings. -;; -;; Many of these regexps must be tested at beginning-of-line, but are also -;; used to search for next matches, so neither omitting "^" nor -;; replacing "^" by "\n" (to make it slightly faster) will work. - -(defvar dired-re-inode-size "[ \t0-9]*") -;; Regexp for optional initial inode and file size. -;; Must match output produced by ls' -i and -s flags. - -(defvar dired-re-mark "^[^ \n\r]") -;; Regexp matching a marked line. -;; Important: the match ends just after the marker. - -(defvar dired-re-maybe-mark "^. ") - -(defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d")) -;; Matches directory lines - -(defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l")) -;; Matches symlink lines - -(defvar dired-re-exe;; match ls permission string of an executable file - (mapconcat (function - (lambda (x) - (concat dired-re-maybe-mark dired-re-inode-size x))) - '("-[-r][-w][xs][-r][-w].[-r][-w]." - "-[-r][-w].[-r][-w][xs][-r][-w]." - "-[-r][-w].[-r][-w].[-r][-w][xst]") - "\\|")) - -(defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/' -;; . and .. files - -(defvar dired-re-month-and-time - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct\\|Nov\\|" - ; June and July are for HP-UX 9.0 - "Dec\\) [ 0-3][0-9]\\(" - " [012][0-9]:[0-6][0-9] \\|" ; time - " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo, - ; HP-UX, A/UX - " [12][90][0-9][0-9] \\)" ; year on AIX - )) -;; This regexp MUST match all the way to first character of the filename. -;; You can loosen it to taste, but then you might bomb on filenames starting -;; with a space. This will have to be modified for non-english month names. - -(defvar dired-subdir-regexp - "\\([\n\r]\n\\|\\`\\). \\([^\n\r]+\\)\\(:\\)\\(\\.\\.\\.\r\\|[\n\r]\\)") - ;; Regexp matching a maybe hidden subdirectory line in ls -lR output. - ;; Subexpression 2 is the subdirectory proper, no trailing colon. - ;; Subexpression 3 must end right before the \n or \r at the end of - ;; the subdir heading. Matches headings after indentation has been done. - -(defvar dired-unhandle-add-files nil) -;; List of files that the dired handler function need not add to dired buffers. -;; This is because they have already been added, most likely in -;; dired-create-files. This is because dired-create-files add files with -;; special markers. - -;;; history variables - -(defvar dired-regexp-history nil - "History list of regular expressions used in Dired commands.") - -(defvar dired-chmod-history nil - "History of arguments to chmod in dired.") - -(defvar dired-chown-history nil - "History of arguments to chown in dired.") - -(defvar dired-chgrp-history nil - "History of arguments to chgrp in dired.") - -(defvar dired-cleanup-history nil - "History of arguments to dired-cleanup.") - -(defvar dired-goto-file-history nil) -;; History for dired-goto-file and dired-goto-subdir -(put 'dired-goto-file-history 'cursor-end t) ; for gmhist - -(defvar dired-history nil) -;; Catch-all history variable for dired file ops without -;; their own history. - -(defvar dired-op-history-alist - ;; alist of dired file operations and history symbols - '((chgrp . dired-chgrp-history) (chown . dired-chown-history) - (chmod . dired-chmod-history) )) - -;;; Tell the byte-compiler that we know what we're doing. -;;; Do we? - -(defvar file-name-handler-alist) -(defvar inhibit-file-name-operation) -(defvar inhibit-file-name-handlers) -(defvar efs-dired-host-type) - - -;;;;------------------------------------------------------------------ -;;;; Utilities -;;;;------------------------------------------------------------------ - -;;; Macros -;; -;; Macros must be defined before they are used - for the byte compiler. - -(defmacro dired-get-subdir-min (elt) - ;; Returns the value of the subdir minumum for subdir with entry ELT in - ;; dired-subdir-alist. - (list 'nth 1 elt)) - -(defmacro dired-save-excursion (&rest body) - ;; Saves excursions of the point (not buffer) in dired buffers. - ;; It tries to be robust against deletion of the region about the point. - ;; Note that this assumes only dired-style deletions. - (let ((temp-bolm (make-symbol "bolm")) - (temp-fnlp (make-symbol "fnlp")) - (temp-offset-bol (make-symbol "offset-bol"))) - (` (let (((, temp-bolm) (make-marker)) - (, temp-fnlp) (, temp-offset-bol)) - (let ((bol (save-excursion (skip-chars-backward "^\n\r") (point)))) - (set-marker (, temp-bolm) bol) - (setq (, temp-offset-bol) (- (point) bol) - (, temp-fnlp) (memq (char-after bol) '(?\n\ ?\r)))) - (unwind-protect - (progn - (,@ body)) - ;; Use the marker to try to find the right line, then move to - ;; the proper column. - (goto-char (, temp-bolm)) - (and (not (, temp-fnlp)) - (memq (char-after (point)) '(?\n ?\r)) - ;; The line containing the point got deleted. Note that this - ;; logic only works if we don't delete null lines, but we never - ;; do. - (forward-line 1)) ; don't move into a hidden line. - (skip-chars-forward "^\n\r" (+ (point) (, temp-offset-bol)))))))) - -(put 'dired-save-excursion 'lisp-indent-hook 0) - -(defun dired-substitute-marker (pos old new) - ;; Change marker, re-fontify - (subst-char-in-region pos (1+ pos) old new) - (dired-move-to-filename)) - -(defmacro dired-mark-if (predicate msg) - ;; Mark all files for which CONDITION evals to non-nil. - ;; CONDITION is evaluated on each line, with point at beginning of line. - ;; MSG is a noun phrase for the type of files being marked. - ;; It should end with a noun that can be pluralized by adding `s'. - ;; Return value is the number of files marked, or nil if none were marked. - (let ((temp-pt (make-symbol "pt")) - (temp-count (make-symbol "count")) - (temp-msg (make-symbol "msg"))) - (` (let (((, temp-msg) (, msg)) - ((, temp-count) 0) - (, temp-pt) buffer-read-only) - (save-excursion - (if (, temp-msg) (message "Marking %ss..." (, temp-msg))) - (goto-char (point-min)) - (while (not (eobp)) - (if (and (, predicate) - (not (char-equal (following-char) dired-marker-char))) - (progn - ;; Doing this rather than delete-char, insert - ;; avoids re-computing markers - (setq (, temp-pt) (point)) - (dired-substitute-marker - (, temp-pt) - (following-char) dired-marker-char) - (setq (, temp-count) (1+ (, temp-count))))) - (forward-line 1)) - (if (, temp-msg) - (message "%s %s%s %s%s." - (, temp-count) - (, temp-msg) - (dired-plural-s (, temp-count)) - (if (eq dired-marker-char ?\040) "un" "") - (if (eq dired-marker-char dired-del-marker) - "flagged" "marked")))) - (and (> (, temp-count) 0) (, temp-count)))))) - -(defmacro dired-map-over-marks (body arg &optional show-progress) -;; Perform BODY with point somewhere on each marked line -;; and return a list of BODY's results. -;; If no marked file could be found, execute BODY on the current line. -;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0) -;; files instead of the marked files. -;; If ARG is t, only apply to marked files. If there are no marked files, -;; the result is a noop. -;; If ARG is otherwise non-nil, use current file instead. -;; If optional third arg SHOW-PROGRESS evaluates to non-nil, -;; redisplay the dired buffer after each file is processed. -;; No guarantee is made about the position on the marked line. -;; BODY must ensure this itself if it depends on this. -;; Search starts at the beginning of the buffer, thus the car of the list -;; corresponds to the line nearest to the buffer's bottom. This -;; is also true for (positive and negative) integer values of ARG. -;; To avoid code explosion, BODY should not be too long as it is -;; expanded four times. -;; -;; Warning: BODY must not add new lines before point - this may cause an -;; endless loop. -;; This warning should not apply any longer, sk 2-Sep-1991 14:10. - (let ((temp-found (make-symbol "found")) - (temp-results (make-symbol "results")) - (temp-regexp (make-symbol "regexp")) - (temp-curr-pt (make-symbol "curr-pt")) - (temp-next-position (make-symbol "next-position"))) - (` (let (buffer-read-only case-fold-search (, temp-found) (, temp-results)) - (dired-save-excursion - (if (and (, arg) (not (eq (, arg) t))) - (if (integerp (, arg)) - (and (not (zerop (, arg))) - (progn;; no save-excursion, want to move point. - (dired-repeat-over-lines - arg - (function (lambda () - (if (, show-progress) (sit-for 0)) - (setq (, temp-results) - (cons (, body) - (, temp-results)))))) - (if (< (, arg) 0) - (nreverse (, temp-results)) - (, temp-results)))) - ;; non-nil, non-integer ARG means use current file: - (list (, body))) - (let (((, temp-regexp) - (concat "^" (regexp-quote (char-to-string - dired-marker-char)))) - (, temp-curr-pt) (, temp-next-position)) - (save-excursion - (goto-char (point-min)) - ;; remember position of next marked file before BODY - ;; can insert lines before the just found file, - ;; confusing us by finding the same marked file again - ;; and again and... - (setq (, temp-next-position) - (and (re-search-forward (, temp-regexp) nil t) - (point-marker)) - (, temp-found) (not (null (, temp-next-position)))) - (while (, temp-next-position) - (setq (, temp-curr-pt) (goto-char (, temp-next-position)) - ;; need to get next position BEFORE body - (, temp-next-position) - (and (re-search-forward (, temp-regexp) nil t) - (point-marker))) - (goto-char (, temp-curr-pt)) - (if (, show-progress) (sit-for 0)) - (setq (, temp-results) (cons (, body) (, temp-results))))) - (if (, temp-found) - (, temp-results) - ;; Do current file, unless arg is t - (and (not (eq (, arg) t)) - (list (, body))))))))))) - -;;; General utility functions - -(defun dired-buffer-more-recently-used-p (buffer1 buffer2) - "Return t if BUFFER1 is more recently used than BUFFER2." - (if (equal buffer1 buffer2) - nil - (let ((more-recent nil) - (list (buffer-list))) - (while (and list - (not (setq more-recent (equal buffer1 (car list)))) - (not (equal buffer2 (car list)))) - (setq list (cdr list))) - more-recent))) - -(defun dired-file-modtime (file) - ;; Return the modtime of FILE, which is assumed to be already expanded - ;; by expand-file-name. - (let ((handler (find-file-name-handler file 'dired-file-modtime))) - (if handler - (funcall handler 'dired-file-modtime file) - (nth 5 (file-attributes file))))) - -(defun dired-set-file-modtime (file alist) - ;; Set the modtime for FILE in the subdir alist ALIST. - (let ((handler (find-file-name-handler file 'dired-set-file-modtime))) - (if handler - (funcall handler 'dired-set-file-modtime file alist) - (let ((elt (assoc file alist))) - (if elt - (setcar (nthcdr 4 elt) (nth 5 (file-attributes file)))))))) - -(defun dired-map-over-marks-check (fun arg op-symbol operation - &optional show-progress no-confirm) - ;; Map FUN over marked files (with second ARG like in dired-map-over-marks) - ;; and display failures. - - ;; FUN takes zero args. It returns non-nil (the offending object, e.g. - ;; the short form of the filename) for a failure and probably logs a - ;; detailed error explanation using function `dired-log'. - - ;; OP-SYMBOL is s symbol representing the operation. - ;; eg. 'compress - - ;; OPERATION is a string describing the operation performed (e.g. - ;; "Compress"). It is used with `dired-mark-pop-up' to prompt the user - ;; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. - ;; `Failed to compress 1 of 2 files - type y to see why ("foo")') - - ;; SHOW-PROGRESS if non-nil means redisplay dired after each file. - - (if (or no-confirm (dired-mark-confirm op-symbol operation arg)) - (let* ((total-list;; all of FUN's return values - (dired-map-over-marks (funcall fun) arg show-progress)) - (total (length total-list)) - (failures (delq nil total-list)) - (count (length failures))) - (if (not failures) - (message "%s: %d file%s." operation total (dired-plural-s total)) - (message "Failed to %s %d of %d file%s - type y to see why %s" - operation count total (dired-plural-s total) - ;; this gives a short list of failed files in parens - ;; which may be sufficient for the user even - ;; without typing `W' for the process' diagnostics - failures) - ;; end this bunch of errors: - (dired-log-summary - (buffer-name (current-buffer)) - (format - "Failed to %s %d of %d file%s" - operation count total (dired-plural-s total)) - failures))))) - -(defun dired-make-switches-string (list) -;; Converts a list of cracters to a string suitable for passing to ls. - (concat "-" (mapconcat 'char-to-string list ""))) - -(defun dired-make-switches-list (string) -;; Converts a string of ls switches to a list of characters. - (delq ?- (mapcar 'identity string))) - -;; Cloning replace-match to work on strings instead of in buffer: -;; The FIXEDCASE parameter of replace-match is not implemented. -(defun dired-string-replace-match (regexp string newtext - &optional literal global) - ;; Replace first match of REGEXP in STRING with NEWTEXT. - ;; If it does not match, nil is returned instead of the new string. - ;; Optional arg LITERAL means to take NEWTEXT literally. - ;; Optional arg GLOBAL means to replace all matches. - (if global - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result - (substring string start mb) - (if literal - newtext - (dired-expand-newtext string newtext))) - start me)) - (if mb ; matched at least once - (concat result (substring string start)) - nil)) - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (dired-expand-newtext string newtext)) - (substring string (match-end 0)))))) - -(defun dired-expand-newtext (string newtext) - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c - (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t - (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - -(defun dired-in-this-tree (file dir) - ;;Is FILE part of the directory tree starting at DIR? - (let ((len (length dir))) - (and (>= (length file) len) - (string-equal (substring file 0 len) dir)))) - -(defun dired-tree-lessp (dir1 dir2) - ;; Lexicographic order on pathname components, like `ls -lR': - ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, - ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, - ;; or DIR1 and DIR2 are in the same parentdir and their last - ;; components are string-lessp. - ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. - ;; string-lessp could arguably be replaced by file-newer-than-file-p - ;; if dired-internal-switches contained `t'. - (let ((dir1 (file-name-as-directory dir1)) - (dir2 (file-name-as-directory dir2)) - (start1 1) - (start2 1) - comp1 comp2 end1 end2) - (while (progn - (setq end1 (string-match "/" dir1 start1) - comp1 (substring dir1 start1 end1) - end2 (string-match "/" dir2 start2) - comp2 (substring dir2 start2 end2)) - (and end1 end2 (string-equal comp1 comp2))) - (setq start1 (1+ end1) - start2 (1+ end2))) - (if (eq (null end1) (null end2)) - (string-lessp comp1 comp2) - (null end1)))) - -;; So that we can support case-insensitive systems. -(fset 'dired-file-name-lessp 'string-lessp) - - -;;;; ------------------------------------------------------------------ -;;;; Initializing Dired -;;;; ------------------------------------------------------------------ - -;;; Set the minor mode alist - -(or (equal (assq 'dired-sort-mode minor-mode-alist) - '(dired-sort-mode dired-sort-mode)) - ;; Test whether this has already been done in case dired is reloaded - ;; There may be several elements with dired-sort-mode as car. - (setq minor-mode-alist - ;; cons " Omit" in first, so that it doesn't - ;; get stuck between the directory and sort mode on the - ;; mode line. - (cons '(dired-sort-mode dired-sort-mode) - (cons '(dired-subdir-omit " Omit") - (cons '(dired-marker-stack dired-marker-string) - minor-mode-alist))))) - -;;; Keymaps - -(defvar dired-mode-map nil - "Local keymap for dired-mode buffers.") -(defvar dired-regexp-map nil - "Dired keymap for commands that use regular expressions.") -(defvar dired-diff-map nil - "Dired keymap for diff and related commands.") -(defvar dired-subdir-map nil - "Dired keymap for commands that act on subdirs, or the files within them.") - -(defvar dired-keymap-grokked nil - "Set to t after dired has grokked the global keymap.") - -(defun dired-key-description (cmd &rest prefixes) - ;; Return a key description string for a menu. If prefixes are given, - ;; they should be either strings, integers, or 'universal-argument. - (let ((key (where-is-internal cmd dired-mode-map t))) - (if key - (key-description - (apply 'vconcat - (append - (mapcar - (function - (lambda (x) - (cond ((eq x 'universal-argument) - (where-is-internal 'universal-argument - dired-mode-map t)) - ((integerp x) (int-to-string x)) - (t x)))) - prefixes) - (list key)))) - ""))) - -(defun dired-grok-keys (to-command from-command) - ;; Assigns to TO-COMMAND the keys for the global binding of FROM-COMMAND. - ;; Does not clobber anything in the local keymap. In emacs 19 should - ;; use substitute-key-definition, but I believe that this will - ;; clobber things in the local map. - (let ((keys (where-is-internal from-command))) - (while keys - (condition-case nil - (if (eq (global-key-binding (car keys)) (key-binding (car keys))) - (local-set-key (car keys) to-command)) - (error nil)) - (setq keys (cdr keys))))) - -(defun dired-grok-keymap () - ;; Initialize the dired keymaps. - ;; This is actually done the first time that dired-mode runs. - ;; We do it this late, to be sure that the user's global-keymap has - ;; stabilized. - (if dired-keymap-grokked - () ; we've done it - ;; Watch out for dired being invoked from the command line. - ;; This is a bit kludgy, but so is the emacs startup sequence IMHO. - (if (and term-setup-hook (boundp 'command-line-args-left)) - (progn - (if (string-equal "18." (substring emacs-version 0 3)) - (funcall term-setup-hook) - (run-hooks 'term-setup-hook)) - (setq term-setup-hook nil))) - (setq dired-keymap-grokked t) - (run-hooks 'dired-setup-keys-hook) - (dired-grok-keys 'dired-next-line 'next-line) - (dired-grok-keys 'dired-previous-line 'previous-line) - (dired-grok-keys 'dired-undo 'undo) - (dired-grok-keys 'dired-undo 'advertised-undo) - (dired-grok-keys 'dired-scroll-up 'scroll-up) - (dired-grok-keys 'dired-scroll-down 'scroll-down) - (dired-grok-keys 'dired-beginning-of-buffer 'beginning-of-buffer) - (dired-grok-keys 'dired-end-of-buffer 'end-of-buffer) - (dired-grok-keys 'dired-next-subdir 'forward-paragraph) - (dired-grok-keys 'dired-prev-subdir 'backward-paragraph))) - -;; The regexp-map is used for commands using regexp's. -(if dired-regexp-map - () - (setq dired-regexp-map (make-sparse-keymap)) - (define-key dired-regexp-map "C" 'dired-do-copy-regexp) - ;; Not really a regexp, but does transform file names. - (define-key dired-regexp-map "D" 'dired-downcase) - (define-key dired-regexp-map "H" 'dired-do-hardlink-regexp) - (define-key dired-regexp-map "R" 'dired-do-rename-regexp) - (define-key dired-regexp-map "S" 'dired-do-symlink-regexp) - (define-key dired-regexp-map "U" 'dired-upcase) - (define-key dired-regexp-map "Y" 'dired-do-relsymlink-regexp) - (define-key dired-regexp-map "c" 'dired-cleanup) - (define-key dired-regexp-map "d" 'dired-flag-files-regexp) - (define-key dired-regexp-map "e" 'dired-mark-extension) - (define-key dired-regexp-map "m" 'dired-mark-files-regexp) - (define-key dired-regexp-map "o" 'dired-add-omit-regexp) - (define-key dired-regexp-map "x" 'dired-flag-extension)) ; a string, rather - ; than a regexp. - -(if dired-diff-map - () - (setq dired-diff-map (make-sparse-keymap)) - (define-key dired-diff-map "d" 'dired-diff) - (define-key dired-diff-map "b" 'dired-backup-diff) - (define-key dired-diff-map "m" 'dired-emerge) - (define-key dired-diff-map "a" 'dired-emerge-with-ancestor) - (define-key dired-diff-map "e" 'dired-ediff) - (define-key dired-diff-map "p" 'dired-epatch)) - -(if dired-subdir-map - () - (setq dired-subdir-map (make-sparse-keymap)) - (define-key dired-subdir-map "n" 'dired-redisplay-subdir) - (define-key dired-subdir-map "m" 'dired-mark-subdir-files) - (define-key dired-subdir-map "d" 'dired-flag-subdir-files) - (define-key dired-subdir-map "z" 'dired-compress-subdir-files)) - -(fset 'dired-regexp-prefix dired-regexp-map) -(fset 'dired-diff-prefix dired-diff-map) -(fset 'dired-subdir-prefix dired-subdir-map) -(fset 'efs-dired-prefix (function (lambda () - (interactive) - (error "efs-dired not loaded yet")))) - -;; the main map -(if dired-mode-map - nil - ;; Force `f' rather than `e' in the mode doc: - (fset 'dired-advertised-find-file 'dired-find-file) - (fset 'dired-advertised-next-subdir 'dired-next-subdir) - (fset 'dired-advertised-prev-subdir 'dired-prev-subdir) - (setq dired-mode-map (make-keymap)) - (suppress-keymap dired-mode-map) - ;; Commands to mark certain categories of files - (define-key dired-mode-map "~" 'dired-flag-backup-files) - (define-key dired-mode-map "#" 'dired-flag-auto-save-files) - (define-key dired-mode-map "*" 'dired-mark-executables) - (define-key dired-mode-map "." 'dired-clean-directory) - (define-key dired-mode-map "/" 'dired-mark-directories) - (define-key dired-mode-map "@" 'dired-mark-symlinks) - (define-key dired-mode-map "," 'dired-mark-rcs-files) - (define-key dired-mode-map "\M-(" 'dired-mark-sexp) - (define-key dired-mode-map "\M-d" 'dired-mark-files-from-other-dired-buffer) - (define-key dired-mode-map "\M-c" 'dired-mark-files-compilation-buffer) - ;; Upper case keys (except ! and &) for operating on the marked files - (define-key dired-mode-map "A" 'dired-do-tags-search) - (define-key dired-mode-map "B" 'dired-do-byte-compile) - (define-key dired-mode-map "C" 'dired-do-copy) - (define-key dired-mode-map "E" 'dired-do-grep) - (define-key dired-mode-map "F" 'dired-do-find-file) - (define-key dired-mode-map "G" 'dired-do-chgrp) - (define-key dired-mode-map "H" 'dired-do-hardlink) - (define-key dired-mode-map "I" 'dired-do-insert-subdir) - (define-key dired-mode-map "K" 'dired-do-kill-file-lines) - (define-key dired-mode-map "L" 'dired-do-load) - (define-key dired-mode-map "M" 'dired-do-chmod) - (define-key dired-mode-map "N" 'dired-do-redisplay) - (define-key dired-mode-map "O" 'dired-do-chown) - (define-key dired-mode-map "P" 'dired-do-print) - (define-key dired-mode-map "Q" 'dired-do-tags-query-replace) - (define-key dired-mode-map "R" 'dired-do-rename) - (define-key dired-mode-map "S" 'dired-do-symlink) - (define-key dired-mode-map "T" 'dired-do-total-size) - (define-key dired-mode-map "U" 'dired-do-uucode) - (define-key dired-mode-map "W" 'dired-copy-filenames-as-kill) - (define-key dired-mode-map "X" 'dired-do-delete) - (define-key dired-mode-map "Y" 'dired-do-relsymlink) - (define-key dired-mode-map "Z" 'dired-do-compress) - (define-key dired-mode-map "!" 'dired-do-shell-command) - (define-key dired-mode-map "&" 'dired-do-background-shell-command) - ;; Make all regexp commands share a `%' prefix: - (define-key dired-mode-map "%" 'dired-regexp-prefix) - ;; Lower keys for commands not operating on all the marked files - (define-key dired-mode-map "a" 'dired-apropos) - (define-key dired-mode-map "c" 'dired-change-marks) - (define-key dired-mode-map "d" 'dired-flag-file-deletion) - (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion-backup) - (define-key dired-mode-map "e" 'dired-find-file) - (define-key dired-mode-map "f" 'dired-advertised-find-file) - (define-key dired-mode-map "g" 'revert-buffer) - (define-key dired-mode-map "h" 'dired-describe-mode) - (define-key dired-mode-map "i" 'dired-maybe-insert-subdir) - (define-key dired-mode-map "k" 'dired-kill-subdir) - (define-key dired-mode-map "m" 'dired-mark) - (define-key dired-mode-map "o" 'dired-find-file-other-window) - (define-key dired-mode-map "q" 'dired-quit) - (define-key dired-mode-map "r" 'dired-read-mail) - (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit) - (define-key dired-mode-map "t" 'dired-get-target-directory) - (define-key dired-mode-map "u" 'dired-unmark) - (define-key dired-mode-map "v" 'dired-view-file) - (define-key dired-mode-map "w" (if (fboundp 'find-file-other-frame) - 'dired-find-file-other-frame - 'dired-find-file-other-window)) - (define-key dired-mode-map "x" 'dired-expunge-deletions) - (define-key dired-mode-map "y" 'dired-why) - (define-key dired-mode-map "+" 'dired-create-directory) - (define-key dired-mode-map "`" 'dired-recover-file) - ;; dired-jump-back Should be in the global map, but put them here - ;; too anyway. - (define-key dired-mode-map "\C-x\C-j" 'dired-jump-back) - (define-key dired-mode-map "\C-x4\C-j" 'dired-jump-back-other-window) - (define-key dired-mode-map "\C-x5\C-j" 'dired-jump-back-other-frame) - ;; Comparison commands - (define-key dired-mode-map "=" 'dired-diff-prefix) - ;; moving - (define-key dired-mode-map "<" 'dired-prev-dirline) - (define-key dired-mode-map ">" 'dired-next-dirline) - (define-key dired-mode-map " " 'dired-next-line) - (define-key dired-mode-map "n" 'dired-next-line) - (define-key dired-mode-map "\C-n" 'dired-next-line) - (define-key dired-mode-map "p" 'dired-previous-line) - (define-key dired-mode-map "\C-p" 'dired-previous-line) - (define-key dired-mode-map "\C-v" 'dired-scroll-up) - (define-key dired-mode-map "\M-v" 'dired-scroll-down) - (define-key dired-mode-map "\M-<" 'dired-beginning-of-buffer) - (define-key dired-mode-map "\M->" 'dired-end-of-buffer) - (define-key dired-mode-map "\C-m" 'dired-advertised-find-file) - ;; motion by subdirectories - (define-key dired-mode-map "^" 'dired-up-directory) - (define-key dired-mode-map "\M-\C-u" 'dired-up-directory) - (define-key dired-mode-map "\M-\C-d" 'dired-down-directory) - (define-key dired-mode-map "\M-\C-n" 'dired-advertised-next-subdir) - (define-key dired-mode-map "\M-\C-p" 'dired-advertised-prev-subdir) - (define-key dired-mode-map "\C-j" 'dired-goto-subdir) - ;; move to marked files - (define-key dired-mode-map "\M-p" 'dired-prev-marked-file) - (define-key dired-mode-map "\M-n" 'dired-next-marked-file) - ;; hiding - (define-key dired-mode-map "$" 'dired-hide-subdir) - (define-key dired-mode-map "\M-$" 'dired-hide-all) - ;; omitting - (define-key dired-mode-map "\C-o" 'dired-omit-toggle) - ;; markers - (define-key dired-mode-map "\(" 'dired-set-marker-char) - (define-key dired-mode-map "\)" 'dired-restore-marker-char) - (define-key dired-mode-map "'" 'dired-marker-stack-left) - (define-key dired-mode-map "\\" 'dired-marker-stack-right) - ;; misc - (define-key dired-mode-map "\C-i" 'dired-mark-prefix) - (define-key dired-mode-map "?" 'dired-summary) - (define-key dired-mode-map "\177" 'dired-backup-unflag) - (define-key dired-mode-map "\C-_" 'dired-undo) - (define-key dired-mode-map "\C-xu" 'dired-undo) - (define-key dired-mode-map "\M-\C-?" 'dired-unmark-all-files) - ;; The subdir map - (define-key dired-mode-map "|" 'dired-subdir-prefix) - ;; efs submap - (define-key dired-mode-map "\M-e" 'efs-dired-prefix)) - - - -;;;;------------------------------------------------------------------ -;;;; The dired command -;;;;------------------------------------------------------------------ - -;;; User commands: -;;; All of these commands should have a binding in the global keymap. - -;;;###autoload (define-key ctl-x-map "d" 'dired) -;;;###autoload -(defun dired (dirname &optional switches) - "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -Optional second argument SWITCHES specifies the `ls' options used. -\(Interactively, use a prefix argument to be able to specify SWITCHES.) -Dired displays a list of files in DIRNAME (which may also have -shell wildcards appended to select certain files). If DIRNAME is a cons, -its first element is taken as the directory name and the resr as an explicit -list of files to make directory entries for. -\\\ -You can move around in it with the usual commands. -You can flag files for deletion with \\[dired-flag-file-deletion] and then -delete them by typing \\[dired-expunge-deletions]. -Type \\[dired-describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." - ;; Cannot use (interactive "D") because of wildcards. - (interactive (dired-read-dir-and-switches "")) - (switch-to-buffer (dired-noselect dirname switches))) - -;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window) -;;;###autoload -(defun dired-other-window (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." - (interactive (dired-read-dir-and-switches "in other window ")) - (switch-to-buffer-other-window (dired-noselect dirname switches))) - -;;;###autoload (define-key ctl-x-5-map "d" 'dired-other-frame) -;;;###autoload -(defun dired-other-frame (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." - (interactive (dired-read-dir-and-switches "in other frame ")) - (switch-to-buffer-other-frame (dired-noselect dirname switches))) - -;;;###autoload -(defun dired-noselect (dir-or-list &optional switches) - "Like `dired' but returns the dired buffer as value, does not select it." - (or dir-or-list (setq dir-or-list (expand-file-name default-directory))) - ;; This loses the distinction between "/foo/*/" and "/foo/*" that - ;; some shells make: - (let (dirname) - (if (consp dir-or-list) - (setq dirname (car dir-or-list)) - (setq dirname dir-or-list)) - (setq dirname (expand-file-name (directory-file-name dirname))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (if (consp dir-or-list) - (setq dir-or-list (cons dirname (cdr dir-or-list))) - (setq dir-or-list dirname)) - (dired-internal-noselect dir-or-list switches))) - -;; Adapted from code by wurgler@zippysun.math.uakron.edu (Tom Wurgler). -;;;###autoload (define-key ctl-x-map "\C-j" 'dired-jump-back) -;;;###autoload -(defun dired-jump-back () - "Jump back to dired. -If in a file, dired the current directory and move to file's line. -If in dired already, pop up a level and goto old directory's line. -In case the proper dired file line cannot be found, refresh the dired - buffer and try again." - (interactive) - (let* ((file (if (eq major-mode 'dired-mode) - (directory-file-name (dired-current-directory)) - buffer-file-name)) - (dir (if file - (file-name-directory file) - default-directory))) - (dired dir) - (if file (dired-really-goto-file file)))) - -;;;###autoload (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) -;;;###autoload -(defun dired-jump-back-other-window () - "Like \\[dired-jump-back], but to other window." - (interactive) - (let* ((file (if (eq major-mode 'dired-mode) - (directory-file-name (dired-current-directory)) - buffer-file-name)) - (dir (if file - (file-name-directory file) - default-directory))) - (dired-other-window dir) - (if file (dired-really-goto-file file)))) - -;;;###autoload (define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) -;;;###autoload -(defun dired-jump-back-other-frame () - "Like \\[dired-jump-back], but in another frame." - (interactive) - (let* ((file (if (eq major-mode 'dired-mode) - (directory-file-name (dired-current-directory)) - buffer-file-name)) - (dir (if file - (file-name-directory file) - default-directory))) - (dired-other-frame dir) - (if file (dired-really-goto-file file)))) - -;;; Dired mode - -;; Dired mode is suitable only for specially formatted data. -(put 'dired-mode 'mode-class 'special) - -(defun dired-mode (&optional dirname switches) - "\\Dired mode is for \"editing\" directory trees. - -For a simple one-line help message, type \\[dired-summary] -For a moderately detailed description of dired mode, type \\[dired-describe-mode] -For the full dired info tree, type \\[universal-argument] \\[dired-describe-mode]" - ;; Not to be called interactively (e.g. dired-directory will be set - ;; to default-directory, which is wrong with wildcards). - (kill-all-local-variables) - (use-local-map dired-mode-map) - (setq major-mode 'dired-mode - mode-name "Dired" - case-fold-search nil - buffer-read-only t - selective-display t ; for subdirectory hiding - selective-display-ellipses nil ; for omit toggling - mode-line-buffer-identification '("Dired: %12b") - mode-line-modified (format dired-mode-line-modified "--" "--" "-") - dired-directory (expand-file-name (or dirname default-directory)) - dired-internal-switches (dired-make-switches-list - (or switches dired-listing-switches))) - (dired-advertise) ; default-directory is already set - (set (make-local-variable 'revert-buffer-function) - (function dired-revert)) - (set (make-local-variable 'default-directory-function) - 'dired-current-directory) - (set (make-local-variable 'page-delimiter) - "\n\n") - (set (make-local-variable 'list-buffers-directory) - dired-directory) - ;; Will only do something in Emacs 19. - (add-hook (make-local-variable 'kill-buffer-hook) - 'dired-unadvertise-current-buffer) - ;; Same here - (if window-system - (add-hook (make-local-variable 'post-command-hook) - (function - (lambda () - (if (memq this-command dired-modeline-tracking-cmds) - (dired-update-mode-line t)))))) - (dired-sort-other dired-internal-switches t) - (dired-hack-local-variables) - (run-hooks 'dired-mode-hook) - ;; Run this after dired-mode-hook, in case that hook makes changes to - ;; the keymap. - (dired-grok-keymap)) - -;;; Internal functions for starting dired - -(defun dired-read-dir-and-switches (str) - ;; For use in interactive. - (reverse (list - (if current-prefix-arg - (read-string "Dired listing switches: " - dired-listing-switches)) - (let ((default-directory (default-directory))) - (read-file-name (format "Dired %s(directory): " str) - nil default-directory nil))))) - -(defun dired-hack-local-variables () - "Parse, bind or evaluate any local variables for current dired buffer. -See variable `dired-local-variables-file'." - (if (and dired-local-variables-file - (file-exists-p dired-local-variables-file)) - (let (buffer-read-only opoint ) - (save-excursion - (goto-char (point-max)) - (setq opoint (point-marker)) - (insert "\^L\n") - (insert-file-contents dired-local-variables-file)) - (let ((buffer-file-name dired-local-variables-file)) - (condition-case err - (hack-local-variables) - (error (message "Error in dired-local-variables-file: %s" err) - (sit-for 1)))) - ;; Must delete it as (eobp) is often used as test for last - ;; subdir in dired.el. - (delete-region opoint (point-max)) - (set-marker opoint nil)))) - -;; Separate function from dired-noselect for the sake of dired-vms.el. -(defun dired-internal-noselect (dir-or-list &optional switches mode) - ;; If there is an existing dired buffer for DIRNAME, just leave - ;; buffer as it is (don't even call dired-revert). - ;; This saves time especially for deep trees or with efs. - ;; The user can type `g'easily, and it is more consistent with find-file. - ;; But if SWITCHES are given they are probably different from the - ;; buffer's old value, so call dired-sort-other, which does - ;; revert the buffer. - ;; If the user specifies a directory with emacs startup, eg. - ;; emacs ~, dir-or-list may be unexpanded at this point. - - (let* ((dirname (expand-file-name (if (consp dir-or-list) - (car dir-or-list) - dir-or-list))) - (buffer (dired-find-buffer-nocreate dir-or-list mode)) - ;; note that buffer already is in dired-mode, if found - (new-buffer-p (not buffer)) - (old-buf (current-buffer)) - wildcard) - (or buffer - (let ((default-major-mode 'fundamental-mode)) - ;; We don't want default-major-mode to run hooks and set auto-fill - ;; or whatever, now that dired-mode does not - ;; kill-all-local-variables any longer. - (setq buffer (create-file-buffer (directory-file-name dirname))))) - (set-buffer buffer) - (if (not new-buffer-p) ; existing buffer ... - (progn - (if switches - (dired-sort-other - (if (stringp switches) - (dired-make-switches-list switches) - switches))) - (if dired-verify-modtimes (dired-verify-modtimes)) - (if (and dired-find-subdir - (not (string-equal (dired-current-directory) - (file-name-as-directory dirname)))) - (dired-initial-position dirname))) - ;; Else a new buffer - (if (file-directory-p dirname) - (setq default-directory dirname - wildcard (consp dir-or-list)) - (setq default-directory (file-name-directory dirname) - wildcard t)) - (or switches (setq switches dired-listing-switches)) - (dired-mode dirname switches) - ;; default-directory and dired-internal-switches are set now - ;; (buffer-local), so we can call dired-readin: - (let ((failed t)) - (unwind-protect - (progn (dired-readin dir-or-list buffer wildcard) - (setq failed nil)) - ;; dired-readin can fail if parent directories are inaccessible. - ;; Don't leave an empty buffer around in that case. - (if failed (kill-buffer buffer)))) - ;; No need to narrow since the whole buffer contains just - ;; dired-readin's output, nothing else. The hook can - ;; successfully use dired functions (e.g. dired-get-filename) - ;; as the subdir-alist has been built in dired-readin. - (run-hooks 'dired-after-readin-hook) - ;; I put omit-expunge after the dired-after-readin-hook - ;; in case that hook marks files. Does this make sense? Also, users - ;; might want to set dired-omit-files in some incredibly clever - ;; way depending on the contents of the directory... I don't know... - (if dired-omit-files - (dired-omit-expunge nil t)) - (goto-char (point-min)) - (dired-initial-position dirname)) - (set-buffer old-buf) - buffer)) - -(defun dired-find-buffer-nocreate (dir-or-list &optional mode) - ;; Returns a dired buffer for DIR-OR-LIST. DIR-OR-LIST may be wildcard, - ;; or a directory and alist of files. - ;; If dired-find-subdir is non-nil, is satisfied with a dired - ;; buffer containing DIR-OR-LIST as a subdirectory. If there is more - ;; than one candidate, returns the most recently used. - (if dired-find-subdir - (let ((buffers (sort (delq (current-buffer) - (dired-buffers-for-dir dir-or-list t)) - (function dired-buffer-more-recently-used-p)))) - (or (car buffers) - ;; Couldn't find another buffer. Will the current one do? - ;; It is up dired-initial-position to actually go to the subdir. - (and (or (equal dir-or-list dired-directory) ; covers wildcards - (and (stringp dir-or-list) - (not (string-equal - dir-or-list - (expand-file-name default-directory))) - (assoc (file-name-as-directory dir-or-list) - dired-subdir-alist))) - (current-buffer)))) - ;; Else just look through the buffer list. - (let (found (blist (buffer-list))) - (or mode (setq mode 'dired-mode)) - (save-excursion - (while blist - (set-buffer (car blist)) - (if (and (eq major-mode mode) - (equal dired-directory dir-or-list)) - (setq found (car blist) - blist nil) - (setq blist (cdr blist))))) - found))) - -(defun dired-initial-position (dirname) - ;; Where point should go in a new listing of DIRNAME. - ;; Point assumed at beginning of new subdir line. - (end-of-line) - (if dired-find-subdir (dired-goto-subdir dirname)) - (if dired-trivial-filenames (dired-goto-next-nontrivial-file)) - (dired-update-mode-line t)) - -(defun dired-readin (dir-or-list buffer &optional wildcard) - ;; Read in a new dired buffer - ;; dired-readin differs from dired-insert-subdir in that it accepts - ;; wildcards, erases the buffer, and builds the subdir-alist anew - ;; (including making it buffer-local and clearing it first). - ;; default-directory and dired-internal-switches must be buffer-local - ;; and initialized by now. - ;; Thus we can test (equal default-directory dirname) instead of - ;; (file-directory-p dirname) and save a filesystem transaction. - ;; This is wrong, if dired-before-readin-hook changes default-directory - ;; Also, we can run this hook which may want to modify the switches - ;; based on default-directory, e.g. with efs to a SysV host - ;; where ls won't understand -Al switches. - (let (dirname other-dirs) - (if (consp dir-or-list) - (setq dir-or-list (dired-frob-dir-list dir-or-list) - other-dirs (cdr dir-or-list) - dir-or-list (car dir-or-list) - dirname (car dir-or-list)) - (setq dirname dir-or-list)) - (setq dirname (expand-file-name dirname)) - (if (consp dir-or-list) - (setq dir-or-list (cons dirname (cdr dir-or-list)))) - (save-excursion - (set-buffer buffer) - (run-hooks 'dired-before-readin-hook) - (message "Reading directory %s..." dirname) - (let (buffer-read-only) - (widen) - (erase-buffer) - (dired-readin-insert dir-or-list wildcard) - (dired-indent-listing (point-min) (point-max)) - ;; We need this to make the root dir have a header line as all - ;; other subdirs have: - (goto-char (point-min)) - (dired-insert-headerline (expand-file-name default-directory))) - (message "Reading directory %s...done" dirname) - (set-buffer-modified-p nil) - ;; Must first make alist buffer local and set it to nil because - ;; dired-build-subdir-alist will call dired-clear-alist first - (setq dired-subdir-alist nil) - (if (memq ?R dired-internal-switches) - (dired-build-subdir-alist) - ;; no need to parse the buffer if listing is not recursive - (dired-simple-subdir-alist)) - (if other-dirs - (mapcar - (function - (lambda (x) - (if (dired-in-this-tree (car x) dirname) - (dired-insert-subdir x)))) - other-dirs))))) - -;;; Subroutines of dired-readin - -(defun dired-readin-insert (dir-or-list &optional wildcard) - ;; Just insert listing for the passed-in directory or - ;; directory-and-file list, assuming a clean buffer. - (let* ((switches (dired-make-switches-string dired-internal-switches)) - (dir-is-list (consp dir-or-list)) - (dirname (if dir-is-list (car dir-or-list) dir-or-list))) - (if wildcard - (progn - (or (file-readable-p - (if dir-is-list - dirname - (directory-file-name (file-name-directory dirname)))) - (error "Directory %s inaccessible or nonexistent" dirname)) - ;; else assume it contains wildcards - (dired-insert-directory dir-or-list switches t) - (save-excursion - ;; insert wildcard instead of total line: - (goto-char (point-min)) - (if dir-is-list - (insert "list wildcard\n") - (insert "wildcard " (file-name-nondirectory dirname) "\n")))) - (dired-insert-directory dir-or-list switches nil t)))) - -(defun dired-insert-directory (dir-or-list switches &optional wildcard full-p) - ;; Do the right thing whether dir-or-list is atomic or not. If it is, - ;; insert all files listed in the cdr -- the car is the passed-in directory - ;; list. - (let ((opoint (point)) - (insert-directory-program dired-ls-program)) - (if (consp dir-or-list) - (mapcar - (function - (lambda (x) - (insert-directory x switches wildcard))) - (cdr dir-or-list)) - (insert-directory dir-or-list switches wildcard full-p)) - (dired-insert-set-properties opoint (point))) - (setq dired-directory dir-or-list)) - -(defun dired-frob-dir-list (dir-list) - (let* ((top (file-name-as-directory (expand-file-name (car dir-list)))) - (tail (cdr dir-list)) - (result (list (list top))) - elt dir) - (setq tail - (mapcar - (function - (lambda (x) - (directory-file-name (expand-file-name x top)))) - tail)) - (while tail - (setq dir (file-name-directory (car tail))) - (if (setq elt (assoc dir result)) - (nconc elt (list (car tail))) - (nconc result (list (list dir (car tail))))) - (setq tail (cdr tail))) - result)) - -(defun dired-insert-headerline (dir);; also used by dired-insert-subdir - ;; Insert DIR's headerline with no trailing slash, exactly like ls - ;; would, and put cursor where dired-build-subdir-alist puts subdir - ;; boundaries. - (save-excursion (insert " " (directory-file-name dir) ":\n"))) - -(defun dired-verify-modtimes () - ;; Check the modtimes of all subdirs. - (let ((alist dired-subdir-alist) - on-disk in-mem badies) - (while alist - (and (setq in-mem (nth 4 (car alist))) - (setq on-disk (dired-file-modtime (car (car alist)))) - (not (equal in-mem on-disk)) - (setq badies (cons (cons (car (car alist)) - (nth 3 (car alist))) - badies))) - (setq alist (cdr alist))) - (and badies - (let* ((ofile (dired-get-filename nil t)) - (osub (and (null ofile) (dired-get-subdir))) - (opoint (point)) - (ocol (current-column))) - (unwind-protect - (and - (or (memq 'revert-subdirs dired-no-confirm) - (save-window-excursion - (let ((flist (mapcar - (function - (lambda (f) - (dired-abbreviate-file-name (car f)))) - badies))) - (switch-to-buffer (current-buffer)) - (dired-mark-pop-up - "*Stale Subdirectories*" 'revert-subdirs - flist 'y-or-n-p - (if (= (length flist) 1) - (concat "Subdirectory " (car flist) - " has changed on disk. Re-list? ") - "Subdirectories have changed on disk. Re-list? ")) - ))) - (while badies - (dired-insert-subdir (car (car badies)) - (cdr (car badies)) nil t) - (setq badies (cdr badies)))) - ;; We can't use dired-save-excursion here, because we are - ;; rewriting the entire listing, and not just changing a single - ;; file line. - (or (if ofile - (dired-goto-file ofile) - (if osub - (dired-goto-subdir osub))) - (progn - (goto-char opoint) - (beginning-of-line) - (skip-chars-forward "^\n\r" (+ (point) ocol)))) - (dired-update-mode-line t) - (dired-update-mode-line-modified t)))))) - -(defun dired-indent-listing (start end) - ;; Indent a dired listing. - (let (indent-tabs-mode) - (indent-rigidly start end 2) - ;; Quote any null lines that shouldn't be. - (save-excursion - (goto-char start) - (while (search-forward "\n\n" end t) - (forward-char -2) - (if (looking-at dired-subdir-regexp) - (goto-char (match-end 3)) - (progn - (forward-char 1) - (insert " "))))))) - - -;;;; ------------------------------------------------------------ -;;;; Reverting a dired buffer, or specific file lines within it. -;;;; ------------------------------------------------------------ - -(defun dired-revert (&optional arg noconfirm) - ;; Reread the dired buffer. Must also be called after - ;; dired-internal-switches have changed. - ;; Should not fail even on completely garbaged buffers. - ;; Preserves old cursor, marks/flags, hidden-p. - (widen) ; just in case user narrowed - (let ((opoint (point)) - (ofile (dired-get-filename nil t)) - (hidden-subdirs (dired-remember-hidden)) - ;; switches for top-level dir - (oswitches (or (nth 3 (nth (1- (length dired-subdir-alist)) - dired-subdir-alist)) - (delq ?R (copy-sequence dired-internal-switches)))) - ;; all other subdirs - (old-subdir-alist (cdr (reverse dired-subdir-alist))) - (omitted-subdirs (dired-remember-omitted)) - ;; do this after dired-remember-hidden, since this unhides - (mark-alist (dired-remember-marks (point-min) (point-max))) - (kill-files-p (save-excursion - (goto-char (point)) - (search-forward - (concat (char-to-string ?\r) - (regexp-quote - (char-to-string - dired-kill-marker-char))) - nil t))) - buffer-read-only) - ;; This is bogus, as it will not handle all the ways that efs uses cache. - ;; Better to just use the fact that revert-buffer-function is a - ;; buffer-local variable, and reset it to something that knows about - ;; cache. - ;; (dired-uncache - ;; (if (consp dired-directory) (car dired-directory) dired-directory)) - ;; treat top level dir extra (it may contain wildcards) - (let ((dired-after-readin-hook nil) - ;; don't run that hook for each subdir... - (dired-omit-files nil) - (dired-internal-switches oswitches)) - (dired-readin dired-directory (current-buffer) - ;; Don't test for wildcards by checking string= - ;; default-directory and dired-directory - ;; in case default-directory got munged. - (or (consp dired-directory) - (null (file-directory-p dired-directory)))) - ;; The R-switch will clobber sorting of subdirs. - ;; What is the right thing to do here? - (dired-insert-old-subdirs old-subdir-alist)) - (dired-mark-remembered mark-alist) ; mark files that were marked - (if kill-files-p (dired-do-hide dired-kill-marker-char)) - (run-hooks 'dired-after-readin-hook) ; no need to narrow - ;; omit-expunge after the readin hook - (save-excursion - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-omit-expunge)))) - omitted-subdirs)) - ;; hide subdirs that were hidden - (save-excursion - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs)) - ;; Try to get back to where we were - (or (and ofile (dired-goto-file ofile)) - (goto-char opoint)) - (dired-move-to-filename) - (dired-update-mode-line t) - (dired-update-mode-line-modified t))) - -(defun dired-do-redisplay (&optional arg) - "Redisplay all marked (or next ARG) files." - (interactive "P") - ;; message instead of making dired-map-over-marks show-progress is - ;; much faster - (dired-map-over-marks (let ((fname (dired-get-filename))) - (dired-uncache fname nil) - (message "Redisplaying %s..." fname) - (dired-update-file-line fname)) - arg) - (dired-update-mode-line-modified t) - (message "Redisplaying...done")) - -(defun dired-redisplay-subdir (&optional arg) - "Redisplay the current subdirectory. -With a prefix prompts for listing switches." - (interactive "P") - (let ((switches (and arg (dired-make-switches-list - (read-string "Switches for listing: " - (dired-make-switches-string - dired-internal-switches))))) - (dir (dired-current-directory)) - (opoint (point)) - (ofile (dired-get-filename nil t))) - (or switches - (setq switches (nth 3 (assoc dir dired-subdir-alist)))) - (or switches - (setq switches (delq ?R (copy-sequence dired-internal-switches)))) - (message "Redisplaying %s..." dir) - (dired-uncache dir t) - (dired-insert-subdir dir switches) - (dired-update-mode-line-modified t) - (or (and ofile (dired-goto-file ofile)) (goto-char opoint)) - (message "Redisplaying %s... done" dir))) - -(defun dired-update-file-line (file) - ;; Delete the current line, and insert an entry for FILE. - ;; Does not update other dired buffers. Use dired-relist-file for that. - (let* ((start (save-excursion (skip-chars-backward "^\n\r") (point))) - (char (char-after start))) - (dired-save-excursion - ;; don't remember omit marks - (if (memq char (list ?\040 dired-omit-marker-char)) - (setq char nil)) - ;; Delete the current-line. Even though dired-add-entry will not - ;; insert duplicates, the file for the current line may not be the same as - ;; FILE. eg. dired-do-compress - (delete-region (save-excursion (skip-chars-backward "^\n\r") (1- (point))) - (progn (skip-chars-forward "^\n\r") (point))) - ;; dired-add-entry inserts at the end of the previous line. - (forward-char 1) - (dired-add-entry file char t)))) - -;;; Subroutines of dired-revert -;;; Some of these are also used when inserting subdirs. - -;; Don't want to remember omit marks, in case omission regexps -;; were changed, before the dired-revert. If we don't unhide -;; omitted files, we won't see their marks. Therefore we use -;; dired-omit-unhide-region. - -(defun dired-remember-marks (beg end) - ;; Return alist of files and their marks, from BEG to END. - (if selective-display ; must unhide to make this work. - (let (buffer-read-only) - (subst-char-in-region (point-min) (point-max) ?\r ?\n) - (dired-do-hide dired-omit-marker-char))) - (let (fil chr alist) - (save-excursion - (goto-char beg) - (while (re-search-forward dired-re-mark end t) - (if (setq fil (dired-get-filename nil t)) - (setq chr (preceding-char) - alist (cons (cons fil chr) alist))))) - alist)) - -(defun dired-mark-remembered (alist) - ;; Mark all files remembered in ALIST. - (let (elt fil chr) - (while alist - (setq elt (car alist) - alist (cdr alist) - fil (car elt) - chr (cdr elt)) - (if (dired-goto-file fil) - (save-excursion - (beginning-of-line) - (dired-substitute-marker (point) (following-char) chr)))))) - -(defun dired-remember-hidden () - ;; Return a list of all hidden subdirs. - (let ((l dired-subdir-alist) dir result min) - (while l - (setq dir (car (car l)) - min (dired-get-subdir-min (car l)) - l (cdr l)) - (if (and (>= min (point-min)) (<= min (point-max)) - (dired-subdir-hidden-p dir)) - (setq result (cons dir result)))) - result)) - -(defun dired-insert-old-subdirs (old-subdir-alist) - ;; Try to insert all subdirs that were displayed before - (let (elt dir switches) - (while old-subdir-alist - (setq elt (car old-subdir-alist) - old-subdir-alist (cdr old-subdir-alist) - dir (car elt) - switches (or (nth 3 elt) dired-internal-switches)) - (condition-case () - (dired-insert-subdir dir switches) - (error nil))))) - -(defun dired-uncache (file dir-p) - ;; Remove directory DIR from any directory cache. - ;; If DIR-P is non-nil, then FILE is a directory - (let ((handler (find-file-name-handler file 'dired-uncache))) - (if handler - (funcall handler 'dired-uncache file dir-p)))) - - -;;;; ------------------------------------------------------------- -;;;; Inserting subdirectories -;;;; ------------------------------------------------------------- - -(defun dired-maybe-insert-subdir (dirname &optional - switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, just move to it (type \\[dired-do-redisplay] to - refresh), else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (dired-make-switches-list - (read-string "Switches for listing: " - (dired-make-switches-string - dired-internal-switches)))))) - (let ((opoint (point))) - ;; We don't need a marker for opoint as the subdir is always - ;; inserted *after* opoint. - (setq dirname (file-name-as-directory dirname)) - (or (and (not switches) - (dired-goto-subdir dirname)) - (dired-insert-subdir dirname switches no-error-if-not-dir-p)) - ;; Push mark so that it's easy to find back. Do this after the - ;; insert message so that the user sees the `Mark set' message. - (push-mark opoint))) - -(defun dired-insert-subdir (dir-or-list &optional - switches no-error-if-not-dir-p no-posn) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - ;; SWITCHES should be a list. - ;; If NO-POSN is non-nil, doesn't bother position the point at - ;; the first nontrivial file line. This can be used as an efficiency - ;; hack when calling this from a program. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (dired-make-switches-list - (read-string "Switches for listing: " - (dired-make-switches-string - dired-internal-switches)))))) - (let ((dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (or (dired-in-this-tree dirname (expand-file-name default-directory)) - (error "%s: not in this directory tree" dirname)) - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (if switches - (or (dired-compatible-switches-p dired-internal-switches switches) - (error "Cannot have subdirs with %s and %s switches together." - (dired-make-switches-string dired-internal-switches) - (dired-make-switches-string switches))) - (setq switches dired-internal-switches)) - (let ((elt (assoc dirname dired-subdir-alist)) - mark-alist opoint-max buffer-read-only) - (if (memq ?R switches) - ;; avoid duplicated subdirs - (progn - (setq mark-alist (dired-kill-tree dirname t)) - (dired-insert-subdir-newpos dirname)) - (if elt - ;; If subdir is already present, remove it and remember its marks - (setq mark-alist (dired-insert-subdir-del elt)) - ;; else move to new position - (dired-insert-subdir-newpos dirname))) - (setq opoint-max (point-max)) - (condition-case nil - (dired-insert-subdir-doupdate - dirname (dired-insert-subdir-doinsert dir-or-list switches) - switches elt mark-alist) - (quit ; watch out for aborted inserts - (and (= opoint-max (point-max)) - (null elt) - (= (preceding-char) ?\n) - (delete-char -1)) - (signal 'quit nil)))) - (or no-posn (dired-initial-position dirname)))) - -(defun dired-do-insert-subdir () - "Insert all marked subdirectories in situ that are not yet inserted. -Non-directories are silently ignored." - (interactive) - (let ((files (or (dired-get-marked-files) - (error "No files marked.")))) - (while files - (if (file-directory-p (car files)) - (save-excursion (dired-maybe-insert-subdir (car files)))) - (setq files (cdr files))))) - -;;; Utilities for inserting subdirectories - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - (let ((alist dired-subdir-alist) elt dir new-pos) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt)) - (if (dired-tree-lessp dir new-dir) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt) - alist nil))) - (goto-char new-pos)) - (insert "\n") - (point)) - -(defun dired-insert-subdir-del (element) - ;; Erase an already present subdir (given by ELEMENT) from buffer. - ;; Move to that buffer position. Return a mark-alist. - (let ((begin-marker (dired-get-subdir-min element))) - (goto-char begin-marker) - ;; Are at beginning of subdir (and inside it!). Now determine its end: - (goto-char (dired-subdir-max)) - (prog1 - (dired-remember-marks begin-marker (point)) - (delete-region begin-marker (point))))) - -(defun dired-insert-subdir-doinsert (dir-or-list switches) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; Return the boundary of the inserted text (as list of BEG and END). - ;; SWITCHES should be a non-nil list. - (let ((begin (point)) - (dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list)) - end) - (message "Reading directory %s..." dirname) - (if (string-equal dirname (car (car (reverse dired-subdir-alist)))) - ;; top level directory may contain wildcards: - (let ((dired-internal-switches switches)) - (dired-readin-insert dired-directory - (null (file-directory-p dired-directory)))) - (let ((switches (dired-make-switches-string switches)) - (insert-directory-program dired-ls-program)) - (if (consp dir-or-list) - (progn - (insert "list wildcard\n") - (mapcar - (function - (lambda (x) - (insert-directory x switches t))) - (cdr dir-or-list))) - (insert-directory dirname switches nil t)))) - (message "Reading directory %s...done" dirname) - (setq end (point-marker)) - (dired-indent-listing begin end) - (dired-insert-set-properties begin end) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - ;; Need a marker for END as this inserts text. - (goto-char begin) - (dired-insert-headerline dirname) - ;; point is now like in dired-build-subdir-alist - (prog1 - (list begin (marker-position end)) - (set-marker end nil)))) - -(defun dired-insert-subdir-doupdate (dirname beg-end switches elt mark-alist) - ;; Point is at the correct subdir alist position for ELT, - ;; BEG-END is the subdir-region (as list of begin and end). - ;; SWITCHES must be a non-nil list. - (if (memq ?R switches) - ;; This will remove ?R from switches on purpose. - (let ((dired-internal-switches (delq ?R switches))) - (dired-build-subdir-alist)) - (if elt - (progn - (set-marker (dired-get-subdir-min elt) (point-marker)) - (setcar (nthcdr 3 elt) switches) - (if dired-verify-modtimes - (dired-set-file-modtime dirname dired-subdir-alist))) - (dired-alist-add dirname (point-marker) dired-omit-files switches))) - (save-excursion - (let ((begin (nth 0 beg-end)) - (end (nth 1 beg-end))) - (goto-char begin) - (save-restriction - (narrow-to-region begin end) - ;; hook may add or delete lines, but the subdir boundary - ;; marker floats - (run-hooks 'dired-after-readin-hook) - (if mark-alist (dired-mark-remembered mark-alist)) - (dired-do-hide dired-kill-marker-char) - (if (if elt (nth 2 elt) dired-omit-files) - (dired-omit-expunge nil t)))))) - - -;;;; -------------------------------------------------------------- -;;;; Dired motion commands -- moving around in the dired buffer. -;;;; -------------------------------------------------------------- - -(defun dired-next-line (arg) - "Move down lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (condition-case err - (next-line arg) - (error - (if (eobp) - (error "End of buffer") - (error "%s" err)))) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-previous-line (arg) - "Move up lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (previous-line arg) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-scroll-up (arg) - "Dired version of scroll up. -Scroll text of current window upward ARG lines; or near full screen if no ARG. -When calling from a program, supply a number as argument or nil." - (interactive "_P") - (scroll-up arg) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-scroll-down (arg) - "Dired version of scroll-down. -Scroll text of current window down ARG lines; or near full screen if no ARG. -When calling from a program, supply a number as argument or nil." - (interactive "_P") - (scroll-down arg) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-beginning-of-buffer (arg) - "Dired version of `beginning of buffer'." - (interactive "_P") - (beginning-of-buffer arg) - (dired-update-mode-line)) - -(defun dired-end-of-buffer (arg) - "Dired version of `end-of-buffer'." - (interactive "_P") - (end-of-buffer arg) - (while (not (or (dired-move-to-filename) (dired-get-subdir) (bobp))) - (forward-line -1)) - (dired-update-mode-line t)) - -(defun dired-next-dirline (arg &optional opoint) - "Goto ARG'th next directory file line." - (interactive "_p") - (if dired-re-dir - (progn - (dired-check-ls-l) - (or opoint (setq opoint (point))) - (if (if (> arg 0) - (re-search-forward dired-re-dir nil t arg) - (beginning-of-line) - (re-search-backward dired-re-dir nil t (- arg))) - (progn - (dired-move-to-filename) ; user may type `i' or `f' - (dired-update-mode-line)) - (goto-char opoint) - (error "No more subdirectories"))))) - -(defun dired-prev-dirline (arg) - "Goto ARG'th previous directory file line." - (interactive "_p") - (dired-next-dirline (- arg))) - -(defun dired-next-marked-file (arg &optional wrap opoint) - "Move to the next marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (or opoint (setq opoint (point))) ; return to where interactively started - (if (if (> arg 0) - (re-search-forward dired-re-mark nil t arg) - (beginning-of-line) - (re-search-backward dired-re-mark nil t (- arg))) - (dired-move-to-filename) - (if (null wrap) - (progn - (goto-char opoint) - (error "No next marked file")) - (message "(Wraparound for next marked file)") - (goto-char (if (> arg 0) (point-min) (point-max))) - (dired-next-marked-file arg nil opoint))) - (dired-update-mode-line)) - -(defun dired-prev-marked-file (arg &optional wrap) - "Move to the previous marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (dired-next-marked-file (- arg) wrap) - (dired-update-mode-line)) - -(defun dired-goto-file (file) - "Goto file line of FILE in this dired buffer." - ;; Return value of point on success, else nil. - ;; FILE must be an absolute pathname. - ;; Loses if FILE contains control chars like "\007" for which ls - ;; either inserts "?" or "\\007" into the buffer, so we won't find - ;; it in the buffer. - (interactive - (prog1 ; let push-mark display its message - (list - (let* ((dired-completer-buffer (current-buffer)) - (dired-completer-switches dired-internal-switches) - (stack (reverse - (mapcar (function - (lambda (x) - (dired-abbreviate-file-name (car x)))) - dired-subdir-alist))) - (initial (car stack)) - (dired-goto-file-history (cdr stack)) - dired-completer-cache) - (expand-file-name - (dired-completing-read "Goto file: " - 'dired-goto-file-completer - nil t initial 'dired-goto-file-history)))) - (push-mark))) - (setq file (directory-file-name file)) ; does no harm if no directory - (let (found case-fold-search) - (save-excursion - (if (dired-goto-subdir (or (file-name-directory file) - (error "Need absolute pathname for %s" - file))) - (let* ((base (file-name-nondirectory file)) - ;; filenames are preceded by SPC, this makes - ;; the search faster (e.g. for the filename "-"!). - (search (concat " " (dired-make-filename-string base t))) - (boundary (dired-subdir-max)) - fn) - (while (and (not found) (search-forward search boundary 'move)) - ;; Match could have BASE just as initial substring or - ;; or in permission bits or date or - ;; not be a proper filename at all: - (if (and (setq fn (dired-get-filename 'no-dir t)) - (string-equal fn base)) - ;; Must move to filename since an (actually - ;; correct) match could have been elsewhere on the - ;; line (e.g. "-" would match somewhere in the - ;; permission bits). - (setq found (dired-move-to-filename))))))) - (and found - ;; return value of point (i.e., FOUND): - (prog1 - (goto-char found) - (dired-update-mode-line))))) - -;;; Moving by subdirectories - -(defun dired-up-directory (arg) - "Move to the ARG'th (prefix arg) parent directory of current directory. -Always stays within the current tree dired buffer. Will insert new -subdirectories if necessary." - (interactive "p") - (if (< arg 0) (error "Can't go up a negative number of directories!")) - (or (zerop arg) - (let* ((dir (dired-current-directory)) - (n arg) - (up dir)) - (while (> n 0) - (setq up (file-name-directory (directory-file-name up)) - n (1- n))) - (if (and (< (length up) (length dired-directory)) - (dired-in-this-tree dired-directory up)) - (if (or (memq 'create-top-dir dired-no-confirm) - (y-or-n-p - (format "Insert new top dir %s and rename buffer? " - (dired-abbreviate-file-name up)))) - (let ((newname (let (buff) - (unwind-protect - (buffer-name - (setq buff - (create-file-buffer - (directory-file-name up)))) - (kill-buffer buff)))) - (buffer-read-only nil)) - (push-mark) - (widen) - (goto-char (point-min)) - (insert-before-markers "\n") - (forward-char -1) - (dired-insert-subdir-doupdate - up (dired-insert-subdir-doinsert up dired-internal-switches) - dired-internal-switches nil nil) - (dired-initial-position up) - (rename-buffer newname) - (dired-unadvertise default-directory) - (setq default-directory up - dired-directory up) - (dired-advertise))) - (dired-maybe-insert-subdir up))))) - -(defun dired-down-directory () - "Go down in the dired tree. -Moves to the first subdirectory of the current directory, which exists in -the dired buffer. Does not take a prefix argument." - ;; What would a prefix mean here? - (interactive) - (let ((dir (dired-current-directory)) ; has slash - (rest (reverse dired-subdir-alist)) - pos elt) - (while rest - (setq elt (car rest)) - (if (dired-in-this-tree (directory-file-name (car elt)) dir) - (setq rest nil - pos (dired-goto-subdir (car elt))) - (setq rest (cdr rest)))) - (prog1 - (if pos - (progn - (push-mark) - (goto-char pos)) - (error "At the bottom")) - (dired-update-mode-line t)))) - -(defun dired-next-subdir (arg &optional no-error-if-not-found no-skip) - "Go to next subdirectory, regardless of level." - ;; Use 0 arg to go to this directory's header line. - ;; NO-SKIP prevents moving to end of header line, returning whatever - ;; position was found in dired-subdir-alist. - (interactive "p") - (let ((this-dir (dired-current-directory)) - pos index) - ;; nth with negative arg does not return nil but the first element - (setq index (- (length dired-subdir-alist) - (length (memq (assoc this-dir dired-subdir-alist) - dired-subdir-alist)) - arg)) - (setq pos (if (>= index 0) - (dired-get-subdir-min (nth index dired-subdir-alist)))) - (if pos - (if no-skip - (goto-char pos) - (goto-char pos) - (skip-chars-forward "^\r\n") - (if (= (following-char) ?\r) - (skip-chars-backward "." (- (point) 3))) - (dired-update-mode-line t) - (point)) - (if no-error-if-not-found - nil ; return nil if not found - (error "%s directory" (if (> arg 0) "Last" "First")))))) - -(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) - "Go to previous subdirectory, regardless of level. -When called interactively and not on a subdir line, go to this subdir's line." - (interactive - (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - ;; if on subdir start already, don't stay there! - (if (dired-get-subdir) 1 0)))) - (dired-next-subdir (- arg) no-error-if-not-found no-skip)) - -(defun dired-goto-subdir (dir) - "Goto end of header line of DIR in this dired buffer. -Return value of point on success, otherwise return nil. -The next char is either \\n, or \\r if DIR is hidden." - (interactive - (prog1 ; let push-mark display its message - (list - (let* ((table (mapcar - (function - (lambda (x) - (list (dired-abbreviate-file-name - (car x))))) - dired-subdir-alist)) - (stack (reverse (mapcar 'car table))) - (initial (car stack)) - (dired-goto-file-history (cdr stack))) - (expand-file-name - (dired-completing-read "Goto subdirectory " table nil t - initial 'dired-goto-file-history)))) - (push-mark))) - (setq dir (file-name-as-directory dir)) - (let ((elt (assoc dir dired-subdir-alist))) - (and elt - ;; need to make sure that we get where we're going. - ;; beware: narrowing might be in effect - (eq (goto-char (dired-get-subdir-min elt)) (point)) - (progn - ;; dired-subdir-hidden-p and dired-add-entry depend on point being - ;; at either \n or looking-at ...\r after this function succeeds. - (skip-chars-forward "^\r\n") - (if (= (preceding-char) ?.) - (skip-chars-backward "." (- (point) 3))) - (if (interactive-p) (dired-update-mode-line)) - (point))))) - -;;; Internals for motion commands - -(defun dired-update-mode-line (&optional force) - "Updates the mode line in dired according to the position of the point. -Normally this uses a cache of the boundaries of the current subdirectory, -but if the optional argument FORCE is non-nil, then modeline is always -updated and the cache is recomputed." - (if (or force - (>= (point) dired-curr-subdir-max) - (< (point) dired-curr-subdir-min)) - (let ((alist dired-subdir-alist) - min max) - (while (and alist (< (point) - (setq min (dired-get-subdir-min (car alist))))) - (setq alist (cdr alist) - max min)) - (setq dired-curr-subdir-max (or max (point-max-marker)) - dired-curr-subdir-min (or min (point-min-marker)) - dired-subdir-omit (nth 2 (car alist))) - (dired-sort-set-modeline (nth 3 (car alist)))))) - -(defun dired-manual-move-to-filename (&optional raise-error bol eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the UNIX version. - ;; have to be careful that we don't move to omitted files - (let (case-fold-search) - - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (or bol (setq bol (progn (skip-chars-backward "^\r\n") (point)))) - - (if (or (memq ?l dired-internal-switches) - (memq ?g dired-internal-switches)) - (if (and - (> (- eol bol) 17) ; a valid file line must have at least - ; 17 chars. 2 leading, 10 perms, - ; separator, node #, separator, owner, - ; separator - (goto-char (+ bol 17)) - (re-search-forward dired-re-month-and-time eol t)) - (point) - (goto-char bol) - (if raise-error - (error "No file on this line") - nil)) - ;; else ls switches don't contain -l. - ;; Note that even if we make dired-move-to-filename and - ;; dired-move-to-end-of-filename (and thus dired-get-filename) - ;; work, all commands that gleaned information from the permission - ;; bits (like dired-mark-directories) will cease to work properly. - (if (= bol eol) - (if raise-error - (error "No file on this line") - nil) - ;; skip marker, if any - (goto-char bol) - (forward-char)) - ;; If we not going to use the l switch, and use nstd listings, - ;; then we must bomb on files starting with spaces. - (skip-chars-forward " \t") - (point)))) - -(defun dired-manual-move-to-end-of-filename (&optional no-error bol eol) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* - ;; line if at all. So, it should be called only after - ;; (dired-move-to-filename t). - ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). - ;; This is the UNIX version. - (let ((bof (point)) - file-type modes-start case-fold-search) - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) - (and - (null no-error) - selective-display - (eq (char-after (1- bol)) ?\r) - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (if (or (memq ?l dired-internal-switches) - (memq ?g dired-internal-switches)) - (if (save-excursion - (goto-char bol) - (re-search-forward - "[^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ][-+ 0-9+]" - bof t)) - (progn - (setq modes-start (match-beginning 0) - file-type (char-after modes-start)) - ;; Move point to end of name: - (if (eq file-type ?l) ; symlink - (progn - (if (search-forward " -> " eol t) - (goto-char (match-beginning 0)) - (goto-char eol)) - (and dired-ls-F-marks-symlinks - (eq (preceding-char) ?@) ; link really marked? - (memq ?F dired-internal-switches) - (forward-char -1)) - (point)) - ;; else not a symbolic link - (goto-char eol) - ;; ls -lF marks dirs, sockets and executables with exactly - ;; one trailing character. -F may not actually be honored, - ;; e.g. by an FTP ls in efs - (and - (memq ?F dired-internal-switches) - (let ((char (preceding-char))) - (or (and (eq char ?*) (or - (memq - (char-after (+ modes-start 3)) - '(?x ?s ?t)) - (memq - (char-after (+ modes-start 6)) - '(?x ?s ?t)) - (memq - (char-after (+ modes-start 9)) - '(?x ?s ?t)))) - (and (eq char ?=) (eq file-type ?s)))) - (forward-char -1)) - ;; Skip back over /'s unconditionally. It's not a valid - ;; file name character. - (skip-chars-backward "/") - (point))) - (and (null no-error) - (error "No file on this line"))) - - ;; A brief listing - (if (eq (point) eol) - (and (null no-error) - (error "No file on this line")) - (goto-char eol) - (if (and (memq (preceding-char) '(?@ ?* ?=)) - (memq ?F dired-internal-switches)) - ;; A guess, since without a long listing, we can't be sure. - (forward-char -1)) - (skip-chars-backward "/") - (point))))) - -(defun dired-goto-next-nontrivial-file () - ;; Position point on first nontrivial file after point. - ;; Does not move into the next sudir. - ;; If point is on a file line, moves to that file. - ;; This does not move to omitted files. - (skip-chars-backward "^\n\r") - (if (= (preceding-char) ?\r) - (forward-line 1)) - (let ((max (dired-subdir-max)) - file) - (while (and (or (not (setq file (dired-get-filename 'no-dir t))) - (string-match dired-trivial-filenames file)) - (< (point) max)) - (forward-line 1))) - (dired-move-to-filename)) - -(defun dired-goto-next-file () - ;; Doesn't move out of current subdir. Does go to omitted files. - ;; Returns the starting position of the file, or nil if none found. - (let ((max (dired-subdir-max)) - found) - (while (and (null (setq found (dired-move-to-filename))) (< (point) max)) - (skip-chars-forward "^\n\r") - (forward-char 1)) - found)) - -;; fluid vars used by dired-goto-file-completer -(defvar dired-completer-buffer nil) -(defvar dired-completer-switches nil) -(defvar dired-completer-cache nil) - -(defun dired-goto-file-completer (string pred action) - (save-excursion - (set-buffer dired-completer-buffer) - (let* ((saved-md (match-data)) - (file (file-name-nondirectory string)) - (dir (file-name-directory string)) - (xstring (expand-file-name string)) - (xdir (file-name-directory xstring)) - (exact (dired-goto-file xstring))) - (unwind-protect - (if (dired-goto-subdir xdir) - (let ((table (cdr (assoc xdir dired-completer-cache))) - fn result max) - (or table - (progn - (setq table (make-vector 37 0)) - (mapcar (function - (lambda (ent) - (setq ent (directory-file-name - (car ent))) - (if (string-equal - (file-name-directory ent) xdir) - (intern - (concat - (file-name-nondirectory ent) "/") - table)))) - dired-subdir-alist) - (or (looking-at "\\.\\.\\.\n\r") - (progn - (setq max (dired-subdir-max)) - (while (and - (< (point) max) - (not - (setq fn - (dired-get-filename 'no-dir t)))) - (forward-line 1)) - (if fn - (progn - (or (intern-soft (concat fn "/") table) - (intern fn table)) - (forward-line 1) - (while (setq fn - (dired-get-filename 'no-dir t)) - (or (intern-soft (concat fn "/") table) - (intern fn table)) - (forward-line 1)))))) - (setq dired-completer-cache (cons - (cons xdir table) - dired-completer-cache)))) - (cond - ((null action) - (setq result (try-completion file table)) - (if exact - (if (stringp result) - string - t) - (if (stringp result) - (concat dir result) - result))) - ((eq action t) - (setq result (all-completions file table)) - (if exact (cons "." result) result)) - ((eq 'lambda action) - (and (or exact (intern-soft file table))))))) - (store-match-data saved-md))))) - -(defun dired-really-goto-file (file) - ;; Goes to a file, even if it needs to insert it parent directory. - (or (dired-goto-file file) - (progn ; refresh and try again - (dired-insert-subdir (file-name-directory file)) - (dired-goto-file file)))) - -(defun dired-between-files () - ;; Point must be at beginning of line - (save-excursion (not (dired-move-to-filename nil (point))))) - -(defun dired-repeat-over-lines (arg function) - ;; This version skips non-file lines. - ;; Skips file lines hidden with selective display. - ;; BACKWARDS means move backwards after each action. This is not the same - ;; as a negative arg, as that skips the current line. - (beginning-of-line) - (let* ((advance (cond ((> arg 0) 1) ((< arg 0) -1) (t nil))) - (check-fun (if (eq advance 1) 'eobp 'bobp)) - (n (if (< arg 0) (- arg) arg)) - (wall (funcall check-fun)) - (done wall)) - (while (not done) - (if advance - (progn - (while (not (or (save-excursion (dired-move-to-filename)) - (setq wall (funcall check-fun)))) - (forward-line advance)) - (or wall - (progn - (save-excursion (funcall function)) - (forward-line advance) - (while (not (or (save-excursion (dired-move-to-filename)) - (setq wall (funcall check-fun)))) - (forward-line advance)) - (setq done (or (zerop (setq n (1- n))) wall))))) - (if (save-excursion (dired-move-to-filename)) - (save-excursion (funcall function))) - (setq done t)))) - (dired-move-to-filename) - ;; Note that if possible the point has now been moved to the beginning of - ;; the file name. - (dired-update-mode-line)) - - -;;;; ---------------------------------------------------------------- -;;;; Miscellaneous dired commands -;;;; ---------------------------------------------------------------- - -(defun dired-quit () - "Bury the current dired buffer." - (interactive) - (bury-buffer)) - -(defun dired-undo () - "Undo in a dired buffer. -This doesn't recover lost files, it is just normal undo with temporarily -writeable buffer. You can use it to recover marks, killed lines or subdirs." - (interactive) - (let ((lines (count-lines (point-min) (point-max))) - buffer-read-only) - (undo) - ;; reset dired-subdir-alist, if a dir may have been affected - ;; Is there a better way to guess this? - (setq lines (- (count-lines (point-min) (point-max)) lines)) - (if (or (>= lines 2) (<= lines -2)) - (dired-build-subdir-alist))) - (dired-update-mode-line-modified t) - (dired-update-mode-line t)) - - -;;;; -------------------------------------------------------- -;;;; Immediate actions on files: visiting, viewing, etc. -;;;; -------------------------------------------------------- - -(defun dired-find-file () - "In dired, visit the file or directory named on this line." - (interactive) - (let ((find-file-run-dired t)) - (find-file (dired-get-filename)))) - -(defun dired-view-file () - "In dired, examine a file in view mode, returning to dired when done. -When file is a directory, show it in this buffer if it is inserted; -otherwise, display it in another buffer." - (interactive) - (let ((file (dired-get-filename))) - (if (file-directory-p file) - (or (dired-goto-subdir file) - (dired file)) - (view-file file)))) - -(defun dired-find-file-other-window (&optional displayp) - "In dired, visit this file or directory in another window. -With a prefix, the file is displayed, but the window is not selected." - (interactive "P") - (if displayp - (dired-display-file) - (let ((find-file-run-dired t)) - (find-file-other-window (dired-get-filename))))) - -;; Only for Emacs 19 -(defun dired-find-file-other-frame () - "In dired, visit this file or directory in another frame." - (interactive) - (let ((find-file-run-dired t)) - (find-file-other-frame (dired-get-filename)))) - -(defun dired-display-file () - "In dired, displays this file or directory in the other window." - (interactive) - (let ((find-file-run-dired t)) - (display-buffer (find-file-noselect (dired-get-filename))))) - -;; After an idea by wurgler@zippysun.math.uakron.edu (Tom Wurgler). -(defun dired-do-find-file (&optional arg) - "Visit all marked files at once, and display them simultaneously. -See also function `simultaneous-find-file'. -If you want to keep the dired buffer displayed, type \\[split-window-vertically] first. -If you want just the marked files displayed and nothing else, type \\[delete-other-windows] first." - (interactive "P") - (dired-simultaneous-find-file (dired-get-marked-files nil arg))) - -(defun dired-simultaneous-find-file (file-list) - "Visit all files in FILE-LIST and display them simultaneously. - -The current window is split across all files in FILE-LIST, as evenly -as possible. Remaining lines go to the bottommost window. - -The number of files that can be displayed this way is restricted by -the height of the current window and the variable `window-min-height'." - ;; It is usually too clumsy to specify FILE-LIST interactively - ;; unless via dired (dired-do-find-file). - (let ((size (/ (window-height) (length file-list)))) - (or (<= window-min-height size) - (error "Too many files to visit simultaneously")) - (find-file (car file-list)) - (setq file-list (cdr file-list)) - (while file-list - ;; Split off vertically a window of the desired size - ;; The upper window will have SIZE lines. We select the lower - ;; (larger) window because we want to split that again. - (select-window (split-window nil size)) - (let ((find-file-run-dired t)) - (find-file (car file-list))) - (setq file-list (cdr file-list))))) - -(defun dired-create-directory (directory) - "Create a directory called DIRECTORY." - (interactive - (list (read-file-name "Create directory: " - (dired-abbreviate-file-name - (dired-current-directory))))) - (let ((expanded (expand-file-name directory))) - (make-directory expanded) - ;; Because this function is meant to be called interactively, it moves - ;; the point. - (dired-goto-file expanded))) - -(defun dired-recover-file () - "Recovers file from its autosave file. -If the file is an autosave file, then recovers its associated file instead." - (interactive) - (let* ((file (dired-get-filename)) - (name (file-name-nondirectory file)) - (asp (auto-save-file-name-p name)) - (orig (and - asp - (if (fboundp 'auto-save-original-name) - (auto-save-original-name file) - (error - "Need auto-save package to compute original file name.")))) - (buff (if asp - (and orig (get-file-buffer orig)) - (get-file-buffer file)))) - (and - buff - (buffer-modified-p buff) - (or - (yes-or-no-p - (format - "Recover file will erase the modified buffer %s. Do it? " - (buffer-name buff))) - (error "Recover file aborted."))) - (if asp - (if orig - (recover-file orig) - (find-file file)) - (recover-file file)))) - - -;;;; -------------------------------------------------------------------- -;;;; Functions for extracting and manipulating file names -;;;; -------------------------------------------------------------------- - -(defun dired-make-filename-string (filename &optional reverse) - ;; Translates the way that a file name appears in a buffer, to - ;; how it is used in a path name. This is useful for non-unix - ;; support in efs. - filename) - -(defun dired-get-filename (&optional localp no-error-if-not-filep) - "In dired, return name of file mentioned on this line. -Value returned normally includes the directory name. -Optional arg LOCALP with value `no-dir' means don't include directory - name in result. A value of t means use path name relative to - `default-directory', which still may contain slashes if in a subdirectory. -Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on - this line, otherwise an error occurs." - - ;; Compute bol & eol once, rather than twice inside move-to-filename - ;; and move-to-end-of-filename - (let ((eol (save-excursion (skip-chars-forward "^\n\r") (point))) - (bol (save-excursion (skip-chars-backward "^\r\n") (point))) - case-fold-search file p1 p2) - (save-excursion - (and - (setq p1 (dired-move-to-filename (not no-error-if-not-filep) bol eol)) - (setq p2 (if (eq system-type 'windows-nt) ; ignore carriage-return at eol - (1- (dired-move-to-end-of-filename no-error-if-not-filep bol eol)) - (dired-move-to-end-of-filename no-error-if-not-filep bol eol))) - (setq file (buffer-substring p1 p2)) - ;; Check if ls quoted the names, and unquote them. - ;; Using read to unquote is much faster than substituting - ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop. - (cond ((memq ?b dired-internal-switches) ; System V ls - ;; This case is about 20% slower than without -b. - (setq file - (read - (concat "\"" - ;; some ls -b don't escape quotes, argh! - ;; This is not needed for GNU ls, though. - (or (dired-string-replace-match - "\\([^\\]\\)\"" file "\\1\\\\\"") - file) - "\"")))) - ;; If you do this, update dired-compatible-switches-p - ;; ((memq ?Q dired-internal-switches) ; GNU ls - ;; (setq file (read file))) - ))) - (and file - (if (eq localp 'no-dir) - (dired-make-filename-string file) - (concat (dired-current-directory localp) - (dired-make-filename-string file)))))) - -(defun dired-make-relative (file &optional dir no-error) - ;; Convert FILE (an *absolute* pathname) to a pathname relative to DIR. - ;; FILE must be absolute, or this function will return nonsense. - ;; If FILE is not in a subdir of DIR, an error is signalled, - ;; unless NO-ERROR is t. Then, ".."'s are inserted to give - ;; a relative representation of FILE wrto DIR - ;; eg. FILE = /vol/tex/bin/foo DIR = /vol/local/bin/ - ;; results in ../../tex/bin/foo - ;; DIR must be expanded. - ;; DIR defaults to default-directory. - ;; DIR must be file-name-as-directory, as with all directory args in - ;; elisp code. - (or dir (setq dir (expand-file-name default-directory))) - (let ((flen (length file)) - (dlen (length dir))) - (if (and (> flen dlen) - (string-equal (substring file 0 dlen) dir)) - (substring file dlen) - ;; Need to insert ..'s - (or no-error (error "%s: not in directory tree growing at %s" file dir)) - (if (string-equal file dir) - "./" - (let ((index 1) - (count 0)) - (while (and (string-match "/" dir index) - (<= (match-end 0) flen) - (string-equal (substring file index (match-end 0)) - (substring dir index (match-end 0)))) - (setq index (match-end 0))) - (setq file (substring file index)) - (if (and (/= flen index) - (not (string-match "/" file)) - (< flen dlen) - (string-equal file (substring dir index flen)) - (= (aref dir flen) ?/)) - (setq file "." - count -1)) - ;; count how many slashes remain in dir. - (while (string-match "/" dir index) - (setq index (match-end 0) - count (1+ count))) - (apply 'concat (nconc (make-list count "../") (list file)))))))) - -;;; Functions for manipulating file names. -;; -;; Used by file tranformers. -;; Define here rather than in dired-shell.el, as it wouldn't be -;; unreasonable to use these elsewhere. - -(defun dired-file-name-base (fn) - "Returns the base name of FN. -This is the file without directory part, and extension. See the variable -`dired-filename-re-ext'." - (setq fn (file-name-nondirectory fn)) - (if (string-match dired-filename-re-ext fn 1) - (substring fn 0 (match-beginning 0)) - fn)) - -(defun dired-file-name-extension (fn) - "Returns the extension for file name FN. -See the variable dired-filename-re-ext'." - (setq fn (file-name-nondirectory fn)) - (if (string-match dired-filename-re-ext fn 1) - (substring fn (match-beginning 0)) - "")) - -(defun dired-file-name-sans-rcs-extension (fn) - "Returns the file name FN without its RCS extension \",v\"." - (setq fn (file-name-nondirectory fn)) - (if (string-match ",v\\'" fn 1) - (substring fn 0 (match-beginning 0)) - fn)) - -(defun dired-file-name-sans-compress-extension (fn) - "Returns the file name FN without the extension from compress or gzip." - (setq fn (file-name-nondirectory fn)) - (if (string-match "\\.\\([zZ]\\|gz\\)\\'" fn 1) - (substring fn (match-beginning 0)) - fn)) - - -;;;; --------------------------------------------------------------------- -;;;; Working with directory trees. -;;;; --------------------------------------------------------------------- -;;; -;;; This where code for the dired-subdir-alist is. - -;;; Utility functions for dired-subdir-alist - -(defun dired-normalize-subdir (dir) - ;; Prepend default-directory to DIR if relative path name. - ;; dired-get-filename must be able to make a valid filename from a - ;; file and its directory DIR. - ;; Fully expand everything. - (file-name-as-directory - (if (file-name-absolute-p dir) - (expand-file-name dir) - (expand-file-name dir (expand-file-name default-directory))))) - -(defun dired-get-subdir () - ;;"Return the subdir name on this line, or nil if not on a headerline." - ;; Look up in the alist whether this is a headerline. - (save-excursion - (let ((cur-dir (dired-current-directory))) - (beginning-of-line) ; alist stores b-o-l positions - (and (zerop (- (point) - (dired-get-subdir-min (assoc cur-dir - dired-subdir-alist)))) - cur-dir)))) - -(defun dired-get-subdir-max (elt) - ;; returns subdir max. - (let ((pos (- (length dired-subdir-alist) - (length (member elt dired-subdir-alist))))) - (if (zerop pos) - (point-max) - (1- (dired-get-subdir-min (nth (1- pos) dired-subdir-alist)))))) - -(defun dired-clear-alist () - ;; Set all markers in dired-subdir-alist to nil. Set the alist to nil too. - (while dired-subdir-alist - (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil) - (setq dired-subdir-alist (cdr dired-subdir-alist)))) - -(defun dired-unsubdir (dir) - ;; Remove DIR from the alist - (setq dired-subdir-alist - (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) - -(defun dired-simple-subdir-alist () - ;; Build and return `dired-subdir-alist' assuming just the top level - ;; directory to be inserted. Don't parse the buffer. - (setq dired-subdir-alist - (list (list (expand-file-name default-directory) - (point-min-marker) dired-omit-files - dired-internal-switches nil))) - (if dired-verify-modtimes - (dired-set-file-modtime (expand-file-name default-directory) - dired-subdir-alist))) - -(defun dired-build-subdir-alist () - "Build `dired-subdir-alist' by parsing the buffer and return its new value." - (interactive) - (let ((o-alist dired-subdir-alist) - (count 0) - subdir) - (dired-clear-alist) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward dired-subdir-regexp nil t) - (setq count (1+ count)) - (apply 'dired-alist-add-1 - (setq subdir (buffer-substring (match-beginning 2) - (match-end 2))) - ;; Put subdir boundary between lines. - (set-marker (make-marker) (match-end 1)) - (let ((elt (assoc subdir o-alist))) - (if elt - (list (nth 2 elt) (nth 3 elt)) - (list dired-omit-files dired-internal-switches))))) - (if (interactive-p) - (message "%d director%s." count (if (= 1 count) "y" "ies"))) - ;; We don't need to sort it because it is in buffer order per - ;; constructionem. Return new alist: - ;; pointers for current-subdir may be stale - dired-subdir-alist))) - -(defun dired-alist-add (dir new-marker &optional omit switches) - ;; Add new DIR at NEW-MARKER. Sort alist. - (dired-alist-add-1 dir new-marker omit switches) - (dired-alist-sort)) - -(defun dired-alist-add-1 (dir new-marker &optional omit switches) - ;; Add new DIR at NEW-MARKER. Don't sort. - (let ((dir (dired-normalize-subdir dir))) - (setq dired-subdir-alist - (cons (list dir new-marker omit switches nil) dired-subdir-alist)) - (if dired-verify-modtimes - (dired-set-file-modtime dir dired-subdir-alist)))) - -(defun dired-alist-sort () - ;; Keep the alist sorted on buffer position. - (setq dired-subdir-alist - (sort dired-subdir-alist - (function (lambda (elt1 elt2) - (> (dired-get-subdir-min elt1) - (dired-get-subdir-min elt2))))))) - -;;; Utilities for working with subdirs in the dired buffer - -;; This function is the heart of tree dired. -;; It is called for each retrieved filename. -;; It could stand to be faster, though it's mostly function call -;; overhead. Avoiding to funcall seems to save about 10% in -;; dired-get-filename. Make it a defsubst? -(defun dired-current-directory (&optional localp) - "Return the name of the subdirectory to which this line belongs. -This returns a string with trailing slash, like `default-directory'. -Optional argument means return a file name relative to `default-directory'. -In this it returns \"\" for the top directory." - (let* ((here (point)) - (dir (catch 'done - (mapcar (function - (lambda (x) - (if (<= (dired-get-subdir-min x) here) - (throw 'done (car x))))) - dired-subdir-alist)))) - (if (listp dir) (error "dired-subdir-alist seems to be mangled")) - (if localp - (let ((def-dir (expand-file-name default-directory))) - (if (string-equal dir def-dir) - "" - (dired-make-relative dir def-dir))) - dir))) - -;; Subdirs start at the beginning of their header lines and end just -;; before the beginning of the next header line (or end of buffer). - -(defun dired-subdir-min () - ;; Returns the minimum position of the current subdir - (save-excursion - (if (not (dired-prev-subdir 0 t t)) - (error "Not in a subdir!") - (point)))) - -(defun dired-subdir-max () - ;; Returns the maximum position of the current subdir - (save-excursion - (if (dired-next-subdir 1 t t) - (1- (point)) ; Do not include separating empty line. - (point-max)))) - - -;;;; -------------------------------------------------------- -;;;; Deleting files -;;;; -------------------------------------------------------- - -(defun dired-flag-file-deletion (arg) - "In dired, flag the current line's file for deletion. -With prefix arg, repeat over several lines. - -If on a subdir headerline, mark all its files except `.' and `..'." - (interactive "p") - (dired-mark arg dired-del-marker)) - -(defun dired-flag-file-deletion-backup (arg) - "Flag current file for deletion, and move to previous line. -With a prefix ARG, repeats this ARG times." - (interactive "p") - ;; Use dired-mark-file and not dired-mark, as this function - ;; should do nothing special on subdir headers. - (dired-mark-file (- arg) dired-del-marker)) - -(defun dired-flag-subdir-files () - "Flag all the files in the current subdirectory for deletion." - (interactive) - (dired-mark-subdir-files dired-del-marker)) - -(defun dired-unflag (arg) - "In dired, remove a deletion flag from the current line's file. -Optional prefix ARG says how many lines to unflag." - (interactive "p") - (let (buffer-read-only) - (dired-repeat-over-lines - arg - (function - (lambda () - (if (char-equal (following-char) dired-del-marker) - (progn - (setq dired-del-flags-number (max (1- dired-del-flags-number) 0)) - (dired-substitute-marker (point) dired-del-marker ?\ ))))))) - (dired-update-mode-line-modified)) - -(defun dired-backup-unflag (arg) - "In dired, move up lines and remove deletion flag there. -Optional prefix ARG says how many lines to unflag; default is one line." - (interactive "p") - (dired-unflag (- arg))) - -(defun dired-update-marker-counters (char &optional remove) - (or (memq char '(?\ ?\n ?\r)) - (let ((counter (cond - ((char-equal char dired-del-marker) - 'dired-del-flags-number) - ((char-equal char dired-marker-char) - 'dired-marks-number) - ('dired-other-marks-number)))) - (if remove - (set counter (max (1- (symbol-value counter)) 0)) - (set counter (1+ (symbol-value counter))))))) - -(defun dired-update-mode-line-modified (&optional check) - ;; Updates the value of mode-line-modified in dired. - ;; Currently assumes that it's of the form "-%%-", where % sometimes - ;; gets replaced by %. Should allow some sort of config flag. - ;; SET is t to set to -DD-, nil to set to -%%-, and 'check means - ;; examine the buffer to find out. - (if check - (save-excursion - (let (char) - (goto-char (point-min)) - (setq dired-del-flags-number 0 - dired-marks-number 0 - dired-other-marks-number 0) - (while (not (eobp)) - (setq char (following-char)) - (cond - ((char-equal char dired-del-marker) - (setq dired-del-flags-number (1+ dired-del-flags-number))) - ((char-equal char dired-marker-char) - (setq dired-marks-number (1+ dired-marks-number))) - ((memq char '(?\ ?\n ?\r)) - nil) - ((setq dired-other-marks-number (1+ dired-other-marks-number)))) - (forward-line 1))))) - (setq mode-line-modified - (format dired-mode-line-modified - (if (zerop dired-del-flags-number) - "--" - (format "%d%c" dired-del-flags-number dired-del-marker)) - (if (zerop dired-marks-number) - "--" - (format "%d%c" dired-marks-number dired-marker-char)) - (if (zerop dired-other-marks-number) - "-" - (int-to-string dired-other-marks-number)))) - (set-buffer-modified-p (buffer-modified-p))) - -(defun dired-do-deletions (&optional nomessage) - (dired-expunge-deletions)) - -(defun dired-expunge-deletions () - "In dired, delete the files flagged for deletion." - (interactive) - (let ((files (let ((dired-marker-char dired-del-marker)) - (dired-map-over-marks (cons (dired-get-filename) (point)) - t)))) - (if files - (progn - (dired-internal-do-deletions files nil dired-del-marker) - ;; In case the point gets left somewhere strange -- hope that - ;; this doesn't cause asynch troubles later. - (beginning-of-line) - (dired-goto-next-nontrivial-file) - (dired-update-mode-line-modified t)) ; play safe, it's cheap - (message "(No deletions requested)")))) - -(defun dired-do-delete (&optional arg) - "Delete all marked (or next ARG) files." - ;; This is more consistent with the file marking feature than - ;; dired-expunge-deletions. - (interactive "P") - (dired-internal-do-deletions - ;; this may move point if ARG is an integer - (dired-map-over-marks (cons (dired-get-filename) (point)) - arg) - arg) - (beginning-of-line) - (dired-goto-next-nontrivial-file)) - -(defun dired-internal-do-deletions (l arg &optional marker-char) - ;; L is an alist of files to delete, with their buffer positions. - ;; ARG is the prefix arg. - ;; Filenames are absolute (VMS needs this for logical search paths). - ;; (car L) *must* be the *last* (bottommost) file in the dired buffer. - ;; That way as changes are made in the buffer they do not shift the - ;; lines still to be changed, so the (point) values in L stay valid. - ;; Also, for subdirs in natural order, a subdir's files are deleted - ;; before the subdir itself - the other way around would not work. - (save-excursion - (let ((files (mapcar (function car) l)) - (count (length l)) - (succ 0) - (cdir (dired-current-directory)) - failures) - ;; canonicalize file list for pop up - (setq files (nreverse (mapcar (function - (lambda (fn) - (dired-make-relative fn cdir t))) - files))) - (if (or (memq 'delete dired-no-confirm) - (dired-mark-pop-up - " *Files Flagged for Deletion*" 'delete files - dired-deletion-confirmer - (format "Delete %s " - (dired-mark-prompt arg files marker-char)))) - (save-excursion - ;; files better be in reverse order for this loop! - (while l - (goto-char (cdr (car l))) - (condition-case err - (let ((fn (car (car l)))) - ;; This test is equivalent to - ;; (and (file-directory-p fn) - ;; (not (file-symlink-p fn))) - ;; but more efficient - (if (if (eq t (car (file-attributes fn))) - (if (<= (length (directory-files fn)) 2) - (progn (delete-directory fn) t) - (and (or - (memq 'recursive-delete dired-no-confirm) - (funcall - dired-deletion-confirmer - (format "\ -Recursively delete directory and files within %s? " - (dired-make-relative fn)))) - (progn - (dired-recursive-delete-directory fn) - t))) - (progn (delete-file fn) t)) - (progn - (setq succ (1+ succ)) - (message "%s of %s deletions" succ count) - (dired-clean-up-after-deletion fn)))) - (error;; catch errors from failed deletions - (dired-log (buffer-name (current-buffer)) "%s\n" err) - (setq failures (cons (car (car l)) failures)))) - (setq l (cdr l))))) - (if failures - (dired-log-summary - (buffer-name (current-buffer)) - (format "%d of %d deletion%s failed:" (length failures) count - (dired-plural-s count)) - failures) - (if (zerop succ) - (message "(No deletions performed)") - (message "%d deletion%s done" succ (dired-plural-s succ))))))) - -(defun dired-recursive-delete-directory (fn) - ;; Recursively deletes directory FN, and all of its contents. - (let* ((fn (expand-file-name fn)) - (handler (find-file-name-handler - fn 'dired-recursive-delete-directory))) - (if handler - (funcall handler 'dired-recursive-delete-directory fn) - (progn - (or (file-exists-p fn) - (signal - 'file-error - (list "Removing old file name" "no such directory" fn))) - ;; Which is better, -r or -R? - (call-process "rm" nil nil nil "-r" (directory-file-name fn)) - (and (file-exists-p fn) - (error "Failed to recusively delete %s" fn)))))) - -(defun dired-clean-up-after-deletion (fn) - ;; Offer to kill buffer of deleted file FN. - (let ((buf (get-file-buffer fn))) - (and buf - (or (memq 'kill-file-buffer dired-no-confirm) - (funcall (function yes-or-no-p) - (format "Kill buffer of %s, too? " - (file-name-nondirectory fn)))) - (save-excursion ; you never know where kill-buffer leaves you - (kill-buffer buf))))) - -;;; Cleaning a directory -- flagging backups for deletion - -(defun dired-clean-directory (keep &optional marker msg) - "Flag numerical backups for deletion. -Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. -Positive prefix arg KEEP overrides `dired-kept-versions'; -Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. - -To clear the flags on these files, you can use \\[dired-flag-backup-files] -with a prefix argument." - (interactive "P") - (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) - (let* ((early-retention (if (< keep 0) (- keep) kept-old-versions)) - (late-retention (if (<= keep 0) dired-kept-versions keep)) - (msg (or msg - (format - "Cleaning numerical backups (keeping %d late, %d old)" - late-retention early-retention))) - (trample-marker (or marker dired-del-marker)) - (file-version-assoc-list)) - (message "%s..." msg) - ;; Do this after messaging, as it may take a while. - (setq file-version-assoc-list (dired-collect-file-versions)) - ;; Sort each VERSION-NUMBER-LIST, - ;; and remove the versions to be deleted. - (let ((fval file-version-assoc-list)) - (while fval - (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) - (v-count (length sorted-v-list))) - (if (> v-count (+ early-retention late-retention)) - (rplacd (nthcdr early-retention sorted-v-list) - (nthcdr (- v-count late-retention) - sorted-v-list))) - (rplacd (car fval) - (cdr sorted-v-list))) - (setq fval (cdr fval)))) - ;; Look at each file. If it is a numeric backup file, - ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. - (dired-map-dired-file-lines (function - (lambda (fn) - (dired-trample-file-versions - fn file-version-assoc-list - trample-marker)))) - (message "%s...done" msg))) - -(defun dired-collect-file-versions () - ;; If it looks like a file has versions, return a list of the versions. - ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) - (let (result) - (dired-map-dired-file-lines - (function - (lambda (fn) - (let* ((base-versions - (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn)))) - (if possibilities - (setq result (cons (cons fn - (mapcar 'backup-extract-version - possibilities)) result))))))) - result)) - -(defun dired-trample-file-versions (fn alist marker) - ;; ALIST is an alist of filenames and versions used to determine - ;; if each file should be flagged for deletion. - ;; This version using file-name-sans-versions is probably a lot slower - ;; than Sebastian's original, but it is more easily adaptable to non-unix. - (let ((base (file-name-sans-versions fn)) - base-version-list bv-length) - (and (not (string-equal base fn)) - (setq base-version-list (assoc base alist)) - (setq bv-length (string-match "[0-9]" fn (length base))) - (not (memq (backup-extract-version fn) base-version-list)) - (progn (skip-chars-backward "^\n\r") - (bolp)) ; make sure the preceding char isn't \r. - (dired-substitute-marker (point) (following-char) marker)))) - -(defun dired-map-dired-file-lines (fun) - ;; Perform FUN with point at the end of each non-directory line. - ;; FUN takes one argument, the filename (complete pathname). - (dired-check-ls-l) - (save-excursion - (let (file buffer-read-only) - (goto-char (point-min)) - (while (not (eobp)) - (save-excursion - (and (not (and dired-re-dir (looking-at dired-re-dir))) - (not (memq (following-char) '(?\n ?\n))) - (setq file (dired-get-filename nil t)) ; nil on non-file - (progn (skip-chars-forward "^\n\r") - (funcall fun file)))) - (forward-line 1))))) ; this guarantees that we don't - ; operate on omitted files. - - -;;;; ----------------------------------------------------------- -;;;; Confirmations and prompting the user. -;;;; ----------------------------------------------------------- - -(defun dired-plural-s (count) - (if (= 1 count) "" "s")) - -(defun dired-mark-prompt (arg files &optional marker-char) - ;; Return a string for use in a prompt, either the current file - ;; name, or the marker and a count of marked files. - (let ((count (length files))) - (if (= count 1) - (car files) - ;; more than 1 file: - (if (integerp arg) - (cond ((zerop arg) "[no files]") - ((> arg 0) "[following]") - ((< arg 0) "[preceding]")) - (char-to-string (or marker-char dired-marker-char)))))) - -(defun dired-pop-to-buffer (buf) - ;; Pop up buffer BUF. - ;; Make its window fit its contents. - (let ((window (selected-window)) - target-lines w2) - (cond ;; if split-window-threshold is enabled, use the largest window - ((and (> (window-height (setq w2 (get-largest-window))) - split-height-threshold) - (= (frame-width) (window-width w2))) - (setq window w2)) - ;; if the least-recently-used window is big enough, use it - ((and (> (window-height (setq w2 (get-lru-window))) - (* 2 window-min-height)) - (= (frame-width) (window-width w2))) - (setq window w2))) - (save-excursion - (set-buffer buf) - (goto-char (point-max)) - (skip-chars-backward "\n\r\t ") - (setq target-lines (count-lines (point-min) (point))) - ;; Don't forget to count the last line. - (if (not (bolp)) - (setq target-lines (1+ target-lines)))) - (if (<= (window-height window) (* 2 window-min-height)) - ;; At this point, every window on the frame is too small to split. - (setq w2 (display-buffer buf)) - (setq w2 (split-window - window - (max window-min-height - (- (window-height window) - (1+ (max window-min-height target-lines))))))) - (set-window-buffer w2 buf) - (if (< (1- (window-height w2)) target-lines) - (progn - (select-window w2) - (enlarge-window (- target-lines (1- (window-height w2)))))) - (set-window-start w2 1))) - -(defun dired-mark-pop-up (bufname op-symbol files function &rest args) - ;; Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS. - ;; Return FUNCTION's result on ARGS after popping up a window (in a buffer - ;; named BUFNAME, nil gives \" *Marked Files*\") showing the marked - ;; files. Uses function `dired-pop-to-buffer' to do that. - ;; FUNCTION should not manipulate files. - ;; It should only read input (an argument or confirmation). - ;; The window is not shown if there is just one file or - ;; OP-SYMBOL is a member of the list in `dired-no-confirm'. - ;; FILES is the list of marked files. - (if (memq op-symbol dired-no-confirm) - (apply function args) - (or bufname (setq bufname " *Marked Files*")) - (if (<= (length files) 1) - (apply function args) - (save-excursion - (let ((standard-output (set-buffer (get-buffer-create bufname)))) - (erase-buffer) - (dired-format-columns-of-files files) - (dired-remove-text-properties (point-min) (point-max)) - (setq mode-line-format (format " %s [%d files]" - bufname (length files))))) - (save-window-excursion - (dired-pop-to-buffer bufname) - (apply function args))))) - -(defun dired-column-widths (columns list &optional across) - ;; Returns the column widths for breaking LIST into - ;; COLUMNS number of columns. - (cond - ((null list) - nil) - ((= columns 1) - (list (apply 'max (mapcar 'length list)))) - ((let* ((len (length list)) - (col-length (/ len columns)) - (remainder (% len columns)) - (i 0) - (j 0) - (max-width 0) - widths padding) - (if (zerop remainder) - (setq padding 0) - (setq col-length (1+ col-length) - padding (- columns remainder))) - (setq list (nconc (copy-sequence list) (make-list padding nil))) - (setcdr (nthcdr (1- (+ len padding)) list) list) - (while (< i columns) - (while (< j col-length) - (setq max-width (max max-width (length (car list))) - list (if across (nthcdr columns list) (cdr list)) - j (1+ j))) - (setq widths (cons (+ max-width 2) widths) - max-width 0 - j 0 - i (1+ i)) - (if across (setq list (cdr list)))) - (setcar widths (- (car widths) 2)) - (nreverse widths))))) - -(defun dired-calculate-columns (list &optional across) - ;; Returns a list of integers which are the column widths that best pack - ;; LIST, a list of strings, onto the screen. - (and list - (let* ((width (1- (window-width))) - (columns (max 1 (/ width - (+ 2 (apply 'max (mapcar 'length list)))))) - col-list last-col-list) - (while (<= (apply '+ (setq col-list - (dired-column-widths columns list across))) - width) - (setq columns (1+ columns) - last-col-list col-list)) - (or last-col-list col-list)))) - -(defun dired-format-columns-of-files (files &optional across) - ;; Returns the number of lines used. - ;; If ACROSS is non-nil, sorts across rather than down the buffer, like - ;; ls -x - (and files - (let* ((columns (dired-calculate-columns files across)) - (ncols (length columns)) - (ncols1 (1- ncols)) - (nfiles (length files)) - (nrows (+ (/ nfiles ncols) - (if (zerop (% nfiles ncols)) 0 1))) - (space-left (- (window-width) (apply '+ columns) 1)) - (i 0) - (j 0) - file padding stretch float-stretch) - (if (zerop ncols1) - (setq stretch 0 - float-stretch 0) - (setq stretch (/ space-left ncols1) - float-stretch (% space-left ncols1))) - (setq files (nconc (copy-sequence files) ; fill up with empty fns - (make-list (- (* ncols nrows) nfiles) ""))) - (setcdr (nthcdr (1- (length files)) files) files) ; make circular - (while (< j nrows) - (while (< i ncols) - (princ (setq file (car files))) - (setq padding (- (nth i columns) (length file))) - (or (= i ncols1) - (progn - (setq padding (+ padding stretch)) - (if (< i float-stretch) (setq padding (1+ padding))))) - (princ (make-string padding ?\ )) - (setq files (if across (cdr files) (nthcdr nrows files)) - i (1+ i))) - (princ "\n") - (setq i 0 - j (1+ j)) - (or across (setq files (cdr files)))) - nrows))) - -(defun dired-query (qs-var qs-prompt &rest qs-args) - ;; Query user and return nil or t. - ;; Store answer in symbol VAR (which must initially be bound to nil). - ;; Format PROMPT with ARGS. - ;; Binding variable help-form will help the user who types C-h. - (let* ((char (symbol-value qs-var)) - (action (cdr (assoc char dired-query-alist)))) - (cond ((eq 'yes action) - t) ; accept, and don't ask again - ((eq 'no action) - nil) ; skip, and don't ask again - (t;; no lasting effects from last time we asked - ask now - (let ((qprompt (concat qs-prompt - (if help-form - (format " [yn!q or %s] " - (key-description - (char-to-string help-char))) - " [ynq or !] "))) - (dired-in-query t) - elt) - ;; Actually it looks nicer without cursor-in-echo-area - you can - ;; look at the dired buffer instead of at the prompt to decide. - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char))) - (while (not (setq elt (assoc char dired-query-alist))) - (message "Invalid char - type %c for help." help-char) - (ding) - (sit-for 1) - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char)))) - (memq (cdr elt) '(t y yes))))))) - -(defun dired-mark-confirm (op-symbol operation arg) - ;; Request confirmation from the user that the operation described - ;; by OP-SYMBOL is to be performed on the marked files. - ;; Confirmation consists in a y-or-n question with a file list - ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. - ;; OPERATION is a string describing the operation. Used for prompting - ;; the user. - ;; The files used are determined by ARG (like in dired-get-marked-files). - (or (memq op-symbol dired-no-confirm) - (let ((files (dired-get-marked-files t arg))) - (dired-mark-pop-up nil op-symbol files (function y-or-n-p) - (concat operation " " - (dired-mark-prompt arg files) "? "))))) - -(defun dired-mark-read-file-name (prompt dir op-symbol arg files) - (dired-mark-pop-up - nil op-symbol files - (function read-file-name) - (format prompt (dired-mark-prompt arg files)) dir)) - -(defun dired-mark-read-string (prompt initial op-symbol arg files - &optional history-sym) - ;; Reading arguments with history. - ;; Read arguments for a mark command of type OP-SYMBOL, - ;; perhaps popping up the list of marked files. - ;; ARG is the prefix arg and indicates whether the files came from - ;; marks (ARG=nil) or a repeat factor (integerp ARG). - ;; If the current file was used, the list has but one element and ARG - ;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). - ;; PROMPT for a string, with INITIAL input. - (dired-mark-pop-up - nil op-symbol files - (function - (lambda (prompt initial) - (let ((hist (or history-sym - (cdr (assq op-symbol dired-op-history-alist)) - 'dired-history))) - (dired-read-with-history prompt initial hist)))) - (format prompt (dired-mark-prompt arg files)) initial)) - - -;;;; ---------------------------------------------------------- -;;;; Marking files. -;;;; ---------------------------------------------------------- - -(defun dired-mark (arg &optional char) - "Mark the current (or next ARG) files. -If on a subdir headerline, mark all its files except `.' and `..'. - -Use \\[dired-unmark-all-files] to remove all marks, -and \\[dired-unmark] to remove the mark of the current file." - (interactive "p") - (if (dired-get-subdir) - (dired-mark-subdir-files char) - (dired-mark-file arg char))) - -(defun dired-mark-file (arg &optional char) - "Mark ARG files starting from the current file line. -Optional CHAR indicates a marker character to use." - (let (buffer-read-only) - (if (memq (or char dired-marker-char) '(?\ ?\n ?\r)) - (error "Invalid marker character %c" dired-marker-char)) - (or char (setq char dired-marker-char)) - (dired-repeat-over-lines - arg - (function - (lambda () - (dired-update-marker-counters (following-char) t) - (dired-substitute-marker (point) (following-char) char) - (dired-update-marker-counters char)))) - (dired-update-mode-line-modified))) - -(defun dired-mark-subdir-files (&optional char) - "Mark all files except `.' and `..'." - (interactive) - (save-excursion - (dired-mark-files-in-region (dired-subdir-min) (dired-subdir-max) char))) - -(defun dired-unmark (arg) - "Unmark the current (or next ARG) files. -If looking at a subdir, unmark all its files except `.' and `..'." - (interactive "p") - (let (buffer-read-only) - (dired-repeat-over-lines - arg - (function - (lambda () - (let ((char (following-char))) - (or (memq char '(?\ ?\n ?\r)) - (progn - (cond - ((char-equal char dired-marker-char) - (setq dired-marks-number (max (1- dired-marks-number) 0))) - ((char-equal char dired-del-marker) - (setq dired-del-flags-number - (max (1- dired-del-flags-number) 0))) - ((setq dired-other-marks-number - (max (1- dired-other-marks-number) 0)))) - (dired-substitute-marker (point) char ?\ ))))))) - (dired-update-mode-line-modified))) - -(defun dired-mark-prefix (&optional arg) - "Mark the next ARG files with the next character typed. -If ARG is negative, marks the previous files." - (interactive "p") - (if (sit-for echo-keystrokes) - (cond - ((or (= arg 1) (zerop arg)) - (message "Mark with character?")) - ((< arg 0) - (message "Mark %d file%s moving backwards?" - (- arg) (dired-plural-s (- arg)))) - ((> arg 1) - (message "Mark %d following files with character?" arg)))) - (dired-mark arg (read-char))) - -(defun dired-change-marks (old new) - "Change all OLD marks to NEW marks. -OLD and NEW are both characters used to mark files. -With a prefix, prompts for a mark to toggle. In other words, all unmarked -files receive that mark, and all files currently marked with that mark become -unmarked." - ;; When used in a lisp program, setting NEW to nil means toggle the mark OLD. - (interactive - (let* ((cursor-in-echo-area t) - (old nil) - (new nil) - (markers (dired-mark-list)) - (default (cond ((null markers) - (error "No markers in buffer")) - ((= (length markers) 1) - (setq old (car markers))) - ((memq dired-marker-char markers) - dired-marker-char) - ;; picks the last one in the buffer. reasonable? - ((car markers))))) - (or old (setq old - (progn - (if current-prefix-arg - (message "Toggle mark (default %c): " default) - (message "Change old mark (default %c): " default)) - (read-char)))) - (if (memq old '(?\ ?\n ?\r)) (setq old default)) - (or current-prefix-arg - (setq new (progn - (message - "Change %c marks to new mark (RET means abort): " old) - (read-char)))) - (list old new))) - (let ((old-count (cond - ((char-equal old dired-marker-char) - 'dired-marks-number) - ((char-equal old dired-del-marker) - 'dired-del-flags-number) - ('dired-other-marks-number)))) - (if new - (or (memq new '(?\ ?\n ?\r)) - ;; \n and \r aren't valid marker chars. Assume that if the - ;; user hits return, he meant to abort the command. - (let ((string (format "\n%c" old)) - (new-count (cond - ((char-equal new dired-marker-char) - 'dired-marks-number) - ((char-equal new dired-del-marker) - 'dired-del-flags-number) - ('dired-other-marks-number))) - (buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (while (search-forward string nil t) - (if (char-equal (preceding-char) old) - (progn - (dired-substitute-marker (1- (point)) old new) - (set new-count (1+ (symbol-value new-count))) - (set old-count (max (1- (symbol-value old-count)) 0)))) - )))) - (save-excursion - (let ((ucount 0) - (mcount 0) - (buffer-read-only nil)) - (goto-char (point-min)) - (while (not (eobp)) - (or (dired-between-files) - (looking-at dired-re-dot) - (cond - ((= (following-char) ?\ ) - (setq mcount (1+ mcount)) - (set old-count (1+ (symbol-value old-count))) - (dired-substitute-marker (point) ?\ old)) - ((= (following-char) old) - (setq ucount (1+ ucount)) - (set old-count (max (1- (symbol-value old-count)) 0)) - (dired-substitute-marker (point) old ?\ )))) - (forward-line 1)) - (message "Unmarked %d file%s; marked %d file%s with %c." - ucount (dired-plural-s ucount) mcount - (dired-plural-s mcount) old))))) - (dired-update-mode-line-modified)) - -(defun dired-unmark-all-files (flag &optional arg) - "Remove a specific mark or any mark from every file. -With prefix arg, query for each marked file. -Type \\[help-command] at that time for help. -With a zero prefix, only counts the number of marks." - (interactive - (let* ((cursor-in-echo-area t) - executing-kbd-macro) ; for XEmacs - (list (and (not (eq current-prefix-arg 0)) - (progn (message "Remove marks (RET means all): ") (read-char))) - current-prefix-arg))) - (save-excursion - (let* ((help-form "\ -Type SPC or `y' to unflag one file, DEL or `n' to skip to next, -`!' to unflag all remaining files with no more questions.") - (allp (memq flag '(?\n ?\r))) - (count-p (eq arg 0)) - (count (if (or allp count-p) - (mapcar - (function - (lambda (elt) - (cons elt 0))) - (nreverse (dired-mark-list))) - 0)) - (msg "") - (no-query (or (not arg) count-p)) - buffer-read-only case-fold-search query) - (goto-char (point-min)) - (if (or allp count-p) - (while (re-search-forward dired-re-mark nil t) - (if (or no-query - (dired-query 'query "Unmark file `%s'? " - (dired-get-filename t))) - (let ((ent (assq (preceding-char) count))) - (if ent (setcdr ent (1+ (cdr ent)))) - (or count-p (dired-substitute-marker - (- (point) 1) (preceding-char) ?\ )))) - (forward-line 1)) - (while (search-forward (format "\n%c" flag) nil t) - (if (or no-query - (dired-query 'query "Unmark file `%s'? " - (dired-get-filename t))) - (progn - (dired-substitute-marker (match-beginning 0) flag ?\ ) - (setq count (1+ count)))))) - (if (or allp count-p) - (mapcar - (function - (lambda (elt) - (or (zerop (cdr elt)) - (setq msg (format "%s%s%d %c%s" - msg - (if (zerop (length msg)) - " " - ", ") - (cdr elt) - (car elt) - (if (= 1 (cdr elt)) "" "'s")))))) - count) - (or (zerop count) - (setq msg (format " %d %c%s" - count flag (if (= 1 count) "" "'s"))))) - (if (zerop (length msg)) - (setq msg " none") - (or count-p (dired-update-mode-line-modified t))) - (message "%s:%s" (if count-p "Number of marks" "Marks removed") msg)))) - -(defun dired-get-marked-files (&optional localp arg) - "Return the marked files' names as list of strings. -The list is in the same order as the buffer, that is, the car is the - first marked file. -Values returned are normally absolute pathnames. -Optional arg LOCALP as in `dired-get-filename'. -Optional second argument ARG forces to use other files. If ARG is an - integer, use the next ARG files. If ARG is otherwise non-nil, use - current file. Usually ARG comes from the current prefix arg." - (save-excursion - (nreverse (dired-map-over-marks (dired-get-filename localp) arg)))) - -;;; Utility functions for marking files - -(defun dired-mark-files-in-region (start end &optional char) - (let (buffer-read-only) - (if (> start end) - (error "start > end")) - (goto-char start) ; assumed at beginning of line - (or char (setq char dired-marker-char)) - (while (< (point) end) - ;; Skip subdir line and following garbage like the `total' line: - (while (and (< (point) end) (dired-between-files)) - (forward-line 1)) - (if (and (/= (following-char) char) - (not (looking-at dired-re-dot)) - (save-excursion - (dired-move-to-filename nil (point)))) - (progn - (dired-update-marker-counters (following-char) t) - (dired-substitute-marker (point) (following-char) char) - (dired-update-marker-counters char))) - (forward-line 1))) - (dired-update-mode-line-modified)) - -(defun dired-mark-list () - ;; Returns a list of all marks currently used in the buffer. - (let ((result nil) - char) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (and (not (memq (setq char (following-char)) '(?\ ?\n ?\r))) - (not (memq char result)) - (setq result (cons char result))) - (forward-line 1))) - result)) - -;;; Dynamic markers - -(defun dired-set-current-marker-string () - "Computes and returns `dired-marker-string'." - (prog1 - (setq dired-marker-string - (if dired-marker-stack - (let* ((n (+ (length dired-marker-stack) 5)) - (str (make-string n ?\ )) - (list dired-marker-stack) - (pointer dired-marker-stack-pointer)) - (setq n (1- n)) - (aset str n ?\]) - (setq n (1- n)) - (while list - (aset str n (car list)) - (if (zerop pointer) - (progn - (setq n (1- n)) - (aset str n dired-marker-stack-cursor))) - (setq n (1- n) - pointer (1- pointer) - list (cdr list))) - (aset str n dired-default-marker) - (if (zerop pointer) - (aset str 2 dired-marker-stack-cursor)) - (aset str 1 ?\[) - str) - "")) - (set-buffer-modified-p (buffer-modified-p)))) - -(defun dired-set-marker-char (c) - "Set the marker character to something else. -Use \\[dired-restore-marker-char] to restore the previous value." - (interactive "cNew marker character: ") - (and (memq c '(?\ ?\n ?\r)) (error "invalid marker char %c" c)) - (setq dired-marker-stack (cons c dired-marker-stack) - dired-marker-stack-pointer 0 - dired-marker-char c) - (dired-update-mode-line-modified t) - (dired-set-current-marker-string)) - -(defun dired-restore-marker-char () - "Restore the marker character to its previous value. -Uses `dired-default-marker' if the marker stack is empty." - (interactive) - (setq dired-marker-stack (cdr dired-marker-stack) - dired-marker-char (car dired-marker-stack) - dired-marker-stack-pointer (min dired-marker-stack-pointer - (length dired-marker-stack))) - (or dired-marker-char - (setq dired-marker-char dired-default-marker)) - (dired-set-current-marker-string) - (dired-update-mode-line-modified t) - (or dired-marker-stack (message "Marker is %c" dired-marker-char))) - -(defun dired-marker-stack-left (n) - "Moves the marker stack cursor to the left." - (interactive "p") - (let ((len (1+ (length dired-marker-stack)))) - (or dired-marker-stack (error "Dired marker stack is empty.")) - (setq dired-marker-stack-pointer - (% (+ dired-marker-stack-pointer n) len)) - (if (< dired-marker-stack-pointer 0) - (setq dired-marker-stack-pointer (+ dired-marker-stack-pointer - len))) - (dired-set-current-marker-string) - (setq dired-marker-char - (if (= dired-marker-stack-pointer (1- len)) - dired-default-marker - (nth dired-marker-stack-pointer dired-marker-stack)))) - (dired-update-mode-line-modified t)) - -(defun dired-marker-stack-right (n) - "Moves the marker stack cursor to the right." - (interactive "p") - (dired-marker-stack-left (- n))) - -;;; Commands to mark or flag files based on their characteristics or names. - -(defun dired-mark-symlinks (&optional unflag-p) - "Mark all symbolic links. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-sym) "symbolic link")) - (dired-update-mode-line-modified t)) - -(defun dired-mark-directories (&optional unflag-p) - "Mark all directory file lines except `.' and `..'. -With prefix argument, unflag all those files." - (interactive "P") - (if dired-re-dir - (progn - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (and (looking-at dired-re-dir) - (not (looking-at dired-re-dot))) - "directory file")))) - (dired-update-mode-line-modified t)) - -(defun dired-mark-executables (&optional unflag-p) - "Mark all executable files. -With prefix argument, unflag all those files." - (interactive "P") - (if dired-re-exe - (progn - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-exe) "executable file")))) - (dired-update-mode-line-modified t)) - -(defun dired-flag-backup-files (&optional unflag-p) - "Flag all backup files (names ending with `~') for deletion. -With prefix argument, unflag these files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - (and (not (and dired-re-dir (looking-at dired-re-dir))) - (let ((fn (dired-get-filename t t))) - (if fn (backup-file-name-p fn)))) - "backup file")) - (dired-update-mode-line-modified t)) - -(defun dired-flag-auto-save-files (&optional unflag-p) - "Flag for deletion files whose names suggest they are auto save files. -A prefix argument says to unflag those files instead." - (interactive "P") - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - ;; It is less than general to check for ~ here, - ;; but it's the only way this runs fast enough. - (and (save-excursion (end-of-line) - (eq (preceding-char) ?#)) - (not (and dired-re-dir (looking-at dired-re-dir))) - (let ((fn (dired-get-filename t t))) - (if fn (auto-save-file-name-p - (file-name-nondirectory fn))))) - "auto save file")) - (dired-update-mode-line-modified t)) - -(defun dired-mark-rcs-files (&optional unflag-p) - "Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - ;; Returns failures, or nil on success. - ;; Finding those with locks would require to peek into the ,v file, - ;; depends slightly on the RCS version used and should be done - ;; together with the Emacs RCS interface. - ;; Unfortunately, there is no definitive RCS interface yet. - (interactive "P") - (message "%sarking RCS controlled files..." (if unflag-p "Unm" "M")) - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - rcs-files wf failures count total) - (mapcar ; loop over subdirs - (function - (lambda (dir) - (or (equal (file-name-nondirectory (directory-file-name dir)) - "RCS") - ;; skip inserted RCS subdirs - (setq rcs-files - (append (directory-files dir t ",v\\'") ; *,v and RCS/*,v - (let ((rcs-dir (expand-file-name "RCS" dir))) - (if (file-directory-p rcs-dir) - (mapcar ; working files from ./RCS are in ./ - (function - (lambda (x) - (expand-file-name x dir))) - (directory-files - (file-name-as-directory rcs-dir) - nil ",v\\'")))) - rcs-files))))) - (mapcar (function car) dired-subdir-alist)) - (setq total (length rcs-files)) - (while rcs-files - (setq wf (substring (car rcs-files) 0 -2) - rcs-files (cdr rcs-files)) - (save-excursion (if (dired-goto-file wf) - (dired-mark 1) ; giving a prefix avoids checking - ; for subdir line. - (setq failures (cons wf failures))))) - (dired-update-mode-line-modified t) - (if (null failures) - (message "%d RCS file%s %smarked." - total (dired-plural-s total) (if unflag-p "un" "")) - (setq count (length failures)) - (dired-log-summary (buffer-name (current-buffer)) - "RCS working file not found %s" failures) - (message "%d RCS file%s: %d %smarked - %d not found %s." - total (dired-plural-s total) (- total count) - (if unflag-p "un" "") count failures)) - failures)) - - -;;;; ------------------------------------------------------------ -;;;; Logging failures -;;;; ------------------------------------------------------------ - -(defun dired-why () - "Pop up a buffer with error log output from Dired. -A group of errors from a single command ends with a formfeed. -Thus, use \\[backward-page] to find the beginning of a group of errors." - (interactive) - (if (get-buffer dired-log-buffer) - (let ((owindow (selected-window)) - (window (display-buffer (get-buffer dired-log-buffer)))) - (unwind-protect - (progn - (select-window window) - (goto-char (point-max)) - (recenter -1)) - (select-window owindow))))) - -(defun dired-log (buffer-name log &rest args) - ;; Log a message or the contents of a buffer. - ;; BUFFER-NAME is the name of the dired buffer to which the message applies. - ;; If LOG is a string and there are more args, it is formatted with - ;; those ARGS. Usually the LOG string ends with a \n. - ;; End each bunch of errors with (dired-log t): this inserts - ;; current time and buffer, and a \f (formfeed). - (or (stringp buffer-name) (setq buffer-name (buffer-name buffer-name))) - (let ((obuf (current-buffer))) - (unwind-protect ; want to move point - (progn - (set-buffer (get-buffer-create dired-log-buffer)) - (goto-char (point-max)) - (let (buffer-read-only) - (cond ((stringp log) - (insert (if args - (apply (function format) log args) - log))) - ((bufferp log) - (insert-buffer log)) - ((eq t log) - (insert "\n\t" (current-time-string) - "\tBuffer `" buffer-name "'\n\f\n"))))) - (set-buffer obuf)))) - -(defun dired-log-summary (buffer-name string failures) - (message (if failures "%s--type y for details %s" - "%s--type y for details") - string failures) - ;; Log a summary describing a bunch of errors. - (dired-log buffer-name (concat "\n" string)) - (if failures (dired-log buffer-name "\n%s" failures)) - (dired-log buffer-name t)) - - -;;;; ------------------------------------------------------- -;;;; Sort mode of dired buffers. -;;;; ------------------------------------------------------- - -(defun dired-sort-type (list) - ;; Returns the sort type of LIST, as a symbol. - (let* ((list (reverse list)) - (alist (sort - (mapcar (function - (lambda (x) - (cons (length (memq (car x) list)) (cdr x)))) - dired-sort-type-alist) - (function - (lambda (x y) - (> (car x) (car y)))))) - (winner (car alist))) - (if (zerop (car winner)) - 'name - (cdr winner)))) - -(defun dired-sort-set-modeline (&optional switches) - ;; Set modeline display according to dired-internal-switches. - ;; Modeline display of "by name" or "by date" guarantees the user a - ;; match with the corresponding regexps. Non-matching switches are - ;; shown literally. - (or switches (setq switches dired-internal-switches)) - (setq dired-sort-mode - (if dired-show-ls-switches - (concat " " (dired-make-switches-string - (or switches dired-internal-switches))) - (concat " by " (and (memq ?r switches) "rev-") - (symbol-name (dired-sort-type switches))))) - ;; update mode line - (set-buffer-modified-p (buffer-modified-p))) - -(defun dired-sort-toggle-or-edit (&optional arg) - "Toggle between sort by date/name for the current subdirectory. - -With a 0 prefix argument, simply reports on the current switches. - -With a prefix 1 allows the ls switches for the current subdirectory to be -edited. - -With a prefix 2 allows the default ls switches for newly inserted -subdirectories to be edited. - -With a prefix \\[universal-argument] allows you to sort the entire -buffer by either name or date. - -With a prefix \\[universal-argument] \\[universal-argument] allows the default switches -for the entire buffer to be edited, and then reverts the buffer so that all -subdirectories are sorted according to these switches. - -Note that although dired allows different ls switches to be used for -different subdirectories, certain combinations of ls switches are incompatible. -If incompatible switches are detected, dired will offer to revert the buffer -to force the ls switches for all subdirectories to a single value. If you -refuse to revert the buffer, any change of ls switches will be aborted." - (interactive "P") - (cond - ((eq arg 0) - ;; Report on switches - (message "Switches for current subdir: %s. Default for buffer: %s." - (dired-make-switches-string - (nth 3 (assoc (dired-current-directory) dired-subdir-alist))) - (dired-make-switches-string dired-internal-switches))) - ((null arg) - ;; Toggle between sort by date/name. - (let* ((dir (dired-current-directory)) - (curr (nth 3 (assoc dir dired-subdir-alist)))) - (dired-sort-other - (if (eq (dired-sort-type curr) 'name) - (cons ?t curr) - (mapcar (function - (lambda (x) - (setq curr - (delq (car x) curr)))) - dired-sort-type-alist) - curr) - nil dir))) - ((eq arg 1) - ;; Edit switches for current subdir. - (let* ((dir (dired-current-directory)) - (switch-string - (read-string - "New ls switches for current subdir (must contain -l): " - (dired-make-switches-string - (nth 3 (assoc dir dired-subdir-alist))))) - (switches (dired-make-switches-list switch-string))) - (if (dired-compatible-switches-p switches dired-internal-switches) - (dired-sort-other switches nil dir) - (if (or - (memq 'sort-revert dired-no-confirm) - (y-or-n-p - (format - "Switches %s incompatible with default %s. Revert buffer? " - switch-string - (dired-make-switches-string dired-internal-switches)))) - (dired-sort-other switches nil nil) - (error "Switches unchanged. Remain as %s." switch-string))))) - ((eq arg 2) - ;; Set new defaults for subdirs inserted in the future. - (let* ((switch-string - (read-string - "Default ls switches for new subdirs (must contain -l): " - (dired-make-switches-string dired-internal-switches))) - (switches (dired-make-switches-list switch-string)) - (alist dired-subdir-alist) - x bad-switches) - (while alist - (setq x (nth 3 (car alist)) - alist (cdr alist)) - (or (dired-compatible-switches-p x switches) - (member x bad-switches) - (setq bad-switches (cons x bad-switches)))) - (if bad-switches - (if (or (memq 'sort-revert dired-no-confirm) - (y-or-n-p - (format - "Switches %s incompatible with %s. Revert buffer? " - switch-string (mapconcat 'dired-make-switches-string - bad-switches ", ")))) - (dired-sort-other switches nil nil) - (error "Default switches unchanged. Remain as %s." - (dired-make-switches-string dired-internal-switches))) - (dired-sort-other switches t nil)))) - ((or (equal arg '(4)) (eq arg 'date) (eq arg 'name)) - ;; Toggle the entire buffer name/data. - (let ((cursor-in-echo-area t) - (switches (copy-sequence dired-internal-switches)) - (type (and (symbolp arg) arg)) - char) - (while (null type) - (message "Sort entire buffer according to (n)ame or (d)ate? ") - (setq char (read-char) - type (cond - ((char-equal char ?d) 'date) - ((char-equal char ?n) 'name) - (t (message "Type one of n or d.") (sit-for 1) nil)))) - (mapcar (function - (lambda (x) - (setq switches - (delq (car x) switches)))) - dired-sort-type-alist) - (dired-sort-other - (if (eq type 'date) (cons ?t switches) switches) nil nil))) - ((equal arg '(16)) - ;; Edit the switches for the entire buffer. - (dired-sort-other - (dired-make-switches-list - (read-string - "Change ls switches for entire buffer to (must contain -l): " - (dired-make-switches-string dired-internal-switches))) - nil nil)) - (t - ;; No idea what's going on. - (error - "Invalid prefix. See %s dired-sort-toggle-or-edit." - (substitute-command-keys - (if (featurep 'ehelp) - "\\[electric-describe-function]" - "\\[describe-function]")))))) - -(defun dired-sort-other (switches &optional no-revert subdir) - ;; Specify new ls SWITCHES for current dired buffer. - ;; With optional second arg NO-REVERT, don't refresh the listing afterwards. - ;; If subdir is non-nil, only changes the switches for the - ;; sudirectory. - (if subdir - (let ((elt (assoc subdir dired-subdir-alist))) - (if elt (setcar (nthcdr 3 elt) switches))) - (setq dired-internal-switches switches)) - (or no-revert - (cond - - (subdir - (let ((ofile (dired-get-filename nil t)) - (opoint (point))) - (message "Relisting %s..." subdir) - (dired-insert-subdir subdir switches) - (message "Relisting %s... done" subdir) - (or (and ofile (dired-goto-file ofile)) (goto-char opoint)))) - - ((memq ?R switches) - ;; We are replacing a buffer with a giant recursive listing. - (let ((opoint (point)) - (ofile (dired-get-filename nil t)) - (hidden-subdirs (dired-remember-hidden)) - (mark-alist (dired-remember-marks (point-min) (point-max))) - (kill-files-p (save-excursion - (goto-char (point)) - (search-forward - (concat (char-to-string ?\r) - (regexp-quote - (char-to-string - dired-kill-marker-char))) - nil t))) - (omit-files (nth 2 (nth (1- (length dired-subdir-alist)) - dired-subdir-alist))) - buffer-read-only) - (dired-readin dired-directory (current-buffer) - (or (consp dired-directory) - (null (file-directory-p dired-directory)))) - (dired-mark-remembered mark-alist) ; mark files that were marked - (if kill-files-p (dired-do-hide dired-kill-marker-char)) - (if omit-files - (dired-omit-expunge nil t)) - ;; hide subdirs that were hidden - (save-excursion - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs)) - ;; Try to get back to where we were - (or (and ofile (dired-goto-file ofile)) - (goto-char opoint)) - (dired-move-to-filename))) - - (t - ;; Clear all switches in the subdir alist - (setq dired-subdir-alist - (mapcar (function - (lambda (x) - (setcar (nthcdr 3 x) nil) - x)) - dired-subdir-alist)) - (revert-buffer nil t)))) - (dired-update-mode-line t)) - -(defun dired-compatible-switches-p (list1 list2) - ;; Returns t if list1 and list2 are allowed as switches in the same - ;; dired buffer. - (and (eq (null (or (memq ?l list1) (memq ?o list1) (memq ?g list1))) - (null (or (memq ?l list2) (memq ?o list2) (memq ?g list2)))) - (eq (null (memq ?F list1)) (null (memq ?F list2))) - (eq (null (memq ?p list1)) (null (memq ?p list2))) - (eq (null (memq ?b list1)) (null (memq ?b list2))))) - -(defun dired-check-ls-l (&optional switches) - ;; Check for long-style listings - (let ((switches (or switches dired-internal-switches))) - (or (memq ?l switches) (memq ?o switches) (memq ?g switches) - (error "Dired needs -l, -o, or -g in ls switches")))) - - -;;;; -------------------------------------------------------------- -;;;; Creating new files. -;;;; -------------------------------------------------------------- -;;; -;;; The dired-create-files paradigm is used for copying, renaming, -;;; compressing, and making hard and soft links. - -(defun dired-file-marker (file) - ;; Return FILE's marker, or nil if unmarked. - (save-excursion - (and (dired-goto-file file) - (progn - (skip-chars-backward "^\n\r") - (and (not (= ?\040 (following-char))) - (following-char)))))) - -;; The basic function for half a dozen variations on cp/mv/ln/ln -s. -(defun dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char query - implicit-to) - ;; Create a new file for each from a list of existing files. The user - ;; is queried, dired buffers are updated, and at the end a success or - ;; failure message is displayed - - ;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists - ;; It is called for each file and must create newfile, the entry of - ;; which will be added. The user will be queried if the file already - ;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a - ;; rename), it is FILE-CREATOR's responsibility to update dired - ;; buffers. FILE-CREATOR must abort by signalling a file-error if it - ;; could not create newfile. The error is caught and logged. - - ;; OPERATION (a capitalized string, e.g. `Copy') describes the - ;; operation performed. It is used for error logging. - - ;; FN-LIST is the list of files to copy (full absolute pathnames). - - ;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to - ;; skip. If it skips files, it is supposed to tell why (using dired-log). - - ;; Optional MARKER-CHAR is a character with which to mark every - ;; newfile's entry, or t to use the current marker character if the - ;; oldfile was marked. - - ;; QUERY is a function to use to prompt the user about creating a file. - ;; It accepts two args, the from and to files, - ;; and must return nil or t. If QUERY is nil, then no user - ;; confirmation will be requested. - - ;; If IMPLICIT-TO is non-nil, then the file constructor does not take - ;; a to-file arg. e.g. compress. - - (let ((success-count 0) - (total (length fn-list)) - failures skipped overwrite-query) - ;; Fluid vars used for storing responses of previous queries must be - ;; initialized. - (dired-save-excursion - (setq dired-overwrite-backup-query nil - dired-file-creator-query nil) - (mapcar - (function - (lambda (from) - (let ((to (funcall name-constructor from))) - (if to - (if (equal to from) - (progn - (dired-log (buffer-name (current-buffer)) - "Cannot %s to same file: %s\n" - (downcase operation) from) - (setq skipped (cons (dired-make-relative from) skipped))) - (if (or (null query) - (funcall query from to)) - (let* ((overwrite (let (jka-compr-enabled) - ;; Don't let jka-compr fool us. - (file-exists-p to))) - ;; for dired-handle-overwrite - (dired-overwrite-confirmed - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite %s?" to)))) - ;; must determine if FROM is marked before - ;; file-creator gets a chance to delete it - ;; (in case of a move). - (actual-marker-char - (cond ((integerp marker-char) marker-char) - (marker-char (dired-file-marker from)) - (t nil)))) - (if (and overwrite (null dired-overwrite-confirmed)) - (setq skipped (cons (dired-make-relative from) - skipped)) - (condition-case err - (let ((dired-unhandle-add-files - (cons to dired-unhandle-add-files))) - (if implicit-to - (funcall file-creator from - dired-overwrite-confirmed) - (funcall file-creator from to - dired-overwrite-confirmed)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" - operation success-count total) - (dired-add-file to actual-marker-char)) - (file-error ; FILE-CREATOR aborted - (progn - (setq failures (cons (dired-make-relative from) - failures)) - (dired-log (buffer-name (current-buffer)) - "%s `%s' to `%s' failed:\n%s\n" - operation from to err)))))) - (setq skipped (cons (dired-make-relative from) skipped)))) - (setq skipped (cons (dired-make-relative from) skipped)))))) - fn-list) - (cond - (failures - (dired-log-summary - (buffer-name (current-buffer)) - (format "%s failed for %d of %d file%s" - operation (length failures) total - (dired-plural-s total)) failures)) - (skipped - (dired-log-summary - (buffer-name (current-buffer)) - (format "%s: %d of %d file%s skipped" - operation (length skipped) total - (dired-plural-s total)) skipped)) - (t - (message "%s: %s file%s." - operation success-count (dired-plural-s success-count))))))) - -(defun dired-do-create-files (op-symbol file-creator operation arg - &optional marker-char - prompter how-to) - ;; Create a new file for each marked file. - ;; Prompts user for target, which is a directory in which to create - ;; the new files. Target may be a plain file if only one marked - ;; file exists. - ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' - ;; will determine wether pop-ups are appropriate for this OP-SYMBOL. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-get-marked-files. - ;; PROMPTER is a function of one-arg, the list of files, to return a prompt - ;; to use for dired-read-file-name. If it is nil, then a default prompt - ;; will be used. - ;; Optional arg MARKER-CHAR as in dired-create-files. - ;; Optional arg HOW-TO determines how to treat target: - ;; If HOW-TO is not given (or nil), and target is a directory, the - ;; file(s) are created inside the target directory. If target - ;; is not a directory, there must be exactly one marked file, - ;; else error. - ;; If HOW-TO is t, then target is not modified. There must be - ;; exactly one marked file, else error. - ;; Else HOW-TO is assumed to be a function of one argument, target, - ;; that looks at target and returns a value for the into-dir - ;; variable. The function dired-into-dir-with-symlinks is provided - ;; for the case (common when creating symlinks) that symbolic - ;; links to directories are not to be considered as directories - ;; (as file-directory-p would if HOW-TO had been nil). - - (let* ((fn-list (dired-get-marked-files nil arg)) - (fn-count (length fn-list)) - (cdir (dired-current-directory)) - (target (expand-file-name - (dired-mark-read-file-name - (if prompter - (funcall prompter fn-list) - (concat operation " %s to: ")) - (dired-dwim-target-directory) - op-symbol arg (mapcar (function - (lambda (fn) - (dired-make-relative fn cdir t))) - fn-list)))) - (into-dir (cond ((null how-to) (file-directory-p target)) - ((eq how-to t) nil) - (t (funcall how-to target))))) - (if (and (> fn-count 1) - (not into-dir)) - (error "Marked %s: target must be a directory: %s" operation target)) - ;; rename-file bombs when moving directories unless we do this: - (or into-dir (setq target (directory-file-name target))) - (dired-create-files - file-creator operation fn-list - (if into-dir ; target is a directory - (list 'lambda '(from) - (list 'expand-file-name '(file-name-nondirectory from) target)) - (list 'lambda '(from) target)) - marker-char))) - -(defun dired-into-dir-with-symlinks (target) - (and (file-directory-p target) - (not (file-symlink-p target)))) -;; This may not always be what you want, especially if target is your -;; home directory and it happens to be a symbolic link, as is often the -;; case with NFS and automounters. Or if you want to make symlinks -;; into directories that themselves are only symlinks, also quite -;; common. -;; So we don't use this function as value for HOW-TO in -;; dired-do-symlink, which has the minor disadvantage of -;; making links *into* a symlinked-dir, when you really wanted to -;; *overwrite* that symlink. In that (rare, I guess) case, you'll -;; just have to remove that symlink by hand before making your marked -;; symlinks. - -(defun dired-handle-overwrite (to) - ;; Save old version of a to be overwritten file TO. - ;; `dired-overwrite-confirmed' and `dired-overwrite-backup-query' - ;; are fluid vars from dired-create-files. - (if (and dired-backup-if-overwrite - dired-overwrite-confirmed - (or (eq 'always dired-backup-if-overwrite) - (dired-query 'dired-overwrite-backup-query - (format "Make backup for existing file `%s'? " to)))) - (let ((backup (car (find-backup-file-name to)))) - (rename-file to backup 0)))) ; confirm overwrite of old backup - -(defun dired-dwim-target-directory () - ;; Try to guess which target directory the user may want. - ;; If there is a dired buffer displayed in the next window, use - ;; its current subdir, else use current subdir of this dired buffer. - ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode - (let* ((this-dir (and (eq major-mode 'dired-mode) - (dired-current-directory))) - (dwimmed - (if dired-dwim-target - (let* ((other-buf (window-buffer (next-window))) - (other-dir (save-excursion - (set-buffer other-buf) - (and (eq major-mode 'dired-mode) - (dired-current-directory))))) - (or other-dir this-dir)) - this-dir))) - (and dwimmed (dired-abbreviate-file-name dwimmed)))) - -(defun dired-get-target-directory () - "Writes a copy of the current subdirectory into an active minibuffer." - (interactive) - (let ((mb (dired-get-active-minibuffer-window))) - (if mb - (let ((dir (dired-current-directory))) - (select-window mb) - (set-buffer (window-buffer mb)) - (erase-buffer) - (insert dir)) - (error "No active minibuffer")))) - -;;; Copying files - -(defun dired-do-copy (&optional arg) - "Copy all marked (or next ARG) files, or copy the current file. -When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and the files are copied into that directory, retaining the same file names. - -A zero prefix argument copies nothing. But it toggles the -variable `dired-copy-preserve-time' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'copy (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg dired-keep-marker-copy) - (setq dired-copy-preserve-time (not dired-copy-preserve-time)) - (if dired-copy-preserve-time - (message "Copy will preserve time.") - (message "Copied files will get current date.")))) - -(defun dired-copy-file (from to ok-flag) - (dired-handle-overwrite to) - (copy-file from to ok-flag dired-copy-preserve-time)) - -;;; Renaming/moving files - -(defun dired-do-rename (&optional arg) - "Rename current file or all marked (or next ARG) files. -When renaming just the current file, you specify the new name. -When renaming multiple or marked files, you specify a directory. - -A zero ARG moves no files but toggles `dired-dwim-target' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'move (function dired-rename-file) - "Move" arg dired-keep-marker-rename - (function - (lambda (list) - (if (= (length list) 1) - "Rename %s to: " - "Move %s to: ")))) - (setq dired-dwim-target (not dired-dwim-target)) - (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF")))) - -(defun dired-rename-file (from to ok-flag) - (dired-handle-overwrite to) - (let ((insert (assoc (file-name-as-directory from) dired-subdir-alist))) - (rename-file from to ok-flag) ; error is caught in -create-files - ;; Silently rename the visited file of any buffer visiting this file. - (dired-rename-update-buffers from to insert))) - -(defun dired-rename-update-buffers (from to &optional insert) - (if (get-file-buffer from) - (save-excursion - (set-buffer (get-file-buffer from)) - (let ((modflag (buffer-modified-p))) - (set-visited-file-name to) ; kills write-file-hooks - (set-buffer-modified-p modflag))) - ;; It's a directory. More work to do. - (let ((blist (buffer-list)) - (from-dir (file-name-as-directory from)) - (to-dir (file-name-as-directory to))) - (save-excursion - (while blist - (set-buffer (car blist)) - (setq blist (cdr blist)) - (cond - (buffer-file-name - (if (dired-in-this-tree buffer-file-name from-dir) - (let ((modflag (buffer-modified-p))) - (unwind-protect - (set-visited-file-name - (concat to-dir (substring buffer-file-name - (length from-dir)))) - (set-buffer-modified-p modflag))))) - (dired-directory - (if (string-equal from-dir (expand-file-name default-directory)) - ;; If top level directory was renamed, lots of things - ;; have to be updated. - (progn - (dired-unadvertise from-dir) - (setq default-directory to-dir - dired-directory - ;; Need to beware of wildcards. - (expand-file-name - (file-name-nondirectory dired-directory) - to-dir)) - (let ((new-name (file-name-nondirectory - (directory-file-name dired-directory)))) - ;; Try to rename buffer, but just leave old name if new - ;; name would already exist (don't try appending "<%d>") - ;; Why? --sandy 19-8-94 - (or (get-buffer new-name) - (rename-buffer new-name))) - (dired-advertise)) - (and insert - (assoc (file-name-directory (directory-file-name to)) - dired-subdir-alist) - (dired-insert-subdir to)))))))))) - -;;; Making symbolic links - -(defun dired-do-symlink (&optional arg) - "Make symbolic links to current file or all marked (or next ARG) files. -When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and new symbolic links are made in that directory -with the same names that the files currently have." - (interactive "P") - (dired-do-create-files 'symlink (function make-symbolic-link) - "SymLink" arg dired-keep-marker-symlink)) - -;; Relative symlinks: -;; make-symbolic no longer expands targets (as of at least 18.57), -;; so the code to call ln has been removed. - -(defun dired-do-relsymlink (&optional arg) - "Symlink all marked (or next ARG) files into a directory, -or make a symbolic link to the current file. -This creates relative symbolic links like - - foo -> ../bar/foo - -not absolute ones like - - foo -> /ugly/path/that/may/change/any/day/bar/foo" - (interactive "P") - (dired-do-create-files 'relsymlink (function dired-make-relative-symlink) - "RelSymLink" arg dired-keep-marker-symlink)) - -(defun dired-make-relative-symlink (target linkname - &optional ok-if-already-exists) - "Make a relative symbolic link pointing to TARGET with name LINKNAME. -Three arguments: FILE1 FILE2 &optional OK-IF-ALREADY-EXISTS -The link is relative (if possible), for example - - \"/vol/tex/bin/foo\" \"/vol/local/bin/foo\" - -results in - - \"../../tex/bin/foo\" \"/vol/local/bin/foo\"" - (interactive - (let ((target (read-string "Make relative symbolic link to file: "))) - (list - target - (read-file-name (format "Make relsymlink to file %s: " target)) - 0))) - (let* ((target (expand-file-name target)) - (linkname (expand-file-name linkname)) - (handler (or (find-file-name-handler - linkname 'dired-make-relative-symlink) - (find-file-name-handler - target 'dired-make-relative-symlink)))) - (if handler - (funcall handler 'dired-make-relative-symlink target linkname - ok-if-already-exists) - (setq target (directory-file-name target) - linkname (directory-file-name linkname)) - (make-symbolic-link - (dired-make-relative target (file-name-directory linkname) t) - linkname ok-if-already-exists)))) - -;;; Hard links -- adding names to files - -(defun dired-do-hardlink (&optional arg) - "Add names (hard links) current file or all marked (or next ARG) files. -When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and new hard links are made in that directory -with the same names that the files currently have." - (interactive "P") - (dired-do-create-files 'hardlink (function add-name-to-file) - "HardLink" arg dired-keep-marker-hardlink)) - - -;;;; --------------------------------------------------------------- -;;;; Running process on marked files -;;;; --------------------------------------------------------------- -;;; -;;; Commands for shell processes are in dired-shell.el. - -;;; Internal functions for running subprocesses, -;;; checking and logging of their errors. - -(defun dired-call-process (program discard &rest arguments) - ;; Run PROGRAM with output to current buffer unless DISCARD is t. - ;; Remaining arguments are strings passed as command arguments to PROGRAM. - ;; Returns program's exit status, as an integer. - ;; This is a separate function so that efs can redefine it. - (let ((return - (apply 'call-process program nil (not discard) nil arguments))) - (if (and (not (equal shell-file-name program)) - (integerp return)) - return - ;; Fudge return code by looking for errors in current buffer. - (if (zerop (buffer-size)) 0 1)))) - -(defun dired-check-process (msg program &rest arguments) - ;; Display MSG while running PROGRAM, and check for output. - ;; Remaining arguments are strings passed as command arguments to PROGRAM. - ;; On error, insert output in a log buffer and return the - ;; offending ARGUMENTS or PROGRAM. - ;; Caller can cons up a list of failed args. - ;; Else returns nil for success. - (let ((err-buffer (get-buffer-create " *dired-check-process output*")) - (dir default-directory)) - (message "%s..." msg) - (save-excursion - ;; Get a clean buffer for error output: - (set-buffer err-buffer) - (erase-buffer) - (setq default-directory dir) ; caller's default-directory - (if (not - (eq 0 (apply (function dired-call-process) program nil arguments))) - (progn - (dired-log (buffer-name (current-buffer)) - (concat program " " (prin1-to-string arguments) "\n")) - (dired-log (buffer-name (current-buffer)) err-buffer) - (or arguments program t)) - (kill-buffer err-buffer) - (message "%s...done" msg) - nil)))) - -;;; Changing file attributes - -(defun dired-do-chxxx (attribute-name program op-symbol arg) - ;; Change file attributes (mode, group, owner) of marked files and - ;; refresh their file lines. - ;; ATTRIBUTE-NAME is a string describing the attribute to the user. - ;; PROGRAM is the program used to change the attribute. - ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). - ;; ARG describes which files to use, like in dired-get-marked-files. - (let* ((files (dired-get-marked-files t arg)) - (new-attribute - (dired-mark-read-string - (concat "Change " attribute-name " of %s to: ") - nil op-symbol arg files)) - (operation (concat program " " new-attribute)) - (failures - (dired-bunch-files 10000 (function dired-check-process) - (list operation program new-attribute) - files))) - (dired-do-redisplay arg);; moves point if ARG is an integer - (if failures - (dired-log-summary (buffer-name (current-buffer)) - (format "%s: error" operation) nil)))) - -(defun dired-do-chmod (&optional arg) - "Change the mode of the marked (or next ARG) files. -This calls chmod, thus symbolic modes like `g+w' are allowed." - (interactive "P") - (dired-do-chxxx "Mode" "chmod" 'chmod arg)) - -(defun dired-do-chgrp (&optional arg) - "Change the group of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) - -(defun dired-do-chown (&optional arg) - "Change the owner of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) - -;;; Utilities for running processes on marked files. - -;; Process all the files in FILES in batches of a convenient size, -;; by means of (FUNCALL FUNCTION ARGS... SOME-FILES...). -;; Batches are chosen to need less than MAX chars for the file names, -;; allowing 3 extra characters of separator per file name. -(defun dired-bunch-files (max function args files) - (let (pending - (pending-length 0) - failures) - ;; Accumulate files as long as they fit in MAX chars, - ;; then process the ones accumulated so far. - (while files - (let* ((thisfile (car files)) - (thislength (+ (length thisfile) 3)) - (rest (cdr files))) - ;; If we have at least 1 pending file - ;; and this file won't fit in the length limit, process now. - (if (and pending (> (+ thislength pending-length) max)) - (setq failures - (nconc (apply function (append args pending)) - failures) - pending nil - pending-length 0)) - ;; Do (setq pending (cons thisfile pending)) - ;; but reuse the cons that was in `files'. - (setcdr files pending) - (setq pending files) - (setq pending-length (+ thislength pending-length)) - (setq files rest))) - (nconc (apply function (append args pending)) - failures))) - - -;;;; --------------------------------------------------------------- -;;;; Calculating data or properties for marked files. -;;;; --------------------------------------------------------------- - -(defun dired-do-total-size (&optional arg) - "Show total size of all marked (or next ARG) files." - (interactive "P") - (let* ((result (dired-map-over-marks (dired-get-file-size) arg)) - (total (apply (function +) result)) - (num (length result))) - (message "%d bytes (%d kB) in %s file%s" - total (/ total 1024) num (dired-plural-s num)) - total)) - -(defun dired-get-file-size () - ;; Returns the file size in bytes of the current file, as an integer. - ;; Assumes that it is on a valid file line. It's the caller's responsibility - ;; to ensure this. Assumes that match 0 for dired-re-month-and-time is - ;; at the end of the file size. - (dired-move-to-filename t) - ;; dired-move-to-filename must leave match-beginning 0 at the start of - ;; the date. - (goto-char (match-beginning 0)) - (skip-chars-backward " ") - (string-to-int (buffer-substring (point) - (progn (skip-chars-backward "0-9") - (point))))) - -(defun dired-copy-filenames-as-kill (&optional arg) - "Copy names of marked (or next ARG) files into the kill ring. -The names are separated by a space, and may be copied into other buffers -with \\[yank]. The list of names is also stored in the variable -`dired-marked-files' for possible manipulation in the *scratch* buffer. - -With a 0 prefix argument, use the pathname relative to the top-level dired -directory for each marked file. - -With a prefix \\[universal-argument], use the complete pathname of each -marked file. - -With a prefix \\[universal-argument] \\[universal-argument], copy the complete -file line. In this case, the lines are separated by newlines. - -If on a subdirectory headerline and no prefix argument given, use the -subdirectory name instead." - (interactive "P") - (let (res) - (cond - ((and (null arg) (setq res (dired-get-subdir))) - (kill-new res) - (message "Copied %s into kill ring." res)) - ((equal arg '(16)) - (setq dired-marked-files - (dired-map-over-marks - (concat " " ; Don't copy the mark. - (buffer-substring - (progn (beginning-of-line) (1+ (point))) - (progn (skip-chars-forward "^\n\r") (point)))) - nil)) - (let ((len (length dired-marked-files))) - (kill-new (concat - (mapconcat 'identity dired-marked-files "\n") - "\n")) - (message "Copied %d file line%s into kill ring." - len (dired-plural-s len)))) - (t - (setq dired-marked-files - (cond - ((null arg) - (dired-get-marked-files 'no-dir)) - ((eq arg 0) - (dired-get-marked-files t)) - ((integerp arg) - (dired-get-marked-files 'no-dir arg)) - ((equal arg '(4)) - (dired-get-marked-files)) - (t (error "Invalid prefix %s" arg)))) - (let ((len (length dired-marked-files))) - (kill-new (mapconcat 'identity dired-marked-files " ")) - (message "Copied %d file name%s into kill ring." - len (dired-plural-s len))))))) - - -;;;; ----------------------------------------------------------- -;;;; Killing subdirectories -;;;; ----------------------------------------------------------- -;;; -;;; These commands actually remove text from the dired buffer. - -(defun dired-kill-subdir (&optional remember-marks tree) - "Remove all lines of current subdirectory. -Lower levels are unaffected. If given a prefix when called interactively, -kills the entire directory tree below the current subdirectory." - ;; With optional REMEMBER-MARKS, return a mark-alist. - (interactive (list nil current-prefix-arg)) - (let ((cur-dir (dired-current-directory))) - (if (string-equal cur-dir (expand-file-name default-directory)) - (error "Attempt to kill top level directory")) - (if tree - (dired-kill-tree cur-dir remember-marks) - (let ((beg (dired-subdir-min)) - (end (dired-subdir-max)) - buffer-read-only) - (prog1 - (if remember-marks (dired-remember-marks beg end)) - (goto-char beg) - (or (bobp) (forward-char -1)) ; gobble separator - (delete-region (point) end) - (dired-unsubdir cur-dir) - (dired-update-mode-line) - (dired-update-mode-line-modified t)))))) - -(defun dired-kill-tree (dirname &optional remember-marks) - "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. -With optional arg REMEMBER-MARKS, return an alist of marked files." - (interactive "DKill tree below directory: ") - (let ((s-alist dired-subdir-alist) dir m-alist) - (while s-alist - (setq dir (car (car s-alist)) - s-alist (cdr s-alist)) - (if (and (not (string-equal dir dirname)) - (dired-in-this-tree dir dirname) - (dired-goto-subdir dir)) - (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) - (dired-update-mode-line) - (dired-update-mode-line-modified t) - m-alist)) - - -;;;; ------------------------------------------------------------ -;;;; Killing file lines -;;;; ------------------------------------------------------------ -;;; -;;; Uses selective diplay, rather than removing lines from the buffer. - -(defun dired-do-kill-file-lines (&optional arg) - "Kill all marked file lines, or those indicated by the prefix argument. -Killing file lines means hiding them with selective display. Giving -a zero prefix redisplays all killed file lines." - (interactive "P") - (or selective-display - (error "selective-display must be t for file line killing to work!")) - (if (eq arg 0) - (dired-do-unhide dired-kill-marker-char - "Successfully resuscitated %d file line%s." - dired-keep-marker-kill) - (let ((files - (length - (dired-map-over-marks - (progn - (beginning-of-line) - (subst-char-in-region (1- (point)) (point) ?\n ?\r) - (dired-substitute-marker (point) (following-char) - dired-kill-marker-char) - (dired-update-marker-counters dired-marker-char t) - t) - arg)))) - ;; Beware of extreme apparent save-excursion lossage here. - (let ((opoint (point))) - (skip-chars-backward "^\n\r") - (if (= (preceding-char) ?\n) - (goto-char opoint) - (setq opoint (- opoint (point))) - (beginning-of-line) - (skip-chars-forward "^\n\r" (+ (point) opoint)))) - (dired-update-mode-line-modified) - (message "Killed %d file line%s." files (dired-plural-s files))))) - - -;;;; ---------------------------------------------------------------- -;;;; Omitting files. -;;;; ---------------------------------------------------------------- - -;; Marked files are never omitted. -;; Adapted from code submitted by: -;; Michael D. Ernst, mernst@theory.lcs.mit.edu, 1/11/91 -;; Changed to work with selective display by Sandy Rutherford, 13/12/92. -;; For historical reasons, we still use the term expunge, although nothing -;; is expunged from the buffer. - -(defun dired-omit-toggle (&optional arg) - "Toggle between displaying and omitting files matching -`dired-omit-regexps' in the current subdirectory. -With a positive prefix, omits files in the entire tree dired buffer. -With a negative prefix, forces all files in the tree dired buffer to be -displayed." - (interactive "P") - (if arg - (let ((arg (prefix-numeric-value arg))) - (if (>= arg 0) - (dired-omit-expunge nil t) - (dired-do-unhide dired-omit-marker-char "") - (mapcar - (function - (lambda (elt) - (setcar (nthcdr 2 elt) nil))) - dired-subdir-alist))) - (if (dired-current-subdir-omitted-p) - (save-restriction - (narrow-to-region (dired-subdir-min) (dired-subdir-max)) - (dired-do-unhide dired-omit-marker-char "") - (setcar (nthcdr 2 (assoc - (dired-current-directory) dired-subdir-alist)) - nil) - (setq dired-subdir-omit nil)) - (dired-omit-expunge) - (setq dired-subdir-omit t))) - (dired-update-mode-line t)) - -(defun dired-current-subdir-omitted-p () - ;; Returns t if the current subdirectory is omited. - (nth 2 (assoc (dired-current-directory) dired-subdir-alist))) - -(defun dired-remember-omitted () - ;; Returns a list of omitted subdirs. - (let ((alist dired-subdir-alist) - result elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (if (nth 2 elt) - (setq result (cons (car elt) result)))) - result)) - -(defun dired-omit-expunge (&optional regexp full-buffer) - ;; Hides all unmarked files matching REGEXP. - ;; If REGEXP is nil or not specified, uses `dired-omit-regexps', - ;; and also omits filenames ending in `dired-omit-extensions'. - ;; If REGEXP is the empty string, this function is a no-op. - (let ((omit-re (or regexp (dired-omit-regexp))) - (alist dired-subdir-alist) - elt min) - (if (null omit-re) - 0 - (if full-buffer - (prog1 - (dired-omit-region (point-min) (point-max) omit-re) - ;; Set omit property in dired-subdir-alist - (while alist - (setq elt (car alist) - min (dired-get-subdir-min elt) - alist (cdr alist)) - (if (and (<= (point-min) min) (>= (point-max) min)) - (setcar (nthcdr 2 elt) t)))) - (prog1 - (dired-omit-region (dired-subdir-min) (dired-subdir-max) omit-re) - (setcar - (nthcdr 2 (assoc (dired-current-directory) - dired-subdir-alist)) - t)))))) - -(defun dired-omit-region (start end regexp) - ;; Omits files matching regexp in region. Returns count. - (save-restriction - (narrow-to-region start end) - (let ((hidden-subdirs (dired-remember-hidden)) - buffer-read-only count) - (or selective-display - (error "selective-display must be t for file omission to work!")) - (dired-omit-unhide-region start end) - (let ((dired-marker-char dired-omit-marker-char) - ;; since all subdirs are now unhidden, this fakes - ;; dired-move-to-end-of-filename into working faster - (selective-display nil)) - (or dired-omit-silent - dired-in-query (message "Omitting...")) - (if (dired-mark-unmarked-files regexp nil nil 'no-dir) - (setq count (dired-do-hide - dired-marker-char - (and (memq dired-omit-silent '(nil 0)) - (not dired-in-query) - "Omitted %d line%s."))) - (or dired-omit-silent dired-in-query - (message "(Nothing to omit)")))) - (save-excursion ;hide subdirs that were hidden - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs)) - count))) - -(defun dired-omit-unhide-region (beg end) - ;; Unhides hidden, but not marked files in the region. - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (and (char-equal (following-char) ?\ ) - (subst-char-in-region (1- (point)) (point) ?\r ?\n)))))) - -(defun dired-do-unhide (char &optional fmt marker) - ;; Unhides files marked with CHAR. Optional FMT is a message - ;; to be displayed. Note that after unhiding, we will need to re-hide - ;; files belonging to hidden subdirs. - (save-excursion - (goto-char (point-min)) - (let ((count 0) - (string (concat "\r" (char-to-string char))) - (hidden-subdirs (dired-remember-hidden)) - (new (if marker (concat "\n" (char-to-string marker)) "\n ")) - buffer-read-only) - (while (search-forward string nil t) - (replace-match new) - (setq count (1+ count))) - (or (equal "" fmt) - (message (or fmt "Unhid %d line%s.") count (dired-plural-s count))) - (goto-char (point-min)) - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1 t)))) - hidden-subdirs) - (if marker (dired-update-mode-line-modified t)) - count))) - -(defun dired-do-hide (char &optional fmt) - ;; Hides files marked with CHAR. Otional FMT is a message - ;; to be displayed. FMT is a format string taking args the number - ;; of hidden file lines, and dired-plural-s. - (save-excursion - (goto-char (point-min)) - (let ((count 0) - (string (concat "\n" (char-to-string char))) - buffer-read-only) - (while (search-forward string nil t) - (subst-char-in-region (match-beginning 0) - (1+ (match-beginning 0)) ?\n ?\r t) - (setq count (1+ count))) - (if fmt - (message fmt count (dired-plural-s count))) - count))) - -(defun dired-omit-regexp () - (let (rgxp) - (if dired-omit-extensions - (setq rgxp (concat - ".\\(" - (mapconcat 'regexp-quote dired-omit-extensions "\\|") - "\\)\\'"))) - (if dired-omit-regexps - (setq rgxp - (concat - rgxp - (and rgxp "\\|") - (mapconcat 'identity dired-omit-regexps "\\|")))) - rgxp)) - -(defun dired-mark-unmarked-files (regexp msg &optional unflag-p localp) - ;; Marks unmarked files matching REGEXP, displaying MSG. - ;; REGEXP is matched against the complete pathname, unless localp is - ;; specified. - ;; Does not re-mark files which already have a mark. - ;; Returns t if any work was done, nil otherwise. - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - fn) - (dired-mark-if - (and - ;; not already marked - (eq (following-char) ?\ ) - ;; uninteresting - (setq fn (dired-get-filename localp t)) - (string-match regexp fn)) - msg))) - -(defun dired-add-omit-regexp (rgxp &optional how) - "Adds a new regular expression to the list of omit regular expresions. -With a non-zero numeric prefix argument, deletes a regular expresion from -the list. - -With a prefix argument \\[universal-argument], adds a new extension to -the list of file name extensions omitted. -With a prefix argument \\[universal-argument] \\[universal-argument], deletes -a file name extension from the list. - -With a prefix 0, reports on the current omit regular expressions and -extensions." - (interactive - (list - (cond - ((null current-prefix-arg) - (read-string "New omit regular expression: ")) - ((equal '(4) current-prefix-arg) - (read-string "New omit extension (\".\" is not implicit): ")) - ((equal '(16) current-prefix-arg) - (completing-read - "Remove from omit extensions (type SPACE for options): " - (mapcar 'list dired-omit-extensions) nil t)) - ((eq 0 current-prefix-arg) - nil) - (t - (completing-read - "Remove from omit regexps (type SPACE for options): " - (mapcar 'list dired-omit-regexps) nil t))) - current-prefix-arg)) - (let (remove) - (cond - ((null how) - (if (member rgxp dired-omit-regexps) - (progn - (describe-variable 'dired-omit-regexps) - (error "%s is already included in the list." rgxp)) - (setq dired-omit-regexps (cons rgxp dired-omit-regexps)))) - ((equal how '(4)) - (if (member rgxp dired-omit-extensions) - (progn - (describe-variable 'dired-omit-extensions) - (error "%s is already included in list." rgxp)) - (setq dired-omit-extensions (cons rgxp dired-omit-extensions)))) - ((equal how '(16)) - (let ((tail (member rgxp dired-omit-extensions))) - (if tail - (setq dired-omit-extensions - (delq (car tail) dired-omit-extensions) - remove t) - (setq remove 'ignore)))) - ((eq 0 how) - (setq remove 'ignore) - (if (featurep 'ehelp) - (with-electric-help - (function - (lambda () - (princ "Omit extensions (dired-omit-extensions ):\n") - (dired-format-columns-of-files dired-omit-extensions) - (princ "\n") - (princ "Omit regular expressions (dired-omit-regexps ):\n") - (dired-format-columns-of-files dired-omit-regexps) - nil))) - (with-output-to-temp-buffer "*Help*" - (princ "Omit extensions (dired-omit-extensions ):\n") - (dired-format-columns-of-files dired-omit-extensions) - (princ "\n") - (princ "Omit regular expressions (dired-omit-regexps ):\n") - (dired-format-columns-of-files dired-omit-regexps) - (print-help-return-message)))) - (t - (let ((tail (member rgxp dired-omit-regexps))) - (if tail - (setq dired-omit-regexps (delq (car tail) dired-omit-regexps) - remove t) - (setq remove 'ignore))))) - (or (eq remove 'ignore) - (save-excursion - (mapcar - (function - (lambda (dir) - (if (dired-goto-subdir dir) - (progn - (if remove - (save-restriction - (narrow-to-region - (dired-subdir-min) (dired-subdir-max)) - (dired-do-unhide dired-omit-marker-char ""))) - (dired-omit-expunge))))) - (dired-remember-omitted)))))) - - - -;;;; ---------------------------------------------------------------- -;;;; Directory hiding. -;;;; ---------------------------------------------------------------- -;;; -;;; To indicate a hidden subdir, we actually insert "..." in the buffer. -;;; Aside from giving the look of ellipses (even though -;;; selective-display-ellipses is nil), it allows us to tell the difference -;;; between a dir with a single omitted file, and a hidden subdir with one -;;; file. - -(defun dired-subdir-hidden-p (dir) - (save-excursion - (and selective-display - (dired-goto-subdir dir) - (looking-at "\\.\\.\\.\r")))) - -(defun dired-unhide-subdir () - (let (buffer-read-only) - (goto-char (dired-subdir-min)) - (skip-chars-forward "^\n\r") - (skip-chars-backward "." (- (point) 3)) - (if (looking-at "\\.\\.\\.\r") (delete-char 4)) - (dired-omit-unhide-region (point) (dired-subdir-max)))) - -(defun dired-hide-check () - (or selective-display - (error "selective-display must be t for subdir hiding to work!"))) - -(defun dired-hide-subdir (arg &optional really) - "Hide or unhide the current subdirectory and move to next directory. -Optional prefix arg is a repeat factor. -Use \\[dired-hide-all] to (un)hide all directories. -With the optional argument REALLY, we always hide -the subdir, regardless of dired-subdir-hidden-p." - ;; The arg REALLY is needed because when we unhide - ;; omitted files in a hidden subdir, we want to - ;; re-hide the subdir, regardless of whether dired - ;; thinks it's already hidden. - (interactive "p") - (dired-hide-check) - (dired-save-excursion - (while (>= (setq arg (1- arg)) 0) - (let* ((cur-dir (dired-current-directory)) - (hidden-p (and (null really) - (dired-subdir-hidden-p cur-dir))) - (elt (assoc cur-dir dired-subdir-alist)) - (end-pos (1- (dired-get-subdir-max elt))) - buffer-read-only) - ;; keep header line visible, hide rest - (goto-char (dired-get-subdir-min elt)) - (skip-chars-forward "^\n\r") - (skip-chars-backward "." (- (point) 3)) - (if hidden-p - (progn - (if (looking-at "\\.\\.\\.\r") - (progn - (delete-char 3) - (setq end-pos (- end-pos 3)))) - (dired-omit-unhide-region (point) end-pos)) - (if (looking-at "\\.\\.\\.\r") - (goto-char (match-end 0)) - (insert "...") - (setq end-pos (+ end-pos 3))) - (subst-char-in-region (point) end-pos ?\n ?\r))) - (dired-next-subdir 1 t)))) - -(defun dired-hide-all (arg) - "Hide all subdirectories, leaving only their header lines. -If there is already something hidden, make everything visible again. -Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." - (interactive "P") - (dired-hide-check) - (let (buffer-read-only) - (dired-save-excursion - (if (let ((alist dired-subdir-alist) - (hidden nil)) - (while (and alist (null hidden)) - (setq hidden (dired-subdir-hidden-p (car (car alist))) - alist (cdr alist))) - hidden) - ;; unhide - (let ((alist dired-subdir-alist)) - (while alist - (goto-char (dired-get-subdir-min (car alist))) - (skip-chars-forward "^\n\r") - (delete-region (point) (progn (skip-chars-backward ".") (point))) - (setq alist (cdr alist))) - (dired-omit-unhide-region (point-min) (point-max))) - ;; hide - (let ((alist dired-subdir-alist)) - (while alist - (dired-goto-subdir (car (car alist))) - (dired-hide-subdir 1 t) - (setq alist (cdr alist)))))))) - - -;;;; ----------------------------------------------------------------- -;;;; Automatic dired buffer maintenance. -;;;; ----------------------------------------------------------------- -;;; -;;; Keeping Dired buffers in sync with the filesystem and with each -;;; other. -;;; When used with efs on remote directories, buffer maintainence is -;;; done asynch. - -(defun dired-buffers-for-dir (dir-or-list &optional check-wildcard) -;; Return a list of buffers that dired DIR-OR-LIST -;; (top level or in-situ subdir). -;; The list is in reverse order of buffer creation, most recent last. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. If DIR-OR-LIST is a wildcard or list, returns any -;; dired buffers for which DIR-OR-LIST is equal to `dired-directory'. -;; If check-wildcard is non-nil, only returns buffers which contain dir-or-list -;; exactly, including the wildcard part. - (let ((alist dired-buffers) - (as-dir (and (stringp dir-or-list) - (file-name-as-directory dir-or-list))) - result buff elt) - (while alist - (setq buff (cdr (setq elt (car alist))) - alist (cdr alist)) - ;; dired-in-this-tree is not fast. It doesn't pay to use this to check - ;; whether the buffer is a good candidate. - (if (buffer-name buff) - (save-excursion - (set-buffer buff) - (if (or (equal dir-or-list dired-directory) ; the wildcard case. - (and as-dir - (not (and check-wildcard - (string-equal - as-dir - (expand-file-name default-directory)))) - (assoc as-dir dired-subdir-alist))) - (setq result (cons buff result)))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers)))) - (or dired-buffers (dired-remove-from-file-name-handler-alist)) - result)) - -(defun dired-advertise () - ;; Advertise in variable `dired-buffers' that we dired `default-directory'. - ;; With wildcards we actually advertise too much. - ;; Also makes sure that we are installed in the file-name-handler-alist - (prog1 - (let ((ddir (expand-file-name default-directory))) - (if (memq (current-buffer) (dired-buffers-for-dir ddir)) - t ; we have already advertised ourselves - (setq dired-buffers - (cons (cons ddir (current-buffer)) - dired-buffers)))) - ;; Do this last, otherwise the call to dired-buffers-for-dir will - ;; remove dired-handler-fn from the file-name-handler-alist. - ;; Strictly speaking, we only need to do this in th else branch of - ;; the if statement. We do it unconditionally as a sanity check. - (dired-check-file-name-handler-alist))) - -(defun dired-unadvertise (dir) - ;; Remove DIR from the buffer alist in variable dired-buffers. - ;; This has the effect of removing any buffer whose main directory is DIR. - ;; It does not affect buffers in which DIR is a subdir. - ;; Removing is also done as a side-effect in dired-buffer-for-dir. - (setq dired-buffers - (delq (assoc dir dired-buffers) dired-buffers)) - ;; If there are no more dired buffers, we are no longer needed in the - ;; file-name-handler-alist. - (or dired-buffers (dired-remove-from-file-name-handler-alist))) - -(defun dired-unadvertise-current-buffer () - ;; Remove all references to the current buffer in dired-buffers. - (setq dired-buffers - (delq nil - (mapcar - (function - (lambda (x) - (and (not (eq (current-buffer) (cdr x))) x))) - dired-buffers))) - ;; If there are no more dired buffers, we are no longer needed in the - ;; file-name-handler-alist. - (or dired-buffers (dired-remove-from-file-name-handler-alist))) - -(defun dired-fun-in-all-buffers (directory fun &rest args) - ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. - ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). - (let* ((buf-list (dired-buffers-for-dir directory)) - (obuf (current-buffer)) - (owin (selected-window)) - (win owin) - buf windows success-list) - (if buf-list - (unwind-protect - (progn - (while (not (eq (setq win (next-window win)) owin)) - (and (memq (setq buf (window-buffer win)) buf-list) - (progn - (set-buffer buf) - (= (point) (window-point win))) - (setq windows (cons win windows)))) - (while buf-list - (setq buf (car buf-list) - buf-list (cdr buf-list)) - (set-buffer buf) - (if (apply fun args) - (setq success-list (cons (buffer-name buf) success-list)))) - ;; dired-save-excursion prevents lossage of save-excursion - ;; for point. However, if dired buffers are displayed in - ;; other windows, the setting of window-point loses, and - ;; drags the point with it. This should fix this. - (while windows - (condition-case nil - (progn - (set-buffer (window-buffer (setq win (car windows)))) - (set-window-point win (point))) - (error nil)) - (setq windows (cdr windows)))) - (set-buffer obuf))) - success-list)) - -(defun dired-find-file-place (subdir file) - ;; Finds a position to insert in SUBDIR FILE. If it can't find SUBDIR, - ;; returns nil. - (let ((sort (dired-sort-type dired-internal-switches)) - (rev (memq ?r (nth 3 (assoc subdir dired-subdir-alist))))) - (cond - ((eq sort 'name) - (if (dired-goto-subdir subdir) - (let ((max (dired-subdir-max)) - start end found) - (if (dired-goto-next-file) - (progn - (skip-chars-forward "^\n\r") - (setq start (point)) - (goto-char (setq end max)) - (forward-char -1) - (skip-chars-backward "^\n\r") - ;; This loop must find a file. At the very least, it will - ;; find the one found previously. - (while (not found) - (if (save-excursion (dired-move-to-filename nil (point))) - (setq found t) - (setq end (point)) - (forward-char -1) - (skip-chars-backward "^\n\r"))) - (if rev - (while (< start end) - (goto-char (/ (+ start end) 2)) - (if (dired-file-name-lessp - (or (dired-get-filename 'no-dir t) - (error - "Error in dired-find-file-place")) - file) - (setq end (progn - (skip-chars-backward "^\n\r") - (point))) - (setq start (progn - (skip-chars-forward "^\n\r") - (forward-char 1) - (skip-chars-forward "^\n\r") - (point))))) - (while (< start end) - (goto-char (/ (+ start end) 2)) - (if (dired-file-name-lessp - file - (or (dired-get-filename 'no-dir t) - (error - "Error in dired-find-file-place"))) - (setq end (progn - (skip-chars-backward "^\n\r") - (point))) - (setq start (progn - (skip-chars-forward "^\n\r") - (forward-char 1) - (skip-chars-forward "^\n\r") - (point)))))) - (goto-char end)) - (goto-char max)) - t))) - ((eq sort 'date) - (if (dired-goto-subdir subdir) - (if rev - (goto-char (dired-subdir-max)) - (dired-goto-next-file) - t))) - ;; Put in support for other sorting types. - (t - (if (string-equal (dired-current-directory) subdir) - (progn - ;; We are already where we should be, except when - ;; point is before the subdir line or its total line. - (or (save-excursion (beginning-of-line) (dired-move-to-filename)) - (dired-goto-next-nontrivial-file)) ; in the header somewhere - t) ; return t, for found. - (if (dired-goto-subdir subdir) - (progn - (dired-goto-next-nontrivial-file) - t))))))) - -(defun dired-add-entry (filename &optional marker-char inplace) - ;; Add a new entry for FILENAME, optionally marking it - ;; with MARKER-CHAR (a character, else dired-marker-char is used). - ;; Hidden subdirs are exposed if a file is added there. - ;; - ;; This function now adds the new entry at the END of the previous line, - ;; not the beginning of the current line. - ;; Logically, we now think of the `newline' associated - ;; with a fileline, as the one at the beginning of the line, not the end. - ;; This makes it easier to keep track of omitted files. - ;; - ;; Uses dired-save-excursion, so that it doesn't move the - ;; point around. Especially important when it runs asynch. - ;; - ;; If there is already an entry, delete the existing one before adding a - ;; new one. In this case, doesn't remember its mark. Use - ;; dired-update-file-line for that. - ;; - ;; If INPLACE eq 'relist, then the new entry is put in the - ;; same place as the old, if there was an old entry. - ;; If INPLACE is t, then the file entry is put on the line - ;; currently containing the point. Otherwise, dired-find-file-place - ;; attempts to determine where to put the file. - - (setq filename (directory-file-name filename)) - (dired-save-excursion - (let ((oentry (save-excursion (dired-goto-file filename))) - (directory (file-name-directory filename)) - (file-nodir (file-name-nondirectory filename)) - buffer-read-only) - (if oentry - ;; Remove old entry - (let ((opoint (point))) - (goto-char oentry) - (delete-region (save-excursion - (skip-chars-backward "^\r\n") - (dired-update-marker-counters (following-char) t) - (1- (point))) - (progn - (skip-chars-forward "^\r\n") - (point))) - ;; Move to right place to replace deleted line. - (cond ((eq inplace 'relist) (forward-char 1)) - ((eq inplace t) (goto-char opoint))) - (dired-update-mode-line-modified))) - (if (or (eq inplace t) - (and oentry (eq inplace 'relist)) - ;; Tries to move the point to the right place. - ;; Returns t on success. - (dired-find-file-place directory file-nodir)) - (let ((switches (dired-make-switches-string - (cons ?d dired-internal-switches))) - b-of-l) - ;; Bind marker-char now, in case we are working asynch and - ;; dired-marker-char changes in the meantime. - (if (and marker-char (not (integerp marker-char))) - (setq marker-char dired-marker-char)) - ;; since we insert at the end of a line, - ;; backup to the end of the previous line. - (skip-chars-backward "^\n\r") - (forward-char -1) - (setq b-of-l (point)) - (if (and (featurep 'efs-dired) efs-dired-host-type) - ;; insert asynch - ;; we call the efs version explicitly here, - ;; rather than let the handler-alist work for us - ;; because we want to pass extra args. - ;; Is there a cleaner way to do this? - (efs-insert-directory filename ; don't expand `.' ! - switches nil nil - t ; nowait - marker-char) - (let ((insert-directory-program dired-ls-program)) - (insert-directory filename switches nil nil)) - (dired-after-add-entry b-of-l marker-char)) - (if dired-verify-modtimes - (dired-set-file-modtime directory dired-subdir-alist)) - t))))) ; return t on success, else nil. - -(defun dired-after-add-entry (start marker-char) - ;; Does the cleanup of a dired entry after listing it. - ;; START is the start of the new listing-line. - ;; This is a separate function for the sake of efs. - (save-excursion - (goto-char start) - ;; we make sure that the new line is bracketted by new-lines - ;; so the user doesn't need to use voodoo in the - ;; after-readin-hook. - (insert ?\n) - (dired-add-entry-do-indentation marker-char) - (let* ((beg (dired-manual-move-to-filename t)) - ;; error for strange output - (end (dired-manual-move-to-end-of-filename)) - (filename (buffer-substring beg end))) - ;; We want to have the non-directory part only. - (delete-region beg end) - ;; Any markers pointing to the beginning of the filename, will - ;; still point there after this insertion. Should keep - ;; save-excursion from losing. - (setq beg (point)) - (insert (file-name-nondirectory filename)) - (dired-insert-set-properties beg (point)) - (dired-move-to-filename)) - ;; The subdir-alist is not affected so we can run it right now. - (let ((omit (dired-current-subdir-omitted-p)) - (hide (dired-subdir-hidden-p (dired-current-directory)))) - (if (or dired-after-readin-hook omit hide) - (save-excursion - (save-restriction - ;; Use start so that we get the new-line at - ;; the beginning of the line in case we want - ;; to hide the file. Don't need to test (bobp) - ;; here, since we never add a file at - ;; the beginning of the buffer. - (narrow-to-region start - (save-excursion (forward-line 1) (point))) - (run-hooks 'dired-after-readin-hook) - (if omit - (let ((dired-omit-silent (or dired-omit-silent 0))) - (dired-omit-region (point-min) (point-max) - (dired-omit-regexp)))) - (if hide - (subst-char-in-region (point-min) (1- (point-max)) - ?\n ?\r)))))) - ;; clobber the extra newline at the end of the line - (end-of-line) - (delete-char 1))) - -;; This is a separate function for the sake of nested dired format. -(defun dired-add-entry-do-indentation (marker-char) - ;; two spaces or a marker plus a space: - (insert (if marker-char - (let ((char (if (integerp marker-char) - marker-char - dired-marker-char))) - (dired-update-marker-counters char) - (dired-update-mode-line-modified) - char) - ?\040) - ?\040)) - -(defun dired-remove-file (file) - (let ((alist dired-buffers) - buff) - (save-excursion - (while alist - (setq buff (cdr (car alist))) - (if (buffer-name buff) - (progn - (set-buffer buff) - (dired-remove-entry file)) - (setq dired-buffers (delq (car alist) dired-buffers))) - (setq alist (cdr alist)))) - (or dired-buffers (dired-remove-from-file-name-handler-alist)))) - -(defun dired-remove-entry (file) - (let ((ddir (expand-file-name default-directory)) - (dirname (file-name-as-directory file))) - (if (dired-in-this-tree ddir dirname) - (if (or (memq 'kill-dired-buffer dired-no-confirm) - (y-or-n-p (format "Kill dired buffer %s for %s, too? " - (buffer-name) dired-directory))) - (kill-buffer (current-buffer))) - (if (dired-in-this-tree file ddir) - (let ((alist dired-subdir-alist)) - (while alist - (if (dired-in-this-tree (car (car alist)) dirname) - (save-excursion - (goto-char (dired-get-subdir-min (car alist))) - (dired-kill-subdir))) - (setq alist (cdr alist))) - (dired-save-excursion - (and (dired-goto-file file) - (let (buffer-read-only) - (delete-region - (progn (skip-chars-backward "^\n\r") - (or (memq (following-char) '(\n \r ?\ )) - (progn - (dired-update-marker-counters - (following-char) t) - (dired-update-mode-line-modified))) - (1- (point))) - (progn (skip-chars-forward "^\n\r") (point))) - (if dired-verify-modtimes - (dired-set-file-modtime - (file-name-directory (directory-file-name file)) - dired-subdir-alist)))))))))) - -(defun dired-add-file (filename &optional marker-char) - (dired-fun-in-all-buffers - (file-name-directory filename) - (function dired-add-entry) filename marker-char)) - -(defun dired-relist-file (file) - (dired-uncache file nil) - (dired-fun-in-all-buffers (file-name-directory file) - (function dired-relist-entry) file)) - -(defun dired-relist-entry (file) - ;; Relist the line for FILE, or just add it if it did not exist. - ;; FILE must be an absolute pathname. - (let* ((file (directory-file-name file)) - (directory (file-name-directory file)) - (dd (expand-file-name default-directory))) - (if (assoc directory dired-subdir-alist) - (if (or - ;; Not a wildcard - (equal dd dired-directory) - ;; Not top-level - (not (string-equal directory dd)) - (and (string-equal directory - (if (consp dired-directory) - (file-name-as-directory - (car dired-directory)) - (file-name-directory dired-directory))) - (dired-file-in-wildcard-p dired-directory file))) - (let ((marker (save-excursion - (and (dired-goto-file file) - (dired-file-marker file))))) - ;; recompute omission - (if (eq marker dired-omit-marker-char) - (setq marker nil)) - (dired-add-entry file marker 'relist)) - ;; At least tell dired that we considered updating the buffer. - (if dired-verify-modtimes - (dired-set-file-modtime directory dired-subdir-alist)))))) - -(defun dired-file-in-wildcard-p (wildcard file) - ;; Return t if a file is part of the listing for wildcard. - ;; File should be the non-directory part only. - ;; This version is slow, but meticulously correct. Is it worth it? - (if (consp wildcard) - (let ((files (cdr wildcard)) - (dir (car wildcard)) - yep) - (while (and files (not yep)) - (setq yep (string-equal file (expand-file-name (car files) dir)) - files (cdr files))) - yep) - (let ((err-buff - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create " *dired-check-process output*"))) - (dir default-directory) - (process-connection-type nil)) - (save-excursion - (set-buffer err-buff) - (erase-buffer) - (setq default-directory dir) - (call-process shell-file-name nil t nil "-c" - (concat dired-ls-program " -d " wildcard " | " - "egrep '(^|/)" file "$'")) - (/= (buffer-size) 0))))) - -;; The difference between dired-add-file and dired-relist-file is that -;; the former creates the entry with a specific marker. The later preserves -;; existing markers on a per buffer basis. This is not the same as -;; giving dired-create-files a marker of t, which uses a marker in a specific -;; buffer to determine the marker for file line creation in all buffers. - - -;;;; ---------------------------------------------------------------- -;;;; Applying Lisp functions to marked files. -;;;; ---------------------------------------------------------------- - -;;; Running tags commands on marked files. -;; -;; Written 8/30/93 by Roland McGrath . -;; Requires tags.el as distributed with GNU Emacs 19.23, or later. - -(defun dired-do-tags-search (regexp) - "Search through all marked files for a match for REGEXP. -Stops when a match is found. -To continue searching for next match, use command \\[tags-loop-continue]." - (interactive "sSearch marked files (regexp): ") - (tags-search regexp '(dired-get-marked-files))) - -(defun dired-do-tags-query-replace (from to &optional delimited) - "Query-replace-regexp FROM with TO through all marked files. -Third arg DELIMITED (prefix arg) means replace only word-delimited matches. -If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace -with the command \\[tags-loop-continue]." - (interactive - "sQuery replace in marked files (regexp): \nsQuery replace %s by: \nP") - (tags-query-replace from to delimited '(dired-get-marked-files))) - -;;; byte compiling - -(defun dired-byte-compile () - ;; Return nil for success, offending file name else. - (let* ((filename (dired-get-filename)) - buffer-read-only failure) - (condition-case err - (save-excursion (byte-compile-file filename)) - (error - (setq failure err))) - ;; We should not need to update any file lines, as this will have - ;; already been done by after-write-region-hook. - (and failure - (progn - (dired-log (buffer-name (current-buffer)) - "Byte compile error for %s:\n%s\n" filename failure) - (dired-make-relative filename))))) - -(defun dired-do-byte-compile (&optional arg) - "Byte compile marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-map-over-marks-check (function dired-byte-compile) arg - 'byte-compile "byte-compile" t)) - -;;; loading - -(defun dired-load () - ;; Return nil for success, offending file name else. - (let ((file (dired-get-filename)) failure) - (condition-case err - (load file nil nil t) - (error (setq failure err))) - (if (not failure) - nil - (dired-log (buffer-name (current-buffer)) - "Load error for %s:\n%s\n" file failure) - (dired-make-relative file)))) - -(defun dired-do-load (&optional arg) - "Load the marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-map-over-marks-check (function dired-load) arg 'load "load" t)) - - -;;;; ---------------------------------------------------------------- -;;;; File Name Handler Alist -;;;; ---------------------------------------------------------------- -;;; -;;; Make sure that I/O functions maintain dired buffers. - -(defun dired-remove-from-file-name-handler-alist () - ;; Remove dired from the file-name-handler-alist - (setq file-name-handler-alist - (delq nil - (mapcar - (function - (lambda (x) - (and (not (eq (cdr x) 'dired-handler-fn)) - x))) - file-name-handler-alist)))) - -(defun dired-check-file-name-handler-alist () - ;; Verify that dired is installed as the first item in the alist - (and dired-refresh-automatically - (or (eq (cdr (car file-name-handler-alist)) 'dired-handler-fn) - (setq file-name-handler-alist - (cons - '("." . dired-handler-fn) - (dired-remove-from-file-name-handler-alist)))))) - -(defun dired-handler-fn (op &rest args) - ;; Function to update dired buffers after I/O. - (prog1 - (let ((inhibit-file-name-handlers - (cons 'dired-handler-fn - (and (eq inhibit-file-name-operation op) - inhibit-file-name-handlers))) - (inhibit-file-name-operation op)) - (apply op args)) - (let ((dired-omit-silent t) - (hf (get op 'dired))) - (and hf (funcall hf args))))) - -(defun dired-handler-fn-1 (args) - (let ((to (expand-file-name (nth 1 args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-2 (args) - (let ((from (expand-file-name (car args))) - (to (expand-file-name (nth 1 args)))) - ;; Don't remove the original entry if making backups. - ;; Otherwise we lose marks. I'm not completely happy with the - ;; logic here. - (or (and - (eq (nth 2 args) t) ; backups always have OK-IF-OVERWRITE t - (string-equal (car (find-backup-file-name from)) to)) - (dired-remove-file from)) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-3 (args) - (let ((to (expand-file-name (nth 2 args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-4 (args) - (dired-remove-file (expand-file-name (car args)))) - -(defun dired-handler-fn-5 (args) - (let ((to (expand-file-name (car args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-6 (args) - (let ((to (expand-file-name (nth 1 args))) - (old (expand-file-name (car args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)) - (dired-relist-file old))) - -(put 'copy-file 'dired 'dired-handler-fn-1) -(put 'dired-make-relative-symlink 'dired 'dired-handler-fn-1) -(put 'make-symbolic-link 'dired 'dired-handler-fn-1) -(put 'add-name-to-file 'dired 'dired-handler-fn-6) -(put 'rename-file 'dired 'dired-handler-fn-2) -(put 'write-region 'dired 'dired-handler-fn-3) -(put 'delete-file 'dired 'dired-handler-fn-4) -(put 'delete-directory 'dired 'dired-handler-fn-4) -(put 'dired-recursive-delete-directory 'dired 'dired-handler-fn-4) -(put 'make-directory-internal 'dired 'dired-handler-fn-5) -(put 'set-file-modes 'dired 'dired-handler-fn-5) - -;;;; ------------------------------------------------------------ -;;;; Autoload land. -;;;; ------------------------------------------------------------ - -;;; Reading mail (dired-xy) - -(autoload 'dired-read-mail "dired-xy" - "Reads the current file as a mail folder." t) -(autoload 'dired-vm "dired-xy" "Run VM on this file." t) -(autoload 'dired-rmail "dired-xy" "Run RMAIL on this file." t) - -;;; Virtual dired (dired-vir) - -(autoload 'dired-virtual "dired-vir" - "Put this buffer into virtual dired mode." t) - -;;; Grep (dired-grep) - -(autoload 'dired-do-grep "dired-grep" "Grep marked files for a pattern." t) - -;;; Doing diffs (dired-diff) - -(autoload 'dired-diff "dired-diff" - "Compare file at point with FILE using `diff'." t) -(autoload 'dired-backup-diff "dired-diff" - "Diff this file with its backup file or vice versa." t) -(autoload 'dired-emerge "dired-diff" - "Merge file at point with FILE using `emerge'." t) -(autoload 'dired-emerge-with-ancestor "dired-diff" - "Merge file at point with FILE, using a common ANCESTOR file." t) -(autoload 'dired-ediff "dired-diff" "Ediff file at point with FILE." t) -(autoload 'dired-epatch "dired-diff" "Patch file at point using `epatch'." t) - -;;; Shell commands (dired-shell) - -(autoload 'dired-do-print "dired-shell" "Print the marked (next ARG) files." t) -(autoload 'dired-run-shell-command "dired-shell" nil) -(autoload 'dired-do-shell-command "dired-shell" - "Run a shell command on the marked (or next ARG) files." t) -(autoload 'dired-do-background-shell-command "dired-shell" - "Run a background shell command on marked (or next ARG) files." t) - -;;; Commands using regular expressions (dired-rgxp) - -(autoload 'dired-mark-files-regexp "dired-rgxp" - "Mark all files whose names match REGEXP." t) -(autoload 'dired-flag-files-regexp "dired-rgxp" - "Flag for deletion all files whose names match REGEXP." t) -(autoload 'dired-mark-extension "dired-rgxp" - "Mark all files whose names have a given extension." t) -(autoload 'dired-flag-extension "dired-rgxp" - "Flag for deletion all files whose names have a given extension." t) -(autoload 'dired-cleanup "dired-rgxp" - "Flag for deletion dispensable files files created by PROGRAM." t) -(autoload 'dired-do-rename-regexp "dired-rgxp" - "Rename marked files whose names match a given regexp." t) -(autoload 'dired-do-copy-regexp "dired-rgxp" - "Copy marked files whose names match a given regexp." t) -(autoload 'dired-do-hardlink-regexp "dired-rgxp" - "Hardlink all marked files whose names match a regexp." t) -(autoload 'dired-do-symlink "dired-rgxp" - "Make a symbolic link to all files whose names match a regexp." t) -(autoload - 'dired-do-relsymlink-regexp "dired-rgxp" - "Make a relative symbolic link to all files whose names match a regexp." t) -(autoload 'dired-upcase "dired-rgxp" - "Rename all marked (or next ARG) files to upper case." t) -(autoload 'dired-downcase "dired-rgxp" - "Rename all marked (or next ARG) files to lower case." t) - -;;; Marking files from other buffers (dired-mob) - -(autoload 'dired-mark-files-from-other-dired-buffer "dired-mob" - "Mark files which are marked in another dired buffer." t) -(autoload 'dired-mark-files-compilation-buffer "dired-mob" - "Mark the files mentioned in the compilation buffer." t) - -;;; uuencoding (dired-uu) - -(autoload 'dired-do-uucode "dired-uu" "Uuencode or uudecode marked files." t) - -;;; Compressing (dired-cmpr) - -(autoload 'dired-do-compress "dired-cmpr" - "Compress or uncompress marked files." t) -(autoload 'dired-compress-subdir-files "dired-cmpr" - "Compress uncompressed files in the current subdirectory." t) - - -;;; Marking files according to sexps - -(autoload 'dired-mark-sexp "dired-sex" - "Mark files according to an sexpression." t) - -;;; Help! - -(autoload 'dired-summary "dired-help" - "Display summary of basic dired commands in the minibuffer." t) -(autoload 'dired-describe-mode "dired-help" - "Detailed description of dired mode. -With a prefix, runs the info documentation browser for dired." t) -(autoload 'dired-apropos "dired-help" - "Do command apropos help for dired commands. -With prefix does apropos help for dired variables." t) -(autoload 'dired-report-bug "dired-help" "Report a bug for dired." t) - -;;;; -------------------------------------------------------------- -;;;; Multi-flavour Emacs support -;;;; -------------------------------------------------------------- - -(let ((lucid-p (string-match "XEmacs" emacs-version)) - ver) - (or (string-match "^\\([0-9]+\\)\\." emacs-version) - (error "Weird emacs version %s" emacs-version)) - (setq ver (string-to-int (substring emacs-version (match-beginning 1) - (match-end 1)))) - - ;; Reading with history. - (if (>= ver 19) - - (defun dired-read-with-history (prompt initial history) - (read-from-minibuffer prompt initial nil nil history)) - - (defun dired-read-with-history (prompt initial history) - (let ((minibuffer-history-symbol history)) ; for gmhist - (read-string prompt initial)))) - - ;; Completing read with history. - (if (>= ver 19) - - (fset 'dired-completing-read 'completing-read) - - (defun dired-completing-read (prompt table &optional predicate - require-match initial-input history) - (let ((minibuffer-history-symbol history)) ; for gmhist - (completing-read prompt table predicate require-match - initial-input)))) - - ;; Abbreviating file names. - (if lucid-p - (fset 'dired-abbreviate-file-name - ;; Lemacs has this extra hack-homedir arg - (function - (lambda (fn) - (abbreviate-file-name fn t)))) - (fset 'dired-abbreviate-file-name 'abbreviate-file-name)) - - ;; Deleting directories - ;; Check for pre 19.8 versions of lucid emacs. - (if lucid-p - (or (fboundp 'delete-directory) - (fset 'delete-directory 'remove-directory))) - - ;; Minibuffers - (if (= ver 18) - - (defun dired-get-active-minibuffer-window () - (and (> (minibuffer-depth) 0) - (minibuffer-window))) - - (defun dired-get-active-minibuffer-window () - (let ((frames (frame-list)) - win found) - (while frames - (if (and (setq win (minibuffer-window (car frames))) - (minibuffer-window-active-p win)) - (setq found win - frames nil) - (setq frames (cdr frames)))) - found))) - - ;; Text properties and menus. - - (cond - (lucid-p - (require 'dired-xemacs)) - ((>= ver 19) - (require 'dired-fsf)) - (t - ;; text property stuff doesn't work in V18 - (fset 'dired-insert-set-properties 'ignore) - (fset 'dired-remove-text-properties 'ignore) - (fset 'dired-set-text-properties 'ignore) - (fset 'dired-move-to-filename 'dired-manual-move-to-filename) - (fset 'dired-move-to-end-of-filename - 'dired-manual-move-to-end-of-filename)))) - -;;; MULE - -(if (or (boundp 'MULE) (featurep 'mule)) (load "dired-mule")) - - -;; Run load hook for user customization. -(run-hooks 'dired-load-hook) - -;;; end of dired.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-auto.el --- a/lisp/efs/efs-auto.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-auto.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.8 $ -;; RCS: -;; Description: Simple way of autoloading efs -;; Author: Andy Norman, Dawn -;; Created: Thu Sep 24 09:50:08 1992 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Provides a way of autoloading efs. To use this, just put -;;; (require 'efs-auto) in your .emacs file. -;;; -;;; The Bad News: -;;; -;;; 1. Calls to load and require will not trigger efs to autoload. -;;; If you are want to put remote directories in your load path, -;;; you should require efs. -;;; 2. Because efs does not overload expand-file-name until it is loaded, -;;; "smart" expansion of file names on remote apollos running domain -;;; will not work yet. This means that accessing a file on a remote -;;; apollo may not correctly cause efs to autoload. This will depend -;;; the details of your command sequence. - -(provide 'efs-auto) -(require 'efs-ovwrt) -(require 'efs-fnh) - -(defconst efs-auto-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.8 $" 11 -2))) - -;;; Interactive functions that should be accessible from here. - -(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) -(autoload - 'efs-set-passwd "efs-netrc" - "For a given HOST and USER, set or change the associated PASSWORD." t) -(autoload 'efs-nslookup-host "efs" - "Attempt to resolve a hostname using nslookup if possible." t) -(autoload 'efs-display-ftp-activity "efs" - "Displays the number of active background ftp sessions in the modeline. -Uses the variable `efs-mode-line-format' to determine how this will be -displayed." t) -(autoload 'efs-ftp-path "efs-cu" - "Parse PATH according to efs-path-regexp. -Returns a list (HOST USER PATH), or nil if PATH does not match the format.") - -;;; end of efs-auto.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-cms-knet.el --- a/lisp/efs/efs-cms-knet.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,245 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cms-knet.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: CMS support for efs using KNET/VM server -;; Authors: Sandy Rutherford -;; Joerg-Martin Schwarz -;; Created: Wed Mar 23 14:39:00 1994 by schwarz on hal1 from efs-cms.el -;; Modified: Sun Nov 27 11:45:58 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-cms-knet) -(require 'efs) - -(defconst efs-cms-knet-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; CMS support for KNET-VM server -;;;; ------------------------------------------------------------ - -;;; efs has full support, including tree dired support, for hosts running -;;; CMS. It should be able to automatically recognize any CMS machine. -;;; We would be grateful if you would report any failures to automatically -;;; recognize a CMS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; KNET/VM Support (J. M. Schwarz, Mar 12, 1994): -;;; This code has been developed and tested with -;;; "KNET/VM FTP server Release 3.2.0" by Spartacus. -;;; -;;; This server uses not only a different listing format than the one used in -;;; efs-cms.el, but also handles minidisks differently. -;;; The cd command for changing minidisk is not supported, -;;; instead a full filename syntax "FILENAME.FILETYPE.FM" is used, where -;;; FM is the filemode. To access a file "PROFILE EXEC A0", efs uses a -;;; syntax "/cms-hostname:/A:/PROFILE.EXEC" (Note the ':') -;;; -;;; In this directory notation, "/A0:" is actually a subset of the "/A:" -;;; directory. - -(efs-defun efs-send-pwd cms-knet (host user &optional xpwd) - ;; cms-knet has no concept of current directory. - ;; Is it safe to always assume this is the user's home? - (cons "A" "")) - -(efs-defun efs-fix-path cms-knet (path &optional reverse) - ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert - ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, - ;; so we fudge things by sending cd's. - (if reverse - ;; Since we only convert output from a pwd in this direction, - ;; this should never be applied, as PWD doesn't work for this server. - (concat "/" path "/") - (efs-save-match-data - (if (string-match "^/[A-Z]/\\([-A-Z0-9$_+@:]+\\.[-A-Z0-9$_+@:]+\\)$" - path) - (concat - (substring path (match-beginning 1) (match-end 1)) - "." - ;; minidisk - (substring path 1 2)) - (error "Invalid CMS-KNET filename"))))) - -(efs-defun efs-fix-dir-path cms-knet (dir-path) - ;; Convert path from UNIX-ish to CMS-KNET ready for a DIRectory listing. - (cond - ((string-equal "/" dir-path) - "*.*.*") - ((string-match - "^/[A-Z]/\\([-A-Z0-9$._+@:]+\\.[-A-Z0-9$._+@:]+\\)?$" - dir-path) - (concat - (if (match-beginning 1) - (substring dir-path (match-beginning 1) (match-end 1)) - "*") - "." - (substring dir-path 1 2))) - (t (error "Invalid CMS-KNET pathname")))) - -(defconst efs-cms-knet-file-name-regexp - (concat - "^ *\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +" - "\\([A-Z]\\)[0-9] +[VF] +[0-9]+ ")) - -(efs-defun efs-parse-listing cms-knet - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a CMS directory listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory as a full efs-path - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (efs-save-match-data - (if (string-equal dir "/") - (let ((case-fold (memq 'cms-knet efs-case-insensitive-host-types)) - tbl-alist md md-tbl) - (while (re-search-forward efs-cms-knet-file-name-regexp nil t) - (setq md (buffer-substring (match-beginning 3) (match-end 3)) - md-tbl (or (cdr (assoc md tbl-alist)) - (let ((new-tbl (efs-make-hashtable))) - (setq tbl-alist - (cons (cons md new-tbl) - tbl-alist)) - new-tbl))) - (efs-put-hash-entry md '(t) tbl) - (efs-put-hash-entry (concat - (buffer-substring (match-beginning 1) - (match-end 1)) - "." - (buffer-substring (match-beginning 2) - (match-end 2))) - '(nil) md-tbl) - (forward-line 1)) - (while tbl-alist - (setq md (car (car tbl-alist)) - md-tbl (cdr (car tbl-alist))) - (efs-put-hash-entry "." '(t) md-tbl) - (efs-put-hash-entry ".." '(t) md-tbl) - (efs-put-hash-entry (concat path md "/") md-tbl - efs-files-hashtable case-fold) - (setq tbl-alist (cdr tbl-alist)))) - (while (re-search-forward efs-cms-knet-file-name-regexp nil t) - (efs-put-hash-entry - (concat (buffer-substring (match-beginning 1) - (match-end 1)) - "." - (buffer-substring (match-beginning 2) - (match-end 2))) - '(nil) tbl) - (forward-line 1))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-allow-child-lookup cms-knet (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; CMS file system is flat. Only minidisks are "subdirs". - (string-equal "/" dir)) - -;;; Tree dired support: - -(defconst efs-dired-cms-re-exe - "^. +[-A-Z0-9$_+@:]+ +\\(EXEC\\|MODULE\\) " - "Regular expression to use to search for CMS executables.") - -(or (assq 'cms efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'cms-knet efs-dired-cms-re-exe) - efs-dired-re-exe-alist))) - -(efs-defun efs-dired-insert-headerline cms-knet (dir) - ;; CMS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename cms-knet - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; This is the CMS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-cms-knet-file-name-regexp eol t) - (goto-char (match-beginning 1)) - (if raise-error - (error "No file on this line.") - (goto-char bol))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename cms-knet - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the CMS version. - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (looking-at "[-A-Z0-9$_+@:]+ +[-A-Z0-9$_+@:]+ +[A-Z][0-9] ") - (goto-char (- (match-end 0) 2)) ; return point - (if no-error - nil - (error "No file on this line.")))) - -(efs-defun efs-dired-get-filename cms-knet - (&optional localp no-error-if-not-filep) - (let ((name (efs-real-dired-get-filename 'no-dir no-error-if-not-filep))) - (and name - (if (string-match - "^\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +\\([A-Z]\\)$" - name) - (let* ((dir (dired-current-directory)) - (rdir (nth 2 (efs-ftp-path dir)))) - (setq name (concat (substring name (match-beginning 1) - (match-end 1)) - "." - (substring name (match-beginning 2) - (match-end 2)))) - (if (string-equal rdir "/") - (setq name (concat (substring name (match-beginning 3) - (match-end 3)) "/" name))) - (if (eq localp 'no-dir) - name - (concat (if localp - (dired-current-directory localp) - dir) - name))) - (error "Strange CMS-KNET file name %s" name))))) - -;;; end of efs-cms-knet.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-cms.el --- a/lisp/efs/efs-cms.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,462 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cms.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.9 $ -;; RCS: -;; Description: CMS support for efs -;; Author: Sandy Rutherford -;; Created: Fri Oct 23 08:52:00 1992 -;; Modified: Sun Nov 27 11:46:51 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-cms) -(require 'efs) - -(defconst efs-cms-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.9 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; CMS support -;;;; ------------------------------------------------------------ - -;;; efs has full support, including tree dired support, for hosts running -;;; CMS. It should be able to automatically recognize any CMS machine. -;;; We would be grateful if you would report any failures to automatically -;;; recognize a CMS host as a bug. -;;; -;;; This should also work with CMS machines running SFS (Shared File System). -;;; -;;; Filename syntax: -;;; -;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are -;;; treated as UNIX directories. For example to access the file READ.ME in -;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter -;;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME -;;; If *.301 is the default minidisk for this account, you could access -;;; FOO.BAR on this minidisk as -;;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR -;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be -;;; up to 8 characters. Again, beware that CMS filenames are always upper -;;; case, and hence must be entered as such. -;;; -;;; Tips: -;;; 1. CMS machines, with the exception of anonymous accounts, nearly always -;;; need an account password. To have efs send an account password, -;;; you can either include it in your .netrc file, or use -;;; efs-set-account. -;;; 2. efs-set-account can be used to set account passwords for specific -;;; minidisks. This is usually used to optain write access to the minidisk. -;;; As well you can put tokens of the form -;;; minidisk in your .netrc file. There can be -;;; as many minidisk tokens as you like, however they should follow all -;;; other tokens for a given machine entry. Of course, ordinary ftp -;;; will not understand these entries in your .netrc file. -;;; - - -;;; Since CMS doesn't have any full pathname syntax, we have to fudge -;;; things with cd's. We actually send too many cd's, but is dangerous -;;; to try to remember the current minidisk, because if the connection -;;; is closed and needs to be reopened, we will find ourselves back in -;;; the default minidisk. This is fairly likely since CMS ftp servers -;;; usually close the connection after 5 minutes of inactivity. - -;;; Have I got the filename character set right? - -;;; The following three functions are entry points to this file. -;;; They have been added to the appropriate alists in efs.el - -(efs-defun efs-fix-path cms (path &optional reverse) - ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert - ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, - ;; so we fudge things by sending cd's. - (efs-save-match-data - (if reverse - (if (string-match ":" path) - ;; It's SFS - (let* ((start (match-end 0)) - (return (concat "/" (substring path 0 start)))) - (while (string-match "\\." path start) - (setq return (concat return "/" - (substring path start - (match-beginning 0))) - start (match-end 0))) - (concat return "/" (substring path start))) - ;; Since we only convert output from a pwd in this direction, - ;; we'll assume that it's a minidisk, and make it into a - ;; directory file name. Note that the expand-dir-hashtable - ;; stores directories without the trailing /. - (if (char-equal (string-to-char path) ?/) - path - (concat "/" path))) - (if (let ((case-fold-search t)) - (string-match - (concat - "^/\\([-A-Z0-9$*._+:]+\\)/" - ;; In case there is a SFS - "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" - "\\([-A-Z0-9$._+]+\\)$") - path)) - (let ((minidisk (substring path 1 (match-end 1))) - (sfs (and (match-beginning 2) - (substring path (match-beginning 3) - (match-end 3)))) - (file (substring path (match-beginning 5) (match-end 5))) - account) - (and sfs (match-beginning 4) - (setq sfs (concat sfs "." (substring path (match-beginning 4) - (1- (match-end 4)))))) - (unwind-protect - (progn - (or sfs - (setq account - (efs-get-account host user minidisk))) - (efs-raw-send-cd host user (if sfs - (concat minidisk sfs ".") - minidisk)) - (if account - (efs-cms-send-minidisk-acct - host user minidisk account))) - (if account (fillarray account 0))) - file) - (error "Invalid CMS filename"))))) - -(efs-defun efs-fix-dir-path cms (dir-path) - ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. - (efs-save-match-data - (cond - ((string-equal "/" dir-path) - (error "Cannot get listing for CMS \"/\" directory.")) - ((let ((case-fold-search t)) - (string-match - (concat "^/\\([-A-Z0-9$*._+:]+\\)/" - "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" - "\\([-A-Z0-9$*_.+]+\\)?$") dir-path)) - (let ((minidisk (substring dir-path (match-beginning 1) (match-end 1))) - (sfs (and (match-beginning 2) - (concat - (substring dir-path (match-beginning 3) - (match-end 3))))) - (file (if (match-beginning 5) - (substring dir-path (match-beginning 5) (match-end 5)) - "*")) - account) - (and sfs (match-beginning 4) - (setq sfs (concat sfs "." (substring dir-path - (match-beginning 4) - (1- (match-end 4)))))) - (unwind-protect - (progn - (or sfs - (setq account (efs-get-account host user minidisk))) - (efs-raw-send-cd host user (if sfs - (concat minidisk sfs ".") - minidisk)) - (if account - (efs-cms-send-minidisk-acct host user minidisk account))) - (if account (fillarray account 0))) - file)) - (t (error "Invalid CMS pathname"))))) - -(defconst efs-cms-file-line-regexp - (concat - "\\([-A-Z0-9$_+]+\\) +" - "\\(\\(\\([-A-Z0-9$_+]+\\) +[VF] +[0-9]+ \\)\\|\\(DIR +- \\)\\)")) - -(efs-defun efs-parse-listing cms - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a CMS directory listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory as a full efs-path - (let ((tbl (efs-make-hashtable)) - fn dir-p) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward efs-cms-file-line-regexp nil t) - (if (match-beginning 3) - (setq fn (concat (buffer-substring - (match-beginning 1) (match-end 1)) - "." - (buffer-substring - (match-beginning 4) (match-end 4))) - dir-p nil) - (setq fn (buffer-substring (match-beginning 1) (match-end 1)) - dir-p t)) - (efs-put-hash-entry fn (list dir-p) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(defun efs-cms-send-minidisk-acct (host user minidisk account - &optional noretry) - "For HOST and USER, send the account password ACCOUNT. If MINIDISK is given, -the account password is for that minidisk. If PROC is given, send to that -process, rathr than use HOST and USER to look up the process." - (efs-save-match-data - (let ((result (efs-raw-send-cmd - (efs-get-process host user) - (concat "quote acct " account)))) - (cond - ((eq (car result) 'failed) - (setq account nil) - (unwind-protect - (progn - (setq - account - (read-passwd - (format - "Invalid acct. password for %s on %s@%s. Try again: " - minidisk user host))) - (if (string-equal "" account) - (setq account nil))) - ;; This guarantees that an interrupt will clear the account - ;; password. - (efs-set-account host user minidisk account)) - (if account ; give the user another chance - (efs-cms-send-minidisk-acct host user minidisk account))) - ((eq (car result) 'fatal) - (if noretry - ;; give up - (efs-error host user - (concat "ACCOUNT password failed: " (nth 1 result))) - ;; try once more - (efs-cms-send-minidisk-acct host user minidisk account t)))) - ;; return result - result))) - -(efs-defun efs-write-recover cms - (line cont-lines host user cmd msg pre-cont cont nowait noretry) - ;; If a write fails because of insufficient privileges, give the user a - ;; chance to send an account password. - (let ((cmd0 (car cmd)) - (cmd1 (nth 1 cmd)) - (cmd2 (nth 2 cmd))) - (efs-save-match-data - (if (and (or (memq cmd0 '(append put rename)) - (and (eq cmd0 'quote) (eq cmd1 'stor))) - (string-match "^/\\([-A-Z0-9$*._+]+\\)/[-A-Z0-9$*._+]+$" cmd2)) - (let ((minidisk (substring cmd2 (match-beginning 1) (match-end 1))) - account retry) - (unwind-protect - (progn - (setq account - (read-passwd - (format "Account password for minidisk %s on %s@%s: " - minidisk user host))) - (if (string-equal account "") - (setq account nil))) - (efs-set-account host user minidisk account)) - (if account - (progn - (efs-cms-send-minidisk-acct host user minidisk account) - (setq retry - (efs-send-cmd host user cmd msg pre-cont cont - nowait noretry)) - (and (null (or cont nowait)) retry)) - (if cont - (progn - (efs-call-cont cont 'failed line cont-lines) - nil) - (and (null nowait) (list 'failed line cont-lines))))) - (if cont - (progn - (efs-call-cont cont 'failed line cont-lines) - nil) - (and (null nowait) (list 'failed line cont-lines))))))) - -(efs-defun efs-allow-child-lookup cms (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; CMS file system is flat. Only minidisks are "subdirs". - (or (string-equal "/" dir) - (efs-save-match-data - (string-match "^/[^/:]+:/$" dir)))) - -;;; Sorting listings - -(defconst efs-cms-date-and-time-regexp - (concat - " \\(1?[0-9]\\)/\\([0-3][0-9]\\)/\\([0-9][0-9]\\) +" - "\\([12]?[0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\) ")) - -(efs-defun efs-t-converter cms (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-cms-date-and-time-regexp nil t) - (let (list-start list bol nbol) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq bol (point)) - (re-search-forward efs-cms-date-and-time-regexp - (setq nbol (save-excursion - (forward-line 1) (point))) - t)) - (setq list - (cons - (cons - (list (string-to-int (buffer-substring - (match-beginning 3) - (match-end 3))) ; year - (string-to-int (buffer-substring - (match-beginning 1) - (match-end 1))) ; month - (string-to-int (buffer-substring - (match-beginning 2) - (match-end 2))) ; day - (string-to-int (buffer-substring - (match-beginning 4) - (match-end 4))) ; hour - (string-to-int (buffer-substring - (match-beginning 5) - (match-end 5))) ; minutes - (string-to-int (buffer-substring - (match-beginning 6) - (match-end 6)))) ; seconds - (buffer-substring bol nbol)) - list)) - (goto-char nbol)) - (if list - (progn - (setq list - (mapcar 'cdr - (sort list 'efs-cms-t-converter-sort-pred))) - (if reverse (setq list (nreverse list))) - (delete-region list-start (point)) - (apply 'insert list))) - t))))) - -(defun efs-cms-t-converter-sort-pred (elt1 elt2) - (let* ((data1 (car elt1)) - (data2 (car elt2)) - (year1 (car data1)) - (year2 (car data2)) - (month1 (nth 1 data1)) - (month2 (nth 1 data2)) - (day1 (nth 2 data1)) - (day2 (nth 2 data2)) - (hour1 (nth 3 data1)) - (hour2 (nth 3 data2)) - (minute1 (nth 4 data1)) - (minute2 (nth 4 data2)) - (second1 (nth 5 data1)) - (second2 (nth 5 data2))) - (or (> year1 year2) - (and (= year1 year2) - (or (> month1 month2) - (and (= month1 month2) - (or (> day1 day2) - (and (= day1 day2) - (or (> hour1 hour2) - (and (= hour1 hour2) - (or (> minute1 minute2) - (and (= minute1 minute2) - (or (> (nth 5 data1) - (nth 5 data2))) - )))))))))))) - - -;;; Tree dired support: - -(defconst efs-dired-cms-re-exe "^. [-A-Z0-9$_+]+ +EXEC ") - -(or (assq 'cms efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'cms efs-dired-cms-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-cms-re-dir "^. [-A-Z0-9$_+]+ +DIR ") - -(or (assq 'cms efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'cms efs-dired-cms-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline cms (dir) - ;; CMS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename cms - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; This is the CMS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-cms-file-line-regexp eol t) - (goto-char (match-beginning 0)) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename cms - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the CMS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9$_+") - (or (looking-at " +DIR ") - (progn - (skip-chars-forward " ") - (skip-chars-forward "-A-Z0-9$_+"))) - (if (or (= opoint (point)) (/= (following-char) ?\ )) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-make-filename-string cms (filename &optional reverse) - (if reverse - (if (string-match "\\." filename) - ;; Can't count on the number of blanks between the base and the - ;; extension, so ignore the extension. - (substring filename 0 (match-beginning 0)) - filename) - (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" filename) - (concat (substring filename 0 (match-end 1)) - "." - (substring filename (match-beginning 2) (match-end 2))) - filename))) - -;;; end of efs-cms.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-coke.el --- a/lisp/efs/efs-coke.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,176 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-coke.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Coke Machine support for efs -;; Author: Sandy Rutherford -;; Created: Fri Oct 14 23:55:04 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 12:16:47 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-coke) -(require 'efs) - -(defconst efs-coke-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; Coke Machine support -;;;; ------------------------------------------------------------ -;;; -;;; Works for the MIT vending machine FTP server. -;;; Hopefully, a vending machine RFC is on its way, so we won't -;;; need to support a wide variation of vending machine protocols. - -(efs-defun efs-send-pwd coke (host user &optional xpwd) - ;; Directories on vending machines? - "/") - -(efs-defun efs-fix-path coke (path &optional reverse) - (if (= ?/ (aref path 0)) - (if reverse path (substring path 1)) - (if reverse (concat "/" path) path))) - -(efs-defun efs-fix-dir-path coke (dir-path) - ;; Make a beverage path for a dir listing. - (if (or (string-equal dir-path "/") (string-equal dir-path "/.")) - "*" - dir-path)) - -(efs-defun efs-parse-listing coke - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in coke machine - ;; ftp dir format. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a remote full path - ;; PATH = directory as an efs full path - ;; SWITCHES are never used here, but they - ;; must be specified in the argument list for compatibility - ;; with the unix version of this function. - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward "^\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\)" - nil t) - (efs-put-hash-entry (buffer-substring (match-beginning 2) - (match-end 2)) - (list nil) tbl) - (forward-line 1))) - ;; Don't need to bother with .. - (efs-put-hash-entry "." '(t) tbl) - tbl)) - -(efs-defun efs-allow-child-lookup coke (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Coke machine file system is flat. Hopefully not the coke. - (and (string-equal "/" dir) (string-equal "." file))) - -(defun efs-coke-insert-beverage-contents (buffer file line) - ;; Inserts the contents of a beverage (determined by the FTP server - ;; response LINE) into BUFFER, and then drinks it. - ;; FILE is the name of the file. - (efs-save-buffer-excursion - (set-buffer buffer) - (if (zerop (buffer-size)) - (progn - (insert "\n\n\n\n " (substring line 4) "\n") - (set-buffer-modified-p nil) - (set-process-sentinel - (start-process "efs-coke-gulp-buffer" (current-buffer) "sleep" "3") - (function - (lambda (proc str) - (efs-save-buffer-excursion - (let ((buff (process-buffer proc))) - (and buff (get-buffer buff) - (progn - (set-buffer buff) - (erase-buffer) - (insert "\n\n\n\n GULP!!!\n") - (sit-for 1) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))))))))) - (if (featurep 'dired) - (dired-fun-in-all-buffers - (file-name-directory file) 'dired-revert))) - (message "You haven't finished your last drink in buffer %s!" - (current-buffer)) - (ding) - (sit-for 1)))) - -;;; Dired support - -(efs-defun efs-dired-manual-move-to-filename coke - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the COKE version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (looking-at "\\(. \\)?\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\): ") - (goto-char (match-beginning 3)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename coke - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the COKE version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (search-forward ": " eol t) - (goto-char (- (match-end 0) 2)) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline coke (dir) - (let* ((parsed (efs-ftp-path dir)) - (host (car parsed)) - (user (nth 1 parsed)) - (accounting - (efs-send-cmd - host user '(quote pwd) - (format "Getting accounting data for %s@%s user host" user host)))) - (insert " " user "@" host "\n " - (if (car accounting) - "Account status unavailable" - (substring (nth 1 accounting) 4))) - (delete-region (point) (progn (skip-chars-backward ":.,;") (point))) - (insert ":\n \n"))) - -;;; end of efs-coke.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-cp-p.el --- a/lisp/efs/efs-cp-p.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cp-p.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Support for preserving file modtimes with copies. i.e. cp -p -;; Author: Sandy Rutherford -;; Created: Fri Feb 18 03:28:22 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 12:17:33 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-cp-p) -(require 'efs) - -;;;; Internal Variables - -(defconst efs-cp-p-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defvar efs-local-timezone nil) -;; cache. - -;;; Utility functions - -(efs-define-fun efs-gmt-time () - ;; Get the time as the number of seconds elapsed since midnight, - ;; Jan 1, 1970, GMT. Emacs 18 doesn't have `current-time' function. - (let ((time (current-time))) - (list (car time) (nth 1 time)))) - -(defun efs-local-time () - (let ((str (current-time-string))) - (efs-seconds-elapsed - (string-to-int (substring str -4)) - (cdr (assoc (substring str 4 7) efs-month-alist)) - (string-to-int (substring str 8 10)) - (string-to-int (substring str 11 13)) - (string-to-int (substring str 14 16)) - 0))) ; don't care about seconds - -(defun efs-local-timezone () - ;; Returns the local timezone as an integer. Right two digits the minutes, - ;; others the hours. - (or efs-local-timezone - (setq efs-local-timezone - (let* ((local (efs-local-time)) - (gmt (efs-gmt-time)) - (sign 1) - (diff (efs-time-minus local gmt)) - hours minutes) - ;; 2^16 is 36 hours. - (if (zerop (car diff)) - (setq diff (nth 1 diff)) - (error "Weird timezone!")) - (setq diff (/ (- (nth 1 local) (nth 1 gmt)) 60)) - (setq hours (/ diff 60)) - (setq minutes (% diff 60)) - (if (< diff 0) - (setq sign -1 - hours (- hours) - minutes (- minutes))) - ;; Round minutes - (setq minutes (* 10 (/ (+ minutes 5) 10))) - (if (= minutes 60) - (setq hours (1+ hours) - minutes 0)) - (* sign (+ (* hours 100) minutes)))))) - -(defun efs-last-day-of-month (month year) - ;; The last day in MONTH during YEAR. - ;; Taken from calendar.el. Thanks. - (if (and - (or - (and (= (% year 4) 0) - (/= (% year 100) 0)) ; leap-year-p - (= (% year 400) 0)) - (= month 2)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - -(defun efs-make-date-local (year month day hour minutes seconds) - ;; Takes a GMT date (list of integers), and returns the local time. - (let* ((lzone (efs-local-timezone)) - (lminutes (% lzone 100)) - (lhour (/ lzone 100))) - (setq minutes (+ minutes lminutes)) - (cond ((> minutes 60) - (setq minutes (- minutes 60) - hour (1+ hour))) - ((< minutes 0) - (setq minutes (+ minutes 60) - hour (1- hour)))) - (setq hour (+ lhour hour)) - (if (or (< hour 0) (> hour 23)) - (progn - (cond ((< hour 0) - (setq hour (+ hour 24) - day (1- day))) - ((> hour 23) - (setq hour (- hour 24) - day (1+ day)))) - (if (or (zerop day) (> day - (efs-last-day-of-month month year))) - (cond ((zerop day) - (setq month (1- month)) - (if (zerop month) - (setq year (1- year) - month 12)) - (setq day (efs-last-day-of-month month year))) - ((> day (efs-last-day-of-month month year)) - (setq month (1+ month) - day 1) - (if (= month 13) - (setq year (1+ year) - month 1))))))) - (list year month day hour minutes seconds))) - -;;;; Entry function - -(defun efs-set-mdtm-of (filename newname &optional cont) - ;; NEWNAME must be local - ;; Always works NOWAIT = 0 - (let* ((parsed (efs-ftp-path filename)) - (host (car parsed)) - (user (nth 1 parsed)) - (file (nth 2 parsed))) - (if (efs-get-host-property host 'mdtm-failed) - (and cont (efs-call-cont cont 'failed "" "") nil) - (efs-send-cmd - host user - (list 'quote 'mdtm file) - nil nil - (efs-cont (result line cont-lines) (host newname cont) - (if (or result - (not (string-match efs-mdtm-msgs line))) - (efs-set-host-property host 'mdtm-failed t) - (let ((time (apply 'efs-make-date-local - (mapcar 'string-to-int - (list - (substring line 4 8) - (substring line 8 10) - (substring line 10 12) - (substring line 12 14) - (substring line 14 16) - (substring line 16 18)))))) - (if time - (call-process "touch" nil 0 nil "-t" - (format "%04d%02d%02d%02d%02d.%02d" - (car time) (nth 1 time) - (nth 2 time) (nth 3 time) - (nth 4 time) (nth 5 time)) - newname)))) - (if cont (efs-call-cont cont result line cont-lines))) - 0)))) - -;;; end of efs-cp-p.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-cu.el --- a/lisp/efs/efs-cu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,637 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cu.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.12 $ -;; RCS: -;; Description: Common utilities needed by efs files. -;; Author: Sandy Rutherford -;; Created: Fri Jan 28 19:55:45 1994 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;;; Provisions and autoloads. - -(provide 'efs-cu) -(require 'backquote) -(autoload 'efs-get-process "efs") -(autoload 'efs-parse-netrc "efs-netrc") - -;;;; ------------------------------------------------------------ -;;;; Use configuration variables. -;;;; ------------------------------------------------------------ - -(defvar efs-default-user "anonymous" - "*User name to use when none is specied in a pathname. - -If a string, than this string is used as the default user name. -If nil, then the name under which the user is logged in is used. -If t, then the user is prompted for a name. -If an association list of the form - - '((REGEXP1 . USERNAME1) (REGEXP2 . USERNAME2) ...) - -then the host name is tested against each of the regular expressions -REGEXP in turn, and the default user name is the corresponding value -of USERNAME. USERNAME may be either a string, nil, or t, and these -values are interpreted as above. If there are no matches, then the -user's curent login name is used.") - -(defvar efs-default-password nil - "*Password to use when the user is the same as efs-default-user.") - -(defvar efs-default-account nil - "*Account password to use when the user is efs-default-user.") - -;;;; ------------------------------------------------------------- -;;;; Internal variables. -;;;; ------------------------------------------------------------- - -(defconst efs-cu-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.12 $" 11 -2))) - -(defconst efs-case-insensitive-host-types - '(vms cms mts ti-twenex ti-explorer dos mvs tops-20 mpe ka9q dos-distinct - os2 hell guardian ms-unix netware cms-knet nos-ve) - "List of host types for which case is insignificant in file names.") - -;;; Remote path name syntax - -;; All of the following variables must be set consistently. -;; As well the below two functions depend on the grouping constructs -;; in efs-path-regexp. So know what you're doing if you change them. - -(defvar efs-path-regexp "^/\\([^@:/]*@\\)?\\([^@:/]*\\):.*" - "Regexp of a fully expanded remote path.") - -(defvar efs-path-format-string "/%s@%s:%s" - "Format of a fully expanded remote path. Passed to format with -additional arguments user, host, and remote path.") - -(defvar efs-path-format-without-user "/%s:%s" - "Format of a remote path, but not specifying a user.") - -(defvar efs-path-user-at-host-format - (substring efs-path-format-string 1 7) - "Format to return `user@host:' strings for completion in root directory.") - -(defvar efs-path-host-format - (substring efs-path-user-at-host-format 3) - "Format to return `host:' strings for completion in root directory.") - -;;;###autoload -(defvar efs-path-root-regexp "^/[^/:]+:" - "Regexp to match the `/user@host:' root of an efs full path.") - -(defvar efs-path-root-short-circuit-regexp "//[^/:]+:") -;; Regexp to match an efs user@host root, which short-circuits -;; the part of the path to the left of this pattern. - -;;;; ----------------------------------------------------------- -;;;; Variables for multiple host type support -;;;; ----------------------------------------------------------- - -(defvar efs-vms-host-regexp nil - "Regexp to match the names of hosts running VMS.") -(defvar efs-cms-host-regexp nil - "Regexp to match the names of hosts running CMS.") -(defvar efs-mts-host-regexp nil - "Regexp to match the names of hosts running MTS.") -(defvar efs-ti-explorer-host-regexp nil - "Regexp to match the names of hosts running TI-EXPLORER. -These are lisp machines.") -(defvar efs-ti-twenex-host-regexp nil - "Regexp to match the names of hosts running TI-TWENEX. -These are lisp machines, and this should not be confused with DEC's TOPS-20.") -(defvar efs-sysV-unix-host-regexp nil - "Regexp to match the names of sysV unix hosts. -These are defined to be unix hosts which mark symlinks -with a @ in an ls -lF listing.") -(defvar efs-bsd-unix-host-regexp nil - "Regexp to match the names of bsd unix hosts. -These are defined to be unix hosts which do not mark symlinks -with a @ in an ls -lF listing.") -(defvar efs-next-unix-host-regexp nil - "Regexp to match names of NeXT unix hosts. -These are defined to be unix hosts which put a @ after the -destination of a symlink when doing ls -lF listing.") -(defvar efs-unix-host-regexp nil - "Regexp to match names of unix hosts. -I you know which type of unix, it is much better to set that regexp instead.") -(defvar efs-dumb-unix-host-regexp nil - "Regexp to match names of unix hosts which do not take ls switches. -For these hosts we use the \"dir\" command.") -(defvar efs-super-dumb-unix-host-regexp nil - "Regexp to match names of unix hosts with FTP servers that cannot do a PWD. -It is also assumed that these hosts do not accept ls switches, whether -or not this is actually true.") -(defvar efs-dos-host-regexp nil - "Regexp to match names of hosts running DOS.") -;; In principal there is apollo unix support -- at least efs -;; should do the right thing. However, apollo ftp servers can be -;; very flakey, especially about accessing files by fullpaths. -;; Good luck. -(defvar efs-apollo-unix-host-regexp nil - "Regexp to match names of apollo unix hosts running Apollo's Domain. -For these hosts we don't short-circuit //'s immediately following -\"/user@host:\"") -(defvar efs-mvs-host-regexp nil - "Regexp to match names of hosts running MVS.") -(defvar efs-tops-20-host-regexp nil - "Regexp to match names of hosts runninf TOPS-20.") -(defvar efs-mpe-host-regexp nil - "Regexp to match hosts running the MPE operating system.") -(defvar efs-ka9q-host-regexp nil - "Regexp to match hosts using the ka9q ftp server. -These may actually be running one of DOS, LINUX, or unix.") -(defvar efs-dos-distinct-host-regexp nil - "Regexp to match DOS hosts using the Distinct FTP server. -These are not treated as DOS hosts with a special listing format, because -the Distinct FTP server uses unix-style path syntax.") -(defvar efs-os2-host-regexp nil - "Regexp to match names of hosts running OS/2.") -(defvar efs-vos-host-regexp nil - "Regexp to match hosts running the VOS operating system.") -(defvar efs-hell-host-regexp nil - "Regexp to match hosts using the hellsoft ftp server. -These map be either DOS PC's or Macs.") -;; The way that we implement the hellsoft support, it probably won't -;; work with Macs. This could probably be fixed, if enough people scream. -(defvar efs-guardian-host-regexp nil - "Regexp to match hosts running Tandem's guardian operating system.") -;; Note that ms-unix is really an FTP server running under DOS. -;; It's not a type of unix. -(defvar efs-ms-unix-host-regexp nil - "Regexp to match hosts using the Microsoft FTP server in unix mode.") -(defvar efs-plan9-host-regexp nil - "Regexp to match hosts running ATT's Plan 9 operating system.") -(defvar efs-cms-knet-host-regexp nil - "Regexp to match hosts running the CMS KNET FTP server.") -(defvar efs-nos-ve-host-regexp nil - "Regexp to match hosts running NOS/VE.") -(defvar efs-netware-host-regexp nil - "Regexp to match hosts running Novell Netware.") -(defvar efs-dumb-apollo-unix-regexp nil - "Regexp to match dumb hosts running Apollo's Domain. -These are hosts which do not accept switches to ls over FTP.") - -;;; Further host types: -;; -;; unknown: This encompasses ka9q, dos-distinct, unix, sysV-unix, bsd-unix, -;; next-unix, and dumb-unix. - -(defconst efs-host-type-alist - ;; When efs-add-host is called interactively, it will only allow - ;; host types from this list. - '((dumb-unix . efs-dumb-unix-host-regexp) - (super-dumb-unix . efs-super-dumb-unix-host-regexp) - (next-unix . efs-next-unix-host-regexp) - (sysV-unix . efs-sysV-unix-host-regexp) - (bsd-unix . efs-bsd-unix-host-regexp) - (apollo-unix . efs-apollo-unix-host-regexp) - (unix . efs-unix-host-regexp) - (vms . efs-vms-host-regexp) - (mts . efs-mts-host-regexp) - (cms . efs-cms-host-regexp) - (ti-explorer . efs-ti-explorer-host-regexp) - (ti-twenex . efs-ti-twenex-host-regexp) - (dos . efs-dos-host-regexp) - (mvs . efs-mvs-host-regexp) - (tops-20 . efs-tops-20-host-regexp) - (mpe . efs-mpe-host-regexp) - (ka9q . efs-ka9q-host-regexp) - (dos-distinct . efs-dos-distinct-host-regexp) - (os2 . efs-os2-host-regexp) - (vos . efs-vos-host-regexp) - (hell . efs-hell-host-regexp) - (guardian . efs-guardian-host-regexp) - (ms-unix . efs-ms-unix-host-regexp) - (plan9 . efs-plan9-host-regexp) - (cms-net . efs-cms-knet-host-regexp) - (nos-ve . efs-nos-ve-host-regexp) - (netware . efs-netware-host-regexp) - (dumb-apollo-unix . efs-dumb-apollo-unix-regexp))) - -;; host type cache -(defconst efs-host-cache nil) -(defconst efs-host-type-cache nil) - -;; cache for efs-ftp-path. -(defconst efs-ftp-path-arg "") -(defconst efs-ftp-path-res nil) - -;;;; ------------------------------------------------------------- -;;;; General macros. -;;;; ------------------------------------------------------------- - -(defmacro efs-save-match-data (&rest body) - "Execute the BODY forms, restoring the global value of the match data. -Before executing BODY, case-fold-search is locally bound to nil." - ;; Because Emacs is buggy about let-binding buffer-local variables, - ;; we have to do this in a slightly convoluted way. - (let ((match-data-temp (make-symbol "match-data")) - (buff-temp (make-symbol "buff")) - (cfs-temp (make-symbol "cfs"))) - (list - 'let (list (list match-data-temp '(match-data)) - (list buff-temp '(current-buffer)) - (list cfs-temp 'case-fold-search)) - (list 'unwind-protect - (cons 'progn - (cons - '(setq case-fold-search nil) - body)) - (list 'condition-case nil - (list 'save-excursion - (list 'set-buffer buff-temp) - (list 'setq 'case-fold-search cfs-temp)) - '(error nil)) - (list 'store-match-data match-data-temp))))) - -(put 'efs-save-match-data 'lisp-indent-hook 0) -(put 'efs-save-match-data 'edebug-form-spec '(&rest form)) - -(defmacro efs-define-fun (fun args &rest body) - "Like defun, but only defines a function if it has no previous definition." - ;; There are easier ways to do this. This approach is used so that the - ;; byte compiler won't complain about possibly undefined functions. - (` - (progn - (put (quote (, fun)) 'efs-define-fun - (and (fboundp (quote (, fun))) - (symbol-function (quote (, fun))))) - (defun (, fun) (, args) (,@ body)) - (if (and (get (quote (, fun)) 'efs-define-fun) - (not (eq (car-safe (get (quote (, fun)) 'efs-define-fun)) - (quote autoload)))) - (fset (quote (, fun)) (get (quote (, fun)) 'efs-define-fun))) - (put (quote (, fun)) 'efs-define-fun nil) - (quote (, fun))))) - -(put 'efs-define-fun 'lisp-indent-hook 'defun) - -(defmacro efs-quote-dollars (string) - ;; Quote `$' as `$$' in STRING to get it past `substitute-in-file-name.' - (` - (let ((string (, string)) - (pos 0)) - (while (setq pos (string-match "\\$" string pos)) - (setq string (concat (substring string 0 pos) - "$";; precede by escape character (also a $) - (substring string pos)) - ;; add 2 instead 1 since another $ was inserted - pos (+ 2 pos))) - string))) - -(defmacro efs-cont (implicit-args explicit-args &rest body) - "Defines an efs continuation function. -The IMPLICIT-ARGS are bound when the continuation function is called. -The EXPLICIT-ARGS are bound when the continuation function is set." - (let ((fun (list 'function - (cons 'lambda - (cons - (append implicit-args explicit-args) - body))))) - (if explicit-args - (cons 'list (cons fun explicit-args)) - fun))) - -(put 'efs-cont 'lisp-indent-hook 2) - -;;;; ------------------------------------------------------------ -;;;; Utility functions -;;;; ------------------------------------------------------------ - -(efs-define-fun efs-repaint-minibuffer () - ;; Set minibuf_message = 0, so that the contents of the minibuffer will show. - ;; This is the Emacs V19 version of this function. For Emacs 18, it will - ;; be redefined in a grotty way to accomplish the same thing. - (message nil)) - -(defun efs-get-user (host) - "Given a HOST, return the default USER." - (efs-parse-netrc) - ;; We cannot check for users case-insensitively on those systems - ;; which are treat usernames case-insens., because we need to log in - ;; first, before we know what type of system. - (let ((user (efs-get-host-property host 'user))) - (if (stringp user) - user - (prog1 - (setq user - (cond ((stringp efs-default-user) - ;; We have a default name. Use it. - efs-default-user) - ((consp efs-default-user) - ;; Walk the list looking for a host-specific value. - (efs-save-match-data - (let ((alist efs-default-user) - (case-fold-search t) - result) - (while alist - (if (string-match (car (car alist)) host) - (setq result (cdr (car alist)) - alist nil) - (setq alist (cdr alist)))) - (cond - ((stringp result) - result) - (result - (let ((enable-recursive-minibuffers t)) - (read-string (format "User for %s: " host) - (user-login-name)))) - (t - (user-login-name)))))) - (efs-default-user - ;; Ask the user. - (let ((enable-recursive-minibuffers t)) - (read-string (format "User for %s: " host) - (user-login-name)))) - ;; Default to the user's login name. - (t - (user-login-name)))) - (efs-set-user host user))))) - -;;;###autoload -(defun efs-ftp-path (path) - "Parse PATH according to efs-path-regexp. -Returns a list (HOST USER PATH), or nil if PATH does not match the format." - (or (string-equal path efs-ftp-path-arg) - (setq efs-ftp-path-res - (efs-save-match-data - (and (string-match efs-path-regexp path) - (let ((host (substring path (match-beginning 2) - (match-end 2))) - (user (and (match-beginning 1) - (substring path (match-beginning 1) - (1- (match-end 1))))) - (rpath (substring path (1+ (match-end 2))))) - (list (if (string-equal host "") - (setq host (system-name)) - host) - (or user (efs-get-user host)) - rpath)))) - ;; Set this last, in case efs-get-user calls this - ;; function, which would modify an earlier setting. - efs-ftp-path-arg path)) - efs-ftp-path-res) - -(defun efs-chase-symlinks (file) - ;; If FILE is a symlink, chase it until we get to a real file. - ;; Unlike file truename, this function does not chase symlinks at - ;; every level, only the bottom level. Therefore, it is not useful for - ;; obtaining the truename of a file. It is useful for getting at file - ;; attributes, with a lot less overhead than file truename. - (let ((target (file-symlink-p file))) - (if target - (efs-chase-symlinks - (expand-file-name target (file-name-directory file))) - file))) - -;; If efs-host-type is called with the optional user -;; argument, it will attempt to guess the host type by connecting -;; as user, if necessary. - -(defun efs-host-type (host &optional user) - "Return a symbol which represents the type of the HOST given. -If the optional argument USER is given, attempts to guess the -host-type by logging in as USER." - - (and host - (let ((host (downcase host)) - type) - (cond - - ((and efs-host-cache - (string-equal host efs-host-cache) - efs-host-type-cache)) - - ((setq type - (efs-get-host-property host 'host-type)) - (setq efs-host-cache host - efs-host-type-cache type)) - - ;; Trigger an ftp connection, in case we need to - ;; guess at the host type. - ((and user (efs-get-process host user) - (if (string-equal host efs-host-cache) - ;; logging in may update the cache - efs-host-type-cache - (and (setq type (efs-get-host-property host 'host-type)) - (setq efs-host-cache host - efs-host-type-cache type))))) - - ;; Try the regexps. - ((setq type - (let ((alist efs-host-type-alist) - regexp type-pair) - (catch 'match - (efs-save-match-data - (let ((case-fold-search t)) - (while alist - (progn - (and (setq type-pair (car alist) - regexp (eval (cdr type-pair))) - (string-match regexp host) - (throw 'match (car type-pair))) - (setq alist (cdr alist))))) - nil)))) - (setq efs-host-cache host - efs-host-type-cache type)) - ;; Return 'unknown, but _don't_ cache it. - (t 'unknown))))) - -;;;; ------------------------------------------------------------- -;;;; Functions and macros for hashtables. -;;;; ------------------------------------------------------------- - -(defun efs-make-hashtable (&optional size) - "Make an obarray suitable for use as a hashtable. -SIZE, if supplied, should be a prime number." - (make-vector (or size 31) 0)) - -(defun efs-map-hashtable (fun tbl &optional property) - "Call FUNCTION on each key and value in HASHTABLE. -If PROPERTY is non-nil, it is the property to be used as the second -argument to FUNCTION. The default property is 'val" - (let ((prop (or property 'val))) - (mapatoms - (function - (lambda (sym) - (funcall fun (symbol-name sym) (get sym prop)))) - tbl))) - -(defmacro efs-make-hash-key (key) - "Convert KEY into a suitable key for a hashtable. This returns a string." - (` (let ((key (, key))) ; eval exactly once, in case evalling key moves the - ; point. - (if (stringp key) key (prin1-to-string key))))) - -;;; Note, if you store entries in a hashtable case-sensitively, and then -;;; retrieve them with IGNORE-CASE=t, it is possible that there may be -;;; be more than one entry that could be retrieved. It is more or less random -;;; which one you'll get. The onus is on the programmer to be consistent. -;;; Suggestions to make this faster are gratefully accepted! - -(defmacro efs-case-fold-intern-soft (name tbl) - "Returns a symbol with case-insensitive name NAME in the obarray TBL. -Case is considered insignificant in NAME. Note, if there is more than -one possible match, it is hard to predicate which one you'll get." - (` - (let* ((completion-ignore-case t) - (name (, name)) - (tbl (, tbl)) - (len (length (, name))) - (newname (try-completion name tbl - (function - (lambda (sym) - (= (length (symbol-name sym)) len)))))) - (and newname - (if (eq newname t) - (intern name tbl) - (intern newname tbl)))))) - -(defmacro efs-hash-entry-exists-p (key tbl &optional ignore-case) - "Return whether there is an association for KEY in TABLE. -If optional IGNORE-CASE is non-nil, then ignore-case in the test." - (` (let ((key (efs-make-hash-key (, key)))) - (if (, ignore-case) - (efs-case-fold-intern-soft key (, tbl)) - (intern-soft key (, tbl)))))) - -(defmacro efs-get-hash-entry (key tbl &optional ignore-case) - "Return the value associated with KEY in HASHTABLE. -If the optional argument IGNORE-CASE is given, then case in the key is -considered irrelevant." - (` (let* ((key (efs-make-hash-key (, key))) - (sym (if (, ignore-case) - (efs-case-fold-intern-soft key (, tbl)) - (intern-soft key (, tbl))))) - (and sym (get sym 'val))))) - -(defmacro efs-put-hash-entry (key val tbl &optional ignore-case) - "Record an association between KEY and VALUE in HASHTABLE. -If the optional IGNORE-CASE argument is given, then check for an entry -which is the same modulo case, and update it instead of adding a new entry." - (` (let* ((key (efs-make-hash-key (, key))) - (sym (if (, ignore-case) - (or (efs-case-fold-intern-soft key (, tbl)) - (intern key (, tbl))) - (intern key (, tbl))))) - (put sym 'val (, val))))) - -(defun efs-del-hash-entry (key tbl &optional ignore-case) - "Copy all symbols except KEY in HASHTABLE and return modified hashtable. -If the optional argument CASE-FOLD is non-nil, then fold KEY to lower case." - (let* ((len (length tbl)) - (new-tbl (efs-make-hashtable len)) - (i (1- len)) - (key (efs-make-hash-key key))) - (if ignore-case (setq key (downcase key))) - (efs-map-hashtable - (if ignore-case - (function - (lambda (k v) - (or (string-equal (downcase k) key) - ;; Don't need to specify ignore-case here, because - ;; we have already weeded out possible case-fold matches. - (efs-put-hash-entry k v new-tbl)))) - (function - (lambda (k v) - (or (string-equal k key) - (efs-put-hash-entry k v new-tbl))))) - tbl) - (while (>= i 0) - (aset tbl i (aref new-tbl i)) - (setq i (1- i))) - ;; Return the result. - tbl)) - -(defun efs-hash-table-keys (tbl &optional nosort) - "Return a sorted of all the keys in the hashtable TBL, as strings. -This list is sorted, unless the optional argument NOSORT is non-nil." - (let ((result (all-completions "" tbl))) - (if nosort - result - (sort result (function string-lessp))))) - -;;; hashtable variables - -(defconst efs-host-hashtable (efs-make-hashtable) - "Hash table holding data on hosts.") - -(defconst efs-host-user-hashtable (efs-make-hashtable) - "Hash table for holding data on host user pairs.") - -(defconst efs-minidisk-hashtable (efs-make-hashtable) - "Mapping between a host, user, minidisk triplet and a account password.") - -;;;; ------------------------------------------------------------ -;;;; Host / User mapping -;;;; ------------------------------------------------------------ - -(defun efs-set-host-property (host property value) - ;; For HOST, sets PROPERTY to VALUE. - (put (intern (downcase host) efs-host-hashtable) property value)) - -(defun efs-get-host-property (host property) - ;; For HOST, gets PROPERTY. - (get (intern (downcase host) efs-host-hashtable) property)) - -(defun efs-set-host-user-property (host user property value) - ;; For HOST and USER, sets PROPERTY to VALUE. - (let* ((key (concat (downcase host) "/" user)) - (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) - (efs-case-fold-intern-soft key efs-host-user-hashtable)))) - (or sym (setq sym (intern key efs-host-user-hashtable))) - (put sym property value))) - -(defun efs-get-host-user-property (host user property) - ;; For HOST and USER, gets PROPERTY. - (let* ((key (concat (downcase host) "/" user)) - (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) - (efs-case-fold-intern-soft key efs-host-user-hashtable)))) - (or sym (setq sym (intern key efs-host-user-hashtable))) - (get sym property))) - -(defun efs-set-user (host user) - "For a given HOST, set or change the default USER." - (interactive "sHost: \nsUser: ") - (efs-set-host-property host 'user user)) - -;;;; ------------------------------------------------------------ -;;;; Encryption -;;;; ------------------------------------------------------------ - -(defconst efs-passwd-seed nil) -;; seed used to encrypt the password cache. - -(defun efs-get-passwd-seed () - ;; Returns a random number to use for encrypting passwords. - (or efs-passwd-seed - (setq efs-passwd-seed (+ 1 (random 255))))) - -(defun efs-code-string (string) - ;; Encode a string, using `efs-passwd-seed'. This is nil-potent, - ;; meaning applying it twice decodes. - (if (and (fboundp 'int-to-char) (fboundp 'char-to-int)) - (mapconcat - (function - (lambda (c) - (char-to-string - (int-to-char (logxor (efs-get-passwd-seed) (char-to-int c)))))) - string "") - (mapconcat - (function - (lambda (c) - (char-to-string (logxor (efs-get-passwd-seed) c)))) - string ""))) - -;;; end of efs-cu.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-defun.el --- a/lisp/efs/efs-defun.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-defun.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: efs-defun allows for OS-dependent coding of functions -;; Author: Sandy Rutherford -;; Created: Thu Oct 22 17:58:14 1992 -;; Modified: Sun Nov 27 12:18:35 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; efs-defun allows object-oriented emacs lisp definitions. -;;; In efs, this feature is used to support multiple host types. -;;; -;;; The first arg after the function name is a key which determines -;;; which version of the function is being defined. Normally, when the function -;;; is called this key is given as the first argument to the function. -;;; -;;; For example: -;;; -;;; (efs-defun foobar vms (x y) -;;; (message "hello vms world") -;;; (+ x y)) -;;; => foobar -;;; -;;; (foobar 'vms 1 2) -;;; => 3 - -;;; The key nil plays a special role: -;;; -;;; First, it defines a default action. If there is no function -;;; definition associated with a given OS-key, then the function -;;; definition associated with nil is used. If further there is no -;;; function definition associated with nil, then an error is -;;; signaled. -;;; -;;; Second, the documentation string for the function is the one given -;;; with the nil definition. You can supply doc-strings with other -;;; definitions of the function, but they are not accessible with -;;; 'describe-function. In fact, when the function is either loaded or -;;; byte-compiled, they are just thrown away. - -;;; There is another way to define the default action of an efs-function. -;;; This is with the use flag. If you give as the key (&use foobar), -;;; then when the function is called the variable foobar will be used to -;;; determine which OS version of the function to use. As well as -;;; allowing you to define the doc string, if the use flag is used, -;;; then you can specify an interactive specification with the function. -;;; Although a function is only interactive, if the default definition -;;; has an interactive spec, it is still necessary to give interactive -;;; specs for the other definitions of the function as well. It is possible -;;; for these interactive specs to differ. -;;; -;;; For example: -;;; -;;; (efs-defun fizzle (&use foobar) -;;; "Fizzle's doc string." -;;; (interactive) -;;; (message "fizz wizz")) -;;; -;;; (efs-defun fizzle vms -;;; (interactive) -;;; (message "VMS is fizzled.")) -;;; -;;; (setq foobar 'unix) -;;; => unix -;;; -;;; (fizzle) -;;; => "fizz wizz" -;;; -;;; (setq foobar 'vms) -;;; => vms -;;; -;;; (fizzle) -;;; => "VMS is fizzled." -;;; -;;; M-x f i z z l e -;;; => "VMS is fizzled." -;;; -;;; Actually, when you use the &use spec, whatever follows it is simply -;;; evaluated at call time. - -;;; Note that when the function is defined, the key is implicitly -;;; quoted, whereas when the function is called, the key is -;;; evaluated. If this seems strange, think about how efs-defuns -;;; are used in practice. - -;;; There are no restrictions on the order in which the different OS-type -;;; definitions are done. - -;;; There are no restrictions on the keys that can be used, nor on the -;;; symbols that can be used as arguments to an efs-defun. We go -;;; to some lengths to avoid potential conflicts. In particular, when -;;; the OS-keys are looked up in the symbol's property list, we -;;; actually look for a symbol with the same name in the special -;;; obarray, efs-key-obarray. This avoids possible conflicts with -;;; other entries in the property list, that are usually accessed with -;;; symbols in the standard obarray. - -;;; The V19 byte-compiler will byte-compile efs-defun's. -;;; The standard emacs V18 compiler will not, however they will still -;;; work, just not at byte-compiled speed. - -;;; efs-autoload works much like the standard autoload, except it -;;; defines the efs function cell for a given host type as an autoload. -;;; The from-kbd arg only makes sense if the default action of the autoload -;;; has been defined with a &use. - -;;; To do: -;;; -;;; 1. Set an edebug-form-hook for efs-defun - -;;; Known Bugs: -;;; -;;; 1. efs-autoload will correctly NOT overload an existing function -;;; definition with an autoload definition. However, it will also -;;; not overload a previous autoload with a new one. It should. An -;;; overload can be forced for the KEY def of function FUN by doing -;;; (put 'FUN (intern "KEY" efs-key-obarray) nil) first. -;;; - -;;; Provisions and requirements - -(provide 'efs-defun) -(require 'backquote) - -;;; Variables - -(defconst efs-defun-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defconst efs-key-obarray (make-vector 7 0)) - -;; Unfortunately, we need to track this in bytecomp.el. -;; It's not much to keep track of, although. -(defconst efs-defun-bytecomp-buffer "*Compile-Log*") - -(defvar efs-key nil - "Inside an efs function, this is set to the key that was used to -call the function. You can test this inside the default definition, to -determine which key was actually used.") -(defvar efs-args nil - "Inside an efs function, this is set to a list of the calling args -of the function.") - -;;; Utility Functions - -;;; These functions are called when the macros efs-defun and efs-autoload -;;; are expanded. Their purpose is to help in producing the expanded code. - -(defun efs-defun-arg-count (list) - ;; Takes a list of arguments, and returns a list of three - ;; integers giving the number of normal args, the number - ;; of &optional args, and the number of &rest args (this should - ;; only be 0 or 1, but we don't check this). - (let ((o-leng (length (memq '&optional list))) - (r-leng (length (memq '&rest list))) - (leng (length list))) - (list (- leng (max o-leng r-leng)) - (max 0 (- o-leng r-leng 1)) - (max 0 (1- r-leng))))) - -;; For each efs-function the property efs-function-arg-structure -;; is either a list of three integers to indicate the number of normal, -;; optional, and rest args, or it can be the symbol 'autoload to indicate -;; that all definitions of the function are autoloads, and we have no -;; idea of its arg structure. - -(defun efs-defun-arg-check (fun key list) - ;; Checks that the LIST of args is consistent for the KEY def - ;; of function FUN. - (let ((prop (get fun 'efs-function-arg-structure)) - count) - (if (eq list 'autoload) - (or prop (put fun 'efs-function-arg-structure 'autoload)) - (setq count (efs-defun-arg-count list)) - (if (and prop (not (eq prop 'autoload)) (not (equal prop count))) - (let ((warning - (format - "args. for the %s def. of %s don't agree with previous defs." - key fun))) - (message (concat "Warning: " warning)) - ;; We are compiling, I suppose... - (if (get-buffer efs-defun-bytecomp-buffer) - (save-excursion - (set-buffer efs-defun-bytecomp-buffer) - (goto-char (point-max)) - (insert "efs warning:\n " warning "\n"))))) - (put fun 'efs-function-arg-structure count)))) - -(defun efs-def-generic (fun use doc-string interactive-p) - ;; Generates a generic function def using USE. - ;; If use is nil, the first arg of the function - ;; is the key. - (let ((def-args '(&rest efs-args)) - result) - (or use - (setq def-args (cons 'efs-key def-args))) - (setq result - (` (or (get (quote (, fun)) - (, (if use - (list 'intern - (list 'symbol-name use) - 'efs-key-obarray) - '(intern - (symbol-name efs-key) - efs-key-obarray)))) - (get (quote (, fun)) - (intern "nil" efs-key-obarray))))) - ;; Make the gen fun interactive, if nec. - (setq result - (if interactive-p - (` ((interactive) - (if (interactive-p) - (let ((prefix-arg current-prefix-arg)) - (call-interactively - (, result))) - (, (cons 'apply (list result 'efs-args)))))) - (list (cons 'apply (list result 'efs-args))))) - (if doc-string (setq result (cons doc-string result))) - (cons 'defun (cons fun (cons def-args result))))) - -(defun efs-def-autoload (fun key file from-kbd) - ;; Returns the autoload lambda for FUN and FILE. - ;; I really should have some notion of efs-autoload - ;; objects, and not just plain lambda's. - (let ((result - (if from-kbd - (` - (lambda (&rest args) - (interactive) - (let ((qkey (intern (symbol-name (quote (, key))) - efs-key-obarray)) - (tmp1 (intern "tmp1" efs-key-obarray)) - (tmp2 (intern "tmp2" efs-key-obarray))) - ;; Need to store the a-f-function, to see if it has been - ;; re-defined by the load. This is avoid to an infinite loop. - (set tmp1 (get (quote (, fun)) qkey)) - ;; Need to store the prefix arg in case it's interactive. - ;; These values are stored in variables interned in the - ;; efs-key-obarray, because who knows what loading a - ;; file might do. - (set tmp2 current-prefix-arg) - (load (, file)) - ;; check for re-def - (if (equal (symbol-value tmp1) - (get (quote (, fun)) qkey)) - (error "%s definition of %s is not defined by loading %s" - qkey (quote (, fun)) (, file))) - ;; call function - (if (interactive-p) - (let ((prefix-arg (symbol-value tmp2))) - (call-interactively - (get (quote (, fun)) qkey))) - (apply (get (quote (, fun)) qkey) args))))) - (` (lambda (&rest args) - (let ((qkey (intern (symbol-name (quote (, key))) - efs-key-obarray)) - (tmp1 (intern "tmp1" efs-key-obarray))) - ;; Need to store the a-f-function, to see if it has been - ;; re-defined by the load. This is avoid to an infinite loop. - (set tmp1 (get (quote (, fun)) qkey)) - (load (, file)) - ;; check for re-def - (if (equal (symbol-value tmp1) - (get (quote (, fun)) qkey)) - (error "%s definition of %s is not defined by loading %s" - qkey (quote (, fun)) (, file))) - ;; call function - (apply (get (quote (, fun)) qkey) args))))))) - (list 'put (list 'quote fun) - (list 'intern - (list 'symbol-name (list 'quote key)) - 'efs-key-obarray) - (list 'function result)))) - -;;; User level macros -- efs-defun and efs-autoload. - -(defmacro efs-defun (funame key args &rest body) - (let* ((use (and (eq (car-safe key) '&use) - (nth 1 key))) - (key (and (null use) key)) - result doc-string interactive-p) - ;; check args - (efs-defun-arg-check funame key args) - ;; extract doc-string - (if (stringp (car body)) - (setq doc-string (car body) - body (cdr body))) - ;; If the default fun is interactive, and it's a use construct, - ;; then we allow the gen fun to be interactive. - (if use - (setq interactive-p (eq (car-safe (car-safe body)) 'interactive))) - (setq result - (` ((put (quote (, funame)) - (intern (symbol-name (quote (, key))) - efs-key-obarray) - (function - (, (cons 'lambda - (cons args body))))) - (quote (, funame))))) - ;; if the key is null, make a generic def - (if (null key) - (setq result - (cons (efs-def-generic - funame use doc-string interactive-p) - result))) - ;; return - (cons 'progn result))) - -;;; For lisp-mode - -(put 'efs-defun 'lisp-indent-hook 'defun) - -;; efs-autoload -;; Allows efs function cells to be defined as autoloads. -;; If efs-autoload inserted autoload objects in the property list, -;; and the funcall mechanism in efs-defun checked for such -;; auto-load objects, we could reduce the size of the code -;; resulting from expanding efs-autoload. However, the expansion -;; of efs-defun would be larger. What is the best thing to do? - -(defmacro efs-autoload (fun key file &optional docstring from-kbd) - (let* ((use (and (eq (car-safe key) '&use) - (nth 1 key))) - (key (and (null use) key))) - (efs-defun-arg-check (eval fun) key 'autoload) - ;; has the function been previously defined? - (` - (if (null (get (, fun) - (intern (symbol-name (quote (, key))) - efs-key-obarray))) - (, - (if (null key) - (list 'progn - ;; need to eval fun, since autoload wants an explicit - ;; quote built into the fun arg. - (efs-def-generic - (eval fun) use docstring from-kbd ) - (efs-def-autoload (eval fun) key file from-kbd) - (list 'quote - (list - 'efs-autoload - key file docstring from-kbd))) - (list 'progn - (efs-def-autoload (eval fun) key file from-kbd) - (list 'quote - (list - 'efs-autoload - key file docstring from-kbd))))))))) - -(defun efs-fset (sym key fun) - ;; Like fset but sets KEY's definition of SYM. - (put sym (intern (symbol-name key) efs-key-obarray) fun)) - -(defun efs-fboundp (key fun) - ;; Like fboundp, but checks for KEY's def. - (null (null (get fun (intern (symbol-name key) efs-key-obarray))))) - -;; If we are going to use autoload objects, the following two functions -;; will be useful. -;; -;; (defun efs-defun-do-autoload (fun file key interactive-p args) -;; ;; Loads FILE and runs the KEY def of FUN. -;; (let (fun file key interactive-p args) -;; (load file)) -;; (let ((new-def (get fun key))) -;; (if (eq (car-safe new-def) 'autoload) -;; (error "%s definition of %s is not defined by loading %s" -;; key fun file) -;; (if interactive-p -;; (let ((prefix-arg current-predix-arg)) -;; (call-interactively fun)) -;; (apply new-def args))))) -;; -;; (defun efs-defun-autoload (fun key file doc-string from-kbd) -;; ;; Sets the KEY def of FUN to an autoload object. -;; (let* ((key (intern (symbol-name key) efs-key-obarray)) -;; (def (get fun key))) -;; (if (or (null def) -;; (eq (car-safe def) 'autoload)) -;; (put fun key (list 'autoload file doc-string from-kbd))))) - -;;; end of efs-defun.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-dired-mule.el --- a/lisp/efs/efs-dired-mule.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dired.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Makes efs-dired.el work with MULE. -;; Author: Ishikawa Ichiro -;; Created: Sat Aug 20 05:25:55 1994 -;; Modified: Sun Nov 27 12:19:17 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst efs-dired-mule-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;; Keep the byte-compiler happy -(defvar efs-version-host-types) -(defvar efs-dired-host-type) - -(defun efs-dired-find-file (&optional coding-system) - "Documented as original" - (interactive "ZCoding-system: ") - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (find-file file coding-system))) - -(defun efs-dired-find-file-other-window (&optional display coding-system) - "Documented as original" - (interactive "P\nZCoding-system: ") - (if display - (dired-display-file coding-system) - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (find-file-other-window file coding-system)))) - - -(defun efs-dired-display-file (&optional coding-system) - "Documented as original" - (interactive "ZCoding-system: ") - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (display-buffer (find-file-noselect file coding-system)))) - -;;; end of efs-dired-mule.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-dired.el --- a/lisp/efs/efs-dired.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1635 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dired.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.32 $ -;; RCS: -;; Description: Extends much of Dired to work under efs. -;; Authors: Sebastian Kremer , -;; Andy Norman , -;; Sandy Rutherford -;; Created: Throughout the ages. -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Provisions and requirements - -(provide 'efs-dired) -(require 'efs) -(require 'dired) -(autoload 'dired-shell-call-process "dired-shell") - -(defconst efs-dired-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.32 $" 11 -2))) - -;;;; ---------------------------------------------------------------- -;;;; User Configuration Variables -;;;; ---------------------------------------------------------------- - -(defvar efs-dired-verify-modtime-host-regexp nil - "Regular expression determining on which hosts dired modtimes are checked.") - -(defvar efs-dired-verify-anonymous-modtime nil - "If non-nil, dired modtimes are checked for anonymous logins.") - -;;; Internal Variables - -(make-variable-buffer-local 'dired-ls-F-marks-symlinks) - -;;;; ----------------------------------------------------------- -;;;; Inserting Directories into Buffers -;;;; ----------------------------------------------------------- - -;; The main command for inserting a directory listing in a buffer. -;; In Emacs 19 this is in files.el, and not specifically connected to -;; dired. Since our version of it uses some dired functions, it is -;; included here, but there is an autoload for it in efs.el. - -(defun efs-insert-directory (file switches &optional wildcard full-directory-p - nowait marker-char) - ;; Inserts a remote directory. Can do this asynch. - (let* ((parsed (efs-ftp-path file)) - (mk (point-marker)) - (host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (host-type (efs-host-type host)) - (dumb (memq host-type efs-dumb-host-types)) - (subdir (and (null (or full-directory-p wildcard)) - (condition-case nil - (dired-current-directory) - (error nil)))) - (case-fold-search nil) ; for testing switches - (parse (and full-directory-p (not wildcard) - (or dumb (efs-parsable-switches-p switches)))) - ;; In case dired-omit-silent isn't defined. - (dired-omit-silent (and (boundp 'dired-omit-silent) - dired-omit-silent))) - - ;; Insert the listing. If it's not a wild-card, and not a full-dir, - ;; then we are updating a dired-line. Do this asynch. - ;; This way of doing the listing makes sure that the dired - ;; buffer is still around after the listing is obtained. - - (efs-ls - file switches t (if parse 'parse t) nil - ;; asynch, if we're inserting in a subdir. Do it nowait = 0, so - ;; updating the file line gets a high priority?? - ;; Insert subdir listings NOWAIT = 0 also so 1-line - ;; updates don't toggle the mode line. - (if (and subdir nowait) 0 nowait) - (efs-cont (listing) (host user file path wildcard - nowait marker-char - mk subdir parse switches dired-omit-silent) - ;; We pass the value of dired-omit-silent from the caller to the cont. - (let ((host-type (efs-host-type host)) - (listing-type (efs-listing-type host user))) - (if (marker-buffer mk) - (efs-save-buffer-excursion - (set-buffer (marker-buffer mk)) - ;; parsing a listing, sometimes updates info - (if (and parse (eq major-mode 'dired-mode)) - (progn - (setq efs-dired-host-type host-type - efs-dired-listing-type listing-type - efs-dired-listing-type-string - (and efs-show-host-type-in-dired - (concat " " - (symbol-name - efs-dired-listing-type)))) - (if (memq host-type '(bsd-unix next-unix)) - (setq dired-ls-F-marks-symlinks nil) - (if (memq host-type '(sysV-unix apollo-unix)) - (setq dired-ls-F-marks-symlinks t))))) - (if subdir - ;; a 1-line re-list - (save-excursion - (efs-update-file-info - host-type file efs-data-buffer-name) - (goto-char mk) - (let ((new-subdir (condition-case nil - (dired-current-directory) - (error nil))) - buffer-read-only) - (if (and new-subdir - (string-equal subdir new-subdir)) - (progn - ;; Is there an existing entry? - (if (dired-goto-file file) - (progn - (delete-region - (save-excursion - (skip-chars-backward "^\n\r") - (1- (point))) - (progn - (skip-chars-forward "^\n\r") - (point))) - (goto-char mk))) - (insert listing) - (save-restriction - (narrow-to-region mk (point)) - (efs-dired-fixup-listing - listing-type file path switches wildcard) - (efs-dired-ls-trim - listing-type) - ;; save-excursion loses if fixup had to - ;; remove and re-add the region. Say for - ;; sorting. - (goto-char (point-max))) - (if (and nowait (eq major-mode 'dired-mode)) - (dired-after-add-entry - (marker-position mk) - marker-char)))))) - (goto-char mk) - (let (buffer-read-only) - (insert listing) - (save-restriction - (narrow-to-region mk (point)) - (efs-dired-fixup-listing - listing-type file path switches wildcard) - (goto-char (point-max)))))))))) - ;; Return 0 if synch, nil if asynch - (if nowait nil 0))) - -;;; Functions for cleaning listings. - -(efs-defun efs-dired-ls-trim nil () - ;; Trims dir listings, so that the listing of a single file is one line. - nil) - -(efs-defun efs-dired-fixup-listing nil (file path &optional switches wildcard) - ;; FILE is in efs syntax. - ;; PATH is just the remote path. - ;; Some ftpd's put the whole directory name in front of each filename. - ;; Seems to depend in a strange way on server-client interaction. - ;; Walk down the listing generated and remove this stuff. - ;; SWITCHES is a string. - (if (memq efs-key efs-unix-host-types) - (let ((continue t) - spot bol) - (goto-char (point-min)) - (while (and (not (eobp)) continue) - (and (setq bol (point) - spot (dired-manual-move-to-filename nil bol)) - (setq continue (= (following-char) ?/)) - (dired-manual-move-to-end-of-filename t bol) - (progn - (skip-chars-backward "^/") - (delete-region spot (point)))) - (forward-line 1)) - (efs-save-match-data - (if (and switches (string-match "R" switches) - (not (string-match "d" switches))) - (let ((subdir-regexp "^\\(/[^ \n\r]+\\):[\n\r]") - name) - (goto-char (point-min)) - (while (re-search-forward subdir-regexp nil t) - (goto-char (match-beginning 0)) - ;; There may be /./ type nonsense. - ;; expand-file-name will handle it. - (setq name (expand-file-name - (buffer-substring (point) (match-end 0)))) - (delete-region (point) (match-end 0)) - (insert (efs-replace-path-component file name))))))))) - - -;;;; ------------------------------------------------------------ -;;;; Tree Dired support -;;;; ------------------------------------------------------------ - -;;; efs-dired keymap - -(defvar efs-dired-map nil - "Keymap for efs commands in dired buffers.") - -(if efs-dired-map - () - (setq efs-dired-map (make-sparse-keymap)) - (define-key efs-dired-map "c" 'efs-dired-close-ftp-process) - (define-key efs-dired-map "k" 'efs-dired-kill-ftp-process) - (define-key efs-dired-map "o" 'efs-dired-display-ftp-process-buffer) - (define-key efs-dired-map "p" 'efs-dired-ping-connection)) - -(fset 'efs-dired-prefix efs-dired-map) - -;;; Functions for dealing with the FTP process - -(defun efs-dired-close-ftp-process () - "Close the FTP process for the current dired buffer. -Closing causes the connection to be dropped, but efs will retain its -cached data for the connection. This will make it more efficient to -reopen the connection." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-close-ftp-process (current-buffer)) - (let ((parsed (efs-ftp-path default-directory))) - (message "Closed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) - -(defun efs-dired-kill-ftp-process () - "Kills the FTP process for the current dired buffer. -Killing causes the connection to be closed, the process buffer to be killed, -and most of efs's cached data to be wiped." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-kill-ftp-process (current-buffer)) - (let ((parsed (efs-ftp-path default-directory))) - (message "Killed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) - -(defun efs-dired-display-ftp-process-buffer () - "Displays in another window the FTP process buffer for a dired buffer." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-display-ftp-process-buffer (current-buffer))) - -(defun efs-dired-ping-connection () - "Pings FTP connection associated with current dired buffer." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-ping-ftp-connection (current-buffer))) - - -;;; Reading in dired buffers. - -(defun efs-dired-revert (&optional arg noconfirm) - (let ((efs-ls-uncache t)) - (dired-revert arg noconfirm))) - -(defun efs-dired-default-dir-function () - (let* ((cd (dired-current-directory)) - (parsed (efs-ftp-path cd))) - (if parsed - (efs-save-match-data - (let ((tail directory-abbrev-alist)) - (while tail - (if (string-match (car (car tail)) cd) - (setq cd (concat (cdr (car tail)) - (substring cd (match-end 0))) - parsed nil)) - (setq tail (cdr tail))) - (apply 'efs-unexpand-parsed-filename - (or parsed (efs-ftp-path cd))))) - cd))) - -(defun efs-dired-before-readin () - ;; Put in the dired-before-readin-hook. - (let ((parsed (efs-ftp-path default-directory))) - (if parsed - (let ((host (car parsed)) - (user (nth 1 parsed))) - (setq efs-dired-listing-type (efs-listing-type host user) - efs-dired-host-type (efs-host-type host) - efs-dired-listing-type-string - (and efs-show-host-type-in-dired - (concat " " (symbol-name efs-dired-listing-type)))) - (set (make-local-variable 'revert-buffer-function) - (function efs-dired-revert)) - (set (make-local-variable 'default-directory-function) - (function efs-dired-default-dir-function)) - (set (make-local-variable 'dired-verify-modtimes) - (null (null (and - efs-dired-verify-modtime-host-regexp - (efs-save-match-data - (let ((case-fold-search t)) - (string-match - efs-dired-verify-modtime-host-regexp host)) - (or efs-dired-verify-anonymous-modtime - (not (efs-anonymous-p user)))))))) - ;; The hellsoft ftp server mixes up cases. - ;; However, we may not be able to catch this until - ;; after the first directory is listed. - (if (and - (eq efs-dired-host-type 'hell) - (not (string-equal default-directory - (setq default-directory - (downcase default-directory))))) - (or (string-equal (buffer-name) (downcase (buffer-name))) - (rename-buffer (generate-new-buffer-name - (directory-file-name default-directory))))) - ;; Setup the executable and directory regexps - (let ((eentry (assq efs-dired-listing-type - efs-dired-re-exe-alist)) - (dentry (assq efs-dired-listing-type - efs-dired-re-dir-alist))) - (if eentry - (set (make-local-variable 'dired-re-exe) (cdr eentry))) - (if dentry - (set (make-local-variable 'dired-re-dir) (cdr dentry)))) - ;; No switches are sent to dumb hosts, so don't confuse dired. - ;; I hope that dired doesn't get excited if it doesn't see the l - ;; switch. If it does, then maybe fake things by setting this to - ;; "-Al". - (if (eq efs-dired-listing-type 'vms) - (setq dired-internal-switches - (delq ?F dired-internal-switches)) - (if (memq efs-dired-host-type efs-dumb-host-types) - (setq dired-internal-switches '(?l ?A) - ;; Don't lie on the mode line - dired-sort-mode ""))) - ;; If the remote file system is version-based, don't set - ;; dired-kept-versions to 0. It will flag the most recent - ;; copy of the file for deletion -- this isn't really a backup. - (if (memq efs-dired-host-type efs-version-host-types) - (set (make-local-variable 'dired-kept-versions) - (max 1 dired-kept-versions))))))) - -(efs-defun efs-dired-insert-headerline (&use efs-dired-listing-type) (dir) - "Documented as original." - (efs-real-dired-insert-headerline dir)) - -(defun efs-dired-uncache (file dir-p) - ;; Remove FILE from cache. - (if dir-p - (efs-del-from-ls-cache file nil t) - (efs-del-from-ls-cache file t nil))) - -;;; Checking modtimes of directories. -;; -;; This only runs if efs-dired-verify-anonymous-modtime and -;; efs-verify-modtime-host-regexp turn it on. Few (any?) FTP servers -;; support getting MDTM for directories. As usual, we cache whether -;; this works, and don't keep senselessly trying it if it doesn't. - -(defun efs-dired-file-modtime (file) - ;; Returns the modtime. - (let* ((parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (rpath (nth 2 parsed))) - (and (null (efs-get-host-property host 'dir-mdtm-failed)) - (let ((result (efs-send-cmd host user (list 'quote 'mdtm rpath) - (and (eq efs-verbose t) - "Getting modtime"))) - mp) - (if (and (null (car result)) - (setq mp (efs-parse-mdtime (nth 1 result)))) - (let ((ent (efs-get-file-entry file))) - (if ent - (setcdr ent (list (nth 1 ent) (nth 2 ent) - (nth 3 ent) (nth 4 ent) mp))) - parsed) - (efs-set-host-property host 'dir-mdtm-failed t) - nil))))) - -(defun efs-dired-set-file-modtime (file alist) - ;; This works asynch. - (let* ((parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed))) - (if (efs-get-host-property host 'dir-mdtm-failed) - (let ((elt (assoc file alist))) - (if elt (setcar (nthcdr 4 elt) nil))) - (efs-send-cmd - host user (list 'quote 'mdtm path) nil nil - (efs-cont (result line cont-lines) (file alist host) - (let ((elt (assoc file alist)) - modtime) - (if (and (null result) (setq modtime (efs-parse-mdtime line))) - (if elt (setcar (nthcdr 4 elt) modtime)) - (if elt (setcar (nthcdr 4 elt) nil)) - (efs-set-host-property host 'dir-mdtm-failed t)))) - 0) ; Always do this NOWAIT = 0 - nil))) ; return NIL - -;;; Asynch insertion of subdirs. Used when renaming subdirs. - -(defun efs-dired-insert-subdir (dirname &optional noerror nowait) - (let ((buff (current-buffer)) - (switches (delq ?R (copy-sequence dired-internal-switches)))) - (efs-ls - dirname (dired-make-switches-string switches) - t nil noerror nowait - (efs-cont (listing) (dirname buff switches) - (if (and listing (get-buffer buff)) - (save-excursion - (set-buffer buff) - (save-excursion - (let ((elt (assoc dirname dired-subdir-alist)) - mark-list) - (if elt - (setq mark-list (dired-insert-subdir-del elt)) - (dired-insert-subdir-newpos dirname)) - (dired-insert-subdir-doupdate - dirname - (efs-dired-insert-subdir-do-insert dirname listing) - switches elt mark-list))))))))) - -(defun efs-dired-insert-subdir-do-insert (dirname listing) - (let ((begin (point)) - indent-tabs-mode end) - (insert listing) - (setq end (point-marker)) - (indent-rigidly begin end 2) - (goto-char begin) - (dired-insert-headerline dirname) - ;; If the listing has null lines `quote' them so that "\n\n" delimits - ;; subdirs. This is OK, because we aren't inserting -R listings. - (save-excursion - (while (search-forward "\n\n" end t) - (forward-char -1) - (insert " "))) - ;; point is now like in dired-build-subdir-alist - (prog1 - (list begin (marker-position end)) - (set-marker end nil)))) - -;;; Moving around in dired buffers. - -(efs-defun efs-dired-manual-move-to-filename (&use efs-dired-listing-type) - (&optional raise-error bol eol) - "Documented as original." - (efs-real-dired-manual-move-to-filename raise-error bol eol)) - -(efs-defun efs-dired-manual-move-to-end-of-filename - (&use efs-dired-listing-type) (&optional no-error bol eol) - "Documented as original." - (efs-real-dired-manual-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-make-filename-string (&use efs-dired-listing-type) - (filename &optional reverse) - "Documented as original." - ;; This translates file names from the way that they are displayed - ;; in listings to the way that the user gives them in the minibuffer. - ;; For example, in CMS this should take "FOO BAR" to "FOO.BAR". - filename) - -(defun efs-dired-find-file () - "Documented as original." - (interactive) - (find-file - (if (memq efs-dired-host-type efs-version-host-types) - (efs-internal-file-name-sans-versions - efs-dired-host-type (dired-get-filename) t) - (dired-get-filename)))) - -(defun efs-dired-find-file-other-window (&optional display) - "Documented as original." - (interactive "P") - (if display - (dired-display-file) - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (find-file-other-window file)))) - -(defun efs-dired-display-file () - "Documented as original." - (interactive) - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (display-buffer (find-file-noselect file)))) - -(defun efs-dired-find-file-other-frame () - "Documented as original." - (interactive) - (find-file-other-frame - (if (memq efs-dired-host-type efs-version-host-types) - (efs-internal-file-name-sans-versions - efs-dired-host-type (dired-get-filename) t) - (dired-get-filename)))) - -;;; Creating and deleting new directories. - -(defun efs-dired-recursive-delete-directory (fn) - ;; Does recursive deletion of remote directories for dired. - (or (file-exists-p fn) - (signal 'file-error - (list "Removing old file name" "no such directory" fn))) - (efs-dired-internal-recursive-delete-directory fn)) - -(defun efs-dired-internal-recursive-delete-directory (fn) - (if (eq (car (file-attributes fn)) t) - (let ((files (efs-directory-files fn))) - (if files - (mapcar (function - (lambda (ent) - (or (string-equal "." ent) - (string-equal ".." ent) - (efs-dired-internal-recursive-delete-directory - (expand-file-name ent fn))))) - files)) - (efs-delete-directory fn)) - (condition-case err - (efs-delete-file fn) - (ftp-error (if (and (nth 2 err) (stringp (nth 2 err)) - (efs-save-match-data - (string-match "^FTP Error: \"550 " (nth 2 err)))) - (message "File %s already deleted." fn) - (signal (car err) (cdr err))))))) - -;;; File backups and versions. - -(efs-defun efs-dired-flag-backup-files - (&use efs-dired-host-type) (&optional unflag-p) - "Documented as original." - (interactive "P") - (efs-real-dired-flag-backup-files unflag-p)) - -(efs-defun efs-dired-collect-file-versions (&use efs-dired-host-type) () - ;; If it looks like a file has versions, return a list of the versions. - ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) - (efs-real-dired-collect-file-versions)) - -;;; Sorting dired buffers - -(defun efs-dired-file-name-lessp (name1 name2) - (if (and efs-dired-host-type - (memq efs-dired-host-type efs-case-insensitive-host-types)) - (string< (downcase name1) (downcase name2)) - (string< name1 name2))) - -;;; Support for async file creators. - -(defun efs-dired-copy-file (from to ok-flag &optional cont nowait) - ;; Version of dired-copy-file for remote files. - ;; Assumes that filenames are already expanded. - (dired-handle-overwrite to) - (efs-copy-file-internal from (efs-ftp-path from) to (efs-ftp-path to) - ok-flag dired-copy-preserve-time 0 cont nowait)) - -(defun efs-dired-rename-file (from to ok-flag &optional cont nowait - insert-subdir) - ;; Version of dired-rename-file for remote files. - (dired-handle-overwrite to) - (efs-rename-file-internal - from to ok-flag nil - (efs-cont (result line cont-lines) (from to cont insert-subdir) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Dired Renaming" - (format "FTP Error: \"%s\"" line) - from to))) - (dired-remove-file from) - ;; Silently rename the visited file of any buffer visiting this file. - ;; We do not maintain inserted subdirs for remote - (efs-dired-rename-update-buffers from to insert-subdir) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait)) - -(defun efs-dired-rename-update-buffers (from to &optional insert-subdir) - (if (get-file-buffer from) - (save-excursion - (set-buffer (get-file-buffer from)) - (let ((modflag (buffer-modified-p))) - (set-visited-file-name to) ; kills write-file-hooks - (set-buffer-modified-p modflag))) - ;; It's a directory. More work to do. - (let ((blist (buffer-list)) - (from-dir (file-name-as-directory from)) - (to-dir (file-name-as-directory to))) - (save-excursion - (while blist - (set-buffer (car blist)) - (setq blist (cdr blist)) - (cond - (buffer-file-name - (if (dired-in-this-tree buffer-file-name from-dir) - (let ((modflag (buffer-modified-p))) - (unwind-protect - (set-visited-file-name - (concat to-dir (substring buffer-file-name - (length from-dir)))) - (set-buffer-modified-p modflag))))) - (dired-directory - (if (string-equal from-dir (expand-file-name default-directory)) - ;; If top level directory was renamed, lots of things - ;; have to be updated. - (progn - (dired-unadvertise from-dir) - (setq default-directory to-dir - dired-directory - ;; Need to beware of wildcards. - (expand-file-name - (file-name-nondirectory dired-directory) - to-dir)) - (let ((new-name (file-name-nondirectory - (directory-file-name dired-directory)))) - ;; Try to rename buffer, but just leave old name if new - ;; name would already exist (don't try appending "<%d>") - ;; Why? --sandy 19-8-94 - (or (get-buffer new-name) - (rename-buffer new-name))) - (dired-advertise)) - (and insert-subdir - (assoc (file-name-directory (directory-file-name to)) - dired-subdir-alist) - (if (efs-ftp-path to) - (efs-dired-insert-subdir to t 1) - (dired-insert-subdir to))))))))))) - -(defun efs-dired-make-relative-symlink (from to ok-flag &optional cont nowait) - ;; efs version of dired-make-relative-symlink - ;; Called as a file-name-handler when dired-make-relative-symlink is - ;; called interactively. - ;; efs-dired-create-files calls it directly to supply CONT - ;; and NOWAIT args. - (setq from (directory-file-name from) - to (directory-file-name to)) - (efs-make-symbolic-link-internal - (dired-make-relative from (file-name-directory to) t) - to ok-flag cont nowait)) - -(defun efs-dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char query - implicit-to) - "Documented as original." - (if (catch 'found - (let ((list fn-list) - val) - (while list - (if (setq val (efs-ftp-path (car list))) - (throw 'found val) - (if (setq val (funcall name-constructor (car list))) - (throw 'found (efs-ftp-path val)) - (setq list (cdr list))))))) - (progn - (cond ((eq file-creator 'dired-copy-file) - (setq file-creator 'efs-dired-copy-file)) - ((eq file-creator 'dired-rename-file) - (setq file-creator 'efs-dired-rename-file)) - ((eq file-creator 'make-symbolic-link) - (setq file-creator 'efs-make-symbolic-link-internal)) - ((eq file-creator 'add-name-to-file) - (setq file-creator 'efs-add-name-to-file-internal)) - ((eq file-creator 'dired-make-relative-symlink) - (setq file-creator 'efs-dired-make-relative-symlink)) - ((eq file-creator 'dired-compress-file) - (setq file-creator 'efs-dired-compress-file)) - ((error "Unable to perform operation %s on remote hosts." - file-creator))) - ;; use the process-filter driven routine rather than the iterative one. - (efs-dcf-1 file-creator operation fn-list name-constructor - (if (eq marker-char t) - (mapcar 'dired-file-marker fn-list) - marker-char) - query (buffer-name (current-buffer)) - nil ;overwrite-query - nil ;dired-overwrite-backup-query - nil ;dired-file-creator-query - nil ;failures - nil ;skipped - 0 ;success-count - (length fn-list) ;total - implicit-to - (and (eq file-creator 'efs-dired-rename-file) - (delq nil - (mapcar - (function - (lambda (x) - (and (assoc (file-name-as-directory x) - dired-subdir-alist) - x))) - fn-list))))) - ;; normal case... use the interative routine... much cheaper. - (efs-real-dired-create-files file-creator operation fn-list - name-constructor marker-char query - implicit-to))) - -(defun efs-dcf-1 (file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - overwrite-backup-query file-creator-query - failures skipped success-count total - implicit-to insertions) - (if (null fn-list) - (efs-dcf-3 failures operation total skipped - success-count buffer-name) - (let* ((from (car fn-list)) - ;; For dired-handle-overwrite and the file-creator-query, - ;; need to set these 2 fluid vars according to the cont data. - (dired-overwrite-backup-query overwrite-backup-query) - (dired-file-creator-query file-creator-query) - (to (funcall name-constructor from)) - (marker-char (if (consp markers) - (prog1 (car markers) - (setq markers (cdr markers))) - markers)) - (fn-list (cdr fn-list))) - (if to - (if (equal to from) - (progn - (dired-log buffer-name "Cannot %s to same file: %s\n" - (downcase operation) from) - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - dired-overwrite-backup-query - dired-file-creator-query failures - (cons (dired-make-relative from nil t) skipped) - success-count total implicit-to insertions)) - (if (or (null query) - (funcall query from to)) - (let* ((overwrite (let (jka-compr-enabled) - ;; Don't let jka-compr fool us. - (file-exists-p to))) - (overwrite-confirmed ; for dired-handle-overwrite - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite `%s'?" to))))) - (condition-case err - (let ((dired-unhandle-add-files - (cons to dired-unhandle-add-files))) - (if implicit-to - (funcall file-creator from overwrite-confirmed - (list (function efs-dcf-2) - file-creator operation fn-list - name-constructor markers - query marker-char - buffer-name to from overwrite - overwrite-confirmed overwrite-query - dired-overwrite-backup-query - dired-file-creator-query - failures skipped success-count - total implicit-to insertions) - t) - (apply file-creator from to overwrite-confirmed - (list (function efs-dcf-2) - file-creator operation fn-list - name-constructor markers - query marker-char - buffer-name to from overwrite - overwrite-confirmed overwrite-query - dired-overwrite-backup-query - dired-file-creator-query - failures skipped success-count total - implicit-to insertions) - (if insertions - (list t insertions) - '(t))))) - (error ; FILE-CREATOR aborted - (efs-dcf-2 'failed ;result - (format "%s" err) ;line - "" file-creator operation fn-list - name-constructor markers query marker-char - buffer-name to from overwrite - overwrite-confirmed overwrite-query - dired-overwrite-backup-query - dired-file-creator-query failures skipped - success-count total implicit-to insertions)))) - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - dired-overwrite-backup-query dired-file-creator-query - failures - (cons (dired-make-relative from nil t) skipped) - success-count total implicit-to insertions))) - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - dired-overwrite-backup-query dired-file-creator-query - failures (cons (dired-make-relative from nil t) skipped) - success-count total implicit-to insertions))))) - -(defun efs-dcf-2 (result line cont-lines file-creator operation fn-list - name-constructor markers query marker-char - buffer-name to from overwrite overwrite-confirmed - overwrite-query overwrite-backup-query - file-creator-query failures skipped success-count - total implicit-to insertions) - (if result - (progn - (setq failures (cons (dired-make-relative from nil t) failures)) - (dired-log buffer-name "%s `%s' to `%s' failed:\n%s\n" - operation from to line)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" operation success-count total) - (let ((efs-ls-uncache t)) - (dired-add-file to marker-char))) - ;; iterate again - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query overwrite-backup-query - file-creator-query failures skipped success-count total - implicit-to insertions)) - -(defun efs-dcf-3 (failures operation total skipped success-count buffer-name) - (cond - (failures - (dired-log-summary buffer-name (format "%s failed for %d of %d file%s" - operation (length failures) total - (dired-plural-s total)) failures)) - (skipped - (dired-log-summary buffer-name (format "%s: %d of %d file%s skipped" - operation (length skipped) total - (dired-plural-s total)) skipped)) - (t - (message "%s: %s file%s." - operation success-count - (dired-plural-s success-count))))) - -;;; Running remote shell commands - -;;; This support isn't very good. efs is really about a virtual file system, -;;; and not remote processes. What is really required is low-level -;;; support for start-process & call-process on remote hosts. This shouldn't -;;; be part of efs, although. - -(defun efs-dired-shell-unhandle-file-name (filename) - ;; Puts remote file names into a form where they can be passed to remsh. - (nth 2 (efs-ftp-path filename))) - -(defun efs-dired-shell-call-process (command dir &optional in-background) - ;; Runs shell process on remote hosts. - (let* ((parsed (efs-ftp-path dir)) - (host (car parsed)) - (user (nth 1 parsed)) - (rdir (nth 2 parsed)) - (file-name-handler-alist nil)) - (or (string-equal (efs-internal-directory-file-name dir) - (efs-expand-tilde "~" (efs-host-type host) host user)) - (string-match "^cd " command) - (setq command (concat "cd " rdir "; " command))) - (setq command - (format "%s %s%s \"%s\"" ; remsh -l USER does not work well - ; on a hp-ux machine I tried - efs-remote-shell-file-name host - (if efs-remote-shell-takes-user - (concat " -l " user) - "") - command)) - (message "Doing shell command on %s..." host) - (dired-shell-call-process - command (file-name-directory efs-tmp-name-template) in-background))) - -;;; Dired commands for running local processes on remote files. -;; -;; Lots of things in this section need to be re-thunk. - -(defun efs-dired-call-process (program discard &rest arguments) - "Documented as original." - ;; PROGRAM is always one of those below in the cond in dired.el. - ;; The ARGUMENTS are (nearly) always files. - (if (efs-ftp-path default-directory) - ;; Can't use efs-dired-host-type here because the current - ;; buffer is *dired-check-process output* - (condition-case oops - (cond - ((string-equal "efs-call-compress" program) - (apply 'efs-call-compress arguments)) - ((string-equal "chmod" program) - (efs-call-chmod arguments)) - (t (error "Unknown remote command: %s" program))) - (ftp-error (dired-log (buffer-name (current-buffer)) - (format "%s: %s, %s\n" - (nth 1 oops) - (nth 2 oops) - (nth 3 oops)))) - (error (dired-log (buffer-name (current-buffer)) - (format "%s\n" (nth 1 oops))))) - (apply 'call-process program nil (not discard) nil arguments))) - -(defun efs-dired-make-compressed-filename (name &optional method) - ;; Version of dired-make-compressed-filename for efs. - ;; If NAME is in the syntax of a compressed file (according to - ;; dired-compression-method-alist), return the data (a list) from this - ;; alist on how to uncompress it. Otherwise, return a string, the - ;; uncompressed form of this file name. This is computed using the optional - ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of - ;; dired-compression-method is used. - (let* ((host-type (efs-host-type (car (efs-ftp-path name)))) - (ef-alist (if (memq host-type efs-single-extension-host-types) - (mapcar - (function - (lambda (elt) - (list (car elt) - (mapconcat - (function - (lambda (char) - (if (= char ?.) - "-" - (char-to-string char)))) - (nth 1 elt) "") - (nth 2 elt) - (nth 3 elt)))) - dired-compression-method-alist) - dired-compression-method-alist)) - (alist ef-alist) - (len (length name)) - ext ext-len result) - (if (memq host-type efs-version-host-types) - (setq name (efs-internal-file-name-sans-versions host-type name))) - (if (memq host-type efs-case-insensitive-host-types) - (let ((name (downcase name))) - (while alist - (if (and (> len - (setq ext-len (length (setq ext (nth 1 (car alist)))))) - (string-equal (downcase ext) - (substring name (- ext-len)))) - (setq result (car alist) - alist nil) - (setq alist (cdr alist))))) - (while alist - (if (and (> len - (setq ext-len (length (setq ext (nth 1 (car alist)))))) - (string-equal ext (substring name (- ext-len)))) - (setq result (car alist) - alist nil) - (setq alist (cdr alist))))) - (or result - (concat name - (nth 1 (or (assq (or method dired-compression-method) - ef-alist) - (error "Unknown compression method: %s" - (or method dired-compression-method)))))))) - -(defun efs-dired-compress-file (file ok-flag &optional cont nowait) - ;; Version of dired-compress-file for remote files. - (let* ((compressed-fn (efs-dired-make-compressed-filename file)) - (host (car (efs-ftp-path file))) - (host-type (efs-host-type host))) - (cond ((file-symlink-p file) - (if cont - (efs-call-cont - cont 'failed - (format "Cannot compress %s, a symbolic link." file) "") - (signal 'file-error (list "Compress error:" file - "a symbolic link")))) - ((listp compressed-fn) - (let ((newname (substring (if (memq host-type - efs-version-host-types) - (efs-internal-file-name-sans-versions - host-type file) - file) - 0 (- (length (nth 1 compressed-fn))))) - (program (nth 3 compressed-fn))) - (if (and (memq host-type efs-unix-host-types) - (null (efs-get-host-property host 'exec-failed)) - (null (eq (efs-get-host-property - host - (intern - (concat - "exec-" - (efs-compress-progname (car program))))) - 'failed))) - (efs-call-remote-compress - program file newname t ok-flag - (efs-cont (result line cont-lines) (program file newname - cont nowait) - (if result - (if (eq result 'unsupported) - (efs-call-compress program file newname - t t cont nowait) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Uncompressing file" - (format "FTP Error: \"%s\" " line) - file)))) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait) - (efs-call-compress - program file newname t ok-flag cont nowait) - newname))) - ((stringp compressed-fn) - (let ((program (nth 2 (assq dired-compression-method - dired-compression-method-alist)))) - (if (and (memq host-type efs-unix-host-types) - (null (efs-get-host-property host 'exec-failed)) - (null (eq (efs-get-host-property - host - (intern - (concat - "exec-" - (efs-compress-progname (car program))))) - 'failed))) - (efs-call-remote-compress - program file compressed-fn nil ok-flag - (efs-cont (result line cont-lines) (program file - compressed-fn - cont nowait) - (if result - (if (eq result 'unsupported) - (efs-call-compress program file compressed-fn nil - t cont nowait) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Compressing file" - (format "FTP Error: \"%s\" " line) - file)))) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait) - (efs-call-compress - program file compressed-fn nil ok-flag cont nowait))) - compressed-fn) - (t (error "Strange error in efs-dired-compress-file."))))) - -(defun efs-dired-print-file (command file) - ;; Version of dired-print-file for remote files. - (let ((command (dired-trans-command command (list file) ""))) - ;; Only replace the first occurence of the file name? - (if (string-match (concat "[ ><|]\\(" (regexp-quote - (dired-shell-quote file)) - "\\)\\($\\|[ |><&]\\)") - command) - (setq command (concat (substring command 0 (match-beginning 1)) - "%s" - (substring command (match-end 1)))) - (error "efs-print-command: strange error")) - (efs-call-lpr file command))) - -;;;;---------------------------------------------------------------- -;;;; Support for `processes' run on remote files. -;;;; Usually (but not necessarily) these are only called from dired. -;;;;---------------------------------------------------------------- - -(defun efs-compress-progname (program) - ;; Returns a canonicalized i.e. without the "un", version of a compress - ;; program name. - (efs-save-match-data - (if (string-equal program "gunzip") - "gzip" - (if (string-match "^un" program) - (substring program (match-end 0)) - program)))) - -(defun efs-call-remote-compress (program filename newname &optional uncompress - ok-if-already-exists cont nowait) - ;; Run a remote compress process using SITE EXEC. - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname - (if uncompress - "uncompress to it" - "compress to it") - (numberp ok-if-already-exists))) - (let* ((filename (expand-file-name filename)) - (parsed (efs-ftp-path filename)) - (host (car parsed)) - (user (nth 1 parsed)) - (rpath (nth 2 parsed))) - (if (efs-get-host-property host 'exec-failed) - (if cont - (efs-call-cont cont 'unsupported "SITE EXEC not supported" "") - (signal 'ftp-error (list "Unable to SITE EXEC" host))) - (let* ((progname (efs-compress-progname (car program))) - (propsym (intern (concat "exec-" progname))) - (prop (efs-get-host-property host propsym))) - (cond - ((eq prop 'failed) - (if cont - (efs-call-cont cont 'unsupported - (concat progname " not in FTP exec path") "") - (signal 'ftp-error - (list (concat progname " not in FTP exec path") host)))) - ((eq prop 'worked) - (efs-send-cmd - host user - (list 'quote 'site 'exec - (concat (mapconcat 'identity program " ") " " rpath)) - (concat (if uncompress "Uncompressing " "Compressing ") filename) - nil - (efs-cont (result line cont-lines) (host user filename cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (concat "FTP exec Error: " line))) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user (concat "FTP Error: " err)))) - ;; This function only gets called for unix hosts, so - ;; we'll use the default version of efs-delete-file-entry - ;; and save a host-type lookup. - (efs-delete-file-entry nil filename) - (dired-remove-file filename) - (if cont (efs-call-cont cont nil line cont-lines)))))) - nowait)) - (t ; (null prop) - (efs-send-cmd - host user - (list 'quote 'site 'exec (concat progname " " "-V")) - (format "Checking for %s executable" progname) - nil - (efs-cont (result line cont-lines) (propsym host program filename - newname uncompress - cont nowait) - (efs-save-match-data - (if (string-match "\n200-" cont-lines) - (efs-set-host-property host propsym 'worked) - (efs-set-host-property host propsym 'failed))) - (efs-call-remote-compress program filename newname uncompress - t ; already tested for overwrite - cont nowait)) - nowait))))))) - -(defun efs-call-compress (program filename newname &optional uncompress - ok-if-already-exists cont nowait) - "Perform a compress command on a remote file. -PROGRAM is a list of the compression program and args. Works by taking a -copy of the file, compressing it and copying the file back. Returns 0 on -success, 1 or 2 on failure. If UNCOMPRESS is non-nil, does this instead." - (let* ((filename (expand-file-name filename)) - (newname (expand-file-name newname)) - (parsed (efs-ftp-path filename)) - (tmp1 (car (efs-make-tmp-name nil (car parsed)))) - (tmp2 (car (efs-make-tmp-name nil (car parsed)))) - (program (mapconcat 'identity program " "))) - (efs-copy-file-internal - filename parsed tmp1 nil - t nil 2 - (efs-cont (result line cont-lines) (filename newname tmp1 tmp2 program - uncompress ok-if-already-exists - cont nowait) - (if result - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\" " line) filename)) - (let ((err-buff (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create - (generate-new-buffer-name - (format - " efs-call-compress %s" filename)))))) - (save-excursion - (set-buffer err-buff) - (set (make-local-variable 'efs-call-compress-filename) filename) - (set (make-local-variable 'efs-call-compress-newname) newname) - (set (make-local-variable 'efs-call-compress-tmp1) tmp1) - (set (make-local-variable 'efs-call-compress-tmp2) tmp2) - (set (make-local-variable 'efs-call-compress-cont) cont) - (set (make-local-variable 'efs-call-compress-nowait) nowait) - (set (make-local-variable 'efs-call-compress-ok) - ok-if-already-exists) - (set (make-local-variable 'efs-call-compress-uncompress) - uncompress) - (set (make-local-variable 'efs-call-compress-abbr) - (efs-relativize-filename filename)) - (if efs-verbose - (efs-message - (format "%s %s..." - (if uncompress "Uncompressing" "Compressing") - (symbol-value (make-local-variable - 'efs-call-compress-abbr))))) - (set-process-sentinel - (start-process (format "efs-call-compress %s" filename) - err-buff shell-file-name - "-c" (format "%s %s < %s > %s" - program - ;; Hope -c makes the compress - ;; program write to std out. - "-c" - tmp1 tmp2)) - (function - (lambda (proc str) - (let ((buff (get-buffer (process-buffer proc)))) - (if buff - (save-excursion - (set-buffer buff) - (if (/= (buffer-size) 0) - (if cont - (efs-call-cont - (symbol-value - (make-local-variable - 'efs-call-compress-cont)) - 'failed - (concat - "failed to compress " - (symbol-value (make-local-variable - 'efs-call-compress-filename)) - ", " - (buffer-substring - (point-min) - (progn (goto-char (point-min)) - (end-of-line) (point)))))) - (efs-del-tmp-name (symbol-value - (make-local-variable - 'efs-call-compress-tmp1))) - (let ((tmp2 (symbol-value - (make-local-variable - 'efs-call-compress-tmp2))) - (newname (symbol-value - (make-local-variable - 'efs-call-compress-newname))) - (filename (symbol-value - (make-local-variable - 'efs-call-compress-filename))) - (cont (symbol-value - (make-local-variable - 'efs-call-compress-cont))) - (nowait (symbol-value - (make-local-variable - 'efs-call-compress-nowait))) - (ok (symbol-value - (make-local-variable - 'efs-call-compress-ok))) - (uncompress - (symbol-value - (make-local-variable - 'efs-call-compress-uncompress)))) - (if efs-verbose - (efs-message - (format "%s %s...done" - (if uncompress - "Uncompressing" - "Compressing") - (symbol-value - (make-local-variable - 'efs-call-compress-abbr))))) - (kill-buffer (current-buffer)) - (efs-copy-file-internal - tmp2 nil newname (efs-ftp-path newname) - ok nil 1 - (efs-cont (result line cont-lines) (cont - tmp2 - filename) - (efs-del-tmp-name tmp2) - (or result - (let (efs-verbose) - (efs-delete-file filename) - (dired-remove-file filename))) - (if cont - (efs-call-cont cont result line - cont-lines))) - nowait (if uncompress nil 'image))))) - (error "Strange error: %s" proc)))))))))) - nowait (if uncompress 'image nil)))) - -(defun efs-update-mode-string (perms modes) - ;; For PERMS of the form `u+w', and MODES a unix 9-character mode string, - ;; computes the new mode string. - ;; Doesn't call efs-save-match-data. The calling function should. - (or (string-match "^[augo]+\\([+-]\\)[rwxst]+$" perms) - (error "efs-update-mode-string: invalid perms %s" perms)) - (let* ((who (substring perms 0 (match-beginning 1))) - (add (= (aref perms (match-beginning 1)) ?+)) - (what (substring perms (match-end 1))) - (newmodes (copy-sequence modes)) - (read (string-match "r" what)) - (write (string-match "w" what)) - (execute (string-match "x" what)) - (sticky (string-match "t" what)) - (suid (string-match "s" what))) - (if (string-match "a" who) - (if add - (progn - (if read - (progn - (aset newmodes 0 ?r) - (aset newmodes 3 ?r) - (aset newmodes 6 ?r))) - (if write - (progn - (aset newmodes 1 ?w) - (aset newmodes 4 ?w) - (aset newmodes 7 ?w))) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?s))) - (setq curr (aref newmodes 5)) - (if (= curr ?-) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?s))) - (setq curr (aref newmodes 8)) - (if (= curr ?-) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?t))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?S) - (if (= curr ?x) - (aset newmodes 2 ?s))) - (setq curr (aref newmodes 5)) - (if (= curr ?-) - (aset newmodes 5 ?S) - (if (= curr ?x) - (aset newmodes 5 ?s))))) - (if sticky - (let ((curr (aref newmodes 8))) - (if (= curr ?-) - (aset newmodes 8 ?T) - (if (= curr ?x) - (aset newmodes 8 ?t)))))) - (if read - (progn - (aset newmodes 0 ?-) - (aset newmodes 3 ?-) - (aset newmodes 6 ?-))) - (if write - (progn - (aset newmodes 1 ?-) - (aset newmodes 4 ?-) - (aset newmodes 7 ?-))) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?x) - (aset newmodes 2 ?-) - (if (= curr ?s) - (aset newmodes 2 ?S))) - (setq curr (aref newmodes 5)) - (if (= curr ?x) - (aset newmodes 5 ?-) - (if (= curr ?s) - (aset newmodes 5 ?S))) - (setq curr (aref newmodes 8)) - (if (= curr ?x) - (aset newmodes 8 ?-) - (if (= curr ?t) - (aset newmodes 8 ?T))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?s) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?-))) - (setq curr (aref newmodes 5)) - (if (= curr ?s) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?-))))) - (if sticky - (let ((curr (aref newmodes 8))) - (if (= curr ?t) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?-)))))) - (if (string-match "u" who) - (if add - (progn - (if read - (aset newmodes 0 ?r)) - (if write - (aset newmodes 1 ?w)) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?s))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?S) - (if (= curr ?x) - (aset newmodes 2 ?s)))))) - (if read - (aset newmodes 0 ?-)) - (if write - (aset newmodes 1 ?-)) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?x) - (aset newmodes 2 ?-) - (if (= curr ?s) - (aset newmodes 2 ?S))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?s) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?-))))))) - (if (string-match "g" who) - (if add - (progn - (if read - (aset newmodes 3 ?r)) - (if write - (aset newmodes 4 ?w)) - (if execute - (let ((curr (aref newmodes 5))) - (if (= curr ?-) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?s))))) - (if suid - (let ((curr (aref newmodes 5))) - (if (= curr ?-) - (aset newmodes 5 ?S) - (if (= curr ?x) - (aset newmodes 5 ?s)))))) - (if read - (aset newmodes 3 ?-)) - (if write - (aset newmodes 4 ?-)) - (if execute - (let ((curr (aref newmodes 5))) - (if (= curr ?x) - (aset newmodes 5 ?-) - (if (= curr ?s) - (aset newmodes 5 ?S))))) - (if suid - (let ((curr (aref newmodes 5))) - (if (= curr ?s) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?-))))))) - (if (string-match "o" who) - (if add - (progn - (if read - (aset newmodes 6 ?r)) - (if write - (aset newmodes 7 ?w)) - (if execute - (let ((curr (aref newmodes 8))) - (if (= curr ?-) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?t))))) - (if sticky - (let ((curr (aref newmodes 8))) - (if (= curr ?-) - (aset newmodes 8 ?T) - (if (= curr ?x) - (aset newmodes 5 ?t)))))) - (if read - (aset newmodes 6 ?-)) - (if write - (aset newmodes 7 ?-)) - (if execute - (let ((curr (aref newmodes 8))) - (if (= curr ?x) - (aset newmodes 8 ?-) - (if (= curr ?t) - (aset newmodes 8 ?T))))) - (if suid - (let ((curr (aref newmodes 8))) - (if (= curr ?t) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?-)))))))) - newmodes)) - -(defun efs-compute-chmod-arg (perms file) - ;; Computes the octal number, represented as a string, required to - ;; modify the permissions PERMS of FILE. - (efs-save-match-data - (cond - ((string-match "^[0-7][0-7]?[0-7]?[0-7]?$" perms) - perms) - ((string-match "^[augo]+[-+][rwxst]+$" perms) - (let ((curr-mode (nth 3 (efs-get-file-entry file)))) - (or (and curr-mode - (stringp curr-mode) - (= (length curr-mode) 10)) - (progn - ;; Current buffer is process error buffer - (insert "Require an octal integer to modify modes for " - file ".\n") - (error "Require an octal integer to modify modes for %s." file))) - (format "%o" - (efs-parse-mode-string - (efs-update-mode-string perms - (substring curr-mode 1)))))) - (t - (insert "Don't know how to set modes " perms " for " file ".\n") - (error "Don't know how to set modes %s" perms))))) - -(defun efs-call-chmod (args) - ;; Sends an FTP CHMOD command. - (if (< (length args) 2) - (error "efs-call-chmod: missing mode and/or filename: %s" args)) - (let ((mode (car args)) - bombed) - (mapcar - (function - (lambda (file) - (setq file (expand-file-name file)) - (let ((parsed (efs-ftp-path file))) - (if parsed - (condition-case nil - (let* ((mode (efs-compute-chmod-arg mode file)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (efs-quote-string - (efs-host-type host user) (nth 2 parsed))) - (abbr (efs-relativize-filename file)) - (result (efs-send-cmd host user - (list 'quote 'site 'chmod - mode path) - (format "doing chmod %s" - abbr)))) - - (if (car result) - (efs-dired-shell-call-process - (concat "chmod " mode " " (file-name-nondirectory file)) - (file-name-directory file))) - - (efs-del-from-ls-cache file t)) - (error (setq bombed t))))))) - (cdr args)) - (if bombed 1 0))) ; return code - -(defun efs-call-lpr (file command-format) - "Print remote file FILE. SWITCHES are passed to the print program." - ;; Works asynch. - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file)) - (abbr (efs-relativize-filename file)) - (temp (car (efs-make-tmp-name nil (car parsed))))) - (efs-copy-file-internal - file parsed temp nil t nil 2 - (efs-cont (result line cont-lines) (command-format file abbr temp) - (if result - (signal 'ftp-error (list "Opening input file" - (format "FTP Error: \"%s\" " line) - file)) - (message "Spooling %s..." abbr) - (set-process-sentinel - (start-process (format "*print %s /// %s*" abbr temp) - (generate-new-buffer-name " *print temp*") - "sh" "-c" (format command-format temp)) - (function - (lambda (proc status) - (let ((buff (process-buffer proc)) - (name (process-name proc))) - (if (and buff (get-buffer buff)) - (unwind-protect - (save-excursion - (set-buffer buff) - (if (> (buffer-size) 0) - (let ((log-buff (get-buffer-create - "*Shell Command Output*"))) - (set-buffer log-buff) - (goto-char (point-max)) - (or (bobp) - (insert "\n")) - (insert-buffer-substring buff) - (goto-char (point-max)) - (display-buffer log-buff)))) - (condition-case nil (kill-buffer buff) (error nil)) - (efs-save-match-data - (if (string-match "^\\*print \\(.*\\) /// \\(.*\\)\\*$" - name) - (let ((abbr (substring name (match-beginning 1) - (match-end 1))) - (temp (substring name (match-beginning 2) - (match-end 2)))) - (or (= (match-beginning 2) (match-end 2)) - (efs-del-tmp-name temp)) - (message "Spooling %s...done" abbr)))))))))))) - t))) - -;;;; -------------------------------------------------------------- -;;;; Attaching onto dired. -;;;; -------------------------------------------------------------- - -;;; Look out for MULE -(if (or (boundp 'MULE) (featurep 'mule)) (load "efs-dired-mule")) - -;;; Magic file name hooks for dired. - -(put 'dired-print-file 'efs 'efs-dired-print-file) -(put 'dired-make-compressed-filename 'efs 'efs-dired-make-compressed-filename) -(put 'dired-compress-file 'efs 'efs-dired-compress-file) -(put 'dired-recursive-delete-directory 'efs - 'efs-dired-recursive-delete-directory) -(put 'dired-uncache 'efs 'efs-dired-uncache) -(put 'dired-shell-call-process 'efs 'efs-dired-shell-call-process) -(put 'dired-shell-unhandle-file-name 'efs 'efs-dired-shell-unhandle-file-name) -(put 'dired-file-modtime 'efs 'efs-dired-file-modtime) -(put 'dired-set-file-modtime 'efs 'efs-dired-set-file-modtime) - -;;; Overwriting functions - -(efs-overwrite-fn "efs" 'dired-call-process) -(efs-overwrite-fn "efs" 'dired-insert-headerline) -(efs-overwrite-fn "efs" 'dired-manual-move-to-filename) -(efs-overwrite-fn "efs" 'dired-manual-move-to-end-of-filename) -(efs-overwrite-fn "efs" 'dired-make-filename-string) -(efs-overwrite-fn "efs" 'dired-flag-backup-files) -(efs-overwrite-fn "efs" 'dired-create-files) -(efs-overwrite-fn "efs" 'dired-find-file) -(efs-overwrite-fn "efs" 'dired-find-file-other-window) -(efs-overwrite-fn "efs" 'dired-find-file-other-frame) -(efs-overwrite-fn "efs" 'dired-collect-file-versions) -(efs-overwrite-fn "efs" 'dired-file-name-lessp) - -;;; Hooks - -(add-hook 'dired-before-readin-hook 'efs-dired-before-readin) - -;;; Handle dired-grep.el too. - -(if (featurep 'dired-grep) - (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file - 'efs-diff/grep-del-temp-file) - (add-hook 'dired-grep-load-hook - (function - (lambda () - (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file - 'efs-diff/grep-del-temp-file))))) - -;;; end of efs-dired.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-dl.el --- a/lisp/efs/efs-dl.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,145 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dl.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.3 $ -;; RCS: -;; Description: Unix descriptive listing support for efs -;; Author: Sandy Rutherford -;; Created: Wed Jan 13 19:19:20 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:29:41 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-unix:dl) -(require 'efs) - -(defconst efs-dl-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.3 $" 11 -2))) - -;;;----------------------------------------------------------------- -;;; Unix descriptive listing (dl) support for efs -;;;----------------------------------------------------------------- - -;; this is also defined in efs.el, because it used to recognize -;; a dl listing. We re-define it here just to keep the dl stuff self-contained. - -(defconst efs-unix:dl-listing-regexp - "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") - -;; entry point - -(efs-defun efs-parse-listing unix:dl - (host user dir path &optional switches) - ;; Parse the current buffer, which is assumed to be a unix descriptive - ;; listing, and return a hashtable. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - ;; Is it really a listing? - (efs-save-match-data - (if (re-search-forward efs-unix:dl-listing-regexp nil t) - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (while (not (eobp)) - (efs-put-hash-entry - (buffer-substring (point) - (progn - (skip-chars-forward "^ /\n") - (point))) - (list (eq (following-char) ?/)) - tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -;;; Support for tree dired. - -(defconst efs-dired-dl-re-dir - "^. [^ /]+/[ \n]" - "Regular expression to use to search for dl directories.") - -(or (assq 'unix:dl efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'unix:dl efs-dired-dl-re-dir) - efs-dired-re-dir-alist))) - - -(efs-defun efs-dired-manual-move-to-filename unix:dl - (&optional raise-error bol eol) - ;; In dired, move to the first character of the filename on this line. - ;; This is the Unix dl version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (and - (> (- eol bol) 3) - (progn - (forward-char 2) - (skip-chars-forward " \t") - (looking-at "[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) "))) - (point) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename unix:dl - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Unix dl version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "^ /\r\n\t") - (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?/)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline unix:dl (dir) - ;; Unix dl has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-fixup-listing unix:dl (file path &optional - switches wildcard) - ;; Deal with continuation lines. - (efs-save-match-data - (goto-char (point-min)) - (while (re-search-forward "\n +" nil t) - (delete-region (match-beginning 0) (match-end 0)) - (insert " ")))) - -;;; end of efs-dl.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-dos-distinct.el --- a/lisp/efs/efs-dos-distinct.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dos-distinct.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Distinct's DOS FTP server support for efs -;; Author: Sandy Rutherford -;; Created: Fri Jan 15 22:20:32 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:30:04 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Thanks to Rodd Zurcher for beta testing. - -(provide 'efs-dos-distinct) -(require 'efs) - -(defconst efs-dos-distinct-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ----------------------------------------------------------------- -;;;; Distinct's DOS FTP server support for efs -;;;; ----------------------------------------------------------------- - -;;; This is not included in efs-dos.el with the support for the -;;; other dos ftp servers, because the Distinct server uses unix syntax -;;; for path names. - -;; This is defined in efs.el, but we put it here too. - -(defconst efs-dos-distinct-date-and-time-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " - "[ 12][0-9]:[0-5][0-9] ")) - -;;; entry point - -(efs-defun efs-parse-listing dos-distinct - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a listing from - ;; Distinct's DOS FTP server. Both empty dirs, and ls errors return - ;; empty buffers. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a full remote path - ;; PATH = directory in full efs-path syntax - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-dos-distinct-date-and-time-regexp nil t) - (let ((tbl (efs-make-hashtable)) - dir-p) - (beginning-of-line) - (while (progn - (setq dir-p (eq (following-char) ?d)) ; we're bolp - (re-search-forward - efs-dos-distinct-date-and-time-regexp nil t)) - (efs-put-hash-entry (buffer-substring (point) - (progn (end-of-line) - (point))) - (list dir-p) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(efs-defun efs-allow-child-lookup dos-distinct (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Subdirs in DOS can't have an extension. - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-dos-distinct-re-exe - "^[^\n]+\\.exe$") - -(or (assq 'dos-distinct efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos-distinct efs-dired-dos-distinct-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos-distinct-re-dir - "^. [ \t]*d") - -(or (assq 'dos-distinct efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos-distinct efs-dired-dos-distinct-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos-distinct (dir) - ;; The Distinct DOS server has no total line, so we insert a - ;; blank line for aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos-distinct - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This version is for Distinct's DOS FTP server. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-dos-distinct-date-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos-distinct - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the version for Distinct's DOS FTP server. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; it's hidden or omitted - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_+=a-z0-9.$") - (if (or (= opoint (point)) (not (memq (following-char) '(\n \r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-dos-distinct.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-dump.el --- a/lisp/efs/efs-dump.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dump.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Install a bare-bones EFS hook into file-name-handler-alist -;; for dumping -;; Author: Mike Sperber -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-dump) - -(defconst efs-dump-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;###autoload -(or (assoc efs-path-root-regexp file-name-handler-alist) - (setq file-name-handler-alist - (cons - (cons efs-path-root-regexp 'remote-path-file-handler-function) - file-name-handler-alist))) - -;;;###autoload -(defun remote-path-file-handler-function (operation &rest args) - "Function to call special file handlers for remote files." - (if allow-remote-paths - (apply 'efs-file-handler-function operation args) - (let ((inhibit-file-name-handlers - (cons 'remote-path-file-handler-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args)))) - -;;; end of efs-dump.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-fnh.el --- a/lisp/efs/efs-fnh.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-fnh.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.3 $ -;; RCS: -;; Description: Look for the emacs version, and install into -;; the file-name-handler-alist -;; Author: Sandy Rutherford -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Although used by efs, these utilities could be of general use to other -;;; packages too. Keeping them separate from the main efs program -;;; makes it easier for other programs to require them. - -(provide 'efs-fnh) - -(defconst efs-fnh-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.3 $" 11 -2))) - -;;;###autoload -(defvar allow-remote-paths t - "*Set this to nil if you don't want remote paths to access -remote files.") - -;;;; ---------------------------------------------------------------- -;;;; Loading emacs version files -;;;; ---------------------------------------------------------------- - -(defun efs-handle-emacs-version () - ;; Load appropriate files for the current emacs version - (let ((ehev-match-data (match-data))) - (unwind-protect - (let ((lucidp (string-match "Lucid" emacs-version)) - ver subver) - (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) - (error "efs does not work with emacs version %s" emacs-version)) - (setq ver (string-to-int (substring emacs-version - (match-beginning 1) - (match-end 1))) - subver (string-to-int (substring emacs-version - (match-beginning 2) - (match-end 2)))) - (cond - - ;; Lucid XEmacs (emacs-version looks like \"19.xx XEmacs Lucid\") - (lucidp - (cond - ((and (= ver 19) (>= subver 11) (< subver 15)) - (require 'efs-l19\.11)) - ((and (= ver 19) (>= subver 15)) - (require 'efs-x19\.15)) - ((= ver 20) - (require 'efs-x19\.15)) - (t - (error - "efs does not work with emacs version %s" emacs-version)))) - - ;; Original GNU Emacs from FSF - (t - (cond - ((and (= ver 19) (<= subver 22)) - (require 'efs-19)) - ((and (= ver 19) (>= subver 23)) - (require 'efs-19\.23)) - - ;; GNU Emacs 18- - ((<= ver 18) - (require 'efs-18)) ; this file will (require 'emacs-19) - - (t - (error - "efs does not work with emacs version %s" emacs-version)))))) - - (store-match-data ehev-match-data)))) - -;;;; -------------------------------------------------------------- -;;;; Stuff for file name handlers. -;;;; -------------------------------------------------------------- - -;;; Need to do this now, to make sure that the file-name-handler-alist is -;;; defined for Emacs 18. - -(efs-handle-emacs-version) - -;; Also defined in efs-cu.el -(defvar efs-path-root-regexp "^/[^/:]+:" - "Regexp to match the `/user@host:' root of an efs full path.") - -(defun efs-file-name-handler-alist-sans-fn (fn) - ;; Returns a version of file-name-handler-alist without efs. - (delq nil (mapcar - (function - (lambda (x) - (and (not (eq (cdr x) fn)) x))) - file-name-handler-alist))) - -(defun efs-root-handler-function (operation &rest args) - "Function to handle completion in the root directory." - (let ((handler (and (if (boundp 'allow-remote-paths) - allow-remote-paths - t) - (get operation 'efs-root)))) - (if handler - (apply handler args) - (let ((inhibit-file-name-handlers - (cons 'efs-root-handler-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args))))) - -(put 'file-name-completion 'efs-root 'efs-root-file-name-completion) -(put 'file-name-all-completions 'efs-root 'efs-root-file-name-all-completions) -(autoload 'efs-root-file-name-all-completions "efs-netrc") -(autoload 'efs-root-file-name-completion "efs-netrc") - -(autoload 'efs-file-handler-function "efs" - "Function to use efs to handle remote files.") - -;; Install into the file-name-handler-alist. -;; If we are already there, remove the old entry, and re-install. -;; Remove the ange-ftp entry too. - -(setq file-name-handler-alist - (let (dired-entry alist) - (setq alist - (nconc - (list - (cons efs-path-root-regexp 'efs-file-handler-function) - '("^/$" . efs-root-handler-function)) - (delq nil - (mapcar - (function - (lambda (x) - (if (eq (cdr x) 'dired-handler-fn) - (progn - (setq dired-entry x) - nil) - (and (not - (memq (cdr x) - '(remote-path-file-handler-function - efs-file-handler-function - efs-root-handler-function - ange-ftp-hook-function - ange-ftp-completion-hook-function))) - x)))) - file-name-handler-alist)))) - ;; Make sure that dired is in first. - (if dired-entry (cons dired-entry alist) alist))) - -;;; end of efs-fnh.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-guardian.el --- a/lisp/efs/efs-guardian.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,241 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-guardian.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.7 $ -;; RCS: -;; Description: Guardian support for efs -;; Author: Sandy Rutherford -;; Created: Sat Jul 10 12:26:12 1993 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Acknowledgements: -;;; Adrian Philips and David Karr for answering questions -;;; and debugging. Thanks. - -(defconst efs-guardian-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.7 $" 11 -2))) - -(provide 'efs-guardian) -(require 'efs) - -;;;; ------------------------------------------------------------ -;;;; Support for Tandem's GUARDIAN operating system. -;;;; ------------------------------------------------------------ - -;;; Supposed to work for (Version 2.7 TANDEM 01SEP92). - -;;; File name syntax: -;;; -;;; File names are of the form volume.subvolume.file where -;;; volume is $[alphanumeric characters]{1 to 7} -;;; subvolume is []{0 to 7} -;;; and file is the same as subvolume. - -(defconst efs-guardian-date-regexp - (concat - " [ 1-3][0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|" - "Sep\\|Oct\\|Nov\\|Dec\\)-[0-9][0-9] ")) - -;;; entry points -- 2 of 'em. - -(efs-defun efs-fix-path guardian (path &optional reverse) - ;; Convert PATH from unix-ish to guardian. - ;; If REVERSE is non-nil do just that. - (efs-save-match-data - (let ((case-fold-search t)) - (if reverse - (if (string-match - (concat - "^\\(\\\\[A-Z0-9]+\\.\\)?" - "\\(\\$[A-Z0-9]+\\)\\.\\([A-Z0-9]+\\)\\(\\.[A-Z0-9]+\\)?$") - path) - (concat - "/" - (substring path (match-beginning 2) (match-end 2)) - "/" - (substring path (match-beginning 3) (match-end 3)) - "/" - (and (match-beginning 4) - (substring path (1+ (match-beginning 4))))) - (error "path %s is invalid for the GUARDIAN operating system" - path)) - (if (string-match - "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" path) - (apply 'concat - (substring path 1 (match-end 1)) - "." - (substring path (match-beginning 2) (match-end 2)) - (and (match-beginning 3) - (/= (- (match-end 3) (match-beginning 3)) 1) - (list "." - (substring path (1+ (match-beginning 3)))))) - (error "path %s is invalid for the guardian operating system" - path)))))) - -(efs-defun efs-fix-dir-path guardian (dir-path) - ;; Convert DIR-PATH from unix-ish to guardian fir a DIR listing. - (efs-save-match-data - (let ((case-fold-search t)) - (cond - ((string-equal "/" dir-path) - (error "Can't grok guardian disk volumes.")) - ((string-match "^/\\$[A-Z0-9]+/?$" dir-path) - (error "Can't grok guardian subvolumes.")) - ((string-match "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" - dir-path) - (apply 'concat - (substring dir-path 1 (match-end 1)) - "." - (substring dir-path (match-beginning 2) (match-end 2)) - (and (match-beginning 3) - (/= (- (match-end 3) (match-beginning 3)) 1) - (list "." - (substring dir-path (1+ (match-beginning 3))))))) - (t - (error "path %s is invalid for the guardian operating system")))))) - -(efs-defun efs-parse-listing guardian - (host user dir path &optional switches) - ;; Parses a GUARDIAN DIRectory listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a remote full path - ;; PATH = directory as an efs full path - ;; SWITCHES are never used here, but they - ;; must be specified in the argument list for compatibility - ;; with the unix version of this function. - (efs-save-match-data - (goto-char (point-min)) - (if (re-search-forward efs-guardian-date-regexp nil t) - (let ((tbl (efs-make-hashtable)) - file size) - (while - (progn - (beginning-of-line) - (setq file (buffer-substring (point) - (progn - (skip-chars-forward "A-Z0-9") - (point)))) - (skip-chars-forward " ") - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq size (string-to-int (buffer-substring - (point) - (progn - (skip-chars-forward "0-9"))))) - (efs-put-hash-entry file (list nil size) tbl) - (forward-line 1) - (re-search-forward efs-guardian-date-regexp nil t))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(efs-defun efs-allow-child-lookup guardian (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - (efs-save-match-data - (let ((case-fold-search t)) - (string-match "^/\\$[A-Z0-9]+/$" dir)))) - -(efs-defun efs-internal-file-directory-p guardian (file) - ;; Directories pop into existence simply by putting files in them. - (efs-save-match-data - (let ((case-fold-search t)) - (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) - t - (efs-internal-file-directory-p nil file))))) - -(efs-defun efs-internal-file-exists-p guardian (file) - ;; Directories pop into existence simply by putting files in them. - (efs-save-match-data - (let ((case-fold-search t)) - (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) - t - (efs-internal-file-exists-p nil file))))) - -;;; Tree Dired support - -(defconst efs-dired-guardian-re-exe nil) - -(or (assq 'guardian efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'guardian efs-dired-guardian-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-guardian-re-dir nil) - -(or (assq 'guardian efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'guardian efs-dired-guardian-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename guardian - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the guardian version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (save-excursion (re-search-forward efs-guardian-date-regexp eol t)) - (progn - (if (looking-at ". [^ ]") - (forward-char 2)) - (point)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename guardian - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the guardian version. - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (if (and - (>= (following-char) ?A) - (<= (following-char) ?Z) - (progn - (skip-chars-forward "A-Z0-9") - (= (following-char) ?\ ))) - (point) - (and (null no-error) - (error "No file on this line")))) - -(efs-defun efs-dired-ls-trim guardian () - (goto-char (point-min)) - (let (case-fold-search) - (if (re-search-forward efs-guardian-date-regexp nil t) - (progn - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max)))))) - -;;; end of efs-guardian.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-gwp.el --- a/lisp/efs/efs-gwp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-gwp.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Support for efs to use an interactive gateway. -;; Author: Andy Norman, Dawn -;; Created: Thu Mar 18 13:03:14 1993 -;; Modified: Sun Nov 27 18:31:50 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-gwp) -(require 'efs) - -;;;; ------------------------------------------------------------ -;;;; Interactive gateway program support. -;;;; ------------------------------------------------------------ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; User Variables and Documentation - -(defvar efs-gwp-setup-term-command - (if (eq system-type 'hpux) - "stty -onlcr -echo\n" - "stty -echo nl\n") - "Command to do terminal setup on the gateway machine. -They must stop the terminal echoing each command and strip out trailing -^M characters. This string must end in \\n. If you need to send multiple -commands, include them all in this string, separated by \\n. -See the documentation in efs.el for some example commands.") - -;; About efs-gwp-term-setup-command: -;; -;; It is important to get efs-gwp-setup-term-command right. -;; Here are some examples. Please tell us about which commands -;; to use on other platforms, so that we can include it in the -;; documentation. -;; -;; -;; HP-UX: -;; -;; "stty -onlcr -echo\n" -;; -;; SunOS: -;; -;; "stty -echo nl\n" -;; -;; VMS: (this should work) -;; -;; "set terminal/noecho\n" -;; - - -(defvar efs-gwp-prompt-pattern "^[^#$%>;]*[#$%>;] *" - "*Regexp used to detect that the gateway login sequence has completed. -It will be assumed that the shell is ready to receive input. Make this -regexp as strict as possible; it shouldn't match *anything* at all except -the shell's initial prompt. The above string will fail under most SUN-3's -since it matches the login banner.") - -;; About efs-gwp-prompt-pattern: -;; -;; It is very important that this not match anything in the machine's -;; login banner. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Internal Variables - -(defconst efs-gwp-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defvar efs-gwp-running t) -(defvar efs-gwp-status nil) -(defvar efs-gwp-string "") - -;;; Entry point (defined as an autoload in efs.el) - -(defun efs-gwp-start (host user name) - "Login to the gateway machine and fire up an ftp process." - (message "Connecting to gateway %s..." efs-gateway-host) - (let ((proc (apply 'start-process name (efs-ftp-process-buffer host user) - (nth 1 efs-gateway-type) - (append (nth 2 efs-gateway-type) - (list efs-gateway-host)))) - (ftp (concat (nth 3 efs-gateway-type) " " - (mapconcat (function identity) (nth 4 efs-gateway-type) - " ") "\n"))) - (process-kill-without-query proc) - (set-process-sentinel proc (function efs-gwp-sentinel)) - (set-process-filter proc (function efs-gwp-filter)) - (set-marker (process-mark proc) (point)) - (setq efs-gwp-running t - efs-gwp-status nil - efs-gwp-string "") - (while efs-gwp-running ;perform login sequence - (accept-process-output proc)) - (if (not efs-gwp-status) - (efs-error host user "unable to login to gateway")) - (message "Connecting to gateway %s...done" efs-gateway-host) - (setq efs-gwp-running t - efs-gwp-status nil - efs-gwp-string "") - (process-send-string proc efs-gwp-setup-term-command) - (while efs-gwp-running ;zap ^M's and double echoing. - (accept-process-output proc)) - (if (not efs-gwp-status) - (efs-error host user "unable to set terminal modes on gateway")) - (setq efs-gwp-running t - efs-gwp-status nil - efs-gwp-string "") - (message "Opening FTP connection to %s..." host) - (process-send-string proc ftp) - proc)) - -;;; Process filter/sentinel - -(defun efs-gwp-sentinel (proc str) - (setq efs-gwp-running nil)) - -(defun efs-gwp-filter (proc str) - (efs-save-match-data - ;; Don't be sensitive to login vn LOGIN. - (let ((case-fold-search t)) - (efs-process-log-string proc str) - (setq efs-gwp-string (concat efs-gwp-string str)) - (cond ((string-match "\\(login\\|username\\): *$" efs-gwp-string) - (process-send-string proc - (concat - (let ((efs-default-user t)) - (efs-get-user efs-gateway-host)) - "\n"))) - ((string-match "password: *$" efs-gwp-string) - (process-send-string proc - (concat - (efs-get-passwd efs-gateway-host - (efs-get-user - efs-gateway-host)) - "\n"))) - ((string-match efs-gateway-fatal-msgs - efs-gwp-string) - (delete-process proc) - (setq efs-gwp-running nil)) - ((string-match efs-gwp-prompt-pattern - efs-gwp-string) - (setq efs-gwp-running nil - efs-gwp-status t)))))) - -;;; end of efs-gwp.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-hell.el --- a/lisp/efs/efs-hell.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-hell.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Hellsoft FTP server support for efs -;; Author: Sandy Rutherford -;; Created: Tue May 25 02:31:37 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:32:27 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-hell) -(require 'efs) - -(defconst efs-hell-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; -------------------------------------------------------------- -;;;; Hellsoft FTP server support for efs -;;;; -------------------------------------------------------------- - -;;; The hellsoft FTP server runs on DOS PC's and Macs. The hellsoft -;;; support here probably won't work for Macs. If enough people need it -;;; the Mac support _might_ be fixed. - -;;; Works for "novell FTP Server for NW 3.11 (v1.8), (c) by HellSoft." - -;; Hellsoft uses unix path syntax. However, we shouldn't append a "." -;; to directories, because if foobar is a plain file, then -;; dir foobar/ will not give a listing (which is correct), but -;; dir foobar/. will give a one-line listing (which is a little strange). - -(efs-defun efs-fix-dir-path hell (dir-path) - dir-path) - -;; Hellsoft returns PWD output in upper case, whereas dir listings are -;; in lower case. To avoid confusion, downcase pwd output. - -(efs-defun efs-send-pwd hell (host user &optional xpwd) - ;; Returns ( DIR . LINE ), where DIR is either the current directory, or - ;; nil if this couldn't be found. LINE is the line of output from the - ;; FTP server. Since the hellsoft server returns pwd output in uppercase, we - ;; downcase it. - (let ((result (efs-send-pwd 'unix host user xpwd))) - (if (car result) - (setcar result (downcase (car result)))) - result)) - -(defconst efs-hell-date-and-time-regexp - (concat - " \\([0-9]+\\) \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [0-3][0-9] " - "\\([012][0-9]:[0-5][0-9]\\| [12][019][0-9][0-9]\\) ")) -;; The end of this regexp corresponds to the start of a filename. - -(defmacro efs-hell-parse-file-line () - ;; Returns ( FILENAME DIR-P SIZE ) from the current line - ;; of a hellsoft listing. Assumes that the point is at the beginning - ;; of the line. - (` (let ((eol (save-excursion (end-of-line) (point))) - (dir-p (= (following-char) ?d))) - (if (re-search-forward efs-hell-date-and-time-regexp eol t) - (list (buffer-substring (point) (progn (end-of-line) (point))) - dir-p - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))))))) - -(efs-defun efs-parse-listing hell - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a listing from - ;; a Hellsoft FTP server. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a full remote path - ;; PATH = directory in full efs-path syntax - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-hell-date-and-time-regexp nil t) - (let ((tbl (efs-make-hashtable)) - file-info) - (beginning-of-line) - (while (setq file-info (efs-hell-parse-file-line)) - (efs-put-hash-entry (car file-info) (cdr file-info) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl) - (if (not (string-match (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name dir)) "\\.")) - ;; It's an empty dir - (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - - -(efs-defun efs-allow-child-lookup hell (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Subdirs in DOS can't have an extension. - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-hell-re-exe - "^[^\n]+\\.exe$") - -(or (assq 'hell efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'hell efs-dired-hell-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-hell-re-dir - "^. [ \t]*d") - -(or (assq 'hell efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'hell efs-dired-hell-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename hell - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line, where - ;; line can be delimited by either \r or \n. - ;; Returns (point) or nil if raise-error is nil and there is no - ;; filename on this line. In the later case, leaves the point at the - ;; beginning of the line. - ;; This version is for the Hellsoft FTP server. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-hell-date-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename hell - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the Hellsoft FTP server version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_+=a-zA-Z0-9.$~") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline hell (dir) - ;; Insert a blank line for aesthetics - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -;;; end of efs-hell.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-ka9q.el --- a/lisp/efs/efs-ka9q.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ka9q.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: KA9Q support for efs -;; Author: Sandy Rutherford -;; Created: Mon Dec 21 10:34:43 1992 by sandy on ibm550 -;; Modified: Sun Nov 27 18:32:56 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Thanks go to Joe Reinhardt for beta testing. - -(provide 'efs-ka9q) -(require 'efs) - -(defconst efs-ka9q-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;;;----------------------------------------------------------------- -;;; KA9Q support for efs -;;;----------------------------------------------------------------- -;;; -;;; KA9Q is not really an OS, but an ftp server that runs on PC's. -;;; It runs under DOS and unix. Seems to have been adopted by LINUX. - -;; KA9Q uses unix syntax for paths, so don't need to bother with pathname -;; converters. It always gives a listing, even if a file or dir doesn't -;; exist. Therefore, we shall assume that empty dir = nonexistent dir. sigh... - -(defconst efs-ka9q-date-regexp - " +[.,0-9]* [ 0-2][0-9]:[0-9][0-9] +[0-9]+/[0-9]+/[0-9]+") - ;; (match-beginning 0) should be the last char of the filename. - -(defun efs-ka9q-bogus-listing (dir path) - ;; Check to see if a 1-line ka9q listing is bogus, and the directory - ;; is really just a file. - (and - (not (string-equal "/" dir)) - (goto-char (point-min)) - (looking-at (regexp-quote - (concat (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name dir)) - " "))) - (forward-line 1) - (looking-at "1 file\\. ") - (string-match "^No files\\. " - ;; ls switches don't matter - (efs-ls (concat path "*") "-al" t t)))) - -(efs-defun efs-parse-listing ka9q - (host user dir path &optional switches) - ;; Parse the current listing which is assumed to be a ka9q listing. - ;; Format is based on version 890421.1a.linux.7 (whatever that means). - ;; Note that ka9q uses two files per line. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs-path syntax - (let ((tbl (efs-make-hashtable)) - dir-p file) - (efs-save-match-data - (if (and - (progn - (goto-char (point-max)) - (forward-line -1) - ;; Although "No files." may refer to an empty - ;; directory, it may also be a non-existent - ;; dir. Returning nil should force a listing - ;; of the parent, which will sort things out. - (looking-at "[0-9]+ files?\\. ")) - ;; Check for a bogus listing. - (not (efs-ka9q-bogus-listing dir path))) - (progn - (goto-char (point-min)) - (while (re-search-forward efs-ka9q-date-regexp nil t) - (goto-char (match-beginning 0)) - (if (setq dir-p (eq (preceding-char) ?/)) - (forward-char -1)) - (setq file (buffer-substring (point) - (progn (skip-chars-backward "^ \n") - (point)))) - (efs-put-hash-entry file (list dir-p) tbl) - (goto-char (match-end 0))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - -;;; Tree Dired - -(defconst efs-dired-ka9q-re-exe - "^. [^ \n\r./]+\\.exe ") - -(or (assq 'ka9q efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'ka9q efs-dired-ka9q-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-ka9q-re-dir - "^. [^ \n\r/]+/ ") - -(or (assq 'ka9q efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'ka9q efs-dired-ka9q-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-fixup-listing ka9q (file path &optional switches wildcard) - ;; ka9q puts two files per line. Need to put in one file per line format - ;; for dired. - (let ((regexp (concat efs-ka9q-date-regexp " "))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (delete-char -3) - (insert-char ?\n 1)) - ;; is there a blank line left? - (if (looking-at "[ \t]*\n") - (delete-region (match-beginning 0) (match-end 0))))) - -(efs-defun efs-dired-ls-trim ka9q () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (forward-line 1) - (if (looking-at "\\([0-9]+\\|No\\) files?\\. ") - (delete-region (point) (point-max))))) - -(efs-defun efs-dired-insert-headerline ka9q (dir) - ;; Insert a headerline - (insert-char ?\n 1) - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename ka9q - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This is the KA9Q version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-ka9q-date-regexp eol t) - (progn - (goto-char (match-beginning 0)) - (skip-chars-backward "^ " bol) - (point)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ka9q - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the KA9Q version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "^ \n\r/") - (if (or (= opoint (point)) (not (memq (following-char) '(?/ ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-ka9q.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-kerberos.el --- a/lisp/efs/efs-kerberos.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,136 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-kerberos.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.0 $ -;; RCS: -;; Description: Support for Kerberos gateways. -;; Author: Sandy Rutherford -;; Created: Thu Nov 24 21:19:25 1994 by sandy on gandalf -;; Modified: -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Support for the Kerberos gateway authentication system from MIT's -;;; Project Athena. - -(provide 'efs-kerberos) -(require 'efs) - -(defconst efs-kerberos-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.0 $" 11 -2))) - -;;; Internal Variables - -(defvar efs-kerberos-passwd-sent nil) -;; Set to t after the passwd has been sent. -(defvar efs-kerberos-output "") -;; Holds the output lines from the kinit process. -(defvar efs-kerberos-buffer-name "*efs kerberos*") -;; Buffer where kinit output is logged. -(defvar efs-kerberos-passwd-prompt-regexp "^Password: *$") -;; Regular expression to match prompt used by the kinit program. -(defvar efs-kerberos-failed-msgs "[^ ]+") -;; Regular expression to match output for an invalid kinit ticket password. -;; Is this too general? -(defvar efs-kerberos-passwd-failed nil) -;; Whether the kinit command worked. -(defvar efs-kerberos-passwd-retry nil) - -;;; Code - -(defun efs-kerberos-process-filter (proc str) - ;; Process filter for the kinit process. - (setq efs-kerberos-output (concat efs-kerberos-output str)) - (let ((buff (get-buffer (process-buffer proc)))) - (if buff - (efs-save-buffer-excursion - (set-buffer buff) - (efs-save-match-data - (goto-char (point-max)) - (while (string-match "\n" efs-kerberos-output) - (let ((line (substring efs-kerberos-output 0 - (match-beginning 0)))) - (insert line "\n") - (and efs-kerberos-passwd-sent - (string-match efs-kerberos-failed-msgs line) - (setq efs-kerberos-passwd-failed t))) - (setq efs-kerberos-output (substring efs-kerberos-output - (match-end 0)))) - (and (null efs-kerberos-passwd-sent) - (string-match efs-kerberos-passwd-prompt-regexp - efs-kerberos-output) - (memq (process-status proc) '(run open)) - (let ((passwd (or - (efs-lookup-passwd efs-gateway-host "kerberos") - (read-passwd - (if efs-kerberos-passwd-retry - "Password failed. Try again: " - (format "Kerberos password for %s: " - efs-gateway-host)))))) - (unwind-protect - (progn - (insert efs-kerberos-output) - (setq efs-kerberos-output "") - (process-send-string proc passwd) - (insert "Turtle Power!\n")) - (fillarray passwd 0))))))))) - -(defun efs-kerberos-get-ticket () - ;; Gets a kerbos ticket. The password is actually sent by the process - ;; filter. - (let ((mess (format "Getting kerberos ticket for %s..." efs-gateway-host))) - (message mess) - (setq efs-kerberos-passwd-failed nil - efs-kerberos-passwd-sent nil - efs-kerberos-output "") - (condition-case nil (delete-process "*efs kerberos*") (eror nil)) - (let* ((program (or (nth 3 efs-gateway-type) "kinit")) - (args (nth 4 efs-gateway-type)) - (proc (apply 'start-process - "*efs kerberos*" efs-kerberos-buffer-name - program args))) - (set-process-filter proc (function efs-kerberos-process-filter)) - ;; Should check for a pty, but efs-pty-check will potentially eat - ;; important output. Need to wait until Emacs 19.29 to do this properly. - (while (memq (process-status proc) '(run open)) - (accept-process-output proc)) - (if efs-kerberos-passwd-failed - (let ((efs-kerberos-passwd-failed t)) - (efs-kerberos-get-ticket)))) - (message "%sdone" mess))) - -(defun efs-kerberos-login (host user proc) - ;; Open a connection using process PROC to HOST adn USER, using a - ;; kerberos gateway. Returns the process object of the connection. - ;; This may not be PROC, if a ticket collection was necessary. - (let ((to host) - result port cmd) - (if (string-match "#" host) - (setq to (substring host 0 (match-beginning 0)) - port (substring host (match-end 0)))) - (and efs-nslookup-on-connect - (string-match "[^0-9.]" to) - (setq to (efs-nslookup-host to))) - (setq cmd (concat "open " to)) - (if port (setq cmd (concat cmd " " port))) - (setq result (efs-raw-send-cmd proc cmd)) - (while (and (car result) - (string-match "\\bcannot authenticate to server\\b" - (nth 1 result))) - (let ((name (process-name proc))) - (condition-case nil (delete-process proc) (error nil)) - (efs-kerberos-get-ticket) - (setq proc (efs-start-process host user name) - result (efs-raw-send-cmd proc cmd)))) - (if (car result) - (progn - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "OPEN request failed: " - (nth 1 result))))) - proc)) - -;;; End of efs-kerberos.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-mpe.el --- a/lisp/efs/efs-mpe.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,678 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-mpe.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.8 $ -;; RCS: -;; Description: MPE (HP3000) support for efs. -;; Author: (Corny de Souza) cdesouza@hpbbn.bbn.hp.com -;; Created: Fri Jan 15 12:58:29 1993 -;; Modified: Sun Nov 27 18:36:13 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Credits -;; -;; Sandy Rutherford for his help and advice. - -;;; Usage -;; -;; For a general description of remote file access see efs.el. -;; -;; MPE Specifics -;; -;; *) To make things easier (for me) MPE has been UNIXified so think UNIX -;; and you stand a good chance of understanding everything. -;; -;; *) Filename syntax is as follows -;; -;; /session,user.account,group@system:/account/group/file;buildparms -;; -;; the "session," and ",group" in the logon sequence are optional. -;; -;; e.g. /CDSUSER.OSCAR@SYSTEM41:/OSCAR/CDSSRC/TST0000S -;; will get the file TST0000S.CDSSRC.OSCAR -;; -;; The ";buildparms" is also optional. It should be used when creating -;; files whos characteristics differ from the default system buildparms, -;; described in the file FTPDOC.ARPA.SYS (at least it is on my system). -;; Also see variable efs-mpe-default-buildparms. -;; -;; e.g. REC=-256,,V,ASCII -;; -;; *) Password syntax is as follows -;; -;; userpass,accountpass,grouppass -;; -;; Leading commas cannot be omitted, trailing commas can. -;; e.g. USERPASS,ACCTPASS (no group password) -;; ,ACCTPASS (only account password) -;; USERPASS,,GRPPASS (no account password) -;; -;; *) Do not use account name completion on large systems. See the variable -;; efs-mpe-account-completion-confirm -;; -;; *) Do not use group name completion on large accounts. See the variable -;; efs-mpe-group-completion-confirm -;; -;; *) The buffers FILE and FILE;BUILDPARMS both point to the same physical -;; disc file. -;; -;; *) When using filename completion you will usually be given the option -;; between FILE and FILE;BUILDPARMS. Just ignore the FILE;BUILDPARMS -;; bit. -;; -;; *) WARNING ********* Two buffer for the same file ************ WARNING -;; If you land up with two buffers FILE and FILE;BUILDPARMS for the same -;; file kill the FILE;BUILDPARMS one. If however this is newwer than -;; the FILE buffer (and you cannot live with a buffer called -;; FILE;BUILDPARMS) save it kill both buffers and get the FILE buffer again. -;; -;; *) When creating new files only create FILES. It is possible to create -;; files as GROUPs and ACCOUNTs but don't! -;; -;;; To Do -;; -;; A lot of things are likely to change with MPE 4.5 and POSIX so I do not want -;; to invest too much time in this now. I would rather wait until I can see -;; what comes with POSIX. -;; -;; Feel free to send bugs, suggestions for enhancements and enhancements -;; to me cdesouza@hpbbn.bbn.hp.com. If I have TIME I will try to deal with -;; them. Also I'm not a lisp programmer so keep it simple or put in plenty -;; of comments. -;; -;; -;; *) Improve on the dired GROUP and ACCOUNT listings. -;; -;; *) Add ".." to dired FILE and GROUP listings. -;; -;; *) Support POSIX (need POSIX machine first though). -;; -;; *) Test ACCOUNT name completion and listings properly. I have the problem -;; that the only systems available to me are large ( i.e. start a listf -;; @.@.@,2 today and come back tomorrow), which makes -;; it pretty hard for me to test. -;; - -;;; Code - -(provide 'efs-mpe) -(require 'efs) - -;;; User Variables - -(defvar efs-mpe-account-completion-confirm t - "*Set to non-nil will cause a prompt to be issued before attempting ACCOUNT -name completion. For ACCOUNT name completion a LISTF @.@.@,2 is required. -This can take a very long time on large systems") - -(defvar efs-mpe-group-completion-confirm t - "*Set to non-nil will cause a prompt to be issued before attempting GROUP -name completion. For GROUP name completion a LISTF @.@.ACCOUNT,2 is required. -This can take a very long time on large accounts") - -(defvar efs-mpe-default-buildparms "" - "*If set to non empty string used to override the system default buildparms.") - -;;; Internal Variables - -(defconst efs-mpe-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.8 $" 11 -2))) - -;;; Support for build parameters - -(defun efs-mpe-get-buildparms (path) - ;; Gets the mpe buildparms for PATH. PATH should be in efs syntax. - (let ((files (efs-get-files-hashtable-entry (file-name-directory - (directory-file-name path))))) - (if files - (let* ((file (efs-get-file-part path)) - (completion-ignore-case - (memq 'mpe efs-case-insensitive-host-types)) - (bpversions (all-completions (concat file ";") files))) - (cond - ((null bpversions) - efs-mpe-default-buildparms) - ((= (length bpversions) 1) - (substring (car bpversions) (length file))) - (t - (error - "efs-mpe: %s seems to have more than one set of buildparams." - path)))) - ;; return the default - efs-mpe-default-buildparms))) - -(defun efs-mpe-fix-buildparms (buildparms host user path) - "Try to assign buildparms for the file being PUT" - (or - ;; Buildparms specified with file use them. - buildparms - (efs-mpe-get-buildparms (format efs-path-format-string user host path)))) - -;;; entry points - -(efs-defun efs-fix-path mpe (path &optional reverse) - ;; Convert PATH from UNIX-ish to MPE. If REVERSE given then convert from - ;; MPE to UNIX-ish. N.B. Path does not contain HOST or USER part so the - ;; dynamic variables HOST and USER are used. - ;; Also uses the dynamic variable CMD0. - (efs-save-match-data - (if reverse - ;; This is never used as we only convert PWD (see below) output in - ;; this direction. However I will leave this here should it be - ;; required in the future. - (if (let ((case-fold-search t)) - (string-match - (concat "^\\([A-Z][A-Z0-9]*\\)" ; file - "\\(.[A-Z][A-Z0-9]*\\)" ; group - "\\(.[A-Z][A-Z0-9]*\\)$") ; account - path)) - (let (file group account) - (setq file (substring path 0 (match-end 1))) - (if (match-beginning 2) - (setq group (substring - path (1+ (match-beginning 2)) (match-end 2)))) - (if (match-beginning 3) - (setq account (substring - path (1+ (match-beginning 3)) - (match-end 3)))) - (concat (and account (concat "/" account "/")) - (and group (concat group "/")) - file)) - ;; handle PWD output - (if (let ((case-fold-search t)) - (string-match - (concat - "\\([A-Z][A-Z0-9]*\\)?" ; sessionname - ",[A-Z][A-Z0-9]*\.\\([A-Z][A-Z0-9]*\\)," ; username.account - "\\([A-Z][A-Z0-9]*\\)$") ; group - path)) - (concat "/" - (substring path (match-beginning 2) (match-end 2)) - "/" - (substring path (match-beginning 3) (match-end 3)) - "/") - (error "Invalid MPE (MPE->UNIX) filename: %s" path))) - (if (let ((case-fold-search t)) - (string-match - (concat - "^\\(/[A-Z][A-Z0-9]*/\\)" ; account - "\\([A-Z][A-Z0-9]*/\\)" ; group - "\\([A-Z][A-Z0-9]*\\)" ; file - "\\(;.*\\)?$") ; buildparms - path)) - (let ((for-put (and (boundp 'cmd0) (eq cmd0 'put))) - file group account buildparms) - (setq account (substring - path (1+ (match-beginning 1)) (1- (match-end 1)))) - (setq group (substring - path (match-beginning 2) (1- (match-end 2)))) - (setq file (substring path (match-beginning 3) (match-end 3))) - (if for-put - (setq buildparms - (efs-mpe-fix-buildparms - (and (match-beginning 4) - (substring path - (match-beginning 4) (match-end 4))) - host user path))) - (concat file - (and group (concat "." group )) - (and account (concat "." account )) - (and for-put buildparms))) - (error "Invalid MPE (UNIX->MPE) filename: *%s*" path))))) - -(efs-defun efs-fix-dir-path mpe (dir-path) - ;; Convert path from UNIX-ish to MPE ready for a DIRectory listing. MPE does - ;; not have directories as such. It does have GROUPS and ACCOUNTS, but the - ;; DIR command does not let you list just ACCOUNTs on the system or just - ;; GROUPs in the ACCOUNT - no you always get everything downwards - ;; i.e. ACCOUNTs + GROUPs + FILEs or GROUPs + FILEs or just FILEs - ;; depending on the level. - (efs-save-match-data - (message "Fixing listing %s ..." dir-path) - (cond - ;; Everything !?! might take a while. - ((string-equal dir-path "/") - (if efs-mpe-account-completion-confirm - (if (y-or-n-p "Continue with ACCOUNT name completion? ") - "@.@.@" - (error "Quit ACCOUNT name completion")) - "@.@.@")) - ;; specification starts with account - ((let ((case-fold-search t)) - (string-match - (concat - "^\\(/[A-Z][A-Z0-9]*/\\)" ; account - "\\([A-Z][A-Z0-9]*/\\)?" ; group - "\\([A-Z][A-Z0-9]*\\)?" ; file - "\\(;.*\\)?/?$") ; buildparms - dir-path)) - (let (file group account) - (setq account (substring dir-path - (1+ (match-beginning 1)) (1- (match-end 1)))) - (if (match-beginning 2) - (setq group (substring dir-path - (match-beginning 2) (1- (match-end 2)))) - (if efs-mpe-group-completion-confirm - (if (y-or-n-p "Continue with GROUP name completion? ") - (setq group "@") - (error "Quit GROUP name completion")) - (setq group "@"))) - (if (match-beginning 3) - ;;(setq file (substring dir-path - ;; (match-beginning 3) (1- (match-end 3)))) - ;; set the filename to something silly so that the DIR will fail - ;; and so force a DIR for the group instead. Either I've - ;; misunderstood something or you have to do it like this. - (setq file "~!#&*") - (setq file "@")) - (concat file "." group "." account))) - (t - (error "Invalid MPE (LISTF) filename: %s" dir-path))))) - -(defconst efs-mpe-acct-grp-line-regexp - "ACCOUNT= +\\([A-Z][A-Z0-9]*\\) +GROUP= +\\([A-Z][A-Z0-9]*\\)") -(defconst efs-mpe-file-line-regexp - (concat - "\\*? +\\([A-Z0-9]*\\) +\\([0-9]+\\)" - "\\([BW]\\) +\\([FV]\\)\\([AB]\\)\\([MCO]?\\) +\\([0-9]+\\)")) - -(efs-defun efs-parse-listing mpe - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in - ;; mpe ftp dir format. - ;; HOST is the name of the remote host. - ;; USER is the user name. - ;; DIR is the directory as a full remote path - ;; PATH is the directory in full efs-syntax - ;; SWITCHES are the switches passed to ls (not relevant for mpe) - (goto-char (point-min)) - (efs-save-match-data - ;;Make sure this is a valid listing - (if (re-search-forward "ACCOUNT= +[A-Z]+ +GROUP=" nil t) - (let (acct-tbl grp-tbl file-tbl - account group file - acct-cur grp-cur) - (goto-char (point-min)) - ;; Look for something that could be a filename. - (while (re-search-forward "^[A-Z][A-Z0-9]*" nil t) - (goto-char (match-beginning 0)) - ;; Check to see if looking at an ACCOUNT= GROUP= line. Could - ;; be a continuation (cont). line or a change in account or group - (if (looking-at efs-mpe-acct-grp-line-regexp) - (progn - (setq account (buffer-substring (match-beginning 1) - (match-end 1))) - (setq group (buffer-substring (match-beginning 2) - (match-end 2))) - ;;Check for change of account - (if (not (string-equal acct-cur account)) - (progn - ;;Create table for account names and fill with - ;; "." entry. - (if (not acct-tbl) - (progn - (setq acct-tbl (efs-make-hashtable)) - (efs-put-hash-entry "." '(t) acct-tbl))) - (efs-put-hash-entry account '(t) acct-tbl) - ;;Store the current group table - (if grp-tbl - (progn - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/")) - grp-tbl ) - (setq grp-tbl nil))))) - ;;Check for change in group. Change in account is automatic - ;;change in group. - (if (or (not (string-equal acct-cur account)) - (not (string-equal grp-cur group))) - (progn - ;;Create table for group names and fill with - ;; "." and ".." entries. - (if (not grp-tbl) - (progn - (setq grp-tbl (efs-make-hashtable)) - (efs-put-hash-entry "." '(t) grp-tbl) - (efs-put-hash-entry ".." '(t) grp-tbl))) - (efs-put-hash-entry group '(t) grp-tbl) - ;;Store current file table - (if file-tbl - (progn - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/" grp-cur "/")) - file-tbl) - (setq file-tbl nil))))) - ;;Set new grp-cur and acct-cur incase one or both chnaged. - (setq grp-cur group acct-cur account) - ) - ;;Looking at either a file name, or the line - ;;"FILENAME CODE --....--LOGICAL.." - ;;Save the possible filename. - (setq file (buffer-substring (point) - (progn - (skip-chars-forward "A-Z0-9") - (point)))) - ;;Make sure its a file name. - ;;"\\*?" is for files in access. - ;; File codes can be numeric as well! CdS - (if (looking-at efs-mpe-file-line-regexp) - ;;Hack out the buildparms - (let* ((code (and - (/= (match-beginning 1) (match-end 1)) - (concat ";CODE=" - (buffer-substring - (match-beginning 1) (match-end 1))))) - (length (buffer-substring (match-beginning 2) - (match-end 2))) - (eof (buffer-substring (match-beginning 7) - (match-end 7))) - (bytes (* (string-to-int eof) - (string-to-int length))) - (word-byte (buffer-substring (match-beginning 3) - (match-end 3))) - (fix-var (buffer-substring (match-beginning 4) - (match-end 4))) - (ascii-binary (buffer-substring (match-beginning 5) - (match-end 5))) - (cir-msg (and (match-beginning 6) - (buffer-substring (match-beginning 6) - (match-end 6)))) - (rec ";REC=")) - (if (string-equal word-byte "B") - (setq rec (concat rec "-")) - (setq bytes (* 2 bytes))) - (setq rec (concat rec length ",," fix-var ",")) - (if (string-equal ascii-binary "A") - (setq rec (concat rec "ASCII")) - (setq rec (concat rec "BINARY"))) - (cond ((string-equal cir-msg "M") - (setq cir-msg ";MSG")) - ((string-equal cir-msg "O") - (setq cir-msg ";CIR")) - (t - (setq cir-msg nil))) - (if (not file-tbl) - (progn - (setq file-tbl (efs-make-hashtable)) - (efs-put-hash-entry "." '(t) file-tbl) - (efs-put-hash-entry ".." '(t) file-tbl))) - (message "Adding... %s" file) - (efs-put-hash-entry file (list nil bytes) file-tbl) - (efs-put-hash-entry (concat file rec code cir-msg) - (list nil bytes) file-tbl))) - ) ;if looking-at - (forward-line 1) - );while - ;;Check at what level the listing was done and return the - ;;corresponding table. System = acct-tbl, Account = grp-tbl, - ;;Group = file-tbl. - (if (let ((case-fold-search t)) - (string-match - "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" - dir)) - ;;group level listing, just return table of files - (if (or (match-beginning 3) (match-beginning 4)) - file-tbl - ;;account level listing, return table of groups but do not - ;;forget to store current table of files. - (if (match-beginning 2) - (progn - (if file-tbl - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/" grp-cur "/")) - file-tbl)) - grp-tbl) - ;;System level listing, return table of accounts but do not - ;;forget to store current table of groups and files - (if (match-beginning 1) - (progn - (if file-tbl - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/" grp-cur "/")) - file-tbl)) - (if grp-tbl - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/")) - grp-tbl)) - acct-tbl) - (error "Parse listing 0 path %s" path)))) - (error "Parse listing 1 path %s" path)))))) - - -(efs-defun efs-really-file-p mpe (file ent) - ;; Doesn't treat the buildparm entry as a real file entry. - (efs-save-match-data - (not (string-match ";" file)))) - -(efs-defun efs-delete-file-entry mpe (path &optional dir-p) - ;; Deletes FILE and FILE;BUILDPARMS from file hashtable. - (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-files-hashtable-entry - (file-name-directory path))) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (let ((file (efs-get-file-part path)) - (files (efs-get-files-hashtable-entry - (file-name-directory path)))) - (if files - (efs-save-match-data - (if (string-match ";" file) - (let ((root (substring file (match-beginning 0)))) - ;; delete ROOT from hashtable - (efs-del-hash-entry root files ignore-case) - ;; delete ROOT;BUILDPARAMS from hashtable - (efs-del-hash-entry file files ignore-case)) - ;; we've specified only a root. - (let* ((root (concat file ";")) - (completion-ignore-case ignore-case) - (extensions (all-completions root files))) - ;; Get rid of FILE. - (efs-del-hash-entry file files ignore-case) - ;; Get rid of all BUILDPARAMS versions - (while extensions - ;; all-completions will return names with the right case. - ;; Don't need to ignore-case now. - (efs-del-hash-entry (car extensions) files) - (setq extensions (cdr extensions))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry mpe (path dir-p size owner - &optional modes nlinks mdtm) - ;; Deletes FILE (if present) and FILE;BUILDPARMS (if present) from hashtable - ;; then adds FILE and FILE;BUILDPARMS (if specified) to hashtable. - (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-files-hashtable-entry - (file-name-directory path)))) - (if files - (efs-put-hash-entry (efs-get-file-part path) ent files - ignore-case))) - - (let ((files (efs-get-files-hashtable-entry - (file-name-directory path)))) - (efs-save-match-data - (if files - (let* ((file (efs-get-file-part path)) - (root (substring file 0 (string-match ";" file)))) - (if (equal root file) - (setq file (concat file (efs-mpe-get-buildparms path)))) - ;; In case there is another entry with different buildparams, - ;; wipe it. - (efs-delete-file-entry 'mpe path nil) - (efs-put-hash-entry root ent files ignore-case) - (efs-put-hash-entry file ent files ignore-case)))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-allow-child-lookup mpe (host user dir file) - ;; Returns non-NIL if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. Note that DIR is in directory syntax i.e. /foo/bar/, not - ;; /foo/bar. - - ;; Subdirs in MPE are accounts or groups. - (string-match "^/\\([^/]+/\\)?$" dir)) - -(efs-defun efs-file-type mpe (path) - ;; Returns whether to treat an efs file as a text file or not. - (let ((buildparams (efs-mpe-get-buildparms path))) - (efs-save-match-data - (let ((case-fold-search t)) - (cond - ((string-match "BINARY" buildparams) - '8-binary) - (t - 'text)))))) - -;;; Tree dired support: - -(efs-defun efs-dired-manual-move-to-filename mpe - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the MPE version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - ;; The "\\|ACCOUNT=\\|GROUP=" bit is to take care of the hacked account and - ;; group dired listings. - (if (looking-at - ". [A-Z][A-Z0-9]*\\*? +\\([A-Z]* +[0-9]+\\|ACCOUNT=\\|GROUP=\\)") - (progn - (forward-char 2) - (point)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mpe - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the MPE version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "A-Z0-9") - (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?*)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-ls-trim mpe () - ;; trim single file listings 1-line. - ;; This uses an evil dynamical binding of file. - (if (and (boundp 'file) (stringp file)) - (let ((f (file-name-nondirectory file))) - (or (zerop (length f)) - (progn - (goto-char (point-min)) - (if (search-forward (concat "\n" (upcase file) " ") nil t) - (progn - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))))))))) - -(efs-defun efs-dired-fixup-listing mpe (file path &optional switches wildcard) - ;; File (group) listings stay pretty much as they are group (account) and - ;; account (system) listings get realy hacked. - (efs-save-match-data - (goto-char (point-max)) - (string-match - "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" - path) - ;; group or file level listing. - (if (or (match-beginning 3) (match-beginning 4)) - ;; Hack out the continuation lines. - (while - (re-search-backward - "\n\nACCOUNT=.+GROUP=.+(CONT\\.)\n\n.*\n.*\n" nil t) - (replace-match "" nil nil)) - ;;account level listing, hack out everything apart from group names - (if (match-beginning 2) - (let ((group nil) - (grp-cur nil)) - (while - (re-search-backward - "GROUP= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" - nil t) - (setq group - (buffer-substring (match-beginning 1) (match-end 1))) - ;;Continuation header or new group - (if (string-equal grp-cur group) - (replace-match "" nil nil) - (replace-match (format "\n\n%-10sGROUP=" group) nil nil)) - (forward-line -1) - (setq grp-cur group) - (narrow-to-region (point-min) (point))) - (widen) - (goto-char (point-max)) - (insert "\n\n")) - ;;System level listing, hack out everything apart from account names - (if (match-beginning 1) - (let (account acct-cur) - (while - (re-search-backward - "^ACCOUNT= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" - nil t) - (setq account - (buffer-substring (match-beginning 1) (match-end 1))) - ;;Continuation header or new account - (if (string-equal acct-cur account) - (replace-match "" nil nil) - (replace-match (format "%-10sACCOUNT=" account) nil nil)) - (forward-line -1) - (setq acct-cur account) - (narrow-to-region (point-min) (point))) - (widen) - (goto-char (point-max)) - (insert "\n\n"))))))) - -;;; end of efs-mpe.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-ms-unix.el --- a/lisp/efs/efs-ms-unix.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ms-unix.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: efs support for the Microsoft PC FTP server in unix mode. -;; Author: Sandy Rutherford -;; Created: Thu Aug 19 08:31:15 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:37:00 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-ms-unix) -(require 'efs) - -(defconst efs-ms-unix-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defvar efs-ms-unix-month-and-time-regexp - (concat - " \\([0-9]+\\) +" ; file size - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 0-3][0-9]" - " +\\([ 012][0-9]:[0-6][0-9]\\|[12][90][0-9][0-9]\\) +")) - -;;; entry points - -(efs-defun efs-fix-path ms-unix (path &optional reverse) - ;; Convert PATH from UNIX-ish to MS-UNIX. - (if reverse - (concat "/" path) - (substring path 1))) - -(efs-defun efs-fix-dir-path ms-unix (dirpath) - ;; Convert a path from UNIX-ish to MS-UNIX for a dir listing - (if (string-equal dirpath "/") - (error "Cannot grok disk names.") - (setq dirpath (substring dirpath 1)) - (efs-save-match-data - (if (string-match "/$" dirpath) - (concat dirpath "*") - dirpath)))) - -(defmacro efs-ms-unix-parse-file-line () - ;; Extract the filename, size, and permission string from the current - ;; line of a dired-like listing. Assumes that the point is at - ;; the beginning of the line, leaves it just before the size entry. - ;; Returns a list (name size perm-string nlinks owner). - ;; If there is no file on the line, returns nil. - (` (let ((eol (save-excursion (end-of-line) (point))) - name size modes nlinks owner) - (skip-chars-forward " 0-9" eol) - (and - (looking-at efs-modes-links-owner-regexp) - (setq modes (buffer-substring (match-beginning 1) - (match-end 1)) - nlinks (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))) - owner (buffer-substring (match-beginning 3) (match-end 3))) - (re-search-forward efs-ms-unix-month-and-time-regexp eol t) - (setq name (buffer-substring (point) eol) - size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (list name size modes nlinks owner))))) - -(efs-defun efs-parse-listing ms-unix (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be output from - ;; the Microsoft FTP server in unix mode. - ;; Return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-ms-unix-month-and-time-regexp nil t) - (let ((tbl (efs-make-hashtable)) - size modes nlinks dir-p owner file) - (beginning-of-line) - (while (setq file (efs-ms-unix-parse-file-line)) - (setq size (nth 1 file) - modes (nth 2 file) - nlinks (nth 3 file) - owner (nth 4 file) - file (car file) - dir-p (= (string-to-char modes) ?d)) - (if (and dir-p - (string-match "/$" file)) - (setq file (substring file 0 -1))) - (efs-put-hash-entry file (list dir-p size owner modes nlinks) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -;;; Tree Dired - -;; ms-unix does not have a total line - -(efs-defun efs-dired-insert-headerline ms-unix (dir) - ;; MTS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename ms-unix - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This version is for ms-unix. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-ms-unix-month-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ms-unix - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the ms-unix version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (if (eolp) - (progn - (goto-char opoint) - (if no-error - nil - (error "No file on this line"))) - (end-of-line) - (if (char-equal (preceding-char) ?/) - (forward-char -1)) - (point)))) - -;;; end of efs-ms-unix.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-mts.el --- a/lisp/efs/efs-mts.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,239 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-mts.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: MTS support for efs -;; Author: Sandy Rutherford -;; Created: Fri Oct 23 08:51:29 1992 -;; Modified: Sun Nov 27 18:37:18 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-mts) -(require 'efs) - -(defconst efs-mts-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; MTS support -;;;; ------------------------------------------------------------ - -;;; efs has full support, including tree dired support, for hosts running -;;; the Michigan terminal system. It should be able to automatically -;;; recognize any MTS machine. We would be grateful if you -;;; would report any failures to automatically recognize a MTS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; MTS filenames are entered in a UNIX-y way. For example, if your account -;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be -;;; entered as -;;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE -;;; In other words, MTS accounts are treated as UNIX directories. Of course, -;;; to access a file in another account, you must have access permission for -;;; it. If FILE were in your own account, then you could enter it in a -;;; relative path fashion as -;;; /YYYY@mtsg.ubc.ca:FILE -;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the -;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you -;;; like.) MTS filenames are always in upper case, and hence be sure to enter -;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX -;;; is. - - -(defconst efs-mts-date-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 123]?[0-9] ")) - -;;; The following two functions are entry points to this file. -;;; They are put into the appropriate alists in efs.el - -(efs-defun efs-fix-path mts (path &optional reverse) - ;; Convert PATH from UNIX-ish to MTS. - ;; If REVERSE given then convert from MTS to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path) - (let (acct file) - (if (match-beginning 1) - (setq acct (substring path 0 (match-end 1)))) - (if (match-beginning 2) - (setq file (substring path - (match-beginning 2) (match-end 2)))) - (concat (and acct (concat "/" acct "/")) - file)) - (error "path %s didn't match" path)) - (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path) - (concat (substring path 1 (match-end 1)) - (substring path (match-beginning 2) (match-end 2))) - ;; Let's hope that mts will recognize it anyway. - path)))) - -(efs-defun efs-fix-dir-path mts (dir-path) -;; Convert path from UNIX-ish to MTS ready for a DIRectory listing. -;; Remember that there are no directories in MTS. - (if (string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.") - (let ((dir-path (efs-fix-path 'mts dir-path))) - (cond - ((string-equal dir-path "") - "?") - ((efs-save-match-data (string-match ":$" dir-path)) - (concat dir-path "?")) - (dir-path))))) ; It's just a single file. - - -(efs-defun efs-parse-listing mts - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in - ;; mts ftp dir format. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a remote full path - ;; PATH = directory as an efs full path - ;; SWITCHES are never used here, but they - ;; must be specified in the argument list for compatibility - ;; with the unix version of this function. - (let ((tbl (efs-make-hashtable)) - perms) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward efs-mts-date-regexp nil t) - (beginning-of-line) - (if (looking-at "[rwed]+") - (setq perms (buffer-substring (match-beginning 0) (match-end 0))) - (setq perms nil)) - (end-of-line) - (skip-chars-backward " ") - (let ((end (point))) - (skip-chars-backward "-A-Z0-9_.!") - (efs-put-hash-entry (buffer-substring (point) end) - (list nil nil nil perms) tbl)) - (forward-line 1))) - ;; Don't need to bother with .. - (efs-put-hash-entry "." '(t) tbl) - tbl)) - -(efs-defun efs-allow-child-lookup mts (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; MTS file system is flat. Only "accounts" are subdirs. - (string-equal "/" dir)) - -(efs-defun efs-internal-file-writable-p mts (user owner modes) - (if (stringp modes) - (efs-save-match-data - (null (null (string-match "w" modes)))) - t)) ; guess - -(efs-defun efs-internal-file-readable-p mts (user owner modes) - (if (stringp modes) - (efs-save-match-data - (null (null (string-match "r" modes)))) - t)) ; guess - -;;; Tree dired support: - -;; There aren't too many systems left that use MTS. This dired support will -;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems -;; implement ftp in the same way. If not, it might be necessary to make the -;; following more flexible. - -(defconst efs-dired-mts-re-exe nil) - -(or (assq 'mts efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'mts efs-dired-mts-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-mts-re-dir nil) - -(or (assq 'mts efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'mts efs-dired-mts-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename mts - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the MTS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-mts-date-regexp eol t) - (progn - (skip-chars-forward " ") ; Eat blanks after date - (skip-chars-forward "0-9:") ; Eat time or year - (skip-chars-forward " ") ; one space before filename - (point)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mts - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the MTS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9._!") - (if (or (= opoint (point)) (not (memq (following-char) '(?\r ?\n)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-fixup-listing mts (file path &optional switches wildcard) - ;; If you're not listing your own account, MTS puts the - ;; account name in front of each filename. Scrape them off. - ;; PATH will have unix /'s on it. - ;; file-name-directory is in case of wildcards - (let ((len (length path))) - (if (> len 2) - (progn - (if (= (aref path (1- len)) ?/) - (setq path (substring path -2)) - (setq path (substring path -1))) - (goto-char (point-min)) - (while (search-forward path nil t) - (delete-region (match-beginning 0) (match-end 0))))))) - -(efs-defun efs-dired-insert-headerline mts (dir) - ;; MTS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -;;; end of efs-mts.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-mvs.el --- a/lisp/efs/efs-mvs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,361 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-mvs.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.4 $ -;; RCS: -;; Description: MVS support for efs -;; Author: Sandy Rutherford -;; Created: Sat Nov 14 02:04:54 1992 -;; Modified: Sun Nov 27 18:37:54 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; -------------------------------------------------------- -;;; MVS support -;;; -------------------------------------------------------- - -(provide 'efs-mvs) -(require 'efs) - -(defconst efs-mvs-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.4 $" 11 -2))) - -;; What's the MVS character set for valid partitioned data sets? -;; I'll guess [-A-Z0-9_$+] - -;; The top level directory in MVS contains partitioned data sets. -;; We will view these as directories. The data sets within each -;; partitioned data set will be viewed as files. -;; -;; In MVS an entry for a "sub-dir" may have the same name as a plain -;; file. This is impossible in unix, so we retain the "dots" at the -;; end of subdir names, to distinuguish. -;; i.e. FOO.BAR --> /FOO./BAR - -(efs-defun efs-send-pwd mvs (host user &optional xpwd) - ;; Broken quoting for PWD output on some MVS servers. - (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) - (line (nth 1 result)) - dir) - (and (car result) - (efs-save-match-data - (and (string-match " \"'?\\([0-9A-Z]+\\)'?\"" line) - (setq dir (substring line (match-beginning 1) - (match-end 1)))))) - (cons dir line))) - -(efs-defun efs-fix-path mvs (path &optional reverse) - ;; Convert PATH from UNIX-ish to MVS. - (efs-save-match-data - (if reverse - (let ((start 0) - (res "/")) - ;; MVS has only files, some of which are partitioned - ;; into smaller files (partitioned data sets). We will - ;; assume that path starts with a partitioned dataset. - (while (string-match "\\." path) - ;; grab the dot too, because in mvs prefixes and plain - ;; files can have the same name. - (setq res (concat res (substring path start (match-end 0)) "/") - start (match-end 0))) - (concat res (substring path start))) - (let ((start 1) - res) - (while (string-match "/" path start) - (setq res (concat res (substring path start (match-beginning 0))) - start (match-end 0))) - (concat res (substring path start)))))) - -(efs-defun efs-fix-dir-path mvs (dir-path) - ;; Convert path from UNIX-ish to MVS for a DIR listing. - (cond - ((string-equal "/" dir-path) - " ") - (t (concat (efs-fix-path 'mvs dir-path) "*")))) - -(efs-defun efs-allow-child-lookup mvs (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; MVS file system is flat. Only partitioned data sets are "subdirs". - (efs-save-match-data - (string-match "\\.$" file))) - -(efs-defun efs-parse-listing mvs (host user dir path &optional switches) - ;; Guesses the type of mvs listings. - (efs-save-match-data - (goto-char (point-min)) - (cond - ((looking-at "Volume ") - (efs-add-listing-type 'mvs:tcp host user) - (efs-parse-listing 'mvs:tcp host user dir path switches)) - - ((looking-at "[-A-Z0-9_$.+]+ ") - (efs-add-listing-type 'mvs:nih host user) - (efs-parse-listing 'mvs:nih host user dir path switches)) - - (t - ;; Since MVS works on a template system, return an empty hashtable. - (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - -(efs-defun efs-ls-dumb-check mvs (line host file path lsargs msg noparse - noerror nowait cont) - ;; Because of the template structure of the MVS file system, empty - ;; directories are the same as non-existent. It's better for us to treat - ;; them as empty. - (and (string-match "^550 " line) - (let ((parse (or (null noparse) (eq noparse 'parse) - (efs-parsable-switches-p lsargs t)))) - (efs-add-to-ls-cache file lsargs "\n" parse) - (if parse - (efs-set-files file (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - (if nowait - (progn - (if cont - (efs-call-cont cont "\n")) - t) - (if cont - (efs-call-cont cont "\n")) - "\n")))) - -;;;; ---------------------------------------------------- -;;;; Support for the NIH FTP server. -;;;; ---------------------------------------------------- - -(efs-defun efs-parse-listing mvs:nih - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an MVS listing - ;; Based on the listing format of the NIH server. Hope that this format - ;; is widespread. If a directory doesn't exist, get a 426 ftp error. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs-syntax - (let ((tbl (efs-make-hashtable)) - (top-p (string-equal "/" dir)) - ;; assume that everything top-level is a partitioned data set - ) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward "^[-A-Z0-9_$.+]+" nil t) - (efs-put-hash-entry - (concat (buffer-substring (match-beginning 0) (match-end 0)) - (and top-p ".")) - (list top-p) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (or top-p (efs-put-hash-entry ".." '(t) tbl))) - tbl)) - -;;; Tree dired support - -(defconst efs-dired-mvs-re-exe - "^. [-A-Z0-9_$+]+\\.EXE " - "Regular expression to use to search for MVS executables.") - -(or (assq 'mvs:nih efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'mvs:nih efs-dired-mvs-re-exe) - efs-dired-re-exe-alist))) - -(efs-defun efs-dired-insert-headerline mvs:nih (dir) - ;; MVS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename mvs:nih - (&optional raise-error bol eol) - ;; In dired, move to the first char of the filename on this line. - ;; This is the MVS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - ;; MVS listings are pretty loose. Tough to tell when we've got a file line. - (if (and - (> (- eol bol) 2) - (progn - (forward-char 2) - (skip-chars-forward " \t") - (looking-at "[-A-Z0-9$_.+]+[ \n\r]"))) - (point) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mvs:nih - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the MVS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9$_.+" eol) - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-get-filename mvs:nih - (&optional localp no-error-if-not-filep) - (let ((name (efs-real-dired-get-filename localp no-error-if-not-filep)) - (parsed (efs-ftp-path (dired-current-directory)))) - (if (and name (string-equal "/" (nth 2 parsed))) - (concat name ".") - name))) - -(efs-defun efs-dired-fixup-listing mvs:nih - (file path &optional switches wildcard) - ;; MVS listings have trailing spaces to 80 columns. - ;; Can lead to a mess after indentation. - (goto-char (point-min)) - (while (re-search-forward " +$" nil t) - (replace-match ""))) - -;;;; ------------------------------------------------------- -;;;; Support for the TCPFTP MVS server -;;;; ------------------------------------------------------- -;;; -;;; For TCPFTP IBM MVS V2R2.1 Does it really work? - -(efs-defun efs-parse-listing mvs:tcp - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an MVS listing - ;; Based on the listing format of the NIH server. Hope that this format - ;; is widespread. If a directory doesn't exist, get a 426 ftp error. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs-syntax - (efs-save-match-data - (goto-char (point-min)) - (and (looking-at "Volume ") - (let ((top-tbl (efs-make-hashtable)) - (case-fold (memq 'mvs efs-case-insensitive-host-types)) - tbl-list file dn fn tbl dir-p) - (forward-line 1) - (while (not (eobp)) - (end-of-line) - (setq file (buffer-substring (point) - (progn (skip-chars-backward "^ ") - (point))) - dn path - dir-p (string-match "\\." file)) - (efs-put-hash-entry file '(nil) top-tbl) - (if dir-p - (progn - (setq dir-p (1+ dir-p) - fn (substring file 0 dir-p)) - (efs-put-hash-entry fn '(t) top-tbl) - (while dir-p - (setq dn (efs-internal-file-name-as-directory nil - (concat dn fn)) - file (substring file dir-p) - tbl (cdr (assoc dn tbl-list))) - (or tbl (setq tbl (efs-make-hashtable) - tbl-list (cons (cons dn tbl) tbl-list))) - (efs-put-hash-entry file '(nil) tbl) - (setq dir-p (string-match "\\." file)) - (if dir-p - (progn - (setq dir-p (1+ dir-p) - fn (substring file 0 dir-p)) - (efs-put-hash-entry fn '(t) tbl)))))) - (forward-line 1)) - (while tbl-list - (efs-put-hash-entry (car (car tbl-list)) (cdr (car tbl-list)) - efs-files-hashtable case-fold) - (setq tbl-list (cdr tbl-list))) - top-tbl)))) - -;;; Tree Dired - -(efs-defun efs-dired-manual-move-to-filename mvs:tcp - (&optional raise-error bol eol) - ;; In dired, move to the first char of the filename on this line. - ;; This is the MVS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (and (re-search-forward " [0-9][0-9]/[0-9][0-9]/[0-9][0-9] " eol t) - (progn - (goto-char eol) - (skip-chars-backward "-A-Z0-9$_.") - (char-equal (preceding-char) ?\ )) - (/= eol (point))) - (point) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mvs:tcp - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the MVS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9$_.+" eol) - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-mvs.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-netrc.el --- a/lisp/efs/efs-netrc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-netrc.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: Parses ~/.netrc file, and does completion in /. -;; Author: Sandy Rutherford -;; Created: Fri Jan 28 19:32:47 1994 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;;; ------------------------------------------------------------ -;;;; Provisions and requirements. -;;;; ------------------------------------------------------------ - -(provide 'efs-netrc) -(require 'efs-cu) -(require 'efs-ovwrt) -(require 'passwd) -(require 'efs-fnh) - -;;;; ------------------------------------------------------------ -;;;; Internal Variables -;;;; ------------------------------------------------------------ - -(defconst efs-netrc-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;; Make the byte compiler happy. -(defvar dired-directory) - -;;;; ------------------------------------------------------------ -;;;; Use configuration variables. -;;;; ------------------------------------------------------------ - -(defvar efs-netrc-filename "~/.netrc" - "*File in .netrc format to search for passwords. -If you encrypt this file, name it something other than ~/.netrc. Otherwise, -ordinary FTP will bomb. - -If you have any cryption package running off of find-file-hooks -(such as crypt.el or crypt++.el), efs will use it to decrypt this file. -Encrypting this file is a good idea!") - -(defvar efs-disable-netrc-security-check nil - "*If non-nil avoid checking permissions for `efs-netrc-filename'.") - -;;;; ------------------------------------------------------------ -;;;; Host / User / Account mapping support. -;;;; ------------------------------------------------------------ - -;;;###autoload -(defun efs-set-passwd (host user passwd) - "For a given HOST and USER, set or change the associated PASSWORD." - (interactive (list (read-string "Host: ") - (read-string "User: ") - (read-passwd "Password: "))) - (efs-set-host-user-property host user 'passwd - (and passwd (efs-code-string passwd)))) - -(defun efs-set-account (host user minidisk account) - "Given HOST, USER, and MINIDISK, set or change the ACCOUNT password. -The minidisk is only relevant for CMS. If minidisk is irrelevant, -give the null string for it. In lisp programs, give the minidisk as nil." - (interactive (efs-save-match-data - (let* ((path (or buffer-file-name - (and (eq major-mode 'dired-mode) - dired-directory))) - (parsed (and path (efs-ftp-path path))) - (default-host (car parsed)) - (default-user (nth 1 parsed)) - (default-minidisk - (and parsed - (eq (efs-host-type default-host) 'cms) - (string-match "^/[^/]+/" (nth 2 parsed)) - (substring (nth 2 parsed) 1 - (1- (match-end 0))))) - (host (read-string "Host: " default-host)) - (user (read-string "User: " default-user)) - (minidisk - (read-string - "Minidisk (enter null string if inapplicable): " - default-minidisk)) - (account (read-passwd "Account password: "))) - (if (string-match "^ *$" minidisk) - (setq minidisk nil)) - (list host user minidisk account)))) - (and account (setq account (efs-code-string account))) - (if minidisk - (efs-put-hash-entry (concat (downcase host) "/" user "/" minidisk) - account efs-minidisk-hashtable) - (efs-set-host-user-property host user 'account account))) - -;;;; ------------------------------------------------------------ -;;;; Parsing the ~/.netrc. -;;;; ------------------------------------------------------------ - -(defconst efs-netrc-modtime nil) -;; Last modified time of the netrc file from file-attributes. - -(defun efs-netrc-next-token () - ;; Gets the next token plus it's value. - ;; Returns \(token value-1 value-2 ...\) - (skip-chars-forward " \t\n") - (while (char-equal (following-char) ?#) - (forward-line 1) - (skip-chars-forward " \t\n")) - (let ((tok (and (not (eobp)) - (downcase (buffer-substring - (point) - (progn - (skip-chars-forward "^ \n\t") - (point))))))) - (cond - ((null tok) nil) - ((string-equal tok "default") - (list tok)) - ((member tok (list "machine" "login" "password" "account")) - (list tok (efs-netrc-read-token-value))) - ((string-equal tok "minidisk") - (list tok (efs-netrc-read-token-value) - (efs-netrc-read-token-value))) - ((string-equal tok "include") - (let ((start (- (point) 7)) - (path (expand-file-name (efs-netrc-read-token-value)))) - (delete-region start (point)) - (save-excursion (insert (efs-netrc-get-include path)))) - (efs-netrc-next-token)) - ;; Deal with tokens that we skip - ((string-equal tok "macdef") - (efs-save-match-data - (search-forward "\n\n" nil 'move)) - (if (eobp) - nil - (efs-netrc-next-token))) - (t (error "efs netrc file error: Invalid token %s." tok))))) - -(defun efs-netrc-read-token-value () - ;; Read the following word as a token value. - (skip-chars-forward " \t\n") - (while (char-equal (following-char) ?#) - (forward-line 1) - (skip-chars-forward " \t\n")) - (if (eq (following-char) ?\") ;quoted token value - (prog2 - (forward-char 1) - (buffer-substring (point) - (progn (skip-chars-forward "^\"") (point))) - (forward-char 1)) - (buffer-substring (point) - (progn (skip-chars-forward "^ \n\t") (point))))) - -(defun efs-netrc-get-include (path) - ;; Returns the text of an include file. - (let ((buff (create-file-buffer path))) - (unwind-protect - (save-excursion - (set-buffer buff) - (setq buffer-file-name path - default-directory (file-name-directory path)) - (insert-file-contents path) - (normal-mode t) - (mapcar 'funcall find-file-hooks) - (setq buffer-file-name nil) - (buffer-string)) - (condition-case nil - ;; go through this rigamoroll, because who knows - ;; where an interrupt in find-file-hooks leaves us. - (save-excursion - (set-buffer buff) - (set-buffer-modified-p nil) - (passwd-kill-buffer buff)) - (error nil))))) - -(defun efs-parse-netrc-group (&optional machine) - ;; Extract the values for the tokens "machine", "login", "password", - ;; "account" and "minidisk" in the current buffer. If successful, - ;; record the information found. - (let (data login) - ;; Get a machine token. - (if (or machine (setq data (efs-netrc-next-token))) - (progn - (cond - (machine) ; noop - ((string-equal (car data) "machine") - (setq machine (nth 1 data))) - ((string-equal (car data) "default") - (setq machine 'default)) - (error - "efs netrc file error: %s" - "Token group must start with machine or default.")) - ;; Next look for a login token. - (setq data (efs-netrc-next-token)) - (cond - ((null data) - ;; This just interns in the hashtable for completion to - ;; work. The username gets set later by efs-get-user. - (if (stringp machine) (efs-set-user machine nil)) - nil) - ((string-equal (car data) "machine") - (if (stringp machine) (efs-set-user machine nil)) - (nth 1 data)) - ((string-equal (car data) "default") - 'default) - ((not (string-equal (car data) "login")) - (error "efs netrc file error: Expected login token for %s." - (if (eq machine 'default) - "default" - (format "machine %s" machine)))) - (t - (setq login (nth 1 data)) - (if (eq machine 'default) - (setq efs-default-user login) - (efs-set-user machine login) - ;; Since an explicit login entry is given, intern an entry - ;; in the efs-host-user-hashtable for completion purposes. - (efs-set-host-user-property machine login nil nil)) - (while (and (setq data (efs-netrc-next-token)) - (not (or (string-equal (car data) "machine") - (string-equal (car data) "default")))) - (cond - ((string-equal (car data) "password") - (if (eq machine 'default) - (setq efs-default-password (nth 1 data)) - (efs-set-passwd machine login (nth 1 data)))) - ((string-equal (car data) "account") - (if (eq machine 'default) - (setq efs-default-account (nth 1 data)) - (efs-set-account machine login nil (nth 1 data)))) - ((string-equal (car data) "minidisk") - (if (eq machine 'default) - (error "efs netrc file error: %s." - "Minidisk token is not allowed for default entry.") - (apply 'efs-set-account machine login (cdr data)))) - ((string-equal (car data) "login") - (error "efs netrc file error: Second login token for %s." - (if (eq machine 'default) - "default" - (format "machine %s" machine)))))) - (and data (if (string-equal (car data) "machine") - (nth 1 data) - 'default)))))))) - -(defun efs-parse-netrc () - "Parse the users ~/.netrc file, or file specified `by efs-netrc-filename'. -If the file exists and has the correct permissions then extract the -\`machine\', \`login\', \`password\', \`account\', and \`minidisk\' -information from within." - (interactive) - (and efs-netrc-filename - (let* ((file (expand-file-name efs-netrc-filename)) - ;; Set to nil to avoid an infinite recursion if the - ;; .netrc file is remote. - (efs-netrc-filename nil) - (file (efs-chase-symlinks file)) - (attr (file-attributes file)) - netrc-buffer next) - (if (or (interactive-p) ; If interactive, really do something. - (and attr ; file exists. - ;; file changed - (not (equal (nth 5 attr) efs-netrc-modtime)))) - (efs-save-match-data - (or efs-disable-netrc-security-check - (and (eq (nth 2 attr) (user-uid)) ; Same uids. - (string-match ".r..------" (nth 8 attr))) - (efs-netrc-scream-and-yell file attr)) - (unwind-protect - (save-excursion - ;; we are cheating a bit here. I'm trying to do the - ;; equivalent of find-file on the .netrc file, but - ;; then nuke it afterwards. - ;; with the bit of logic below we should be able to have - ;; encrypted .netrc files. - (set-buffer (setq netrc-buffer - (generate-new-buffer "*ftp-.netrc*"))) - (insert-file-contents file) - (setq buffer-file-name file) - (setq default-directory (file-name-directory file)) - (normal-mode t) - (mapcar 'funcall find-file-hooks) - (setq buffer-file-name nil) - (goto-char (point-min)) - (while (and (not (eobp)) - (setq next (efs-parse-netrc-group next))))) - (condition-case nil - ;; go through this rigamoroll, because we knows - ;; where an interrupt in find-file-hooks leaves us. - (save-excursion - (set-buffer netrc-buffer) - (set-buffer-modified-p nil) - (passwd-kill-buffer netrc-buffer)) - (error nil))) - (setq efs-netrc-modtime (nth 5 attr))))))) - -(defun efs-netrc-scream-and-yell (file attr) - ;; Complain about badly protected netrc files. - (let* ((bad-own (/= (nth 2 attr) (user-uid))) - (modes (nth 8 attr)) - (bad-protect (not (string-match ".r..------" modes)))) - (if (or bad-own bad-protect) - (save-window-excursion - (with-output-to-temp-buffer "*Help*" - (if bad-own - (princ - (format - "Beware that your .netrc file %s is not owned by you.\n" - file))) - (if bad-protect - (progn - (if bad-own - (princ "\nAlso,") - (princ "Beware that")) - (princ - " your .netrc file ") - (or bad-own (princ (concat file " "))) - (princ - (format - "has permissions\n %s.\n" modes)))) - (princ - "\nIf this is intentional, then setting \ -efs-disable-netrc-security-check -to t will inhibit this warning in the future.\n")) - (select-window (get-buffer-window "*Help*")) - (enlarge-window (- (count-lines (point-min) (point-max)) - (window-height) -1)) - (if (and bad-protect - (y-or-n-p (format "Set permissions on %s to 600? " file))) - (set-file-modes file 384)))))) - -;;;; ---------------------------------------------------------------- -;;;; Completion in the root directory. -;;;; ---------------------------------------------------------------- - -(defun efs-generate-root-prefixes () - "Return a list of prefixes of the form \"user@host:\". -Used when completion is done in the root directory." - (efs-parse-netrc) - (efs-save-match-data - (let (res) - (efs-map-hashtable - (function - (lambda (key value) - (if (string-match "^[^/]+\\(/\\).+$" key) - ;; efs-passwd-hashtable may have entries of the type - ;; "machine/" to indicate a password assigned to the default - ;; user for "machine". Don't use these entries for completion. - (let ((host (substring key 0 (match-beginning 1))) - (user (substring key (match-end 1)))) - (setq res (cons (list (format - efs-path-user-at-host-format - user host)) - res)))))) - efs-host-user-hashtable) - (efs-map-hashtable - (function (lambda (host user) - (setq res (cons (list (format efs-path-host-format - host)) - res)))) - efs-host-hashtable) - (if (and (null res) - (string-match "^1[0-8]\\.\\|^[0-9]\\." emacs-version)) - (list nil) - res)))) - -;;;###autoload -(defun efs-root-file-name-all-completions (file dir) - ;; Generates all completions in the root directory. - (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn - 'efs-root-handler-function))) - (nconc (all-completions file (efs-generate-root-prefixes)) - (file-name-all-completions file dir)))) - - -;;;###autoload -(defun efs-root-file-name-completion (file dir) - ;; Calculates completions in the root directory to include remote hosts. - (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn - 'efs-root-handler-function))) - (try-completion - file - (nconc (efs-generate-root-prefixes) - (mapcar 'list (file-name-all-completions file "/")))))) - - -;;; end of efs-netrc.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-netware.el --- a/lisp/efs/efs-netware.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-netware.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.5 $ -;; RCS: -;; Description: efs support for the Novell Netware FTP server -;; Author: Sandy Rutherford -;; Created: Fri Oct 15 00:30:50 1993 by sandy on gauss.math.ubc.ca -;; Modified: Tue Nov 22 00:11:46 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Works for (at least) Novell NetWare v3.11. This is a DOS FTP server, -;;; however, it returns a unix-ish path format. - -(provide 'efs-netware) -(require 'efs) - -(defconst efs-netware-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.5 $" 11 -2))) - -;;; Basic efs support - -(defconst efs-netware-date-regexp - (concat - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" - "Dec\\) [ 0-3][0-9] \\([0-9][0-9] \\)?[0-2][0-9]:[0-6][0-9] +")) - -(efs-defun efs-fix-path netware (path &optional reverse) - ;; Convert PATH from UNIX-ish to netware. - (efs-save-match-data - (if reverse - (cond ((string-match "^[^/][^:]*:" path) - (concat "/" path)) - ((string-match "^/" path) - path) - ((error "%s not a valid netware path." path))) - (if (string-match ":" path) - (substring path 1) - path)))) - -(efs-defun efs-fix-dir-path netware (dir-path) - ;; Convert DIR-PATH from UN*X-ish to Netware for a DIR listing. - (efs-fix-dir-path nil (efs-fix-path 'netware dir-path))) - -(defun efs-netware-bogus-listing-p (dir path) - (save-excursion - (and - (not (eobp)) - (save-excursion (forward-line 1) (eobp)) - (not (string-equal dir "/")) - (re-search-forward efs-netware-date-regexp nil t) - (search-forward "/.\n")))) - -(efs-defun efs-parse-listing netware (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a listing from - ;; a Novell Netware FTP server (runs under DOS). - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-netware-date-regexp nil t) - (progn - (beginning-of-line) - (and (not (efs-netware-bogus-listing-p dir path)) - (let ((tbl (efs-make-hashtable)) - dir-p file size) - (while (let ((eol (save-excursion (end-of-line) (point)))) - (setq dir-p (= (following-char) ?d)) - (re-search-forward efs-netware-date-regexp eol t)) - (setq file (buffer-substring (point) - (progn (end-of-line) (point))) - size (progn - (goto-char (match-beginning 0)) - (skip-chars-backward " ") - (buffer-substring (point) - (progn - (skip-chars-backward "0-9") - (point))))) - (if (string-equal size "") - (setq size nil) - (setq size (string-to-int size))) - (efs-put-hash-entry file (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))))) - -;;; Sorting dir listings. - -(efs-fset 'efs-t-converter 'netware 'efs-unix-t-converter) - -;;; Dired support - -(defconst efs-dired-netware-re-exe "\\.\\(exe\\|EXE\\)$") -(or (assq 'netware efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'netware efs-dired-netware-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-netware-re-dir "^.[ \t]+d ") -(or (assq 'netware efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'netware efs-dired-netware-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename netware - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This is the Netware version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - ;; move over marker - (if (re-search-forward efs-netware-date-regexp eol t) - (goto-char (match-end 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename netware - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the Netware version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "^A-Z\n\r") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline netware (dir) - ;; Insert a blank line for aesthetics. - (insert " \n") - (forward-char -2) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-fixup-listing netware - (file path &optional switches wildcard) - ;; listings come out in random order - (let (case-fold-search) - (if (or (null switches) - ;; In case efs is handling the switches itself. - (not (string-match "t" switches))) - (progn - (goto-char (point-max)) - (if (re-search-backward efs-netware-date-regexp nil t) - (save-restriction - (forward-line 1) - (narrow-to-region (point-min) (point)) - (forward-line -1) - ;; Count how many fields - (let ((fields 0)) - (skip-chars-forward " \t") - (while (not (eolp)) - (skip-chars-forward "^ \t\n") - (skip-chars-forward " \t") - (setq fields (1+ fields))) - (sort-fields fields (point-min) (point-max))))))))) - -;;; end of efs-netware.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-nos-ve.el --- a/lisp/efs/efs-nos-ve.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,209 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-nos-ve.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: efs support for NOS/VE -;; Authors: Sandy Rutherford -;; Created: Fri Aug 19 04:57:09 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 18:39:43 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-nos-ve) -(require 'efs) - -;;; Works for NOS/VE from CDC. NOS/VE runs on Cybers. - -;;; Thank you to Jost Krieger for -;;; providing imformation and testing. - -(defconst efs-nos-ve-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;;;;--------------------------------------------------------------- -;;;; NOS/VE support for efs -;;;;--------------------------------------------------------------- - -;;; A legal NOS/VE filename is of the form -;;; ........ -;;; where always starts with the char : and is followed by -;;; alphanumeric characters. Each or can be up to 31 -;;; characters. File names are case insensistive. -;;; eg. :FOO.DIR_1.DIR_2.BAR -;;; -;;; The character set consists of (single case) alphabet, the numerals, -;;; and the characters "@$_#". (Not the quotes ...) The characters -;;; "[\]{|}" will also occur in a misguided attempt at -;;; internationalization. A filename may not start with a numeral. - - -;;; entry points - -(efs-defun efs-fix-path nos-ve (path &optional reverse) - ;; Convert path from UNIX to NOS/VE. - ;; If REVERSE is non-nil, goes in the opposite direction. - (if reverse - (let* ((res (concat "." path)) - (len (length res)) - (n 0)) - (while (< n len) - (and (= (aref res n) ?.) (aset res n ?/)) - (setq n (1+ n))) - res) - (let* ((res (substring (efs-internal-directory-file-name path) 1)) - (len (length res)) - (n 0)) - (while (< n len) - (and (= (aref res n) ?/) (aset res n ?.)) - (setq n (1+ n))) - res))) - -(efs-defun efs-fix-dir-path nos-ve (dir-path) - ;; Converts DIR-PATH to NOS/VE format for a directory listing. - (efs-fix-path 'nos-ve dir-path)) - -;;; parser - -(defconst efs-nos-ve-file-line-regexp - (concat - " \\([>0-9,]+\\) bytes \\(in [0-9]+ \\(file\\|catalog\\)s?\\)?\\|" - "\\( -- empty catalog\\)\\| -- device")) - -(efs-defun efs-parse-listing nos-ve (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a NOS/VE listing. - ;; Returns a hashtable. - (goto-char (point-min)) - (efs-save-match-data - (if (and (re-search-forward efs-nos-ve-file-line-regexp - (save-excursion (end-of-line) (point)) t) - (or (match-beginning 2) (match-beginning 4))) - (let ((tbl (efs-make-hashtable)) - size dir-p file) - (forward-line 1) - (while (re-search-forward efs-nos-ve-file-line-regexp - (save-excursion (end-of-line) (point)) t) - (setq size (and (match-beginning 1) - (buffer-substring - (match-beginning 1) (match-end 1))) - dir-p (null (null (or (match-beginning 2) - (match-beginning 4))))) - (if size - (let ((start 0) - res) - (while (string-match "," size start) - (setq res (concat res (substring size start - (match-beginning 0))) - start (match-end 0))) - (setq size (string-to-int - (concat res (substring size start)))))) - (beginning-of-line) - (forward-char 2) - (setq file (buffer-substring - (point) - (progn (skip-chars-forward "^ \t\n") (point)))) - (efs-put-hash-entry file (list dir-p size) - (or tbl (setq tbl (efs-make-hashtable)))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(efs-defun efs-allow-child-lookup nos-ve (host user dir file) - ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. Note that DIR is in directory syntax. - ;; i.e. /foo/bar/, not /foo/bar. - ;; Deal with dired. Anything else? - (not (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal (downcase dired-local-variables-file) - (downcase file))))) - -;;; Tree Dired - -(defconst efs-dired-nos-ve-re-exe "^.[^ \t\n]") -;; Matches no lines. Should it match something? - -(or (assq 'nos-ve efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'nos-ve efs-dired-nos-ve-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-nos-ve-re-dir " [0-9,]+ bytes in [0-9]+ file") - -(or (assq 'nos-ve efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'nos-ve efs-dired-nos-ve-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-fixup-listing nos-ve (file path &optional switches - wildcard) - ;; Need to turn the header line into something to masquerading as a file - ;; line, and need to remove the indentation. Both upset dired. - (goto-char (point-min)) - (while (search-forward "\n " nil t) - (delete-char -2)) - (goto-char (point-min)) - (if (looking-at "\\([^ \n]+ +\\)[0-9,]+ bytes in [0-9]+ file") - (progn - (delete-region (match-beginning 1) (match-end 1)) - (insert " Total of ")))) - -(defconst efs-dired-nos-ve-file-line-regexp - (concat - ".[ \t]+\\([][{}|\\\\a-z0-9@$_#]+\\) +" - "\\([>0-9,]+ bytes\\|-- \\(empty\\|device\\)\\)")) - -(efs-defun efs-dired-manual-move-to-filename nos-ve - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the NOS/VE version. - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (looking-at efs-dired-nos-ve-file-line-regexp) - (goto-char (match-beginning 1)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename nos-ve - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the NOS/VE version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "_a-z0-9$@#\\\\[]{}|") ; right char set? - (if (or (= opoint (point)) (/= (following-char) ?\ )) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-nos-ve.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-ovwrt.el --- a/lisp/efs/efs-ovwrt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ovwrt.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: Utilities for overwriting functions with new definitions. -;; Author: Andy Norman -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Although used by efs, these utilities could be of general use to other -;;; packages too. Keeping them separate from the main efs program -;;; makes it easier for other programs to require them. - -(provide 'efs-ovwrt) -(eval-when-compile - (condition-case nil - (require 'advice) - (error))) - -(defconst efs-ovwrt-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -(defvar efs-overwrite-fmt - "Note: This function has been modified to work with %s.") - -;; Make the byte compiler happy. -(defvar file-name-handler-alist) -(defvar inhibit-file-name-handlers) -(defvar inhibit-file-name-operation) - -(defun efs-safe-documentation (fun) - "A documentation function that isn't quite as fragile." - (condition-case () - (documentation fun) - (error nil))) - -(defun efs-overwrite-fn (package fun &optional newfun) - "Overwrites a function with a new definition from PACKAGE. -PACKAGE should be a string. The the function to be overwritten is FUN. -The new definition is obtained from the optional NEWFUN. If ommitted, -NEWFUN is taken to be PACKAGE-FUN. The original definition is stored in -PACKAGE-real-FUN. The original documentation is placed on the new -definition suitably augmented." - (let* ((name (symbol-name fun)) - (saved (intern (concat package "-real-" name))) - (new (or newfun (intern (concat package "-" name)))) - (nfun (symbol-function new)) - (exec-directory (if (or (equal (nth 3 command-line-args) "dump") - (equal (nth 4 command-line-args) "dump")) - "../etc/" - exec-directory))) - - (while (symbolp nfun) - (setq nfun (symbol-function nfun))) - - ;; Interpose the new function between the function symbol and the - ;; original definition of the function symbol AT TIME OF FIRST LOAD. - ;; We must only redefine the symbol-function of FUN the very first - ;; time, to avoid blowing away stuff that overloads FUN after this. - - ;; We direct the function symbol to the new function symbol - ;; rather than function definition to allow reloading of this file or - ;; redefining of the individual function (e.g., during debugging) - ;; later after some other code has been loaded on top of our stuff. - - (or (fboundp saved) - (let ((advised-p (and (featurep 'advice) - (ad-is-advised fun)))) - (if advised-p (ad-deactivate fun)) - (fset saved (symbol-function fun)) - (fset fun new) - (if advised-p (ad-activate fun)))) - - ;; Rewrite the doc string on the new function. This should - ;; be done every time the file is loaded (or a function is redefined), - ;; because the underlying overloaded function may have changed its doc - ;; string. - - (let* ((doc-str (efs-safe-documentation saved)) - (ndoc-str (concat doc-str (and doc-str "\n") - (format efs-overwrite-fmt package)))) - - (cond ((listp nfun) - ;; Probe to test whether function is in preloaded read-only - ;; memory, and if so make writable copy: - (condition-case nil - (setcar nfun (car nfun)) - (error - (setq nfun (copy-sequence nfun)) ; shallow copy only - (fset new nfun))) - (let ((ndoc-cdr (nthcdr 2 nfun))) - (if (stringp (car ndoc-cdr)) - ;; Replace the existing docstring. - (setcar ndoc-cdr ndoc-str) - ;; There is no docstring. Insert the overwrite msg. - (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr))) - (setcar ndoc-cdr (format efs-overwrite-fmt package))))) - (t - ;; it's an emacs19 compiled-code object - ;; - ;; XEmacs: can't use append on a compiled function - ;; as the latter is no longer a vector. Use the - ;; accessor functions instead. - (let ((new-code (nconc - (list (compiled-function-arglist nfun) - (compiled-function-instructions nfun) - (compiled-function-constants nfun) - (compiled-function-stack-depth nfun) - ndoc-str))) - spec) - (if (setq spec (compiled-function-interactive nfun)) - (setq new-code (nconc new-code (list (nth 1 spec))))) - (fset new (apply 'make-byte-code new-code)))))))) - - -;;; end of efs-ovwrt.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-pc.el --- a/lisp/efs/efs-pc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,980 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-pc.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: PC support for efs -;; Author: Sandy Rutherford -;; Created: Thu Mar 18 13:06:25 1993 -;; Modified: Sun Nov 27 18:40:46 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Thanks to jrs@world.std.com (Rick Sladkey) for providing support for -;;; the Frontier Technologies Super-TCP server - -;;; Many thanks to the following people for beta testing: -;;; Mike Northam -;;; bagman@austin.ibm.com (Doug Bagley) -;;; Jens Petersen -;;; Jeff Morgenthaler - -(provide 'efs-pc) -(require 'efs) - -(defconst efs-pc-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;----------------------------------------------------------------- -;;; PC support for efs -;;;----------------------------------------------------------------- - -;;; Works for the DOS FTP servers: -;;; Novell LAN WorkPlace v4.01 (NetWare & EXOS) -;;; PC/TCP Version 2.05 pl2 FTP Server by FTP Software -;;; Microsoft FTP Server service (beta 2) -;;; NCSA DOS ftp server. -;;; Frontier Technologies super tcp server (runs under MS WINDOWS) -;;; Alun's Windows FTP daemon for Winsock, v1.8b -;;; -;;; Works for IBM OS/2 TCP/IP FTP Version 1.2 - -;;; Currently support for all of the above FTP servers are in this file. -;;; Should they live in separate files? - -;;; host and listing type hierarchy in this file -;;; -;;; dos: dos:novell, dos:ftp, dos:ncsa, dos:microsoft, dos:stcp, dos:winsock -;;; os2: - -;;; DOS and OS/2 have slightly different filename syntaxes. -;;; -;;; DOS only allows at most one extension (".") per filename. -;;; A directory name usually has the extension ".DIR" implicit, but -;;; it seems that other extensions can be used. -;;; -;;; OS/2 running the FAT file system uses the same 8.3 format for -;;; filenames as DOS, except that extensions are allowed in directory names. -;;; OS/2 running the HPFS (high performance file system allows an arbitrary -;;; number of extensions in a filename. -;;; Mostly these differences are unimportant here, except in the dos -;;; definition of efs-allow-child-lookup. - -;;;; ---------------------------------------------------- -;;;; Utility functions and macros -;;;; ---------------------------------------------------- - -(defun efs-fix-pc-path (path &optional reverse) - ;; Convert PATH from UNIX-ish to DOS or OS/2. - ;; If REVERSE do just that. - (efs-save-match-data - (if reverse - (let ((n 0) - len res) - (if (string-match "^[a-zA-Z0-9]:" path) - ;; there's a disk - (setq res (concat "\\" path)) - (setq res (copy-sequence path))) - (setq len (length res)) - (while (< n len) - (and (= (aref res n) ?\\ ) (aset res n ?/)) - (setq n (1+ n))) - res) - (let ((n 0) - len res) - (if (string-match "^/[a-zA-Z0-9]:" path) - (setq res (substring path 1)) - (setq res (copy-sequence path))) - (setq len (length res)) - (while (< n len) - (and (= (aref res n) ?/) (aset res n ?\\ )) - (setq n (1+ n))) - res)))) - -(defmacro efs-dired-pc-move-to-end-of-filename (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the DOS and OS/2 version. It is common to all of the PC ftp - ;; servers since it depends only on the file name character set. - (` - (let ((opoint (point))) - (and selective-display - (null (, no-error)) - (eq (char-after - (1- (or (, bol) (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_+=a-zA-Z0-9.$~") - (if (= opoint (point)) - (if (, no-error) - nil - (error "No file on this line")) - (point))))) - -(defun efs-dired-pc-insert-headerline (dir) - ;; Insert a blank line for aesthetics. - (insert " \n") - (forward-char -2) - (efs-real-dired-insert-headerline dir)) - - -;;;;----------------------------------------------------------- -;;;; General DOS support -;;;;----------------------------------------------------------- - -;;; Regexps to be used for host and listing-type identification. - -(defconst efs-dos:ftp-file-line-regexp - (concat - " *\\([0-9]+\\|\\) +\\([-_+=a-zA-Z0-9$~.]+\\)" - " +\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\) " - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|" - "Oct\\|Nov\\|Dec\\) [0-3][0-9] ")) - -(defconst efs-dos:microsoft-file-line-regexp - ;; matches all the way to the first char of the filename. - (concat - "[01][0-9]-[0-3][0-9]-[0-9][0-9] +[012][0-9]:[0-5][0-9][AP]M +" - "\\(\\|[0-9]+\\) +")) - -(defconst efs-dos:ncsa-file-line-regexp - "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(\\|[0-9]+\\)[ \n]") - -(defconst efs-dos:stcp-file-line-regexp - (concat - "\\([-_+=a-zA-Z0-9$~.]+\\) +\\(\\|[0-9]+\\) " - "+[0-9][0-9]?-[0-3][0-9]-[12][90][0-9][0-9] +" - "[0-9][0-9]?:[0-5][0-9]")) - -(defconst efs-dos:winsock-date-and-size-regexp - (concat - " \\([0-9]+\\) " - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" - "Dec\\) [ 0-3][0-9] \\( [12][0-9][0-9][0-9]\\|[0-2][0-9]:[0-6][0-9]\\) +")) - -(efs-defun efs-parse-listing dos - (host user dir path &optional switches) - ;; Examine the listing, which is assumed to be either a DOS or OS/2 - ;; listing, and determine the operating system type and FTP server. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - ;; No need to check for OS/2, as it gets ID'ed by a SYST in - ;; efs-guess-host-type. - (efs-save-match-data - (cond - - ;; Check for the Microsoft server - ((re-search-forward efs-dos:microsoft-file-line-regexp nil t) - (efs-add-listing-type 'dos:microsoft host user) - (efs-parse-listing 'dos:microsoft host user dir path switches)) - - ;; Check for the Novell FTP server - ((save-excursion - (goto-char (point-max)) - (forward-line -1) - (looking-at " [0-9]+ File(s)\n")) - (efs-add-listing-type 'dos:novell host user) - (efs-parse-listing 'dos:novell host user dir path switches)) - - ;; Check for FTP software's server - ((re-search-forward efs-dos:ftp-file-line-regexp nil t) - (efs-add-listing-type 'dos:ftp host user) - (efs-parse-listing 'dos:ftp host user dir path switches)) - - ;; Check for winsock - ((re-search-forward efs-dos:winsock-date-and-size-regexp nil t) - (efs-add-listing-type 'dos:winsock host user) - (efs-parse-listing 'dos:winsock host user dir path switches)) - - ;; Check for the NCSA FTP server - ((re-search-forward efs-dos:ncsa-file-line-regexp nil t) - (efs-add-listing-type 'dos:ncsa host user) - (efs-parse-listing 'dos:ncsa host user dir path switches)) - - ;; Check for Frontier's Super-TCP server - ((re-search-forward efs-dos:stcp-file-line-regexp nil t) - (efs-add-listing-type 'dos:stcp host user) - (efs-parse-listing 'dos:stcp host user dir path switches)) - - ((string-match "^/\\([A-Za-z0-9]:/\\)?$" dir) - ;; root always exists - (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)) - (t - ;; an error message? - nil)))) - -;; Some DOS servers (NCSA), return a 501 message for an empty disk. -(efs-defun efs-ls-dumb-check dos (line host file path lsargs msg noparse - noerror nowait cont) - (and (string-match "^501 " line) - (string-match "^/[A-Za-z0-9]:/?$" path) - (let ((parse (or (null noparse) (eq noparse 'parse) - (efs-parsable-switches-p lsargs t)))) - (efs-add-to-ls-cache file lsargs "\n" parse) - (if parse - (efs-set-files file (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - (if nowait - (progn - (if cont - (efs-call-cont cont "\n")) - t) - (if cont - (efs-call-cont cont "\n")) - "\n")))) - -(efs-defun efs-fix-path dos (path &optional reverse) - (efs-fix-pc-path path reverse)) - -(efs-defun efs-fix-dir-path dos (dir-path) - ;; Convert path from UNIX-ish to DOS for a DIRectory listing. - (cond ((string-match "^/\\(.:\\)?$" dir-path) - (error "Can't list DOS or OS/2 disks")) - ;; Neither DOS nor OS/2 allows us to end the name of a directory - ;; with an "\". - ;; Adding *.* to the end also allows us to distinguish plain files from - ;; directories. All DOS servers seem to understand this except - ;; Frontier Technologies' super-tcp server. - ((string-match "/$" dir-path) - (concat (efs-fix-pc-path dir-path) "*.*")) - (t (efs-fix-pc-path dir-path)))) - -(efs-defun efs-get-pwd dos (host user &optional xpwd) - ;; Parses PWD output for the current working directory. Hopefully this is - ;; DOS proof. - (let* ((result (efs-send-cmd host user (list 'quote - (if xpwd 'xpwd 'pwd)) - "Getting PWD")) - (line (nth 1 result)) - dir) - (if (car result) - (efs-save-match-data - (and (or (string-match "\"\\([^\"]*\\)\"" line) - ;; FTP software's output. They should know better... - (string-match "Current working directory is +\\([^ ]+\\)$" - line)) - (setq dir (substring line - (match-beginning 1) - (match-end 1)))))) - (cons dir line))) - -(efs-defun efs-allow-child-lookup dos (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in DOS usually don't have an extension. - (not (string-match "\\." file))) - -;;;;----------------------------------- -;;;; Support for the Novell FTP server -;;;;----------------------------------- - -(defconst efs-dos:novell-file-line-regexp - ;; Matches from the first character of the filename to the end of the date. - ;; Does not match parent directories which the server might decide - ;; to put in front of the filename. - (concat - "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(\\|[0-9]+\\) +" - "[ 0-9][0-9]-[0-9][0-9]-[0-9][0-9] ")) - -(efs-defun efs-parse-listing dos:novell - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (let ((tbl (efs-make-hashtable)) - file size dir-p) - (efs-save-match-data - ;; Can we check somehow if the listing is really for something - ;; that doesn't exist? - (goto-char (point-min)) - (while (re-search-forward efs-dos:novell-file-line-regexp - nil t) - (setq file (buffer-substring (match-beginning 1) - (match-end 1)) - size (buffer-substring (match-beginning 2) - (match-end 2))) - (if (string-equal size "") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry file (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:novell-re-exe - "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") - -(or (assq 'dos:novell efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:novell efs-dired-dos:novell-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:novell-re-dir - "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +") - -(or (assq 'dos:novell efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:novell efs-dired-dos:novell-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:novell (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:novell - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - ;; move over marker - (if (re-search-forward efs-dos:novell-file-line-regexp eol t) - (goto-char (match-beginning 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:novell - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:novell - (file path &optional switches wildcard) - ;; DOS may insert the entire directory name in front of the file name. - ;; Scrape it off. The Novell server seems to do weird things when insert - ;; the full-path, so be liberal with the hatchet. - (goto-char (point-min)) - (while (re-search-forward efs-dos:novell-file-line-regexp nil t) - (beginning-of-line) - (delete-region (point) (match-beginning 0)) - (forward-line 1)) - ;; the novell server outputs lines in seemingly random order - ;; this isn't as good as sorting switches, but at least it's not random. - (sort-fields 1 (point-min) (progn (goto-char (point-max)) - (forward-line -1) - (point)))) - -(efs-defun efs-dired-ls-trim dos:novell () - (goto-char (point-min)) - (let (case-fold-search) - (forward-line 1) - (if (looking-at " [0-9]+ File(s)\n") - (delete-region (match-beginning 0) (match-end 0))))) - - -;;;;----------------------------------------------- -;;;; PC/TCP (by FTP software) support -;;;;----------------------------------------------- - -(efs-defun efs-parse-listing dos:ftp - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an FTP Software DOS - ;; listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (let ((tbl (efs-make-hashtable)) - file size dir-p) - (efs-save-match-data - ;; Can we check somehow if an empty directory is really - ;; a nonexistent directory? - (goto-char (point-min)) - (goto-char (point-min)) - (while (looking-at efs-dos:ftp-file-line-regexp) - (setq file (buffer-substring (match-beginning 2) - (match-end 2)) - size (buffer-substring (match-beginning 1) - (match-end 1))) - (if (string-equal size "") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry file (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:ftp-re-exe - "^. [ \t]*[0-9]+ +[-_+=a-zA-Z0-9$~]+\\.exe ") - -(or (assq 'dos:ftp efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:ftp efs-dired-dos:ftp-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:ftp-re-dir - "^. [ \t]* ") - -(or (assq 'dos:ftp efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:ftp efs-dired-dos:ftp-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:ftp (dir) - (efs-dired-pc-insert-headerline dir)) - -;;; Because dos:ftp listings have the file names right justified, -;;; I have reversed what -move-to-filename and -move-to-end-of-filename -;;; actually do. This shouldn't confuse dired, and should make browsing -;;; a dos:ftp listing more aesthetically pleasing. - -(efs-defun efs-dired-manual-move-to-filename dos:ftp - (&optional raise-error bol eol) - ;; In dired, move to the *last* char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-dos:ftp-file-line-regexp eol t) - (goto-char (match-end 2)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:ftp - (&optional no-error bol eol) - ;; Assumes point is at the *end* of filename. Really moves the - ;; point to the beginning of the filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the DOS version. It is common to all of the DOS ftp servers - ;; since it depends only on the file name character set. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-backward "-_+=a-zA-Z0-9.$~" bol) - (if (= opoint (point)) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;;;----------------------------------------------- -;;;; NCSA FTP support -;;;;----------------------------------------------- - -(efs-defun efs-parse-listing dos:ncsa - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (let (tbl file size dir-p next) - (efs-save-match-data - (goto-char (point-min)) - (while (re-search-forward - efs-dos:ncsa-file-line-regexp - (setq next (save-excursion (forward-line 1) (point))) t) - (setq file (buffer-substring (match-beginning 1) - (match-end 1)) - size (buffer-substring (match-beginning 2) - (match-end 2))) - (if (string-equal size "") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry file (list dir-p size) - (or tbl (setq tbl (efs-make-hashtable)))) - (goto-char next)) - ;; DOS does not put . and .. in the root directory. - (if (or tbl - ;; root always exists - (string-match "^/\\([A-Za-z0-9]:/\\)?$" dir)) - (progn - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl))) - tbl))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:ncsa-re-exe - "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") - -(or (assq 'dos:ncsa efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:ncsa-re-dir - "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +") - -(or (assq 'dos:ncsa efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:ncsa (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:ncsa - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward "[-_+=a-zA-Z0-9$.~]+ +\\(\\|[0-9]\\)" eol t) - (goto-char (match-beginning 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:ncsa - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:ncsa - (file path &optional switches wildcard) - ;; DOS may insert the entire directory name in front of the file name. - ;; Scrape it off. - (let (bonl) - (goto-char (point-min)) - (while (re-search-forward - efs-dos:ncsa-file-line-regexp - (setq bonl (save-excursion (forward-line 1) (point))) t) - (goto-char (match-beginning 0)) - (delete-region (point) (progn (beginning-of-line) (point))) - (goto-char bonl))) - ;; sort the buffer - (sort-fields 1 (point-min) (point-max))) - -(efs-defun efs-dired-ls-trim dos:ncsa () - (goto-char (point-min)) - (if (re-search-forward efs-dos:ncsa-file-line-regexp nil t) - (delete-region (point-min) (match-beginning 0)))) - -;;;;----------------------------------------------- -;;;; Microsoft DOS FTP support -;;;;----------------------------------------------- - -(defconst efs-dos:microsoft-valid-listing-regexp - (concat efs-dos:microsoft-file-line-regexp "\\.")) - -(efs-defun efs-parse-listing dos:microsoft - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - - ;; Use the existence of a "." file as confirmation that it's really - ;; a directory listing. - (goto-char (point-min)) - (efs-save-match-data - (if (or (string-match "^/.:/$" dir) - (re-search-forward efs-dos:microsoft-valid-listing-regexp nil t)) - (let ((tbl (efs-make-hashtable)) - size dir-p) - (goto-char (point-min)) - (while (re-search-forward efs-dos:microsoft-file-line-regexp nil t) - (setq size (buffer-substring (match-beginning 1) (match-end 1))) - (if (string-equal size "") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry (buffer-substring (point) - (progn (end-of-line) - (point))) - (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:microsoft-re-exe - "^[^\n]+ +[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\)$") - -(or (assq 'dos:microsoft efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:microsoft-re-dir - "^[^\n]+ ") - -(or (assq 'dos:microsoft efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:microsoft (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:microsoft - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-dos:microsoft-file-line-regexp eol t) - (goto-char (match-end 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:microsoft - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -;;;;----------------------------------------------- -;;;; Frontier's Super-TCP FTP Server for Windows -;;;;----------------------------------------------- - -(efs-defun efs-parse-listing dos:stcp - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Super-TCP FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - - ;; Use the existence of a strict file line pattern as - ;; confirmation that it's really a directory listing. - (goto-char (point-min)) - (efs-save-match-data - (let ((regexp (concat "^" efs-dos:stcp-file-line-regexp))) - (if (let ((eol (save-excursion (end-of-line) (point)))) - (re-search-forward regexp eol t)) - (let ((tbl (efs-make-hashtable)) - size dir-p) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (setq size (buffer-substring (match-beginning 2) (match-end 2))) - (if (string-equal size "") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry (buffer-substring (match-beginning 1) - (match-end 1)) - (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:stcp-re-exe - "^[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\) ") - -(or (assq 'dos:stcp efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:stcp efs-dired-dos:stcp-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:stcp-re-dir - "^[^\n ]+ + ") - -(or (assq 'dos:stcp efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:stcp efs-dired-dos:stcp-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:stcp (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:stcp - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-dos:stcp-file-line-regexp eol t) - (goto-char (match-beginning 0)) ; returns (point) - (if raise-error - (error "No file on this line") - (goto-char bol))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:stcp - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:stcp - (file path &optional switches wildcard) - ;; The Super-TCP server outputs lines in seemingly random order. - ;; This isn't as good as sorting switches, but at least it's not random. - (sort-fields 1 (point-min) (point-max))) - -;;;;---------------------------------------------------------- -;;;; Winsock DOS FTP server (Alun's FTP server) -;;;;---------------------------------------------------------- - -(efs-defun efs-parse-listing dos:winsock - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a DOS Winsock listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-dos:winsock-date-and-size-regexp nil t) - (let ((tbl (efs-make-hashtable)) - size dirp) - (while - (progn - (setq size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1))) - dirp (save-excursion - (beginning-of-line) - (skip-chars-forward " ") - (char-equal (following-char) ?d))) - (efs-put-hash-entry - (buffer-substring (point) (progn (end-of-line) (point))) - (list dirp size) tbl) - (re-search-forward efs-dos:winsock-date-and-size-regexp nil t))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(defconst efs-dired-dos:winsock-re-exe "\\.exe$") - -(or (assq 'dos:winsock efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:winsock efs-dired-dos:winsock-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:winsock-re-dir "^. +d") - -(or (assq 'dos:winsock efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:winsock efs-dired-dos:winsock-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:winsock (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:winsock - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-dos:winsock-date-and-size-regexp eol t) - (point) - (if raise-error - (error "No file on this line") - (goto-char bol))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:winsock - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:winsock - (file path &optional switches wildcard) - ;; The Winsock server outputs lines in seemingly random order. - ;; This isn't as good as sorting switches, but at least it's not random. - (sort-fields 9 (point-min) (point-max))) - -;;;;----------------------------------------------------------- -;;;; OS/2 Support -;;;;----------------------------------------------------------- - -;;; OS/2 has two types of file systems, FAT and HPFS. In the FAT file system -;;; filenames are restricted to the traditional DOS 8 + 3 syntax. In the -;;; HPFS file system, filenames can have arbitrarily many extensions (.'s). -;;; As well, file lines for "." and ".." are listed for HPFS. -;;; For the FAT FS, "." and ".." lines are only listed for sudirs, it seems. -;;; Go figure... - -(defconst efs-os2-file-line-regexp - (concat - " +\\([0-9]+\\) +\\([^ ]+\\)? +[01][0-9]-[0-3][0-9]-[0-9][0-9] +" - "[0-2][0-9]:[0-6][0-9] +")) - -(efs-defun efs-fix-path os2 (path &optional reverse) - (efs-fix-pc-path path reverse)) - -(efs-defun efs-fix-dir-path os2 (dir-path) - ;; Convert path from UNIX-ish to DOS for a DIRectory listing. - (cond ((string-match "^/\\(.:\\)?$" dir-path) - (error "Can't list DOS or OS/2 disks")) - ;; Neither DOS nor OS/2 allows us to end the name of a directory - ;; with an "\". - ;; Can't just hack it off, because if the dir is C:, we'll get the - ;; default dir. - ;; Don't apend the filename wildcard to distinguish - ;; plain files from directories, because OS/2 and DOS may - ;; not agree on what the wildcard is. Also, can't then tell - ;; the difference between plain files and empty directories. - ((string-match "/$" dir-path) - (concat (efs-fix-pc-path dir-path) ".")) - (t (efs-fix-pc-path dir-path)))) - -(defconst efs-os2-dot-line-regexp - (concat efs-os2-file-line-regexp "\\.\n")) - -(efs-defun efs-parse-listing os2 - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an OS/2 listing. - ;; To make sure that it is really a directory listing and not a bogus - ;; listing of a single file, make sure that there is an entry for ".". - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (efs-save-match-data - (if (or - (string-match "^/.:/$" dir) ; FAT proofing - (progn - (goto-char (point-min)) - (re-search-forward efs-os2-dot-line-regexp nil t))) - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - (while (looking-at efs-os2-file-line-regexp) - (end-of-line) - (efs-put-hash-entry - (buffer-substring (match-end 0) (point)) - (list (and - (match-beginning 2) - (string-equal "DIR" - (buffer-substring (match-beginning 2) - (match-end 2)))) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - tbl) - (forward-line 1)) - tbl)))) - -;;; Tree Dired - -(defconst efs-dired-os2-re-exe - "^[^\n]+\\.EXEC?$") - -(or (assq 'os2 efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'os2 efs-dired-os2-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-os2-re-dir - "^ +[0-9]+ +DIR ") - -(or (assq 'os2 efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'os2 efs-dired-os2-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename os2 - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This version is for OS/2 - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (and - (> (- eol bol) 24) - (progn - (forward-char 2) - (looking-at efs-os2-file-line-regexp))) - (goto-char (match-end 0)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename os2 - (&optional no-error bol eol) - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-insert-headerline os2 (dir) - (efs-dired-pc-insert-headerline dir)) - -;; end of efs-pc.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-plan9.el --- a/lisp/efs/efs-plan9.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-plan9.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: efs support for the Plan 9 FTP Server -;; Author: Sandy Rutherford -;; Created: Sat Jan 22 21:26:06 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 18:41:05 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Works for the plan 9 server plan9.att.com. Plan 9 is an -;;; AT&T operating system that is similar to unix. - -(provide 'efs-plan9) -(require 'efs) - -(defconst efs-plan9-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(efs-defun efs-fix-dir-path plan9 (dir-path) - ;; Convert DIR-PATH from UN*X-ish to Plan 9. Does nothing actually. - ;; Avoids appending the "." that we do in unix. - dir-path) - -(efs-defun efs-allow-child-lookup plan9 (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Relies on the fact that directories can't have extensions in plan9, - ;; I think. - (and (not (and (string-equal dir "/") (string-equal file "."))) - (progn - ;; Makes sure that this is cached, before cd'ing - (efs-expand-tilde "~" 'plan9 host user) - (efs-raw-send-cd host user - (if (string-equal file ".") - (efs-internal-file-name-nondirectory - dir) - (concat dir file)) - t)))) - -;;; end of efs-plan9.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-report.el --- a/lisp/efs/efs-report.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,215 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-report.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.9 $ -;; RCS: -;; Description: Function to report efs bugs in a usable way. -;; Author: Andy Norman, Dawn -;; Created: Tue May 18 08:34:45 1993 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-report) -(require 'efs) -(autoload 'reporter-submit-bug-report "reporter") -(defvar reporter-version) ; For the byte-compiler - -;;; Variables - -(defconst efs-report-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.9 $" 11 -2))) - -(defconst efs-report-salutations - ["Dear bug team:" - "Ciao bug team:" - "Salut bug team:" - "Gruss bug team:" - "To whom it may concern:" - "Fellow efs'ers:" - "Greetings earthlings:"]) - -(defvar efs-bug-address "efs-bugs@cuckoo.hpl.hp.com") - -(defconst efs-report-other-vars - ;; List of variables needed for efs-report, that aren't generated below. - '(efs-ftp-program-name - efs-ftp-program-args - efs-local-host-regexp - efs-ftp-local-host-regexp - efs-gateway-host - efs-gateway-type - reporter-version - features)) - -(defconst efs-report-avoid-vars - ;; List of variables we don't want to see. - '(efs-netrc-filename - efs-default-password - efs-default-account - efs-default-user)) - -;; Dynamically bound. Used to pass data to hooks. -(defvar efs-report-default-host nil) -(defvar efs-report-default-user nil) -(defvar efs-report-blurb nil) - -;;; Functions - -(defun efs-report-get-host-type-regexps () - "Return a list of host type regexp's which are non-nil." - (let ((list efs-host-type-alist) - ent result) - (while (setq ent (car list)) - (if (symbol-value (cdr ent)) - (setq result (cons (cdr ent) result))) - (setq list (cdr list))) - result)) - -(defun efs-report-get-versions () - ;; Return a list of efs versions variables. - (mapcar - 'intern - (sort - (let (completion-ignore-case) - (all-completions - "efs-" obarray - (function - (lambda (sym) - (and (boundp sym) - (let ((name (symbol-name sym))) - (and (>= (length name) 8) - (string-equal (substring name -8) "-version")))))))) - 'string-lessp))) - -(defun efs-report-get-user-vars () - ;; Return a list of efs user variables. - (mapcar - 'intern - (sort - (let (completion-ignore-case) - (all-completions "efs-" obarray 'user-variable-p)) - 'string-lessp))) - -(defun efs-report-pre-hook () - ;; efs-report-default-host, efs-report-default-user, and - ;; efs-report-blurb are dynamically bound. - (save-excursion - (let ((end (progn (mail-position-on-field "subject") (point)))) - (beginning-of-line) - (search-forward ":" end) - (delete-region (point) end) - (insert - " EFS " - (or (and (boundp 'efs-version) (string-match "/" efs-version) - (concat (substring efs-version 0 (match-beginning 0)) - " ")) - "") - "bug: "))) - (let ((host (read-string "Bug occurred for remote host: " - efs-report-default-host)) - (user (read-string "Logged in as: " - efs-report-default-user)) - buff-name) - (if (string-match "^ *$" host) (setq host nil)) - (if (string-match "^ *$" user) (setq user nil)) - (if host - (insert "\nefs believes that the host type of " host " is " - (symbol-name (efs-host-type host)) - ".\n")) - (if efs-report-blurb - (insert "\n" efs-report-blurb "\n")) - (if (and host - user - (get-buffer (setq buff-name (efs-ftp-process-buffer host user))) - (save-window-excursion - (y-or-n-p - (progn - (with-output-to-temp-buffer "*Help*" - (princ - (format - "The contents of %s -will likely very useful for identifying any bugs. - -You will be given a chance to edit out any sensitive information. -Passwords are never written into this buffer." buff-name))) - (format "Insert contents of %s? " - buff-name))))) - (let ((header-1 (concat "Contents of " buff-name ":")) - (header-2 "Please edit sensitive or irrelevant information.")) - (insert "\n" header-1 "\n" header-2 "\n") - (insert-char ?= (max (length header-1) (length header-2))) - (insert "\n\n") - (insert-buffer-substring buff-name) - (insert "\n"))))) - -(defun efs-report-post-hook () - ;; Post hook run by report-submit-bug-report. - (save-excursion - (mail-position-on-field "subject") - (let ((subj (read-string "Subject header: "))) - (if (string-equal subj "") - (subst-char-in-region - (point) - (progn - (insert - (if (or (fboundp 'yow) (load "yow" t t)) (yow) "")) - (point)) - ?\n ?\ ) - (insert subj))))) - -;;;###autoload -(defun efs-report-bug (&optional default-host default-user blurb no-confirm) - "Submit a bug report for efs." - (interactive) - (let (;; reporter-confirm-p and reporter-package-abbrev appeared once - ;; as fluid vars in reporter.el. They aren't used any longer, - ;; but we let-bind them anyway in case the user has an old version - ;; of reporter. - (reporter-confirm-p nil) - (reporter-prompt-for-summary-p nil) - (reporter-package-abbrev "efs")) - ;; Look out for old reporter versions. - (or (boundp 'reporter-version) - (setq reporter-version - "Your version of reporter is obsolete. Please upgrade.")) - (if (or no-confirm - (y-or-n-p "Do you want to submit a bug report on efs? ")) - (let ((efs-report-default-host default-host) - (efs-report-default-user default-user) - (efs-report-blurb blurb) - (vars (nconc (efs-report-get-versions) - (efs-report-get-user-vars) - efs-report-other-vars - (efs-report-get-host-type-regexps))) - (avoids efs-report-avoid-vars) - path) - (cond - ((or efs-report-default-host efs-report-default-user)) - (efs-process-host - (setq efs-report-default-host efs-process-host - efs-report-default-user efs-process-user)) - ((setq path (or buffer-file-name - (and (eq major-mode 'dired-mode) - dired-directory))) - (let ((parsed (efs-ftp-path path))) - (setq efs-report-default-host (car parsed) - efs-report-default-user (nth 1 parsed))))) - (while avoids - (setq vars (delq (car avoids) vars)) - (setq avoids (cdr avoids))) - (reporter-submit-bug-report - efs-bug-address - "efs" - vars - (function efs-report-pre-hook) - (function efs-report-post-hook) - (aref efs-report-salutations - (% (+ (% (random) 1000) 1000) - (length efs-report-salutations)))))))) - -;;; end of efs-report.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-ti-explorer.el --- a/lisp/efs/efs-ti-explorer.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,371 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ti-explorer.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Explorer support for efs -;; Author: Jamie Zawinski -;; Created: Thu Dec 17 15:04:14 1992 -;; Modified: Sun Nov 27 18:42:47 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-ti-explorer) -(require 'efs) - -(defconst efs-ti-explorer-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; Explorer support. -;;;; ------------------------------------------------------------ - -;;; efs support for TI Explorer Lisp Machines. -;;; Symbolics Lispms use a different syntax, but I think that the -;;; MIT and LMI Lispms use the same syntax as Explorers. - -(defconst efs-ti-explorer-filename-regexp - (let* ((excluded-chars ":;<>.#\n\r\ta-z") - (token (concat "[^" excluded-chars "]+")) - (token* (concat "[^" excluded-chars "]*"))) - (concat "\\(" token ": *" "\\)?" ; optional device - "\\([^ " excluded-chars "]" token* "\\)" - "\\(\\." token "\\)*; *" ; directory - "\\(" token* "." token* "\\|\\) *" ; name and extension - "# *-?\\([0-9]+\\|>\\)"))) ; version - -(efs-defun efs-quote-string ti-explorer (string &optional not-space) - ;; ## This is an EVIL hack. Backslash is not what Explorers use to - ;; quote magic characters, and in addition, it is *incorrect* to quote - ;; spaces between the directory and filename: they are not a part of - ;; the filename, they are ignored. Quoting them would make them be - ;; significant. - (if not-space - string - (concat "\"" string "\""))) - -(efs-defun efs-send-pwd ti-explorer (host user &optional xpwd) -;; TI-EXPLORER output from pwd's needs to be specially parsed because -;; the fullpath syntax contains spaces. - (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) - (line (nth 1 result)) - dir) - (if (car result) - (efs-save-match-data - (and (string-match "^257 " line) - (setq dir (substring line 4))))) - (cons dir line))) - -(efs-defun efs-fix-path ti-explorer (path &optional reverse) - ;; Convert PATH from UNIX-ish to Explorer. If REVERSE given then convert - ;; from Explorer to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match - "^\\([^:]+:\\)? *\\([^:]+:\\)? *\\([^;]*\\); *\\(.*\\)$" - path) - (let (dir file) - ;; I don't understand how "devices" work, so I'm ignoring them. - ;; (if (match-beginning 2) - ;; (setq device (substring path - ;; (match-beginning 2) - ;; (1- (match-end 2))))) - (if (match-beginning 3) - (setq dir - (substring path (match-beginning 3) (match-end 3)))) - (if (match-beginning 4) - (setq file - (substring path (match-beginning 4) (match-end 4)))) - (cond (dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - dir))) - (if (string-match "^/" dir) - (setq dir (substring dir 1)) - (setq dir (concat "/" dir))))) - (concat - ;; (and device ":") device (and device ":") - dir (and dir "/") - file)) - (error "path %s didn't match explorer syntax" path)) - (let (dir file tmp) - ;; (if (string-match "^/[^:]+:" path) - ;; (setq device (substring path 1 - ;; (1- (match-end 0))) - ;; path (substring path (match-end 0)))) - (cond ((setq tmp (file-name-directory path)) - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?/) - (vector ?.) - (vector char)))) - (substring tmp 0 -1)))) - (if (string-match "^[.]" dir) - (setq dir (substring dir 1)) - (error "explorer pathnames can't be relative") - (setq dir (concat "." dir))))) - (setq file (file-name-nondirectory path)) - (concat - ;; (and device ":") device (and device ":") - dir - (and dir ";") - file))))) - -;; (efs-fix-path-for-explorer "/PUBLIC/ZMACS/ZYMURG.LISP#1") -;; (efs-fix-path-for-explorer "PUBLIC.ZMACS;ZYMURG.LISP#1" t) - -(efs-defun efs-fix-dir-path ti-explorer (dir-path) - ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. - (cond ((string-equal dir-path "/") - (efs-fix-path 'ti-explorer "/~/" nil)) - ((string-match "^/[-A-Z0-9_$]+:/" dir-path) - (error "Don't grok Explorer \"devices\" yet.")) - ((efs-fix-path 'ti-explorer dir-path nil)))) - -(defmacro efs-parse-ti-explorer-filename () - ;; Extract the next filename from an Explorer dired-like listing. - (` (if (re-search-forward - efs-ti-explorer-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0))))) - -(efs-defun efs-parse-listing ti-explorer - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an Explorer directory - ;; listing, and return a hashtable as the result. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (while (setq file (efs-parse-ti-explorer-filename)) - ;; Explorer/Twenex listings might come out in absolute form. - (if (string-match "^[^;]*; *" file) - (setq file (substring file (match-end 0)))) - (if (string-match "\\.\\(DIRECTORY\\|directory\\)#[0-9]+$" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - (if (string-match "#[0-9]+$" file) ; deal with extension - ;; sans extension - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-really-file-p ti-explorer (file ent) - ;; Eliminates the version entries - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match "#[0-9]+$" file)))) - -(efs-defun efs-delete-file-entry ti-explorer (path &optional dir-p) - (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match "#[0-9]+$" file) - ;; Only delete entries with explicit version numbers. - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match "#[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry ti-explorer - (path dir-p size owner &optional modes nlinks mdtm) - ;; The ti-explorer version of this function needs to keep track - ;; of file versions. - (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - (if (string-match "#[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match "#[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file "#" (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-internal-file-name-as-directory ti-explorer (name) - (efs-save-match-data - (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(#[0-9>]\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -(efs-defun efs-allow-child-lookup ti-explorer (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in EXPLORER can't have an extension (other than .DIRECTORY, - ;; which we have truncated). - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-ti-explorer-re-dir - "^. *[^;\n\r]+;[^;\n\r.]+\\.\\(DIRECTORY\\|directory\\) *#" - "Regular expression to use to search for Explorer directories.") - -(or (assq 'ti-explorer efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'ti-explorer efs-dired-ti-explorer-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename ti-explorer - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the Explorer version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-ti-explorer-filename-regexp eol t) - (progn - (goto-char (match-beginning 0)) - ;; Explorer listings might come out in absolute form. - (if (looking-at "[^;]*; *") - (goto-char (match-end 0)) - (point))) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ti-explorer - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Explorer version. - (let (case-fold-search) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (looking-at efs-ti-explorer-filename-regexp) - (goto-char (match-end 0)) - (if no-error - nil - (error "No file on this line"))))) - -(efs-defun efs-dired-ls-trim ti-explorer () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward efs-ti-explorer-filename-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - -(efs-defun efs-internal-file-name-sans-versions ti-explorer - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match "#\\([0-9]+\\|>\\)$" name) - (substring name 0 (match-beginning 0)) - name))) - -;;; ### still need to ape these from vms: -;;; efs-dired-vms-clean-directory -;;; efs-dired-vms-collect-file-versions -;;; efs-dired-vms-trample-file-versions -;;; efs-dired-vms-flag-backup-files -;;; efs-dired-vms-backup-diff - -;;; end of efs-ti-explorer.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-ti-twenex.el --- a/lisp/efs/efs-ti-twenex.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,341 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ti-twenex.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Support for a TI lisp machine in Twenex emulation mode. -;; Author: Jamie Zawinski -;; Created: Thu Dec 17 15:04:14 1992 -;; Modified: Sun Nov 27 18:43:17 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-ti-twenex) -(require 'efs) - -(defconst efs-ti-twenex-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; Twenex support. -;;;; ------------------------------------------------------------ -;;; Written for an explorer in ti-twenex mode. Twenex is supposed to be just -;;; MIT's name for tops-20, but an explorer emulating twenex is not the same -;;; thing. - -(defconst efs-ti-twenex-filename-regexp - (let* ((excluded-chars ":;<>.#\n\r\ta-z") - (token (concat "[^" excluded-chars "]+")) - (token* (concat "[^" excluded-chars "]*"))) - (concat "\\(" token ": *" "\\)?" ; optional device - "<\\(" token "\\)?\\(\\." token "\\)*> *" ; directory - "\\(" token* "." token* "\\|\\) *" ; name and extension - "\\(\\. *-?\\([0-9]+\\|>\\)\\)?"))) ; version - -;;; The above isn't entirely accurate, because "/" can quote any character -;;; anywhere in a pathname. - -(efs-defun efs-fix-path ti-twenex (path &optional reverse) - ;; Convert PATH from UNIX-ish to Twenex. If REVERSE given then convert - ;; from Twenex to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match - "^\\([^:]+:\\)? *\\([^:]+:\\)? *<\\([^>]*\\)> *\\(.*\\)$" - path) - (let (dir file) - ;; I don't understand how "devices" work, so I'm ignoring them. - ;; (if (match-beginning 2) - ;; (setq device (substring path - ;; (match-beginning 2) - ;; (1- (match-end 2))))) - (if (match-beginning 3) - (setq dir - (substring path (match-beginning 3) (match-end 3)))) - (if (match-beginning 4) - (setq file - (substring path (match-beginning 4) (match-end 4)))) - (cond (dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - dir))) - (if (string-match "^/" dir) - (setq dir (substring dir 1)) - (setq dir (concat "/" dir))))) - (concat - ;; (and device ":") device (and device ":") - dir (and dir "/") - file)) - (error "path %s didn't match ti-twenex syntax" path)) - (let (dir file tmp) - ;; (if (string-match "^/[^:]+:" path) - ;; (setq device (substring path 1 - ;; (1- (match-end 0))) - ;; path (substring path (match-end 0)))) - (cond ((setq tmp (file-name-directory path)) - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?/) - (vector ?.) - (vector char)))) - (substring tmp 0 -1)))) - (if (string-match "^[.]" dir) - (setq dir (substring dir 1)) - (setq dir (concat "." dir))))) - (setq file (file-name-nondirectory path)) - (concat - ;; (and device ":") device (and device ":") - (and dir "<") - dir - (and dir ">") - file))))) - -;; (efs-fix-path-for-twenex "/PUBLIC/ZMACS/ZYMURG.LISP.1") -;; (efs-fix-path-for-twenex "ZYMURG.LISP.1" t) - -(efs-defun efs-fix-dir-path ti-twenex (dir-path) - ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. - (cond ((string-equal dir-path "/") - (efs-fix-path 'ti-twenex "/~/" nil)) - ((string-match "^/[-A-Z0-9_$]+:/" dir-path) - (error "Don't grok TWENEX \"devices\" yet.")) - ((efs-fix-path 'ti-twenex dir-path nil)))) - -(defmacro efs-parse-ti-twenex-filename () - ;; Extract the next filename from an Explorer dired-like listing. - (` (if (re-search-forward - efs-ti-twenex-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0))))) - -(efs-defun efs-parse-listing ti-twenex - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a TWENEX directory - ;; listing, and return a hashtable as the result. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (while (setq file (efs-parse-ti-twenex-filename)) - ;; Explorer/Twenex listings might come out in absolute form. - (if (string-match "^[^>]*> *" file) - (setq file (substring file (match-end 0)))) - (if (string-match "\\.\\(DIRECTORY\\|directory\\).[0-9]+$" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - (if (string-match "\\.[0-9]+$" file) ; deal with extension - ;; sans extension - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-really-file-p ti-twenex (file ent) - ;; Eliminates the version entries - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match "\\.[0-9]+$" file)))) - -(efs-defun efs-delete-file-entry ti-twenex (path &optional dir-p) - (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match "\\.[0-9]+$" file) - ;; Only delete versions with explicit version numbers. - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry ti-twenex - (path dir-p size owner &optional modes nlinks mdtm) - ;; The ti-twenex version of this function needs to keep track - ;; of ti-twenex's file versions. - (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file "." (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-internal-file-name-as-directory ti-twenex (name) - (efs-save-match-data - (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(\\.[0-9>]\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -(efs-defun efs-allow-child-lookup ti-twenex (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in TI-TWENEX can't have an extension (other than .DIRECTORY, - ;; which we have truncated). - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-ti-twenex-re-dir - "^. *[^>\n\r]+>[^>\n\r.]+\\.\\(DIRECTORY\\|directory\\)\\b" - "Regular expression to use to search for TWENEX directories.") - -(or (assq 'ti-twenex efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'ti-twenex efs-dired-ti-twenex-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename ti-twenex - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the Twenex version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-ti-twenex-filename-regexp eol t) - (progn - (goto-char (match-beginning 0)) - ;; Twenex listings might come out in absolute form. - (if (looking-at "[^>]*> *") - (goto-char (match-end 0)) - (point))) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ti-twenex - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Explorer version. - (let (case-fold-search) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (looking-at efs-ti-twenex-filename-regexp) - (goto-char (match-end 0)) - (if no-error - nil - (error "No file on this line"))))) - -(efs-defun efs-internal-file-name-sans-versions ti-twenex - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -;;; ### still need to ape these from vms: -;;; efs-dired-vms-clean-directory -;;; efs-dired-vms-collect-file-versions -;;; efs-dired-vms-trample-file-versions -;;; efs-dired-vms-flag-backup-files -;;; efs-dired-vms-backup-diff - -;;; end of efs-ti-twenex.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-tops-20.el --- a/lisp/efs/efs-tops-20.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,353 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-tops-20.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: TOPS-20 support for efs -;; Author: Sandy Rutherford -;; Created: Fri Oct 23 08:52:00 1992 -;; Modified: Sun Nov 27 18:43:45 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(require 'efs) -(provide 'efs-tops-20) - -(defconst efs-tops-20-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; TOPS-20 support -;;;; ------------------------------------------------------------ - -(efs-defun efs-send-pwd tops-20 (host user &optional xpwd) - ;; pwd doesn't work for tops-20. Need to get the cwd from a dir listing - ;; this function returns the cwd in tops-20 syntax - (let* ((temp (efs-make-tmp-name host nil)) - (cmd (concat "dir * " (cdr temp))) - dir u-dir full-dir result) - (unwind-protect - (if (null (and (car (setq result (efs-raw-send-cmd - (efs-get-process host user) - cmd - "Getting TOPS-20 PWD"))) - (progn - (condition-case () - (delete-file (car temp)) (error nil)) - (car (setq result - (efs-raw-send-cmd - (efs-get-process host user) - cmd - "Trying to get TOPS-20 PWD, again.")))))) - (save-excursion - (set-buffer (get-buffer-create - efs-data-buffer-name)) - (erase-buffer) - (if (or (file-readable-p (car temp)) - (sleep-for efs-retry-time) - (file-readable-p (car temp))) - ;; Try again. - (insert-file-contents (car temp)) - (efs-error host user - (format - "list data file %s not readable" (car temp)))) - ;; get the cwd - (goto-char (point-min)) - (efs-save-match-data - (if (looking-at "[^ /:]+:<[^<>/ ]+>") - (progn - (setq dir (buffer-substring (match-beginning 0) - (match-end 0)) - u-dir (efs-internal-directory-file-name - (efs-fix-path 'tops-20 dir t)) - full-dir (format efs-path-format-string - user host u-dir)) - ;; cache the files too - (efs-set-files full-dir - (efs-parse-listing - 'tops-20 host user u-dir full-dir)) - (efs-add-to-ls-cache full-dir nil (buffer-string) t)))))) - (efs-del-tmp-name (car temp))) - (cons dir (nth 1 result)))) - -(efs-defun efs-fix-path tops-20 (path &optional reverse) - ;; Convert PATH from UNIX-ish to tops-20. If REVERSE given, then - ;; do just that. - (efs-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?<\\([^>.][^>]*\\)>.*$" path) - (let ((device (and (match-beginning 1) - (substring path (match-beginning 1) - (match-end 1)))) - (dir (substring path (match-beginning 2) - (match-end 2))) - (file (substring path (1+ (match-end 2))))) - (while (string-match "\\." dir) - (setq dir (concat (substring dir 0 (match-beginning 0)) - "/" - (substring dir (match-end 0))))) - (if device - (setq dir (concat "/" device "/" dir))) - (concat dir file)) - (error "path %s didn't match tops-20 syntax" path)) - (if (string-match "^\\(/[^:/]+:/\\)?\\([^./]+/\\)*\\([^/]*\\)$" path) - (let ((device (and (match-beginning 1) - (substring path 1 (1- (match-end 1))))) - (dir (and (match-beginning 2) - (substring path (match-beginning 2) - (1- (match-end 2))))) - (file (substring path (match-beginning 3) - (match-end 3)))) - (if dir - (progn - (while (string-match "/" dir) - (setq dir (concat (substring dir 0 (match-beginning 0)) - "." - (substring dir (match-end 0))))) - (if device - (concat device "<" dir ">" file) - (concat "<" dir ">" file))) - (if device - (error "%s is invalid relative syntax for tops-20" path) - file))) - (error "path %s is invalid syntax for tops-20" path))))) - -(efs-defun efs-fix-dir-path tops-20 (dir-path) - ;; Convert a path from UNIX-ish to Tops-20 fir a dir listing. - (cond ((string-equal "/" dir-path) - (error "Can't list tops-20 devices")) - ((string-match "/[^:/]+:/$" dir-path) - (error "Can't list all root directories on a tops-20 device")) - ((efs-fix-path 'tops-20 dir-path nil)))) - - -;; In tops-20 listings, the filename starts immediatley after the date regexp. - -(defconst efs-tops-20-date-regexp - (concat - " [1-3]?[0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\)-[0-9][0-9] [0-9][0-9]:[0-9][0-9]:[0-9][0-9] ")) - - -(efs-defun efs-parse-listing tops-20 - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a TOPS-20 directory - ;; listing, and return a hashtable as the result. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (if (looking-at " *[^/:]+:<\\([^/.<>]+\\.\\)+> *$") - ;; looking at the directory name - (forward-line 1)) - (while (re-search-forward efs-tops-20-date-regexp nil t) - (setq file (buffer-substring (point) - (progn (end-of-line) (point)))) - (if (string-match "\\.DIRECTORY\\.[0-9]+$" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - ;; sans extension - (if (string-match "\\.[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-really-file-p tops-20 (file ent) - ;; Eliminates the version entries - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match "\\.[0-9]+$" file)))) - -(efs-defun efs-delete-file-entry tops-20 (path &optional dir-p) - (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match "\\.[0-9]+$" file) - ;; Only delete explicit versions - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry tops-20 - (path dir-p size owner &optional modes nlinks mdtm) - ;; The tops-20 version of this function needs to keep track - ;; of tops-20's file versions. - (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file "." (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-internal-file-name-as-directory tops-20 (name) - (efs-save-match-data - (if (string-match "\\.DIRECTORY\\(\\.[0-9>]\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -;;; Tree Dired - -(defconst efs-dired-tops-20-re-dir - "^[^\n]+\\.DIRECTORY\\(\\.[0-9]+\\)?$") - -(or (assq 'tops-20 efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'tops-20 efs-dired-tops-20-re-dir) - efs-dired-re-dir-alist))) - - -(efs-defun efs-dired-manual-move-to-filename tops-20 - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the Tops-20 version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-tops-20-date-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename tops-20 - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Tops-20 version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - ;; Is this the right character set? - (skip-chars-forward "-_A-Z0-9$.;") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-internal--file-name-sans-versions tops-20 - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -(efs-defun efs-dired-insert-headerline tops-20 (dir) - ;; TOPS-20 inserts a headerline. I would prefer the headerline - ;; to be in efs format. This version tries to - ;; be careful, because we can't count on a headerline - ;; over ftp, and we wouldn't want to delete anything - ;; important. - (save-excursion - (if (looking-at "^ wildcard ") - (forward-line 1)) - (if (looking-at "^[ \n\t]*[^:/<>]+:<[^<>/]+> *\n") - (delete-region (point) (match-end 0))) - (insert " " (directory-file-name dir) ":\n\n"))) - -;;; end of efs-tops-20.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-vm.el --- a/lisp/efs/efs-vm.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,342 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-vm.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Allows the VM mail reader to access folders using efs. -;; If you are looking for support for VM/CMS, see efs-cms.el. -;; Author: Sandy Rutherford -;; Created: Mon Nov 9 23:49:18 1992 by sandy on riemann -;; Modified: Sun Nov 27 18:44:07 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; If vm-get-new-mail (usually bound to "g") is given a prefix, it -;; will prompt for a folder from which to collect mail. With -;; efs-vm, this folder can be in efs syntax. As is usual -;; with VM, this folder will not be deleted. If at the folder prompt, -;; you give "/user@host:", efs-vm will collect mail from the -;; spool file on the remote machine. The spool file will be deleted if -;; the mail is successfully collected. It is not necessary for -;; movemail, nor even emacs, to be installed on the remote machine. -;; The functionality of movemail is mimicked with FTP commands. Both -;; local and remote crashboxes are used, so that mail will not be lost -;; if the FTP connection is lost. -;; -;; To use efs-vm, put (require 'efs-vm) in your .vm file. -;; -;; Works for vm 5.56 through 5.72. May not work with older versions. -;; If vm grows some file-name-handler-alist support, we should use it. -;; Actually it has. I just haven't gotten around to this yet. - -;;; Known Bugs: -;; -;; 1. efs-vm will not be able to collect mail from a spool file if -;; you do not have write permission in the spool directory. -;; I think that this precludes HP-UX. -;; I hope to do something about this. -;; -;; 2. efs-vm is as clever as at can be about spool file locking. -;; i.e. not very clever at all. At least it uses a rename command -;; to minimize the window for problems. Use POP if you want to -;; be careful. -;; - -;;; Provisions, requirements, and autoloads - -(provide 'efs-vm) -(require 'efs-cu) -(require 'efs-ovwrt) -(require 'vm) -;(require 'vm-folder) ; not provided -(if (or (not (fboundp 'vm-get-new-mail)) - (eq (car-safe (symbol-function 'vm-get-new-mail)) 'autoload)) - (load-library "vm-folder")) -(autoload 'efs-make-tmp-name "efs") -(autoload 'efs-del-tmp-name "efs") -(autoload 'efs-send-cmd "efs") -(autoload 'efs-re-read-dir "efs") -(autoload 'efs-copy-file-internal "efs") - -;;; User variables - -(defvar efs-vm-spool-files nil - "Association list of \( USER@MACHINE . SPOOLFILES \) pairs that -specify the location of the default remote spool file for MACHINE. SPOOLFILES -is a list of remote spool files.") - -(defvar efs-vm-crash-box "~/EFS.INBOX.CRASH" - "Local file where efs keeps its local crash boxes.") - -;;; Internal variables - -(defconst efs-vm-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - - -(defun efs-vm-get-new-mail (&optional arg) - "Documented as original" - (interactive "P") - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-virtual-folder) - (vm-error-if-folder-read-only) - (cond - ((null arg) - (if (not (eq major-mode 'vm-mode)) - (vm-mode)) - (if (consp (car (vm-spool-files))) - (message "Checking for new mail for %s..." buffer-file-name) - (message "Checking for new mail...")) - (let (new-messages totals-blurb) - (if (and (vm-get-spooled-mail) - (setq new-messages (vm-assimilate-new-messages t))) - (progn - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb)) - (if (consp (car (vm-spool-files))) - (message "No new mail for %s" buffer-file-name) - (message "No new mail.")) - (sit-for 4) - (message "")))) - (t - (let* ((buffer-read-only nil) - (folder (read-file-name "Gather mail from folder: " - vm-folder-directory t)) - (parsed (efs-ftp-path folder)) - mcount new-messages totals-blurb) - (if parsed - (if (string-equal (nth 2 parsed) "") - ;; a spool file - (if (not (and (efs-vm-get-remote-spooled-mail folder) - (setq new-messages - (vm-assimilate-new-messages t)))) - (progn - (message - "No new mail, or mail couldn't be retrieved by ftp.") - ;; don't let this message stay up forever... - (sit-for 4) - (message "")) - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb)) - - ;; a remote folder - (let ((tmp-file (car (efs-make-tmp-name nil (car parsed)))) - (folder (expand-file-name folder))) - (unwind-protect - (progn - (efs-copy-file-internal - folder parsed tmp-file nil t nil - (format "Getting %s" folder) - ;; asynch worries me here - nil nil) - (if (and vm-check-folder-types - (not (vm-compatible-folder-p tmp-file))) - (error - "Folder %s is not the same format as this folder." - folder)) - (save-excursion - (vm-save-restriction - (widen) - (goto-char (point-max)) - (insert-file-contents tmp-file))) - (setq mcount (length vm-message-list)) - (if (setq new-messages (vm-assimilate-new-messages)) - (progn - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) - '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb) - ;; The gathered messages are actually still on disk - ;; unless the user deletes the folder himself. - ;; However, users may not understand what happened if - ;; the messages go away after a "quit, no save". - (setq vm-messages-not-on-disk - (+ vm-messages-not-on-disk - (- (length vm-message-list) - mcount)))) - (message "No messages gathered.")) - (efs-del-tmp-name tmp-file))))) - - ;; local - - (if (and vm-check-folder-types - (not (vm-compatible-folder-p folder))) - (error "Folder %s is not the same format as this folder." - folder)) - (save-excursion - (vm-save-restriction - (widen) - (goto-char (point-max)) - (insert-file-contents folder))) - (setq mcount (length vm-message-list)) - (if (setq new-messages (vm-assimilate-new-messages)) - (progn - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb) - ;; The gathered messages are actually still on disk - ;; unless the user deletes the folder himself. - ;; However, users may not understand what happened if - ;; the messages go away after a "quit, no save". - (setq vm-messages-not-on-disk - (+ vm-messages-not-on-disk - (- (length vm-message-list) - mcount)))) - (message "No messages gathered."))))))) - -(defun efs-vm-gobble-remote-crash-box (remote-crash-box) - (let ((remote-crash-box (expand-file-name remote-crash-box)) - (crash-box (expand-file-name efs-vm-crash-box)) - lsize) - (if (file-exists-p vm-crash-box) - (progn - ;; This should never happen, but let's make sure that we never - ;; clobber mail. - (message "Recovering messages from local crash box...") - (vm-gobble-crash-box efs-vm-crash-box) - (message "Recovering messages from local crash box... done"))) - (efs-copy-file-internal remote-crash-box (efs-ftp-path remote-crash-box) - crash-box nil nil nil - (format "Getting %s" remote-crash-box) - ;; asynch worries me here - nil nil) - ;; only delete the remote crash box if we are sure that we have everything - (if (and (setq lsize (nth 7 (file-attributes crash-box))) - (eq lsize (nth 7 (file-attributes remote-crash-box))) - (vm-compatible-folder-p crash-box)) - (progn - (vm-gobble-crash-box crash-box) - (delete-file remote-crash-box)) - ;; don't leave garbage in the local crash box - (condition-case () (delete-file crash-box) (error nil)) - (error "Problem reading remote crash box %s" remote-crash-box)))) - -(defun efs-vm-get-remote-spooled-mail (remote-path) - ;; remote-path is usually of the form /user@machine: - ;; Usually vm sets inhibit-quit to t for this. This is probably - ;; a bad idea if there is ftp activity. - ;; I don't want to assume that the remote machine has movemail. - ;; Try to mimic movemail with ftp commands as best as possible. - ;; For this to work, we need to be able to create a subdirectory - ;; in the spool directory. - (if vm-block-new-mail - (error "Can't get new mail until you save this folder.")) - (let* ((parsed (efs-ftp-path remote-path)) - (host (car parsed)) - (user (nth 1 parsed)) - (spool-files - (or (cdr (assoc (concat user "@" host) - efs-vm-spool-files)) - (list (concat "/usr/spool/mail/" user)))) - got-mail) - (while spool-files - (let* ((s-file (car spool-files)) - (spool-file (format efs-path-format-string user host s-file)) - ;; rmdir and mkdir bomb if this path ends in a /. - (c-dir (concat s-file ".CRASHBOX")) - (rc-file (concat c-dir "/CRASHBOX")) - (crash-dir (concat spool-file ".CRASHBOX/")) - (remote-crash-file (concat crash-dir "CRASHBOX")) - (crash-box (expand-file-name efs-vm-crash-box))) - (if (file-exists-p crash-box) - (progn - (message "Recovering messages from crash box...") - (vm-gobble-crash-box crash-box) - (message "Recovering messages from crash box... done") - (setq got-mail t))) - (if (let ((efs-allow-child-lookup nil)) - (file-exists-p remote-crash-file)) - (progn - (message "Recovering messages from remote crash box...") - (efs-vm-gobble-remote-crash-box remote-crash-file) - (message "Recovering messages from remote crash box... done") - (setq got-mail t))) - (if (file-exists-p crash-box) - (progn - (message "Recovering messages from crash box...") - (vm-gobble-crash-box crash-box) - (message "Recovering messages from crash box... done") - (setq got-mail t))) - (unwind-protect - (if (car - (efs-send-cmd - host user (list 'mkdir c-dir) - (format "Making crash directory %s" crash-dir))) - (progn - (efs-re-read-dir crash-dir) - (message "Unable to make crash directory %s" crash-dir) - (ding)) - (or (car - (efs-send-cmd host user (list 'rename s-file rc-file) - (format "Checking spool file %s" spool-file))) - (progn - (message "Getting new mail from %s..." spool-file) - ;; The rename above wouldn't have updated the cash. - (efs-re-read-dir crash-dir) - (efs-vm-gobble-remote-crash-box remote-crash-file) - (message "Getting new mail from %s... done" spool-file) - (setq got-mail t)))) - (condition-case nil - (efs-send-cmd - host user (list 'rmdir c-dir) - "Removing crash directory") - (error nil)))) - (setq spool-files (cdr spool-files))) - got-mail)) - -;;; Overwrite existing functions - -(efs-overwrite-fn "efs" 'vm-get-new-mail) - -;;; end of efs-vm.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-vms.el --- a/lisp/efs/efs-vms.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,760 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-vms.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.13 $ -;; RCS: -;; Description: VMS support for efs -;; Authors: Andy Norman, Joe Wells, Sandy Rutherford -;; Modified: Sun Nov 27 18:44:59 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-vms) -(require 'efs) - -(defconst efs-vms-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.13 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; VMS support. -;;;; ------------------------------------------------------------ - -;;; efs has full support for VMS hosts, including tree dired support. It -;;; should be able to automatically recognize any VMS machine. However, if it -;;; fails to do this, you can use the command efs-add-vms-host. As well, -;;; you can set the variable efs-vms-host-regexp in your .emacs file. We -;;; would be grateful if you would report any failures to automatically -;;; recognize a VMS host as a bug. -;;; -;;; Filename Syntax: -;;; -;;; For ease of *implementation*, the user enters the VMS filename syntax in a -;;; UNIX-y way. For example: -;;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 -;;; would be entered as: -;;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 -;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file: -;;; [.CSV.POLICY]RULES.MEM -;;; you would type: -;;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM -;;; -;;; A legal VMS filename is of the form: FILE.TYPE;## -;;; where FILE can be up to 39 characters -;;; TYPE can be up to 39 characters -;;; ## is a version number (an integer between 1 and 32,767) -;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $ -;;; $ cannot begin a filename, and - cannot be used as the first or last -;;; character. -;;; -;;; Tips: -;;; 1. To access the latest version of file under VMS, you use the filename -;;; without the ";" and version number. You should always edit the latest -;;; version of a file. If you want to edit an earlier version, copy it to a -;;; new file first. This has nothing to do with efs, but is simply -;;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is -;;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you -;;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find -;;; that VMS will not allow you to save the file because it will refuse to -;;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and -;;; attach the buffer to this file. To get out of this situation, M-x -;;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to -;;; latest version of the file. For this reason, in tree dired "f" -;;; (dired-find-file), always loads the file sans version, whereas "v", -;;; (dired-view-file), always loads the explicit version number. The -;;; reasoning being that it reasonable to view old versions of a file, but -;;; not to edit them. -;;; 2. EMACS has a feature in which it does environment variable substitution -;;; in filenames. Therefore, to enter a $ in a filename, you must quote it -;;; by typing $$. There is a bug in EMACS, in that it neglects to quote the -;;; $'s in the default directory when it writes it in the minibuffer. You -;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug -;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26 -;;; or newer), you will not have this problem. - - -;; Because some VMS ftp servers convert filenames to lower case -;; we allow a-z in the filename regexp. - -(defconst efs-vms-filename-regexp - "\\([_A-Za-z0-9$][-_A-Za-z0-9$]*\\)?\\.\\([-_A-Za-z0-9$]*\\);[0-9]+") -;; Regular expression to match for a valid VMS file name in Dired buffer. - -(defvar efs-vms-month-alist - '(("JAN" . 1) ("FEB". 2) ("MAR" . 3) ("APR" . 4) ("MAY" . 5) ("JUN" . 6) - ("JUL" . 7) ("AUG" . 8) ("SEP" . 9) ("OCT" . 10) - ("NOV" . 11) ("DEC" . 12))) - -(defvar efs-vms-date-regexp - (concat - "\\([0-3]?[0-9]\\)-" - "\\(JAN\\|FEB\\|MAR\\|APR\\|MAY\\|JUN\\|" - "JUL\\|AUG\\|SEP\\|OCT\\|NOV\\|DEC\\)-" - "\\([0-9][0-9][0-9]?[0-9]?\\) \\(\\([0-5][0-9]\\):\\([0-5][0-9]\\)" - "\\(:[0-5][0-9]\\)?\\)? ")) - - -;;; The following two functions are entry points to this file. -;;; They are defined as efs-autoloads in efs.el - -(efs-defun efs-fix-path vms (path &optional reverse) - ;; Convert PATH from UNIX-ish to VMS. - ;; If REVERSE given then convert from VMS to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match - "^\\([^:]+:\\)?\\(\\[[^]]+\\]\\)?\\([^][]*\\)$" path) - (let (drive dir file) - (if (match-beginning 1) - (setq drive (substring path - (match-beginning 1) - (match-end 1)))) - (if (match-beginning 2) - (setq dir - (substring path (match-beginning 2) (match-end 2)))) - (if (match-beginning 3) - (setq file - (substring path (match-beginning 3) (match-end 3)))) - (and dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - (substring dir 1 -1))))) - (concat (and drive - (concat "/" drive "/")) - dir (and dir "/") - file)) - (error "path %s didn't match" path)) - (let (drive dir file) - (if (string-match "^/[^:/]+:/" path) - (setq drive (substring path 1 (1- (match-end 0))) - path (substring path (1- (match-end 0))))) - (setq dir (file-name-directory path) - file (efs-internal-file-name-nondirectory path)) - (if dir - (let ((len (1- (length dir))) - (n 0)) - (if (<= len 0) - (setq dir nil) - (while (<= n len) - (and (char-equal (aref dir n) ?/) - (cond - ((zerop n) (aset dir n ?\[)) - ((= n len) (aset dir n ?\])) - (t (aset dir n ?.)))) - (setq n (1+ n)))))) - (concat drive dir file))))) - -;; It is important that this function barf for directories for which we know -;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/". -;; This is because it saves an unnecessary FTP error, or possibly the listing -;; might succeed, but give erroneous info. This last case is particularly -;; likely for OS's (like MTS) for which we need to use a wildcard in order -;; to list a directory. - -(efs-defun efs-fix-dir-path vms (dir-path) - ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. - ;; Should there be entries for .. -> [-] and . -> [] below. Don't - ;; think so, because expand-filename should have already short-circuited - ;; them. - (cond ((string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.")) - ((string-match "^/[-A-Z0-9_$]+:/$" dir-path) - (error "Cannot get listing for device.")) - ((efs-fix-path 'vms dir-path)))) - -;; These parsing functions are as general as possible because the syntax -;; of ftp listings from VMS hosts is a bit erratic. What saves us is that -;; the VMS filename syntax is so rigid. If they bomb on a listing in the -;; standard VMS Multinet format, then this is a bug. If they bomb on a listing -;; from vms.weird.net, then too bad. - -(defmacro efs-parse-vms-filename () - "Extract the next filename from a VMS dired-like listing." - (` (if (re-search-forward - efs-vms-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0))))) - -(defun efs-parse-vms-listing () - ;; Parse the current buffer which is assumed to be a VMS DIR - ;; listing (either a short (NLIST) or long listing). - ;; Assumes that point is at the beginning of the buffer. - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (while (setq file (efs-parse-vms-filename)) - (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - (if (string-match ";[0-9]+$" file) ; deal with extension - ;; sans extension - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - ;; Would like to look for a "Total" line, or a "Directory" line to - ;; make sure that the listing isn't complete garbage before putting - ;; in "." and "..", but we can't even count on all VAX's giving us - ;; either of these. - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-parse-listing vms - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a VMS FTP dir - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - ;; check for a DIR/FULL monstrosity - (if (search-forward "\nSize:" nil t) - (progn - (efs-add-listing-type 'vms:full host user) - ;; This will cause the buffer to be refilled with an NLIST - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (goto-char (point-min)) - (efs-parse-vms-listing)) - (efs-parse-vms-listing)))) - - -;;;; Sorting of listings - -(efs-defun efs-t-converter vms (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-vms-filename-regexp nil t) - (let (list-start start end list) - (beginning-of-line) - (setq list-start (point)) - (while (and (looking-at efs-vms-filename-regexp) - (progn - (setq start (point)) - (goto-char (match-end 0)) - (forward-line (if (eolp) 2 1)) - (setq end (point)) - (goto-char (match-end 0)) - (re-search-forward efs-vms-date-regexp nil t))) - (setq list - (cons - (cons - (nconc - (list (string-to-int (buffer-substring - (match-beginning 3) - (match-end 3))) ; year - (cdr (assoc - (buffer-substring (match-beginning 2) - (match-end 2)) - efs-vms-month-alist)) ; month - (string-to-int (buffer-substring - (match-beginning 1) - (match-end 1)))) ;day - (if (match-beginning 4) - (list - (string-to-int (buffer-substring - (match-beginning 5) - (match-end 5))) ; hour - (string-to-int (buffer-substring - (match-beginning 6) - (match-end 6))) ; minute - (if (match-beginning 7) - (string-to-int (buffer-substring - (1+ (match-beginning 7)) - (match-end 7))) ; seconds - 0)) - (list 0 0 0))) - (buffer-substring start end)) - list)) - (goto-char end)) - (if list - (progn - (setq list - (mapcar 'cdr - (sort list 'efs-vms-t-converter-sort-pred))) - (if reverse (setq list (nreverse list))) - (delete-region list-start (point)) - (apply 'insert list))) - t))))) - -(defun efs-vms-t-converter-sort-pred (elt1 elt2) - (let* ((data1 (car elt1)) - (data2 (car elt2)) - (year1 (car data1)) - (year2 (car data2)) - (month1 (nth 1 data1)) - (month2 (nth 1 data2)) - (day1 (nth 2 data1)) - (day2 (nth 2 data2)) - (hour1 (nth 3 data1)) - (hour2 (nth 3 data2)) - (minute1 (nth 4 data1)) - (minute2 (nth 4 data2))) - (or (> year1 year2) - (and (= year1 year2) - (or (> month1 month2) - (and (= month1 month2) - (or (> day1 day2) - (and (= day1 day2) - (or (> hour1 hour2) - (and (= hour1 hour2) - (or (> minute1 minute2) - (and (= minute1 minute2) - (or (> (nth 5 data1) - (nth 5 data2))) - )))))))))))) - - -(efs-defun efs-X-converter vms (&optional regexp reverse) - ;; Sorts by extension - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-vms-filename-regexp nil t) - (let (list-start start list) - (beginning-of-line) - (setq list-start (point)) - (while (looking-at efs-vms-filename-regexp) - (setq start (point)) - (goto-char (match-end 0)) - (forward-line (if (eolp) 2 1)) - (setq list - (cons - (cons (buffer-substring (match-beginning 2) - (match-end 2)) - (buffer-substring start (point))) - list))) - (setq list - (mapcar 'cdr - (sort list - (if reverse - (function - (lambda (x y) - (string< (car y) (car x)))) - (function - (lambda (x y) - (string< (car x) (car y)))))))) - (delete-region list-start (point)) - (apply 'insert list) - t))))) - -;; This version only deletes file entries which have -;; explicit version numbers, because that is all VMS allows. - -(efs-defun efs-delete-file-entry vms (path &optional dir-p) - (let ((ignore-case (memq 'vms efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match ";[0-9]+$" file) - ;; In VMS you can't delete a file without an explicit - ;; version number, or wild-card (e.g. FOO;*) - ;; For now, we give up on wildcards. - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match ";[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry vms (path dir-p size owner - &optional modes nlinks mdtm) - ;; The vms version of this function needs to keep track - ;; of vms's file versions. - (let ((ignore-case (memq 'vms efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - ;; In VMS files must have an extension. If there isn't - ;; one, it will be added. - (or (string-match "^[^;]*\\." file) - (if (string-match ";" file) - (setq file (concat - (substring file 0 (match-beginning 0)) - ".;" - (substring file (match-end 0)))) - (setq file (concat file ".")))) - (if (string-match ";[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match ";[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file ";" (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-really-file-p vms (file ent) - ;; Returns whether the hash entry FILE with entry ENT is a real file. - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match ";" file)))) - -(efs-defun efs-internal-file-name-as-directory vms (name) - (efs-save-match-data - (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -(efs-defun efs-remote-directory-file-name vms (dir) - ;; Returns the VMS filename in unix directory syntax for directory DIR. - ;; This is something like /FM/SANDY/FOOBAR.DIR;1 - (efs-save-match-data - (setq dir (directory-file-name dir)) - (concat dir - (if (string-match "[a-z]" (nth 2 (efs-ftp-path dir))) - ".dir;1" - ".DIR;1")))) - -(efs-defun efs-allow-child-lookup vms (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in VMS can't have an extension (other than .DIR, which we - ;; have truncated). - (not (or (string-match "\\." file) - (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file file))))) - -;;; Tree dired support: - -;; For this code I have borrowed liberally from Sebastian Kremer's -;; dired-vms.el - - -;; These regexps must be anchored to beginning of line. -;; Beware that the ftpd may put the device in front of the filename. - -(defconst efs-dired-vms-re-exe - "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]") - -(or (assq 'vms efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'vms efs-dired-vms-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-vms-re-dir - "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]") - -(or (assq 'vms efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'vms efs-dired-vms-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline vms (dir) - ;; VMS inserts a headerline. I would prefer the headerline - ;; to be in efs format. This version tries to - ;; be careful, because we can't count on a headerline - ;; over ftp, and we wouldn't want to delete anything - ;; important. - (save-excursion - (if (looking-at "^ \\(list \\)?wildcard ") - (forward-line 1)) - ;; This is really aggressive. Too aggressive? - (let ((start (point))) - (skip-chars-forward " \t\n") - (if (looking-at efs-vms-filename-regexp) - (beginning-of-line) - (forward-line 1) - (skip-chars-forward " \t\n") - (beginning-of-line)) - (delete-region start (point))) - (insert " \n")) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-fixup-listing vms (file path &optional switches wildcard) - ;; Some vms machines list the entire path. Scrape this off. - (setq path (efs-fix-path - 'vms - ;; Need the file-name-directory, in case of widcards. - ;; Note that path is a `local' path rel. the remote host. - ;; Lose on wildcards in parent dirs. Fix if somebody complains. - (let (file-name-handler-alist) - (file-name-directory path)))) - ;; Some machines put a Node name down too. - (let ((regexp (concat "^\\([_A-Za-z0-9][-_A-Za-z0-9]*\\$\\)?" - (regexp-quote path)))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (delete-region (match-beginning 0) (match-end 0)))) - ;; Now need to deal with continuation lines. - (goto-char (point-min)) - (let (col start end) - (while (re-search-forward - ";[0-9]+[ \t]*\\(\n[ \t]+\\)[^; \t\n]+[^\n;]*\n" nil t) - (setq start (match-beginning 1) - end (match-end 1)) - ;; guess at the column dimensions - (or col - (save-excursion - (goto-char (point-min)) - (if (re-search-forward - (concat efs-vms-filename-regexp - "[ \t]+[^ \t\n\r]") nil t) - (setq col (- (goto-char (match-end 0)) - (progn (beginning-of-line) (point)) - 1)) - (setq col 0)))) - ;; join cont. lines. - (delete-region start end) - (goto-char start) - (insert-char ? (max (- col (current-column)) 2)))) - ;; Some vms dir listings put a triple null line before the total line. - (goto-char (point-min)) - (skip-chars-forward "\n") - (if (search-forward "\n\n\n" nil t) - (delete-char -1))) - -(efs-defun efs-dired-manual-move-to-filename vms - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the VMS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-vms-filename-regexp eol t) - (goto-char (match-beginning 0)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename vms - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the VMS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_A-Za-z0-9$.;") - (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?\t ?\n ?\r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-ls-trim vms () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward efs-vms-filename-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - -(efs-defun efs-internal-file-name-sans-versions vms - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match ";[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -(efs-defun efs-dired-collect-file-versions vms () - ;; If it looks like file FN has versions, return a list of the versions. - ;; That is a list of strings which are file names. - ;; The caller may want to flag some of these files for deletion. - (let ((completion-ignore-case (memq 'vms efs-case-insensitive-host-types)) - result) - (dired-map-dired-file-lines - (function - (lambda (fn) - (if (string-match ";[0-9]+$" fn) - (let* ((base-fn (substring fn 0 (match-beginning 0))) - (base-version (file-name-nondirectory - (substring fn 0 (1+ (match-beginning 0))))) - (bv-length (length base-version)) - (possibilities (and - (null (assoc base-fn result)) - (file-name-all-completions - base-version - (file-name-directory fn))))) - (if possibilities - (setq result - (cons (cons base-fn - ;; code this explicitly - ;; using backup-extract-version has a - ;; lot of function-call overhead. - (mapcar (function - (lambda (fn) - (string-to-int - (substring fn bv-length)))) - possibilities)) result)))))))) - result)) - -(efs-defun efs-dired-flag-backup-files vms (&optional unflag-p) - (interactive "P") - (let ((dired-kept-versions 1) - (kept-old-versions 0) - marker msg) - (if unflag-p - (setq marker ?\040 msg "Unflagging old versions") - (setq marker dired-del-marker msg "Purging old versions")) - (dired-clean-directory 1 marker msg))) - -(efs-defun efs-internal-diff-latest-backup-file vms (fn) - ;; For FILE;#, returns the filename FILE;N, where N - ;; is the largest number less than #, for which this file exists. - ;; Returns nil if none found. - (efs-save-match-data - (and (string-match ";[0-9]+$" fn) - (let ((base (substring fn 0 (1+ (match-beginning 0)))) - (num (1- (string-to-int (substring fn - (1+ (match-beginning 0)))))) - found file) - (while (and (setq found (> num 0)) - (not (file-exists-p - (setq file - (concat base (int-to-string num)))))) - (setq num (1- num))) - (and found file))))) - -;;;;-------------------------------------------------------------- -;;;; Support for VMS DIR/FULL listings. (listing type vms:full) -;;;;-------------------------------------------------------------- - -(efs-defun efs-parse-listing vms:full - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a VMS FTP dir - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - (efs-parse-vms-listing))) - -;;; Tree Dired - -(or (assq 'vms:full efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'vms:full efs-dired-vms-re-exe) - efs-dired-re-exe-alist))) - -(or (assq 'vms:full efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'vms:full efs-dired-vms-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline vms:full (dir) - ;; Insert a blank line for aesthetics. - (insert " \n") - (forward-char -2) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename vms:full - (&optional raise-error bol eol) - (let ((efs-dired-listing-type 'vms)) - (efs-dired-manual-move-to-filename raise-error bol eol))) - -(efs-defun efs-dired-manual-move-to-end-of-filename vms:full - (&optional no-error bol eol) - (let ((efs-dired-listing-type 'vms)) - (efs-dired-manual-move-to-end-of-filename no-error bol eol))) - -;;; end of efs-vms.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-vos.el --- a/lisp/efs/efs-vos.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,285 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-vos.el -;; Description: VOS support for efs -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Author: Sandy Rutherford -;; Created: Sat Apr 3 03:05:00 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:45:24 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; The original ange-ftp VOS support was written by Joe Wells - -;;; Thank you to Jim Franklin for providing -;;; information on the VOS operating system. - -(provide 'efs-vos) -(require 'efs) - -(defconst efs-vos-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;;--------------------------------------------------------------- -;;;; VOS support for efs -;;;;--------------------------------------------------------------- - -;;; A legal VOS pathname is of the form: -;;; %systemname#diskname>dirname>dirname>dir-or-filename -;;; -;;; Each of systemname, diskname, dirname, dir-or-filename can be -;;; at most 32 characters. -;;; Valid characters are all alpha, upper and lower case, all digits, -;;; plus: @[]\^`{|}~"$+,-./:_ -;;; restrictions: name cannot begin with hyphen (-) or period (.) -;;; name must not end with a period (.) -;;; name must not contain two adjacent periods (.) -;;; -;;; Invalid characters are: -;;; non-printing control characters -;;; SPACE and DEL -;;; !#%&'()*;<=>? -;;; all other ascii chars -;;; -;;; The full pathname must be less than or equal to 256 characters. -;;; VOS pathnames are CASE-SENSITIVE. -;;; The may be a directory depth limitation of 10 (newer versions may have -;;; eliminated this). - -;;; entry points - -(efs-defun efs-fix-path vos (path &optional reverse) - ;; Convert PATH from UNIX-ish to VOS. - ;; If REVERSE given then convert from VOS to UNIX-ish. - ;; Does crude checking for valid path syntax, but is by no means exhaustive. - (efs-save-match-data - (if reverse - (if (string-match "^\\(\\(%[^#>%]+\\)?#[^>#%]+\\)?>[^>#%]" path) - (let ((marker (1- (match-end 0))) - (result "/") - system drive) - (if (match-beginning 1) - (if (match-beginning 2) - (setq system (substring path 1 (match-end 2)) - drive (substring path (1+ (match-end 2)) - (match-end 1))) - (setq drive (substring 1 (match-end 1))))) - (while (string-match ">" path marker) - (setq result (concat result - (substring path marker - (match-beginning 0)) - "/") - marker (match-end 0))) - (if drive - (if system - (concat "/" system "/" drive result - (substring path marker)) - (concat "/" drive result (substring path marker))) - (concat result (substring path marker)))) - (error "Invalid VOS pathname %s" path)) - (if (string-match "^/\\([^/]+\\)/\\([^/]+\\)/[^/]" path) - (let ((marker (1- (match-end 0))) - (result (concat "%" - (substring path - (match-beginning 1) - (match-end 1)) - "#" - (substring path - (match-beginning 2) - (match-end 2)) - ">"))) - ;; I'm guessing that VOS doesn't have a directory syntax. - (setq path (efs-internal-directory-file-name path)) - (while (string-match "/" path marker) - (setq result - (concat result - (substring path marker - (match-beginning 0)) - ">") - marker (match-end 0))) - (concat result (substring path marker))) - (error "Cannot convert path %s to VOS." path))))) - -(efs-defun efs-fix-dir-path vos (dir-path) - ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. - (cond ((string-equal dir-path "/") - (error "Cannot gork VOS system names")) - ((string-match "^/[^/]/$" dir-path) - (error "Cannot grok VOS devices")) - ((efs-fix-path 'vos dir-path)))) - -(defconst efs-vos-date-and-time-regexp - (concat - "\\(^\\| \\)" ; For links, this must match at the beginning of the line. - "[678901][0-9]-[01][0-9]-[0-3][0-9] [012][0-9]:[0-6][0-9]:[0-6][0-9] ")) -;; Regexp to match a VOS file line. The end of the regexp must correspond -;; to the start of the filename. - -(defmacro efs-vos-parse-filename () - ;; Return the VOS filename on the current line of a listing. - ;; Assumes that the point is at the beginning of the line. - ;; Return nil if no filename is found. - (` (let ((eol (save-excursion (end-of-line) (point)))) - (and (re-search-forward efs-vos-date-and-time-regexp eol t) - (buffer-substring (point) eol))))) - -(efs-defun efs-parse-listing vos - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in MultiNet FTP dir - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - (let (tbl file) - ;; Look file files. - (if (search-forward "\nFiles: " nil t) - (progn - (setq tbl (efs-make-hashtable)) - (forward-line 1) - (skip-chars-forward "\n") - (while (setq file (efs-vos-parse-filename)) - (efs-put-hash-entry file '(nil) tbl) - (forward-line 1)))) - ;; Look for directories. - (if (search-forward "\nDirs: " nil t) - (progn - (or tbl (setq tbl (efs-make-hashtable))) - (forward-line 1) - (skip-chars-forward "\n") - (while (setq file (efs-vos-parse-filename)) - (efs-put-hash-entry file '(t) tbl) - (forward-line 1)))) - ;; Look for links - (if (search-forward "\nLinks: " nil t) - (let (link) - (or tbl (setq tbl (efs-make-hashtable))) - (forward-line 1) - (skip-chars-forward "\n") - (while (setq file (efs-vos-parse-filename)) - (if (string-match " -> \\([^ ]+\\)" file) - ;; VOS puts a trailing blank after the name of a symlink - ;; target. Go figure... - (setq link (substring file (match-beginning 1) (match-end 1)) - file (substring file 0 (match-beginning 0))) - (setq link "")) ; weird? - (efs-put-hash-entry file (list link) tbl) - (forward-line 1)))) - ;; This returns nil if no headings for files, dirs, or links - ;; are found. In this case, we're assuming that it isn't a valid - ;; listing. - (if tbl - (progn - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl))) - tbl))) - -(efs-defun efs-allow-child-lookup vos (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Directoried don't have a size. - (string-match ": not a file\\.$" - (cdr (efs-send-size host user (concat dir file))))) - -;;; Tree Dired Support - -(defconst efs-dired-vos-re-exe - "^. +e ") - -(or (assq 'vos efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'vos efs-dired-vos-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-vos-re-dir - "^. +[nsm] +[0-9]+ +[678901][0-9]-") - -(or (assq 'vos efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'vos efs-dired-vos-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename vos - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line, where - ;; line can be delimited by either \r or \n. - ;; Returns (point) or nil if raise-error is nil and there is no - ;; filename on this line. In the later case, leaves the point at the - ;; beginning of the line. - ;; This version is for VOS. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-vos-date-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename vos - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the VOS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-a-zA-Z0-9@[]\\^`{|}~\"$+,./:_") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-fixup-listing vos (file path &optional switches wildcard) - ;; VOS listing contain some empty lines, which is inconvenient for dired. - (goto-char (point-min)) - (skip-chars-forward "\n") - (delete-region (point-min) (point)) - (while (search-forward "\n\n" nil t) - (forward-char -2) - (delete-char 1))) - -(efs-defun efs-dired-ls-trim vos () - ;; Trims VOS dir listings for single files, so that they are exactly one line - ;; long. - (goto-char (point-min)) - (let (case-fold-search) - (re-search-forward efs-vos-date-and-time-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - -;;; end of efs-vos.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs-x19.15.el --- a/lisp/efs/efs-x19.15.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-x19.15.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: efs support for XEmacs, versions 19.15, and later. -;; Author: Sandy Rutherford -;; Created: Tue Aug 2 17:40:32 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-x19\.15) -(require 'efs-cu) -(require 'efs-ovwrt) - -(defconst efs-x19\.15-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;;; Functions requiring special defs. for these XEmacs versions. - -(defun efs-abbreviate-file-name (filename &optional hack-homedir) - ;; XEmacs version of abbreviate-file-name for remote files. - (let (file-name-handler-alist) - (if (and hack-homedir (efs-ftp-path filename)) - ;; Do replacements from directory-abbrev-alist - (apply 'efs-unexpand-parsed-filename - (efs-ftp-path (abbreviate-file-name filename nil))) - (abbreviate-file-name filename hack-homedir)))) - -(defun efs-set-buffer-file-name (filename) - ;; Sets the buffer local variables for filename appropriately. - ;; A special function because XEmacs and FSF do this differently. - (setq buffer-file-name filename) - (if (and efs-compute-remote-buffer-file-truename - (memq (efs-host-type (car (efs-ftp-path filename))) - efs-unix-host-types)) - (compute-buffer-file-truename) - (setq buffer-file-truename filename))) - -;; Only XEmacs has this function. Why do we need both this and -;; set-visited-file-modtime? - -(defun efs-set-buffer-modtime (buffer &optional time) - ;; For buffers visiting remote files, set the buffer modtime. - (or time - (progn - (setq time - (let* ((file (save-excursion - (set-buffer buffer) buffer-file-name)) - (parsed (efs-ftp-path file))) - (efs-get-file-mdtm (car parsed) (nth 1 parsed) - (nth 2 parsed) file))) - (if time - (setq time (cons (car time) (nth 1 time))) - (setq time '(0 . 0))))) - (let (file-name-handler-alist) - (set-buffer-modtime buffer time))) - -;;; For the file-name-handler-alist - -(put 'set-buffer-modtime 'efs 'efs-set-buffer-modtime) - -;;; end of efs-x19.15.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/efs.el --- a/lisp/efs/efs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10917 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.56 $ -;; RCS: -;; Description: Transparent FTP support for the original GNU Emacs -;; from FSF and XEmacs -;; Authors: Andy Norman , -;; Sandy Rutherford -;; Created: Thu Oct 12 14:00:05 1989 (as ange-ftp) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The following restrictions apply to all of the files in the efs -;;; distribution. -;;; -;;; Copyright (C) 1993 Andy Norman / Sandy Rutherford -;;; -;;; Authors: -;;; Andy Norman (ange@hplb.hpl.hp.com) -;;; Sandy Rutherford (sandy@ibm550.sissa.it) -;;; -;;; The authors of some of the sub-files of efs are different -;;; from the above. We are very grateful to people who have -;;; contributed code to efs. -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's authors (send electronic mail to ange@hplb.hpl.hp.com) or -;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -;;; MA 02139, USA. - -;;; Description: -;;; -;;; This package attempts to make accessing files and directories on -;;; remote computers from within GNU Emacs as simple and transparent -;;; as possible. Currently all remote files are accessed using FTP. -;;; The goal is to make the entire internet accessible as a virtual -;;; file system. - -;;; Acknowledgements: << please add to this list >> -;;; -;;; Corny de Souza for writing efs-mpe.el. -;;; Jamie Zawinski for writing efs-ti-twenex.el and efs-ti-explorer.el -;;; Joe Wells for writing the first pass at vms support for ange-ftp.el. -;;; Sebastian Kremer for helping with dired support. -;;; Ishikawa Ichiro for MULE support. -;;; -;;; Many other people have contributed code, advice, and beta testing -;;; (sometimes without even realizing it) to both ange-ftp and efs: -;;; -;;; Rob Austein, Doug Bagley, Andy Caiger, Jim Franklin, Noah -;;; Friedman, Aksnes Knut-Havard, Elmar Heeb, John Interrante, Roland -;;; McGrath, Jeff Morgenthaler, Mike Northam, Jens Petersen, Jack -;;; Repenning, Joerg-Martin Schwarz, Michael Sperber, Svein Tjemsland, -;;; Andy Whitcroft, Raymond A. Wiker -;;; -;;; Also, thank you to all the people on the efs-testers mailing list. -;;; - -;;; -------------------------------------------------------------- -;;; Documentation: -;;; -------------------------------------------------------------- -;;; -;;; If you have any problems with efs, please read this section -;;; *before* submitting a bug report. - -;;; Installation: -;;; -;;; For byte compiling the efs package, a Makefile is provided. -;;; You should follow the instructions at the top of the Makefile. -;;; If you have any problems, please let us know so that we can fix -;;; them for other users. Don't even consider using efs without -;;; byte compiling it. It will be far too slow. -;;; -;;; If you decide to byte compile efs by hand, it is important that -;;; the file efs-defun.el be byte compiled first, followed by efs.el. -;;; The other files may be byte compiled in any order. -;;; -;;; To use efs, simply put the byte compiled files in your load path -;;; and add -;;; -;;; (require 'efs) -;;; -;;; in your .emacs file. Note this takes awhile, and some users have -;;; found this to be unbearably slow. Therefore ... -;;; -;;; If you would like efs to be autoloaded when you attempt to access -;;; a remote file, put -;;; -;;; (require 'efs-auto) -;;; -;;; in your .emacs file. Note that there are some limitations associated -;;; with autoloading efs. A discussion of them is given at the top of -;;; efs-auto.el. - -;;; Configuration variables: -;;; -;;; It is important that you read through the section on user customization -;;; variables (search forward for the string ">>>"). If your local network -;;; is not fully connected to the internet, but accesses the internet only -;;; via a gateway, then it is vital to set the appropriate variables to -;;; inform efs about the geometry of your local network. Also, see the -;;; paragraph on gateways below. - -;;; Usage: -;;; -;;; Once installed, efs operates largely transparently. All files -;;; normally accessible to you on the internet, become part of a large -;;; virtual file system. These files are accessed using an extended -;;; file name syntax. To access file on remote host by -;;; logging in as user , you simply specify the full path of the -;;; file as /@:. Nearly all GNU Emacs file handling -;;; functions work for remote files. It is not possible to access -;;; remote files using shell commands in an emacs *shell* buffer, as such -;;; commands are passed directly to the shell, and not handled by emacs. -;;; FTP is the underlying utility that efs uses to operate on remote files. -;;; -;;; For example, if find-file is given a filename of: -;;; -;;; /ange@anorman:/tmp/notes -;;; -;;; then efs will spawn an FTP process, connect to the host 'anorman' as -;;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the -;;; contents of that file as if it were on the local file system. If efs -;;; needed a password to connect then it would prompt the user in the -;;; minibuffer. For further discussion of the efs path syntax, see the -;;; paragraph on extended file name syntax below. - -;;; Ports: -;;; -;;; efs supports the use of nonstandard ports on remote hosts. -;;; To specify that port should be used, give the host name as -;;; host#. Host names may be given in this form anywhere that efs -;;; normally expects a host name. This includes in the .netrc file. -;;; Logically, efs treats different ports to correspond to different -;;; remote hosts. - -;;; Extended filename syntax: -;;; -;;; The default full efs path syntax is -;;; -;;; /@#: -;;; -;;; Both the `#' and `@' may be omitted. -;;; -;;; If the `#' is omitted, then the default port is taken to be 21, -;;; the usual FTP port. For most users, the port syntax will only -;;; very rarely be necessary. -;;; -;;; If the `@' is omitted, then efs will use a default user. If a -;;; login token is specified in your .netrc file, then this will be used as -;;; the default user for . Otherwise, it is determined based on the -;;; value of the variable efs-default-user. -;;; -;;; This efs path syntax can be customised to a certain extent by -;;; changing a number of variables in the subsection Internal Variables. -;;; To undertake such a customization requires some knowledge about the -;;; internal workings of efs. - -;;; Passwords: -;;; -;;; A password is required for each host / user pair. This will be -;;; prompted for when needed, unless already set by calling -;;; efs-set-passwd, or specified in a *valid* ~/.netrc file. -;;; -;;; When efs prompts for a password, it provides defaults from its -;;; cache of currently known passwords. The defaults are ordered such -;;; that passwords for accounts which have the same user name as the -;;; login which is currently underway have priority. You can cycle -;;; through your list of defaults with C-n to cycle forwards and C-p -;;; to cycle backwards. The list is circular. - -;;; Passwords for user "anonymous": -;;; -;;; Passwords for the user "anonymous" (or "ftp") are handled -;;; specially. The variable efs-generate-anonymous-password controls -;;; what happens. If the value of this variable is a string, then this -;;; is used as the password; if non-nil, then a password is created -;;; from the name of the user and the hostname of the machine on which -;;; GNU Emacs is running; if nil (the default) then the user is -;;; prompted for a password as normal. - -;;; "Dumb" UNIX hosts: -;;; -;;; The FTP servers on some UNIX machines have problems if the "ls" -;;; command is used. efs will try to correct for this automatically, -;;; and send the "dir" command instead. If it fails, you can call the -;;; function efs-add-host, and give the host type as dumb-unix. Note -;;; that this change will take effect for the current GNU Emacs -;;; session only. To make this specification for future emacs -;;; sessions, put -;;; -;;; (efs-add-host 'dumb-unix "hostname") -;;; -;;; in your .emacs file. Also, please report any failure to automatically -;;; recognize dumb unix to the "bugs" address given below, so that we can -;;; fix the auto recognition code. - -;;; File name completion: -;;; -;;; Full file-name completion is supported on every type of remote -;;; host. To do filename completion, efs needs a listing from the -;;; remote host. Therefore, for very slow connections, it might not -;;; save any time. However, the listing is cached, so subsequent uses -;;; of file-name completion will be just as fast as for local file -;;; names. - -;;; FTP processes: -;;; -;;; When efs starts up an FTP process, it leaves it running for speed -;;; purposes. Some FTP servers will close the connection after a period of -;;; time, but efs should be able to quietly reconnect the next time that -;;; the process is needed. -;;; -;;; The FTP process will be killed should the associated "*ftp user@host*" -;;; buffer be deleted. This should not cause efs any grief. - -;;; Showing background FTP activity on the mode-line: -;;; -;;; After efs is loaded, the command efs-display-ftp-activity will cause -;;; background FTP activity to be displayed on the mode line. The variable -;;; efs-mode-line-format is used to determine how this data is displayed. -;;; efs does not continuously track the number of active sessions, as this -;;; would cause the display to change too rapidly. Rather, it uses a heuristic -;;; algorithm to determine when there is a significant change in FTP activity. - -;;; File types: -;;; -;;; By default efs will assume that all files are ASCII. If a file -;;; being transferred matches the value of efs-binary-file-name-regexp -;;; then the file will be assumed to be a binary file, and efs will -;;; transfer it using "type image". ASCII files will be transferred -;;; using a transfer type which efs computes to be correct according -;;; to its knowledge of the file system of the remote host. The -;;; command `efs-prompt-for-transfer-type' toggles the variable -;;; `efs-prompt-for-transfer-type'. When this variable is non-nil, efs -;;; will prompt the user for the transfer type to use for every FTP -;;; transfer. Having this set all the time is annoying, but it is -;;; useful to give special treatment to a small set of files. -;;; There is also variable efs-text-file-name-regexp. This is tested before -;;; efs-binary-file-name-regexp, so if you set efs-text-file-name-regexp -;;; to a non-trivial regular expression, and efs-binary-file-name-regexp -;;; to ".*", the result will to make image the default tranfer type. -;;; -;;; Also, if you set efs-treat-crlf-as-nl, then efs will use type image -;;; to transfer files between hosts whose file system differ only in that -;;; one specifies end of line as CR-LF, and the other as NL. This is useful -;;; if you are transferring files between UNIX and DOS machines, and have a -;;; package such as dos-mode.el, that handles the extra ^M's. - -;;; Account passwords: -;;; -;;; Some FTP servers require an additional password which is sent by -;;; the ACCOUNT command. efs will detect this and prompt the user for -;;; an account password if the server expects one. Also, an account -;;; password can be set by calling efs-set-account, or by specifying -;;; an account token in the .netrc file. -;;; -;;; Some operating systems, such as CMS, require that ACCOUNT be used to -;;; give a write access password for minidisks. efs-set-account can be used -;;; to set a write password for a specific minidisk. Also, tokens of the form -;;; minidisk -;;; may be added to host lines in your .netrc file. Minidisk tokens must be -;;; at the end of the host line, however there may be an arbitrary number of -;;; them for any given host. - -;;; Preloading: -;;; -;;; efs can be preloaded, but must be put in the site-init.el file and -;;; not the site-load.el file in order for the documentation strings for the -;;; functions being overloaded to be available. - -;;; Status reports: -;;; -;;; Most efs commands that talk to the FTP process output a status -;;; message on what they are doing. In addition, efs can take advantage -;;; of the FTP client's HASH command to display the status of transferring -;;; files and listing directories. See the documentation for the variables -;;; efs-hash-mark-size, efs-send-hash and efs-verbose for more details. - -;;; Caching of directory information: -;;; -;;; efs keeps an internal cache of file listings from remote hosts. -;;; If this cache gets out of synch, it can be renewed by reverting a -;;; dired buffer for the appropriate directory (dired-revert is usually -;;; bound to "g"). -;;; -;;; Alternatively, you can add the following two lines to your .emacs file -;;; if you want C-r to refresh efs's cache whilst doing filename -;;; completion. -;;; (define-key minibuffer-local-completion-map "\C-r" 'efs-re-read-dir) -;;; (define-key minibuffer-local-must-match-map "\C-r" 'efs-re-read-dir) - -;;; Gateways: -;;; -;;; Sometimes it is necessary for the FTP process to be run on a different -;;; machine than the machine running GNU Emacs. This can happen when the -;;; local machine has restrictions on what hosts it can access. -;;; -;;; efs has support for running the ftp process on a different (gateway) -;;; machine. The way it works is as follows: -;;; -;;; 1) Set the variable 'efs-gateway-host' to the name of a machine -;;; that doesn't have the access restrictions. If you need to use -;;; a nonstandard port to access this host for gateway use, then -;;; specify efs-gateway-host as "#". -;;; -;;; 2) Set the variable 'efs-ftp-local-host-regexp' to a regular expression -;;; that matches hosts that can be contacted from running a local ftp -;;; process, but fails to match hosts that can't be accessed locally. For -;;; example: -;;; -;;; "\\.hp\\.com$\\|^[^.]*$" -;;; -;;; will match all hosts that are in the .hp.com domain, or don't have an -;;; explicit domain in their name, but will fail to match hosts with -;;; explicit domains or that are specified by their ip address. -;;; -;;; 3) Set the variable `efs-local-host-regexp' to machines that you have -;;; direct TCP/IP access. In other words, you must be able to ping these -;;; hosts. Usually, efs-ftp-local-host-regexp and efs-local-host-regexp -;;; will be the same. However, they will differ for so-called transparent -;;; gateways. See #7 below for more details. -;;; -;;; 4) Set the variable 'efs-gateway-tmp-name-template' to the name of -;;; a directory plus an identifying filename prefix for making temporary -;;; files on the gateway. For example: "/tmp/hplose/ange/efs" -;;; -;;; 5) If the gateway and the local host share cross-mounted directories, -;;; set the value of `efs-gateway-mounted-dirs-alist' accordingly. It -;;; is particularly useful, but not mandatory, that the directory -;;; of `efs-gateway-tmp-name-template' be cross-mounted. -;;; -;;; 6) Set the variable `efs-gateway-type' to the type gateway that you have. -;;; This variable is a list, the first element of which is a symbol -;;; denoting the type of gateway. Following elements give further -;;; data on the gateway. -;;; -;;; Supported gateway types: -;;; -;;; a) local: -;;; This means that your local host is itself the gateway. However, -;;; it is necessary to use a different FTP client to gain access to -;;; the outside world. If the name of the FTP client were xftp, you might -;;; set efs-gateway-type to -;;; -;;; (list 'local "xftp" efs-ftp-program-args) -;;; -;;; If xftp required special arguments, then give them in place of -;;; efs-ftp-program-args. See the documentation for efs-ftp-program-args -;;; for the syntax. -;;; -;;; b) proxy: -;;; This indicates that your gateway works by first FTP'ing to it, and -;;; then issuing a USER command of the form -;;; -;;; USER @ -;;; -;;; In this case, you might set efs-gateway-type to -;;; -;;; (list 'proxy "ftp" efs-ftp-program-args) -;;; -;;; If you need to use a nonstandard client, such as iftp, give this -;;; instead of "ftp". If this client needs to take special arguments, -;;; give them instead of efs-ftp-program-args. -;;; -;;; c) remsh: -;;; For this type of gateway, you need to start a remote shell on -;;; your gateway, using either remsh or rsh. You should set -;;; efs-gateway-type to something like -;;; -;;; (list 'remsh "remsh" nil "ftp" efs-ftp-program-args) -;;; -;;; If you use rsh instead of remsh, change the second element from -;;; "remsh" to "rsh". Note that the symbol indicating the gateway -;;; type should still be 'remsh. If you want to pass arguments -;;; to the remsh program, give them as the third element. For example, -;;; if you need to specify a user, make this (list "-l" "sandy"). -;;; If you need to use a nonstandard FTP client, specify that as the fourth -;;; element. If your FTP client needs to be given special arguments, -;;; give them instead of efs-ftp-program-args. -;;; -;;; d) interactive: -;;; This indicates that you need to establish a login on the gateway, -;;; using either telnet or rlogin. -;;; You should set efs-gateway-type to something like -;;; -;;; (list 'interactive "rlogin" nil "exec ftp" efs-ftp-program-args) -;;; -;;; If you need to use telnet, then give "telnet" in place of the second -;;; element "rlogin". If your login program needs to be given arguments, -;;; then they should be given in the third slot. The fourth element -;;; is for the name of the FTP client program. Giving this as "exec ftp", -;;; instead of "ftp", ensures that you are logged out if the FTP client -;;; dies. If the FTP client takes special arguments, give these instead -;;; of efs-ftp-program-args. Furthermore, you should see the documentation -;;; at the top of efs-gwp.el. You may need to set the variables -;;; efs-gwp-setup-term-command, and efs-gwp-prompt-pattern. -;;; -;;; e) raptor: -;;; This is a type of gateway where efs is expected to specify a gateway -;;; user, and send a password for this user using the ACCOUNT command. -;;; For example, to log in to foobar.edu as sandy, while using the account -;;; ange on the gateway, the following commands would be sent: -;;; -;;; open raptorgate.com -;;; quote USER sandy@foobar.edu ange -;;; quote pass -;;; quote account -;;; -;;; For such a gateway, you would set efs-gateway-type to -;;; -;;; (list 'raptor efs-ftp-program efs-ftp-program-args ) -;;; -;;; where is the name of your account on the gateway. In -;;; the above example, this would be "ange". You can set your gateway -;;; password by simply setting an account password for the gateway host. -;;; This can be done with either efs-set-account, or within your .netrc -;;; file. If no password is set, you will be prompted for one. -;;; -;;; f) interlock: -;;; This is a type of gateway where you are expected to send a PASS -;;; command after opening the connection to the gateway. -;;; The precise login sequence is -;;; -;;; open interlockgate -;;; quote PASS -;;; quote USER sandy@foobar.edu -;;; quote PASS -;;; -;;; For such a gateway, you should set efs-gateway-type to -;;; -;;; (list 'interlock efs-ftp-program efs-ftp-program-args) -;;; -;;; If you need to use a nonstandard name for your FTP client, -;;; then replace efs-ftp-program with this name. If your FTP client -;;; needs to take nonstandard arguments, then replace efs-ftp-program-args -;;; with these arguments. See efs-ftp-program-args for the required -;;; syntax. -;;; -;;; If your gateway returns both a 220 code and a 331 code to the -;;; "open interlockgate" command, then you should add a regular -;;; expression to efs-skip-msgs that matches the 220 response. -;;; Returning two response codes to a single FTP command is not permitted -;;; in RFC 959. It is not possible for efs to ignore the 220 by default, -;;; because than it would hang for interlock installations which do not -;;; require a password. -;;; -;;; g) kerberos: -;;; With this gateway, you need to authenticate yourself by getting a -;;; kerberos "ticket" first. Usually, this is done with the kinit program. -;;; Once authenticated, you connect to foobar.com as user sandy with the -;;; sequence: (Note that the "-n" argument inhibits automatic login. -;;; Although, in manual use you probably don't use it, efs always uses it.) -;;; -;;; iftp -n -;;; open foobar.com -;;; user sandy@foobar.com -;;; -;;; You should set efs-gateway-type to something like -;;; -;;; (list 'kerberos "iftp" efs-ftp-program-args "kinit" ) -;;; -;;; If you use an FTP client other than iftp, insert its name instead -;;; of "iftp" above. If your FTP client needs special arguments, give -;;; them as a list of strings in place of efs-ftp-program-args. If -;;; the program that you use to collect a ticket in not called "kinit", -;;; then give its name in place of "kinit" above. should be -;;; any arguments that you need to pass to your kinit program, given as a -;;; list of strings. Most likely, you will give this as nil. -;;; -;;; See the file efs-kerberos.el for more configuration variables. If you -;;; need to adjust any of these variables, please report this to us so that -;;; we can fix them for other users. -;;; -;;; If efs detects that you are not authenticated to use the gateway, it -;;; will run the kinit program automatically, prompting you for a password. -;;; If you give a password in your .netrc file for login the value of -;;; efs-gateway-host and user kerberos, then efs will use this to -;;; obtain gateway authentication. -;;; -;;; 7) Transparent gateways: -;;; -;;; If your gateway is completely transparent (for example it uses -;;; socks), then you should set efs-gateway-type to nil. Also, -;;; set efs-ftp-local-host-regexp to ".*". However, efs-local-host-regexp, -;;; must still be set to a regular expression matching hosts in your local -;;; domain. efs uses this to determine which machines that it can -;;; open-network-stream to. Furthermore, you should still set -;;; efs-gateway-host to the name of your gateway machine. That way efs -;;; will know that this is a special machine having direct TCP/IP access -;;; to both hosts in the outside world, and hosts in your local domain. -;;; -;;; 8) Common Problems with Gateways: -;;; -;;; a) Spurious 220 responses: -;;; Some proxy-style gateways (eg gateway type 'proxy or 'raptor), -;;; return two 3-digit FTP reply codes to the USER command. -;;; For example: -;;; -;;; open gateway.weird -;;; 220 Connected to gateway.weird -;;; quote USER sandy@foobar -;;; 220 Connected to foobar -;;; 331 Password required for sandy -;;; -;;; This is wrong, according to the FT Protocol. Each command must return -;;; exactly one 3-digit reply code. It may be preceded by continuation -;;; lines. What should really be returned is: -;;; -;;; quote USER sandy@foobar -;;; 331-Connected to foobar. -;;; 331 Password required for sandy. -;;; -;;; or even -;;; -;;; quote USER sandy@foobar -;;; 331-220 Connected to foobar. -;;; 331 Password required for sandy. -;;; -;;; Even though the "331-220" looks strange, it is correct protocol, and -;;; efs will parse it properly. -;;; -;;; If your gateway is returning a spurious 220 to USER, a work-around -;;; is to add a regular expression to `efs-skip-msgs' that matches -;;; this line. It must not match the 220 line returned to the open -;;; command. This work-around may not work, as some system FTP clients -;;; also get confused by the spurious 220. In this case, the only -;;; solution is to patch the gateway server. In either case, please -;;; send a bug report to the author of your gateway software. -;;; -;;; b) Case-sensitive parsing of FTP commands: -;;; Some gateway servers seem to treat FTP commands case-sensitively. -;;; This is incorrect, as RFC 959 clearly states that FTP commands -;;; are always to be case-insensitive. If this is a problem with your -;;; gateway server, you should send a bug report to its author. -;;; If efs is using a case for FTP commands that does not suit your server, -;;; a possible work-around is to edit the efs source so that the required -;;; case is used. However, we will not be making any changes to the -;;; standard efs distribution to support this type of server behaviour. -;;; If you need help changing the efs source, you should enquire with the -;;; efs-help mailing list. -;;; - -;;; --------------------------------------------------------------- -;;; Tips for using efs: -;;; --------------------------------------------------------------- - -;;; 1) Beware of compressing files on non-UNIX hosts. efs will do it by -;;; copying the file to the local machine, compressing it there, and then -;;; sending it back. Binary file transfers between machines of different -;;; architectures can be a risky business. Test things out first on some -;;; test files. See "Bugs" below. Also, note that efs sometimes -;;; copies files by moving them through the local machine. Again, -;;; be careful when doing this with binary files on non-Unix -;;; machines. -;;; -;;; 2) Beware that dired over ftp will use your setting of dired-no-confirm -;;; (list of dired commands for which confirmation is not asked). -;;; You might want to reconsider your setting of this variable, -;;; because you might want confirmation for more commands on remote -;;; direds than on local direds. For example, I strongly recommend -;;; that you not include compress in this list. If there is enough -;;; demand it might be a good idea to have an alist -;;; efs-dired-no-confirm of pairs ( TYPE . LIST ), where TYPE is an -;;; operating system type and LIST is a list of commands for which -;;; confirmation would be suppressed. Then remote dired listings -;;; would take their (buffer-local) value of dired-no-confirm from -;;; this alist. Who votes for this? -;;; -;;; 3) Some combinations of FTP clients and servers break and get out of sync -;;; when asked to list a non-existent directory. Some of the ai.mit.edu -;;; machines cause this problem for some FTP clients. Using -;;; efs-kill-ftp-process can be used to restart the ftp process, which -;;; should get things back in synch. -;;; -;;; 4) Some ftp servers impose a length limit on the password that can -;;; be sent. If this limit is exceeded they may bomb in an -;;; incomprehensible way. This sort of behaviour is common with -;;; MVS servers. Therefore, you should beware of this possibility -;;; if you are generating a long password (like an email address) -;;; with efs-generate-anonymous-password. -;;; -;;; 5) Some antiquated FTP servers hang when asked for an RNFR command. -;;; efs sometimes uses this to test whether its local cache is stale. -;;; If your server for HOST hangs when asked for this command, put -;;; (efs-set-host-property HOST 'rnfr-failed t) -;;; in your efs-ftp-startup-function-alist entry for HOST. -;;; - -;;; ----------------------------------------------------------------------- -;;; Where to get the latest version of efs: -;;; ----------------------------------------------------------------------- -;;; -;;; The authors are grateful to anyone or any organization which -;;; provides anonymous FTP distribution for efs. -;;; -;;; -;;; Europe: -;;; -;;; Switzerland -;;; /anonymous@itp.ethz.ch:/sandy/efs/ -;;; -;;; North America: -;;; -;;; Massachusetts, USA -;;; /anonymous@alpha.gnu.ai.mit.edu:/efs/ -;;; -;;; California, USA -;;; /anonymous@ftp.hmc.edu:/pub/emacs/packages/efs/ -;;; -;;; Australia and New Zealand: -;;; -;;; ???????????? -;;; -;;; Japan: -;;; -;;; ???????????? - -;;; --------------------------------------------------------------------- -;;; Non-UNIX support: -;;; --------------------------------------------------------------------- - -;;; efs has full support, incuding file name completion and tree dired -;;; for: -;;; -;;; VMS, CMS, MTS, MVS, ti-twenex, ti-explorer (the last two are lisp -;;; machines), TOPS-20, DOS (running the Distinct, Novell, FTP -;;; software, NCSA, Microsoft in both unix and DOS mode, Super TCP, and -;;; Hellsoft FTP servers), unix descriptive listings (dl), KA9Q, OS/2, -;;; VOS, NOS/VE, CMS running the KNET server, Tandem's Guardian OS, COKE -;;; -;;; efs should be able to automatically recognize any of the operating -;;; systems and FTP servers that it supports. Please report any -;;; failure to do so to the "bugs" address below. You can specify a -;;; certain host as being of a given host type with the command -;;; -;;; (efs-add-host ) -;;; -;;; is a symbol, is a string. If this command is -;;; used interactively, then is prompted for with -;;; completion. Some host types have regexps that can be used to -;;; specify a class of host names as being of a certain type. Note -;;; that if you specify a host as being of a certain type, efs does -;;; not verify that that is really the type of the host. This calls -;;; for caution when using regexps to specify host types, as an -;;; inadvertent match to a regexp might have unpleasant consequences. -;;; -;;; See the respective efs-TYPE.el files for more information. -;;; When or if we get a tex info file, it should contain some more -;;; details on the non-unix support. - -;;; ------------------------------------------------------------------ -;;; Bugs and other things that go clunk in the night: -;;; ------------------------------------------------------------------ - -;;; How to report a bug: -;;; -------------------- -;;; -;;; Type M-x efs-report-bug -;;; or -;;; send mail to efs-bugs@cuckoo.hpl.hp.com. -;;; -;;; efs is a "free" program. This means that you didn't (or shouldn't -;;; have) paid anything for it. It also means that nobody is paid to -;;; maintain it, and the authors weren't paid for writing it. -;;; Therefore, please try to write your bug report in a clear and -;;; complete fashion. It will greatly enhance the probability that -;;; something will be done about your problem. -;;; -;;; Note that efs relies heavily in cached information, so the bug may -;;; depend in a complicated fashion on commands that were performed on -;;; remote files from the beginning of your emacs session. Trying to -;;; reproduce your bug starting from a fresh emacs session is usually -;;; a good idea. -;;; - -;;; Fan/hate mail: -;;; -------------- -;;; -;;; efs has its own mailing list called efs-help. All users of efs -;;; are welcome to subscribe (see below) and to discuss aspects of -;;; efs. New versions of efs are posted periodically to the mailing -;;; list. -;;; -;;; To [un]subscribe to efs-help, or to report mailer problems with the -;;; list, please mail one of the following addresses: -;;; -;;; efs-help-request@cuckoo.hpl.hp.com -;;; or -;;; efs-help-request%cuckoo.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Please don't forget the -request part. -;;; -;;; For mail to be posted directly to efs-help, send to one of the -;;; following addresses: -;;; -;;; efs-help@cuckoo.hpl.hp.com -;;; or -;;; efs-help%cuckoo.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Alternatively, there is a mailing list that only gets -;;; announcements of new efs releases. This is called efs-announce, -;;; and can be subscribed to by e-mailing to the -request address as -;;; above. Please make it clear in the request which mailing list you -;;; wish to join. -;;; - -;;; Known bugs: -;;; ----------- -;;; -;;; If you hit a bug in this list, please report it anyway. Most of -;;; the bugs here remain unfixed because they are considered too -;;; esoteric to be a high priority. If one of them gets reported -;;; enough, we will likely change our view on that. -;;; -;;; 1) efs does not check to make sure that when creating a new file, -;;; you provide a valid filename for the remote operating system. -;;; If you do not, then the remote FTP server will most likely -;;; translate your filename in some way. This may cause efs to -;;; get confused about what exactly is the name of the file. -;;; -;;; 2) For CMS support, we send too many cd's. Since cd's are cheap, I haven't -;;; worried about this too much. Eventually, we should have some caching -;;; of the current minidisk. This is complicated by the fact that some -;;; CMS servers lie about the current minidisk, so sending redundant -;;; cd's helps us recover in this case. -;;; -;;; 3) The code to do compression of files over ftp is not as careful as it -;;; should be. It deletes the old remote version of the file, before -;;; actually checking if the local to remote transfer of the compressed -;;; file succeeds. Of course to delete the original version of the file -;;; after transferring the compressed version back is also dangerous, -;;; because some OS's have severe restrictions on the length of filenames, -;;; and when the compressed version is copied back the "-Z" or ".Z" may be -;;; truncated. Then, efs would delete the only remaining version of -;;; the file. Maybe efs should make backups when it compresses files -;;; (of course, the backup "~" could also be truncated off, sigh...). -;;; Suggestions? -;;; -;;; 4) If a dir listing is attempted for an empty directory on (at least -;;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and -;;; I don't know how to get efs work to around it. -;;; -;;; 5) efs gets confused by directories containing file names with -;;; embedded newlines. A temporary solution is to add "q" to your -;;; dired listing switches. As long as your dired listing switches -;;; also contain "l" and either "a" or "A", efs will use these -;;; switches to get listings for its internal cache. The "q" switch -;;; should force listings to be exactly one file per line. You -;;; still will not be able to access a file with embedded newlines, -;;; but at least it won't mess up the parsing of the rest of the files. -;;; -;;; 6) efs cannot parse symlinks which have an embedded " -> " -;;; in their name. It's alright to have an embedded " -> " in the name -;;; of any other type of file. A fix is possible, but probably not worth -;;; the trouble. If you disagree, send us a bug report. -;;; -;;; 7) efs doesn't handle context-dep. files in H-switch listings on -;;; HP's. It wouldn't be such a big roaring deal to fix this. I'm -;;; waiting until I get an actual bug report though. -;;; -;;; 8) If a hard link is added or deleted, efs will not update its -;;; internal cache of the link count for other names of the file. -;;; This may cause file-nlinks to return incorrectly. Reverting -;;; any dired buffer containing other names for the file will -;;; cause the file data to be updated, including the link counts. -;;; A fix for this problem is known and will be eventually -;;; implemented. How it is implemented will depend on how we decide -;;; to handle inodes. See below. -;;; -;;; 9) efs is unable to parse R-switch listings from remote unix hosts. -;;; This is inefficient, because efs will insist on doing individual -;;; listings of the subdirectories to get its file information. -;;; This may be fixed if there is enough demand. -;;; -;;; 10) In file-attributes, efs returns a fake inode number. Of course -;;; this is necessary, but this inode number is not even necessarily -;;; unique. It is simply the sum of the characters (treated as -;;; integers) in the host name, user name, and file name. Possible -;;; ways to get a unique inode number are: -;;; a) Simply keep a count of all remote file in the cache, and -;;; return the file's position in this count as a negative number. -;;; b) For unix systems, we could actually get at the real inode -;;; number on the remote host, by adding an "i" to the ls switches. -;;; The inode numbers would then be removed from the listing -;;; returned by efs-ls, if the caller hadn't requested the "i" -;;; switch. We could then make a unique number out of the host name -;;; and the real inode number. -;;; -;;; 11) efs tries to determine if a file is readable or writable by comparing -;;; the file modes, file owner, and user name under which it is logged -;;; into the remote host. This does not take into account groups. -;;; We simply assume that the user belongs to all groups. As a result -;;; we may assume that a file is writable, when in fact it is not. -;;; Groups are tough to handle correctly over FTP. Suggestions? -;;; (For new FTP servers, can do a "QUOTE SITE EXEC groups" to -;;; handle this.) - -;;; ----------------------------------------------------------- -;;; Technical information on this package: -;;; ----------------------------------------------------------- - -;;; efs hooks onto the following functions using the -;;; file-name-handler-alist. Depending on which version of emacs you -;;; are using, not all of these functions may access this alist. In -;;; this case, efs overloads the definitions of these functions with -;;; versions that do access the file-name-handler-alist. These -;;; overloads are done in efs's version-specific files. -;;; -;;; abbreviate-file-name -;;; backup-buffer -;;; copy-file -;;; create-file-buffer -;;; delete-directory -;;; delete-file -;;; directory-file-name -;;; directory-files -;;; file-attributes -;;; file-directory-p -;;; file-exists-p -;;; file-local-copy -;;; file-modes -;;; file-name-all-completions -;;; file-name-as-directory -;;; file-name-completion -;;; file-name-directory -;;; file-name-nondirectory -;;; file-name-sans-versions -;;; file-newer-than-file-p -;;; file-readable-p -;;; file-executable-p -;;; file-accessible-directory-p -;;; file-symlink-p -;;; file-writable-p -;;; get-file-buffer -;;; insert-directory -;;; insert-file-contents -;;; list-directory -;;; make-directory-internal -;;; rename-file -;;; set-file-modes -;;; set-visited-file-modtime -;;; substitute-in-file-name -;;; verify-visited-file-modtime -;;; write-region -;;; -;;; The following functions are overloaded in efs.el, because they cannot -;;; be handled via the file-name-handler-alist. -;;; -;;; expand-file-name -;;; load -;;; read-file-name-internal (Emacs 18, only) -;;; require -;;; -;;; The following dired functions are handled by hooking them into the -;;; the file-name-handler-alist. This is done in efs-dired.el. -;;; -;;; efs-dired-compress-file -;;; eds-dired-print-file -;;; efs-dired-make-compressed-filename -;;; efs-compress-file -;;; efs-dired-print-file -;;; efs-dired-create-directory -;;; efs-dired-recursive-delete-directory -;;; efs-dired-uncache -;;; efs-dired-call-process -;;; -;;; In efs-dired.el, the following dired finctions are overloaded. -;;; -;;; dired-collect-file-versions -;;; dired-find-file -;;; dired-flag-backup-files -;;; dired-get-filename -;;; dired-insert-headerline -;;; dired-move-to-end-of-filename -;;; dired-move-to-filename -;;; dired-run-shell-command -;;; -;;; efs makes use of the following hooks -;;; -;;; diff-load-hook -;;; dired-before-readin-hook -;;; find-file-hooks -;;; dired-grep-load-hook - -;;; LISPDIR ENTRY for the Elisp Archive: -;;; -;;; LCD Archive Entry: -;;; efs|Andy Norman and Sandy Rutherford -;;; |ange@hplb.hpl.hp.com and sandy@ibm550.sissa.it -;;; |transparent FTP Support for GNU Emacs -;;; |$Date: 1997/10/03 00:11:00 $|$efs release: 1.15 beta $| - -;;; Host and listing type notation: -;;; -;;; The functions efs-host-type and efs-listing-type, and the -;;; variable efs-dired-host-type follow the following conventions -;;; for remote host types. -;;; -;;; nil = local host type, whatever that is (probably unix). -;;; Think nil as in "not a remote host". This value is used by -;;; efs-dired-host-type for local buffers. -;;; (efs-host-type nil) => nil -;;; -;;; 'type = a remote host of TYPE type. -;;; -;;; 'type:list = a remote host using listing type 'type:list. -;;; This is currently used for Unix dl (descriptive -;;; listings), when efs-dired-host-type is set to -;;; 'unix:dl, and to support the myriad of DOS FTP -;;; servers. - -;;; Supported host and listing types: -;;; -;;; unknown, unix, dumb-unix, bsd-unix, sysV-unix, next-unix, -;;; super-dumb-unix, dumb-apollo-unix, -;;; apollo-unix, unix:dl, dos-distinct, ka9q, dos, dos:ftp, dos:novell, -;;; dos:ncsa, dos:winsock, vos, hell, dos:microsoft, super-dumb-unix -;;; vms, cms, mts, mvs, mvs:tcp mvs:nih tops-20, mpe, ti-twenex, -;;; ti-explorer, os2, vos, -;;; vms:full, guardian, ms-unix (This is the Microsoft NT Windows server -;;; in unix mode.), plan9, unix:unknown, nos-ve (actually NOS/VE). - -;;; Host and listing type hierarchy: -;;; -;;; unknown: unix, dumb-unix, sysV-unix, bsd-unix, next-unix, apollo-unix, -;;; ka9q, dos-distinct, unix:dl, hell, -;;; super-dumb-unix, dumb-apollo-unix -;;; unix: sysV-unix, bsd-unix, next-unix, apollo-unix, unix:dl -;;; dos: dos:ftp, dos:novell, dos:ncsa, dos:microsoft, dos:winsock -;;; dumb-unix: -;;; bsd-unix: -;;; sysV-unix: -;;; next-unix: -;;; apollo-unix: -;;; dumb-apollo-unix: -;;; unix:dl: -;;; unix:unknown: unix:dl, unix -;;; super-dumb-unix: -;;; dos-distinct: -;;; dos:ftp: -;;; dos:novell: -;;; dos:microsoft -;;; ka9q: -;;; vms: vms:full -;;; cms: -;;; mts: -;;; mvs: mvs:tcp, mvs:nih -;;; mvs:tcp: -;;; mvs:nih: -;;; tops-20: -;;; ti-twenex: -;;; ti-explorer: -;;; os2: -;;; vos: -;;; vms:full: -;;; dos:ncsa: -;;; dos:winsock: -;;; vos: -;;; hell: -;;; guardian: -;;; ms-unix: -;;; plan9: -;;; nos-ve: -;;; coke: -;;; - - -;;;; ================================================================ -;;;; >0 -;;;; Table of Contents for efs.el -;;;; ================================================================ -;; -;; Each section of efs.el is labelled by >#, where # is the number of -;; the section. -;; -;; 1. Provisions, requirements, and autoloads. -;; 2. Variable definitions. -;; 3. Utilities. -;; 4. Hosts, users, accounts, and passwords. -;; 5. FTP client process and server responses. -;; 6. Sending commands to the FTP server. -;; 7. Parsing and storing remote file system data. -;; 8. Redefinitions of standard GNU Emacs functions. -;; 9. Multiple host type support. -;; 10. Attaching onto the appropriate emacs version. - - -;;;; ================================================================ -;;;; >1 -;;;; General provisions, requirements, and autoloads. -;;;; Host type, and local emacs type dependent loads, and autoloads -;;;; are in the last two sections of this file. -;;;; ================================================================ - -;;;; ---------------------------------------------------------------- -;;;; Provide the package (Do this now to avoid an infinite loop) -;;;; ---------------------------------------------------------------- - -(provide 'efs) - -;;;; ---------------------------------------------------------------- -;;;; Our requirements. -;;;; ---------------------------------------------------------------- - -(require 'backquote) -(require 'comint) -(require 'efs-defun) -(require 'efs-netrc) -(require 'efs-cu) -(require 'efs-ovwrt) -;; Do this last, as it installs efs into the file-name-handler-alist. -(require 'efs-fnh) - -(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) -(autoload 'efs-gwp-start "efs-gwp" ; For interactive gateways. - "Login to the gateway machine and fire up an FTP client.") -(autoload 'efs-kerberos-login "efs-kerberos") -(autoload 'efs-insert-directory "efs-dired" "Insert a directory listing.") -(autoload 'efs-set-mdtm-of "efs-cp-p") -(autoload 'diff-latest-backup-file "diff") -(autoload 'read-passwd "passwd" "Read a password from the minibuffer." t) - - -;;;; ============================================================ -;;;; >2 -;;;; Variable Definitions -;;;; **** The user configuration variables are in **** -;;;; **** the second subsection of this section. **** -;;;; ============================================================ - -;;;; ------------------------------------------------------------ -;;;; Constant Definitions -;;;; ------------------------------------------------------------ - -(defconst efs-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.56 $" 11 -2))) - -(defconst efs-time-zero 1970) ; we count time from midnight, Jan 1, 1970 GMT. - -(defconst efs-dumb-host-types - '(dumb-unix super-dumb-unix vms cms mts ti-twenex ti-explorer dos mvs - tops-20 mpe ka9q dos-distinct os2 vos hell guardian - netware cms-knet nos-ve coke dumb-apollo-unix) - "List of host types that can't take UNIX ls-style listing options.") -;; dos-distinct only ignores ls switches; it doesn't barf. -;; Still treat it as dumb. - -(defconst efs-unix-host-types - '(unix sysV-unix bsd-unix next-unix apollo-unix dumb-unix - dumb-apollo-unix super-dumb-unix) - "List of unix host types.") - -(defconst efs-version-host-types '(vms tops-20 ti-twenex ti-explorer) - "List of host-types which associated a version number to all files. -This is not the same as associating version numbers to only backup files.") -;; Note that on these systems, -;; (file-name-sans-versions EXISTING-FILE) does not exist as a file. - -(defconst efs-single-extension-host-types - '(vms tops-20 ti-twenex ti-explorer cms mvs dos ka9q dos-distinct hell - netware ms-unix plan9 cms-knet nos-ve) - "List of host types which allow at most one extension on a file name. -Extensions are deliminated by \".\". In addition, these host-types must -allow \"-\" in file names, because it will be used to add additional extensions -to indicate compressed files.") - -(defconst efs-idle-host-types - (append '(coke unknown) efs-unix-host-types)) -;; List of host types for which it is possible that the SITE IDLE command -;; is supported. - -(defconst efs-listing-types - '(unix:dl unix:unknown - dos:novell dos:ftp dos:ncsa dos:microsoft dos:stcp dos:winsock - mvs:nih mvs:tcp mvs:tcp - vms:full) - "List of supported listing types") - -(defconst efs-nlist-listing-types - '(vms:full)) -;; Listing types which give a long useless listing when asked for a -;; LIST. For these, use an NLST instead. This can only be done -;; when there is some way to distinguish directories from -;; plain files in an NLST. - -(defconst efs-opaque-gateways '(remsh interactive)) -;; List of gateway types for which we need to do explicit file handling on -;; the gateway machine. - -;;;; ------------------------------------------------------------------ -;;;; User customization variables. Please read through these carefully. -;;;; ------------------------------------------------------------------ - -;;;>>>> If you are not fully connected to the internet, <<<< -;;;>>>> and need to use a gateway (no matter how transparent) <<<< -;;;>>>> you will need to set some of the following variables. <<<< -;;;>>>> Read the documentation carefully. <<<< - -(defvar efs-local-host-regexp ".*" - "Regexp to match names of local hosts. -These are hosts to which it is possible to obtain a direct internet -connection. Even if the host is accessible by a very transparent FTP gateway, -it does not qualify as a local host. The test to determine if machine A is -local to your machine is if it is possible to ftp from A _back_ to your -local machine. Also, open-network-stream must be able to reach the host -in question.") - -(defvar efs-ftp-local-host-regexp ".*" - "Regexp to match the names of hosts reachable by a direct ftp connection. -This regexp should match the names of hosts which can be reached using ftp, -without requiring any explicit connection to a gateway. If you have a smart -ftp client which is able to transparently go through a gateway, this will -differ from `efs-local-host-regexp'.") - -(defvar efs-gateway-host nil - "If non-nil, this must be the name of your ftp gateway machine. -If your net world is divided into two domains according to -`efs-local-ftp-host-regexp', set this variable to the name of the -gateway machine.") - -(defvar efs-gateway-type nil - "Specifies which type of gateway you wish efs to use. -This should be a list, the first element of which is a symbol denoting the -gateway type, and following elements give data on how to use the gateway. - -The following possibilities are supported: - - '(local FTP-PROGRAM FTP-PROGRAM-ARGS) - This means that your local host is itself the gateway. However, - you need to run a special FTP client to access outside hosts. - FTP-PROGRAM should be the name of this FTP client, and FTP-PROGRAM-ARGS - is a list of arguments to pass to it \(probably set this to the value of - efs-ftp-program-args \). Note that if your gateway is of this type, - then you would set efs-gateway-host to nil. - - '(proxy FTP-PROGRAM FTP-PROGRAM-ARGS) - This indicates that your gateway works by first FTP'ing to it, and - then giving a USER command of the form \"USER @\". - FTP-PROGRAM is the FTP program to use to connect to the gateway; this - is most likely \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to - pass to it. You likely want this to be set to the value of - efs-ftp-program-args . If the connection to the gateway FTP server - is to be on a port different from 21, set efs-gateway-host to - \"#\". - - '(raptor FTP-PROGRAM FTP-PROGRAM-ARGS USER) - This is for the gateway called raptor by Eagle. After connecting to the - the gateway, the command \"user @host USER\" is issued to login - as on , where USER is an authentication username for the - gateway. After issuing the password for the remote host, efs will - send the password for USER on efs-gateway-host as an account command. - - '(interlock FTP-PROGRAM FTP-PROGRAM-ARGS) - This is for the interlock gateway. The exact login sequence is to - connect to the gateway specified by efs-gateway-host , send the - gateway password with a PASS command, send the command - \"user @\" to connect to remote host as user , - and finally to send the password for on with a second - PASS command. - - '(kerberos FTP-PROGRAM FTP-PROGRAM-ARGS KINIT-PROGRAM KINIT-PROGRAM-ARGS) - This is for the kerberos gateway where you need to run a program (kinit) to - obtain a ticket for gateway authroization first. FTP-PROGRAM should be - the name of the FTP client that you use to connect to the gateway. This - may likely be \"iftp\". FTP-PROGRAM-ARGS are the arguments that you need - to pass to FTP-PROGRAM. This is probably the value of - efs-ftp-program-args . KINIT-PROGRAM is the name of the program to - run in order to obtain a ticket. This is probably \"kinit\". - KINIT-PROGRAM-ARGS is a list og strings indicating any arguments that you - need to pass to KINIT-PROGRAM. Most likely this is nil. - - '(remsh GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM FTP-PROGRAM-ARGS) - This indicates that you wish to run FTP on your gateway using a remote shell. - GATEWAY-PROGRAM is the name of the program to use to start a remote shell. - It is assumed that it is not necessary to provide a password to start - this remote shell. Likely values are \"remsh\" or \"rsh\". - GATEWAY-PROGRAM-ARGS is a list of arguments to pass to GATEWAY-PROGRAM. - FTP-PROGRAM is the name of the FTP program on the gateway. A likely setting - of this is \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass to - FTP-PROGRAM. Most likely these should be set to the value of - efs-ftp-program-args . - - '(interactive GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM - FTP-PROGRAM-ARGS) - This indicates that you need to start an interactive login on your gatway, - using rlogin, telnet, or something similar. GATEWAY-PROGRAM is the name - of the program to use to log in to the gateway, and GATEWAY-PROGRAM-ARGS - is a list of arguments to pass to it. FTP-PROGRAM is the name of the FTP - program on the gateway. A likely setting for this variable would be - \"exec ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass - to FTP-PROGRAM. You probably want to set these to the same value as - efs-ftp-program-args . If you are using this option, read the - documentation at the top of efs-gwp.el, and see - efs-gwp-setup-term-command .") - -(defvar efs-gateway-hash-mark-size nil - "*Value of `efs-hash-mark-size' for FTP clients on `efs-gateway-host'. -See the documentation of these variables for more information.") - -(defvar efs-gateway-incoming-binary-hm-size nil - "*Value of `efs-incoming-binary-hm-size' for `efs-gateway-host'. -See documentation of these variables for more information.") - -(defvar efs-gateway-tmp-name-template "/tmp/efs" - "Template used to create temporary files when ftp-ing through a gateway. -This should be the name of the file on the gateway, and not necessarily -the name on the local host.") - -(defvar efs-gateway-mounted-dirs-alist nil - "An alist of directories cross-mounted between the gateway and local host. -Each entry is of the form \( DIR1 . DIR2 \), where DIR1 is the name of the -directory on the local host, and DIR2 is its name on the remote host. Both -DIR1 and DIR2 must be specified in directory syntax, i.e. end in a slash. -Note that we will assume that subdirs of DIR1 and DIR2 are also accessible -on both machines.") - -(defvar efs-gateway-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" - "*Regular expression to match the prompt of the gateway FTP client.") - -;;; End of gateway config variables. - -(defvar efs-tmp-name-template "/tmp/efs" - "Template used to create temporary files. -If you are worried about security, make this a directory in some -bomb-proof cave somewhere. efs does clean up its temp files, but -they do live for short periods of time.") - -(defvar efs-generate-anonymous-password t - "*If t, use a password of `user@host' when logging in as the anonymous user. -`host' is generated by the function `efs-system-fqdn'. If `system name' returns -a fully qualified domain name, `efs-system-fqdn' will return this. Otherwise, -it will attempt to use nslookup to obtain a fully qualified domain name. If -this is unsuccessful, the returned value will be the same as `system-name', -whether this is a fully qualified domain name or not. - -If a string then use that as the password. - -If nil then prompt the user for a password. - -Beware that some operating systems, such as MVS, restrict substantially -the password length. The login will fail with a weird error message -if you exceed it.") - -(defvar efs-high-security-hosts nil - "*Indicates host user pairs for which passwords should not be cached. -If non-nil, should be a regexp matching user@host constructions for which -efs should not store passwords in its internal cache.") - -;; The following regexps are tested in the following order: -;; efs-binary-file-host-regexp, efs-36-bit-binary-file-name-regexp, -;; efs-binary-file-name-regexp, efs-text-file-name-regexp. -;; File names which match nothing are transferred in 'image mode. - -;; If we're not careful, we're going to blow the regexp stack here. -;; Probably should move to a list of regexps. Slower, but safer. -;; This is not a problem in Emacs 19. -(defvar efs-binary-file-name-regexp - (concat "\\." ; the dot - ;; extensions - "\\([zZ]\\|t?gz\\|lzh\\|arc\\|zip\\|zoo\\|ta[rz]\\|dvi\\|sit\\|" - "ps\\|elc\\|gif\\|Z-part-..\\|tpz\\|exe\\|[jm]pg\\|TZ[a-z]?\\|lib\\)" - "\\(~\\|~[0-9]+~\\)?$" ; backups - "\\|" - ;; UPPER CASE LAND - "\\." - "\\(ARC\\|ELC\\|TAGS\\|EXE\\|ZIP\\|DVI\|ZOO\\|GIF\\|T?GZ\\|" - "[JM]PG\\)" - "\\([.#;][0-9]+\\)?$" ; versions - ) - "*Files whose names match this regexp will be considered to be binary. -By binary here, we mean 8-bit binary files (the usual unix binary files). -If nil, no files will be considered to be binary.") - -(defvar efs-binary-file-host-regexp nil - "*All files on hosts matching this regexp are treated as 8-bit binary. -Setting this to nil, inhibits this feature.") - -(defvar efs-36-bit-binary-file-name-regexp nil - "*Files whose names match this regexp will be considered to PDP 10 binaries. -These are 36-bit word-aligned binary files. This is really only relevant for -files on PDP 10's, and similar machines. If nil, no files will be considered -to be PDP 10 binaries.") - -(defvar efs-text-file-name-regexp ".*" - "*Files whose names match this regexp will be considered to be text files.") - -(defvar efs-prompt-for-transfer-type nil - "*If non-nil, efs will prompt for the transfer type for each file transfer. -The command efs-prompt-for-transfer-type can be used to toggle its value.") - -(defvar efs-treat-crlf-as-nl nil - "*Controls how file systems using CRLF as end of line are treated. -If non-nil, such file systems will be considered equivalent to those which use -LF as end of line. This is particularly relevant to transfers between DOS -systems and UNIX. Setting this to be non-nil will cause all file transfers -between DOS and UNIX systems to use be image or binary transfers.") - -(defvar efs-send-hash t - "*If non-nil, send the HASH command to the FTP client.") - -(defvar efs-hash-mark-size nil - "*Default size, in bytes, between hash-marks when transferring a file. -If this is nil then efs will attempt to assign a value based on the -output of the HASH command. Also, if this variable is incorrectly set, -then efs will try to correct it based on the size of the last file -transferred, and the number hashes outputed by the client during the -transfer. - -The variable `efs-gateway-hash-mark-size' defines the corresponding value -for the FTP client on the gateway, if you are using a gateway. - -Some client-server combinations do not correctly compute the number of hash -marks for incoming binary transfers. In this case, a separate variable -`efs-incoming-binary-hm-size' can be used to set a default value of the -hash mark size for incoming binary transfers.") - -(defvar efs-incoming-binary-hm-size nil - "*Default hash mark size for incoming binary transfers. -If this is nil, incoming binary transfers will use `efs-hash-mark-size' as -the default. See the documentation of this variable for more details.") - -(defvar efs-verbose t - "*If non-NIL then be chatty about interaction with the FTP process. -If 0 do not give % transferred reports for asynchronous commands and status -reports for commands verifying file modtimes, but report on everything else.") - -(defvar efs-message-interval 0 - "*Defines the minimum time in seconds between status messages. -A new status message is not displayed, if one has already been given -within this period of time.") - -(defvar efs-max-ftp-buffer-size 3000 - "*Maximum size in characters of FTP process buffer, before it is trimmed. -The buffer is trimmed to approximately half this size. Setting this to nil -inhibits trimming of FTP process buffers.") - -(defvar efs-ls-cache-max 5 - "*Maximum number of directory listings to be cached in efs-ls-cache.") - -(defvar efs-mode-line-format " ftp(%d)" - "Format string used to determine how FTP activity is shown on the mode line. -It is passed to format, with second argument the number of active FTP -sessions as an integer.") - -(defvar efs-show-host-type-in-dired t - "If non-nil, show the system type on the mode line of remote dired buffers.") - -(defvar efs-ftp-activity-function nil - "Function called to indicate FTP activity. -It must have exactly one argument, the number of active FTP sessions as an -integer.") - -(defvar efs-ftp-program-name "ftp" - "Name of FTP program to run.") - -(defvar efs-ftp-program-args '("-i" "-n" "-g" "-v") - "*A list of arguments passed to the FTP program when started.") - -(defvar efs-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" - "*Regular expression to match the prompt of your FTP client.") - -(defvar efs-nslookup-program "nslookup" - "*If non-NIL then a string naming nslookup program." ) - -(defvar efs-nslookup-on-connect nil - "*If non-NIL then use nslookup to resolve the host name before connecting.") - -(defvar efs-nslookup-threshold 1000 - "How many iterations efs waits on the nslookup program. -Applies when nslookup is used to compute a fully qualified domain name -for the local host, in the case when `system-name' does not return one. -If you set this to nil, efs will wait an arbitrary amount of time to get -output.") - -(defvar efs-remote-shell-file-name - (if (memq system-type '(hpux usg-unix-v)) ; hope that's right - "remsh" - "rsh") - "Remote shell used by efs.") - -(defvar efs-remote-shell-takes-user - (null (null (memq system-type '(aix aix-v3 hpux silicon-graphics-unix - berkeley-unix)))) - ;; Complete? Doubt it. - "Set to non-nil if your remote shell command takes \"-l USER\".") - -(defvar efs-make-backup-files efs-unix-host-types - "*A list of operating systems for which efs will make Emacs backup files. -The backup files are made on the remote host. - -For example: -'\(unix sysV-unix bsd-unix apollo-unix dumb-unix\) makes sense, but -'\(unix vms\) would be silly, since vms makes its own backups.") - -;; Is this variable really useful? We should try to figure a way to -;; do local copies on a remote machine that doesn't take forever. -(defvar efs-backup-by-copying nil - "*Version of `backup by copying' for remote files. -If non-nil, remote files will be backed up by copying, instead of by renaming. -Note the copying will be done by moving the file through the local host -- a -very time consuming operation.") - -;;; Auto-save variables. Relevant for auto-save.el - -(defvar efs-auto-save 0 - "*If 1, allows efs files to be auto-saved. -If 0, suppresses auto-saving of efs files. -Don't use any other value.") - -(defvar efs-auto-save-remotely nil - "*Determines where remote files are auto-saved. - -If nil, auto-saves for remote files will be written in `auto-save-directory' -or `auto-save-directory-fallback' if this isn't defined. - -If non-nil, causes the auto-save file for an efs file to be written in -the remote directory containing the file, rather than in a local directory. -For remote files, this overrides a non-nil `auto-save-directory'. Local files -are unaffected. If you want to use this feature, you probably only want to -set this true in a few buffers, rather than globally. You might want to give -each buffer its own value using `make-variable-buffer-local'. It is usually -a good idea to auto-save remote files locally, because it is not only faster, -but provides protection against a connection going down. - -See also variable `efs-auto-save'.") - -(defvar efs-short-circuit-to-remote-root nil - "*Defines whether \"//\" short-circuits to the remote or local root.") - -;; Can we somehow grok this from system type? No. -(defvar efs-local-apollo-unix - (eq 0 (string-match "//" (or (getenv "HOME") (getenv "SHELL") ""))) - "*Defines whether the local machine is an apollo running Domain. -This variable has nothing to do with efs, and should be basic to all -of emacs.") - -(defvar efs-root-umask nil - "*umask to use for root logins.") - -(defvar efs-anonymous-umask nil - "*umask to use for anonymous logins.") - -(defvar efs-umask nil - "*umask to use for efs sessions. -If this is nil, then the setting of umask on the local host is used.") - -;; Eliminate these variables when Sun gets around to getting its FTP server -;; out of the stone age. -(defvar efs-ding-on-umask-failure t - "*Ring the bell if the umask command fails on a unix host. Many servers don't -support this command, so if you get a lot of annoying failures, set this -to nil.") - -(defvar efs-ding-on-chmod-failure t - "*Ring the bell if the chmod command fails on a unix host. Some servers don't -support this command, so if you get a lot of annoying failures, set this -to nil.") - -;; Please let us know if you can contribute more entries to this guessing game. -(defvar efs-nlist-cmd - (cond - ;; Covers Ultrix, SunOS, and NeXT. - ((eq system-type 'berkeley-unix) - "ls") - ((memq system-type '(hpux aix-v3 silicon-graphics-unix)) - "nlist") - ;; Blind guess - ("ls")) - "*FTP client command for getting a brief listing (NLST) from the FTP server. -We try to guess this based on the local system-type, but obviously if you -are using a gateway, you'll have to set it yourself.") - -(defvar efs-compute-remote-buffer-file-truename nil - "*If non-nil, `buffer-file-truename' will be computed for remote buffers. -In emacs 19, each buffer has a local variable, `buffer-file-truename', -which is used to ensure that symbolic links will not confuse emacs into -visiting the same file with two buffers. This variable is computed by -chasing all symbolic links in `buffer-file-name', both at the level of the -file and at the level of all parent directories. Since this operation can be -very time-consuming over FTP, this variable can be used to inhibit it.") - -(defvar efs-buffer-name-case nil - "*Selects the case used for buffer names of case-insensitive file names. -Case-insensitive file names are files on hosts whose host type is in -`efs-case-insensitive-host-types'. - -If this is 'up upper case is used, if it is 'down lower case is used. -If this has any other value, the case is inherited from the name used -to access the file.") - -(defvar efs-fancy-buffer-names "%s@%s" - "Format used to compute names of buffers attached to remote files. - -If this is nil, buffer names are computed in the usual way. - -If it is a string, then the it is passed to format with second and third -arguments the host name and file name. - -Otherwise, it is assumed to be function taking three arguments, the host name, -the user name, and the truncated file name. It should returns the name to -be used for the buffer.") - -(defvar efs-verify-anonymous-modtime nil - "*Determines if efs checks modtimes for remote files on anonymous logins. -If non-nil, efs runs `verify-visited-file-modtime' for remote files on -anonymous ftp logins. Since verify-visited-file-modtime slows things down, -and most people aren't editing files on anonymous ftp logins, this is nil -by default.") - -(defvar efs-verify-modtime-host-regexp ".*" - "*Regexp to match host names for which efs checks file modtimes. -If non-nil, efs will run `verify-visited-file-modtime' for remote -files on hosts matching this regexp. If nil, verify-visited-file-modtime -is supressed for all remote hosts. This is tested before -`efs-verify-anonymous-modtime'.") - -(defvar efs-maximize-idle nil - "*If non-nil, efs will attempt to maximize the idle time out period. -At some idle moment in the connection after login, efs will attempt to -set the idle time out period to the maximum amount allowed by the server. -It applies only to non-anonymous logins on unix hosts.") - -(defvar efs-expire-ftp-buffers t - "*If non-nil ftp buffers will be expired. -The buffers will be killed either after `efs-ftp-buffer-expire-time' has -elapsed with no activity, or the remote FTP server has timed out.") - -(defvar efs-ftp-buffer-expire-time nil - "*If non-nil, the time after which ftp buffers will be expired. -If nil, ftp buffers will be expired only when the remote server has timed out. -If an integer, ftp buffers will be expired either when the remote server -has timed out, or when this many seconds on inactivity has elapsed.") - -;; If you need to increase this variable much, it is likely that -;; the true problem is timing errors between the efs process filter -;; and the FTP server. This could either be caused by the server -;; not following RFC959 response codes, or a bug in efs. In either -;; case please report the problem to us. If it's a bug, we'll fix it. -;; If the server is at fault we may try to do something. Our rule -;; of thumb is that we will support non-RFC959 behaviour, as long as -;; it doesn't risk breaking efs for servers which behave properly. - -(defvar efs-retry-time 5 - "*Number of seconds to wait before retrying if data doesn't arrive. -The FTP command isn't retried, rather efs just takes a second look -for the data file. This might need to be increased for very slow FTP -clients.") - -(defvar efs-pty-check-threshold 1000 - "*How long efs waits before deciding that it doesn't have a pty. -Specifically it is the number of iterations through `accept-process-output' -that `efs-pty-p' waits before deciding that the pty is really a pipe. -Set this to nil to inhibit checking for pty's. If efs seems to be -mistaking some pty's for pipes, try increasing this number.") - -(defvar efs-pty-check-retry-time 5 - "*Number of seconds that efs waits before retrying a pty check. -This can be lengthened, if your FTP client is slow to start.") - -(defvar efs-suppress-abort-recursive-edit-and-then nil - "*If non-nil, `efs-abort-recursive-edit-and-then' will not run its function. -This means that when a recursive edit is in progress, automatic popping of the -FTP process buffer, and automatic popping of the bug report buffer will not -work. `efs-abort-recursive-edit-and-then' works by forking a \"sleep 0\" -process. On some unix implementations the forked process might be of the same -size as the original GNU Emacs process. Forking such a large process just to -do a \"sleep 0\" is probably not good.") - -(defvar efs-ftp-buffer-format "*ftp %s@%s*" - "Format to construct the name of FTP process buffers. -This string is fed to `format' with second and third arguments the user -name and host name.") -;; This does not affect the process name of the FTP client process. -;; That is always *ftp USER@HOST* - -(defvar efs-debug-ftp-connection nil - "*If non-nil, the user will be permitted to debug the FTP connection. -This means that typing a C-g to the FTP process filter will give the user -the option to type commands at the FTP connection. Normally, the connection -is killed first. Note that doing this may result in the FTP process filter -getting out of synch with the FTP client, so using this feature routinely -isn't recommended.") - -(defvar efs-use-passive-mode nil - "*If non-nil, the ftp client will specify passive mode for all transfers.") - -;;; Hooks and crooks. - -(defvar efs-ftp-startup-hook nil - "Hook to run immediately after starting the FTP client. -This hook is run before the FTP OPEN command is sent.") - -(defvar efs-ftp-startup-function-alist nil - "Association list of functions to running after FTP login. -This should be an alist of the form '\(\(REGEXP . FUNCTION\) ...\), where -REGEXP is a regular expression matched against the name of the remote host, -and FUNCTION is a function of two arguments, HOST and USER. REGEXP is -compared to the host name with `case-fold-search' bound to t. Only the first -match in the alist is run.") - -(defvar efs-load-hook nil - "Hook to run immediately after loading efs.el. -You can use it to alter definitions in efs.el, but why would you want -to do such a thing?") - -;;;; ----------------------------------------------------------- -;;;; Regexps for parsing FTP server responses. -;;;; ----------------------------------------------------------- -;;; -;;; If you have to tune these variables, please let us know, so that -;;; we can get them right in the next release. - -(defvar efs-multi-msgs - ;; RFC959 compliant codes - "^[1-5][0-5][0-7]-") -;; Regexp to match the start of an FTP server multiline reply. - -(defvar efs-skip-msgs - ;; RFC959 compliant codes - (concat - "^110 \\|" ; Restart marker reply. - "^125 \\|" ; Data connection already open; transfer starting. - "^150 ")) ; File status OK; about to open connection. -;; Regexp to match an FTP server response which we wish to ignore. - -(defvar efs-cmd-ok-msgs - ;; RFC959 compliant - "^200 \\|^227 ") -;; Regexp to match the server command OK response. -;; Because PORT commands return this we usually ignore it. However, it is -;; a valid response for TYPE, SITE, and a few other commands (cf. RFC 959). -;; If we are explicitly sending a PORT, or one of these other commands, -;; then we don't want to ignore this response code. Also use this to match -;; the return code for PASV, as some clients burp these things out at odd -;; times. - -(defvar efs-pending-msgs - ;; RFC959 compliant - "^350 ") ; Requested file action, pending further information. -;; Regexp to match the \"requested file action, pending further information\" -;; message. These are usually ignored, except if we are using RNFR to test for -;; file existence. - -(defvar efs-cmd-ok-cmds - (concat - "^quote port \\|^type \\|^quote site \\|^chmod \\|^quote noop\\|" - "^quote pasv\\|^passive")) -;; Regexp to match commands for which efs-cmd-ok-msgs is a valid server -;; response for success. - -(defvar efs-passwd-cmds - "^quote pass \\|^quote acct \\|^quote site gpass ") -;; Regexp to match commands for sending passwords. -;; All text following (match-end 0) will be replaced by "Turtle Power!" - -(defvar efs-bytes-received-msgs - ;; Strictly a client response - "^[0-9]+ bytes ") -;; Regexp to match the reply from the FTP client that it has finished -;; receiving data. - -(defvar efs-server-confused-msgs - ;; ka9q uses this to indicate an incorrectly set transfer mode, and - ;; then does send a second completion code for the command. This does - ;; *not* conform to RFC959. - "^100 Warning: type is ") -;; Regexp to match non-standard response from the FTP server. This can -;; sometimes be the result of an incorrectly set transfer mode. In this case -;; we do not rely on the server to tell us when the data transfer is complete, -;; but check with the client. - -(defvar efs-good-msgs - (concat - ;; RFC959 compliant codes - "^2[01345][0-7] \\|" ; 2yz = positive completion reply - "^22[02-7] \\|" ; 221 = successful logout - ; (Sometimes get this with a timeout, - ; so treat as fatal.) - "^3[0-5][0-7] \\|" ; 3yz = positive intermediate reply - ;; passive - "^[Pp]assive \\|" - ;; client codes - "^[Hh]ash mark ")) -;; Response to indicate that the requested action was successfully completed. - -(defvar efs-failed-msgs - (concat - ;; RFC959 compliant codes - "^120 \\|" ; Service ready in nnn minutes. - "^450 \\|" ; File action not taken; file is unavailable, or busy. - "^452 \\|" ; Insufficient storage space on system. - "^5[0-5][0-7] \\|" ; Permanent negative reply codes. - ;; When clients tell us that a file doesn't exist, or can't access. - "^\\(local: +\\)?/[^ ]* +" - "\\([Nn]o such file or directory\\|[Nn]ot a plain file\\|" - "The file access permissions do not allow \\|Is a directory\\b\\)")) -;; Regexp to match responses for failed commands. However, the ftp connection -;; is assumed to be good. - -(defvar efs-fatal-msgs - (concat - ;; RFC959 codes - "^221 \\|" ; Service closing control connection. - "^421 \\|" ; Service not available. - "^425 \\|" ; Can't open data connection. - "^426 \\|" ; Connection closed, transfer aborted. - "^451 \\|" ; Requested action aborted, local error in processing. - ;; RFC959 non-compliant codes - "^552 Maximum Idle Time Exceded\\.$\\|" ; Hellsoft server uses this to - ; indicate a timeout. 552 is - ; supposed to be used for exceeded - ; storage allocation. Note that - ; they also misspelled the error - ; message. - ;; client problems - "^ftp: \\|^Not connected\\|^rcmd: \\|^No control connection\\|" - "^unknown host\\|: unknown host$\\|^lost connection\\|" - "^[Ss]egmentation fault\\|" - ;; Make sure that the "local: " isn't just a message about a file. - "^local: [^/]\\|" - ;; Gateways - "^iftp: cannot authenticate to server\\b" - )) -;; Regexp to match responses that something has gone drastically wrong with -;; either the client, server, or connection. We kill the ftp process, and start -;; anew. - -(defvar efs-unknown-response-msgs - "^[0-9][0-9][0-9] ") -;; Regexp to match server response codes that we don't understand. This -;; is tested after all the other regexp, so it can match everything. - -(defvar efs-pasv-msgs - ;; According to RFC959. - "^227 .*(\\([0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+\\))$") -;; Matches the output of a PASV. (match-beginning 1) and (match-end 1) -;; must bracket the IP address and port. - -(defvar efs-syst-msgs "^215 \\|^210 ") -;; 215 is RFC959. Plan 9 FTP server returns a 210. 210 is not assigned in -;; RFC 959. -;; The plan 9 people tell me that they fixed this. -- sr 18/4/94 -;; Matches the output of a SYST. - -(defvar efs-mdtm-msgs - (concat - "^213 [0-9][0-9][0-9][0-9][0-9][0-9][0-9]" - "[0-9][0-9][0-9][0-9][0-9][0-9][0-9]$")) -;; Regexp to match the output of a quote mdtm command. - -(defvar efs-idle-msgs - "^200 [^0-9]+ \\([0-9]+\\)[^0-9]* max \\([0-9]+\\)") -;; Regexp to match the output of a SITE IDLE command. -;; Match 1 should refer to the current idle time, and match 2 the maximum -;; idle time. - -(defvar efs-write-protect-msgs "^532 ") ; RFC959 -;; Regexp to match a server ressponse to indicate that a STOR failed -;; because of insufficient write privileges. - -(defvar efs-hash-mark-msgs - "[hH]ash mark [^0-9]*\\([0-9]+\\)") -;; Regexp matching the FTP client's output upon doing a HASH command. - -(defvar efs-xfer-size-msgs - (concat - ;; UN*X - "^150 .* connection for .* (\\([0-9]+\\) bytes)\\|" - ;; Wollongong VMS server. - "^125 .* transfer started for .* (\\([0-9]+\\) bytes)\\|" - ;; TOPS-20 server - "^150 .* retrieve of .* ([0-9]+ pages?, \\([0-9]+\\) 7-bit bytes)")) -;; Regular expression used to determine the number of bytes -;; in a FTP transfer. The first (match-beginning #) which is non-nil is assumed -;; to give the size. - -(defvar efs-expand-dir-msgs "^550 \\([^: ]+\\):") -;; Regexp to match the error response from a "get ~sandy". -;; By parsing the error, we can get a quick expansion of ~sandy -;; According to RFC 959, should be a 550. - -(defvar efs-gateway-fatal-msgs - "No route to host\\|Connection closed\\|No such host\\|Login incorrect") -;; Regular expression matching messages from the rlogin / telnet process that -;; indicates that logging in to the gateway machine has gone wrong. - -(defvar efs-too-many-users-msgs - ;; The test for "two many" is because some people can't spell. - ;; I allow for up to two adjectives before "users". - (concat - "\\b[Tt][wo]o many\\( +[^ \n]+\\)?\\( +[^ \n]+\\)? +users\\b\\|" - "\\btry back later\\b")) -;; Regular expresion to match what servers output when there are too many -;; anonymous logins. It is assumed that this is part of a 530 or 530- response -;; to USER or PASS. - -;;;; ------------------------------------------------------------- -;;;; Buffer local FTP process variables -;;;; ------------------------------------------------------------- - -;;; Variables buffer local to the process buffers are -;;; named with the prefix efs-process- - -(defvar efs-process-q nil) -;; List of functions to be performed asynch. -(make-variable-buffer-local 'efs-process-q) - -(defvar efs-process-cmd-waiting nil) -;; Set to t if a process has a synchronous cmd waiting to execute. -;; In this case, it will allow the synch. cmd to run before returning to -;; the cmd queue. -(make-variable-buffer-local 'efs-process-cmd-waiting) - -(defvar efs-process-server-confused nil) -(make-variable-buffer-local 'efs-process-server-confused) - -(defvar efs-process-cmd nil) -;; The command currently being executed, as a string. -(make-variable-buffer-local 'efs-process-cmd) - -(defvar efs-process-xfer-size 0) -(make-variable-buffer-local 'efs-process-xfer-size) - -(defvar efs-process-umask nil) -;; nil if the umask hash not been set -;; an integer (the umask) if the umask has been set -(make-variable-buffer-local 'efs-process-umask) - -(defvar efs-process-idle-time nil) -;; If non-nil, the idle time of the server in seconds. -(make-variable-buffer-local 'efs-process-idle-time) - -(defvar efs-process-busy nil) -(make-variable-buffer-local 'efs-process-busy) - -(defvar efs-process-result-line "") -(make-variable-buffer-local 'efs-process-result-line) - -(defvar efs-process-result nil) -(make-variable-buffer-local 'efs-process-result) - -(defvar efs-process-result-cont-lines "") -(make-variable-buffer-local 'efs-process-result-cont-lines) - -(defvar efs-process-msg "") -(make-variable-buffer-local 'efs-process-msg) - -(defvar efs-process-nowait nil) -(make-variable-buffer-local 'efs-process-nowait) - -(defvar efs-process-string "") -(make-variable-buffer-local 'efs-process-string) - -(defvar efs-process-continue nil) -(make-variable-buffer-local 'efs-process-continue) - -(defvar efs-process-hash-mark-count 0) -(make-variable-buffer-local 'efs-process-hash-mark-count) - -(defvar efs-process-hash-mark-unit nil) -(make-variable-buffer-local 'efs-process-hash-mark-unit) - -(defvar efs-process-last-percent -1) -(make-variable-buffer-local 'efs-process-last-percent) - -(defvar efs-process-host nil) -(make-variable-buffer-local 'efs-process-host) - -(defvar efs-process-user nil) -(make-variable-buffer-local 'efs-process-user) - -(defvar efs-process-host-type nil) -;; Holds the host-type as a string, for showing it on the mode line. -(make-variable-buffer-local 'efs-process-host-type) - -(defvar efs-process-xfer-type nil) -;; Set to one of 'ascii, 'ebcdic, 'image, 'tenex, or nil to indicate -;; the current setting of the transfer type for the connection. nil means -;; that we don't know. -(make-variable-buffer-local 'efs-process-xfer-type) - -(defvar efs-process-client-altered-xfer-type nil) -;; Sometimes clients alter the xfer type, such as doing -;; an ls it is changed to ascii. If we are using quoted commands -;; to do xfers the client doesn't get a chance to set it back. -(make-variable-buffer-local 'efs-process-client-altered-xfer-type) - -(defvar efs-process-prompt-regexp nil) -;; local value of prompt of FTP client. -(make-variable-buffer-local 'efs-process-prompt-regexp) - -(defvar efs-process-cmd-counter 0) -;; Counts FTP commands, mod 16. -(make-variable-buffer-local 'efs-process-cmd-counter) - -;;;; ------------------------------------------------------------ -;;;; General Internal Variables. -;;;; ------------------------------------------------------------ - -;;; For the byte compiler -;; -;; These variables are usually unbound. We are just notifying the -;; byte compiler that we know what we are doing. - -(defvar bv-length) ; getting file versions. -(defvar default-file-name-handler-alist) ; for file-name-handler-alist -(defvar efs-completion-dir) ; for file name completion predicates -(defvar dired-directory) ; for default actions in interactive specs -(defvar dired-local-variables-file) ; for inhibiting child look ups -(defvar dired-in-query) ; don't clobber dired queries with stat messages -(defvar after-load-alist) ; in case we're in emacs 18. -(defvar comint-last-input-start) -(defvar comint-last-input-end) -(defvar explicit-shell-file-name) - -;;; fluid vars - -(defvar efs-allow-child-lookup t) -;; let-bind to nil, if want to inhibit child lookups. - -(defvar efs-nested-cmd nil) -;; let-bound to t, when a cmd is executed by a cont or pre-cont. -;; Such cmds will never end by looking at the next item in the queue, -;; if they are run synchronously, but rely on their calling function -;; to do this. - -;;; polling ftp buffers - -(defvar efs-ftp-buffer-poll-time 300 - "Period, in seconds, which efs will poll ftp buffers for activity. -Used for expiring \(killing\) inactive ftp buffers.") - -(defconst efs-ftp-buffer-alist nil) -;; alist of ftp buffers, and the total number of seconds that they -;; have been idle. - -;;; load extensions - -(defvar efs-load-lisp-extensions '(".elc" ".el" "") - "List of extensions to try when loading lisp files.") - -;;; mode-line - -(defvar efs-mode-line-string "") -;; Stores the string that efs displays on the mode line. - -;;; data & temporary buffers - -(defvar efs-data-buffer-name " *ftp data*") -;; Buffer name to hold directory listing data received from ftp process. - -(defvar efs-data-buffer-name-2 " *ftp data-2*") -;; A second buffer name in which to hold directory listings. -;; Used for listings which are made during another directory listing. - -;;; process names - -(defvar efs-ctime-process-name-format "*efs ctime %s*") -;; Passed to format with second arg the host name. - -;;; For temporary files. - -;; This is a list of symbols. -(defconst efs-tmp-name-files ()) -;; Here is where these symbols live: -(defconst efs-tmp-name-obarray (make-vector 7 0)) -;; We put our version of the emacs PID here: -(defvar efs-pid nil) - -;;; For abort-recursive-edit - -(defvar efs-abort-recursive-edit-data nil) -(defvar efs-abort-recursive-edit-delay 5) -;; Number of seconds after which efs-abort-recursive-edit-and-then -;; will decide not to runs its sentinel. The assumption is that something -;; went wrong. - -;;; hashtables (Use defconst's to clobber any user silliness.) - -(defconst efs-files-hashtable (efs-make-hashtable 97)) -;; Hash table for storing directories and their respective files. - -(defconst efs-expand-dir-hashtable (efs-make-hashtable)) -;; Hash table of tilde expansions for remote directories. - -(defconst efs-ls-converter-hashtable (efs-make-hashtable 37)) -;; Hashtable for storing functions to convert listings from one -;; format to another. Keys are the required switches, and the values -;; are alist of the form ((SWITCHES . CONVERTER)...) where is SWITCHES -;; are the listing switches for the original listing, and CONVERTER is a -;; function of one-variable, the listing-type, to do the conversion -;; on data in the current buffer. SWITCHES is either a string, or nil. -;; nil means that the listing can be converted from cache in -;; efs-files-hashtable, a string from cache in efs-ls-cache. For the latter, -;; listings with no switches (dumb listings), represent SWITCHES as a string -;; consisting only of the ASCII null character. - -;;; cache variables (Use defconst's to clobber any user sillines.) - -(defconst efs-ls-cache nil - "List of results from efs-ls. -Each entry is a list of four elements, the file listed, the switches used -\(nil if none\), the listing string, and whether this string has already been -parsed.") - -(defvar efs-ls-uncache nil) -;; let-bind this to t, if you want to be sure that efs-ls will replace any -;; cache entries. - -;; This is a cache to see if the user has changed -;; completion-ignored-extensions. -(defconst efs-completion-ignored-extensions completion-ignored-extensions - "This variable is internal to efs. Do not set. -See completion-ignored-extensions, instead.") - -;; We cache the regexp we use for completion-ignored-extensions. This -;; saves building a string every time we do completion. String construction -;; is costly in emacs. -(defconst efs-completion-ignored-pattern - (mapconcat (function - (lambda (s) (if (stringp s) - (concat (regexp-quote s) "$") - "/"))) ; / never in filename - efs-completion-ignored-extensions - "\\|") - "This variable is internal to efs. Do not set. -See completion-ignored-extensions, instead.") - -(defvar efs-system-fqdn nil - "Cached value of the local systems' fully qualified domain name.") - -;;; The file-type-alist - -;; efs-file-type-alist is an alist indexed by host-type -;; which stores data on how files are structured on the given -;; host-type. Each entry is a list of three elements. The first is the -;; definition of a `byte', the second the native character representation, -;; and the third, the file structure. -;; -;; Meanings of the symbols: -;; ------------------------ -;; The byte symbols: -;; 8-bit = bytes of 8-bits -;; 36-bit-wa = 36-bit word aligned. Precisely, the addressing unit is that -;; of a PDP-10 using the "<440700,,0> byte pointer". -;; -;; The native character set symbols: -;; 8-ascii = 8-bit NVT-ASCII -;; 7-ascii = 7-bit ascii as on a PDP-10 -;; ebcdic = EBCDIC as on an IBM mainframe -;; lispm = the native character set on a lispm (Symbolics and LMI) -;; mts = native character representation in the Michigan Terminal System -;; (which runs on IBM and Amdal mainframes), similar to ebcdic -;; -;; The file structure symbols: -;; -;; file-nl = data is stored as a contiguous sequence of data bytes -;; with EOL denoted by . -;; file-crlf = data is stored as a contiguous sequence of data bytes -;; with EOL denoted by -;; record = data is stored as a sequence of records -;; file-lispm = data as stored on a lispm. i.e. a sequence of bits -;; with EOL denoted by character code 138 (?) -;; -;; If we've messed anything up here, please let us know. - -(defvar efs-file-type-alist - '((unix . (8-bit 8-ascii file-nl)) - (sysV-unix . (8-bit 8-ascii file-nl)) - (bsd-unix . (8-bit 8-ascii file-nl)) - (apollo-unix . (8-bit 8-ascii file-nl)) - (dumb-apollo-unix . (8-bit 8-ascii file-nl)) - (dumb-unix . (8-bit 8-ascii file-nl)) - (super-dumb-unix . (8-bit 8-ascii file-nl)) - (guardian . (8-bit ascii file-nl)) - (plan9 . (8-bit 8-ascii file-nl)) - (dos . (8-bit 8-ascii file-crlf)) - (ms-unix . (8-bit 8-ascii file-crlf)) - (netware . (8-bit 8-ascii file-crlf)) - (os2 . (8-bit 8-ascii file-crlf)) - (tops-20 . (36-bit-wa 7-ascii file-crlf)) - (mpe . (8-bit 8-ascii record)) - (mvs . (8-bit ebcdic record)) - (cms . (8-bit ebcdic record)) - (cms-knet . (8-bit ebcdic record)) - (mts . (8-bit mts record)) ; mts seems to have its own char rep. - ; Seems to be close to ebcdic, but not the same. - (dos-distinct . (8-bit 8-ascii file-crlf)) - (ka9q . (8-bit 8-ascii file-crlf)) - (vms . (8-bit 8-ascii record)) ; The mysteries of VMS's RMS. - (hell . (8-bit 8-ascii file-crlf)) - (vos . (8-bit 8-ascii record)) - (ti-explorer . (8-bit lispm file-lispm)) ; lispms use a file structure, but - ; use an out of range char to - ; indicate EOL. - (ti-twenex . (8-bit lispm file-lispm)) - (nos-ve . (8-bit 8-ascii record)) - (coke . (8-bit 8-ascii file-nl)) ; only support 8-bit beverages - (nil . (8-bit 8-ascii file-nl)))) ; the local host - -;;; Status messages - -(defvar efs-last-message-time -86400) ; yesterday -;; The time of the last efs status message. c.f. efs-message-interval - -;;; For handling dir listings - -;; This MUST match all the way to to the start of the filename. -;; This version corresponds to what dired now uses (sandy, 14.1.93) -(defvar efs-month-and-time-regexp - (concat - " \\([0-9]+\\) +" ; file size - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct" - ; June and July are for HP-UX 9.0 - "\\|Nov\\|Dec\\) \\([ 0-3][0-9]\\)\\(" - " [012][0-9]:[0-6][0-9] \\|" ; time - " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo - ; HP-UX, A/UX - " [12][90][0-9][0-9] \\)" ; year on AIX - )) - -(defvar efs-month-alist - '(("Jan" . 1) ("Feb". 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) - ("June" . 6) ("Jul" . 7) ("July" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) - ("Nov" . 11) ("Dec" . 12))) - -;; Matches the file modes, link number, and owner string. -;; The +/- is for extended file access permissions. -(defvar efs-modes-links-owner-regexp - (concat - "\\([^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ]\\)[-+]? *\\([0-9]+\\)" - " +\\([^ ]+\\) ")) - -;;;; --------------------------------------------------------------- -;;;; efs-dired variables -;;;; --------------------------------------------------------------- - -;; These variables must be here, instead of in efs-dired.el, because -;; the efs-HOST-TYPE.el files need to add to it. -(defvar efs-dired-re-exe-alist nil - "Association list of regexps which match file lines of executable files.") - -(defvar efs-dired-re-dir-alist nil - "Association list of regexps which match file lines of subdirectories.") - -(defvar efs-dired-host-type nil - "Host type of a dired buffer. \(buffer local\)") -(make-variable-buffer-local 'efs-dired-host-type) - -(defvar efs-dired-listing-type nil - "Listing type of a dired buffer. \(buffer local\)") -(make-variable-buffer-local 'efs-dired-listing-type) - -(defvar efs-dired-listing-type-string nil) -(make-variable-buffer-local 'efs-dired-listing-type-string) - -;;;; ------------------------------------------------------------- -;;;; New error symbols. -;;;; ------------------------------------------------------------- - -(put 'ftp-error 'error-conditions '(ftp-error file-error error)) -;; (put 'ftp-error 'error-message "FTP error") - - -;;;; ============================================================= -;;;; >3 -;;;; Utilities -;;;; ============================================================= - -;;; ------------------------------------------------------------------- -;;; General Macros (Make sure that macros are defined before they're -;;; used, for the byte compiler. -;;; ------------------------------------------------------------------- - -(defmacro efs-kbd-quit-protect (proc &rest body) - ;; When an efs function controlling an FTP connection gets a kbd-quit - ;; this tries to make sure that everything unwinds consistently. - (let ((temp (make-symbol "continue"))) - (list 'let - (list '(quit-flag nil) - '(inhibit-quit nil) - (list temp t)) - (list - 'while temp - (list 'setq temp nil) - (list - 'condition-case nil - (cons 'progn - body) - (list 'quit - (list 'setq temp - (list 'efs-kbd-quit-protect-cover-quit proc)))))))) - -(defun efs-kbd-quit-protect-cover-quit (proc) - ;; This function exists to keep the macro expansion of the - ;; efs-kbd-quit-protect down to a reasonable size. - (let ((pop-up-windows t) - (buff (get-buffer (process-buffer proc))) - res) - (if (save-window-excursion - (if buff - (progn - (pop-to-buffer buff) - (goto-char (point-max)) - (recenter (- (window-height) - 2)))) - (setq res (efs-kill-ftp-buffer-with-prompt proc buff))) - (progn - (if (eq res 0) - (if (eq (selected-window) - (minibuffer-window)) - (efs-abort-recursive-edit-and-then - (function - (lambda (buff) - (if (get-buffer buff) - (display-buffer buff)))) - buff) - (if (get-buffer buff) - (display-buffer buff)) - (signal 'quit nil)) - (if (eq (selected-window) (minibuffer-window)) - (abort-recursive-edit) - (signal (quote quit) nil))) - nil) - (sit-for 0) - (message "Waiting on %s..." (or (car (efs-parse-proc-name proc)) - "a whim")) - t))) - -(put 'efs-kbd-quit-protect 'lisp-indent-hook 1) - -(defmacro efs-save-buffer-excursion (&rest forms) - "Execute FORMS, restoring the current buffer afterwards. -Unlike, save-excursion, this does not restore the point." - (let ((temp (make-symbol "saved-buff"))) - (list 'let - (list (list temp '(current-buffer))) - (list 'unwind-protect - (cons 'progn forms) - (list 'condition-case nil - (list 'set-buffer temp) - '(error nil)))))) - -(put 'efs-save-buffer-excursion 'lisp-indent-hook 0) - -(defmacro efs-unquote-dollars (string) - ;; Unquote $$'s to $'s in STRING. - (` (let ((string (, string)) - (start 0) - new) - (while (string-match "\\$\\$" string start) - (setq new (concat new (substring - string start (1+ (match-beginning 0)))) - start (match-end 0))) - (if new - (concat new (substring string start)) - string)))) - -(defmacro efs-get-file-part (path) - ;; Given PATH, return the file part used for looking up the file's entry - ;; in a hashtable. - ;; This need not be the same thing as file-name-nondirectory. - (` (let ((file (file-name-nondirectory (, path)))) - (if (string-equal file "") - "." - file)))) - -(defmacro efs-ftp-path-macro (path) - ;; Just a macro version of efs-ftp-path, for speed critical - ;; situations. Could use (inline ...) instead, but not everybody - ;; uses the V19 byte-compiler. Also, doesn't call efs-save-match-data, - ;; but assumes that the calling function does it. - (` - (let ((path (, path))) - (or (string-equal path efs-ftp-path-arg) - (setq efs-ftp-path-res - (and (string-match efs-path-regexp path) - (let ((host (substring path (match-beginning 2) - (match-end 2))) - (user (and (match-beginning 1) - (substring path (match-beginning 1) - (1- (match-end 1))))) - (rpath (substring path (1+ (match-end 2))))) - (list (if (string-equal host "") - (setq host (system-name)) - host) - (or user (efs-get-user host)) - rpath))) - ;; Set this last, in case efs-get-user calls this function, - ;; which would modify an earlier setting. - efs-ftp-path-arg path)) - efs-ftp-path-res))) - -(defmacro efs-canonize-switches (switches) - ;; Converts a switches string, into a lexographically ordered string, - ;; omitting - and spaces. Should we remove duplicate characters too? - (` (if (, switches) - (mapconcat - 'char-to-string - (sort (delq ?- (delq ?\ (mapcar 'identity (, switches)))) '<) "") - ;; For the purpose of interning in a hashtable, represent the nil - ;; switches, as a string consisting of the ascii null character. - (char-to-string 0)))) - -(defmacro efs-canonize-file-name (fn) - ;; Canonizes the case of file names. - (` (let ((parsed (efs-ftp-path (, fn)))) - (if parsed - (let ((host (car parsed))) - (if (memq (efs-host-type host) efs-case-insensitive-host-types) - (downcase (, fn)) - (format efs-path-format-string (nth 1 parsed) (downcase host) - (nth 2 parsed)))) - (, fn))))) - -(defmacro efs-get-files-hashtable-entry (fn) - (` (efs-get-hash-entry (efs-canonize-file-name (, fn)) efs-files-hashtable))) - -;;;; ------------------------------------------------------------ -;;;; Utility Functions -;;;; ------------------------------------------------------------ - -(defun efs-kill-ftp-buffer-with-prompt (proc buffer) - ;; Does a 3-way prompt to kill a ftp PROC and BUFFER. - ;; Returns t if buffer was killed, 0 if only process, nil otherwise. - (let ((inhibit-quit t) - (cursor-in-echo-area t) - char) - (message - (if efs-debug-ftp-connection - "Kill ftp process and buffer (y[es], n[o], c[lose], d[ebug] ) " - "Kill ftp process and buffer? (y or n, c to only close process) ")) - (setq char (read-char)) - (prog1 - (cond - ((memq char '(?y ?Y ?\ )) - (set-process-sentinel proc nil) - (condition-case nil - (kill-buffer buffer) - (error nil)) - t) - ((memq char '(?c ?C)) - (set-process-sentinel proc nil) - (condition-case nil - (save-excursion - (set-buffer buffer) - (setq efs-process-busy nil - efs-process-q nil) - (delete-process proc)) - (error nil)) - 0) - ((memq char '(?n ?N)) - (message "") - nil) - ((and efs-debug-ftp-connection - (memq char '(?d ?D))) - (condition-case nil - (save-excursion - (set-buffer buffer) - (setq efs-process-busy nil - efs-process-q nil)) - (error nil)) - 0) - (t - (message - (if efs-debug-ftp-connection - "Type one of y, n, c or d." - "Type one of y, n or c.")) - (ding) - (sit-for 1) - (setq quit-flag nil) - (efs-kill-ftp-buffer-with-prompt proc buffer)))))) - -(defun efs-barf-if-not-directory (directory) - ;; Signal an error if DIRECTORY is not one. - (or (file-directory-p directory) - (signal 'file-error - (list "Opening directory" - (if (file-exists-p directory) - "not a directory" - "no such file or directory") - directory)))) - -(defun efs-call-cont (cont &rest args) - "Call the function specified by CONT. -CONT can be either a function or a list of a function and some args. -The first parameters passed to the function will be ARGS. The remaining -args will be taken from CONT if a list was passed." - (if cont - (let ((efs-nested-cmd t)) ; let-bound so that conts don't pop any queues - (efs-save-buffer-excursion - (if (and (listp cont) - (not (eq (car cont) 'lambda))) - (apply (car cont) (append args (cdr cont))) - (apply cont args)))))) - -(defun efs-replace-path-component (fullpath path) - "For FULLPATH matching efs-path-regexp replace the path component with PATH." - (efs-save-match-data - (if (string-match efs-path-root-regexp fullpath) - (concat (substring fullpath 0 (match-end 0)) path) - path))) - -(defun efs-abort-recursive-edit-and-then (fun &rest args) - ;; Does an abort-recursive-edit, and runs fun _after_ emacs returns to - ;; top level. - (if (get-process "efs-abort-recursive-edit") - ;; Don't queue these things. Clean them out. - (delete-process "efs-abort-recursive-edit")) - (or efs-suppress-abort-recursive-edit-and-then - (progn - (setq efs-abort-recursive-edit-data (cons (nth 1 (current-time)) - (cons fun args))) - (condition-case nil - (set-process-sentinel - (let ((default-directory exec-directory) - (process-connection-type nil)) - (start-process "efs-abort-recursive-edit" nil "sleep" "0")) - (function - (lambda (proc string) - (let ((data efs-abort-recursive-edit-data)) - (setq efs-abort-recursive-edit-data) - (if (and data - (integerp (car data)) - (<= (- (nth 1 (current-time)) (car data)) - efs-abort-recursive-edit-delay)) - (apply (nth 1 data) (nthcdr 2 data))))))) - (error nil)))) - (abort-recursive-edit)) - -(defun efs-occur-in-string (char string) - ;; Return the number of occurrences of CHAR in STRING. - (efs-save-match-data - (let ((regexp (regexp-quote (char-to-string char))) - (count 0) - (start 0)) - (while (string-match regexp string start) - (setq start (match-end 0) - count (1+ count))) - count))) - -(defun efs-parse-proc-name (proc) - ;; Parses the name of process to return a list \(host user\). - (efs-save-match-data - (let ((name (process-name proc))) - (and name - (string-match "^\\*ftp \\([^@]*\\)@\\([^*]+\\)\\*$" name) - (list (substring name (match-beginning 2) (match-end 2)) - (substring name (match-beginning 1) (match-end 1))))))) - -;;;; ------------------------------------------------------------ -;;;; Of Geography, connectivity, and the internet... Gateways. -;;;; ------------------------------------------------------------ - -(defun efs-use-gateway-p (host &optional opaque-p) -;; Returns whether to access this host via a gateway. -;; Returns the gateway type as a symbol. See efs-gateway-type . -;; If optional OPAQUE-P is non-nil, only returns non-nil if the gateway -;; type is in the list efs-opaque-gateways . - (and efs-gateway-type - host ;local host is nil - (efs-save-match-data - (and (not (string-match efs-ftp-local-host-regexp host)) - (let ((type (car efs-gateway-type))) - (if opaque-p - (and (memq type efs-opaque-gateways) type) - type)))))) - -(defun efs-local-to-gateway-filename (filename &optional reverse) - ;; Converts a FILENAME on the local host to its name on the gateway, - ;; using efs-gateway-mounted-dirs-alist. If REVERSE is non-nil, does just - ;; that. If the there is no corresponding name because non of its parent - ;; directories are mounted, returns nil. - (if efs-gateway-mounted-dirs-alist - (let ((len (length filename)) - (alist efs-gateway-mounted-dirs-alist) - result elt elt-len) - (if reverse - (while (setq elt (car alist)) - (if (and (>= len (setq elt-len (length (cdr elt)))) - (string-equal (cdr elt) (substring filename 0 elt-len))) - (setq result (concat (car elt) - (substring filename elt-len)) - alist nil) - (setq alist (cdr alist)))) - (while (setq elt (car alist)) - (if (and (>= len (setq elt-len (length (car elt)))) - (string-equal (car elt) (substring filename 0 elt-len))) - (setq result (concat (cdr elt) - (substring filename elt-len)) - alist nil) - (setq alist (cdr alist))))) - result))) - -;;; ------------------------------------------------------------ -;;; Enhanced message support. -;;; ------------------------------------------------------------ - -(defun efs-message (fmt &rest args) - "Output the given message, truncating to the size of the minibuffer window." - (let ((msg (apply (function format) fmt args)) - (max (window-width (minibuffer-window)))) - (if (>= (length msg) max) - (setq msg (concat "> " (substring msg (- 3 max))))) - (message "%s" msg))) - -(defun efs-message-p () - ;; Returns t, if efs is allowed to display a status message. - (not - (or (and (boundp 'dired-in-query) dired-in-query) - (boundp 'search-message) - cursor-in-echo-area - (and (/= efs-message-interval 0) - (let ((diff (- efs-last-message-time - (setq efs-last-message-time - (nth 1 (current-time)))))) - (and - (> diff (- efs-message-interval)) - (< diff 0))))))) ; in case the clock wraps. - -(efs-define-fun efs-relativize-filename (file &optional dir new) - "Abbreviate the given filename relative to DIR . -If DIR is nil, use the value of `default-directory' for the currently selected -window. If the optional parameter NEW is given and the -non-directory parts match, only return the directory part of the file." - (let* ((dir (or dir (save-excursion - (set-buffer (window-buffer (selected-window))) - default-directory))) - (dlen (length dir)) - (result file)) - (and (> (length file) dlen) - (string-equal (substring file 0 dlen) dir) - (setq result (substring file dlen))) - (and new - (string-equal (file-name-nondirectory result) - (file-name-nondirectory new)) - (or (setq result (file-name-directory result)) - (setq result "./"))) - (abbreviate-file-name result))) - -;;; ------------------------------------------------------------ -;;; Temporary file location and deletion... -;;; ------------------------------------------------------------ - -(defun efs-get-pid () - ;; Half-hearted attempt to get the current process's id. - (setq efs-pid (substring (make-temp-name "") 1))) - -(defun efs-make-tmp-name (host1 host2) - ;; Returns the name of a new temp file, for moving data between HOST1 - ;; and HOST2. This temp file must be directly accessible to the - ;; FTP client connected to HOST1. Using nil for either HOST1 or - ;; HOST2 means the local host. The return value is actually a list - ;; whose car is the name of the temp file wrto to the local host - ;; and whose cdr is the name of the temp file wrto to the host - ;; on which the client connected to HOST1 is running. If the gateway - ;; is only accessible by FTP, then the car of this may be in efs extended - ;; file name syntax. - (let ((pid (or efs-pid (efs-get-pid))) - (start ?a) - file entry template rem-template template-len) - ;; Compute the templates. - (if (null (and host1 (efs-use-gateway-p host1 t))) - ;; file must be local - (if (null (and host2 (efs-use-gateway-p host2 t))) - (setq template efs-tmp-name-template) - (setq template (or (efs-local-to-gateway-filename - efs-gateway-tmp-name-template t) - efs-tmp-name-template))) - ;; file must be on the gateway -- make sure that the gateway - ;; configuration is sensible. - (efs-save-match-data - (or (string-match efs-ftp-local-host-regexp efs-gateway-host) - (error "Gateway %s must be directly ftp accessible." - efs-gateway-host))) - (setq rem-template efs-gateway-tmp-name-template - template (or (efs-local-to-gateway-filename - efs-gateway-tmp-name-template t) - (format efs-path-format-string - (efs-get-user efs-gateway-host) - efs-gateway-host - efs-gateway-tmp-name-template)) - template-len (length template))) - ;; Compute a new file name. - (while (let (efs-verbose) - (setq file (format "%s%c%s" template start pid) - entry (intern file efs-tmp-name-obarray)) - (or (memq entry efs-tmp-name-files) - (file-exists-p file))) - (if (> (setq start (1+ start)) ?z) - (progn - (setq template (concat template "X")) - (setq start ?a)))) - (setq efs-tmp-name-files - (cons entry efs-tmp-name-files)) - (if rem-template - (cons file (concat rem-template (substring file template-len))) - (cons file file)))) - -(defun efs-del-tmp-name (temp) - ;; Deletes file TEMP, a string. - (setq efs-tmp-name-files - (delq (intern temp efs-tmp-name-obarray) - efs-tmp-name-files)) - (condition-case () - (let (efs-verbose) - (delete-file temp)) - (error nil))) - - -;;;; ============================================================== -;;;; >4 -;;;; Hosts, Users, Accounts, and Passwords -;;;; ============================================================== -;;; -;;; A lot of the support for this type of thing is in efs-netrc.el. - -;;;; ------------------------------------------------------------ -;;;; Password support. -;;;; ------------------------------------------------------------ - -(defun efs-lookup-passwd (host user) - ;; Look up the password for HOST and USER. - (let ((ent (efs-get-host-user-property host user 'passwd))) - (and ent (efs-code-string ent)))) - -(defun efs-system-fqdn () - "Returns a fully qualified domain name for the current host, if possible." - (or efs-system-fqdn - (setq efs-system-fqdn - (let ((sys (system-name))) - (if (string-match "\\." sys) - sys - (if efs-nslookup-program - (let ((proc (let ((default-directory exec-directory) - (process-connection-type nil)) - (start-process " *nslookup*" " *nslookup*" - efs-nslookup-program sys))) - (res sys) - (n 0)) - (process-kill-without-query proc) - (save-excursion - (set-buffer (process-buffer proc)) - (let ((quit-flag nil) - (inhibit-quit nil)) - (if efs-nslookup-threshold - (progn - (while (and (memq (process-status proc) - '(run open)) - (< n efs-nslookup-threshold)) - (accept-process-output) - (setq n (1+ n))) - (if (>= n efs-nslookup-threshold) - (progn - (with-output-to-temp-buffer "*Help*" - (princ (format "\ -efs is unable to determine a fully qualified domain name -for the local host to send as an anonymous ftp password. - -The function `system-name' is not returning a fully qualified -domain name. An attempt to obtain a fully qualified domain name -with `efs-nslookup-program' (currently set to \"%s\") has -elicited no response from that program. Consider setting -`efs-generate-anonymous-password' to an email address for anonymous -ftp passwords. - -For more information see the documentation (use C-h v) for the -variables `efs-nslookup-program' and `efs-nslookup-threshold'." - efs-nslookup-program))) - (error "No response from %s" - efs-nslookup-program)))) - (while (memq (process-status proc) '(run open)) - (accept-process-output proc))) - (goto-char (point-min)) - (if (re-search-forward - (format "^Name: *\\(%s\\.[^ \n\t]+\\)" - sys) nil t) - (setq res (buffer-substring - (match-beginning 1) - (match-end 1))) - (kill-buffer (current-buffer))))) - res) - sys)))))) - -(defun efs-passwd-unique-list (alist) - ;; Preserving the relative order of ALIST, remove all entries with duplicate - ;; cars. - (let (result) - (while alist - (or (assoc (car alist) result) - (setq result (cons (car alist) result))) - (setq alist (cdr alist))) - (nreverse result))) - -(defun efs-get-passwd-list (user host) - ;; Returns an alist of the form '((pass host user) ...). - ;; The order is essentially arbitrary, except that entries with user - ;; equal to USER will appear first. Followed by entries with host equal to - ;; HOST. Also, there will be no entries with duplicate values of pass. - (efs-parse-netrc) - (let* ((user-template (concat "/" user)) - (ulen (length user-template)) - (hlen (length host)) - primaries secondaries tertiaries) - (efs-save-match-data - (efs-map-hashtable - (function - (lambda (key passwd) - (cond ((null passwd) nil) - ((and (> (length key) ulen) - (string-equal user-template - (substring key (- ulen)))) - (setq primaries (cons (list (efs-code-string passwd) - (substring key 0 (- ulen)) - (substring user-template 1)) - primaries))) - ((and (> (length key) hlen) - (string-equal host (substring key 0 hlen)) - (memq (aref key hlen) '(?/ ?.))) - (if (string-match "/" key hlen) - (setq secondaries - (cons (list (efs-code-string passwd) - (substring key 0 (match-beginning 0)) - (substring key (match-end 0))) - secondaries)))) - ((string-match "/" key) - (setq tertiaries - (cons (list (efs-code-string passwd) - (substring key 0 (match-beginning 0)) - (substring key (match-end 0))) - tertiaries)))))) - efs-host-user-hashtable 'passwd)) - (efs-passwd-unique-list (nconc primaries secondaries tertiaries)))) - -(defun efs-get-passwd (host user) - "Given a HOST and USER, return the FTP password, prompting if it was not -previously set." - (efs-parse-netrc) - - ;; look up password in the hash table first; user might have overriden the - ;; defaults. - (cond ((efs-lookup-passwd host user)) - - ;; see if default user and password set from the .netrc file. - ((and (stringp efs-default-user) - efs-default-password - (string-equal user efs-default-user)) - (copy-sequence efs-default-password)) - - ;; anonymous ftp password is handled specially since there is an - ;; unwritten rule about how that is used on the Internet. - ((and (efs-anonymous-p user) - efs-generate-anonymous-password) - (if (stringp efs-generate-anonymous-password) - (copy-sequence efs-generate-anonymous-password) - (concat (user-login-name) "@" (efs-system-fqdn)))) - - ;; see if same user has logged in to other hosts; if so then prompt - ;; with the password that was used there. - (t - (let (others defaults passwd) - (unwind-protect - (progn - (setq others (efs-get-passwd-list user host) - defaults (mapcar - (function - (lambda (x) - (cons - (format - "Passwd for %s@%s (same as %s@%s): " - user host (nth 2 x) (nth 1 x)) - (car x)))) - others)) - (setq passwd - (read-passwd - (or defaults - (format "Password for %s@%s: " user host))))) - (while others - (fillarray (car (car others)) 0) - (setq others (cdr others)))) - (or (null passwd) - (and efs-high-security-hosts - (efs-save-match-data - (string-match efs-high-security-hosts - (format "%s@%s" user host)))) - (efs-set-passwd host user passwd)) - passwd)))) - -;;;; ------------------------------------------------------------ -;;;; Account support -;;;; ------------------------------------------------------------ - -(defun efs-get-account (host user &optional minidisk really) - "Given a HOST, USER, and optional MINIDISK return the FTP account password. -If the optional REALLY argument is given, prompts the user if it can't find -one." - (efs-parse-netrc) - (let ((account (if minidisk - (efs-get-hash-entry - (concat (downcase host) "/" user "/" minidisk) - efs-minidisk-hashtable - (memq (efs-host-type host) - efs-case-insensitive-host-types)) - (efs-get-host-user-property host user 'account)))) - (if account - (efs-code-string account) - ;; Do we really want to send the default-account passwd for all - ;; minidisks? - (if (and (stringp efs-default-user) - (string-equal user efs-default-user) - efs-default-account) - efs-default-account - (and really - (let ((acct - (read-passwd - (if minidisk - (format - "Write access password for minidisk %s on %s@%s: " - minidisk user host) - (format - "Account password for %s@%s: " user host))))) - (or (and efs-high-security-hosts - (efs-save-match-data - efs-high-security-hosts - (format "%s@%s" user host))) - (efs-set-account host user minidisk acct)) - acct)))))) - -;;;; ------------------------------------------------------------- -;;;; Special classes of users. -;;;; ------------------------------------------------------------- - -(defun efs-anonymous-p (user) - ;; Returns t if USER should be treated as an anonymous FTP login. - (let ((user (downcase user))) - (or (string-equal user "anonymous") (string-equal user "ftp")))) - - -;;;; ============================================================= -;;;; >5 -;;;; FTP client process, and server responses -;;;; ============================================================= - -;;;; --------------------------------------------------------- -;;;; Support for asynch process queues. -;;;; --------------------------------------------------------- - -(defun efs-add-to-queue (host user item) - "To the end of the command queue for HOST and USER, adds ITEM. -Does nothing if there is no process buffer for HOST and USER." - (let ((buff (efs-ftp-process-buffer host user))) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-q - (nconc efs-process-q (list item))))))) - -;;;; ------------------------------------------------------- -;;;; Error recovery for the process filter. -;;;; ------------------------------------------------------- - -;;; Could make this better, but it's such an unlikely error to hit. -(defun efs-process-scream-and-yell (line) - (let* ((buff (buffer-name (current-buffer))) - (host (and (string-match "@\\(.*\\)\\*$" buff) - (substring buff (match-beginning 1) (match-end 1))))) - (with-output-to-temp-buffer "*Help*" - (princ - (concat - "efs is unable to identify the following reply code -from the ftp server " host ":\n\n" line " - -Please send a bug report to ange@hplb.hpl.hp.com. -In your report include a transcript of your\n" -buff " buffer.")))) - (error "Unable to identify server code.")) - -(defun efs-error (host user msg) - "Signal \'ftp-error for the FTP connection for HOST and USER. -The error gives the string MSG as text. The process buffer for the FTP -is popped up in another window." - (let ((cur (selected-window)) - (pop-up-windows t) - (buff (get-buffer (efs-ftp-process-buffer host user)))) - (if buff - (progn - (pop-to-buffer buff) - (goto-char (point-max)) - (select-window cur)))) - (signal 'ftp-error (list (format "FTP Error: %s" msg)))) - -;;;; -------------------------------------------------------------------- -;;;; Process filter and supporting functions for handling FTP codes. -;;;; -------------------------------------------------------------------- - -(defun efs-process-handle-line (line proc) - ;; Look at the given LINE from the ftp process PROC and try to catagorize it. - (cond ((string-match efs-xfer-size-msgs line) - (let ((n 1)) - ;; this loop will bomb with an args out of range error at 10 - (while (not (match-beginning n)) - (setq n (1+ n))) - (setq efs-process-xfer-size - (ash (string-to-int (substring line - (match-beginning n) - (match-end n))) - -10)))) - - ((string-match efs-multi-msgs line) - (setq efs-process-result-cont-lines - (concat efs-process-result-cont-lines line "\n"))) - - ((string-match efs-skip-msgs line)) - - ((string-match efs-cmd-ok-msgs line) - (if (string-match efs-cmd-ok-cmds efs-process-cmd) - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line))) - - ((string-match efs-pending-msgs line) - (if (string-match "^quote rnfr " efs-process-cmd) - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line))) - - ((string-match efs-bytes-received-msgs line) - (if efs-process-server-confused - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line))) - - ((string-match efs-server-confused-msgs line) - (setq efs-process-server-confused t)) - - ((string-match efs-good-msgs line) - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line)) - - ((string-match efs-fatal-msgs line) - (set-process-sentinel proc nil) - (delete-process proc) - (setq efs-process-busy nil - efs-process-result 'fatal - efs-process-result-line line)) - - ((string-match efs-failed-msgs line) - (setq efs-process-busy nil - efs-process-result 'failed - efs-process-result-line line)) - - ((string-match efs-unknown-response-msgs line) - (setq efs-process-busy nil - efs-process-result 'weird - efs-process-result-line line) - (efs-process-scream-and-yell line)))) - -(efs-define-fun efs-process-log-string (proc str) - ;; For a given PROCESS, log the given STRING at the end of its - ;; associated buffer. - (let ((buff (get-buffer (process-buffer proc)))) - (if buff - (efs-save-buffer-excursion - (set-buffer buff) - (comint-output-filter proc str))))) - -(defun efs-process-filter (proc str) - ;; Build up a complete line of output from the ftp PROCESS and pass it - ;; on to efs-process-handle-line to deal with. - (let ((inhibit-quit t) - (buffer (get-buffer (process-buffer proc))) - (efs-default-directory default-directory)) - - ;; see if the buffer is still around... it could have been deleted. - (if buffer - (efs-save-buffer-excursion - (set-buffer (process-buffer proc)) - (efs-save-match-data - - ;; handle hash mark printing - (if efs-process-busy - (setq str (efs-process-handle-hash str) - efs-process-string (concat efs-process-string str))) - (efs-process-log-string proc str) - (while (and efs-process-busy - (string-match "\n" efs-process-string)) - (let ((line (substring efs-process-string - 0 - (match-beginning 0)))) - (setq efs-process-string (substring - efs-process-string - (match-end 0))) - ;; If we are in synch with the client, we should - ;; never get prompts in the wrong place. Just to be safe, - ;; chew them off. - (while (string-match efs-process-prompt-regexp line) - (setq line (substring line (match-end 0)))) - (efs-process-handle-line line proc))) - - ;; has the ftp client finished? if so then do some clean-up - ;; actions. - (if (not efs-process-busy) - (progn - (efs-correct-hash-mark-size) - ;; reset process-kill-without-query - (process-kill-without-query proc) - ;; issue the "done" message since we've finished. - (if (and efs-process-msg - (efs-message-p) - (null efs-process-result)) - (progn - - (efs-message "%s...done" efs-process-msg) - (setq efs-process-msg nil))) - - (if (and efs-process-nowait - (null efs-process-cmd-waiting)) - - (progn - ;; Is there a continuation we should be calling? - ;; If so, we'd better call it, making sure we - ;; only call it once. - (if efs-process-continue - (let ((cont efs-process-continue)) - (setq efs-process-continue nil) - (efs-call-cont - cont - efs-process-result - efs-process-result-line - efs-process-result-cont-lines))) - ;; If the cmd was run asynch, run the next - ;; cmd from the queue. For synch cmds, this - ;; is done by efs-send-cmd. For asynch - ;; cmds we don't care about - ;; efs-nested-cmd, since nothing is - ;; waiting for the cmd to complete. If - ;; efs-process-cmd-waiting is t, exit - ;; to let this command run. - (if (and efs-process-q - ;; Be careful to check efs-process-busy - ;; again, because the cont may have started - ;; some new ftp action. - ;; wheels within wheels... - (null efs-process-busy)) - (let ((next (car efs-process-q))) - (setq efs-process-q - (cdr efs-process-q)) - (apply 'efs-send-cmd - efs-process-host - efs-process-user - next)))) - - (if efs-process-continue - (let ((cont efs-process-continue)) - (setq efs-process-continue nil) - (efs-call-cont - cont - efs-process-result - efs-process-result-line - efs-process-result-cont-lines)))) - - ;; Update the mode line - ;; We can't test nowait to see if we changed the - ;; modeline in the first place, because conts - ;; may be running now, which will confuse the issue. - ;; The logic is simpler if we update the modeline - ;; before the cont, but then the user sees the - ;; modeline track the cont execution. It's dizzying. - (if (and (or efs-mode-line-format - efs-ftp-activity-function) - (null efs-process-busy)) - (efs-update-mode-line))))) - - ;; Trim buffer, if required. - (and efs-max-ftp-buffer-size - (zerop efs-process-cmd-counter) - (> (point-max) efs-max-ftp-buffer-size) - (= (point-min) 1) ; who knows, the user may have narrowed. - (null (get-buffer-window (current-buffer))) - (save-excursion - (goto-char (/ efs-max-ftp-buffer-size 2)) - (forward-line 1) - (delete-region (point-min) (point)))))))) - -;;;; ------------------------------------------------------------------ -;;;; Functions for counting hashes and reporting on bytes transferred. -;;;; ------------------------------------------------------------------ - -(defun efs-set-xfer-size (host user bytes) - ;; Set the size of the next FTP transfer in bytes. - (let ((proc (efs-get-process host user))) - (if proc - (let ((buf (process-buffer proc))) - (if buf - (save-excursion - (set-buffer buf) - (setq efs-process-xfer-size (ash bytes -10)))))))) - -(defun efs-guess-incoming-bin-hm-size () - ;; Guess at the hash mark size for incoming binary transfers by taking - ;; the average value for such transfers to other hosts. - (let ((total 0) - (n 0)) - (efs-map-hashtable - (function - (lambda (host hm-size) - (if hm-size (setq total (+ total hm-size) - n (1+ n))))) - efs-host-hashtable - 'incoming-bin-hm-size) - (and (> n 0) (/ total n)))) - -(defun efs-set-hash-mark-unit (host user &optional incoming) - ;; Sets the value of efs-process-hash-mark-unit according to the xfer-type. - ;; efs-hash-mark-unit is the number of bytes represented by a hash mark, - ;; in units of 16. If INCOMING is non-nil, the xfer will be a GET. - (if efs-send-hash - (let ((buff (efs-ftp-process-buffer host user)) - (gate-p (efs-use-gateway-p host t))) - (if buff - (save-excursion - (set-buffer buff) - (setq efs-process-hash-mark-unit - (ash (or - (and incoming (eq efs-process-xfer-type 'image) - (or (efs-get-host-property - host 'incoming-bin-hm-size) - (if gate-p - efs-gateway-incoming-binary-hm-size - efs-incoming-binary-hm-size) - (let ((guess - (efs-guess-incoming-bin-hm-size))) - (and guess - (efs-set-host-property - host 'incoming-bin-hm-size - guess))))) - (if gate-p - efs-gateway-hash-mark-size - efs-hash-mark-size) - 1024) ; make sure that we have some integer - -4))))))) - -(defun efs-correct-hash-mark-size () - ;; Corrects the value of efs-{ascii,binary}-hash-mark-size. - ;; Must be run in the process buffer. - (and efs-send-hash - efs-process-hash-mark-unit - (> efs-process-xfer-size 0) - (< efs-process-xfer-size 524288) ; 2^19, prevent overflows - (> efs-process-hash-mark-count 0) - (or (> efs-process-last-percent 100) - (< (ash (* efs-process-hash-mark-unit - (1+ efs-process-hash-mark-count )) -6) - efs-process-xfer-size)) - (let ((val (ash (/ (ash efs-process-xfer-size 6) - efs-process-hash-mark-count) 4))) - (if (and (eq efs-process-xfer-type 'image) - (>= (length efs-process-cmd) 4) - (string-equal (downcase (substring efs-process-cmd 0 4)) - "get ")) - (efs-set-host-property efs-process-host 'incoming-bin-hm-size val) - (set (if (efs-use-gateway-p efs-process-host t) - 'efs-gateway-hash-mark-size - 'efs-hash-mark-size) - val))))) - -(defun efs-process-handle-hash (str) - ;; Remove hash marks from STRING and display count so far. - (if (string-match "^#+$" str) - (progn - (setq efs-process-hash-mark-count - (+ efs-process-hash-mark-count - (- (match-end 0) (match-beginning 0)))) - (and - efs-process-msg - efs-process-hash-mark-unit - (not (and efs-process-nowait - (or (eq efs-verbose 0) - (eq (selected-window) (minibuffer-window))))) - (efs-message-p) - (let* ((big (> efs-process-hash-mark-count 65536)) ; 2^16 - (kbytes (if big - (* efs-process-hash-mark-unit - (ash efs-process-hash-mark-count -6)) - (ash (* efs-process-hash-mark-unit - efs-process-hash-mark-count) - -6)))) - (if (zerop efs-process-xfer-size) - (or (zerop kbytes) - (efs-message "%s...%dk" efs-process-msg kbytes)) - (let ((percent (if big - (/ (* 100 (ash kbytes -7)) - (ash efs-process-xfer-size -7)) - (/ (* 100 kbytes) efs-process-xfer-size)))) - ;; Don't display %'s betwwen 100 and 110 - (and (> percent 100) (< percent 110) (setq percent 100)) - ;; cut out the redisplay of identical %-age messages. - (or (eq percent efs-process-last-percent) - (progn - (setq efs-process-last-percent percent) - (efs-message "%s...%d%%" efs-process-msg percent))))))) - (concat (substring str 0 (match-beginning 0)) - (and (/= (length str) (match-end 0)) - (substring str (1+ (match-end 0)))))) - str)) - -;;;; ------------------------------------------------------------------ -;;;; Keeping track of the number of active background connections. -;;;; ------------------------------------------------------------------ - -(defun efs-ftp-processes-active () - ;; Return the number of FTP processes busy. - (save-excursion - (length - (delq nil - (mapcar - (function - (lambda (buff) - (set-buffer buff) - (and (boundp 'efs-process-busy) - efs-process-busy))) - (buffer-list)))))) - -(defun efs-update-mode-line () - ;; Updates the mode with FTP activity, and runs `efs-ftp-activity-function'. - (let ((num (efs-ftp-processes-active))) - (if efs-mode-line-format - (progn - (if (zerop num) - (setq efs-mode-line-string "") - (setq efs-mode-line-string (format efs-mode-line-format num))) - ;; fake emacs into re-calculating all the mode lines. - (save-excursion (set-buffer (other-buffer))) - (set-buffer-modified-p (buffer-modified-p)))) - (if efs-ftp-activity-function - (funcall efs-ftp-activity-function num)))) - -;;;###autoload -(defun efs-display-ftp-activity () - "Displays the number of active background ftp sessions in the modeline. -Uses the variable `efs-mode-line-format' to determine how this will be -displayed." - (interactive) - (or (memq 'efs-mode-line-string global-mode-string) - (if global-mode-string - (nconc global-mode-string '(efs-mode-line-string)) - (setq global-mode-string '("" efs-mode-line-string))))) - -;;;; ------------------------------------------------------------------- -;;;; Expiring inactive ftp buffers. -;;;; ------------------------------------------------------------------- - -(defun efs-start-polling () - ;; Start polling FTP buffers, to look for idle ones. - (or (null efs-expire-ftp-buffers) - (let ((proc (get-process "efs poll"))) - (or (and proc (eq (process-status proc) 'run)))) - (let ((default-directory exec-directory) - (process-connection-type nil) - new-proc) - (condition-case nil - (delete-process "efs poll") - (error nil)) - (setq new-proc (start-process - "efs poll" nil - (concat exec-directory "wakeup") - (int-to-string efs-ftp-buffer-poll-time))) - (set-process-filter new-proc (function efs-expire-ftp-buffers-filter)) - (process-kill-without-query new-proc)))) - -(defun efs-connection-visited-p (host user) - ;; Returns t if there are any buffers visiting files on HOST and USER. - (save-excursion - (let ((list (buffer-list)) - (case-fold (memq (efs-host-type host) - efs-case-insensitive-host-types)) - (visited nil) - parsed) - (setq host (downcase host)) - (if case-fold (setq user (downcase user))) - (while list - (set-buffer (car list)) - (if (or (and buffer-file-name - (setq parsed (efs-ftp-path buffer-file-name)) - (string-equal host (downcase (car parsed))) - (string-equal user (if case-fold - (downcase (nth 1 parsed)) - (nth 1 parsed)))) - (and (boundp 'dired-directory) - (stringp dired-directory) - efs-dired-host-type - (setq parsed (efs-ftp-path dired-directory)) - (string-equal host (downcase (car parsed))) - (string-equal user (if case-fold - (downcase (nth 1 parsed)) - (nth 1 parsed))))) - (setq visited t - list nil) - (setq list (cdr list)))) - visited))) - -(defun efs-expire-ftp-buffers-filter (proc string) - ;; Check all ftp buffers, and kill them if they have been inactive - ;; for the minimum of efs-ftp-buffer-expire-time and their local - ;; time out time. - (if efs-expire-ftp-buffers - (let ((list (buffer-list)) - new-alist) - (save-excursion - (while list - (set-buffer (car list)) - (if (eq major-mode 'efs-mode) - (let* ((proc (get-buffer-process (current-buffer))) - (proc-p (and proc (memq (process-status proc) - '(run open))))) - (if (or efs-ftp-buffer-expire-time - efs-process-idle-time - (null proc-p)) - (let ((elt (assq (car list) efs-ftp-buffer-alist)) - (wind-p (get-buffer-window (car list)))) - (if (or (null elt) (buffer-modified-p) - efs-process-busy wind-p) - (progn - (setq new-alist (cons (cons (car list) 0) - new-alist)) - (or wind-p (set-buffer-modified-p nil))) - (let ((idle (+ (cdr elt) - efs-ftp-buffer-poll-time))) - (if (and proc-p - (< idle - (if efs-ftp-buffer-expire-time - (if efs-process-idle-time - (min efs-ftp-buffer-expire-time - efs-process-idle-time) - efs-ftp-buffer-expire-time) - efs-process-idle-time))) - (progn - (setq new-alist (cons (cons (car list) idle) - new-alist)) - (set-buffer-modified-p nil)) - ;; If there are still buffers for host & user, - ;; don't wipe the cache. - (and proc - (efs-connection-visited-p - efs-process-host efs-process-user) - (set-process-sentinel proc nil)) - (kill-buffer (car list))))))))) - (setq list (cdr list)))) - (setq efs-ftp-buffer-alist new-alist)) - (condition-case nil - (delete-process "efs poll") - (error nil)))) - -;;;; ------------------------------------------------------------------- -;;;; When the FTP client process dies... -;;;; ------------------------------------------------------------------- - -(defun efs-process-sentinel (proc str) - ;; When ftp process changes state, nuke all file-entries in cache. - (let ((buff (process-buffer proc))) - ;; If the client dies, make sure that efs doesn't think that - ;; there is a running process. - (save-excursion - (condition-case nil - (progn - (set-buffer buff) - (setq efs-process-busy nil)) - (error nil))) - (let ((parsed (efs-parse-proc-name proc))) - (if parsed - (progn - (apply 'efs-wipe-file-entries parsed) - (apply 'efs-wipe-from-ls-cache parsed)))) - (if (or efs-mode-line-format efs-ftp-activity-function) - (efs-update-mode-line)))) - -(defun efs-kill-ftp-process (buffer) - "Kill an FTP connection and its associated process buffer. -If the BUFFER's visited file name or default-directory is an efs remote -file name, it is the connection for that file name that is killed." - (interactive "bKill FTP process associated with buffer: ") - (or buffer (setq buffer (current-buffer))) - (save-excursion - (set-buffer buffer) - (if (eq major-mode 'efs-mode) - (kill-buffer buffer) - (let ((file (or (buffer-file-name) default-directory))) - (if file - (let ((parsed (efs-ftp-path (expand-file-name file)))) - (if parsed - (let ((host (nth 0 parsed)) - (user (nth 1 parsed))) - (kill-buffer - (efs-ftp-process-buffer host user)))))))))) - -(defun efs-close-ftp-process (buffer) - "Close an FTP connection. -This kills the FTP client process, but unlike `efs-kill-ftp-process' this -neither kills the process buffer, nor deletes cached data for the connection." - (interactive "bClose FTP process associated with buffer: ") - (or buffer (setq buffer (current-buffer))) - (save-excursion - (set-buffer buffer) - (if (eq major-mode 'efs-mode) - (let ((process (get-buffer-process buffer))) - (if process - (progn - (set-process-sentinel process nil) - (setq efs-process-busy nil - efs-process-q nil) - (if (or efs-mode-line-format efs-ftp-activity-function) - (efs-update-mode-line)) - (delete-process process)))) - (let ((file (or (buffer-file-name) default-directory))) - (if file - (let ((parsed (efs-ftp-path (expand-file-name file)))) - (if parsed - (let ((process (get-process - (format "*ftp %s@%s*" - (nth 1 parsed) (car parsed))))) - (if process - (progn - (set-buffer (process-buffer process)) - (set-process-sentinel process nil) - (setq efs-process-busy nil - efs-process-q nil) - (if (or efs-mode-line-format - efs-ftp-activity-function) - (efs-update-mode-line)) - (delete-process process))))))))))) - -(defun efs-ping-ftp-connection (buffer) - "Ping a connection by sending a NOOP command. -Useful for waking up a possible expired connection." - (interactive "bPing FTP connection associated with buffer: ") - (or buffer (setq buffer (current-buffer))) - (efs-save-buffer-excursion - (set-buffer buffer) - (let (file host user parsed) - (if (or (and (eq major-mode 'efs-mode) - (setq host efs-process-host - user efs-process-user)) - (and (setq file (or (buffer-file-name) default-directory)) - (setq parsed (efs-ftp-path file)) - (setq host (car parsed) - user (nth 1 parsed)))) - (or (car - (efs-send-cmd - host user '(quote noop) - (format "Pinging connection %s@%s" user host))) - (message "Connection %s@%s is alive." user host)))))) - -(defun efs-display-ftp-process-buffer (buffer) - "Displays the FTP process buffer associated with the current buffer." - (interactive "bDisplay FTP buffer associated with buffer: ") - (if (null buffer) (setq buffer (current-buffer))) - (let ((file (or (buffer-file-name) default-directory)) - parsed proc-buffer) - (if (and file (setq parsed (efs-ftp-path file)) - (setq proc-buffer (get-buffer (efs-ftp-process-buffer - (car parsed) - (nth 1 parsed))))) - (display-buffer proc-buffer) - (error "Buffer %s not associated with an FTP process" buffer)))) - -;;;; ------------------------------------------------------------------- -;;;; Starting the FTP client process -;;;; ------------------------------------------------------------------- - -(defun efs-ftp-process-buffer (host user) - "Return name of the process buffer for ftp process for HOST and USER." - ;; Host names on the internet are case-insensitive. - (format efs-ftp-buffer-format user (downcase host))) - -(defun efs-pty-check (proc threshold) - ;; Checks to see if PROC is a pty. Beware, it clobbers the process - ;; filter, so run this before you set the filter. - ;; THRESHOLD is an integer to tell it how long to wait for output. - (sit-for 0) ; Update the display before doing any waiting. - (let ((efs-pipe-p t) - (n 0)) - (set-process-filter proc (function (lambda (proc string) - (setq efs-pipe-p nil)))) - (while (and (< n threshold) efs-pipe-p) - (accept-process-output) - (setq n (1+ n))) - (if efs-pipe-p - (progn - (sit-for 0) ; update display - ;; Use a sleep-for as I don't want pty-checking to depend - ;; on pending input. - (sleep-for efs-pty-check-retry-time))) - (accept-process-output) - (if efs-pipe-p - (if (or noninteractive - (progn - ;; in case the user typed something during the wait. - (discard-input) - (y-or-n-p - (format "%s seems not a pty. Kill? " proc)))) - (progn - (kill-buffer (process-buffer proc)) - (if (eq (selected-window) (minibuffer-window)) - (abort-recursive-edit) - (signal 'quit nil)))) - ;; Need to send a \n to make sure, because sometimes we get the startup - ;; prompt from a pipe. - (sit-for 0) - (process-send-string proc "\n") - (setq efs-pipe-p t - n 0) - (while (and (< n threshold) efs-pipe-p) - (accept-process-output) - (setq n (1+ n))) - (if efs-pipe-p - (progn - (sit-for 0) - (sleep-for efs-pty-check-retry-time))) - (accept-process-output) - (if (and efs-pipe-p - (or noninteractive - (progn - ;; in case the user typed something during the wait. - (discard-input) - (y-or-n-p - (format "%s seems not a pty. Kill? " proc))))) - (progn - (kill-buffer (process-buffer proc)) - (if (eq (selected-window) (minibuffer-window)) - (abort-recursive-edit) - (signal 'quit nil))))))) - -(defun efs-start-process (host user name) - "Spawn a new ftp process ready to connect to machine HOST as USER. -If HOST is only ftp-able through a gateway machine then spawn a shell -on the gateway machine to do the ftp instead. NAME is the name of the -process." - (let* ((use-gateway (efs-use-gateway-p host)) - (buffer (get-buffer-create (efs-ftp-process-buffer host user))) - (process-connection-type t) - (opaque-p (memq use-gateway efs-opaque-gateways)) - proc) - (save-excursion - (set-buffer buffer) - (efs-mode host user (if opaque-p - efs-gateway-ftp-prompt-regexp - efs-ftp-prompt-regexp))) - (cond - ((null use-gateway) - (message "Opening FTP connection to %s..." host) - (setq proc (apply 'start-process name buffer efs-ftp-program-name - efs-ftp-program-args))) - ((eq use-gateway 'interactive) - (setq proc (efs-gwp-start host user name))) - ((eq use-gateway 'remsh) - (message "Opening FTP connection to %s via %s..." host efs-gateway-host) - (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) - (append (list efs-gateway-host) - (nth 2 efs-gateway-type) - (list (nth 3 efs-gateway-type)) - (nth 4 efs-gateway-type))))) - ((memq use-gateway '(proxy raptor interlock kerberos)) - (message "Opening FTP connection to %s via %s..." host efs-gateway-host) - (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) - (nth 2 efs-gateway-type)))) - ((eq use-gateway 'local) - (message "Opening FTP connection to %s..." host) - (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) - (nth 2 efs-gateway-type)))) - ((error "Never heard of gateway type %s" use-gateway))) - (process-kill-without-query proc) - (if opaque-p - (accept-process-output proc) - (if efs-pty-check-threshold - (efs-pty-check proc efs-pty-check-threshold) - (accept-process-output proc))) - (set-process-sentinel proc (function efs-process-sentinel)) - (set-process-filter proc (function efs-process-filter)) - (efs-start-polling) - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (set-marker (process-mark proc) (point))) - proc)) - -(defun efs-get-process-internal (host user) - ;; Get's the first process for HOST and USER. If HOST runs a - ;; a case insignificant OS, then case is not considered in USER. - (let ((list (process-list)) - (case-fold (memq (efs-host-type host) - efs-case-insensitive-host-types)) - (len (+ (length host) (length user) 7)) - fmt name found) - (setq host (downcase host)) - (if case-fold (setq user (downcase user))) - (while (and (not found) list) - (setq name (process-name (car list))) - (if (and (= (length name) len) - (string-equal (substring name 0 5) "*ftp ") - (string-equal - (if case-fold (downcase (substring name 5)) (substring name 5)) - (or fmt (setq fmt (format "%s@%s*" user host)))) - (memq (process-status (car list)) '(run open))) - (setq found (car list)) - (setq list (cdr list)))) - found)) - -;; efs-guess-host-type calls this -;; function recursively. The (if (and proc... avoids an infinite -;; loop. We should make sure that this won't hang things if the -;; connection goes wrong. - -(defun efs-get-process (host user) - "Return the process object for the FTP process for HOST and USER. -Create a new process if needed." - - (let ((proc (efs-get-process-internal host user))) - (if (and proc (memq (process-status proc) '(run open))) - proc - - ;; Make sure that the process isn't around in some strange state. - - (setq host (downcase host)) - (let ((name (concat "*ftp " user "@" host "*"))) - (if proc (condition-case nil (delete-process proc) (error nil))) - - ;; grab a suitable process. - (setq proc (efs-start-process host user name)) - - (efs-save-match-data - (efs-save-buffer-excursion - (set-buffer (process-buffer proc)) - - ;; Run any user-specified hooks. - (run-hooks 'efs-ftp-startup-hook) - - ;; login to FTP server. - (efs-login host user proc) - - ;; Beware, the process may have died if the login went bad. - (if (memq (process-status proc) '(run open)) - - (progn - ;; Tell client to send back hash-marks as progress. It isn't - ;; usually fatal if this command fails. - (efs-guess-hash-mark-size proc) - - (if efs-use-passive-mode - (efs-passive-mode host user)) - - ;; Run any user startup functions - (let ((alist efs-ftp-startup-function-alist) - (case-fold-search t)) - (while alist - (if (string-match (car (car alist)) host) - (progn - (funcall (cdr (car alist)) host user) - (setq alist nil)) - (setq alist (cdr alist))))) - - ;; Guess at the host type. - (efs-guess-host-type host user) - - ;; Check the idle time. - (efs-check-idle host user) - - proc) - - ;; Hopefully a recursive retry worked. - (or (efs-get-process-internal host user) - (error "No FTP process for %s@%s" user host))))))))) - -(defun efs-guess-hash-mark-size (proc) - ;; Doesn't run efs-save-match-data. You must do that yourself. - (if efs-send-hash - (save-excursion - (set-buffer (process-buffer proc)) - (let ((line (nth 1 (efs-raw-send-cmd proc "hash"))) - (gate-p (efs-use-gateway-p efs-process-host t))) - ;; Don't guess if the hash-mark-size is already set. - (or (if gate-p efs-gateway-hash-mark-size efs-hash-mark-size) - (if (string-match efs-hash-mark-msgs line) - (let ((size (substring line (match-beginning 1) - (match-end 1)))) - (if (string-match "^[0-9]+$" size) - (set (if gate-p - 'efs-gateway-hash-mark-size - 'efs-hash-mark-size) - (string-to-int size)))))))))) - -(defun efs-passive-mode (host user) - ;; put ftp into passive mode - (efs-send-cmd host user '(passive))) - -;;;; ------------------------------------------------------------ -;;;; Simple FTP process shell support. -;;;; ------------------------------------------------------------ - -(defun efs-mode (host user prompt) - "Major mode for interacting with an FTP process. -The user interface for sending commands to the FTP process is `comint-mode'. -For more information see the documentation for `comint-mode'. This command -is not intended for interactive use. -Takes arguments: HOST USER PROMPT - -Runs efs-mode-hook if it is not nil. - -Key map: -\\{comint-mode-map}" - (let ((proc (get-buffer-process (current-buffer)))) - ;; Running comint-mode will kill-all-local-variables. - (comint-mode) - ;; All these variables are buffer local. - (setq major-mode 'efs-mode - mode-name "efs" - default-directory (file-name-directory efs-tmp-name-template) - comint-prompt-regexp prompt - efs-process-host host - efs-process-user user - efs-process-prompt-regexp prompt) - (set (make-local-variable 'paragraph-start) comint-prompt-regexp) - ;; Old versions of comint don't have this. It does no harm for - ;; the newer ones. - (set (make-local-variable 'comint-last-input-start) (make-marker)) - (goto-char (point-max)) - ;; in case there is a running process - (if proc (set-marker (process-mark proc) (point))) - (run-hooks 'efs-mode-hook))) - - -;;;; ============================================================= -;;;; >6 -;;;; Sending commands to the FTP server. -;;;; ============================================================= - -;;;; ------------------------------------------------------------- -;;;; General purpose functions for sending commands. -;;;; ------------------------------------------------------------- - -(defun efs-raw-send-cmd (proc cmd &optional msg pre-cont cont nowait) -;; Low-level routine to send the given ftp CMD to the ftp PROCESS. -;; MSG is an optional message to output before and after the command. -;; If PRE-CONT is non-nil, it is called immediately after execution -;; of the command starts, but without waiting for it to finish. -;; If CONT is non-NIL then it is either a function or a list of function and -;; some arguments. The function will be called when the ftp command has -;; completed. -;; If CONT is NIL then this routine will return \( RESULT . LINE \) where -;; RESULT is whether the command was successful, and LINE is the line from -;; the FTP process that caused the command to complete. -;; If NOWAIT is nil then we will wait for the command to complete before -;; returning. If NOWAIT is 0, then we will wait until the command starts, -;; executing before returning. NOWAIT of 1 is like 0, except that the modeline -;; will indicate an asynch FTP command. -;; If NOWAIT has any other value, then we will simply queue the -;; command. In all cases, CONT will still be called - - (if (memq (process-status proc) '(run open)) - (efs-save-buffer-excursion - (set-buffer (process-buffer proc)) - - (if efs-process-busy - ;; This function will always wait on a busy process. - ;; Queueing is done by efs-send-cmd. - (let ((efs-process-cmd-waiting t)) - (efs-kbd-quit-protect proc - (while efs-process-busy - (accept-process-output))))) - - (setq efs-process-string "" - efs-process-result-line "" - efs-process-result-cont-lines "" - efs-process-busy t - efs-process-msg (and efs-verbose msg) - efs-process-continue cont - efs-process-server-confused nil - efs-process-nowait nowait - efs-process-hash-mark-count 0 - efs-process-last-percent -1 - efs-process-xfer-size 0 - efs-process-cmd-counter (% (1+ efs-process-cmd-counter) 16)) - (process-kill-without-query proc t) - (and efs-process-msg - (efs-message-p) - (efs-message "%s..." efs-process-msg)) - (goto-char (point-max)) - (move-marker comint-last-input-start (point)) - (move-marker comint-last-input-end (point)) - ;; don't insert the password into the buffer on the USER command. - (efs-save-match-data - (if (string-match efs-passwd-cmds cmd) - (insert (setq efs-process-cmd - (substring cmd 0 (match-end 0))) - " Turtle Power!\n") - (setq efs-process-cmd cmd) - (insert cmd "\n"))) - (process-send-string proc (concat cmd "\n")) - (set-marker (process-mark proc) (point)) - ;; Update the mode-line - (if (and (or efs-mode-line-format efs-ftp-activity-function) - (memq nowait '(t 1))) - (efs-update-mode-line)) - (if pre-cont - (let ((efs-nested-cmd t)) - (save-excursion - (apply (car pre-cont) (cdr pre-cont))))) - (prog1 - (if nowait - nil - ;; hang around for command to complete - ;; Some clients die after the command is sent, if the server - ;; times out. Don't wait on dead processes. - (efs-kbd-quit-protect proc - (while (and efs-process-busy - ;; Need to recheck nowait, since it may get reset - ;; in a cont. - (null efs-process-nowait) - (memq (process-status proc) '(run open))) - (accept-process-output proc))) - - ;; cont is called by the process filter - (if cont - ;; Return nil if a cont was called. - ;; Can't return process-result - ;; and process-line since executing - ;; the cont may have changed - ;; the state of the process buffer. - nil - (list efs-process-result - efs-process-result-line - efs-process-result-cont-lines))) - - ;; If the process died, the filter would have never got the chance - ;; to call the cont. Try to jump start things. - - (if (and (not (memq (process-status proc) '(run open))) - (string-equal efs-process-result-line "") - cont - (equal cont efs-process-continue)) - (progn - (setq efs-process-continue nil - efs-process-busy nil) - ;; The process may be in some strange state. Get rid of it. - (condition-case nil (delete-process proc) (error nil)) - (efs-call-cont cont 'fatal "" ""))))) - - (error "FTP process %s has died." (process-name proc)))) - -(efs-defun efs-quote-string nil (string &optional not-space) - "Quote any characters in STRING that may confuse the ftp process. -If NOT-SPACE is non-nil, then blank characters are not quoted, because -it is assumed that the string will be surrounded by \"'s." - (apply (function concat) - (mapcar (function - (lambda (char) - (if (or (< char ?\ ) - (and (null not-space) (= char ?\ )) - (> char ?\~) - (= char ?\") - (= char ?\\)) - (vector ?\\ char) - (vector char)))) - string))) - -(efs-defun efs-fix-path nil (path &optional reverse) - "Convert PATH from a unix format to a non-unix format. -If optional REVERSE, convert in the opposite direction." - (identity path)) - -(efs-defun efs-fix-dir-path nil (dir-path) - "Convert DIR-PATH from unix format to a non-unix format for a dir listing" - ;; The default def runs for dos-distinct, ka9q, and all the unix's. - ;; To be more careful about distinguishing dirs from plain files, - ;; we append a ".". - (let ((len (length dir-path))) - (if (and (not (zerop len)) (= (aref dir-path (1- len)) ?/)) - (concat dir-path ".") - dir-path))) - -(defun efs-send-cmd (host user cmd - &optional msg pre-cont cont nowait noretry) - "Find an ftp process connected to HOST logged in as USER and send it CMD. -MSG is an optional status message to be output before and after issuing the -command. - -See the documentation for efs-raw-send-cmd for a description of CONT, PRE-CONT -and NOWAIT. Normally, if the command fails it is retried. If NORETRY is -non-nil, this is not done." - ;; Handles conversion to remote pathname syntax and remote ls option - ;; capability. Also, sends umask if nec. - - (let ((proc (efs-get-process host user))) - - (if (and - (eq nowait t) - (save-excursion - (set-buffer (process-buffer proc)) - (or efs-process-busy - efs-process-cmd-waiting))) - - (progn - (efs-add-to-queue - host user - ;; Not nec. to store host and user, because the queue is for - ;; a specific host user pair anyway. Because the queue is always - ;; examined when efs-process-busy - ;; is nil, it should be impossible to get into a loop - ;; where we keep re-queueing over and over. To be on the safe - ;; side, store nowait as 1. - (list cmd msg pre-cont cont 1 noretry)) - nil) - - ;; Send a command. - - (let (cmd-string afsc-result afsc-line afsc-cont-lines) - - (let ((efs-nested-cmd t) - (cmd0 (car cmd)) - (cmd1 (nth 1 cmd)) - (cmd2 (nth 2 cmd)) - (cmd3 (nth 3 cmd))) - - (cond - - ((eq cmd0 'quote) - ;; QUOTEd commands - (cond - - ((eq cmd1 'site) - ;; SITE commands - (cond - ((memq cmd2 '(umask idle dos exec nfs group gpass)) - ;; For UMASK cmd3 = value of umask - ;; For IDLE cmd3 = idle setting, or nil if we're querying. - ;; For DOS and NFS cmd3 is nil. - ;; For EXEC cmd3 is the command to be exec'ed -- a string. - (if cmd3 (setq cmd3 (concat " " cmd3))) - (setq cmd-string (concat "quote site " (symbol-name cmd2) - cmd3))) - ((eq cmd2 'chmod) - (let* ((host-type (efs-host-type host user)) - (cmd4 (efs-quote-string - host-type (efs-fix-path host-type (nth 4 cmd))))) - (setq cmd-string (concat "quote site chmod " cmd3 " " - cmd4)))) - (t (error "efs: Don't know how to send %s %s %s %s" - cmd0 cmd1 cmd2 cmd3)))) - - ((memq cmd1 '(pwd xpwd syst pasv noop)) - (setq cmd-string (concat "quote " (symbol-name cmd1)))) - - ;; PORT command (cmd2 is IP + port address) - ((eq cmd1 'port) - (setq cmd-string (concat "quote port " cmd2))) - - ((memq cmd1 '(appe retr)) - (let ((host-type (efs-host-type host user))) - ;; Set an xfer type - (if cmd3 (efs-set-xfer-type host user cmd3 t)) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "quote " (symbol-name cmd1) " " - cmd2)))) - - ((eq cmd1 'stor) - (let ((host-type (efs-host-type host user))) - (if (memq host-type efs-unix-host-types) - (efs-set-umask host user)) - ;; Set an xfer type - (if cmd3 (efs-set-xfer-type host user cmd3 t)) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "quote stor " cmd2)))) - - ((memq cmd1 '(size mdtm rnfr)) - (let ((host-type (efs-host-type host user))) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "quote " - (symbol-name cmd1) " " cmd2)))) - - ((memq cmd1 '(pass user)) - (setq cmd-string (concat "quote " (symbol-name cmd1) " " cmd2))) - - (t - (error "efs: Don't know how to send %s %s %s %s" - cmd0 cmd1 cmd2 cmd3)))) - - ;; TYPE command - ((eq cmd0 'type) - (setq cmd-string (concat "type " (symbol-name cmd1)))) - - ;; DIR command - ;; cmd == 'dir "remote-path" "local-path" "ls-switches" - ((memq cmd0 '(dir nlist)) - (let ((host-type (efs-host-type host user)) - (listing-type (efs-listing-type host user))) - (setq cmd1 (efs-fix-dir-path host-type cmd1)) - (cond - ((memq listing-type efs-nlist-listing-types) - (setq cmd-string (concat efs-nlist-cmd " " - (efs-quote-string host-type cmd1) - " " cmd2))) - ((or (memq host-type efs-dumb-host-types) - (null cmd3)) - (setq cmd-string (format "%s %s %s" - (if (eq cmd0 'nlist) - efs-nlist-cmd - "dir") - (efs-quote-string host-type cmd1) - cmd2))) - ((setq cmd-string - (format "%s \"%s %s\" %s" - (if (eq cmd0 'nlist) - efs-nlist-cmd - "ls") - cmd3 (efs-quote-string host-type cmd1 t) - ;; cmd2 is a temp file, not nec. to quote. - cmd2)))))) - - ;; First argument is the remote pathname - ((memq cmd0 '(delete mkdir rmdir cd)) - (let ((host-type (efs-host-type host user))) - (setq cmd1 (efs-quote-string host-type - (efs-fix-path host-type cmd1)) - cmd-string (concat (symbol-name cmd0) " " cmd1)))) - - ;; GET command - ((eq cmd0 'get) - (let ((host-type (efs-host-type host user))) - (if cmd3 (efs-set-xfer-type host user cmd3)) - (efs-set-hash-mark-unit host user t) - (setq cmd1 (efs-quote-string host-type - (efs-fix-path host-type cmd1)) - cmd2 (efs-quote-string host-type cmd2) - cmd-string (concat "get " cmd1 " " cmd2)))) - - ;; PUT command - ((eq cmd0 'put) - (let ((host-type (efs-host-type host user))) - (if (memq host-type efs-unix-host-types) - (efs-set-umask host user)) - (if cmd3 (efs-set-xfer-type host user cmd3)) - (efs-set-hash-mark-unit host user) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd1 (efs-quote-string host-type cmd1) - cmd-string (concat "put " cmd1 " " cmd2)))) - - ;; APPEND command - ((eq cmd0 'append) - (let ((host-type (efs-host-type host user))) - (if cmd3 (efs-set-xfer-type host user cmd3)) - (efs-set-hash-mark-unit host user) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd1 (efs-quote-string host-type cmd1) - cmd-string (concat "append " cmd1 " " cmd2)))) - - ;; CHMOD command - ((eq cmd0 'chmod) - (let ((host-type (efs-host-type host user))) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "chmod " cmd1 " " cmd2)))) - - ;; Both arguments are remote pathnames - ((eq cmd0 'rename) - (let ((host-type (efs-host-type host user))) - (setq cmd1 (efs-quote-string host-type - (efs-fix-path host-type cmd1)) - cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "rename " cmd1 " " cmd2)))) - - ;; passive command - ((eq cmd0 'passive) - (setq cmd-string "passive")) - - (t - (error "efs: Don't know how to send %s %s %s %s" - cmd0 cmd1 cmd2 cmd3)))) - - ;; Actually send the resulting command. - ;; Why do we use this complicated binding of afsc-{result,line}, - ;; rather then use the fact that efs-raw-send-cmd returns? - ;; Because efs-raw-send-cmd returns the result of the first - ;; attempt only. efs-send-cmd should return the result of - ;; the retry, if one was necessary. - ;; Maybe it would be better if efs-raw-send-cmd returned - ;; the result of cont, if nowait was nil? Or maybe still return - ;; \(result line \)? As long as nowait is nil, it should - ;; return something useful. - - ;; Beware, if some of the above FTP commands had to restart - ;; the process, PROC won't be set to the right process object. - (setq proc (efs-get-process host user)) - - (efs-raw-send-cmd - proc - cmd-string - msg - pre-cont - (efs-cont (result line cont-lines) (host user proc cmd msg pre-cont - cont nowait noretry) - (cond ((and (null noretry) (eq result 'fatal)) - (let ((retry - (efs-send-cmd - host user cmd msg pre-cont cont - (if (eq nowait t) 1 nowait) t))) - (or cont nowait - (setq afsc-result (car retry) - afsc-line (nth 1 retry) - afsc-cont-lines (nth 2 retry))))) - ((and (eq result 'failed) - (or (memq (car cmd) '(append rename put)) - (and (eq (car cmd) 'quote) - (eq (nth 1 cmd) 'stor))) - (efs-save-match-data - (string-match efs-write-protect-msgs line))) - (let ((retry (efs-write-recover - (efs-host-type host) - line cont-lines host user cmd msg pre-cont - cont nowait noretry))) - (or cont nowait - (setq afsc-result (car retry) - afsc-line (nth 1 retry) - afsc-cont-lines (nth 2 retry))))) - - (t (if cont - (efs-call-cont cont result line cont-lines) - (or nowait - (setq afsc-result result - afsc-line line - afsc-cont-lines cont-lines)))))) - nowait) - - (prog1 - (if (or nowait cont) - nil - (list afsc-result afsc-line afsc-cont-lines)) - - ;; Check the queue - (or nowait - efs-nested-cmd - (let ((buff (efs-ftp-process-buffer host user))) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (if efs-process-q - (let ((next (car efs-process-q))) - (setq efs-process-q (cdr efs-process-q)) - (apply 'efs-send-cmd host user next)))))))))))) - -(efs-defun efs-write-recover nil - (line cont-lines host user cmd msg pre-cont cont nowait noretry) - "Called when a write command fails with `efs-write-protect-msgs'. -Should return \(result line cont-lines\), like `efs-raw-send-cmd'." - ;; This default version doesn't do anything. - (if cont - (progn - (efs-call-cont cont 'failed line cont-lines) - nil) - (if nowait nil (list 'failed line cont-lines)))) - -;;;; --------------------------------------------------------------------- -;;;; The login sequence. (The follows RFC959 rather tightly. If a server -;;;; can't even get the login codes right, it is -;;;; pretty much scrap metal.) -;;;; --------------------------------------------------------------------- - -;;;###autoload -(defun efs-nslookup-host (host) - "Attempt to resolve the given HOSTNAME using nslookup if possible." - (interactive "sHost: ") - (if efs-nslookup-program - (let* ((default-directory exec-directory) - (default-major-mode 'fundamental-mode) - (process-connection-type nil) - (proc (start-process " *nslookup*" " *nslookup*" - efs-nslookup-program host)) - (res host)) - (process-kill-without-query proc) - (save-excursion - (set-buffer (process-buffer proc)) - (let ((quit-flag nil) - (inhibit-quit nil)) - (while (memq (process-status proc) '(run open)) - (accept-process-output proc))) - (goto-char (point-min)) - (if (re-search-forward - "Name:.*\nAddress\\(es\\)?: *\\([.0-9]+\\)$" nil t) - (setq res (buffer-substring (match-beginning 2) - (match-end 2)))) - (kill-buffer (current-buffer))) - (if (interactive-p) - (message "%s: %s" host res)) - res) - (if (interactive-p) - (message - "No nslookup program. See the variable efs-nslookup-program.")) - host)) - -(defun efs-login (host user proc) - "Connect to the FTP-server on HOST as USER. -PROC is the process to the FTP-client. Doesn't call efs-save-match-data. -You must do that yourself." - (let ((gate (efs-use-gateway-p host))) - (if (eq gate 'kerberos) - (progn - (setq proc (efs-kerberos-login host user proc)) - (efs-login-send-user host user proc gate)) - (let ((to (if (memq gate '(proxy raptor)) - efs-gateway-host - host)) - port cmd result) - (if (string-match "#" to) - (setq port (substring to (match-end 0)) - to (substring to 0 (match-beginning 0)))) - (and efs-nslookup-on-connect - (string-match "[^0-9.]" to) - (setq to (efs-nslookup-host to))) - (setq cmd (concat "open " to)) - (if port (setq cmd (concat cmd " " port))) - - ;; Send OPEN command. - (setq result (efs-raw-send-cmd proc cmd nil)) - - (and (eq gate 'interlock) (string-match "^331 " (nth 1 result)) - (setq result (efs-login-send-pass - efs-gateway-host - (efs-get-user efs-gateway-host) proc))) - - ;; Analyze result of OPEN. - (if (car result) - (progn - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "OPEN request failed: " - (nth 1 result)))) - (efs-login-send-user host user proc gate)))))) - -(defun efs-login-send-user (host user proc &optional gate retry) - "Send user command to HOST and USER. PROC is the ftp client process. -Optional argument GATE specifies which type of gateway is being used. -RETRY argument specifies to try twice if we get a 421 response." - (let ((cmd (cond - ((memq gate '(proxy interlock)) - (format "quote USER \"%s\"@%s" user - (if (and efs-nslookup-on-connect - (string-match "[^0-9.]" host)) - (efs-nslookup-host host) - host))) - ((eq gate 'raptor) - (format "quote USER \"%s\"@%s %s" user - (if (and efs-nslookup-on-connect - (string-match "[^0-9.]" host)) - (efs-nslookup-host host) - host) - (nth 3 efs-gateway-type))) - ((eq gate 'kerberos) - (let ((to host) - port) - (if (string-match "#" host) - (progn - (setq to (substring host 0 (match-beginning 0)) - port (substring host (match-end 0))) - (and efs-nslookup-on-connect - (string-match "[^0-9.]" to) - (efs-nslookup-host to)) - (setq to (concat to "@" port)))) - (format "quote user \"%s\"@%s" user to))) - (t - (format "quote user \"%s\"" user)))) - (msg (format "Logging in as user %s%s..." user - (if (memq gate '(proxy raptor kerberos)) - (concat "@" host) ""))) - result code) - - ;; Send the message by hand so that we can report on the size - ;; of the MOTD. - (message msg) - - ;; Send USER command. - (setq result (efs-raw-send-cmd proc cmd nil)) - - ;; Analyze result of USER (this follows RFC959 strictly) - (if (< (length (nth 1 result)) 4) - (progn - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user - (concat "USER request failed: " (nth 1 result)))) - - (setq code (substring (nth 1 result) 0 4)) - (cond - - ((string-equal "331 " code) - ;; Need password - (setq result (efs-login-send-pass host user proc gate))) - - ((string-equal "332 " code) - ;; Need an account, but no password - (setq result (efs-login-send-acct host user proc gate))) - - ((null (car result)) - ;; logged in proceed - nil) - - ((and (or (string-equal "530 " code) (string-equal "421 " code)) - (efs-anonymous-p user) - (or (string-match efs-too-many-users-msgs (nth 1 result)) - (string-match efs-too-many-users-msgs (nth 2 result)))) - (if (save-window-excursion - (condition-case nil - (display-buffer (process-buffer proc)) - (error nil)) - (y-or-n-p (format - "Too many users for %s@%s. Try again? " - user host))) - (progn - ;; Set result to nil if we are doing a retry, so done - ;; message only gets sent once. - (setq result nil) - (if (string-equal code "530 ") - (efs-login-send-user host user proc gate t) - (efs-get-process host user))) - (signal 'quit nil))) - - ((and retry (string-equal code "421 ")) - (setq result nil) - (efs-get-process host user)) - - (t ; bombed - (condition-case nil (delete-process proc) (error nil)) - ;; Wrong username? - (efs-set-user host nil) - (efs-error host user - (concat "USER request failed: " (nth 1 result))))) - (and (null (car result)) - (stringp (nth 2 result)) - (message "%sdone%s" msg - (let ((n (efs-occur-in-string ?\n (nth 2 result)))) - (if (> n 1) - (format "; MOTD of %d lines" n) - ""))))))) - -(defun efs-login-send-pass (host user proc &optional gate) - "Sends password to HOST and USER. PROC is the ftp client process. -Doesn't call efs-save-match data. You must do that yourself." - ;; Note that efs-get-password always returns something. - ;; It prompts the user if necessary. Even if the returned password is - ;; \"\", send it, because we wouldn't be running this function - ;; if the server wasn't insisting on a password. - (let* ((pass "") - (qpass "") - (cmd "") - (result (unwind-protect - (progn - (condition-case nil - (setq pass (efs-get-passwd host user)) - (quit (condition-case nil - (kill-buffer (process-buffer proc)) - (error nil)) - (signal 'quit nil))) - (setq cmd (concat - "quote pass " - (setq qpass (efs-quote-string nil pass t)))) - (efs-raw-send-cmd proc cmd)) - (fillarray pass 0) - (fillarray qpass 0) - (fillarray cmd 0))) - (code (and (>= (length (nth 1 result)) 4) - (substring (nth 1 result) 0 4)))) - (or code (setq code "")) - ;; Analyze the result. - (cond - ((string-equal code "332 ") - ;; require an account passwd - (setq result (efs-login-send-acct host user proc gate))) - ((null (car result)) - ;; logged in proceed - nil) - ((or (string-equal code "530 ") (string-equal code "421 ")) - ;; Give the user another chance - (condition-case nil - (if (efs-anonymous-p user) - (if (or (string-match efs-too-many-users-msgs (nth 1 result)) - (string-match efs-too-many-users-msgs (nth 2 result))) - (if (save-window-excursion - (condition-case nil - (display-buffer (process-buffer proc)) - (error nil)) - (y-or-n-p (format - "Too many users for %s@%s. Try again? " - user host))) - (progn - ;; Return nil if we are doing a retry, so done - ;; message only gets sent once. - (setq result nil) - (if (string-equal code "530 ") - (efs-login-send-user host user proc gate) - (efs-get-process host user))) - (signal 'quit nil)) - (unwind-protect - (efs-set-passwd - host user - (save-window-excursion - (condition-case nil - (display-buffer (process-buffer proc)) - (error nil)) - (setq pass - (read-passwd - (format - "Password for %s@%s failed. Try again: " - user host))))) - (fillarray pass 0)) - (setq result nil) - (efs-login-send-user host user proc gate)) - (unwind-protect - (efs-set-passwd - host user - (setq pass - (read-passwd - (format "Password for %s@%s failed. Try again: " - user host)))) - (fillarray pass 0)) - (setq result nil) - (efs-login-send-user host user proc gate)) - (quit (condition-case nil (delete-process proc) (error nil)) - (efs-set-user host nil) - (efs-set-passwd host user nil) - (signal 'quit nil)) - (error (condition-case nil (delete-process proc) (error nil)) - (efs-set-user host nil) - (efs-set-passwd host user nil) - (efs-error host user "PASS request failed.")))) - (t ; bombed for unexplained reasons - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "PASS request failed: " (nth 1 result))))) - result)) - -(defun efs-login-send-acct (host user proc &optional gate) - "Sends account password to HOST and USER. PROC is the ftp client process. -Doesn't call efs-save-match data. You must do that yourself." - (let* ((acct "") - (qacct "") - (cmd "") - (result (unwind-protect - (progn - ;; The raptor gateway requires us to send a gateway - ;; authentication password for account. What if the - ;; remote server wants one too? - (setq acct (if (eq gate 'raptor) - (efs-get-account - efs-gateway-host - (nth 3 efs-gateway-type) nil t) - (efs-get-account host user nil t)) - qacct (efs-quote-string nil acct t) - cmd (concat "quote acct " qacct)) - (efs-raw-send-cmd proc cmd)) - (fillarray acct 0) - (fillarray qacct 0) - (fillarray cmd 0)))) - ;; Analyze the result - (cond - ((null (car result)) - ;; logged in proceed - nil) - ((eq (car result) 'failed) - ;; Give the user another chance - (condition-case nil - (progn - (unwind-protect - (progn - (setq acct (read-passwd - (format - "Account password for %s@%s failed. Try again: " - user host))) - (or (and efs-high-security-hosts - (string-match efs-high-security-hosts - (format "%s@%s" user host))) - (efs-set-account host user nil acct))) - (fillarray acct 0)) - (setq result (efs-login-send-user host user proc gate))) - (quit (condition-case nil (delete-process proc) (error nil))) - (error (condition-case nil (delete-process proc) (error nil)) - (efs-error host user "ACCT request failed.")))) - (t ; bombed for unexplained reasons - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "ACCT request failed: " (nth 1 result))))) - result)) - -;;;; ---------------------------------------------------------------------- -;;;; Changing working directory. -;;;; ---------------------------------------------------------------------- - -(defun efs-raw-send-cd (host user dir &optional no-error) - ;; If NO-ERROR, doesn't barf, but just returns success (t) or failure (nil). - ;; This does not use efs-send-cmd. - ;; Also DIR must be in the syntax of the remote host-type. - (let* ((cmd (concat "cd " dir)) - cd-result cd-line) - (efs-raw-send-cmd - (efs-get-process host user) - cmd nil nil - (efs-cont (result line cont-lines) (cmd) - (if (eq result 'fatal) - (efs-raw-send-cmd - (efs-get-process host user) - cmd nil nil - (function (lambda (result line cont-lines) - (setq cd-result result - cd-line line)))) - (setq cd-result result - cd-line line)))) - (if no-error - (null cd-result) - (if cd-result - (efs-error host user (concat "CD failed: " cd-line)))))) - -;;;; -------------------------------------------------------------- -;;;; Getting a PWD. -;;;; -------------------------------------------------------------- - -(defun efs-unquote-quotes (string) - ;; Unquote \"\"'s in STRING to \". - (let ((start 0) - new) - (while (string-match "\"\"" string start) - (setq new (concat new (substring - string start (1+ (match-beginning 0)))) - start (match-end 0))) - (if new - (concat new (substring string start)) - string))) - -(efs-defun efs-send-pwd nil (host user &optional xpwd) - "Attempts to get the current working directory for the given HOST/USER pair. -Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found, -and LINE is the relevant success or fail line from the FTP-server. If the -optional arg XPWD is given, uses this server command instead of PWD." - (let* ((result (efs-send-cmd host user - (list 'quote (if xpwd 'xpwd 'pwd)) - "Getting pwd")) - (line (nth 1 result)) - dir) - (or (car result) - (efs-save-match-data - (if (string-match "\"\\(.*\\)\"[^\"]*$" line) - (setq dir (efs-unquote-quotes (substring line (match-beginning 1) - (match-end 1)))) - (if (string-match " \\([^ ]+\\) " line) ; stone-age servers! - (setq dir (substring line - (match-beginning 1) - (match-end 1))))))) - (cons dir line))) - -(efs-defun efs-send-pwd super-dumb-unix (host user &optional xpwd) - ;; Guess at the pwd for a unix host that doesn't support pwd. - (if (efs-anonymous-p user) - ;; guess - (cons "/" "") - ;; Who knows? - (message "Can't obtain pwd for %s" host) - (ding) - (sleep-for 2) - (message "All file names must be specified as full paths.") - (cons nil ""))) - -;;;; -------------------------------------------------------- -;;;; Getting the SIZE of a remote file. -;;;; -------------------------------------------------------- - -(defun efs-send-size (host user file) - "For HOST and USER, get the size of FILE in bytes. -This returns a list \( SIZE . LINE \), where SIZE is the file size in bytes, -or nil if this couldn't be determined, and LINE is the output line of the -FTP server." - (efs-save-match-data - (let ((result (efs-send-cmd host user (list 'quote 'size file)))) - (setcar result - (and (null (car result)) - (string-match "^213 +\\([0-9]+\\)$" (nth 1 result)) - (string-to-int - (substring - (cdr result) - (match-beginning 1) (match-end 1))))) - result))) - -;;;; ------------------------------------------------------------ -;;;; umask support -;;;; ------------------------------------------------------------ - -(defun efs-umask (user) - "Returns the umask that efs will use for USER. -If USER is root or anonymous, then the values of efs-root-umask -and efs-anonymous-umask, respectively, take precedence, to be followed -by the value of efs-umask, and if this is nil, it returns your current -umask on the local machine. Returns nil if this can't be determined." - (or - (and (string-equal user "root") efs-root-umask) - (and (efs-anonymous-p user) - efs-anonymous-umask) - efs-umask - (let* ((shell (or (and (boundp 'explicit-shell-file-name) - explicit-shell-file-name) - (getenv "ESHELL") - (getenv "SHELL") - "/bin/sh")) - (default-major-mode 'fundamental-mode) - (default-directory exec-directory) - (buff (get-buffer-create " *efs-umask-data*"))) - (unwind-protect - (save-excursion - (set-buffer buff) - (call-process shell nil buff nil "-c" "umask") - (goto-char (point-min)) - (if (re-search-forward "[0-7]?[0-7]?[0-7]" nil t) - (string-to-int (buffer-substring (match-beginning 0) - (match-end 0))))) - (kill-buffer buff))))) - -(defun efs-send-umask (host user mask) - "Sets the umask on HOST for USER to MASK. -Returns t for success, nil for failure." - (interactive - (let* ((path (or buffer-file-name - (and (eq major-mode 'dired-mode) - dired-directory))) - (parsed (and path (efs-ftp-path path))) - (default-host (car parsed)) - (default-user (nth 1 parsed)) - (default-mask (efs-umask default-user))) - (list - (read-string "Host: " default-host) - (read-string "User: " default-user) - (read-string "Umask: " (int-to-string default-mask))))) - (let (int-mask) - (if (integerp mask) - (setq int-mask mask - mask (int-to-string mask)) - (setq int-mask (string-to-int mask))) - (or (string-match "^ *[0-7]?[0-7]?[0-7] *$" mask) - (error "Invalid umask %s" mask)) - (efs-send-cmd host user - (list 'quote 'site 'umask mask) - (concat "Setting umask to " mask) - (list - (function - (lambda (int-mask) - (let ((buff (efs-ftp-process-buffer host user))) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-umask int-mask)))))) - int-mask) - (efs-cont (result line cont-lines) (host user mask) - (if result - (let ((buff (efs-ftp-process-buffer host user))) - (efs-set-host-property host 'umask-failed t) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-umask nil))) - (message - "Unable to set umask to %s on %s" mask host) - (if efs-ding-on-umask-failure - (progn - (ding) - (sit-for 1)))))) - 0))) ; Do this NOWAIT = 0 - -(defun efs-set-umask (host user) - "Sets the umask for HOST and USER, if it has not already been set." - (save-excursion - (set-buffer (process-buffer (efs-get-process host user))) - (if (or efs-process-umask (efs-get-host-property host 'umask-failed)) - nil - (let ((umask (efs-umask user))) - (efs-send-umask host user umask) - t)))) ; Tell the caller that we did something. - -(defun efs-modes-from-umask (umask) - ;; Given the 3 digit octal integer umask, returns the decimal integer - ;; according to chmod that a file would be written with. - ;; Assumes only ordinary files, so ignores x bits. - (let* ((others (% umask 10)) - (umask (/ umask 10)) - (group (% umask 10)) - (umask (/ umask 10)) - (owner (% umask 10)) - (factor 1)) - (apply '+ - (mapcar - (function - (lambda (x) - (prog1 - (* factor (- 6 (- x (% x 2)))) - (setq factor (* factor 8))))) - (list others group owner))))) - -;;;; ------------------------------------------------------------ -;;;; Idle time manipulation. -;;;; ------------------------------------------------------------ - -(defun efs-check-idle (host user) - ;; We just toss it in the queue to run whenever there's time. - ;; Just fail quietly if this doesn't work. - (if (and (or efs-maximize-idle efs-expire-ftp-buffers) - (memq (efs-host-type host) efs-idle-host-types) - (null (efs-get-host-property host 'idle-failed))) - (let ((buffname (efs-ftp-process-buffer host user))) - (efs-add-to-queue - host user - (list '(quote site idle) - nil nil - (efs-cont (result line cont-lines) (host user buffname) - (efs-save-match-data - (if (and (null result) - (string-match efs-idle-msgs line)) - (let ((max (substring line (match-beginning 2) - (match-end 2)))) - (if (get-buffer buffname) - (save-excursion - (set-buffer buffname) - (setq efs-process-idle-time - (string-to-int - (substring line (match-beginning 1) - (match-end 1)))))) - (if (and efs-maximize-idle - (not (efs-anonymous-p user))) - (efs-add-to-queue - host user - (list - (list 'quote 'site 'idle max) - nil nil - (efs-cont (result line cont-lines) (buffname - max) - (and (null result) - (get-buffer buffname) - (save-excursion - (set-buffer buffname) - (setq efs-process-idle-time - (string-to-int max))))) - 0)))) - (efs-set-host-property host 'idle-failed t)))) - 0 nil))))) ; Using NOWAIT = 0 inhibits mode line toggling. - - -;;;; ------------------------------------------------------------ -;;;; Sending the SYST command for system type. -;;;; ------------------------------------------------------------ - -(defun efs-get-syst (host user) - "Use SYST to get the remote system type. -Returns the system type as a string if this succeeds, otherwise nil." - (let* ((result (efs-send-cmd host user '(quote syst))) - (line (nth 1 result))) - (efs-save-match-data - (and (null (car result)) - (string-match efs-syst-msgs line) - (substring line (match-end 0)))))) - -;;;; ------------------------------------------------------------ -;;;; File transfer representation type support -;;;; ------------------------------------------------------------ - -;;; Legal representation types are: image, ascii, ebcdic, tenex - -(efs-defun efs-file-type nil (path) - ;; Returns the file type for PATH, the full efs path, with filename FILE. - ;; The return value is one of 'text, '8-binary, or '36-binary. - (let ((parsed (efs-ftp-path path))) - (efs-save-match-data - (cond - ;; There is no special significance to temp names, but we assume that - ;; they exist on an 8-bit byte machine. - ((or (null path) - (let ((temp (intern-soft path efs-tmp-name-obarray))) - (and temp (memq temp efs-tmp-name-files)))) - '8-binary) - ((and (null parsed) (file-exists-p path)) - (efs-local-file-type path)) - ;; test special hosts - ((and parsed - efs-binary-file-host-regexp - (let ((case-fold-search t)) - (string-match efs-binary-file-host-regexp (car parsed)))) - '8-binary) - (t - ;; Test file names - (let ((file (efs-internal-file-name-nondirectory - (or (nth 2 parsed) path)))) - (cond - ;; test for PDP-10 binaries - ((and efs-36-bit-binary-file-name-regexp - (string-match efs-36-bit-binary-file-name-regexp file)) - '36-binary) - ((and efs-binary-file-name-regexp - (string-match efs-binary-file-name-regexp file)) - '8-binary) - ((and efs-text-file-name-regexp - (string-match efs-text-file-name-regexp file)) - 'text) - ;; by default - (t - '8-binary)))))))) - -(efs-define-fun efs-local-file-type (file) - ;; Looks at the beginning (magic-cookie) of a local file to determine - ;; if it is a text file or not. If it's not a text file, it doesn't care - ;; about what type of binary file, so this doesn't really look for a magic - ;; cookie. - ;; Doesn't call efs-save-match-data. The caller should do so. - (save-excursion - (set-buffer (get-buffer-create efs-data-buffer-name)) - (erase-buffer) - (insert-file-contents file nil 0 16) - (if (looking-at "[ -~\n\r\C-L]*\\'") - 'text - '8-binary))) - -(defun efs-rationalize-file-type (f-type t-type) - ;; When the original and new names for a file indicate - ;; different file types, this function applies an ad hoc heuristic - ;; to return a single file type. - (cond - ((eq f-type t-type) - f-type) - ((memq '36-binary (list f-type t-type)) - '36-binary) - ((memq '8-binary (list f-type t-type)) - '8-binary) - (t - 'text))) - -(defun efs-prompt-for-transfer-type (arg) - "Toggles value of efs-prompt-for-transfer-type. -With prefix arg, turns prompting on if arg is positive, otherwise turns -prompting off." - (interactive "P") - (if (if arg - (> (prefix-numeric-value arg) 0) - (null efs-prompt-for-transfer-type)) - ;; turn prompting on - (prog1 - (setq efs-prompt-for-transfer-type t) - (message "Prompting for FTP transfer TYPE is on.")) - (prog1 - (setq efs-prompt-for-transfer-type nil) - (message "Prompting for FTP transfer TYPE is off.")))) - -(defun efs-read-xfer-type (path) - ;; Prompt for the transfer type to use for PATH - (let ((type - (completing-read - (format "FTP transfer TYPE for %s: " (efs-relativize-filename path)) - '(("binary") ("image") ("ascii") ("ebcdic") ("tenex")) - nil t))) - (if (string-equal type "binary") - 'image - (intern type)))) - -(defun efs-xfer-type (f-host-type f-path t-host-type t-path - &optional via-local) - ;; Returns the transfer type for transferring a file. - ;; F-HOST-TYPE = the host type of the machine on which the file is from. - ;; F-PATH = path, in full efs-syntax, of the original file - ;; T-HOST-TYPE = host-type of the machine to which the file is being - ;; transferred. - ;; VIA-LOCAL = non-nil of the file is being moved through the local, or - ;; a gateway machine. - ;; Set F-PATH or T-PATH to nil, to indicate that the file is being - ;; transferred from/to a temporary file, whose name has no significance. - (let (temp) - (and f-path - (setq temp (intern-soft f-path efs-tmp-name-obarray)) - (memq temp efs-tmp-name-files) - (setq f-path nil)) - (and t-path - (setq temp (intern-soft t-path efs-tmp-name-obarray)) - (memq temp efs-tmp-name-files) - (setq t-path nil))) - (if (or (null (or f-host-type t-host-type)) (null (or f-path t-path))) - 'image ; local copy? - (if efs-prompt-for-transfer-type - (efs-read-xfer-type (if f-path f-path t-path)) - (let ((f-fs (cdr (assq f-host-type efs-file-type-alist))) - (t-fs (cdr (assq t-host-type efs-file-type-alist)))) - (if (and f-fs t-fs - (if efs-treat-crlf-as-nl - (and (eq (car f-fs) (car t-fs)) - (eq (nth 1 f-fs) (nth 1 t-fs)) - (let ((f2-fs (nth 2 f-fs)) - (t2-fs (nth 2 t-fs))) - (or (eq f2-fs t2-fs) - (and (memq f2-fs '(file-crlf file-nl)) - (memq t2-fs '(file-crlf file-nl)))))) - (equal f-fs t-fs))) - 'image - (let ((type (cond - ((and f-path t-path) - (efs-rationalize-file-type - (efs-file-type t-host-type t-path) - (efs-file-type f-host-type f-path))) - (f-path - (efs-file-type f-host-type f-path)) - (t-path - (efs-file-type t-host-type t-path))))) - (cond - ((eq type '36-binary) - 'image) - ((eq type '8-binary) - (if (or (eq (car f-fs) '36-bit-wa) - (eq (car t-fs) '36-bit-wa)) - 'tenex - 'image)) - (t ; handles 'text - (if (and t-fs f-fs (eq (nth 1 f-fs) 'ebcdic) - (eq (nth 1 t-fs) 'ebcdic) (null via-local)) - 'ebcdic - 'ascii))))))))) - -(defun efs-set-xfer-type (host user type &optional clientless) - ;; Sets the xfer type for HOST and USER to TYPE. - ;; If the connection is already using the required type, does nothing. - ;; If clientless is non-nil, we are using a quoted xfer command, and - ;; need to check if the client has changed things. - (save-excursion - (let ((buff (process-buffer (efs-get-process host user)))) - (set-buffer buff) - (or (if (and clientless efs-process-client-altered-xfer-type) - (or (eq type efs-process-client-altered-xfer-type) - (setq efs-process-client-altered-xfer-type nil)) - ;; We are sending a non-clientless command, so the client - ;; gets back in synch. - (setq efs-process-client-altered-xfer-type nil) - (and efs-process-xfer-type - (eq type efs-process-xfer-type))) - (let ((otype efs-process-xfer-type)) - ;; Set this now in anticipation that the TYPE command will work, - ;; in case other commands, such as efs-set-hash-mark-unit want to - ;; grok this before the TYPE command completes. - (setq efs-process-xfer-type type) - (efs-send-cmd - host user (list 'type type) - nil nil - (efs-cont (result line cont-lines) (host user type otype buff) - (if result - (unwind-protect - (efs-error host user (format "TYPE %s failed: %s" - (upcase (symbol-name type)) - line)) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-xfer-type otype)))))) - 0)))))) ; always send type commands NOWAIT = 0 - - -;;;; ------------------------------------------------------------ -;;;; Obtaining DIR listings. -;;;; ------------------------------------------------------------ - -(defun efs-ls-guess-switches () - ;; Tries to determine what would be the most useful switches - ;; to use for a DIR listing. - (if (and (boundp 'dired-listing-switches) - (stringp dired-listing-switches) - (efs-parsable-switches-p dired-listing-switches t)) - dired-listing-switches - "-al")) - -(efs-defun efs-ls-dumb-check nil (line host file path lsargs msg noparse - noerror nowait cont) - nil) - -(efs-defun efs-ls-dumb-check unknown (line host file path lsargs - msg noparse noerror nowait cont) - ;; Checks to see if the host type might be dumb unix. If so, returns the - ;; listing otherwise nil. - (and - lsargs - (string-match - ;; Some CMU servers return a 530 here. 550 is correct. - (concat "^5[35]0 \\(The file \\)?" - (regexp-quote (concat lsargs " " path))) - ;; 550 is for a non-accessible file -- RFC959 - line) - (progn - (if (eq (efs-host-type host) 'apollo-unix) - (efs-add-host 'dumb-apollo-unix host) - (efs-add-host 'dumb-unix host)) - ;; try again - (if nowait - t ; return t if asynch - ; This is because dumb-check can't run asynch. - ; This means that we can't recognize dumb hosts asynch. - ; Shouldn't be a problem. - (efs-ls file nil - (if (eq msg t) - (format "Relisting %s" (efs-relativize-filename file)) - msg) - noparse noerror nowait cont))))) - -;; With no-error nil, this function returns: -;; an error if file is not an efs-path -;; (This should never happen.) -;; an error if either the listing is unreadable or there is an ftp error. -;; the listing (a string), if everything works. -;; -;; With no-error t, it returns: -;; an error if not an efs-path -;; error if listing is unreable (most likely caused by a slow connection) -;; nil if ftp error (this is because although asking to list a nonexistent -;; directory on a remote unix machine usually (except -;; maybe for dumb hosts) returns an ls error, but no -;; ftp error, if the same is done on a VMS machine, -;; an ftp error is returned. Need to trap the error -;; so we can go on and try to list the parent.) -;; the listing, if everything works. - -(defun efs-ls (file lsargs msg &optional noparse noerror nowait cont nlist) - "Return the output of a `DIR' or `ls' command done over ftp. -FILE is the full name of the remote file, LSARGS is any args to pass to the -`ls' command. MSG is a message to be displayed while listing, if MSG is given -as t, a suitable message will be computed. If nil, no message will be -displayed. If NOPARSE is non-nil, then the listing will not be parsed and -stored in internal cache. Otherwise, the listing will be parsed, if LSARGS -allow it. If NOERROR is non-nil, then we return nil if the listing fails, -rather than signal an error. If NOWAIT is non-nil, we do the listing -asynchronously, returning nil. If CONT is non-nil it is called with first -argument the listing string." - ;; If lsargs are nil, this forces a one-time only dumb listing using dir. - (setq file (efs-expand-file-name file)) - (let ((parsed (efs-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (host-type (efs-host-type host user)) - (listing-type (efs-listing-type host user)) - (parse (cond - ((null noparse) - (efs-parsable-switches-p lsargs t)) - ((eq noparse 'parse) - t) - (t nil))) - (switches lsargs) - cache) - - (if (memq host-type efs-dumb-host-types) - (setq lsargs nil)) - (if (and (null efs-ls-uncache) - (setq cache - (or (efs-get-from-ls-cache file switches) - (and switches - (efs-convert-from-ls-cache - file switches host-type listing-type))))) - ;; The listing is in the mail, errr... cache. - (let (listing) - (if (stringp cache) - (setq listing cache) - (setq listing (car cache)) - (if (and parse (null (nth 1 cache))) - (save-excursion - (set-buffer - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create - efs-data-buffer-name))) - (erase-buffer) - (insert listing) - (goto-char (point-min)) - (efs-set-files - file - (efs-parse-listing listing-type - host user path - file lsargs)) - ;; Note that we have parsed it now. - (setcar (cdr cache) t)))) - (if cont (efs-call-cont cont listing)) - listing) - - (if cache - (efs-del-from-ls-cache file nil nil)) - ;; Need to get the listing via FTP. - (let* ((temp (efs-make-tmp-name host nil)) - (temp-file (car temp)) - listing-result) - (efs-send-cmd - host user - (list (if nlist 'nlist 'dir) path (cdr temp) lsargs) - (if (eq msg t) - (format "Listing %s" (efs-relativize-filename file)) - msg) - nil - (efs-cont (result line cont-lines) - (host-type listing-type host user temp-file path - switches file lsargs noparse parse noerror - msg nowait cont) - ;; The client flipped to ascii, remember this. - (let ((buff (get-buffer - (efs-ftp-process-buffer host user)))) - (if buff - (efs-save-buffer-excursion - (set-buffer buff) - (setq efs-process-client-altered-xfer-type - 'ascii)))) - (unwind-protect - (if result - (or (setq listing-result - (efs-ls-dumb-check - (and (or (eq host-type 'unknown) - (eq listing-type 'unix:unknown)) - 'unknown) - line host file path lsargs msg - noparse noerror nowait cont)) - ;; If dumb-check returns non-nil - ;; then it would have handled any error recovery - ;; and conts. listing-result would only be set to - ;; t if nowait was non-nil. Therefore, the final - ;; return for efs-ls could never be t, even if I - ;; set listing-result to t here. - (if noerror - (if cont - (efs-call-cont cont nil)) - (efs-error host user - (concat "DIR failed: " - line)))) - - ;; listing worked - (if (efs-ftp-path temp-file) - (efs-add-file-entry (efs-host-type efs-gateway-host) - temp-file nil nil nil)) - (save-excursion - ;; A hack to get around a jka-compr problem. - ;; Do we still need it? - (let ((default-major-mode 'fundamental-mode) - efs-verbose jka-compr-enabled) - (set-buffer (get-buffer-create - efs-data-buffer-name)) - (erase-buffer) - (if (or (file-readable-p temp-file) - (sleep-for efs-retry-time) - (file-readable-p temp-file)) - (insert-file-contents temp-file) - (efs-error host user - (format - "list data file %s not readable" - temp-file)))) - (if parse - (progn - (efs-set-files - file - (efs-parse-listing listing-type host user path - file lsargs)) - ;; Parsing may update the host type. - (and lsargs (memq (efs-host-type host) - efs-dumb-host-types) - (setq lsargs nil)))) - (let ((listing (buffer-string))) - (efs-add-to-ls-cache file lsargs listing parse) - (if (and (null lsargs) switches) - ;; Try to convert - (let ((conv (efs-get-ls-converter switches))) - (and conv - (setq conv (assoc - (char-to-string 0) - conv)) - (funcall (cdr conv) listing-type nil) - (setq listing (buffer-string))))) - (or nowait (setq listing-result listing)) - ;; Call the ls cont, with first arg the - ;; listing string. - (if cont - (efs-call-cont cont listing))))) - (efs-del-tmp-name temp-file))) - nowait) - (and (null nowait) listing-result)))) - (error "Attempt to get a remote listing for the local file %s" file)))) - - -;;;; =============================================================== -;;;; >7 -;;;; Parsing and storing remote file system data. -;;;; =============================================================== - -;;; The directory listing parsers do some host type guessing. -;;; Most of the host type guessing is done when the PWD output -;;; is parsed. A bit is done when the error codes for DIR are -;;; analyzed. - -;;;; ----------------------------------------------------------- -;;;; Caching directory listings. -;;;; ----------------------------------------------------------- - -;;; Aside from storing files data in a hashtable, a limited number -;;; of listings are stored in complete form in `efs-ls-cache'. - -(defun efs-del-from-ls-cache (file &optional parent-p dir-p) - ;; Deletes from the ls cache the listing for FILE. - ;; With optional PARENT-P, deletes any entry for the parent - ;; directory of FILE too. - ;; If DIR-P is non-nil, then the directory listing of FILE is to be deleted. - (if dir-p - (setq file (file-name-as-directory file)) - (setq file (directory-file-name file))) - (setq file (efs-canonize-file-name file)) - (if parent-p - (setq parent-p (file-name-directory - (if dir-p - (directory-file-name file) - file)))) - (setq efs-ls-cache - (delq nil - (mapcar - (if parent-p - (function - (lambda (x) - (let ((f-ent (car x))) - (and (not (string-equal file f-ent)) - (not (string-equal parent-p f-ent)) - x)))) - (function - (lambda (x) - (and (not (string-equal file (car x))) - x)))) - efs-ls-cache)))) - -(defun efs-wipe-from-ls-cache (host user) - ;; Remove from efs-ls-cache all listings for HOST and USER. - (let ((host (downcase host)) - (case-insens (memq (efs-host-type host) - efs-case-insensitive-host-types))) - (if case-insens (setq user (downcase user))) - (setq efs-ls-cache - (delq nil - (mapcar - (function - (lambda (x) - (let ((parsed (efs-ftp-path (car x)))) - (and (not - (and (string-equal (car parsed) host) - (string-equal (if case-insens - (downcase (nth 1 parsed)) - (nth 1 parsed)) - user))) - x)))) - efs-ls-cache))))) - -(defun efs-get-from-ls-cache (file switches) - ;; Returns the value in `ls-cache' for FILE and SWITCHES. - ;; Returns a list consisting of the listing string, and whether its - ;; already been parsed. This list is eq to the nthcdr 2 of the actual - ;; cache entry, so you can setcar it. - ;; For dumb listings, SWITCHES will be nil. - (let ((list efs-ls-cache) - (switches (efs-canonize-switches switches)) - (file (efs-canonize-file-name file))) - (catch 'done - (while list - (if (and (string-equal file (car (car list))) - (string-equal switches (nth 1 (car list)))) - (throw 'done (nthcdr 2 (car list))) - (setq list (cdr list))))))) - -(defun efs-add-to-ls-cache (file switches listing parsed) - ;; Only call after efs-get-from-cache returns nil, to avoid duplicate - ;; entries. PARSED should be t, if the listing has already been parsed. - (and (> efs-ls-cache-max 0) - (let ((switches (efs-canonize-switches switches)) - (file (efs-canonize-file-name file))) - (if (= efs-ls-cache-max 1) - (setq efs-ls-cache - (list (list file switches listing parsed))) - (if (>= (length efs-ls-cache) efs-ls-cache-max) - (setcdr (nthcdr (- efs-ls-cache-max 2) efs-ls-cache) nil)) - (setq efs-ls-cache (cons (list file switches listing parsed) - efs-ls-cache)))))) - -;;;; -------------------------------------------------------------- -;;;; Converting listings from cache. -;;;; -------------------------------------------------------------- - -(defun efs-get-ls-converter (to-switches) - ;; Returns converter alist for TO-SWITCHES - (efs-get-hash-entry (efs-canonize-switches to-switches) - efs-ls-converter-hashtable)) - -(defun efs-add-ls-converter (to-switches from-switches converter) - ;; Adds an entry to `efs-ls-converter-hashtable'. - ;; If from-switches is t, the converter converts from internal files - ;; hashtable. - (let* ((to-switches (efs-canonize-switches to-switches)) - (ent (efs-get-hash-entry to-switches efs-ls-converter-hashtable)) - (add (cons (or (eq from-switches t) - (efs-canonize-switches from-switches)) - converter))) - (if ent - (or (member add ent) - (nconc ent (list add))) - (efs-put-hash-entry to-switches (list add) efs-ls-converter-hashtable)))) - -(defun efs-convert-from-ls-cache (file switches host-type listing-type) - ;; Returns a listing by converting the switches from a cached listing. - (let ((clist (efs-get-ls-converter switches)) - (dir-p (= ?/ (aref file (1- (length file))))) - elt listing result regexp alist) - (while file ; this loop will iterate at most twice. - (setq alist clist) - (while alist - (setq elt (car alist)) - (if (eq (car elt) t) - (if (and dir-p (setq result (funcall (cdr elt) host-type - (let ((efs-ls-uncache t)) - (efs-get-files file)) - regexp))) - (setq alist nil - file nil) - (setq alist (cdr alist))) - (if (and (setq listing - (efs-get-from-ls-cache file (car elt))) - (save-excursion - (set-buffer - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create efs-data-buffer-name))) - (erase-buffer) - (insert (car listing)) - (and (funcall (cdr elt) listing-type regexp) - (setq result (buffer-string))))) - (setq alist nil - file nil) - (setq alist (cdr alist))))) - ;; Look for wildcards. - (if (and file (null dir-p) (null regexp)) - (setq regexp (efs-shell-regexp-to-regexp - (file-name-nondirectory file)) - file (file-name-directory file) - dir-p t) - (setq file nil))) - result)) - -;;; Define some converters - -(defun efs-unix-t-converter-sort-pred (elt1 elt2) - (let* ((data1 (car elt1)) - (data2 (car elt2)) - (year1 (car data1)) - (year2 (car data2)) - (month1 (nth 1 data1)) - (month2 (nth 1 data2)) - (day1 (nth 2 data1)) - (day2 (nth 2 data2)) - (hour1 (nth 3 data1)) - (hour2 (nth 3 data2)) - (minutes1 (nth 4 data1)) - (minutes2 (nth 4 data2))) - (if year1 - (and year2 - (or (> year1 year2) - (and (= year1 year2) - (or (> month1 month2) - (and (= month1 month2) - (> day1 day2)))))) - (if year2 - t - (or (> month1 month2) - (and (= month1 month2) - (or (> day1 day2) - (and (= day1 day2) - (or (> hour1 hour2) - (and (= hour1 hour2) - (> minutes1 minutes2))))))))))) - -(defun efs-unix-t-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let ((current-month (cdr (assoc (substring - (current-time-string) 4 7) - efs-month-alist))) - list-start start end list year month day hour minutes) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (forward-line 1) - (setq end (point)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp end t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq month (% (+ (- 11 current-month) - (cdr (assoc - (buffer-substring (match-beginning 2) - (match-end 2)) - efs-month-alist))) 12) - day (string-to-int - (buffer-substring (match-beginning 3) (match-end 3))) - year (buffer-substring (match-beginning 4) (match-end 4))) - (if (string-match ":" year) - (setq hour (string-to-int (substring year 0 - (match-beginning 0))) - minutes (string-to-int (substring year (match-end 0))) - year nil) - (setq hour nil - minutes nil - year (string-to-int year))) - (setq list (cons - (cons - (list year month day hour minutes) - (buffer-substring start end)) - list)) - (goto-char end)) - (setq list - (mapcar 'cdr - (sort list 'efs-unix-t-converter-sort-pred))) - (if reverse (setq list (nreverse list))) - (delete-region list-start (point)) - (apply 'insert list) - t))))) - -(efs-defun efs-t-converter nil (&optional regexp reverse) - ;; Converts listing without the t-switch, to ones with it. - nil) ; by default assume that we cannot work. - -(efs-fset 'efs-t-converter 'unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'sysV-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'apollo-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'bsd-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'dumb-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'dumb-apollo-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'super-dumb-unix 'efs-unix-t-converter) - -(defun efs-rt-converter (listing-type &optional regexp) - ;; Reverse time sorting - (efs-t-converter listing-type regexp t)) - -(defun efs-unix-alpha-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let (list list-start end start next) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (end-of-line) - (setq end (point) - next (1+ end)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp end t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq list - (cons - (cons (buffer-substring (point) end) - (buffer-substring start next)) - list)) - (goto-char next)) - (delete-region list-start (point)) - (apply 'insert - (mapcar 'cdr - (sort list (if reverse - (function - (lambda (x y) - (string< (car y) (car x)))) - (function - (lambda (x y) - (string< (car x) (car y)))))))) - t))))) - -(efs-defun efs-alpha-converter nil (&optional regexp reverse) - ;; Converts listing to lexigraphical order. - nil) ; by default assume that we cannot work. - -(efs-fset 'efs-alpha-converter 'unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'sysV-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'apollo-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'bsd-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'dumb-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'dumb-apollo-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'super-dumb-unix 'efs-unix-alpha-converter) - -(defun efs-ralpha-converter (listing-type &optional regexp) - ;; Reverse alphabetic - (efs-alpha-converter listing-type regexp t)) - -(defun efs-unix-S-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let (list list-start start next) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (forward-line 1) - (setq next (point)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp next t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq list - (cons - (cons (string-to-int - (buffer-substring (match-beginning 1) - (match-end 1))) - (buffer-substring start next)) - list)) - (goto-char next)) - (delete-region list-start (point)) - (apply 'insert - (mapcar 'cdr - (sort list (if reverse - (function - (lambda (x y) - (< (car x) (car y)))) - (function - (lambda (x y) - (> (car x) (car y)))))))) - t))))) - -(efs-defun efs-S-converter nil (&optional regexp reverse) - ;; Converts listing without the S-switch, to ones with it. - nil) ; by default assume that we cannot work. - -(efs-fset 'efs-S-converter 'unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'sysV-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'apollo-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'bsd-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'dumb-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'dumb-apollo-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'super-dumb-unix 'efs-unix-S-converter) - -(defun efs-rS-converter (listing-type &optional regexp) - ;; Reverse S switch. - (efs-S-converter listing-type regexp t)) - -(defun efs-unix-X-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let (next list list-start fnstart eol start end link-p) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (skip-chars-forward "0-9 ") - (setq link-p (= (following-char) ?l)) - (end-of-line) - (setq eol (point) - next (1+ eol)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp eol t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq fnstart (point)) - (or (and link-p (search-forward " -> " eol t) - (goto-char (match-beginning 0))) - (goto-char eol)) - (setq end (point)) - (skip-chars-backward "^." fnstart) - (setq list - (cons - (cons - (if (= (point) fnstart) - "" - (buffer-substring (point) end)) - (buffer-substring start next)) - list)) - (goto-char next)) - (delete-region list-start (point)) - (apply 'insert - (mapcar 'cdr - (sort list (if reverse - (function - (lambda (x y) - (string< (car y) (car x)))) - (function - (lambda (x y) - (string< (car x) (car y)))))))) - t))))) - -(efs-defun efs-X-converter nil (&optional regexp reverse) - ;; Sort on file name extension. By default do nothing - nil) - -(defun efs-rX-converter (listing-type &optional regexp) - (efs-X-converter listing-type regexp t)) - -(efs-fset 'efs-X-converter 'unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'sysV-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'apollo-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'bsd-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'dumb-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'dumb-apollo-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'super-dumb-unix 'efs-unix-X-converter) - -;;; Brief listings - -;;; The following functions do a heap better at packing than -;;; the usual ls listing. A variable column width is used. -(defun efs-column-widths (columns list &optional across) - ;; Returns the column widths for breaking LIST into - ;; COLUMNS number of columns. - (cond - ((null list) - nil) - ((= columns 1) - (list (apply 'max (mapcar 'length list)))) - ((let* ((len (length list)) - (col-length (/ len columns)) - (remainder (% len columns)) - (i 0) - (j 0) - (max-width 0) - widths padding) - (if (zerop remainder) - (setq padding 0) - (setq col-length (1+ col-length) - padding (- columns remainder))) - (setq list (nconc (copy-sequence list) (make-list padding nil))) - (setcdr (nthcdr (1- (+ len padding)) list) list) - (while (< i columns) - (while (< j col-length) - (setq max-width (max max-width (length (car list))) - list (if across (nthcdr columns list) (cdr list)) - j (1+ j))) - (setq widths (cons (+ max-width 2) widths) - max-width 0 - j 0 - i (1+ i)) - (if across (setq list (cdr list)))) - (setcar widths (- (car widths) 2)) - (nreverse widths))))) - -(defun efs-calculate-columns (list &optional across) - ;; Returns a list of integers which are the column widths that best pack - ;; LIST, a list of strings, onto the screen. - (and list - (let* ((width (1- (window-width))) - (columns (max 1 (/ width - (+ 2 (apply 'max (mapcar 'length list)))))) - col-list last-col-list) - (while (<= (apply '+ (setq col-list - (efs-column-widths columns list across))) - width) - (setq columns (1+ columns) - last-col-list col-list)) - (or last-col-list col-list)))) - -(defun efs-format-columns-of-files (files &optional across) - ;; Returns the number of lines used. - ;; If ACROSS is non-nil, sorts across rather than down the buffer, like - ;; ls -x - ;; A beefed up version of the function in dired. Thanks Sebastian. - (and files - (let* ((columns (efs-calculate-columns files across)) - (ncols (length columns)) - (ncols1 (1- ncols)) - (nfiles (length files)) - (nrows (+ (/ nfiles ncols) - (if (zerop (% nfiles ncols)) 0 1))) - (space-left (- (window-width) (apply '+ columns) 1)) - (stretch (/ space-left ncols1)) - (float-stretch (if (zerop ncols1) 0 (% space-left ncols1))) - (i 0) - (j 0) - (result "") - file padding) - (setq files (nconc (copy-sequence files) ; fill up with empty fns - (make-list (- (* ncols nrows) nfiles) ""))) - (setcdr (nthcdr (1- (length files)) files) files) ; make circular - (while (< j nrows) - (while (< i ncols) - (setq result (concat result (setq file (car files)))) - (setq padding (- (nth i columns) (length file))) - (or (= i ncols1) - (progn - (setq padding (+ padding stretch)) - (if (< i float-stretch) (setq padding (1+ padding))))) - (setq result (concat result (make-string padding ?\ ))) - (setq files (if across (cdr files) (nthcdr nrows files)) - i (1+ i))) - (setq result (concat result "\n")) - (setq i 0 - j (1+ j)) - (or across (setq files (cdr files)))) - result))) - -(defun efs-brief-converter (host-type file-table F a A p x C &optional regexp) - ;; Builds a brief directory listing for file cache, with - ;; possible switches F, a, A, p, x. - (efs-save-match-data - (let (list ent modes) - (efs-map-hashtable - (function - (lambda (key val) - (if (and - (efs-really-file-p host-type key val) - (or a - (and A (not (or (string-equal "." key) - (string-equal ".." key)))) - (/= (string-to-char key) ?.)) - (or (null regexp) - (string-match regexp key))) - (setq ent (car val) - modes (nth 3 val) - list (cons - (cond ((null (or F p)) - key) - ((eq t ent) - (concat key "/")) - ((cond - ((null F) - key) - ((stringp ent) - (concat key "@")) - ((null modes) - key) - ((eq (string-to-char modes) ?s) - ;; a socket - (concat key "=")) - ((or - (memq (elt modes 3) '(?x ?s ?t)) - (memq (elt modes 6) '(?x ?s ?t)) - (memq (elt modes 9) '(?x ?s ?t))) - (concat key "*")) - (t - key)))) - list))))) - file-table) - (setq list (sort list 'string<)) - (if (or C x) - (efs-format-columns-of-files list x) - (concat (mapconcat 'identity list "\n") "\n"))))) - -;;; Store converters. - -;; The cheaters. -(efs-add-ls-converter "-al" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) -(efs-add-ls-converter "-Al" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) -(efs-add-ls-converter "-alF" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) -(efs-add-ls-converter "-AlF" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) - -(efs-add-ls-converter "-alt" "-al" 'efs-t-converter) -(efs-add-ls-converter "-Alt" "-Al" 'efs-t-converter) -(efs-add-ls-converter "-lt" "-l" 'efs-t-converter) -(efs-add-ls-converter "-altF" "-alF" 'efs-t-converter) -(efs-add-ls-converter "-AltF" "-AlF" 'efs-t-converter) -(efs-add-ls-converter "-ltF" "-lF" 'efs-t-converter) -(efs-add-ls-converter "-alt" nil 'efs-t-converter) -(efs-add-ls-converter "-altF" nil 'efs-t-converter) -(efs-add-ls-converter "-Alt" nil 'efs-t-converter) ; cheating a bit -(efs-add-ls-converter "-AltF" nil 'efs-t-converter) ; cheating a bit - -(efs-add-ls-converter "-altr" "-al" 'efs-rt-converter) -(efs-add-ls-converter "-Altr" "-Al" 'efs-rt-converter) -(efs-add-ls-converter "-ltr" "-l" 'efs-rt-converter) -(efs-add-ls-converter "-altFr" "-alF" 'efs-rt-converter) -(efs-add-ls-converter "-AltFr" "-AlF" 'efs-rt-converter) -(efs-add-ls-converter "-ltFr" "-lF" 'efs-rt-converter) -(efs-add-ls-converter "-altr" nil 'efs-rt-converter) -(efs-add-ls-converter "-Altr" nil 'efs-rt-converter) - -(efs-add-ls-converter "-alr" "-alt" 'efs-alpha-converter) -(efs-add-ls-converter "-Alr" "-Alt" 'efs-alpha-converter) -(efs-add-ls-converter "-lr" "-lt" 'efs-alpha-converter) -(efs-add-ls-converter "-alFr" "-alFt" 'efs-alpha-converter) -(efs-add-ls-converter "-AlFr" "-AlFt" 'efs-alpha-converter) -(efs-add-ls-converter "-lFr" "-lFt" 'efs-alpha-converter) - -(efs-add-ls-converter "-al" "-alt" 'efs-alpha-converter) -(efs-add-ls-converter "-Al" "-Alt" 'efs-alpha-converter) -(efs-add-ls-converter "-l" "-lt" 'efs-alpha-converter) -(efs-add-ls-converter "-alF" "-alFt" 'efs-alpha-converter) -(efs-add-ls-converter "-AlF" "-AlFt" 'efs-alpha-converter) -(efs-add-ls-converter "-lF" "-lFt" 'efs-alpha-converter) -(efs-add-ls-converter nil "-alt" 'efs-alpha-converter) - -(efs-add-ls-converter "-alr" "-al" 'efs-ralpha-converter) -(efs-add-ls-converter "-Alr" "-Al" 'efs-ralpha-converter) -(efs-add-ls-converter "-lr" "-l" 'efs-ralpha-converter) -(efs-add-ls-converter "-alFr" "-alF" 'efs-ralpha-converter) -(efs-add-ls-converter "-lAFr" "-lAF" 'efs-ralpha-converter) -(efs-add-ls-converter "-lFr" "-lF" 'efs-ralpha-converter) -(efs-add-ls-converter "-alr" nil 'efs-ralpha-converter) - -(efs-add-ls-converter "-alr" "-alt" 'efs-ralpha-converter) -(efs-add-ls-converter "-Alr" "-Alt" 'efs-ralpha-converter) -(efs-add-ls-converter "-lr" "-lt" 'efs-ralpha-converter) -(efs-add-ls-converter "-alFr" "-alFt" 'efs-ralpha-converter) -(efs-add-ls-converter "-lAFr" "-lAFt" 'efs-ralpha-converter) -(efs-add-ls-converter "-lFr" "-lFt" 'efs-ralpha-converter) - -(efs-add-ls-converter "-alS" "-al" 'efs-S-converter) -(efs-add-ls-converter "-AlS" "-Al" 'efs-S-converter) -(efs-add-ls-converter "-lS" "-l" 'efs-S-converter) -(efs-add-ls-converter "-alSF" "-alF" 'efs-S-converter) -(efs-add-ls-converter "-AlSF" "-AlF" 'efs-S-converter) -(efs-add-ls-converter "-lSF" "-lF" 'efs-S-converter) -(efs-add-ls-converter "-alS" nil 'efs-S-converter) - -(efs-add-ls-converter "-alSr" "-al" 'efs-rS-converter) -(efs-add-ls-converter "-AlSr" "-Al" 'efs-rS-converter) -(efs-add-ls-converter "-lSr" "-l" 'efs-rS-converter) -(efs-add-ls-converter "-alSFr" "-alF" 'efs-rS-converter) -(efs-add-ls-converter "-AlSFr" "-AlF" 'efs-rS-converter) -(efs-add-ls-converter "-lSFr" "-lF" 'efs-rS-converter) -(efs-add-ls-converter "-alSr" nil 'efs-rS-converter) - -(efs-add-ls-converter "-alS" "-alt" 'efs-S-converter) -(efs-add-ls-converter "-AlS" "-Alt" 'efs-S-converter) -(efs-add-ls-converter "-lS" "-lt" 'efs-S-converter) -(efs-add-ls-converter "-alSF" "-alFt" 'efs-S-converter) -(efs-add-ls-converter "-AlSF" "-AlFt" 'efs-S-converter) -(efs-add-ls-converter "-lSF" "-lFt" 'efs-S-converter) - -(efs-add-ls-converter "-alSr" "-alt" 'efs-rS-converter) -(efs-add-ls-converter "-AlSr" "-Alt" 'efs-rS-converter) -(efs-add-ls-converter "-lSr" "-lt" 'efs-rS-converter) -(efs-add-ls-converter "-alSFr" "-alFt" 'efs-rS-converter) -(efs-add-ls-converter "-AlSFr" "-AlFt" 'efs-rS-converter) -(efs-add-ls-converter "-lSFr" "-lFt" 'efs-rS-converter) - -(efs-add-ls-converter "-AlX" nil 'efs-X-converter) -(efs-add-ls-converter "-alX" nil 'efs-X-converter) -(efs-add-ls-converter "-AlXr" nil 'efs-rX-converter) -(efs-add-ls-converter "-alXr" nil 'efs-rX-converter) - -(efs-add-ls-converter "-alX" "-al" 'efs-X-converter) -(efs-add-ls-converter "-AlX" "-Al" 'efs-X-converter) -(efs-add-ls-converter "-lX" "-l" 'efs-X-converter) -(efs-add-ls-converter "-alXF" "-alF" 'efs-X-converter) -(efs-add-ls-converter "-AlXF" "-AlF" 'efs-X-converter) -(efs-add-ls-converter "-lXF" "-lF" 'efs-X-converter) - -(efs-add-ls-converter "-alXr" "-al" 'efs-rX-converter) -(efs-add-ls-converter "-AlXr" "-Al" 'efs-rX-converter) -(efs-add-ls-converter "-lXr" "-l" 'efs-rX-converter) -(efs-add-ls-converter "-alXFr" "-alF" 'efs-rX-converter) -(efs-add-ls-converter "-AlXFr" "-AlF" 'efs-rX-converter) -(efs-add-ls-converter "-lXFr" "-lF" 'efs-rX-converter) - -;;; Converters for efs-files-hashtable - -(efs-add-ls-converter - "" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil nil nil nil regexp)))) -(efs-add-ls-converter - "-C" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil nil nil t regexp)))) -(efs-add-ls-converter - "-F" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - t nil nil nil nil nil regexp)))) -(efs-add-ls-converter - "-p" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil t nil nil regexp)))) -(efs-add-ls-converter - "-CF" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - t nil nil nil nil t regexp)))) -(efs-add-ls-converter - "-Cp" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil nil t nil t regexp)))) -(efs-add-ls-converter - "-x" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil nil t nil regexp)))) -(efs-add-ls-converter - "-xF" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t nil nil nil t nil regexp)))) -(efs-add-ls-converter - "-xp" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil nil t t nil regexp)))) -(efs-add-ls-converter - "-Ca" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil nil nil t regexp)))) -(efs-add-ls-converter - "-CFa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t t nil nil nil t regexp)))) -(efs-add-ls-converter - "-Cpa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil t nil t regexp)))) -(efs-add-ls-converter - "-xa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil nil t nil regexp)))) -(efs-add-ls-converter - "-xFa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t t nil nil t nil regexp)))) -(efs-add-ls-converter - "-xpa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil t t nil regexp)))) -(efs-add-ls-converter - "-CA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t nil nil t regexp)))) -(efs-add-ls-converter - "-CFA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t nil t nil nil t regexp)))) -(efs-add-ls-converter - "-CpA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t t nil t regexp)))) -(efs-add-ls-converter - "-xA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t nil t nil regexp)))) -(efs-add-ls-converter - "-xFA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t nil t nil t nil regexp)))) -(efs-add-ls-converter - "-xpA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t t t nil regexp)))) - -;;;; ------------------------------------------------------------ -;;;; Directory Listing Parsers -;;;; ------------------------------------------------------------ - -(defconst efs-unix:dl-listing-regexp - "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") - -;; Note to progammers: -;; Below are a series of macros and functions used for parsing unix -;; file listings. They are intended only to be used together, so be careful -;; about using them out of context. - -(defmacro efs-ls-parse-file-line () - ;; Extract the filename, size, and permission string from the current - ;; line of a dired-like listing. Assumes that the point is at - ;; the beginning of the line, leaves it just before the size entry. - ;; Returns a list (name size perm-string nlinks owner). - ;; If there is no file on the line, returns nil. - (` (let ((eol (save-excursion (end-of-line) (point))) - name size modes nlinks owner) - (skip-chars-forward " 0-9" eol) - (and - (looking-at efs-modes-links-owner-regexp) - (setq modes (buffer-substring (match-beginning 1) - (match-end 1)) - nlinks (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))) - owner (buffer-substring (match-beginning 3) (match-end 3))) - (re-search-forward efs-month-and-time-regexp eol t) - (setq name (buffer-substring (point) eol) - size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (list name size modes nlinks owner))))) - -(defun efs-relist-symlink (host user symlink path switches) - ;; Does a re-list of a single symlink in efs-data-buffer-name-2, - ;; HOST = remote host - ;; USER = remote username - ;; SYMLINK = symbolic link name as a remote fullpath - ;; PATH = efs full path syntax for the dir. being listed - ;; SWITCHES = ls switches to use for the re-list - ;; Returns (symlink-name symlink-target), as given by the listing. Returns - ;; nil if the listing fails. - ;; Does NOT correct for any symlink marking. - (let* ((temp (efs-make-tmp-name host nil)) - (temp-file (car temp)) - (default-major-mode 'fundamental-mode) - spot) - (unwind-protect - (and - (prog1 - (null - (car - (efs-send-cmd host user - (list 'dir symlink (cdr temp) switches) - (format "Listing %s" - (efs-relativize-filename - (efs-replace-path-component - path symlink)))))) - ;; Put the old message back. - (if (and efs-verbose - (not (and (boundp 'dired-in-query) dired-in-query))) - (message "Listing %s..." - (efs-relativize-filename path)))) - (save-excursion - (if (efs-ftp-path temp-file) - (efs-add-file-entry (efs-host-type efs-gateway-host) - temp-file nil nil nil)) - (set-buffer (get-buffer-create efs-data-buffer-name-2)) - (erase-buffer) - (if (or (file-readable-p temp-file) - (sleep-for efs-retry-time) - (file-readable-p temp-file)) - (let (efs-verbose) - (insert-file-contents temp-file)) - (efs-error host user - (format - "list data file %s not readable" temp-file))) - (skip-chars-forward " 0-9") - (and - (eq (following-char) ?l) - (re-search-forward efs-month-and-time-regexp nil t) - (setq spot (point)) - (re-search-forward " -> " nil t) - (progn - (end-of-line) - (list - ;; We might get the full path in the listing. - (file-name-nondirectory - (buffer-substring spot (match-beginning 0))) - (buffer-substring (match-end 0) (point))))))) - (efs-del-tmp-name temp-file)))) - -(defun efs-ls-sysV-p (host user dir linkname path) - ;; Returns t if the symlink is listed in sysV style. i.e. The - ;; symlink name is marked with an @. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory being listed as a remote full path. - ;; LINKNAME = relative name of symbolic link as derived from an ls -..F... - ;; this is assumed to end with an @ - ;; PATH = efs full path synatx for the directory - (let ((link (car (efs-relist-symlink - host user - (concat dir (substring linkname 0 -1)) - path "-lFd" )))) - (and link (string-equal link linkname)))) - -(defun efs-ls-next-p (host user dir linkname target path) - ;; Returns t is the symlink is marked in the NeXT style. - ;; i.e. The symlink destination is marked with an @. - ;; This assumes that the host-type has already been identified - ;; as NOT sysV-unix, and that target ends in an "@". - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory being listed, as a remore full path - ;; LINKNAME = relative name of symbolic link - ;; Since we've eliminated sysV, it won't be marked with an @ - ;; TARGET = target of symbolic link, as derived from an ls -..F.. - ;; PATH = directory being listed in full efs path syntax. - (let ((no-F-target (nth 1 (efs-relist-symlink - host user - (concat dir linkname) - path "-ld")))) - (and no-F-target - (string-equal (concat no-F-target "@") target)))) - -;; This deals with the F switch. Should also do something about -;; unquoting names obtained with the SysV b switch and the GNU Q -;; switch. See Sebastian's dired-get-filename. - -(defun efs-ls-parser (host-type host user dir path switches) - ;; Meant to be called by efs-parse-listing. - ;; Assumes that point is at the beginning of the first file line. - ;; Assumes that SWITCHES has already been bound to nil for a dumb host. - ;; HOST-TYPE is the remote host-type - ;; HOST is the remote host name - ;; USER is the remote user name - ;; DIR is the remote directory as a full path - ;; PATH is the directory in full efs syntax, and directory syntax. - ;; SWITCHES is the ls listing switches - (let ((tbl (efs-make-hashtable)) - (used-F (and switches (string-match "F" switches))) - (old-tbl (efs-get-files-hashtable-entry path)) - file-type symlink directory file size modes nlinks owner) - (while (setq file (efs-ls-parse-file-line)) - (setq size (nth 1 file) - modes (nth 2 file) - nlinks (nth 3 file) - owner (nth 4 file) - file (car file) - file-type (string-to-char modes) - directory (eq file-type ?d)) - (if (eq file-type ?l) - (if (string-match " -> " file) - (setq symlink (substring file (match-end 0)) - file (substring file 0 (match-beginning 0))) - ;; Shouldn't happen - (setq symlink "")) - (setq symlink nil)) - (if used-F - ;; The F-switch jungle - (let ((socket (eq file-type ?s)) - (fifo (eq file-type ?p)) - (executable - (and (not symlink) ; x bits don't mean a thing for symlinks - (or (memq (elt modes 3) '(?x ?s ?t)) - (memq (elt modes 6) '(?x ?s ?t)) - (memq (elt modes 9) '(?x ?s ?t)))))) - ;; Deal with marking of directories, executables, and sockets. - (if (or (and executable (string-match "*$" file)) - (and socket (string-match "=$" file)) - (and fifo (string-match "|$" file))) - (setq file (substring file 0 -1)) - ;; Do the symlink dance. - (if symlink - (let ((fat-p (string-match "@$" file)) - (sat-p (string-match "@$" symlink))) - (cond - ;; Those that mark the file - ((and (memq host-type '(sysV-unix apollo-unix)) fat-p) - (setq file (substring file 0 -1))) - ;; Those that mark nothing - ((memq host-type '(bsd-unix dumb-unix))) - ;; Those that mark the target - ((and (eq host-type 'next-unix) sat-p) - (setq symlink (substring symlink 0 -1))) - ;; We don't know - ((eq host-type 'unix) - (if fat-p - (cond - ((efs-ls-sysV-p host user dir - file path) - (setq host-type 'sysV-unix - file (substring file 0 -1)) - (efs-add-host 'sysV-unix host) - (efs-add-listing-type 'sysV-unix host user)) - ((and sat-p - (efs-ls-next-p host user dir file symlink - path)) - (setq host-type 'next-unix - symlink (substring symlink 0 -1)) - (efs-add-host 'next-unix host) - (efs-add-listing-type 'next-unix host user)) - (t - (setq host-type 'bsd-unix) - (efs-add-host 'bsd-unix host) - (efs-add-listing-type 'bsd-unix host user))) - (if (and sat-p - (efs-ls-next-p host user dir file - symlink path)) - (progn - (setq host-type 'next-unix - symlink (substring symlink 0 -1)) - (efs-add-host 'next-unix host) - (efs-add-listing-type 'next-unix host user)) - (setq host-type 'bsd-unix) - (efs-add-host 'bsd-unix host) - (efs-add-listing-type 'bsd-unix host user))))) - ;; Look out for marking of symlink - ;; If we really wanted to, at this point we - ;; could distinguish aix from hp-ux, ultrix, irix and a/ux, - ;; allowing us to skip the re-list in the future, for the - ;; later 4 host types. Another version... - (if (string-match "[=|*]$" symlink) - (let ((relist (efs-relist-symlink - host user (concat dir file) - path "-dl"))) - (if relist (setq symlink (nth 1 relist)))))))))) - ;; Strip / off the end unconditionally. It's not a valid file character - ;; anyway. - (if (string-match "/$" file) (setq file (substring file 0 -1))) - (let ((mdtm (and old-tbl (nth 5 (efs-get-hash-entry file old-tbl))))) - (if mdtm - (efs-put-hash-entry file (list (or symlink directory) size owner - modes nlinks mdtm) tbl) - (efs-put-hash-entry file (list (or symlink directory) size owner - modes nlinks) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)) - -(efs-defun efs-parse-listing nil (host user dir path &optional switches) - ;; Parse the a listing which is assumed to be from some type of unix host. - ;; Note that efs-key will be bound to the actual host type. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches used for the listing - (efs-save-match-data - (cond - ;; look for total line - ((looking-at "^total [0-9]+$") - (forward-line 1) - ;; Beware of machines that put a blank line after the totals line. - (skip-chars-forward " \t\n") - (efs-ls-parser efs-key host user dir path switches)) - ;; look for errors - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - nil) - ((eobp) ; i.e. zerop buffer-size - nil) ; assume an ls error message - ;; look for listings without total lines - ((re-search-forward efs-month-and-time-regexp nil t) - (beginning-of-line) - (efs-ls-parser efs-key host user dir path switches)) - (t nil)))) - -(efs-defun efs-parse-listing unix:unknown - (host user dir path &optional switches) - ;; Parse the a listing which is assumed to be from some type of unix host, - ;; possibly one doing a dl listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches used for the listing - (efs-save-match-data - (cond - ;; look for total line - ((looking-at "^total [0-9]+$") - (forward-line 1) - ;; Beware of machines that put a blank line after the totals line. - (skip-chars-forward " \t\n") - ;; This will make the listing-type track the host-type. - (efs-add-listing-type nil host user) - (efs-ls-parser 'unix host user dir path switches)) - ;; look for errors - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - nil) - ((eobp) ; i.e. zerop buffer-size - nil) ; assume an ls error message - ;; look for listings without total lines - ((and (re-search-forward efs-month-and-time-regexp nil t) - (progn - (beginning-of-line) - (looking-at efs-modes-links-owner-regexp))) - (efs-add-listing-type nil host user) - (efs-ls-parser 'unix host user dir path switches)) - ;; look for dumb listings - ((re-search-forward - (concat (regexp-quote switches) - " not found\\|\\(^ls: +illegal option -- \\)") - (save-excursion (end-of-line) (point)) t) - (if (eq (efs-host-type host) 'apollo-unix) - (progn - (efs-add-host 'dumb-apollo-unix host) - (efs-add-listing-type 'dumb-apollo-unix host user)) - (efs-add-host 'dumb-unix host) - (efs-add-listing-type 'dumb-unix host user)) - (if (match-beginning 1) - ;; Need to try to list again. - (let ((efs-ls-uncache t)) - (efs-ls - path nil (format "Relisting %s" (efs-relativize-filename path)) t) - (goto-char (point-min)) - (efs-parse-listing nil host user dir path switches)) - (if (re-search-forward "^total [0-9]+$" nil t) - (progn - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (efs-ls-parser 'dumb-unix host user dir path switches))))) - ;; Look for dl listings. - ((re-search-forward efs-unix:dl-listing-regexp nil t) - (efs-add-host 'unix host) - (efs-add-listing-type 'unix:dl host user) - (efs-parse-listing 'unix:dl host user dir path switches)) - ;; don't know, return nil - (t nil)))) - -(defun efs-ls-parse-1-liner (filename buffer &optional symlink) - ;; Parse a 1-line listing for FILENAME in BUFFER, and update - ;; the cached info for FILENAME. - ;; Optional SYMLINK arg gives the expected target of a symlink. - ;; Since one-line listings are usually used to update info for - ;; newly created files, we usually know what sort of a file to expect. - ;; Actually trying to parse out the symlink target could be impossible - ;; for some types of switches. - (efs-save-buffer-excursion - (set-buffer buffer) - (goto-char (point-min)) - (skip-chars-forward " 0-9") - (efs-save-match-data - (let (modes nlinks owner size) - (and - (looking-at efs-modes-links-owner-regexp) - (setq modes (buffer-substring (match-beginning 1) (match-end 1)) - nlinks (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))) - owner (buffer-substring (match-beginning 3) (match-end 3))) - (re-search-forward efs-month-and-time-regexp nil t) - (setq size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (let* ((filename (directory-file-name filename)) - (files (efs-get-files-hashtable-entry - (file-name-directory filename)))) - (if files - (let* ((key (efs-get-file-part filename)) - (ignore-case (memq (efs-host-type - (car (efs-ftp-path filename))) - efs-case-insensitive-host-types)) - (ent (efs-get-hash-entry key files ignore-case)) - (mdtm (nth 5 ent)) - type) - (if (= (string-to-char modes) ?l) - (setq type - (cond - ((stringp symlink) - symlink) - ((stringp (car ent)) - (car ent)) - (t ; something weird happened. - ""))) - (if (= (string-to-char modes) ?d) - (setq type t))) - (efs-put-hash-entry - key (list type size owner modes nlinks mdtm) - files ignore-case))))))))) - -(efs-defun efs-update-file-info nil (file buffer &optional symlink) - "For FILE, update cache information from a single file listing in BUFFER." - ;; By default, this does nothing. - nil) - -(efs-defun efs-update-file-info unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info sysV-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info bsd-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info next-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info apollo-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info dumb-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info dumb-apollo-unix - (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info super-dumb-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) - -;;;; ---------------------------------------------------------------- -;;;; The 'unknown listing parser. This does some host-type guessing. -;;;; ---------------------------------------------------------------- - -;;; Regexps for host and listing type guessing from the listing syntax. - -(defconst efs-ka9q-listing-regexp - (concat - "^\\([0-9,.]+\\|No\\) files\\. [0-9,.]+ bytes free\\. " - "Disk size [0-9,]+ bytes\\.$")) -;; This version of the regexp is really for hosts which allow some switches, -;; but not ours. Rather than determine which switches we could be using -;; we just assume that it's dumb. -(defconst efs-dumb-unix-listing-regexp - (concat - "^[Uu]sage: +ls +-[a-zA-Z0-9]+[ \n]\\|" - ;; Unitree server - "^Error getting stats for \"-[a-zA-Z0-9]+\"")) - -(defconst efs-dos-distinct-date-and-time-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " - "[ 12][0-9]:[0-5][0-9] ")) -;; Regexp to match the output from the hellsoft ftp server to an -;; ls -al. Unfortunately, this looks a lot like some unix ls error -;; messages. -(defconst efs-hell-listing-regexp - (concat - "ls: file or directory not found\n\\'\\|" - "[-d]\\[[-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z]\\]")) - -(efs-defun efs-parse-listing unknown - (host user dir path &optional switches) - "Parse the current buffer which is assumed to contain a dir listing. -Return a hashtable as the result. If the listing is not really a -directory listing, then return nil. - -HOST is the remote host's name. -USER is the remote user name. -DIR is the directory as a full remote path. -PATH is the directory in full efs path synatx. -SWITCHES are the switches passed to ls. If SWITCHES is nil, then a -dumb \(with dir\) listing has been done." - (efs-save-match-data - (cond - - ;; look for total line - ((looking-at "^total [0-9]+$") - (efs-add-host 'unix host) - (forward-line 1) - ;; Beware of machines that put a blank line after the totals line. - (skip-chars-forward " \t\n") - (efs-ls-parser 'unix host user dir path switches)) - - ;; Look for hellsoft. Need to do this before looking - ;; for ls errors, since the hellsoft output looks a lot like an ls error. - ((looking-at efs-hell-listing-regexp) - (if (null (car (efs-send-cmd host user '(quote site dos)))) - (let* ((key (concat host "/" user "/~")) - (tilde (efs-get-hash-entry - key efs-expand-dir-hashtable))) - (efs-add-host 'hell host) - ;; downcase the expansion of ~ - (if (and tilde (string-match "^[^a-z]+$" tilde)) - (efs-put-hash-entry key (downcase tilde) - efs-expand-dir-hashtable)) - ;; Downcase dir, in case its got some upper case stuff in it. - (setq dir (downcase dir) - path (efs-replace-path-component path dir)) - (let ((efs-ls-uncache t)) - ;; This will force the data buffer to be re-filled - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'hell host user dir path)) - ;; Don't know, give unix a try. - (efs-add-host 'unix host) - nil)) - - ;; look for ls errors - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - (efs-add-host 'unix host) - nil) - - ((eobp) ; i.e. (zerop (buffer-size)) - ;; This could be one of: - ;; (1) An Ultrix ls error message - ;; (2) A listing with the A switch of an empty directory - ;; on a machine which doesn't give a total line. - ;; (3) The result of an attempt at an nlist. (This would mean a - ;; dumb host.) - ;; (4) The twilight zone. - (cond - ((save-excursion - (set-buffer (process-buffer - (efs-get-process host user))) - (save-excursion - (goto-char (point-max)) - (and - ;; The dir ftp output starts with a 200 cmd. - (re-search-backward "^150 " nil t) - ;; We never do an nlist (it's a short listing). - ;; If the machine thinks that we did, it's dumb. - (looking-at "[^\n]+ NLST ")))) - ;; It's dumb-unix or ka9q. Anything else? - ;; This will re-fill the data buffer with a dumb listing. - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (cond - ;; check for dumb-unix - ((re-search-forward efs-month-and-time-regexp nil t) - (efs-add-host 'dumb-unix host) - (beginning-of-line) - (efs-parse-listing 'dumb-unix host user dir path)) - ;; check for ka9q - ((save-excursion - (goto-char (point-max)) - (forward-line -1) - (looking-at efs-ka9q-listing-regexp)) - (efs-add-host 'ka9q host) - (efs-parse-listing 'ka9q host user dir path)) - (t ; Don't know, try unix. - (efs-add-host 'unix host) - nil))) - ;; check for Novell Netware - ((null (car (efs-send-cmd host user '(quote site nfs)))) - (efs-add-host 'netware host) - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'netware host user dir path)) - (t - ;; Assume (1), an Ultrix error message. - (efs-add-host 'unix host) - nil))) - - ;; unix without a total line - ((re-search-forward efs-month-and-time-regexp nil t) - (efs-add-host 'unix host) - (beginning-of-line) - (efs-ls-parser 'unix host user dir path switches)) - - ;; Now we look for host-types, or listing-types which are auto-rec - ;; by the listing parser, because it's not possible to pick them out - ;; from a pwd. - - ;; check for dumb-unix - ;; (Guessing of dumb-unix hosts which return an ftp error message is - ;; done in efs-ls.) - ((re-search-forward efs-dumb-unix-listing-regexp nil t) - (efs-add-host 'dumb-unix host) - ;; This will force the data buffer to be re-filled - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'dumb-unix host user dir path)) - - ;; check for Distinct's DOS ftp server - ((re-search-forward efs-dos-distinct-date-and-time-regexp nil t) - (efs-add-host 'dos-distinct host) - (efs-parse-listing 'dos-distinct host user dir path)) - - ;; check for KA9Q pseudo-unix (LINUX?) - ((save-excursion - (goto-char (point-max)) - (forward-line -1) - (looking-at efs-ka9q-listing-regexp)) - (efs-add-host 'ka9q host) - ;; This will re-fill the data buffer. - ;; Need to do this because ka9q is a dumb host. - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'ka9q host user dir path)) - - ;; Check for a unix descriptive (dl) listing - ;; Do this last, because it's hard to guess. - ((re-search-forward efs-unix:dl-listing-regexp nil t) - (efs-add-host 'unix host) - (efs-add-listing-type 'unix:dl host user) - (efs-parse-listing 'unix:dl host user dir path switches)) - - ;; Don't know what's going on. Return nil, and assume unix. - (t - (efs-add-host 'unix host) - nil)))) - -;;;; ------------------------------------------------------------ -;;;; Directory information hashtable. -;;;; ------------------------------------------------------------ - -(efs-defun efs-really-file-p nil (file ent) - ;; efs-files-hashtable sometimes contains fictitious entries, when - ;; some OS's allow a file to be accessed by another name. For example, - ;; in VMS the highest version of a file may be accessed by omitting the - ;; the file version number. This function should return t if the - ;; filename FILE is really a file. ENT is the hash entry of the file. - t) - -(efs-defun efs-add-file-entry nil (path type size owner - &optional modes nlinks mdtm) - ;; Add a new file entry for PATH - ;; TYPE is nil for a plain file, t for a directory, and a string - ;; (the target of the link) for a symlink. - ;; SIZE is the size of the file in bytes. - ;; OWNER is the owner of the file, as a string. - ;; MODES is the file modes, as a string. In Unix, this will be 10 cars. - ;; NLINKS is the number of links for the file. - ;; MDTM is the last modtime obtained for the file. This is for - ;; short-term cache only, as emacs often has sequences of functions - ;; doing modtime lookup. If you really want to be sure of the modtime, - ;; use efs-get-file-mdtm, which asks the remote server. - - (and (eq type t) - (setq path (directory-file-name path))) - (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) - (if files - (efs-put-hash-entry - (efs-get-file-part path) - (cond (mdtm - (list type size owner modes nlinks - mdtm)) - (nlinks - (list type size owner modes nlinks)) - (modes (list type size owner modes)) - (t (list type size owner))) - files - (memq efs-key efs-case-insensitive-host-types))) - (efs-del-from-ls-cache path t nil))) - -(efs-defun efs-delete-file-entry nil (path &optional dir-p) - "Delete the file entry for PATH, if its directory info exists." - (if dir-p - (progn - (setq path (file-name-as-directory path)) - (efs-del-hash-entry (efs-canonize-file-name path) - efs-files-hashtable) - ;; Note that file-name-as-directory followed by - ;; (substring path 0 -1) - ;; serves to canonicalize directory file names to their unix form. - ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO - ;; PATH is supposed to be s fully expanded efs-style path. - (setq path (substring path 0 -1)))) - (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) - (if files - (efs-del-hash-entry - (efs-get-file-part path) - files - (memq (efs-host-type (car (efs-ftp-path path))) - efs-case-insensitive-host-types)))) - (efs-del-from-ls-cache path t nil) - (if dir-p (efs-del-from-ls-cache path nil t))) - -(defun efs-set-files (directory files) - "For DIRECTORY, set or change the associated FILES hashtable." - (if files - (efs-put-hash-entry - (efs-canonize-file-name (file-name-as-directory directory)) - files efs-files-hashtable))) - -(defun efs-parsable-switches-p (switches &optional full-dir) - ;; Returns non-nil if SWITCHES would give an ls listing suitable for parsing - ;; If FULL-DIR is non-nil, the switches must be suitable for parsing a full - ;; ditectory. - (or (null switches) - (efs-save-match-data - (and (string-match "[aA]" switches) - ;; g is not good enough, need l or o for owner. - (string-match "[lo]" switches) - ;; L shows link target, rather than link. We need both. - (not (string-match "[RfL]" switches)) - (not (and full-dir (string-match "d" switches))))))) - -(defun efs-get-files (directory &optional no-error) - "For DIRECTORY, return a hashtable of file entries. -This will give an error or return nil, depending on the value of -NO-ERROR, if a listing for DIRECTORY cannot be obtained." - (let ((directory (file-name-as-directory directory))) - (or (efs-get-files-hashtable-entry directory) - (and (efs-ls directory (efs-ls-guess-switches) t 'parse no-error) - (efs-get-files-hashtable-entry directory))))) - -(efs-defun efs-allow-child-lookup nil (host user dir file) - ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. Note that DIR is in directory syntax. - ;; i.e. /foo/bar/, not /foo/bar. - ;; Deal with dired. Anything else? - (not (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file file)))) - -(defmacro efs-ancestral-check (host-type path ignore-case) - ;; Checks to see if something in a path's ancient parentage - ;; would make it impossible for the path to exist in the directory - ;; tree. In this case it returns nil. Otherwise returns t (there - ;; is essentially no information returned in this case, the file - ;; may exist or not). - ;; This macro should make working with RCS more efficient. - ;; It also helps with FTP servers that go into fits if we ask to - ;; list a non-existent dir. - ;; Yes, I know that the function mapped over the hashtable can - ;; be written more cleanly with a concat, but this is faster. - ;; concat's cause a lot of consing. So do regexp-quote's, but we can't - ;; avoid it. - ;; Probably doesn't make much sense for this to be an efs-defun, since - ;; the host-type dependence is very mild. - (` - (let ((path (, path)) ; expand once - (ignore-case (, ignore-case)) - str) - ;; eliminate flat file systems -- should have a constant for this - (or (memq (, host-type) '(mts cms mvs cms-knet)) - (efs-save-match-data - (catch 'foo - (efs-map-hashtable - (function - (lambda (key val) - (and (eq (string-match (regexp-quote key) path) 0) - (setq str (substring path (match-end 0))) - (string-match "^[^/]+" str) - (not (efs-hash-entry-exists-p - (substring str 0 (match-end 0)) - val ignore-case)) - (throw 'foo nil)))) - efs-files-hashtable) - t)))))) - -(defun efs-file-entry-p (path) - ;; Return whether there is a file entry for PATH. - ;; Under no circumstances does this cause FTP activity. - (let* ((path (directory-file-name (efs-canonize-file-name path))) - (dir (file-name-directory path)) - (file (efs-get-file-part path)) - (tbl (efs-get-files-hashtable-entry dir))) - (and tbl (efs-hash-entry-exists-p - file tbl - (memq (efs-host-type (car (efs-ftp-path dir))) - efs-case-insensitive-host-types)) t))) - -(defun efs-get-file-entry (path) - "Return the given file entry for PATH. -This is a list of the form \(type size owner modes nlinks modtm\), -where type is nil for a normal file, t for a directory, and a string for a -symlink, size is the size of the file in bytes, if known, and modes are -the permission modes of the file as a string. modtm is short-term the -cache of the file modtime. It is not used by `verify-visited-file-modtime'. -If the file isn't in the hashtable, this returns nil." - (let* ((path (directory-file-name (efs-canonize-file-name path))) - (dir (file-name-directory path)) - (file (efs-get-file-part path)) - (parsed (efs-ftp-path dir)) - (host (car parsed)) - (host-type (efs-host-type host)) - (ent (efs-get-files-hashtable-entry dir)) - (ignore-case (memq host-type efs-case-insensitive-host-types))) - (if ent - (efs-get-hash-entry file ent ignore-case) - (let ((user (nth 1 parsed)) - (r-dir (nth 2 parsed))) - (and (efs-ancestral-check host-type path ignore-case) - (or (and efs-allow-child-lookup - (efs-allow-child-lookup host-type - host user r-dir file) - (setq ent (efs-get-files path t)) - (efs-get-hash-entry "." ent)) - ;; i.e. it's a directory by child lookup - (efs-get-hash-entry - file (efs-get-files dir) ignore-case))))))) - -(defun efs-wipe-file-entries (host user) - "Remove cache data for all files on HOST and USER. -This replaces the file entry information hashtable with one that -doesn't have any entries for the given HOST, USER pair." - (let ((new-tbl (efs-make-hashtable (length efs-files-hashtable))) - (host (downcase host)) - (case-fold (memq (efs-host-type host) - efs-case-insensitive-host-types))) - (if case-fold (setq user (downcase user))) - (efs-map-hashtable - (function - (lambda (key val) - (let ((parsed (efs-ftp-path key))) - (if parsed - (let ((h (nth 0 parsed)) - (u (nth 1 parsed))) - (or (and (string-equal host (downcase h)) - (string-equal user (if case-fold (downcase u) u))) - (efs-put-hash-entry key val new-tbl))))))) - efs-files-hashtable) - (setq efs-files-hashtable new-tbl))) - - -;;;; ============================================================ -;;;; >8 -;;;; Redefinitions of standard GNU Emacs functions. -;;;; ============================================================ - -;;;; ------------------------------------------------------------ -;;;; expand-file-name and friends... -;;;; ------------------------------------------------------------ - -;; New filename expansion code for efs. -;; The overall structure is based around the following internal -;; functions and macros. Since these are internal, they do NOT -;; call efs-save-match-data. This is done by their calling -;; function. -;; -;; efs-expand-tilde -;; - expands all ~ constructs, both local and remote. -;; efs-short-circuit-file-name -;; - short-circuits //'s and /~'s, for both local and remote paths. -;; efs-de-dot-file-name -;; - canonizes /../ and /./'s in both local and remote paths. -;; -;; The following two functions overload existing emacs functions. -;; They are the entry points to this filename expansion code, and as such -;; call efs-save-match-data. -;; -;; efs-expand-file-name -;; efs-substitute-in-file-name - -;;; utility macros - -(defmacro efs-short-circuit-file-name (filename) - ;; Short-circuits //'s and /~'s in filenames. - ;; Returns a list consisting of the local path, - ;; host-type, host, user. For local hosts, - ;; host-type, host, and user are all nil. - (` - (let ((start 0) - (string (, filename)) - backskip regexp lbackskip - lregexp parsed host-type host user) - - (if efs-local-apollo-unix - (setq lregexp ".//+" - lbackskip 2) - (setq lregexp "//+" - lbackskip 1)) - - ;; Short circuit /user@mach: roots. It is important to do this - ;; now to avoid unnecessary ftp connections. - - (while (string-match efs-path-root-short-circuit-regexp string start) - (setq start (1+ (match-beginning 0)))) - (or (zerop start) (setq string (substring string start) - start 0)) - - ;; identify remote root - - (if (setq parsed (efs-ftp-path-macro string)) - (if (memq (setq string (nth 2 parsed) - host-type - (efs-host-type (setq host (car parsed)) - (setq user (nth 1 parsed)))) - '(apollo-unix dumb-apollo-unix)) - (setq regexp ".//+" - backskip 2) - (setq regexp "//+" - backskip 1)) - (setq regexp lregexp - backskip lbackskip)) - - ;; Now short-circuit in an apollo and efs sensitive way. - - (while (cond ((string-match regexp string start) - (setq start (- (match-end 0) backskip))) - ((string-match "/~" string start) - (setq start (1- (match-end 0))))) - - (and host-type - (null efs-short-circuit-to-remote-root) - (setq host-type nil - regexp lregexp - backskip lbackskip))) - (or (zerop start) (setq string (substring string start))) - (list string host-type (and host-type host) (and host-type user))))) - -(defmacro efs-expand-tilde (tilde host-type host user) - ;; Expands a TILDE (~ or ~sandy type construction) - ;; Takes as an arg a filename (not directory name!) - ;; and returns a filename. HOST-TYPE is the type of remote host. - ;; nil is the type of the local host. - (` - (if (, host-type) ; nil host-type is the local machine - (let* ((host (downcase (, host))) - (host-type (, host-type)) - (ignore-case (memq host-type - efs-case-insensitive-host-types)) - (tilde (, tilde)) - (user (, user)) - (key (concat host "/" user "/" tilde)) - (res (efs-get-hash-entry - key efs-expand-dir-hashtable ignore-case))) - (or res - ;; for real accounts on unix systems, use the get trick - (and (not (efs-anonymous-p user)) - (memq host-type efs-unix-host-types) - (let ((line (nth 1 (efs-send-cmd - host user - (list 'get tilde "/dev/null") - (format "expanding %s" tilde))))) - (setq res - (and (string-match efs-expand-dir-msgs line) - (substring line - (match-beginning 1) - (match-end 1)))) - (if res - (progn - (setq res (efs-internal-directory-file-name res)) - (efs-put-hash-entry - key res efs-expand-dir-hashtable ignore-case) - res)))) - (progn - (setq res - (if (string-equal tilde "~") - (car (efs-send-pwd - host-type host user)) - (let* ((home-key (concat host "/" user "/~")) - (home (efs-get-hash-entry - home-key efs-expand-dir-hashtable - ignore-case)) - pwd-result) - (if home - (setq home - (efs-fix-path - host-type - (efs-internal-file-name-as-directory - host-type home))) - (if (setq home - (car - (setq pwd-result - (efs-send-pwd - host-type - host user)))) - (efs-put-hash-entry - home-key - (efs-internal-directory-file-name - (efs-fix-path host-type home 'reverse)) - efs-expand-dir-hashtable ignore-case) - (efs-error host user - (concat "PWD failed: " - (cdr pwd-result))))) - (unwind-protect - (and (efs-raw-send-cd host user - (efs-fix-path - host-type tilde) t) - (car - (efs-send-pwd - host-type host user))) - (efs-raw-send-cd host user home))))) - (if res - (progn - (setq res (efs-internal-directory-file-name - (efs-fix-path host-type res 'reverse))) - (efs-put-hash-entry - key res efs-expand-dir-hashtable ignore-case) - res))) - (if (string-equal tilde "~") - (error "Cannot get home directory on %s" host) - (error "User %s is not known on %s" (substring tilde 1) host)))) - ;; local machine - (efs-real-expand-file-name (, tilde))))) - -(defmacro efs-de-dot-file-name (string) - ;; Takes a string as arguments, and removes /../'s and /./'s. - (` - (let ((string (, string)) - (start 0) - new make-dir) - ;; to make the regexp's simpler, canonicalize to directory name. - (if (setq make-dir (string-match "/\\.\\.?$" string)) - (setq string (concat string "/"))) - (while (string-match "/\\./" string start) - (setq new (concat new - (substring string - start (match-beginning 0))) - start (1- (match-end 0)))) - - (if new (setq string (concat new (substring string start)))) - - (while (string-match "/[^/]+/\\.\\./" string) - ;; Is there a way to avoid all this concating and copying? - (setq string (concat (substring string 0 (1+ (match-beginning 0))) - (substring string (match-end 0))))) - - ;; Do /../ and //../ special cases. They should expand to - ;; / and //, respectively. - (if (string-match "^\\(/+\\)\\.\\./" string) - (setq string (concat (substring string 0 (match-end 1)) - (substring string (match-end 0))))) - - (if (and make-dir - (not (string-match "^/+$" string))) - (substring string 0 -1) - string)))) - -(defun efs-substitute-in-file-name (string) - "Documented as original." - ;; Because of the complicated interaction between short-circuiting - ;; and environment variable substitution, this can't call the macro - ;; efs-short-circuit-file-name. - (efs-save-match-data - (let ((start 0) - var new root backskip regexp lbackskip - lregexp parsed fudge-host-type rstart error) - - (if efs-local-apollo-unix - (setq lregexp ".//+" - lbackskip 2) - (setq lregexp "//+" - lbackskip 1)) - - ;; Subst. existing env variables - (while (string-match "\\$" string start) - (setq new (concat new (substring string start (match-beginning 0))) - start (match-end 0)) - (cond ((eq (string-match "\\$" string start) start) - (setq start (1+ start) - new (concat new "$$"))) - ((eq (string-match "{" string start) start) - (if (and (string-match "}" string start) - (setq var (getenv - (substring string (1+ start) - (1- (match-end 0)))))) - (setq start (match-end 0) - new (concat new var)) - (setq new (concat new "$")))) - ((eq (string-match "[a-zA-Z0-9]+" string start) start) - (if (setq var (getenv - (substring string start (match-end 0)))) - (setq start (match-end 0) - new (concat new var)) - (setq new (concat new "$")))) - ((setq new (concat new "$"))))) - (if new (setq string (concat new (substring string start)) - start 0)) - - ;; Short circuit /user@mach: roots. It is important to do this - ;; now to avoid unnecessary ftp connections. - - (while (string-match efs-path-root-short-circuit-regexp - string start) - (setq start (1+ (match-beginning 0)))) - (or (zerop start) (setq string (substring string start) - start 0)) - - ;; Look for invalid environment variables in the root. If one is found, - ;; we set the host-type to 'unix. Since we can't login in to determine - ;; it. There is a good chance that we will bomb later with an error, - ;; but the day may yet be saved if the root is short-circuited off. - - (if (string-match efs-path-root-regexp string) - (progn - (setq root (substring string 0 (match-end 0)) - start (match-end 0)) - (if (string-match "[^$]\\(\\$\\$\\)*\\$[^$]" root) - (progn - (setq rstart (1- (match-end 0)) - fudge-host-type t) - (cond - ((eq (elt root rstart) ?{) - (setq - error - (if (string-match "}" root rstart) - (concat - "Subsituting non-existent environment variable " - (substring root (1+ rstart) (match-beginning 0))) - "Missing \"}\" in environment-variable substitution"))) - ((eq (string-match "[A-Za-z0-9]+" root rstart) rstart) - (setq - error - (concat - "Subsituting non-existent environment variable " - (substring root rstart (match-beginning 0))))) - (t - (setq - error - "Bad format environment-variable substitution"))))) - (setq root (efs-unquote-dollars root) - parsed (efs-ftp-path root)) - - (if (and (not fudge-host-type) - ;; This may trigger an FTP connection - (memq (efs-host-type (car parsed) (nth 1 parsed)) - '(apollo-unix dumb-apollo-unix))) - (setq regexp ".//+" - backskip 2) - (setq regexp "//+" - backskip 1))) - ;; no root, we're local - (setq regexp lregexp - backskip lbackskip)) - - ;; Now short-circuit in an apollo and efs sensitive way. - - (while (cond ((string-match regexp string start) - (setq start (- (match-end 0) backskip))) - ((string-match "/~" string start) - (setq start (1- (match-end 0))))) - - (and root - (null efs-short-circuit-to-remote-root) - (setq root nil - regexp lregexp - backskip lbackskip))) - - ;; If we still have a bad root, barf. - (if (and root error) (error error)) - - ;; look for non-existent evironment variables in the path - - (if (string-match - "\\([^$]\\|^\\)\\(\\$\\$\\)*\\$\\([^$]\\|$\\)" string start) - (progn - (setq start (match-beginning 3)) - (cond - ((eq (length string) start) - (error "Empty string is an invalid environment variable")) - ((eq (elt string start) ?{) - (if (string-match "}" string start) - (error - "Subsituting non-existent environment variable %s" - (substring string (1+ start) (match-end 0))) - (error - "Missing \"}\" in environment-variable substitution"))) - ((eq (string-match "[A-Za-z0-9]+" string start) start) - (error - "Subsituting non-existent environment variable %s" - (substring string start (match-end 0)))) - (t - (error - "Bad format environment-variable substitution"))))) - - (if root - (concat root - (efs-unquote-dollars - (if (zerop start) - string - (substring string start)))) - (efs-unquote-dollars - (if (zerop start) - string - (substring string start))))))) - -(defun efs-expand-file-name (name &optional default) - "Documented as original." - (let (s-c-res path host user host-type) - (efs-save-match-data - (or (file-name-absolute-p name) - (setq name (concat - (file-name-as-directory - (or default default-directory)) - name))) - (setq s-c-res (efs-short-circuit-file-name name) - path (car s-c-res) - host-type (nth 1 s-c-res) - host (nth 2 s-c-res) - user (nth 3 s-c-res)) - (cond ((string-match "^~[^/]*" path) - (let ((start (match-end 0))) - (setq path (concat - (efs-expand-tilde - (substring path 0 start) - host-type host user) - (substring path start))))) - ((and host-type (not (file-name-absolute-p path))) - ;; We expand the empty string to a directory. - ;; This can be more efficient for filename - ;; completion. It's also consistent with non-unix. - (let ((tilde (efs-expand-tilde - "~" host-type host user))) - (if (string-equal tilde "/") - (setq path (concat "/" path)) - (setq path (concat tilde "/" path)))))) - - (setq path (efs-de-dot-file-name path)) - (if host-type - (format efs-path-format-string user host path) - path)))) - -;;;; ------------------------------------------------------------ -;;;; Other functions for manipulating file names. -;;;; ------------------------------------------------------------ - -(defun efs-internal-file-name-extension (filename) - ;; Returns the extension for file name FN. - (save-match-data - (let ((file (file-name-sans-versions (file-name-nondirectory filename)))) - (if (string-match "\\.[^.]*\\'" file) - (substring file (match-beginning 0)) - "")))) - -(defun efs-file-name-as-directory (name) - ;; version of file-name-as-directory for remote files. - ;; Usually just appends a / if there isn't one already. - ;; For some systems, it may also remove .DIR like extensions. - (let* ((parsed (efs-ftp-path name)) - (file (nth 2 parsed))) - (if (string-equal file "") - name - (efs-internal-file-name-as-directory - (efs-host-type (car parsed) (nth 1 parsed)) name)))) - -(efs-defun efs-internal-file-name-as-directory nil (name) - ;; By default, simply adds a trailing /, if there isn't one. - ;; Note that for expanded filenames, it pays to call this rather - ;; than efs-file-name-as-directory. - (let (file-name-handler-alist) - (file-name-as-directory name))) - -(defun efs-file-name-directory (name) - ;; file-name-directory for remote files. Takes care not to - ;; turn /user@host: into /. - (let ((path (nth 2 (efs-ftp-path name))) - file-name-handler-alist) - (if (or (string-equal path "") - (and (= (string-to-char path) ?~) - (not - (efs-save-match-data - (string-match "/" path 1))))) - name - (if (efs-save-match-data - (not (string-match "/" path))) - (efs-replace-path-component name "") - (file-name-directory name))))) - -(defun efs-file-name-nondirectory (name) - ;; Computes file-name-nondirectory for remote files. - ;; For expanded filenames, can just call efs-internal-file-name-nondirectory. - (let ((file (nth 2 (efs-ftp-path name)))) - (if (or (string-equal file "") - (and (= (string-to-char file) ?~) - (not - (efs-save-match-data - (string-match "/" file 1))))) - "" - (if (efs-save-match-data - (not (string-match "/" file))) - file - (efs-internal-file-name-nondirectory name))))) - -(defun efs-internal-file-name-nondirectory (name) - ;; Version of file-name-nondirectory, without the efs-file-handler-function. - ;; Useful to call this, if we have already decomposed the filename. - (let (file-name-handler-alist) - (file-name-nondirectory name))) - -(defun efs-directory-file-name (dir) - ;; Computes directory-file-name for remote files. - ;; Needs to be careful not to turn /foo@bar:/ into /foo@bar: - (let ((parsed (efs-ftp-path dir))) - (if (string-equal "/" (nth 2 parsed)) - dir - (efs-internal-directory-file-name dir)))) - -(defun efs-internal-directory-file-name (dir) - ;; Call this if you want to apply directory-file-name to the remote - ;; part of a efs-style path. Don't call for non-efs-style paths, - ;; as this short-circuits the file-name-handler-alist completely. - (let (file-name-handler-alist) - (directory-file-name dir))) - -(efs-defun efs-remote-directory-file-name nil (dir) - "Returns the file name on the remote system of directory DIR. -If the remote system is not unix, this may not be the same as the file name -of the directory in efs's internal cache." - (directory-file-name dir)) - -(defun efs-file-name-sans-versions (filename &optional keep-backup-versions) - ;; Version of file-name-sans-versions for remote files. - (or (file-name-absolute-p filename) - (setq filename (expand-file-name filename))) - (let ((parsed (efs-ftp-path filename))) - (efs-internal-file-name-sans-versions - (efs-host-type (car parsed) (nth 1 parsed)) - filename keep-backup-versions))) - -(efs-defun efs-internal-file-name-sans-versions nil - (filename &optional keep-backup-versions) - (let (file-name-handler-alist) - (file-name-sans-versions filename keep-backup-versions))) - -(defun efs-diff-latest-backup-file (fn) - ;; Version of diff latest backup file for remote files. - ;; Accomodates non-unix. - ;; Returns the latest backup for fn, according to the numbering - ;; of the backups. Does not check file-newer-than-file-p. - (let ((parsed (efs-ftp-path fn))) - (efs-internal-diff-latest-backup-file - (efs-host-type (car parsed) (nth 1 parsed)) fn))) - -(efs-defun efs-internal-diff-latest-backup-file nil (fn) - ;; Default behaviour is the behaviour in diff.el - (let (file-name-handler-alist) - (diff-latest-backup-file fn))) - -(defun efs-unhandled-file-name-directory (filename) - ;; Calculate a default unhandled directory for an efs buffer. - ;; This is used to compute directories in which to execute - ;; processes. This is relevant to V19 only. Doesn't do any harm for - ;; older versions though. It would be nice if this wasn't such a - ;; kludge. - (file-name-directory efs-tmp-name-template)) - -(defun efs-file-truename (filename) - ;; Calculates a remote file's truename, if this isn't inhibited. - (let ((filename (expand-file-name filename))) - (if (and efs-compute-remote-buffer-file-truename - (memq (efs-host-type (car (efs-ftp-path filename))) - efs-unix-host-types)) - (efs-internal-file-truename filename) - filename))) - -(defun efs-internal-file-truename (filename) - ;; Internal function so that we don't keep checking - ;; efs-compute-remote-buffer-file-truename, etc, as we recurse. - (let ((dir (efs-file-name-directory filename)) - target dirfile) - ;; Get the truename of the directory. - (setq dirfile (efs-directory-file-name dir)) - ;; If these are equal, we have the (or a) root directory. - (or (string= dir dirfile) - (setq dir (efs-file-name-as-directory - (efs-internal-file-truename dirfile)))) - (if (equal ".." (efs-file-name-nondirectory filename)) - (efs-directory-file-name (efs-file-name-directory - (efs-directory-file-name dir))) - (if (equal "." (efs-file-name-nondirectory filename)) - (efs-directory-file-name dir) - ;; Put it back on the file name. - (setq filename (concat dir (efs-file-name-nondirectory filename))) - ;; Is the file name the name of a link? - (setq target (efs-file-symlink-p filename)) - (if target - ;; Yes => chase that link, then start all over - ;; since the link may point to a directory name that uses links. - ;; We can't safely use expand-file-name here - ;; since target might look like foo/../bar where foo - ;; is itself a link. Instead, we handle . and .. above. - (if (file-name-absolute-p target) - (efs-internal-file-truename target) - (efs-internal-file-truename (concat dir target))) - ;; No, we are done! - filename))))) - - -;;;; ---------------------------------------------------------------- -;;;; I/O functions -;;;; ---------------------------------------------------------------- - -(efs-define-fun efs-set-buffer-file-name (filename) - ;; Sets the buffer local variables for filename appropriately. - ;; A special function because Lucid and FSF do this differently. - ;; This default behaviour is the lowest common denominator. - (setq buffer-file-name filename)) - -(defun efs-write-region (start end filename &optional append visit &rest args) - ;; write-region for remote files. - ;; This version accepts the V19 interpretation for the arg VISIT. - ;; However, making use of this within V18 may cause errors to crop up. - ;; ARGS should catch the MULE coding-system argument. - (if (stringp visit) (setq visit (expand-file-name visit))) - (setq filename (expand-file-name filename)) - (let ((parsed (efs-ftp-path filename)) - ;; Make sure that the after-write-region-hook isn't called inside - ;; the file-handler-alist - (after-write-region-hook nil)) - (if parsed - (let* ((host (car parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - (temp (car (efs-make-tmp-name nil host))) - (type (efs-xfer-type nil nil host-type filename)) - (abbr (and (or (stringp visit) (eq t visit) (null visit)) - (efs-relativize-filename - (if (stringp visit) visit filename)))) - (buffer (current-buffer)) - (b-file-name buffer-file-name) - (mod-p (buffer-modified-p))) - (unwind-protect - (progn - (condition-case err - (progn - (unwind-protect - (let ((executing-macro t)) - ;; let-bind executing-macro to inhibit messaging. - ;; Setting VISIT to 'quiet is more elegant. - ;; But in Emacs 18, doing it this way allows - ;; us to modify the visited file modtime, so - ;; that undo's show the buffer modified. - (apply 'write-region start end - temp nil visit args)) - ;; buffer-modified-p is now correctly set - (setq buffer-file-name b-file-name) - ;; File modtime is bogus, so clear. - (clear-visited-file-modtime)) - (efs-copy-file-internal - temp nil filename parsed (if append 'append t) - nil (and abbr (format "Writing %s" abbr)) - ;; cont - (efs-cont (result line cont-lines) (filename buffer - visit) - (if result - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\"" line) - filename))) - ;; The new file entry will be added by - ;; efs-copy-file-internal. - (cond - ((eq visit t) - ;; This will run asynch. - (efs-save-buffer-excursion - (set-buffer buffer) - (efs-set-buffer-file-name filename) - (efs-set-visited-file-modtime))) - ((stringp visit) - (efs-save-buffer-excursion - (set-buffer buffer) - (efs-set-buffer-file-name visit) - (set-visited-file-modtime))))) - nil type)) - (error - ;; restore buffer-modified-p - (let (file-name-handler-alist) - (set-buffer-modified-p mod-p)) - (signal (car err) (cdr err)))) - (if (or (eq visit t) - (and (stringp visit) - (efs-ftp-path visit))) - (efs-set-buffer-mode))) - (efs-del-tmp-name temp)) - (and abbr (efs-message "Wrote %s" abbr))) - (if (and (stringp visit) (efs-ftp-path visit)) - (progn - (apply 'write-region start end filename append visit args) - (efs-set-buffer-file-name visit) - (efs-set-visited-file-modtime) - (efs-set-buffer-mode)) - (error "efs-write-region called for a local file"))))) - -(defun efs-insert-file-contents (filename &optional visit &rest args) - ;; Inserts file contents for remote files. - ;; The additional ARGS covers V19 BEG and END. Should also handle the - ;; CODING-SYSTEM arg for mule. Hope the two don't trip over each other. - (barf-if-buffer-read-only) - (unwind-protect - (let* ((filename (expand-file-name filename)) - (parsed (efs-ftp-path filename)) - (host (car parsed)) - (host-type (efs-host-type host)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (buffer (current-buffer))) - - (if (or (file-exists-p filename) - (let* ((res (and - (not (efs-get-host-property host 'rnfr-failed)) - (efs-send-cmd - host user (list 'quote 'rnfr path)))) - (line (nth 1 res))) - ;; RNFR returns a 550 if the file doesn't exist. - (if (and line (>= (length line) 4) - (string-equal "550 " (substring line 0 4))) - nil - (if (car res) (efs-set-host-property host 'rnfr-failed t)) - (efs-del-from-ls-cache filename t nil) - (efs-del-hash-entry - (efs-canonize-file-name (file-name-directory filename)) - efs-files-hashtable) - (file-exists-p filename)))) - - (let ((temp (concat - (car (efs-make-tmp-name nil host)) - (efs-internal-file-name-extension filename))) - (type (efs-xfer-type host-type filename nil nil)) - (abbr (efs-relativize-filename filename)) - (i-f-c-size 0)) - - (unwind-protect - (efs-copy-file-internal - filename parsed temp nil t nil - (format "Retrieving %s" abbr) - (efs-cont (result line cont-lines) (filename visit buffer - host-type - temp args) - (if result - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\"" - line) - filename)) - (if (eq host-type 'coke) - (efs-coke-insert-beverage-contents buffer filename - line) - (efs-save-buffer-excursion - (set-buffer buffer) - (if (or (file-readable-p temp) - (sleep-for efs-retry-time) - ;; Wait for file to hopefully appear. - (file-readable-p temp)) - - (setq i-f-c-size - (nth 1 (apply 'insert-file-contents - temp visit args))) - (signal 'ftp-error - (list - "Opening input file:" - (format - "FTP Error: %s not arrived or readable" - filename)))) - ;; This is done asynch - (if visit - (let ((buffer-file-name filename)) - (efs-set-visited-file-modtime))))))) - nil type) - (efs-del-tmp-name temp)) - ;; Return (FILENAME SIZE) - (list filename i-f-c-size)) - (signal 'file-error (list "Opening input file" filename)))) - ;; Set buffer-file-name at the very last, so if anything bombs, we're - ;; not visiting. - (if visit - (efs-set-buffer-file-name filename)))) - -(defun efs-revert-buffer (arg noconfirm) - "Revert this buffer from a remote file using ftp." - (let ((opoint (point))) - (cond ((null buffer-file-name) - (error "Buffer does not seem to be associated with any file")) - ((or noconfirm - (yes-or-no-p (format "Revert buffer from file %s? " - buffer-file-name))) - (let ((buffer-read-only nil)) - ;; Set buffer-file-name to nil - ;; so that we don't try to lock the file. - (let ((buffer-file-name nil)) - (unlock-buffer) - (erase-buffer)) - (insert-file-contents buffer-file-name t)) - (goto-char (min opoint (point-max))) - (after-find-file nil) - t)))) - -(defun efs-recover-file (file) - ;; Version of recover file for remote files, and remote autosave files too. - (if (auto-save-file-name-p file) (error "%s is an auto-save file" file)) - (let* ((file-name (let ((buffer-file-name file)) (make-auto-save-file-name))) - (file-name-parsed (efs-ftp-path file-name)) - (file-parsed (efs-ftp-path file)) - (efs-ls-uncache t)) - (cond ((not (file-newer-than-file-p file-name file)) - (error "Auto-save file %s not current" file-name)) - ((save-window-excursion - (or (eq system-type 'vax-vms) - (progn - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (if file-parsed - (progn - (princ (format "On the host %s:\n" - (car file-parsed))) - (princ - (let ((default-directory exec-directory)) - (efs-ls file (if (file-symlink-p file) - "-lL" "-l") - t t)))) - (princ "On the local host:\n") - (let ((default-directory exec-directory)) - (call-process "ls" nil standard-output nil - (if (file-symlink-p file) "-lL" "-l") - file))) - (princ "\nAUTO SAVE FILE on the ") - (if file-name-parsed - (progn - (princ (format "host %s:\n" - (car file-name-parsed))) - (princ - (efs-ls file-name - (if (file-symlink-p file-name) "-lL" "-l") - t t))) - (princ "local host:\n") - (let ((default-directory exec-directory)) - (call-process "ls" nil standard-output nil - "-l" file-name))) - (princ "\nFile modification times are given in ") - (princ "the local time of each host.\n")) - (save-excursion - (set-buffer "*Directory*") - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (if (> (current-column) (window-width)) - (progn - (skip-chars-backward " \t") - (skip-chars-backward "^ \t\n") - (if (> (current-column) 12) - (progn - (delete-horizontal-space) - (insert "\n "))))) - (forward-line 1)) - (set-buffer-modified-p nil) - (goto-char (point-min))))) - (yes-or-no-p (format "Recover using this auto save file? "))) - (switch-to-buffer (find-file-noselect file t)) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-file-contents file-name nil)) - (after-find-file nil)) - (t (error "Recover-file cancelled.")))) - ;; This is no longer done in V19. However, I like the caution for - ;; remote files, where file-newer-than-file-p may lie. - (setq buffer-auto-save-file-name nil) - (message "Auto-save off in this buffer till you do M-x auto-save-mode.")) - -;;;; ------------------------------------------------------------------ -;;;; Attributes of files. -;;;; ------------------------------------------------------------------ - -(defun efs-file-symlink-p (file) - ;; Version of file-symlink-p for remote files. - ;; Call efs-expand-file-name rather than the normal - ;; expand-file-name to stop loops when using a package that - ;; redefines both file-symlink-p and expand-file-name. - ;; Do not use efs-get-file-entry, because a child-lookup won't do. - (let* ((file (efs-expand-file-name file)) - (ignore-case (memq (efs-host-type (car (efs-ftp-path file))) - efs-case-insensitive-host-types)) - (file-type (car (efs-get-hash-entry - (efs-get-file-part file) - (efs-get-files (file-name-directory file)) - ignore-case)))) - (and (stringp file-type) - (if (file-name-absolute-p file-type) - (efs-replace-path-component file file-type) - file-type)))) - -(defun efs-file-exists-p (path) - ;; file-exists-p for remote file. Uses the cache if possible. - (let* ((path (expand-file-name path)) - (parsed (efs-ftp-path path))) - (efs-internal-file-exists-p (efs-host-type (car parsed) (nth 1 parsed)) - path))) - -(efs-defun efs-internal-file-exists-p nil (path) - (and (efs-get-file-entry path) t)) - -(defun efs-file-directory-p (file) - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file))) - (efs-internal-file-directory-p (efs-host-type (car parsed) (nth 1 parsed)) - file))) - -(efs-defun efs-internal-file-directory-p nil (path) - ;; Version of file-directory-p for remote files. - (let ((parsed (efs-ftp-path path))) - (or (string-equal (nth 2 parsed) "/") ; root is always a directory - (let ((file-ent (car (efs-get-file-entry - (efs-internal-file-name-as-directory - (efs-host-type (car parsed) (nth 1 parsed)) - path))))) - ;; We do a file-name-as-directory on path here because some - ;; machines (VMS) use a .DIR to indicate the filename associated - ;; with a directory. This needs to be canonicalized. - (if (stringp file-ent) - (efs-internal-file-directory-p - nil - (efs-chase-symlinks - ;; efs-internal-directory-file-name - ;; only loses for paths where the remote file - ;; is /. This has been eliminated. - (efs-internal-directory-file-name path))) - file-ent))))) - -(defun efs-file-attributes (file) - ;; Returns file-file-attributes for a remote file. - ;; For the file modtime does not return efs's cached value, as that - ;; corresponds to buffer-file-modtime (i.e. the modtime of the file - ;; the last time the buffer was vsisted or saved). Caching modtimes - ;; does not make much sense, as they are usually used to determine - ;; if a cache is stale. The modtime if a remote file can be obtained with - ;; efs-get-file-mdtm. This is _not_ returned for the 5th entry here, - ;; because it requires an FTP transaction, and a priori we don't know - ;; if the caller actually cares about this info. Having file-attributes - ;; return such a long list of info is not well suited to remote files, - ;; as some of this info may be costly to obtain. - (let* ((file (expand-file-name file)) - (ent (efs-get-file-entry file))) - (if ent - (let* ((parsed (efs-ftp-path file)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (type (car ent)) - (size (or (nth 1 ent) -1)) - (owner (nth 2 ent)) - (modes (nth 3 ent)) - ;; Hack to give remote files a "unique" "inode number". - ;; It's actually the sum of the characters in its name. - ;; It's not even really unique. - (inode (apply '+ - (nconc (mapcar 'identity host) - (mapcar 'identity user) - (mapcar 'identity - (efs-internal-directory-file-name - path))))) - (nlinks (or (nth 4 ent) -1))) ; return -1 if we don't know - (list - (if (and (stringp type) (file-name-absolute-p type)) - (efs-replace-path-component file type) - type) ;0 file type - nlinks ;1 link count - (if owner ;2 uid - ;; Not really a unique integer, - ;; just a half-hearted attempt - (apply '+ (mapcar 'identity owner)) - -1) - -1 ;3 gid - '(0 0) ;4 atime - '(0 0) ;5 mtime - '(0 0) ;6 ctime - size ;7 size - (or modes ;8 mode - (concat - (cond ((stringp type) "l") - (type "d") - (t "-")) - "?????????")) - nil ;9 gid weird (Who knows if the gid - ; would be changed?) - inode ;10 inode - -1 ;11 device number [v19 only] - ))))) - -(defun efs-file-writable-p (file) - ;; file-writable-p for remote files. - ;; Does not attempt to open the file, but just looks at the cached file - ;; modes. - (let* ((file (expand-file-name file)) - (ent (efs-get-file-entry file))) - (if (and ent (or (not (stringp (car ent))) - (setq file (efs-chase-symlinks file) - ent (efs-get-file-entry file)))) - (let* ((owner (nth 2 ent)) - (modes (nth 3 ent)) - (parsed (efs-ftp-path file)) - (host-type (efs-host-type (car parsed))) - (user (nth 1 parsed))) - (if (memq host-type efs-unix-host-types) - (setq host-type 'unix)) - (efs-internal-file-writable-p host-type user owner modes)) - (let ((dir (file-name-directory file))) - (and - (not (string-equal dir file)) - (file-directory-p dir) - (file-writable-p dir)))))) - -(efs-defun efs-internal-file-writable-p nil (user owner modes) - ;; By default, we'll just guess yes. - t) - -(efs-defun efs-internal-file-writable-p unix (user owner modes) - (if (and modes - (not (string-equal user "root"))) - (null - (null - (if (string-equal user owner) - (memq ?w (list (aref modes 2) (aref modes 5) - (aref modes 8))) - (memq ?w (list (aref modes 5) (aref modes 8)))))) - t)) ; guess - -(defun efs-file-readable-p (file) - ;; Version of file-readable-p that works for remote files. - ;; Works by checking efs's cache of the file modes. - (let* ((file (expand-file-name file)) - (ent (efs-get-file-entry file))) - (and ent - (or (not (stringp (car ent))) - (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) - ;; file exists - (let* ((parsed (efs-ftp-path file)) - (owner (nth 2 ent)) - (modes (nth 3 ent)) - (host-type (efs-host-type (car parsed))) - (user (nth 1 parsed))) - (if (memq host-type efs-unix-host-types) - (setq host-type 'unix)) - (efs-internal-file-readable-p host-type user owner modes))))) - -(efs-defun efs-internal-file-readable-p nil (user owner modes) - ;; Guess t by default - t) - -(efs-defun efs-internal-file-readable-p unix (user owner modes) - (if (and modes - (not (string-equal user "root"))) - (null - (null - (if (string-equal user owner) - (memq ?r (list (aref modes 1) (aref modes 4) - (aref modes 7))) - (memq ?r (list (aref modes 4) (aref modes 7)))))) - t)) ; guess - -(defun efs-file-executable-p (file) - ;; Version of file-executable-p for remote files. - (let ((ent (efs-get-file-entry file))) - (and ent - (or (not (stringp (car ent))) - (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) - ;; file exists - (let* ((parsed (efs-ftp-path file)) - (owner (nth 2 ent)) - (modes (nth 3 ent)) - (host-type (efs-host-type (car parsed))) - (user (nth 1 parsed))) - (if (memq host-type efs-unix-host-types) - (setq host-type 'unix)) - (efs-internal-file-executable-p host-type user owner modes))))) - -(efs-defun efs-internal-file-executable-p nil (user owner modes) - ;; Guess t by default - t) - -(efs-defun efs-internal-file-executable-p unix (user owner modes) - (if (and modes - (not (string-equal user "root"))) - (null - (null - (if (string-equal user owner) - (memq ?x (list (aref modes 3) (aref modes 6) - (aref modes 9))) - (memq ?x (list (aref modes 6) (aref modes 9)))))) - t)) ; guess - -(defun efs-file-accessible-directory-p (dir) - ;; Version of file-accessible-directory-p for remote directories. - (let ((file (directory-file-name dir))) - (and (efs-file-directory-p file) (efs-file-executable-p file)))) - -;;;; -------------------------------------------------------------- -;;;; Listing directories. -;;;; -------------------------------------------------------------- - -(defun efs-shell-regexp-to-regexp (regexp) - ;; Converts a shell regexp to an emacs regexp. - ;; Probably full of bugs. Tries to follow csh globbing. - (let ((curly 0) - backslash) - (concat "^" - (mapconcat - (function - (lambda (char) - (cond - (backslash - (setq backslash nil) - (regexp-quote (char-to-string char))) - ((and (> curly 0) (eq char ?,)) - "\\|") - ((memq char '(?[ ?])) - (char-to-string char)) - ((eq char ??) - ".") - ((eq char ?\\) - (setq backslash t) - "") - ((eq char ?*) - ".*") - ((eq char ?{) - (setq curly (1+ curly)) - "\\(") - ((and (eq char ?}) (> curly 0)) - (setq curly (1- curly)) - "\\)") - (t (regexp-quote (char-to-string char)))))) - regexp nil) - "$"))) - - -;;; Getting directory listings. - -(defun efs-directory-files (directory &optional full match nosort &rest ignored-for-now) - ;; Returns directory-files for remote directories. - ;; NOSORT is a V19 arg. - (let* ((directory (expand-file-name directory)) - (parsed (efs-ftp-path directory)) - (directory (efs-internal-file-name-as-directory - (efs-host-type (car parsed) (nth 1 parsed)) directory)) - files) - (efs-barf-if-not-directory directory) - (setq files (efs-hash-table-keys (efs-get-files directory) nosort)) - (cond - ((null (or full match)) - files) - (match ; this is slow case - (let (res f) - (efs-save-match-data - (while files - (setq f (if full (concat directory (car files)) (car files)) - files (cdr files)) - (if (string-match match f) - (setq res (nconc res (list f)))))) - res)) - (full - (mapcar (function - (lambda (fn) - (concat directory fn))) - files))))) - -(defun efs-list-directory (dirname &optional verbose) - ;; Version of list-directory for remote directories. - ;; If verbose is nil, it gets its information from efs's - ;; internal cache. - (let* ((dirname (expand-file-name (or dirname default-directory))) - header) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (setq header dirname) - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (princ "Directory ") - (princ header) - (terpri) - (princ - (efs-ls dirname (if verbose - list-directory-verbose-switches - list-directory-brief-switches) - t))))) - -;;;; ------------------------------------------------------------------- -;;;; Manipulating buffers. -;;;; ------------------------------------------------------------------- - -(defun efs-get-file-buffer (file) - ;; Version of get-file-buffer for remote files. Needs to fuss over things - ;; like OS's which are case-insens. for file names. - (let ((file (efs-canonize-file-name (expand-file-name file))) - (buff-list (buffer-list)) - buff-name) - (catch 'match - (while buff-list - (and (setq buff-name (buffer-file-name (car buff-list))) - (= (length buff-name) (length file)) ; efficiency hack - (string-equal (efs-canonize-file-name buff-name) file) - (throw 'match (car buff-list))) - (setq buff-list (cdr buff-list)))))) - -(defun efs-create-file-buffer (filename) - ;; Version of create-file-buffer for remote file names. - (let* ((parsed (efs-ftp-path (expand-file-name filename))) - (file (nth 2 parsed)) - (host (car parsed)) - (host-type (efs-host-type host)) - (buff (cond - ((null efs-fancy-buffer-names) - (if (string-equal file "/") - "/" - (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name file)))) - ((stringp efs-fancy-buffer-names) - (format efs-fancy-buffer-names - (if (string-equal file "/") - "/" - (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name file))) - (substring host 0 (string-match "\\." host 1)))) - (t ; efs-fancy-buffer-names had better be a function - (funcall efs-fancy-buffer-names host - (nth 1 parsed) file))))) - (if (memq host-type efs-case-insensitive-host-types) - (cond ((eq efs-buffer-name-case 'down) - (setq buff (downcase buff))) - ((eq efs-buffer-name-case 'up) - (setq buff (upcase buff))))) - (get-buffer-create (generate-new-buffer-name buff)))) - -(defun efs-set-buffer-mode () - "Set correct modes for the current buffer if it is visiting a remote file." - (if (and (stringp buffer-file-name) - (efs-ftp-path buffer-file-name)) - (progn - (auto-save-mode efs-auto-save) - (set (make-local-variable 'revert-buffer-function) - 'efs-revert-buffer) - (set (make-local-variable 'default-directory-function) - 'efs-default-dir-function)))) - -;;;; --------------------------------------------------------- -;;;; Functions for doing backups. -;;;; --------------------------------------------------------- - -(defun efs-backup-buffer () - ;; Version of backup-buffer for buffers visiting remote files. - (if efs-make-backup-files - (let* ((parsed (efs-ftp-path buffer-file-name)) - (host (car parsed)) - (host-type (efs-host-type (car parsed)))) - (if (or (not (listp efs-make-backup-files)) - (memq host-type efs-make-backup-files)) - (efs-internal-backup-buffer - host host-type (nth 1 parsed) (nth 2 parsed)))))) - -(defun efs-internal-backup-buffer (host host-type user remote-path) - ;; This is almost a copy of the function in files.el, modified - ;; to check to see if the backup file exists, before deleting it. - ;; It also supports efs-backup-by-copying, and tries to do the - ;; right thing about backup-by-copying-when-mismatch. Only called - ;; for remote files. - ;; Set the umask now, so that `setmodes' knows about it. - (efs-set-umask host user) - (let ((ent (efs-get-file-entry (expand-file-name buffer-file-name))) - ;; Never do version-control if the remote operating system is doing it. - (version-control (if (memq host-type efs-version-host-types) - 'never - version-control)) - modstring) - (and make-backup-files - (not buffer-backed-up) - ent ; i.e. file-exists-p - (not (eq t (car ent))) - (or (null (setq modstring (nth 3 ent))) - (not (memq host-type efs-unix-host-types)) - (memq (aref modstring 0) '(?- ?l))) - (or (< (length remote-path) 5) - (not (string-equal "/tmp/" (substring remote-path 0 5)))) - (condition-case () - (let* ((backup-info (find-backup-file-name buffer-file-name)) - (backupname (car backup-info)) - (targets (cdr backup-info)) - (links (nth 4 ent)) - setmodes) - (condition-case () - (if (or file-precious-flag - (stringp (car ent)) ; symlinkp - efs-backup-by-copying - (and backup-by-copying-when-linked - links (> links 1)) - (and backup-by-copying-when-mismatch - (not - (if (memq - host-type - efs-case-insensitive-host-types) - (string-equal - (downcase user) (downcase (nth 2 ent))) - (string-equal user (nth 2 ent)))))) - (copy-file buffer-file-name backupname t t) - (condition-case () - (if (file-exists-p backupname) - (delete-file backupname)) - (file-error nil)) - (rename-file buffer-file-name backupname t) - (setq setmodes (file-modes backupname))) - (file-error - ;; If trouble writing the backup, write it in ~. - (setq backupname (expand-file-name "~/%backup%~")) - (message - "Cannot write backup file; backing up in ~/%%backup%%~") - (sleep-for 1) - (copy-file buffer-file-name backupname t t))) - (setq buffer-backed-up t) - ;; Starting with 19.26, trim-versions-without-asking - ;; has been renamed to delete-old-verions. - (if (and targets - (or (if (boundp 'trim-versions-without-asking) - trim-versions-without-asking - (and - (boundp 'delete-old-versions) - delete-old-versions)) - (y-or-n-p (format - "Delete excess backup versions of %s? " - buffer-file-name)))) - (while targets - (condition-case () - (delete-file (car targets)) - (file-error nil)) - (setq targets (cdr targets)))) - ;; If the file was already written with the right modes, - ;; don't return set-modes. - (and setmodes - (null - (let ((buff (get-buffer - (efs-ftp-process-buffer host user)))) - (and buff - (save-excursion - (set-buffer buff) - (and (integerp efs-process-umask) - (= (efs-modes-from-umask efs-process-umask) - setmodes)))))) - setmodes)) - (file-error nil))))) - -;;;; ------------------------------------------------------------ -;;;; Redefinition for Emacs file mode support -;;;; ------------------------------------------------------------ - -(defmacro efs-build-mode-string-element (int suid-p sticky-p) - ;; INT is between 0 and 7. - ;; If SUID-P is non-nil, we are building the 3-char string for either - ;; the owner or group, and the s[ug]id bit is set. - ;; If STICKY-P is non-nil, we are building the string for other perms, - ;; and the sticky bit is set. - ;; It doesn't make sense for both SUID-P and STICKY-P be non-nil! - (` (let* ((int (, int)) - (suid-p (, suid-p)) - (sticky-p (, sticky-p)) - (read-bit (if (memq int '(4 5 6 7)) "r" "-")) - (write-bit (if (memq int '(2 3 6 7)) "w" "-")) - (x-bit (if (memq int '(1 3 5 7)) - (cond (suid-p "s") (sticky-p "t") ("x")) - (cond (suid-p "S") (sticky-p "T") ("-"))))) - (concat read-bit write-bit x-bit)))) - -(defun efs-mode-string (int) - ;; Takes an octal integer between 0 and 7777, and returns the 9 character - ;; mode string. - (let* ((other-int (% int 10)) - (int (/ int 10)) - (group-int (% int 10)) - (int (/ int 10)) - (owner-int (% int 10)) - (int (/ int 10)) - (suid (memq int '(4 5 6 7))) - (sgid (memq int '(2 3 6 7))) - (sticky (memq int '(1 3 5 7)))) - (concat (efs-build-mode-string-element owner-int suid nil) - (efs-build-mode-string-element group-int sgid nil) - (efs-build-mode-string-element other-int nil sticky)))) - -(defun efs-shell-call-process (command dir &optional in-background) - ;; Runs shell process on remote hosts. - (let* ((parsed (efs-ftp-path dir)) - (host (car parsed)) - (user (nth 1 parsed)) - (rdir (nth 2 parsed)) - (file-name-handler-alist nil)) - (or (string-equal (efs-internal-directory-file-name dir) - (efs-expand-tilde "~" (efs-host-type host) host user)) - (string-match "^cd " command) - (setq command (concat "cd " rdir "; " command))) - (setq command - (format "%s %s%s \"%s\"" ; remsh -l USER does not work well - ; on a hp-ux machine I tried - efs-remote-shell-file-name host - (if efs-remote-shell-takes-user - (concat " -l " user) - "") - command)) - (message "Doing shell command on %s..." host) - ;; do it - (let ((process-connection-type ; don't waste pty's - (null (null in-background)))) - (setq default-directory (file-name-directory efs-tmp-name-template)) - (if in-background - (progn - (setq mode-line-process '(": %s")) - (start-process "Shell" (current-buffer) - shell-file-name "-c" command)) - (call-process shell-file-name nil t nil "-c" command))))) - -(defun efs-set-file-modes (file mode) - ;; set-file-modes for remote files. - ;; For remote files, if mode is nil, does nothing. - ;; This is because efs-file-modes returns nil if the modes - ;; of a remote file couldn't be determined, even if the file exists. - (and mode - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (r-file (nth 2 parsed)) - ;; convert to octal, and keep only 12 lowest order bits. - (omode (format "%o" (- mode (lsh (lsh mode -12) 12))))) - (if (or (efs-get-host-property host 'chmod-failed) - (null (memq (efs-host-type host user) efs-unix-host-types))) - (message "Unable to set file modes for %s to %s." file omode) - (efs-send-cmd - host user - (list 'quote 'site 'chmod omode r-file) - nil nil - (efs-cont (result line cont-lines) (host file r-file omode) - (if result - (let ((exit-code - (efs-shell-call-process - (concat "chmod " omode " " (file-name-nondirectory file)) - (file-name-directory file)))) - (if (not (equal 0 exit-code)) - (progn - (efs-set-host-property host 'chmod-failed t) - (message "CHMOD %s failed for %s on %s." omode r-file host) - (if efs-ding-on-chmod-failure - (progn (ding) (sit-for 1)))))) - (let ((ent (efs-get-file-entry file))) - (if ent - (let* ((type - (cond - ((null (car ent)) "-") - ((eq (car ent) t) "d") - ((stringp (car ent)) "s") - (t - (error - "Weird error in efs-set-file-modes")))) - (mode-string (concat - type - (efs-mode-string - (string-to-int omode)))) - (tail (nthcdr 3 ent))) - (if (consp tail) - (setcar tail mode-string) - (efs-add-file-entry nil file (car ent) (nth 1 ent) - (nth 2 ent) mode-string))))))) - 0)))) ; It should be safe to do this NOWAIT = 0 - ;; set-file-modes returns nil - nil) - -(defmacro efs-parse-mode-element (modes) - ;; Parses MODES, a string of three chars, and returns an integer - ;; between 0 and 7 according to how unix file modes are represented - ;; for chmod. - (` (if (= (length (, modes)) 3) - (let ((list (mapcar - (function (lambda (char) - (if (memq char '( ?- ?S ?T)) 0 1))) - (, modes)))) - ;; Convert to octal - (+ (* (car list) 4) (* (nth 1 list) 2) (nth 2 list))) - (error "Can't parse modes %s" (, modes))))) - -(defun efs-parse-mode-string (string) - ;; Parse a 9-character mode string, and return what it represents - ;; as a decimal integer. - (let ((owner (efs-parse-mode-element (substring string 0 3))) - (group (efs-parse-mode-element (substring string 3 6))) - (other (efs-parse-mode-element (substring string 6 9))) - (owner-x (elt string 2)) - (group-x (elt string 5)) - (other-x (elt string 8))) - (+ (* (+ (if (memq owner-x '(?s ?S)) 4 0) - (if (memq group-x '(?s ?S)) 2 0) - (if (memq other-x '(?t ?T)) 1 0)) - 512) - (* owner 64) - (* group 8) - other))) - -(defun efs-file-modes (file) - ;; Version of file-modes for remote files. - ;; Returns nil if the file modes can't be determined, either because - ;; the file doesn't exist, or for any other reason. - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file))) - (and (memq (efs-host-type (car parsed)) efs-unix-host-types) - ;; Someday we should cache mode strings for non-unix, but they - ;; won't be in unix format. Also, CHMOD doesn't work for non-unix - ;; hosts, so returning this info to emacs is a waste. - (let* ((ent (efs-get-file-entry file)) - (modes (nth 3 ent))) - (and modes - (efs-parse-mode-string (substring modes 1))))))) - -;;;; ------------------------------------------------------------ -;;;; Redefinition of Emacs file modtime support. -;;;; ------------------------------------------------------------ - -(defun efs-day-number (year month day) - ;; Returns the day number within year of date. Taken from calendar.el, - ;; by Edward Reingold. Thanks. - ;; An explanation of the calculation can be found in PascAlgorithms by - ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988. - (let ((day-of-year (+ day (* 31 (1- month))))) - (if (> month 2) - (progn - (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) - (if (zerop (% year 4)) - (setq day-of-year (1+ day-of-year))))) - day-of-year)) - -(defun efs-days-elapsed (year month day) - ;; Number of days elapsed since Jan 1, `efs-time-zero' - (+ (efs-day-number year month day) ; days this year - (* 365 (- year efs-time-zero)) ; days in prior years - (- (/ (max (1- year) efs-time-zero) 4) - (/ efs-time-zero 4)) ; leap years - -1 )) ; don't count today - -;; 2^16 = 65536 -;; Use this to avoid overflows - -(defun efs-seconds-elapsed (year month day hours minutes seconds) - ;; Computes the seconds elapsed from `efs-time-zero', in emacs' - ;; format of a list of two integers, the first the higher 16-bits, - ;; the second the lower 16-bits. - (let* ((days (efs-days-elapsed year month day)) - ;; compute hours - (hours (+ (* 24 days) hours)) - (high (lsh hours -16)) - (low (- hours (lsh high 16))) - ;; compute minutes - (low (+ (* low 60) minutes)) - (carry (lsh low -16)) - (high (+ (* high 60) carry)) - (low (- low (lsh carry 16))) - ;; compute seconds - (low (+ (* low 60) seconds)) - (carry (lsh low -16)) - (high (+ (* high 60) carry)) - (low (- low (lsh carry 16)))) - (list high low))) - -(defun efs-parse-mdtime (string) - ;; Parse a string, which is assumed to be the result of an ftp MDTM command. - (efs-save-match-data - (if (string-match efs-mdtm-msgs string) - (efs-seconds-elapsed - (string-to-int (substring string 4 8)) - (string-to-int (substring string 8 10)) - (string-to-int (substring string 10 12)) - (string-to-int (substring string 12 14)) - (string-to-int (substring string 14 16)) - (string-to-int (substring string 16 18)))))) - -(defun efs-parse-ctime (string) - ;; Parse STRING which is assumed to be the result of a query over port 37. - ;; Returns the number of seconds since the turn of the century, as a - ;; list of two 16-bit integers. - (and (= (length string) 4) - (list (+ (lsh (aref string 0) 8) (aref string 1)) - (+ (lsh (aref string 2) 8) (aref string 3))))) - -(defun efs-time-minus (time1 time2) - ;; Subtract 32-bit integers, represented as two 16-bit integers. - (let ((high (- (car time1) (car time2))) - (low (- (nth 1 time1) (nth 1 time2)))) - (cond - ((and (< high 0) (> low 0)) - (setq high (1+ high) - low (- low 65536))) - ((and (> high 0) (< low 0)) - (setq high (1- high) - low (+ 65536 low)))) - (list high low))) - -(defun efs-time-greater (time1 time2) - ;; Compare two 32-bit integers, each represented as a list of two 16-bit - ;; integers. - (or (> (car time1) (car time2)) - (and (= (car time1) (car time2)) - (> (nth 1 time1) (nth 1 time2))))) - -(defun efs-century-time (host &optional nowait cont) - ;; Treat nil as the local host. - ;; Returns the # of seconds since the turn of the century, according - ;; to the system clock on host. - ;; CONT is called with first arg HOST and second the # of seconds. - (or host (setq host (system-name))) - (efs-set-host-property host 'last-ctime nil) - (efs-set-host-property host 'ctime-cont cont) - (let ((name (format efs-ctime-process-name-format host)) - proc) - (condition-case nil (delete-process name) (error nil)) - (if (and - (or (efs-save-match-data (string-match efs-local-host-regexp host)) - (string-equal host (system-name))) - (setq proc (condition-case nil - (open-network-stream name nil host 37) - (error nil)))) - (progn - (set (intern name) "") - (set-process-filter - proc - (function - (lambda (proc string) - (let ((name (process-name proc)) - result) - (set (intern name) (concat (symbol-value (intern name)) - string)) - (setq result (efs-parse-ctime - (symbol-value (intern name)))) - (if result - (let* ((host (substring name 11 -1)) - (cont (efs-get-host-property host 'ctime-cont))) - (efs-set-host-property host 'last-ctime result) - (condition-case nil (delete-process proc) (error nil)) - (if cont - (progn - (efs-set-host-property host 'ctime-cont nil) - (efs-call-cont cont host result))))))))) - (set-process-sentinel - proc - (function - (lambda (proc state) - (let* ((name (process-name proc)) - (host (substring name 11 -1)) - (cont (efs-get-host-property host 'ctime-cont))) - (makunbound (intern name)) - (or (efs-get-host-property host 'last-ctime) - (if cont - (progn - (efs-set-host-property host 'ctime-cont nil) - (efs-call-cont cont host 'failed)))))))) - (if nowait - nil - (let ((quit-flag nil) - (inhibit-quit nil)) - (while (memq (process-status proc) '(run open)) - (accept-process-output))) - (accept-process-output) - (or (efs-get-host-property host 'last-ctime) - 'failed))) - (if cont - (progn - (efs-set-host-property host 'ctime-cont nil) - (efs-call-cont cont host 'failed))) - (if nowait nil 'failed)))) - -(defun efs-clock-difference (host &optional nowait) - ;; clock difference with the local host - (let ((result (efs-get-host-property host 'clock-diff))) - (or - result - (progn - (efs-century-time - host nowait - (efs-cont (host result) (nowait) - (if (eq result 'failed) - (efs-set-host-property host 'clock-diff 'failed) - (efs-century-time - nil nowait - (efs-cont (lhost lresult) (host result) - (if (eq lresult 'failed) - (efs-set-host-property host 'clock-diff 'failed) - (efs-set-host-property host 'clock-diff - (efs-time-minus result lresult)))))))) - (and (null nowait) - (or (efs-get-host-property host 'clock-diff) - 'failed)))))) - -(defun efs-get-file-mdtm (host user file path) - "For HOST and USER, return FILE's last modification time. -PATH is the file name in full efs syntax. -Returns a list of two six-digit integers which represent the 16 high order -bits, and 16 low order bits of the number of elapsed seconds since -`efs-time-zero'" - (and (null (efs-get-host-property host 'mdtm-failed)) - (let ((result (efs-send-cmd host user (list 'quote 'mdtm file) - (and (eq efs-verbose t) - "Getting modtime"))) - parsed) - (if (and (null (car result)) - (setq parsed (efs-parse-mdtime (nth 1 result)))) - (let ((ent (efs-get-file-entry path))) - (if ent - (setcdr ent (list (nth 1 ent) (nth 2 ent) - (nth 3 ent) (nth 4 ent) - parsed))) - parsed) - (efs-save-match-data - ;; The 550 error is for a nonexistent file. Actually implies - ;; that MDTM works. - (if (string-match "^550 " (nth 1 result)) - '(0 0) - (efs-set-host-property host 'mdtm-failed t) - nil)))))) - -(efs-define-fun efs-set-emacs-bvf-mdtm (buffer mdtm) - ;; Sets cached value for the buffer visited file modtime. - (if (get-buffer buffer) - (save-excursion - (set-buffer buffer) - (let (file-name-handler-alist) - (set-visited-file-modtime mdtm))))) - -;; (defun efs-set-visited-file-modtime (&optional time) -;; ;; For remote files sets the modtime for a buffer to be that of the -;; ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list -;; ;; of two 16-bit integers. -;; ;; The function set-visited-file-modtime is for emacs-19. It doesn't -;; ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for -;; ;; remote files only. -;; (if time -;; (efs-set-emacs-bvf-mdtm (current-buffer) time) -;; (let* ((path buffer-file-name) -;; (parsed (efs-ftp-path path)) -;; (host (car parsed)) -;; (user (nth 1 parsed)) -;; (file (nth 2 parsed)) -;; (buffer (current-buffer))) -;; (if (efs-save-match-data -;; (and efs-verify-modtime-host-regexp -;; (string-match efs-verify-modtime-host-regexp host) -;; (or efs-verify-anonymous-modtime -;; (not (efs-anonymous-p user))) -;; (not (efs-get-host-property host 'mdtm-failed)))) -;; (efs-send-cmd -;; host user (list 'quote 'mdtm file) -;; nil nil -;; (efs-cont (result line cont-lines) (host user path buffer) -;; (let (modtime) -;; (if (and (null result) -;; (setq modtime (efs-parse-mdtime line))) -;; (let ((ent (efs-get-file-entry path))) -;; (if ent -;; (setcdr ent (list (nth 1 ent) (nth 2 ent) -;; (nth 3 ent) (nth 4 ent) -;; modtime))) -;; (setq buffer (and (setq buffer (get-buffer buffer)) -;; (buffer-name buffer))) -;; ;; Beware that since this is happening asynch, the buffer -;; ;; may have disappeared. -;; (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) -;; (efs-save-match-data -;; (or (string-match "^550 " line) -;; (efs-set-host-property host 'mdtm-failed t))) -;; (efs-set-emacs-bvf-mdtm buffer 0)))) ; store dummy values -;; 0) ; Always do this NOWAIT = 0 -;; (efs-set-emacs-bvf-mdtm buffer 0)) -;; nil) ; return NIL -;; )) - -(defvar efs-set-modtimes-synchronously nil - "*Whether efs uses a synchronous FTP command to set the visited file modtime. -Setting this variable to non-nil means that efs will set visited file modtimes -synchronously. - -Asynchronous setting of visited file modtimes leaves a very small -window where Emacs may fail to detect a super session. However, it gives -faster user access to newly visited files.") - - -(defun efs-set-visited-file-modtime (&optional time) - ;; For remote files sets the modtime for a buffer to be that of the - ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list - ;; of two 16-bit integers. - ;; The function set-visited-file-modtime is for emacs-19. It doesn't - ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for - ;; remote files only. - (if time - (efs-set-emacs-bvf-mdtm (current-buffer) time) - (let* ((path buffer-file-name) - (parsed (efs-ftp-path path)) - (host (car parsed)) - (user (nth 1 parsed)) - (file (nth 2 parsed)) - (buffer (current-buffer))) - (if (efs-save-match-data - (and efs-verify-modtime-host-regexp - (string-match efs-verify-modtime-host-regexp host) - (or efs-verify-anonymous-modtime - (not (efs-anonymous-p user))) - (not (efs-get-host-property host 'mdtm-failed)))) - (progn - (or efs-set-modtimes-synchronously (clear-visited-file-modtime)) - (efs-send-cmd - host user (list 'quote 'mdtm file) - nil nil - (efs-cont (result line cont-lines) (host user path buffer) - (let (modtime) - (if (and (null result) - (setq modtime (efs-parse-mdtime line))) - (let ((ent (efs-get-file-entry path))) - (if ent - (setcdr ent (list (nth 1 ent) (nth 2 ent) - (nth 3 ent) (nth 4 ent) - modtime))) - (setq buffer (and (setq buffer (get-buffer buffer)) - (buffer-name buffer))) - ;; Beware that since might be happening asynch, - ;; the buffer may have disappeared. - (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) - (efs-save-match-data - (or (string-match "^550 " line) - (efs-set-host-property host 'mdtm-failed t))) - (efs-set-emacs-bvf-mdtm buffer '(0 0))))) ; store dummy values - (and (null efs-set-modtimes-synchronously) 0))) - (efs-set-emacs-bvf-mdtm buffer '(0 0))) - nil))) ; return NIL - -(defun efs-file-newer-than-file-p (file1 file2) - ;; Version of file-newer-than-file-p for remote files. - (let* ((file1 (expand-file-name file1)) - (file2 (expand-file-name file2)) - (parsed1 (efs-ftp-path file1)) - (parsed2 (efs-ftp-path file2)) - (host1 (car parsed1)) - (host2 (car parsed2)) - (user1 (nth 1 parsed1)) - (user2 (nth 1 parsed2))) - (cond - ;; If the first file doedn't exist, or is remote but - ;; we're not supposed to check modtimes on it, return nil. - ((or (null (file-exists-p file1)) - (and parsed1 - (or - (null efs-verify-modtime-host-regexp) - (efs-get-host-property host1 'mdtm-failed) - (not (string-match efs-verify-modtime-host-regexp host1)) - (and (null efs-verify-anonymous-modtime) - (efs-anonymous-p user1))))) - nil) - ;; If the same is true for the second file, return t. - ((or (null (file-exists-p file2)) - (and parsed2 - (or - (null efs-verify-modtime-host-regexp) - (efs-get-host-property host2 'mdtm-failed) - (not (string-match efs-verify-modtime-host-regexp host2)) - (and (null efs-verify-anonymous-modtime) - (efs-anonymous-p user2))))) - t) - ;; Calculate modtimes. If we get here, any remote files should - ;; have a file entry. - (t - (let (mod1 mod2 shift1 shift2) - (if parsed1 - (let ((ent (efs-get-file-entry file1))) - (setq mod1 (nth 5 ent) - shift1 (efs-clock-difference host1)) - (or mod1 - (setq mod1 (efs-get-file-mdtm - host1 user1 (nth 2 parsed1) file1)))) - (setq mod1 (nth 5 (file-attributes file1)))) - (if parsed2 - (let ((ent (efs-get-file-entry file2))) - (setq mod2 (nth 5 ent) - shift2 (efs-clock-difference host2)) - (or mod2 - (setq mod2 (efs-get-file-mdtm - host2 user2 (nth 2 parsed2) file2)))) - (setq mod2 (nth 5 (file-attributes file2)))) - ;; If we can't compute clock shifts, we act as if we don't - ;; even know the modtime. Should we have more faith in ntp? - (cond - ((or (null mod1) (eq shift1 'failed)) - nil) - ((or (null mod2) (eq shift2 'failed)) - t) - ;; We get to compute something! - (t - (efs-time-greater - (if shift1 (efs-time-minus mod1 shift1) mod1) - (if shift2 (efs-time-minus mod2 shift2) mod2))))))))) - -(defun efs-verify-visited-file-modtime (buff) - ;; Verifies the modtime for buffers visiting remote files. - ;; Won't get called for buffer not visiting any file. - (let ((buff (get-buffer buff))) - (null - (and buff ; return t if no buffer? Need to beware of multi-threading. - (buffer-file-name buff) ; t if no file - (let ((mdtm (save-excursion - (set-buffer buff) - (visited-file-modtime)))) - (and - (not (eq mdtm 0)) - (not (equal mdtm '(0 0))) - efs-verify-modtime-host-regexp - (let* ((path (buffer-file-name buff)) - (parsed (efs-ftp-path path)) - (host (car parsed)) - (user (nth 1 parsed)) - nmdtm) - (and - (null (efs-get-host-property host 'mdtm-failed)) - (efs-save-match-data - (string-match - efs-verify-modtime-host-regexp host)) - (or efs-verify-anonymous-modtime - (not (efs-anonymous-p user))) - (setq nmdtm (efs-get-file-mdtm host user (nth 2 parsed) path)) - (progn - (or (equal nmdtm '(0 0)) - (file-exists-p path) ; Make sure that there is an entry. - (null - (efs-get-files - (file-name-directory - (efs-internal-directory-file-name path)))) - (efs-add-file-entry - (efs-host-type host) path nil nil nil nil nil nmdtm)) - (null (and (eq (cdr mdtm) (nth 1 nmdtm)) - (eq (car mdtm) (car nmdtm))))))))))))) - -;;;; ----------------------------------------------------------- -;;;; Redefinition of Emacs file name completion -;;;; ----------------------------------------------------------- - -(defmacro efs-set-completion-ignored-pattern () - ;; Set regexp efs-completion-ignored-pattern - ;; to use for filename completion. - (` - (or (equal efs-completion-ignored-extensions - completion-ignored-extensions) - (setq efs-completion-ignored-extensions - completion-ignored-extensions - efs-completion-ignored-pattern - (mapconcat (function - (lambda (s) (if (stringp s) - (concat (regexp-quote s) "$") - "/"))) ; / never in filename - efs-completion-ignored-extensions - "\\|"))))) - -(defun efs-file-entry-active-p (sym) - ;; If the file entry is a symlink, returns whether the file pointed to - ;; exists. - ;; Note that DIR is dynamically bound. - (let ((file-type (car (get sym 'val)))) - (or (not (stringp file-type)) - (file-exists-p (efs-chase-symlinks - (expand-file-name file-type efs-completion-dir)))))) - -(defun efs-file-entry-not-ignored-p (sym) - ;; If the file entry is not a directory (nor a symlink pointing to a - ;; directory) returns whether the file (or file pointed to by the symlink) - ;; is ignored by completion-ignored-extensions. - (let ((file-type (car (get sym 'val))) - (symname (symbol-name sym))) - (if (stringp file-type) - ;; Maybe file-truename would be better here, but it is very costly - ;; to chase symlinks at every level over FTP. - (let ((file (efs-chase-symlinks (expand-file-name - file-type efs-completion-dir)))) - (or (file-directory-p file) - (and (file-exists-p file) - (not (string-match efs-completion-ignored-pattern - symname))))) - (or file-type ; is a directory name - (not (string-match efs-completion-ignored-pattern symname)))))) - -(defun efs-file-name-all-completions (file dir) - ;; Does file-name-all-completions in remote directories. - (efs-barf-if-not-directory dir) - (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) - (completion-ignore-case - (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) - efs-case-insensitive-host-types)) - (tbl (efs-get-files efs-completion-dir)) - (completions - (all-completions file tbl - (function efs-file-entry-active-p)))) - ;; see whether each matching file is a directory or not... - (mapcar - ;; Since the entries in completions will match the case - ;; of the entries in tbl, don't need to case-fold - ;; in efs-get-hash-entry below. - (function - (lambda (file) - (let ((ent (car (efs-get-hash-entry file tbl)))) - (if (or (eq ent t) - (and (stringp ent) - (file-directory-p (efs-chase-symlinks - (expand-file-name - ent efs-completion-dir))))) - (concat file "/") - file)))) - completions))) - -(defun efs-file-name-completion (file dir) - ;; Does file name expansion in remote directories. - (efs-barf-if-not-directory dir) - (if (equal file "") - "" - (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) - (completion-ignore-case - (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) - efs-case-insensitive-host-types)) - (tbl (efs-get-files efs-completion-dir))) - (efs-set-completion-ignored-pattern) - (efs-save-match-data - (or (efs-file-name-completion-1 - file tbl efs-completion-dir - (function efs-file-entry-not-ignored-p)) - (efs-file-name-completion-1 - file tbl efs-completion-dir - (function efs-file-entry-active-p))))))) - -(defun efs-file-name-completion-1 (file tbl dir predicate) - ;; Internal subroutine for efs-file-name-completion. Do not call this. - (let ((bestmatch (try-completion file tbl predicate))) - (if bestmatch - (if (eq bestmatch t) - (if (file-directory-p (expand-file-name file dir)) - (concat file "/") - t) - (if (and (eq (try-completion bestmatch tbl predicate) t) - (file-directory-p - (expand-file-name bestmatch dir))) - (concat bestmatch "/") - bestmatch))))) - -;;;; ---------------------------------------------------------- -;;;; Functions for loading lisp. -;;;; ---------------------------------------------------------- - -;;; jka-load provided ideas here. Thanks, Jay. - -(defun efs-load-openp (str suffixes) - ;; Given STR, searches load-path and efs-load-lisp-extensions - ;; for the name of a file to load. Returns the full path, or nil - ;; if none found. - (let ((path-list (if (file-name-absolute-p str) t load-path)) - root result) - ;; If there is no load-path, at least try the default directory. - (or path-list - (setq path-list (list default-directory))) - (while (and path-list (null result)) - (if (eq path-list t) - (setq path-list nil - root str) - (setq root (expand-file-name str (car path-list)) - path-list (cdr path-list)) - (or (file-name-absolute-p root) - (setq root (expand-file-name root default-directory)))) - (let ((suff-list suffixes)) - (while (and suff-list (null result)) - (let ((try (concat root (car suff-list)))) - (if (or (not (file-readable-p try)) - (file-directory-p try)) - (setq suff-list (cdr suff-list)) - (setq result try)))))) - result)) - -(defun efs-load (file &optional noerror nomessage nosuffix) - "Documented as original." - (let ((filename (efs-load-openp - file - (if nosuffix '("") efs-load-lisp-extensions)))) - (if (not filename) - (and (null noerror) (error "Cannot open load file %s" file)) - (let ((parsed (efs-ftp-path filename)) - (after-load (and (boundp 'after-load-alist) - (assoc file after-load-alist)))) - (if parsed - (let ((temp (car (efs-make-tmp-name nil (car parsed))))) - (unwind-protect - (progn - (efs-copy-file-internal - filename parsed temp nil t nil - (format "Getting %s" filename)) - (or (file-readable-p temp) - (error - "efs-load: temp file %s is unreadable" temp)) - (or nomessage - (message "Loading %s..." file)) - ;; temp is an absolute filename, so load path - ;; won't be searched. - (let (after-load-alist) - (efs-real-load temp t t t)) - (or nomessage - (message "Loading %s...done" file)) - (if after-load (mapcar 'eval (cdr after-load))) - t) ; return t if everything worked - (efs-del-tmp-name temp))) - (prog2 - (or nomessage - (message "Loading %s..." file)) - (let (after-load-alist) - (or (efs-real-load filename noerror t t) - (setq after-load nil))) - (or nomessage - (message "Loading %s...done" file)) - (if after-load (mapcar 'eval (cdr after-load))))))))) - -(defun efs-require (feature &optional filename) - "Documented as original." - (if (eq feature 'ange-ftp) (efs-require-scream-and-yell)) - (if (featurep feature) - feature - (or filename (setq filename (symbol-name feature))) - (let ((fullpath (efs-load-openp filename - efs-load-lisp-extensions))) - (if (not fullpath) - (error "Cannot open load file: %s" filename) - (let ((parsed (efs-ftp-path fullpath))) - (if parsed - (let ((temp (car (efs-make-tmp-name nil (car parsed))))) - (unwind-protect - (progn - (efs-copy-file-internal - fullpath parsed temp nil t nil - (format "Getting %s" fullpath)) - (or (file-readable-p temp) - (error - "efs-require: temp file %s is unreadable" temp)) - (efs-real-require feature temp)) - (efs-del-tmp-name temp))) - (efs-real-require feature fullpath))))))) - -(defun efs-require-scream-and-yell () - ;; Complain if something attempts to load ange-ftp. - (with-output-to-temp-buffer "*Help*" - (princ - "Something tried to load ange-ftp. -EFS AND ANGE-FTP DO NOT WORK TOGETHER. - -If the culprit package does need to access ange-ftp internal functions, -then it should be adequate to simply remove the \(require 'ange-ftp\) -line and let efs handle remote file access. Otherwise, it will need to -be ported to efs. This may already have been done, and you can find out -by sending an enquiry to efs-help@cuckoo.hpl.hp.com. - -Signalling an error with backtrace will allow you to determine which -package was requiring ange-ftp.\n")) - (select-window (get-buffer-window "*Help*")) - (enlarge-window (- (count-lines (point-min) (point-max)) - (window-height) -1)) - (if (y-or-n-p "Signal error with backtrace? ") - (let ((stack-trace-on-error t)) - (error "Attempt to require ange-ftp")))) - -;;;; ----------------------------------------------------------- -;;;; Redefinition of Emacs functions for reading file names. -;;;; ----------------------------------------------------------- - -(defun efs-unexpand-parsed-filename (host user path) - ;; Replaces the home directory in path with "~". Returns the unexpanded - ;; full-path. - (let* ((path-len (length path)) - (def-user (efs-get-user host)) - (host-type (efs-host-type host user)) - (ignore-case (memq host-type efs-case-insensitive-host-types))) - (if (> path-len 1) - (let* ((home (efs-expand-tilde "~" host-type host user)) - (home-len (length home))) - (if (and (> path-len home-len) - (if ignore-case (string-equal (downcase home) - (downcase - (substring path - 0 home-len))) - (string-equal home (substring path 0 home-len))) - (= (aref path home-len) ?/)) - (setq path (concat "~" (substring path home-len)))))) - (if (if ignore-case (string-equal (downcase user) - (downcase def-user)) - (string-equal user def-user)) - (format efs-path-format-without-user host path) - (format efs-path-format-string user host path)))) - -(efs-define-fun efs-abbreviate-file-name (filename &optional ignored-for-now) - ;; Version of abbreviate-file-name for remote files. - (efs-save-match-data - (let ((tail directory-abbrev-alist)) - (while tail - (if (string-match (car (car tail)) filename) - (setq filename - (concat (cdr (car tail)) - (substring filename (match-end 0))))) - (setq tail (cdr tail))) - (apply 'efs-unexpand-parsed-filename (efs-ftp-path filename))))) - -(defun efs-default-dir-function () - (let ((parsed (efs-ftp-path default-directory)) - (dd default-directory)) - (if parsed - (efs-save-match-data - (let ((tail directory-abbrev-alist)) - (while tail - (if (string-match (car (car tail)) dd) - (setq dd (concat (cdr (car tail)) - (substring dd (match-end 0))) - parsed nil)) - (setq tail (cdr tail))) - (apply 'efs-unexpand-parsed-filename - (or parsed (efs-ftp-path dd))))) - default-directory))) - -(defun efs-re-read-dir (&optional dir) - "Forces a re-read of the directory DIR. -If DIR is omitted then it defaults to the directory part of the contents -of the current buffer. This is so this function can be caled from the -minibuffer." - (interactive) - (if dir - (setq dir (expand-file-name dir)) - (setq dir (file-name-directory (expand-file-name (buffer-string))))) - (let ((parsed (efs-ftp-path dir))) - (if parsed - (let ((efs-ls-uncache t)) - (efs-del-hash-entry (efs-canonize-file-name dir) - efs-files-hashtable) - (efs-get-files dir t))))) - -;;;; --------------------------------------------------------------- -;;;; Creation and deletion of files and directories. -;;;; --------------------------------------------------------------- - -(defun efs-delete-file (file) - ;; Deletes remote files. - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - (path (nth 2 parsed)) - (abbr (efs-relativize-filename file)) - (result (efs-send-cmd host user (list 'delete path) - (format "Deleting %s" abbr)))) - (if (car result) - (signal 'ftp-error - (list "Removing old name" - (format "FTP Error: \"%s\"" (nth 1 result)) - file))) - (efs-delete-file-entry host-type file))) - -(defun efs-make-directory-internal (dir) - ;; version of make-directory-internal for remote directories. - (if (file-exists-p dir) - (error "Cannot make directory %s: file already exists" dir) - (let* ((parsed (efs-ftp-path dir)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that mkdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that mkdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path (if (or (memq host-type efs-unix-host-types) - (memq host-type '(os2 dos))) - (efs-internal-directory-file-name (nth 2 parsed)) - (efs-internal-file-name-as-directory - host-type (nth 2 parsed)))) - (abbr (efs-relativize-filename dir)) - (result (efs-send-cmd host user - (list 'mkdir path) - (format "Making directory %s" - abbr)))) - (if (car result) - (efs-error host user - (format "Could not make directory %s: %s" dir - (nth 1 result)))) - (efs-add-file-entry host-type dir t nil user)))) - -;; V19 calls this function delete-directory. It used to be called -;; remove-directory. - -(defun efs-delete-directory (dir) - ;; Version of delete-directory for remote directories. - (if (file-directory-p dir) - (let* ((parsed (efs-ftp-path dir)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that rmdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that rmdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path - (if (or (memq host-type efs-unix-host-types) - (memq host-type '(os2 dos))) - (efs-internal-directory-file-name (nth 2 parsed)) - (efs-internal-file-name-as-directory - host-type (nth 2 parsed)))) - (abbr (efs-relativize-filename dir)) - (result (efs-send-cmd host user - (list 'rmdir path) - (format "Deleting directory %s" abbr)))) - (if (car result) - (efs-error host user - (format "Could not delete directory %s: %s" - dir (nth 1 result)))) - (efs-delete-file-entry host-type dir t)) - (error "Not a directory: %s" dir))) - -(defun efs-file-local-copy (file) - ;; internal function for diff.el (dired 6.3 or later) - ;; Makes a temp file containing the contents of file. - ;; returns the name of the tmp file created, or nil if none is. - ;; This function should have optional cont and nowait args. - (let* ((file (expand-file-name file)) - (tmp (car (efs-make-tmp-name nil (car (efs-ftp-path file)))))) - (efs-copy-file-internal file (efs-ftp-path file) - tmp nil t nil (format "Getting %s" file)) - tmp)) - -(defun efs-diff/grep-del-temp-file (temp) - ;; internal function for diff.el and grep.el - ;; if TEMP is non-nil, deletes the temp file TEMP. - ;; if TEMP is nil, does nothing. - (and temp - (efs-del-tmp-name temp))) - -;;;; ------------------------------------------------------------ -;;;; File copying support... -;;;; ------------------------------------------------------------ - -;;; - totally re-written 6/24/92. -;;; - re-written again 9/3/93 -;;; - and again 14/4/93 -;;; - and again 17/8/93 - -(defun efs-barf-or-query-if-file-exists (absname querystring interactive) - (if (file-exists-p absname) - (if (not interactive) - (signal 'file-already-exists (list absname)) - (if (not (yes-or-no-p (format "File %s already exists; %s anyway? " - absname querystring))) - (signal 'file-already-exists (list absname)))))) - -(defun efs-concatenate-files (file1 file2) - ;; Concatenates file1 to file2. Both must be local files. - ;; Needed because the efs version of copy-file understands - ;; ok-if-already-exists = 'append - (or (file-readable-p file1) - (signal 'file-error - (list (format "Input file %s not readable." file1)))) - (or (file-writable-p file2) - (signal 'file-error - (list (format "Output file %s not writable." file2)))) - (let ((default-directory exec-directory)) - (call-process "sh" nil nil nil "-c" (format "cat %s >> %s" file1 file2)))) - -(defun efs-copy-add-file-entry (newname host-type user size append) - ;; Add an entry in `efs-files-hashtable' for a file newly created via a copy. - (if (eq size -1) (setq size nil)) - (if append - (let ((ent (efs-get-file-entry newname))) - (if (and ent (null (car ent))) - (if (and size (numberp (nth 1 ent))) - (setcar (cdr ent) (+ size (nth 1 ent))) - (setcar (cdr ent) nil)) - ;; If the ent is a symlink or directory, don't overwrite that entry. - (if (null ent) - (efs-add-file-entry host-type newname nil nil nil)))) - (efs-add-file-entry host-type newname nil size user))) - -(defun efs-copy-remote-to-remote (f-host-type f-host f-user f-path filename - t-host-type t-host t-user - t-path newname append msg cont - nowait xfer-type) -;; Use a 3rd data connection to copy from F-HOST for F-USER to T-HOST -;; for T-USER. - (if (efs-get-host-property t-host 'pasv-failed) - ;; PASV didn't work before, don't try again. - (if cont (efs-call-cont cont 'failed "" "")) - (or xfer-type - (setq xfer-type (efs-xfer-type f-host-type filename - t-host-type newname))) - (efs-send-cmd - t-host t-user '(quote pasv) nil nil - (efs-cont (pasv-result pasv-line pasv-cont-lines) - (cont nowait f-host-type f-host f-user f-path filename - t-host-type t-host t-user t-path newname xfer-type msg append) - (efs-save-match-data - (if (or pasv-result - (not (string-match efs-pasv-msgs pasv-line))) - (progn - (efs-set-host-property t-host 'pasv-failed t) - (if cont - (efs-call-cont - cont (or pasv-result 'failed) pasv-line pasv-cont-lines))) - (let ((address (substring pasv-line (match-beginning 1) - (match-end 1)))) - (efs-send-cmd - f-host f-user - (list 'quote 'port address) nil nil - (efs-cont (port-result port-line port-cont-lines) - (cont f-host f-user f-host-type f-path filename - xfer-type msg) - (if port-result - (if cont - (efs-call-cont - cont port-result port-line port-cont-lines) - (efs-error f-host f-user - (format "PORT failed for %s: %s" - filename port-line))) - (efs-send-cmd - f-host f-user - (list 'quote 'retr f-path xfer-type) - msg nil - (efs-cont (retr-result retr-line retr-cont-lines) - (cont f-host f-user f-path) - (and retr-result - (null cont) - (efs-error - f-host f-user - (format "RETR failed for %s: %s" - f-path retr-line))) - (if cont (efs-call-cont - cont retr-result retr-line retr-cont-lines))) - (if (eq nowait t) 1 nowait)))) - 1) ; can't ever wait on this command. - (efs-send-cmd - t-host t-user - (list 'quote (if append 'appe 'stor) t-path xfer-type) - nil nil - (efs-cont (stor-result stor-line stor-cont-lines) - (t-host t-user t-path t-host-type newname filename - append) - (if stor-result - (efs-error - t-host t-user (format "%s failed for %s: %s" - (if append "APPE" "STOR") - t-path stor-line)) - (efs-copy-add-file-entry - newname t-host-type t-user - (nth 1 (efs-get-file-entry filename)) append))) - (if (eq nowait t) 1 nowait)))))) - nowait))) - -(defun efs-copy-on-remote (host user host-type filename newname filename-parsed - newname-parsed keep-date append-p msg cont - nowait xfer-type) - ;; Uses site exec to copy the file on a remote host - (let ((exec-cp (efs-get-host-property host 'exec-cp))) - (if (or append-p - (not (memq host-type efs-unix-host-types)) - (efs-get-host-property host 'exec-failed) - (eq exec-cp 'failed)) - (efs-copy-via-temp filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type) - (if (eq exec-cp 'works) - (efs-send-cmd - host user - (list 'quote 'site 'exec - (format "cp %s%s %s" (if keep-date "-p " "") - (nth 2 filename-parsed) (nth 2 newname-parsed))) - msg nil - (efs-cont (result line cont-lines) (host user filename newname - host-type filename-parsed - newname-parsed - keep-date append-p msg cont - xfer-type nowait) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-copy-via-temp filename filename-parsed newname - newname-parsed append-p keep-date - nil cont nowait xfer-type)) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user err))) - (efs-copy-add-file-entry - newname host-type user - (nth 7 (efs-file-attributes filename)) nil) - (if cont (efs-call-cont cont nil line cont-lines)))))) - nowait) - (message "Checking for cp executable on %s..." host) - (efs-send-cmd - host user (list 'quote 'site 'exec "cp / /") nil nil - (efs-cont (result line cont-lines) (host user filename newname - host-type filename-parsed - newname-parsed - keep-date append-p msg cont - xfer-type nowait) - (efs-save-match-data - (if (string-match "\n200-" cont-lines) - (efs-set-host-property host 'exec-cp 'works) - (efs-set-host-property host 'exec-cp 'failed))) - (efs-copy-on-remote host user host-type filename newname - filename-parsed newname-parsed keep-date - append-p msg cont nowait xfer-type)) - nowait))))) - -(defun efs-copy-via-temp (filename filename-parsed newname newname-parsed - append keep-date msg cont nowait xfer-type) - ;; Copies from FILENAME to NEWNAME via a temp file. - (let* ((temp (car (if (efs-use-gateway-p (car filename-parsed) t) - (efs-make-tmp-name (car filename-parsed) - (car newname-parsed)) - (efs-make-tmp-name (car newname-parsed) - (car filename-parsed))))) - (temp-parsed (efs-ftp-path temp))) - (or xfer-type (setq xfer-type - (efs-xfer-type - (efs-host-type (car filename-parsed)) filename - (efs-host-type (car newname-parsed)) newname - t))) - (efs-copy-file-internal - filename filename-parsed temp temp-parsed t nil (if (eq 0 msg) 2 msg) - (efs-cont (result line cont-lines) (newname newname-parsed temp - temp-parsed append msg cont - nowait xfer-type) - (if result - (progn - (efs-del-tmp-name temp) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\" " line) filename)))) - (efs-copy-file-internal - temp temp-parsed newname newname-parsed (if append 'append t) nil - (if (eq msg 0) 1 msg) - (efs-cont (result line cont-lines) (temp newname cont) - (efs-del-tmp-name temp) - (if cont - (efs-call-cont cont result line cont-lines) - (if result - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\" " line) newname))))) - nowait xfer-type))) - nowait xfer-type))) - -(defun efs-copy-file-internal (filename filename-parsed newname newname-parsed - ok-if-already-exists keep-date - &optional msg cont nowait xfer-type) - ;; Internal function for copying a file from FILENAME to NEWNAME. - ;; FILENAME-PARSED and NEWNAME-PARSED are the lists obtained by parsing - ;; FILENAME and NEWNAME with efs-ftp-path. - ;; If OK-IF-ALREADY-EXISTS is nil, then existing files will not be - ;; overwritten. - ;; If it is a number, then the user will be prompted about overwriting. - ;; If it eq 'append, then an existing file will be appended to. - ;; If it has anyother value, then existing files will be silently - ;; overwritten. - ;; If KEEP-DATE is t then we will attempt to reatin the date of the - ;; original copy of the file. If this is a string, the modtime of the - ;; NEWNAME will be set to this date. Must be in touch -t format. - ;; If MSG is nil, then the copying will be done silently. - ;; If it is a string, then that will be the massage displayed while copying. - ;; If it is 0, then a suitable default message will be computed. - ;; If it is 1, then a suitable default will be computed, assuming - ;; that FILENAME is a temporary file, whose name is not suitable to use - ;; in a status message. - ;; If it is 2, then a suitable default will be used, assuming that - ;; NEWNAME is a temporary file. - ;; CONT is a continuation to call after completing the copy. - ;; The first two args are RESULT and LINE, the result symbol and status - ;; line of the FTP command. If more than one ftp command has been used, - ;; then these values for the last FTP command are given. - ;; NOWAIT can be either nil, 0, 1, t. See `efs-send-cmd' for an explanation. - ;; XFER-TYPE is the transfer type to use for transferring the files. - ;; If this is nil, than a suitable transfer type is computed. - ;; Does not call expand-file-name. Do that yourself. - - ;; check to see if we can overwrite - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname "copy to it" (numberp ok-if-already-exists))) - (if (null (or filename-parsed newname-parsed)) - ;; local to local copy - (progn - (if (eq ok-if-already-exists 'append) - (efs-concatenate-files filename newname) - (copy-file filename newname ok-if-already-exists keep-date)) - (if cont - (efs-call-cont cont nil "Copied locally" ""))) - (let* ((f-host (car filename-parsed)) - (f-user (nth 1 filename-parsed)) - (f-path (nth 2 filename-parsed)) - (f-host-type (efs-host-type f-host f-user)) - (f-gate-p (efs-use-gateway-p f-host t)) - (t-host (car newname-parsed)) - (t-user (nth 1 newname-parsed)) - (t-path (nth 2 newname-parsed)) - (t-host-type (efs-host-type t-host t-user)) - (t-gate-p (efs-use-gateway-p t-host t)) - (append-p (eq ok-if-already-exists 'append)) - gatename) - - (if (and (eq keep-date t) (null newname-parsed)) - ;; f-host must be remote now. - (setq keep-date filename)) - - (cond - - ;; Check to see if we can do a PUT - ((or - (and (null f-host) - (or (null t-gate-p) - (setq gatename (efs-local-to-gateway-filename filename)))) - (and t-gate-p - f-host - (string-equal (downcase f-host) (downcase efs-gateway-host)) - (if (memq f-host-type efs-case-insensitive-host-types) - (string-equal (downcase f-user) - (downcase (efs-get-user efs-gateway-host))) - (string-equal f-user (efs-get-user efs-gateway-host))))) - (or f-host (let (file-name-handler-alist) - (if (file-exists-p filename) - (cond - ((file-directory-p filename) - (signal 'file-error - (list "Non-regular file" - "is a directory" filename))) - ((not (file-readable-p filename)) - (signal 'file-error - (list "Opening input file" - "permission denied" filename)))) - (signal 'file-error - (list "Opening input file" - "no such file or directory" filename))))) - (or xfer-type - (setq xfer-type - (efs-xfer-type f-host-type filename t-host-type newname))) - (let ((size (and (or (null f-host-type) - (efs-file-entry-p filename)) - (nth 7 (file-attributes filename))))) - ;; -1 is a bogus size for remote files - (if (eq size -1) (setq size nil)) - (efs-send-cmd - t-host t-user - (list (if append-p 'append 'put) - (if f-host - f-path - (or gatename filename)) - t-path - xfer-type) - (cond ((eq msg 2) - (concat (if append-p "Appending " "Putting ") - (efs-relativize-filename filename))) - ((eq msg 1) - (concat (if append-p "Appending " "Putting ") - (efs-relativize-filename newname))) - ((eq msg 0) - (concat (if append-p "Appending " "Copying ") - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - (t msg)) - (and size (list 'efs-set-xfer-size t-host t-user size)) - (efs-cont (result line cont-lines) (newname t-host-type t-user size - append-p cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\" " line) newname))) - ;; add file entry - (efs-copy-add-file-entry newname t-host-type t-user - size append-p) - (if cont - (efs-call-cont cont result line cont-lines)))) - nowait))) - - ;; Check to see if we can do a GET - ((and - ;; I think that giving the append arg, will cause this function - ;; to make a temp file, recursively call itself, and append the temp - ;; file to the local file. Hope it works out... - (null append-p) - (or - (and (null t-host) - (or (null f-gate-p) - (setq gatename (efs-local-to-gateway-filename newname)))) - (and f-gate-p - t-host - (string-equal (downcase t-host) (downcase efs-gateway-host)) - (if (memq t-host-type efs-case-insensitive-host-types) - (string-equal (downcase t-user) - (downcase (efs-get-user efs-gateway-host))) - (string-equal t-user (efs-get-user efs-gateway-host)))))) - (or t-host (let (file-name-handler-alist) - (cond ((not (file-writable-p newname)) - (signal 'file-error - (list "Opening output file" - "permission denied" newname))) - ((file-directory-p newname) - (signal 'file-error - (list "Opening output file" - "is a directory" newname)))))) - (or xfer-type - (setq xfer-type - (efs-xfer-type f-host-type filename t-host-type newname))) - (let ((size (and (or (null f-host-type) - (efs-file-entry-p filename)) - (nth 7 (file-attributes filename))))) - ;; -1 is a bogus size for remote files. - (if (eq size -1) (setq size nil)) - (efs-send-cmd - f-host f-user - (list 'get - f-path - (if t-host - t-path - (or gatename newname)) - xfer-type) - (cond ((eq msg 0) - (concat "Copying " - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - ((eq msg 2) - (concat "Getting " (efs-relativize-filename filename))) - ((eq msg 1) - (concat "Getting " (efs-relativize-filename newname))) - (t msg)) - ;; If the server emits a efs-xfer-size-msgs, it will over-ride this. - ;; With no xfer msg, this is will do the job. - (and size (list 'efs-set-xfer-size f-host f-user size)) - (efs-cont (result line cont-lines) (filename newname size - t-host-type t-user - cont keep-date) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\" " line) filename))) - ;; Add a new file entry, if relevant. - (if t-host-type - ;; t-host will be equal to efs-gateway-host, if t-host-type - ;; is non-nil. - (efs-copy-add-file-entry newname t-host-type - t-user size nil)) - (if (and (null t-host-type) (stringp keep-date)) - (efs-set-mdtm-of - filename newname - (and cont - (efs-cont (result1 line1 cont-lines1) (result - line cont-lines - cont) - (efs-call-cont cont result line cont-lines)))) - (if cont - (efs-call-cont cont result line cont-lines))))) - nowait))) - - ;; Can we do a EXEC cp? - ((and t-host f-host - (string-equal (downcase t-host) (downcase f-host)) - (if (memq t-host-type efs-case-insensitive-host-types) - (string-equal (downcase t-user) (downcase f-user)) - (string-equal t-user f-user))) - (efs-copy-on-remote - t-host t-user t-host-type filename newname filename-parsed - newname-parsed keep-date append-p - (cond ((eq msg 0) - (concat "Copying " - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - ((eq msg 1) - (concat "Copying " (efs-relativize-filename newname))) - ((eq msg 2) - (concat "Copying " (efs-relativize-filename filename))) - (t msg)) - cont nowait xfer-type)) - - ;; Try for a copy with PASV - ((and t-host f-host - (not (and (string-equal (downcase t-host) (downcase f-host)) - (if (memq t-host-type efs-case-insensitive-host-types) - (string-equal (downcase t-user) (downcase f-user)) - (string-equal t-user f-user)))) - (or - (and efs-gateway-host - ;; The gateway should be able to talk to anything. - (let ((gh (downcase efs-gateway-host))) - (or (string-equal (downcase t-host) gh) - (string-equal (downcase f-host) gh)))) - (efs-save-match-data - (eq (null (string-match efs-local-host-regexp t-host)) - (null (string-match efs-local-host-regexp f-host)))))) - (efs-copy-remote-to-remote - f-host-type f-host f-user f-path filename - t-host-type t-host t-user t-path newname - append-p - (cond ((eq msg 0) - (concat "Copying " - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - ((eq msg 1) - (concat "Copying " (efs-relativize-filename newname))) - ((eq msg 2) - (concat "Copying " (efs-relativize-filename filename))) - (t msg)) - (efs-cont (result line cont-lines) - (filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type) - (if result - ;; PASV didn't work. Do things the old-fashioned - ;; way. - (efs-copy-via-temp - filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type) - (if cont - (efs-call-cont cont result line cont-lines)))) - nowait xfer-type)) - - ;; Can't do anything direct. Divide and conquer. - (t - (efs-copy-via-temp filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type)))))) - -(defun efs-copy-file (filename newname &optional ok-if-already-exists - keep-date nowait) - ;; Version of copy file for remote files. Actually, will also work - ;; for local files too, since efs-copy-file-internal can copy anything. - ;; If called interactively, copies asynchronously. - (setq filename (expand-file-name filename) - newname (expand-file-name newname)) - (if (eq ok-if-already-exists 'append) - (setq ok-if-already-exists t)) - (efs-copy-file-internal filename (efs-ftp-path filename) - newname (efs-ftp-path newname) - ok-if-already-exists keep-date 0 nil nowait)) - -;;;; ------------------------------------------------------------ -;;;; File renaming support. -;;;; ------------------------------------------------------------ - -(defun efs-rename-get-file-list (dir ent) - ;; From hashtable ENT for DIR returns a list of all files except "." - ;; and "..". - (let (list) - (efs-map-hashtable - (function - (lambda (key val) - (or (string-equal "." key) (string-equal ".." key) - (setq list - (cons (expand-file-name key dir) list))))) - ent) - list)) - -(defun efs-rename-get-files (dir cont nowait) - ;; Obtains a list of files in directory DIR (except . and ..), and applies - ;; CONT to the list. Doesn't return anything useful. - (let* ((dir (file-name-as-directory dir)) - (ent (efs-get-files-hashtable-entry dir))) - (if ent - (efs-call-cont cont (efs-rename-get-file-list dir ent)) - (efs-ls - dir (efs-ls-guess-switches) t nil t nowait - (efs-cont (listing) (dir cont) - (efs-call-cont - cont (and listing - (efs-rename-get-file-list - dir (efs-get-files-hashtable-entry dir))))))))) - -(defun efs-rename-get-local-file-tree (dir) - ;; Returns a list of the full directory tree under DIR, for DIR on the - ;; local host. The list is in tree order. - (let ((res (list dir))) - (mapcar - (function - (lambda (file) - (if (file-directory-p file) - (nconc res (delq nil (mapcar - (function - (lambda (f) - (and (not (string-equal "." f)) - (not (string-equal ".." f)) - (expand-file-name f file)))) - (directory-files file))))))) - res) - res)) - -(defun efs-rename-get-remote-file-tree (next curr total cont nowait) - ;; Builds a hierarchy of files. - ;; NEXT is the next level so far. - ;; CURR are unprocessed files in the current level. - ;; TOTAL is the processed files so far. - ;; CONT is a cont. function called on the total list after all files - ;; are processed. - ;; NOWAIT non-nil means run asynch. - (or curr (setq curr next - next nil)) - (if curr - (let ((file (car curr))) - (setq curr (cdr curr) - total (cons file total)) - (if (file-directory-p file) - (efs-rename-get-files - file - (efs-cont (list) (next curr total cont nowait) - (efs-rename-get-remote-file-tree (nconc next list) - curr total cont nowait)) - nowait) - (efs-rename-get-remote-file-tree next curr total cont nowait))) - (efs-call-cont cont (nreverse total)))) - -(defun efs-rename-make-targets (files from-dir-len to-dir host user host-type - cont nowait) - ;; Make targets (copy a file or make a subdir) on local or host - ;; for the files in list. Afterwhich, call CONT. - (if files - (let* ((from (car files)) - (files (cdr files)) - (to (concat to-dir (substring from from-dir-len)))) - (if (file-directory-p from) - (if host-type - (let ((dir (nth 2 (efs-ftp-path to)))) - (or (memq host-type efs-unix-host-types) - (memq host-type '(dos os2)) - (setq dir (efs-internal-file-name-as-directory nil dir))) - (efs-send-cmd - host user (list 'mkdir dir) - (format "Making directory %s" (efs-relativize-filename to)) - nil - (efs-cont (res line cont-lines) (to files from-dir-len - to-dir host user - host-type cont nowait) - (if res - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Making directory" - (format "FTP Error: \"%s\"" line) - to))) - (efs-rename-make-targets - files from-dir-len to-dir host user - host-type cont nowait))) - nowait)) - (condition-case nil - (make-directory-internal to) - (error (efs-call-cont - cont 'failed (format "Failed to mkdir %s" to) ""))) - (efs-rename-make-targets - files from-dir-len to-dir host user host-type cont nowait)) - (efs-copy-file-internal - from (efs-ftp-path from) to (and host-type (efs-ftp-path to)) nil t - (format "Renaming %s to %s" (efs-relativize-filename from) - (efs-relativize-filename to)) - (efs-cont (res line cont-lines) (from to files from-dir-len to-dir - host user host-type cont - nowait) - (if res - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) from to))) - (efs-rename-make-targets - files from-dir-len to-dir host user host-type cont nowait))) - nowait))) - (if cont (efs-call-cont cont nil "" "")))) - -(defun efs-rename-delete-on-local (files) - ;; Delete the files FILES, and then run CONT. - ;; FILES are assumed to be in inverse tree order. - (message "Deleting files...") - (mapcar - (function - (lambda (f) - (condition-case nil - (if (file-directory-p f) - (delete-directory f) - (delete-file f)) - (file-error nil)))) ; don't complain if the file is already gone. - files) - (message "Deleting files...done")) - -(defun efs-rename-delete-on-remote (files host user host-type cont nowait) - ;; Deletes the list FILES on a remote host. When done calls CONT. - ;; FILES is assumed to be in reverse tree order. - (if files - (let* ((f (car files)) - (rf (nth 2 (efs-ftp-path f)))) - (progn - (setq files (cdr files)) - (if (file-directory-p f) - (let ((rf (if (memq host-type (append efs-unix-host-types - '(dos os2))) - (efs-internal-directory-file-name f) - (efs-internal-file-name-as-directory nil f)))) - - (efs-send-cmd - host user (list 'rmdir rf) - (concat "Deleting directory " (efs-relativize-filename f)) - nil - (efs-cont (res line cont-lines) (f files host user host-type - cont nowait) - (if (and res - (efs-save-match-data - (not (string-match "^550 " line)))) - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Deleting directory" - (format "FTP Error: \"%s\"" line) - f))) - (efs-rename-delete-on-remote - files host user host-type cont nowait))) - nowait)) - (efs-send-cmd - host user (list 'delete rf) - (concat "Deleting " rf) - nil - (efs-cont (res line cont-lines) (f files host user host-type - cont nowait) - (if (and res - (efs-save-match-data - (not (string-match "^550 " line)))) - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Deleting" - (format "FTP Error: \"%s\"" line) - f))) - (efs-rename-delete-on-remote - files host user host-type cont nowait))) - nowait)))) - (if cont (efs-call-cont cont nil "" "")))) - -(defun efs-rename-on-remote (host user old-path new-path old-file new-file - msg nowait cont) - ;; Run a rename command on the remote server. - ;; OLD-PATH and NEW-PATH are in full efs syntax. - ;; OLD-FILE and NEW-FILE are the remote full pathnames, not in efs syntax. - (efs-send-cmd - host user (list 'rename old-file new-file) msg nil - (efs-cont (result line cont-lines) (cont old-path new-path host) - (if result - (progn - (or (and (>= (length line) 4) - (string-equal "550 " (substring line 0 4))) - (efs-set-host-property host 'rnfr-failed t)) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - old-path new-path)))) - (let ((entry (efs-get-file-entry old-path)) - (host-type (efs-host-type host)) - ;; If no file entry, do extra work on the hashtable, - ;; rather than force a listing. - (dir-p (or (not (efs-file-entry-p old-path)) - (file-directory-p old-path)))) - (apply 'efs-add-file-entry host-type new-path - (eq (car entry) t) (cdr entry)) - (efs-delete-file-entry host-type old-path) - (if dir-p - (let* ((old (efs-canonize-file-name - (file-name-as-directory old-path))) - (new (efs-canonize-file-name - (file-name-as-directory new-path))) - (old-len (length old)) - (new-tbl (efs-make-hashtable - (length efs-files-hashtable)))) - (efs-map-hashtable - (function - (lambda (key val) - (if (and (>= (length key) old-len) - (string-equal (substring key 0 old-len) - old)) - (efs-put-hash-entry - (concat new (substring key old-len)) val new-tbl) - (efs-put-hash-entry key val new-tbl)))) - efs-files-hashtable) - (setq efs-files-hashtable new-tbl))) - (if cont (efs-call-cont cont result line cont-lines))))) - nowait)) - -(defun efs-rename-local-to-remote (filename newname newname-parsed - msg cont nowait) - ;; Renames a file from the local host to a remote host. - (if (file-directory-p filename) - (let* ((files (efs-rename-get-local-file-tree filename)) - (to-dir (directory-file-name newname)) - (filename (directory-file-name filename)) - (len (length filename)) - (t-parsed (efs-ftp-path to-dir)) - (host (car t-parsed)) - (user (nth 1 t-parsed)) - (host-type (efs-host-type host))) - ;; MSG is never passed here, instead messages are constructed - ;; internally. I don't know how to use a single message - ;; in a function which sends so many FTP commands. - (efs-rename-make-targets - files len to-dir host user host-type - (efs-cont (result line cont-lines) (files filename newname cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" (format "FTP Error: \"%s\"" line) - filename newname))) - (efs-rename-delete-on-local (nreverse files)) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait)) - (efs-copy-file-internal - filename nil newname newname-parsed t t msg - (efs-cont (result line cont-lines) (filename cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - filename newname))) - (condition-case nil - (delete-file filename) - (error nil)) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait))) - -(defun efs-rename-from-remote (filename filename-parsed newname newname-parsed - msg cont nowait) - (let ((f-host (car filename-parsed)) - (f-user (nth 1 filename-parsed)) - (fast-nowait (if (eq nowait t) 1 nowait))) - (if (file-directory-p filename) - (let* ((t-host (car newname-parsed)) - (t-user (nth 1 newname-parsed)) - (t-host-type (and t-host (efs-host-type t-host))) - (f-host-type (efs-host-type f-host))) - (efs-rename-get-remote-file-tree - nil (list filename) nil - (efs-cont (list) (filename filename-parsed newname t-host t-user - t-host-type f-host f-user f-host-type - cont fast-nowait) - (efs-rename-make-targets - list (length filename) newname t-host t-user t-host-type - (efs-cont (res line cont-lines) (filename newname f-host f-user - f-host-type list cont - fast-nowait) - (if res - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - filename newname))) - (efs-rename-delete-on-remote - (nreverse list) f-host f-user f-host-type cont - fast-nowait))) - fast-nowait)) nowait)) - ;; Do things the simple way. - (let ((f-path (nth 2 filename-parsed)) - (f-abbr (efs-relativize-filename filename))) - (efs-copy-file-internal - filename filename-parsed newname newname-parsed t t msg - (efs-cont (result line cont-lines) (filename newname f-host f-user - f-path f-abbr - cont fast-nowait) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - filename newname))) - (efs-send-cmd - f-host f-user (list 'delete f-path) - (format "Removing %s" f-abbr) nil - (efs-cont (result line cont-lines) (filename f-host cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "Failed to remove %s" - filename) - "FTP Error: \"%s\"" line))) - (efs-delete-file-entry (efs-host-type f-host) - filename) - (if cont - (efs-call-cont cont result line cont-lines)))) - fast-nowait))) nowait))))) - -(defun efs-rename-file-internal (filename newname ok-if-already-exists - &optional msg cont nowait) - ;; Internal version of rename-file for remote files. - ;; Takes CONT and NOWAIT args. - (let ((filename (expand-file-name filename)) - (newname (expand-file-name newname))) - (let ((f-parsed (efs-ftp-path filename)) - (t-parsed (efs-ftp-path newname))) - (if (null (or f-parsed t-parsed)) - (progn - ;; local rename - (rename-file filename newname ok-if-already-exists) - (if cont - (efs-call-cont cont nil "Renamed locally" ""))) - - ;; check to see if we can overwrite - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname "rename to it" (numberp ok-if-already-exists))) - - (let ((f-abbr (efs-relativize-filename filename)) - (t-abbr (efs-relativize-filename newname - (file-name-directory filename) - filename))) - (or msg (setq msg (format "Renaming %s to %s" f-abbr t-abbr))) - (if f-parsed - (let* ((f-host (car f-parsed)) - (f-user (nth 1 f-parsed)) - (f-path (nth 2 f-parsed)) - (f-host-type (efs-host-type f-host))) - (if (and t-parsed - (string-equal (downcase f-host) - (downcase (car t-parsed))) - (not (efs-get-host-property f-host 'rnfr-failed)) - (if (memq f-host-type efs-case-insensitive-host-types) - (string-equal (downcase f-user) - (downcase (nth 1 t-parsed))) - (string-equal f-user (nth 1 t-parsed)))) - ;; Can run a RENAME command on the server. - (efs-rename-on-remote - f-host f-user filename newname f-path (nth 2 t-parsed) - msg nowait - (efs-cont (result line cont-lines) (f-host - filename - newname - ok-if-already-exists - msg cont nowait) - (if result - (progn - (efs-set-host-property f-host 'rnfr-failed t) - (efs-rename-file-internal - filename newname ok-if-already-exists msg cont - (if (eq nowait t) 1 nowait))) - (if cont - (efs-call-cont cont result line cont-lines))))) - ;; remote to remote - (efs-rename-from-remote filename f-parsed newname t-parsed - msg cont nowait))) - ;; local to remote - (efs-rename-local-to-remote - filename newname t-parsed msg cont nowait))))))) - -(defun efs-rename-file (filename newname &optional ok-if-already-exists nowait) - ;; Does file renaming for remote files. - (efs-rename-file-internal filename newname ok-if-already-exists - nil nil nowait)) - -;;;; ------------------------------------------------------------ -;;;; Making symbolic and hard links. -;;;; ------------------------------------------------------------ - -;;; These functions require that the remote FTP server understand -;;; SITE EXEC and that ln is in its the ftp-exec path. - -(defun efs-try-ln (host user cont nowait) - ;; Do some preemptive testing to see if exec ln works - (if (efs-get-host-property host 'exec-failed) - (signal 'ftp-error (list "Unable to exec ln on host" host))) - (let ((exec-ln (efs-get-host-property host 'exec-ln))) - (cond - ((eq exec-ln 'failed) - (signal 'ftp-error (list "ln is not in FTP exec path on host" host))) - ((eq exec-ln 'works) - (efs-call-cont cont)) - (t - (message "Checking for ln executable on %s..." host) - (efs-send-cmd - host user '(quote site exec "ln / /") - nil nil - (efs-cont (result line cont-lines) (host user cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (format "exec: %s" line))) - ;; Look for an error message - (if (efs-save-match-data - (string-match "\n200-" cont-lines)) - (progn - (efs-set-host-property host 'exec-ln 'works) - (efs-call-cont cont)) - (efs-set-host-property host 'exec-ln 'failed) - (efs-error host user - (format "ln not in FTP exec path on host %s" host))))) - nowait))))) - -(defun efs-make-symbolic-link-internal - (target linkname &optional ok-if-already-exists cont nowait) - ;; Makes remote symbolic links. Assumes that linkname is already expanded. - (let* ((parsed (efs-ftp-path linkname)) - (host (car parsed)) - (user (nth 1 parsed)) - (linkpath (nth 2 parsed)) - (abbr (efs-relativize-filename linkname - (file-name-directory target) target)) - (tparsed (efs-ftp-path target)) - (com-target target) - cmd-string) - (if (null (file-directory-p - (file-name-directory linkname))) - (if cont - (efs-call-cont cont 'failed - (format "no such file or directory, %s" linkname) - "") - (signal 'file-error (list "no such file or directory" linkname))) - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - linkname "make symbolic link" (numberp ok-if-already-exists))) - ;; Do this after above, so that hopefully the host type is sorted out - ;; by now. - (let ((host-type (efs-host-type host))) - (if (or (not (memq host-type efs-unix-host-types)) - (memq host-type efs-dumb-host-types) - (efs-get-host-property host 'exec-failed)) - (error "Unable to make symbolic links on %s." host))) - ;; Be careful not to spoil relative links, or symlinks to other - ;; machines, which maybe symlink-fix.el can sort out. - (if (and tparsed - (string-equal (downcase (car tparsed)) (downcase host)) - (string-equal (nth 1 tparsed) user)) - (setq com-target (nth 2 tparsed))) - ;; symlinks only work for unix, so don't need to - ;; convert pathnames. What about VOS? - (setq cmd-string (concat "ln -sf " com-target " " linkpath)) - (efs-try-ln - host user - (efs-cont () (host user cmd-string target linkname com-target - abbr cont nowait) - (efs-send-cmd - host user (list 'quote 'site 'exec cmd-string) - (format "Symlinking %s to %s" target abbr) - nil - (efs-cont (result line cont-lines) (host user com-target linkname - cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (format "exec: %s" line))) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user err))) - (efs-add-file-entry nil linkname com-target nil user) - (if cont (efs-call-cont cont nil line cont-lines)))))) - nowait)) - nowait)))) - -(defun efs-make-symbolic-link (target linkname &optional ok-if-already-exists) - ;; efs version of make-symbolic-link - (let* ((linkname (expand-file-name linkname)) - (parsed (efs-ftp-path linkname))) - (if parsed - (efs-make-symbolic-link-internal target linkname ok-if-already-exists) - ;; Handler will match on either target or linkname. We are only - ;; interested in the linkname. - (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn - 'efs-file-handler-function))) - (make-symbolic-link target linkname ok-if-already-exists))))) - -(defun efs-add-name-to-file-internal - (file newname &optional ok-if-already-exists cont nowait) - ;; Makes remote symbolic links. Assumes that linkname is already expanded. - (let* ((parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (nparsed (efs-ftp-path newname)) - (nhost (car nparsed)) - (nuser (nth 1 nparsed)) - (npath (nth 2 nparsed)) - (abbr (efs-relativize-filename newname - (file-name-directory file))) - (ent (efs-get-file-entry file)) - cmd-string) - (or (and (string-equal (downcase host) (downcase nhost)) - (string-equal user nuser)) - (error "Cannot create hard links between different host user pairs.")) - (if (or (null ent) (stringp (car ent)) - (not (file-directory-p - (file-name-directory newname)))) - (if cont - (efs-call-cont cont 'failed - (format "no such file or directory, %s %s" - file newname) "") - (signal 'file-error - (list "no such file or directory" - file newname))) - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname "make hard link" (numberp ok-if-already-exists))) - ;; Do this last, so that hopefully the host type is known. - (let ((host-type (efs-host-type host))) - (if (or (not (memq host-type efs-unix-host-types)) - (memq host-type efs-dumb-host-types) - (efs-get-host-property host 'exec-failed)) - (error "Unable to make hard links on %s." host))) - (setq cmd-string (concat "ln -f " path " " npath)) - (efs-try-ln - host user - (efs-cont () (host user cmd-string file newname abbr cont nowait) - (efs-send-cmd - host user (list 'quote 'site 'exec cmd-string) - (format "Adding to %s name %s" file abbr) - nil - (efs-cont (result line cont-lines) (host user file newname cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (format "exec: %s" line))) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user err))) - (let ((ent (efs-get-file-entry file))) - (if ent - (let ((nlinks (nthcdr 4 ent)) - new-nlinks) - (and (integerp (car nlinks)) - (setq new-nlinks (1+ (car nlinks))) - (setcar nlinks new-nlinks)) - (apply 'efs-add-file-entry nil newname ent) - (if cont (efs-call-cont cont nil line cont-lines))) - (let ((tbl (efs-get-files-hashtable-entry - (file-name-directory - (directory-file-name newname))))) - (if tbl - (efs-ls - newname - (concat (efs-ls-guess-switches) "d") t t nil - nowait - (efs-cont (listing) (newname cont line cont-lines) - (efs-update-file-info - newname efs-data-buffer-name) - (if cont - (efs-call-cont cont nil line cont-lines)))) - (if cont - (efs-call-cont cont nil line cont-lines)))))))))) - nowait)) - nowait)))) - -(defun efs-add-name-to-file (file newname &optional ok-if-already-exists) - ;; efs version of add-name-to-file - (efs-add-name-to-file-internal file newname ok-if-already-exists)) - - -;;;; ============================================================== -;;;; >9 -;;;; Multiple Host Type Support. -;;;; The initial host type guessing is done in the PWD code below. -;;;; If necessary, further guessing is done in the listing parser. -;;;; ============================================================== - - -;;;; -------------------------------------------------------------- -;;;; Functions for setting and retrieving host types. -;;;; -------------------------------------------------------------- - -(defun efs-add-host (type host) - "Sets the TYPE of the remote host HOST. -The host type is read with completion so this can be used to obtain a -list of supported host types. HOST must be a string, giving the name of -the host, exactly as given in file names. Setting the host type with -this function is preferable to setting the efs-TYPE-host-regexp, as look up -will be faster. Returns TYPE." - ;; Since internet host names are always case-insensitive, we will cache - ;; them in lower case. - (interactive - (list - (intern - (completing-read "Host type: " - (mapcar - (function (lambda (elt) - (list (symbol-name (car elt))))) - efs-host-type-alist) - nil t)) - (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (efs-ftp-path name))))))) - (setq host (downcase host)) - (efs-set-host-property host 'host-type type) - (prog1 - (setq efs-host-cache host - efs-host-type-cache type) - (efs-set-process-host-type host))) - -(defun efs-set-process-host-type (host &optional user) - ;; Sets the value of efs-process-host-type so that it is shown - ;; on the mode-line. - (let ((buff-list (buffer-list))) - (save-excursion - (while buff-list - (set-buffer (car buff-list)) - (if (equal efs-process-host host) - (setq efs-process-host-type (concat " " (symbol-name - (efs-host-type host)))) - (and efs-show-host-type-in-dired - (eq major-mode 'dired-mode) - efs-dired-host-type - (string-equal (downcase - (car (efs-ftp-path default-directory))) - (downcase host)) - (if user - (setq efs-dired-listing-type-string - (concat - " " - (symbol-name (efs-listing-type host user)))) - (or efs-dired-listing-type-string - (setq efs-dired-listing-type-string - (concat " " (symbol-name (efs-host-type host)))))))) - (setq buff-list (cdr buff-list)))))) - -;;;; ---------------------------------------------------------------- -;;;; Functions for setting and retrieving listings types. -;;;; ---------------------------------------------------------------- - -;;; listing types?? -;;; These are distinguished from host types, in case some OS's have two -;;; breeds of listings. e.g. Unix descriptive listings. -;;; We also use this to support the myriad of DOS ftp servers. - - -(defun efs-listing-type (host user) - "Returns the type of listing used on HOST by USER. -If there is no entry for a specialized listing, returns the host type." - (or - (efs-get-host-user-property host user 'listing-type) - (efs-host-type host user))) - -(defun efs-add-listing-type (type host user) - "Interactively adds the specialized listing type TYPE for HOST and USER -to the listing type cache." - (interactive - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (list - (intern - (completing-read "Listing type: " - (mapcar - (function (lambda (elt) - (list (symbol-name elt)))) - efs-listing-types) - nil t)) - (read-string "Host: " - (and name (car (efs-ftp-path name)))) - (read-string "User: " - (and name (nth 1 (efs-ftp-path name))))))) - (efs-set-host-user-property host user 'listing-type type) - (efs-set-process-host-type host user)) - -;;;; -------------------------------------------------------------- -;;;; Auotomagic bug reporting for unrecognized host types. -;;;; -------------------------------------------------------------- - -(defun efs-scream-and-yell-1 (host user) - ;; Internal for efs-scream-and-yell. - (with-output-to-temp-buffer "*Help*" - (princ - (format - "efs is unable to identify the remote host type of %s. - -Please report this as a bug. It would be very helpful -if your bug report contained at least the PWD command -within the *ftp %s@%s* buffer. -If you know them, also send the operating system -and ftp server types of the remote host." host user host))) - (if (y-or-n-p "Would you like to submit a bug report now? ") - (efs-report-bug host user - "Bug occurred during efs-guess-host-type." t))) - -(defun efs-scream-and-yell (host user) - ;; Advertises that something has gone wrong in identifying the host type. - (if (eq (selected-window) (minibuffer-window)) - (efs-abort-recursive-edit-and-then 'efs-scream-and-yell-1 host user) - (efs-scream-and-yell-1 host user) - (error "Unable to identify remote host type"))) - -;;;; -------------------------------------------------------- -;;;; Guess at the host type using PWD syntax. -;;;; -------------------------------------------------------- - -;; host-type path templates. These should match a pwd performed -;; as the first command after connecting. They should be as tight -;; as possible - -(defconst efs-unix-path-template "^/") -(defconst efs-apollo-unix-path-template "^//") -(defconst efs-cms-path-template - (concat - "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?" - "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$\\|" - ;; For the SFS version of CMS - "^[-A-Z0-9]+:[-A-Z0-9$*]+\\.$")) - -(defconst efs-mvs-path-template "^'?[A-Z][0-9][0-9]?[0-9]?[0-9]?[0-9]?\\.'?") - -(defconst efs-guardian-path-template - (concat - "^\\(" - "\\\\[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." - "\\)?" - "\\$[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." - "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?$")) -;; guardian and cms are very close to overlapping (they don't). Be careful. -(defconst efs-vms-path-template - "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$") -(defconst efs-mts-path-template - "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") -(defconst efs-ms-unix-path-template "^[A-Za-z0-9]:/") - -;; Following two are for TI lisp machines. Note that lisp machines -;; do not have a default directory, but only a default pathname against -;; which relative pathnames are merged (Jamie tells me). -(defconst efs-ti-explorer-pwd-line-template - (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") - (token (concat "[^" excluded-chars "]+"))) - (concat "^250 " - token ": " ; host name - token "\\(\\." token "\\)*; " ; directory - "\\(\\*.\\*\\|\\*\\)#\\(\\*\\|>\\)" ; name, ext, version - "$"))) ; "*.*#*" or "*.*#>" or "*#*" or "*#>" or "#*" ... -(defconst efs-ti-twenex-path-template - (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") - (token (concat "[^" excluded-chars "]+"))) - (concat "^" - token ":" ; host name - "<\\(" token "\\)?\\(\\." token "\\)*>" ; directory - "\\(\\*.\\*\\|\\*\\)" ; name and extension - "$"))) - -(defconst efs-tops-20-path-template - "^[-A-Z0-9_$]+:<[-A-Z0-9_$]\\(.[-A-Z0-9_$]+\\)*>$") -(defconst efs-pc-path-template - "^[a-zA-Z0-9]:\\\\\\([-_+=a-zA-Z0-9.]+\\\\\\)*[-_+=a-zA-Z0-9.]*$") -(defconst efs-mpe-path-template - (let ((token (concat "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?" - "[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?"))) - (concat - ;; optional session name - "^\\(" token "\\)?," - ;; username - token "." - ;; account - token "," - ;; group - token "$"))) -(defconst efs-vos-path-template - (let ((token "[][@\\^`{}|~\"$+,---./:_a-zA-Z0-9]+")) - (concat - "%" token ; host - "#" token ; disk - "\\(>" token "\\)+" ; directories - ))) -(defconst efs-netware-path-template "^[-A-Z0-9_][-A-Z0-9_/]*:/") -;; Sometimes netware doesn't return a device to a PWD. Then it will be -;; recognized by the listing parser. - -(defconst efs-nos-ve-path-template "^:[A-Z0-9]") -;; Matches the path for NOS/VE - -(defconst efs-mvs-pwd-line-template - ;; Not sure how the PWD parser will do with empty strings, so treate - ;; this as a line regexp. - "^257 \\([Nn]o prefix defined\\|\"\" is working directory\\)") -(defconst efs-cms-pwd-line-template - "^450 No current working directory defined$") -(defconst efs-tops-20-pwd-line-template - "^500 I never heard of the \\(XPWD\\|PWD\\) command\\. Try HELP\\.$") -(defconst efs-dos:ftp-pwd-line-template - "^250 Current working directory is +") -(defconst efs-coke-pwd-line-template "^257 Current balance \\$[0-9]") - -(defconst efs-super-dumb-unix-tilde-regexp - "^550 /.*: No such file or directory\\.?$") -(defconst efs-cms-knet-tilde-regexp - "^501 Invalid CMS fileid: ~$") - - -;; It might be nice to message users about the host type identified, -;; but there is so much other messaging going on, it would not be -;; seen. No point in slowing things down just so users can read -;; a host type message. - -(defun efs-guess-host-type (host user) - "Guess the host type of HOST. -Does a PWD and examines the directory syntax. The PWD is then cached for use -in file name expansion." - (let ((host-type (efs-host-type host)) - (key (concat host "/" user "/~")) - syst) - (efs-save-match-data - (if (eq host-type 'unknown) - ;; Note that efs-host-type returns unknown as the default. - ;; Since we don't yet know the host-type, we use the default - ;; version of efs-send-pwd. We compensate if necessary - ;; by looking at the entire line of output. - (let* ((result (efs-send-pwd nil host user)) - (dir (car result)) - (line (cdr result))) - (cond - - ;; First sift through process lines to see if we recognize - ;; any pwd errors, or full line messages. - - ;; CMS - ((string-match efs-cms-pwd-line-template line) - (setq host-type (efs-add-host 'cms host) - dir (concat "/" (if (> (length user) 8) - (substring user 0 8) - user) - ".191")) - (message - "Unable to determine a \"home\" CMS minidisk. Assuming %s" - dir) - (sit-for 1)) - - ;; TOPS-20 - ((string-match efs-tops-20-pwd-line-template line) - (setq host-type (efs-add-host 'tops-20 host) - dir (car (efs-send-pwd 'tops-20 host user)))) - - ;; TI-EXPLORER lisp machine. pwd works here, but the output - ;; needs to be specially parsed since spaces separate - ;; hostnames from dirs from filenames. - ((string-match efs-ti-explorer-pwd-line-template line) - (setq host-type (efs-add-host 'ti-explorer host) - dir (substring line 4))) - - ;; FTP Software's DOS Server - ((string-match efs-dos:ftp-pwd-line-template line) - (setq host-type (efs-add-host 'dos host) - dir (substring line (match-end 0))) - (efs-add-listing-type 'dos:ftp host user)) - - ;; MVS - ((string-match efs-mvs-pwd-line-template line) - (setq host-type (efs-add-host 'mvs host) - dir "")) ; "" will convert to /, which is always - ; the mvs home dir. - - ;; COKE - ((string-match efs-coke-pwd-line-template line) - (setq host-type (efs-add-host 'coke host) - dir "/")) - - ;; Try to get tilde. - ((null dir) - (let ((tilde (nth 1 (efs-send-cmd - host user (list 'get "~" "/dev/null"))))) - (cond - ;; super dumb unix - ((string-match efs-super-dumb-unix-tilde-regexp tilde) - (setq dir (car (efs-send-pwd 'super-dumb-unix host user)) - host-type (efs-add-host 'super-dumb-unix host))) - - ;; Try for cms-knet - ((string-match efs-cms-knet-tilde-regexp tilde) - (setq dir (car (efs-send-pwd 'cms-knet host user)) - host-type (efs-add-host 'cms-knet host))) - - ;; We don't know. Scream and yell. - (efs-scream-and-yell host user)))) - - ;; Now look at dir to determine host type - - ;; try for UN*X-y type stuff - ((string-match efs-unix-path-template dir) - (if - ;; Check for apollo, so we know not to short-circuit //. - (string-match efs-apollo-unix-path-template dir) - (progn - (setq host-type (efs-add-host 'apollo-unix host)) - (efs-add-listing-type 'unix:unknown host user)) - ;; could be ka9q, dos-distinct, plus any of the unix breeds, - ;; except apollo. - (if (setq syst (efs-get-syst host user)) - (let ((case-fold-search t)) - (cond - ((string-match "\\bNetware\\b" syst) - (setq host-type (efs-add-host 'netware host))) - ((string-match "^Plan 9" syst) - (setq host-type (efs-add-host 'plan9 host))) - ((string-match "^UNIX" syst) - (setq host-type (efs-add-host 'unix host)) - (efs-add-listing-type 'unix:unknown host user))))))) - - ;; try for VMS - ((string-match efs-vms-path-template dir) - (setq host-type (efs-add-host 'vms host))) - - ;; try for MTS - ((string-match efs-mts-path-template dir) - (setq host-type (efs-add-host 'mts host))) - - ;; try for CMS - ((string-match efs-cms-path-template dir) - (setq host-type (efs-add-host 'cms host))) - - ;; try for Tandem's guardian OS - ((string-match efs-guardian-path-template dir) - (setq host-type (efs-add-host 'guardian host))) - - ;; Try for TOPS-20. pwd doesn't usually work for tops-20 - ;; But who knows??? - ((string-match efs-tops-20-path-template dir) - (setq host-type (efs-add-host 'tops-20 host))) - - ;; Try for DOS or OS/2. - ((string-match efs-pc-path-template dir) - (let ((syst (efs-get-syst host user)) - (case-fold-search t)) - (if (and syst (string-match "^OS/2 " syst)) - (setq host-type (efs-add-host 'os2 host)) - (setq host-type (efs-add-host 'dos host))))) - - ;; try for TI-TWENEX lisp machine - ((string-match efs-ti-twenex-path-template dir) - (setq host-type (efs-add-host 'ti-twenex host))) - - ;; try for MPE - ((string-match efs-mpe-path-template dir) - (setq host-type (efs-add-host 'mpe host))) - - ;; try for VOS - ((string-match efs-vos-path-template dir) - (setq host-type (efs-add-host 'vos host))) - - ;; try for the microsoft server in unix mode - ((string-match efs-ms-unix-path-template dir) - (setq host-type (efs-add-host 'ms-unix host))) - - ;; Netware? - ((string-match efs-netware-path-template dir) - (setq host-type (efs-add-host 'netware host))) - - ;; Try for MVS - ((string-match efs-mvs-path-template dir) - (if (string-match "^'.+'$" dir) - ;; broken MVS PWD quoting - (setq dir (substring dir 1 -1))) - (setq host-type (efs-add-host 'mvs host))) - - ;; Try for NOS/VE - ((string-match efs-nos-ve-path-template dir) - (setq host-type (efs-add-host 'nos-ve host))) - - ;; We don't know. Scream and yell. - (t - (efs-scream-and-yell host user))) - - ;; Now that we have done a pwd, might as well put it in - ;; the expand-dir hashtable. - (if dir - (efs-put-hash-entry - key - (efs-internal-directory-file-name - (efs-fix-path host-type dir 'reverse)) - efs-expand-dir-hashtable - (memq host-type efs-case-insensitive-host-types)))) - - ;; host-type has been identified by regexp, set the mode-line. - (efs-set-process-host-type host user) - - ;; Some special cases, where we need to store the cwd on login. - (if (not (efs-hash-entry-exists-p - key efs-expand-dir-hashtable)) - (cond - ;; CMS: We will be doing cd's, so we'd better make sure that - ;; we know where home is. - ((eq host-type 'cms) - (let* ((res (efs-send-pwd 'cms host user)) - (dir (car res)) - (line (cdr res))) - (if (and dir (not (string-match - efs-cms-pwd-line-template line))) - (setq dir (concat "/" dir)) - (setq dir (concat "/" (if (> (length user) 8) - (substring user 0 8) - user) - ".191")) - (message - "Unable to determine a \"home\" CMS minidisk. Assuming %s" - dir)) - (efs-put-hash-entry - key dir efs-expand-dir-hashtable - (memq 'cms efs-case-insensitive-host-types)))) - ;; MVS: pwd doesn't work in the root directory, so we stuff this - ;; into the hashtable manually. - ((eq host-type 'mvs) - (efs-put-hash-entry key "/" efs-expand-dir-hashtable)) - )))))) - - -;;;; ----------------------------------------------------------- -;;;; efs-autoloads -;;;; These provide the entry points for the non-unix packages. -;;;; ----------------------------------------------------------- - -(efs-autoload 'efs-fix-path vms "efs-vms") -(efs-autoload 'efs-fix-path mts "efs-mts") -(efs-autoload 'efs-fix-path cms "efs-cms") -(efs-autoload 'efs-fix-path ti-explorer "efs-ti-explorer") -(efs-autoload 'efs-fix-path ti-twenex "efs-ti-twenex") -(efs-autoload 'efs-fix-path dos "efs-pc") -(efs-autoload 'efs-fix-path mvs "efs-mvs") -(efs-autoload 'efs-fix-path tops-20 "efs-tops-20") -(efs-autoload 'efs-fix-path mpe "efs-mpe") -(efs-autoload 'efs-fix-path os2 "efs-pc") -(efs-autoload 'efs-fix-path vos "efs-vos") -(efs-autoload 'efs-fix-path ms-unix "efs-ms-unix") -(efs-autoload 'efs-fix-path netware "efs-netware") -(efs-autoload 'efs-fix-path cms-knet "efs-cms-knet") -(efs-autoload 'efs-fix-path guardian "efs-guardian") -(efs-autoload 'efs-fix-path nos-ve "efs-nos-ve") - -(efs-autoload 'efs-fix-dir-path vms "efs-vms") -(efs-autoload 'efs-fix-dir-path mts "efs-mts") -(efs-autoload 'efs-fix-dir-path cms "efs-cms") -(efs-autoload 'efs-fix-dir-path ti-explorer "efs-ti-explorer") -(efs-autoload 'efs-fix-dir-path ti-twenex "efs-ti-twenex") -(efs-autoload 'efs-fix-dir-path dos "efs-pc") -(efs-autoload 'efs-fix-dir-path mvs "efs-mvs") -(efs-autoload 'efs-fix-dir-path tops-20 "efs-tops-20") -(efs-autoload 'efs-fix-dir-path mpe "efs-mpe") -(efs-autoload 'efs-fix-dir-path os2 "efs-pc") -(efs-autoload 'efs-fix-dir-path vos "efs-vos") -(efs-autoload 'efs-fix-dir-path hell "efs-hell") -(efs-autoload 'efs-fix-dir-path ms-unix "efs-ms-unix") -(efs-autoload 'efs-fix-dir-path netware "efs-netware") -(efs-autoload 'efs-fix-dir-path plan9 "efs-plan9") -(efs-autoload 'efs-fix-dir-path cms-knet "efs-cms-knet") -(efs-autoload 'efs-fix-dir-path guardian "efs-guardian") -(efs-autoload 'efs-fix-dir-path nos-ve "efs-nos-ve") -(efs-autoload 'efs-fix-dir-path coke "efs-coke") - -;; A few need to autoload a pwd function -(efs-autoload 'efs-send-pwd tops-20 "efs-tops-20") -(efs-autoload 'efs-send-pwd cms-knet "efs-cms-knet") -(efs-autoload 'efs-send-pwd ti-explorer "efs-ti-explorer") -(efs-autoload 'efs-send-pwd hell "efs-hell") -(efs-autoload 'efs-send-pwd mvs "efs-mvs") -(efs-autoload 'efs-send-pwd coke "efs-coke") - -;; A few packages are loaded by the listing parser. -(efs-autoload 'efs-parse-listing ka9q "efs-ka9q") -(efs-autoload 'efs-parse-listing unix:dl "efs-dl") -(efs-autoload 'efs-parse-listing dos-distinct "efs-dos-distinct") -(efs-autoload 'efs-parse-listing hell "efs-hell") -(efs-autoload 'efs-parse-listing netware "efs-netware") - -;; Packages that need to autoload for child-lookup -(efs-autoload 'efs-allow-child-lookup plan9 "efs-plan9") -(efs-autoload 'efs-allow-child-lookup coke "efs-coke") - -;; Packages that need to autoload for file-exists-p and file-directory-p -(efs-autoload 'efs-internal-file-exists-p guardian "efs-guardian") -(efs-autoload 'efs-internal-file-directory-p guardian "efs-guardian") - - - -;;;; ============================================================ -;;;; >10 -;;;; Attaching onto the appropriate Emacs version -;;;; ============================================================ - -;;;; ------------------------------------------------------------------- -;;;; Connect to various hooks. -;;;; ------------------------------------------------------------------- - -(or (memq 'efs-set-buffer-mode find-file-hooks) - (setq find-file-hooks - (cons 'efs-set-buffer-mode find-file-hooks))) - -;;; We are using our own dired.el, so this doesn't depend on Emacs flavour. - -(if (featurep 'dired) - (require 'efs-dired) - (add-hook 'dired-load-hook (function - (lambda () - (require 'efs-dired))))) - -;;;; ------------------------------------------------------------ -;;;; Add to minor-mode-alist. -;;;; ------------------------------------------------------------ - -(or (assq 'efs-process-host-type minor-mode-alist) - (if (assq 'dired-sort-mode minor-mode-alist) - (let ((our-list - (nconc - (delq nil - (list (assq 'dired-sort-mode minor-mode-alist) - (assq 'dired-subdir-omit minor-mode-alist) - (assq 'dired-marker-stack minor-mode-alist))) - (list '(efs-process-host-type efs-process-host-type) - '(efs-dired-listing-type - efs-dired-listing-type-string)))) - (old-list (delq - (assq 'efs-process-host-type minor-mode-alist) - (delq - (assq 'efs-dired-listing-type minor-mode-alist) - minor-mode-alist)))) - (setq minor-mode-alist nil) - (while old-list - (or (assq (car (car old-list)) our-list) - (setq minor-mode-alist (nconc minor-mode-alist - (list (car old-list))))) - (setq old-list (cdr old-list))) - (setq minor-mode-alist (nconc our-list minor-mode-alist))) - (setq minor-mode-alist - (nconc - (list '(efs-process-host-type efs-process-host-type) - '(efs-dired-listing-type efs-dired-listing-type-string)) - minor-mode-alist)))) - -;;;; ------------------------------------------------------------ -;;;; File name handlers -;;;; ------------------------------------------------------------ - -;;;###autoload -(defun efs-file-handler-function (operation &rest args) - "Function to call special file handlers for remote files." - (let ((handler (and (if (boundp 'allow-remote-paths) - allow-remote-paths - t) - (get operation 'efs)))) - (if handler - (apply handler args) - (let ((inhibit-file-name-handlers - (cons 'efs-file-handler-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args))))) - -(defun efs-sifn-handler-function (operation &rest args) - ;; Handler function for substitute-in-file-name - (if (and (if (boundp 'allow-remote-paths) - allow-remote-paths - t) - (eq operation 'substitute-in-file-name)) - (apply 'efs-substitute-in-file-name args) - (let ((inhibit-file-name-handlers - (cons 'efs-sifn-handler-function - (and (eq operation inhibit-file-name-operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args)))) - -;; Yes, this is what it looks like. I'm defining the handler to run our -;; version whenever there is an environment variable. - -(defvar efs-path-sifn-regexp "\\(^\\|[^$]\\)\\(\\$\\$\\)*\\$[{a-zA-Z0-9]" - "Regexp to match environment variables in file names.") - -(or (assoc efs-path-sifn-regexp file-name-handler-alist) - (nconc file-name-handler-alist - (list - (cons efs-path-sifn-regexp - 'efs-sifn-handler-function)))) - -;;;; ------------------------------------------------------------ -;;;; Necessary overloads. -;;;; ------------------------------------------------------------ - -;;; The following functions are overloaded, instead of extended via -;;; the file-name-handler-alist. For various reasons, the -;;; file-name-handler-alist doesn't work for them. It would be nice if -;;; this list could be shortened in the future. - -;; File name exansion. It is not until _after_ a file name has been -;; expanded that it is reasonable to test it for a file name handler. -(efs-overwrite-fn "efs" 'expand-file-name) - -;; Loading lisp files. The problem with using the file-name-handler-alist -;; here is that we don't know what is to be handled, until after searching -;; the load-path. The solution is to change the C code for Fload. -;; A patch to do this has been written by Jay Adams . -(efs-overwrite-fn "efs" 'load) -(efs-overwrite-fn "efs" 'require) - -;;;; ------------------------------------------------------------ -;;;; Install the file handlers for efs-file-handler-function. -;;;; ------------------------------------------------------------ - -;; I/O -(put 'insert-file-contents 'efs 'efs-insert-file-contents) -(put 'write-region 'efs 'efs-write-region) -(put 'directory-files 'efs 'efs-directory-files) -(put 'list-directory 'efs 'efs-list-directory) -(put 'insert-directory 'efs 'efs-insert-directory) -(put 'recover-file 'efs 'efs-recover-file) -;; file properties -(put 'file-directory-p 'efs 'efs-file-directory-p) -(put 'file-writable-p 'efs 'efs-file-writable-p) -(put 'file-readable-p 'efs 'efs-file-readable-p) -(put 'file-executable-p 'efs 'efs-file-executable-p) -(put 'file-symlink-p 'efs 'efs-file-symlink-p) -(put 'file-attributes 'efs 'efs-file-attributes) -(put 'file-exists-p 'efs 'efs-file-exists-p) -(put 'file-accessible-directory-p 'efs 'efs-file-accessible-directory-p) -;; manipulating file names -(put 'file-name-directory 'efs 'efs-file-name-directory) -(put 'file-name-nondirectory 'efs 'efs-file-name-nondirectory) -(put 'file-name-as-directory 'efs 'efs-file-name-as-directory) -(put 'directory-file-name 'efs 'efs-directory-file-name) -(put 'abbreviate-file-name 'efs 'efs-abbreviate-file-name) -(put 'file-name-sans-versions 'efs 'efs-file-name-sans-versions) -(put 'unhandled-file-name-directory 'efs 'efs-unhandled-file-name-directory) -(put 'diff-latest-backup-file 'efs 'efs-diff-latest-backup-file) -(put 'file-truename 'efs 'efs-file-truename) -;; modtimes -(put 'verify-visited-file-modtime 'efs 'efs-verify-visited-file-modtime) -(put 'file-newer-than-file-p 'efs 'efs-file-newer-than-file-p) -(put 'set-visited-file-modtime 'efs 'efs-set-visited-file-modtime) -;; file modes -(put 'set-file-modes 'efs 'efs-set-file-modes) -(put 'file-modes 'efs 'efs-file-modes) -;; buffers -(put 'backup-buffer 'efs 'efs-backup-buffer) -(put 'get-file-buffer 'efs 'efs-get-file-buffer) -(put 'create-file-buffer 'efs 'efs-create-file-buffer) -;; creating and removing files -(put 'delete-file 'efs 'efs-delete-file) -(put 'copy-file 'efs 'efs-copy-file) -(put 'rename-file 'efs 'efs-rename-file) -(put 'file-local-copy 'efs 'efs-file-local-copy) -(put 'make-directory-internal 'efs 'efs-make-directory-internal) -(put 'delete-directory 'efs 'efs-delete-directory) -(put 'add-name-to-file 'efs 'efs-add-name-to-file) -(put 'make-symbolic-link 'efs 'efs-make-symbolic-link) -;; file name completion -(put 'file-name-completion 'efs 'efs-file-name-completion) -(put 'file-name-all-completions 'efs 'efs-file-name-all-completions) - -;;;; ------------------------------------------------------------ -;;;; Finally run any load-hooks. -;;;; ------------------------------------------------------------ - -(run-hooks 'efs-load-hook) - -;;; end of efs.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/efs/fixup.el --- a/lisp/efs/fixup.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: fixup.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Fix up the load path for batch byte compilation of efs. -;; Author: Andy Norman, Dawn -;; Created: Sat Jan 30 00:21:33 1993 -;; Modified: Fri Sep 16 20:01:50 1994 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(setq load-path - (append (list (substitute-in-file-name "$CWD") - (substitute-in-file-name "$BDIR") - (substitute-in-file-name "$VMDIR") - ) - load-path)) - -(setq byte-compile-warnings t) - -;; If the V18 btye-compiler is being used, this won't be around, so don't -;; complain if we can't find it. -(load "bytecomp-runtime" t t) - -(load "bytecomp" nil t) - -;; It seems efs causes the standard byte compiler some grief here. -(setq max-lisp-eval-depth (* 2 max-lisp-eval-depth)) - -;; If the user has the standard dired loaded, having dired -;; featurep will cause efs-dired.el to attempt to do overloads. -(delq 'dired features) - -;;; end of fixup.el diff -r d3e9274cbc4e -r e45d5e7c476e lisp/egg/egg-leim.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/egg/egg-leim.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,52 @@ +;;; egg-leim.el --- Egg-related code for LEIM +;; Copyright (C) 1997 Stephen Turnbull +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Shamelessly ripped off from +;; +;; skk-leim.el --- SKK related code for LEIM +;; Copyright (C) 1997 +;; Murata Shuuichirou +;; +;; Author: Stephen Turnbull +;; Version: egg-leim.el,v 1.1 1997/10/27 09:59:23 steve Exp steve +;; Keywords: japanese, input method, LEIM +;; Last Modified: 1997/10/27 09:59:23 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either versions 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs, see the file COPYING. If not, write to the Free +;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + +;;; TODO +;; +;; Add pointers to Egg documentation in LEIM format + +(defun egg-activate (&optional name) + (if (featurep 'wnn) + (require 'egg) + (error "Wnn is not built into this XEmacs")) + (setq inactivate-current-input-method-function 'egg-inactivate) + (toggle-egg-mode)) + +(defun egg-inactivate () + (cond (egg:*mode-on* (toggle-egg-mode)))) + +(register-input-method + 'japanese-egg-wnn "Japanese" + 'egg-activate nil + "EGG - an interface to the Wnn kana to kanji conversion program" ) + +(provide 'egg-leim) + +;;; egg-leim.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/egg/egg.el --- a/lisp/egg/egg.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/egg/egg.el Mon Aug 13 10:03:52 2007 +0200 @@ -2378,7 +2378,12 @@ ;;; Currently entries C-\ and C-^ at global-map are undefined. ;;; -(define-key global-map "\C-\\" 'toggle-egg-mode) +;; Make this no-op if LEIM interface is used. +(cond ((featurep 'egg-leim) t) + (t (define-key global-map "\C-\\" 'toggle-egg-mode)) ) +;; #### Should hide bindings like this, too? However, `convert-region' +;; probably isn't going to be a LEIM feature, it's really pretty +;; Japanese and Korean specific. (define-key global-map "\C-x " 'henkan-region) ;; 92.3.16 by K.Handa diff -r d3e9274cbc4e -r e45d5e7c476e lisp/emulators/crisp.el --- a/lisp/emulators/crisp.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/emulators/crisp.el Mon Aug 13 10:03:52 2007 +0200 @@ -2,7 +2,7 @@ ;; Author: Gary D. Foster ;; Created: 01 Mar 1996 -;; Version: 1.20 +;; Version: 1.21 ;; Keywords: emulations brief crisp ;; X-Modified-by: ;; crisp.el,v @@ -111,15 +111,9 @@ (defvar crisp-load-hook nil "Hooks to run after loading the CRiSP emulator package.") -(defconst crisp-version "crisp.el release 1.1/1.20" +(defconst crisp-version "crisp.el release 1.1/1.21" "The release number and RCS version for the CRiSP emulator.") -(if (string-match "XEmacs\\Lucid" emacs-version) - (add-minor-mode 'crisp-mode-enabled crisp-mode-modeline-string) - (or (assq 'crisp-mode-enabled minor-mode-alist) - (setq minor-mode-alist - (cons '(crisp-mode-enabled crisp-mode-modeline-string) minor-mode-alist)))) - ;; and now the keymap defines (define-key crisp-mode-map [(f1)] 'other-window) @@ -256,6 +250,13 @@ ((eq crisp-mode-enabled 'nil) (use-global-map crisp-mode-original-keymap)))) +(if (string-match "\\(XEmacs\\|Lucid\\)" emacs-version) + (add-minor-mode 'crisp-mode-enabled 'crisp-mode-modeline-string + nil nil 'crisp-mode) + (or (assq 'crisp-mode-enabled minor-mode-alist) + (setq minor-mode-alist + (cons '(crisp-mode-enabled crisp-mode-modeline-string) minor-mode-alist)))) + (provide 'crisp) ;;; crisp.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/emulators/custom-load.el --- a/lisp/emulators/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/emulators/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,10 +1,9 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Oct 4 18:11:29 1997 ;;; Code: -(custom-put 'emulations 'custom-loads '("crisp")) -(custom-put 'emulations-crisp 'custom-loads '("crisp")) +(custom-add-loads 'emulations '("crisp")) +(custom-add-loads 'emulations-crisp '("crisp")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/emulators/edt-mapper.el --- a/lisp/emulators/edt-mapper.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/emulators/edt-mapper.el Mon Aug 13 10:03:52 2007 +0200 @@ -88,8 +88,8 @@ ;;; ;;; Decide whether we're running GNU or Lucid emacs. ;;; -(defconst edt-lucid-emacs19-p (string-match "Lucid" emacs-version) - "Non-NIL if we are running Lucid Emacs version 19.") +(defconst edt-lucid-emacs19-p (string-match "XEmacs" emacs-version) + "Non-NIL if we are running XEmacs.") ;;; diff -r d3e9274cbc4e -r e45d5e7c476e lisp/eterm/custom-load.el --- a/lisp/eterm/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/eterm/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,12 +1,11 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Oct 4 18:11:31 1997 ;;; Code: -(custom-put 'shell 'custom-loads '("term")) -(custom-put 'term 'custom-loads '("term")) -(custom-put 'processes 'custom-loads '("term")) -(custom-put 'unix 'custom-loads '("term")) +(custom-add-loads 'shell '("term")) +(custom-add-loads 'term '("term")) +(custom-add-loads 'processes '("term")) +(custom-add-loads 'unix '("term")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/NeXTify.el --- a/lisp/games/NeXTify.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -;;; NeXTify.el --- Character insertion variation - -;; Copyright status unknown - -;; Author: Jamie Zawinski -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not in FSF - -;;; Commentary: - -;;; Code: - -(defun SeLF-insert-command (arg) - "Insert the character you TyPE. -Whichever character you TyPE to run ThIS command is inserted." - (interactive "p") - (let ((p (point)) - (case-fold-search nil)) - (self-insert-command arg) - (save-excursion - (goto-char p) - (skip-chars-backward " \t\r\n") - (if (condition-case () (forward-char -4) (error t)) - nil - (if (looking-at "\\<[A-Za-z][a-z][a-z][a-z][^A-Za-z]") - (progn - (insert (upcase (following-char))) (delete-char 1) - (forward-char 1) - (insert (upcase (following-char))) (delete-char 1) - (insert (upcase (following-char))) (delete-char 1))))))) - -(define-key text-mode-map " " 'SeLF-insert-command) -(define-key text-mode-map "," 'SeLF-insert-command) -(define-key text-mode-map "." 'SeLF-insert-command) -(define-key text-mode-map "!" 'SeLF-insert-command) -(define-key text-mode-map "-" 'SeLF-insert-command) -(define-key text-mode-map "_" 'SeLF-insert-command) -(define-key text-mode-map ";" 'SeLF-insert-command) -(define-key text-mode-map ":" 'SeLF-insert-command) - -;;; NeXTify.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/auto-autoloads.el --- a/lisp/games/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,343 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'games-autoloads) (error "Already loaded")) - -;;;### (autoloads (blackbox) "blackbox" "games/blackbox.el") - -(autoload 'blackbox "blackbox" "\ -Play blackbox. Optional prefix argument is the number of balls; -the default is 4. - -What is blackbox? - -Blackbox is a game of hide and seek played on an 8 by 8 grid (the -Blackbox). Your opponent (Emacs, in this case) has hidden several -balls (usually 4) within this box. By shooting rays into the box and -observing where they emerge it is possible to deduce the positions of -the hidden balls. The fewer rays you use to find the balls, the lower -your score. - -Overview of play: - -\\To play blackbox, type \\[blackbox]. An optional prefix argument -specifies the number of balls to be hidden in the box; the default is -four. - -The cursor can be moved around the box with the standard cursor -movement keys. - -To shoot a ray, move the cursor to the edge of the box and press SPC. -The result will be determined and the playfield updated. - -You may place or remove balls in the box by moving the cursor into the -box and pressing \\[bb-romp]. - -When you think the configuration of balls you have placed is correct, -press \\[bb-done]. You will be informed whether you are correct or -not, and be given your score. Your score is the number of letters and -numbers around the outside of the box plus five for each incorrectly -placed ball. If you placed any balls incorrectly, they will be -indicated with `x', and their actual positions indicated with `o'. - -Details: - -There are three possible outcomes for each ray you send into the box: - - Detour: the ray is deflected and emerges somewhere other than - where you sent it in. On the playfield, detours are - denoted by matching pairs of numbers -- one where the - ray went in, and the other where it came out. - - Reflection: the ray is reflected and emerges in the same place - it was sent in. On the playfield, reflections are - denoted by the letter `R'. - - Hit: the ray strikes a ball directly and is absorbed. It does - not emerge from the box. On the playfield, hits are - denoted by the letter `H'. - -The rules for how balls deflect rays are simple and are best shown by -example. - -As a ray approaches a ball it is deflected ninety degrees. Rays can -be deflected multiple times. In the diagrams below, the dashes -represent empty box locations and the letter `O' represents a ball. -The entrance and exit points of each ray are marked with numbers as -described under \"Detour\" above. Note that the entrance and exit -points are always interchangeable. `*' denotes the path taken by the -ray. - -Note carefully the relative positions of the ball and the ninety -degree deflection it causes. - - 1 - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - -1 * * - - - - - - - - - - - - - - - O - - - - O - - - - O - - - - - - - O - - - - - - - * * * * - - - - - - - - - - - - - - * * * * * 2 3 * * * - - * - - - - - - - - - - - - - - * - - - - - - - O - * - - - - - - - - - - - - - - * - - - - - - - - * * - - - - - - - - - - - - - - * - - - - - - - - * - O - - 2 3 - -As mentioned above, a reflection occurs when a ray emerges from the same point -it was sent in. This can happen in several ways: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - O - O - - - - - - - - - - - -R * * * * - - - - - - - * - - - - O - - - - - - - - - - - - O - - - - - - * - - - - R - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - R * * * * - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - -In the first example, the ray is deflected downwards by the upper -ball, then left by the lower ball, and finally retraces its path to -its point of origin. The second example is similar. The third -example is a bit anomalous but can be rationalized by realizing the -ray never gets a chance to get into the box. Alternatively, the ray -can be thought of as being deflected downwards and immediately -emerging from the box. - -A hit occurs when a ray runs straight into a ball: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - - - - - O - - - H * * * * - - - - - - - - - - - - - H * * * * O - - - - - - * - - - - - - - - - - - - - - - - - O - - - - - - O - - - - -H * * * O - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Be sure to compare the second example of a hit with the first example of -a reflection." t nil) - -;;;*** - -;;;### (autoloads (conx-load conx conx-region conx-buffer) "conx" "games/conx.el") - -(autoload 'conx-buffer "conx" "\ -Absorb the text in the current buffer into the tree." t nil) - -(autoload 'conx-region "conx" "\ -Absorb the text in the current region into the tree." t nil) - -(autoload 'conx "conx" "\ -Generate some random sentences in the *conx* buffer." t nil) - -(autoload 'conx-load "conx" "\ -Load in a CONX database written by the \\[conx-save] command. -This clears the database currently in memory." t nil) - -;;;*** - -;;;### (autoloads (shuffle-vector cookie-snarf cookie-insert cookie) "cookie1" "games/cookie1.el") - -(autoload 'cookie "cookie1" "\ -Return a random phrase from PHRASE-FILE. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." nil nil) - -(autoload 'cookie-insert "cookie1" "\ -Insert random phrases from PHRASE-FILE; COUNT of them. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." nil nil) - -(autoload 'cookie-snarf "cookie1" "\ -Reads in the PHRASE-FILE, returns it as a vector of strings. -Emit STARTMSG and ENDMSG before and after. Caches the result; second -and subsequent calls on the same file won't go to disk." nil nil) - -(autoload 'shuffle-vector "cookie1" "\ -Randomly permute the elements of VECTOR (all permutations equally likely)" nil nil) - -;;;*** - -;;;### (autoloads (decipher-mode decipher) "decipher" "games/decipher.el") - -(autoload 'decipher "decipher" "\ -Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." t nil) - -(autoload 'decipher-mode "decipher" "\ -Major mode for decrypting monoalphabetic substitution ciphers. -Lower-case letters enter plaintext. -Upper-case letters are commands. - -The buffer is made read-only so that normal Emacs commands cannot -modify it. - -The most useful commands are: -\\ -\\[decipher-digram-list] Display a list of all digrams & their frequency -\\[decipher-frequency-count] Display the frequency of each ciphertext letter -\\[decipher-adjacency-list] Show adjacency list for current letter (lists letters appearing next to it) -\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) -\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" t nil) - -;;;*** - -;;;### (autoloads (dissociated-press) "dissociate" "games/dissociate.el") - -(autoload 'dissociated-press "dissociate" "\ -Dissociate the text of the current buffer. -Output goes in buffer named *Dissociation*, -which is redisplayed each time text is added to it. -Every so often the user must say whether to continue. -If ARG is positive, require ARG chars of continuity. -If ARG is negative, require -ARG words of continuity. -Default is 2." t nil) - -;;;*** - -;;;### (autoloads (doctor) "doctor" "games/doctor.el") - -(autoload 'doctor "doctor" "\ -Switch to *doctor* buffer and start giving psychotherapy." t nil) - -;;;*** - -;;;### (autoloads (dunnet) "dunnet" "games/dunnet.el") - -(autoload 'dunnet "dunnet" "\ -Switch to *dungeon* buffer and start game." t nil) - -;;;*** - -;;;### (autoloads (flame) "flame" "games/flame.el") - -(autoload 'flame "flame" "\ -Generate ARG (default 1) sentences of half-crazed gibberish." t nil) - -;;;*** - -;;;### (autoloads (gomoku) "gomoku" "games/gomoku.el") - -(autoload 'gomoku "gomoku" "\ -Start a Gomoku game between you and Emacs. -If a game is in progress, this command allow you to resume it. -If optional arguments N and M are given, an N by M board is used. - -You and Emacs play in turn by marking a free square. You mark it with X -and Emacs marks it with O. The winner is the first to get five contiguous -marks horizontally, vertically or in diagonal. -You play by moving the cursor over the square you choose and hitting -\\\\[gomoku-human-plays]. -Use \\[describe-mode] for more info." t nil) - -;;;*** - -;;;### (autoloads (hanoi) "hanoi" "games/hanoi.el") - -(autoload 'hanoi "hanoi" "\ -Towers of Hanoi diversion. Argument is number of rings." t nil) - -;;;*** - -;;;### (autoloads (life) "life" "games/life.el") - -(autoload 'life "life" "\ -Run Conway's Life simulation. -The starting pattern is randomly selected. Prefix arg (optional first -arg non-nil from a program) is the number of seconds to sleep between -generations (this defaults to 1)." t nil) - -;;;*** - -;;;### (autoloads (mpuz) "mpuz" "games/mpuz.el") - -(autoload 'mpuz "mpuz" "\ -Multiplication puzzle with GNU Emacs." t nil) - -;;;*** - -;;;### (autoloads (snarf-spooks spook) "spook" "games/spook.el") - -(autoload 'spook "spook" "\ -Adds that special touch of class to your outgoing mail." t nil) - -(autoload 'snarf-spooks "spook" "\ -Return a vector containing the lines from `spook-phrases-file'." nil nil) - -;;;*** - -;;;### (autoloads (tetris) "tetris" "games/tetris.el") - -(autoload 'tetris "tetris" "\ -Tetris - -Shapes drop from the top of the screen, and the user has to move and -rotate the shape to fit in with those at the bottom of the screen so -as to form complete rows. - -tetris-mode keybindings: - \\ -\\[tetris-start-game] Starts a new game of Tetris -\\[tetris-end-game] Terminates the current game -\\[tetris-move-left] Moves the shape one square to the left -\\[tetris-move-right] Moves the shape one square to the right -\\[tetris-rotate-prev] Rotates the shape clockwise -\\[tetris-rotate-next] Rotates the shape anticlockwise -\\[tetris-move-bottom] Drops the shape to the bottom of the playing area - -" t nil) - -;;;*** - -;;;### (autoloads (xmine-mode) "xmine" "games/xmine.el") - -(autoload 'xmine-mode "xmine" "\ -A mode for playing the well known mine searching game. - - `\\\\[xmine-activate-function-button1]' or `\\\\[xmine-key-action1]' unhides a tile, - `\\\\[xmine-activate-function-button2]' or `\\\\[xmine-key-action2]' unhides all neighbours of a tile, - `\\\\[xmine-activate-function-button3]' or `\\\\[xmine-key-action3]' (un)flagges a tile to hold a mine. - - `\\[xmine-key-new]' starts a new game. - `\\[xmine-key-quit]' ends a game. - -All keybindings (with alternatives) currently in effect: - \\{xmine-keymap} - -The rules are quite easy: You start by unhiding (random) tiles. An unhidden -tile showing a number tells you something about the number of mines in it's -neighborhood, where the neighborhood are all 8 tiles (or less if it's -at a border) around the tile. - -E.g. a \"1\" shows you that there is only one mine in the neighborhood of -this tile. Empty tiles have no mines around them, and empty tiles in -the neighborhood of another empty tile are all automatically unhidden -if you unhide one of them. You need to find a strategy to use the -information you have from the numbers to \"flag\" the tiles with mines -under them and unhide all other tiles. If you correctly made this -without accidently unhiding a mine, you've won. - -If you are sure you have correctly flagged all mines around a unhidden tile, -you can use Button-2 or \\[xmine-key-action2] on it to unhide all it's -neighbors. But beware: If you made a mistake by flagging the wrong mines, -you'll blow up! - -Have Fun." t nil) - -(fset 'xmine 'xmine-mode) - -;;;*** - -;;;### (autoloads (psychoanalyze-pinhead apropos-zippy insert-zippyism yow) "yow" "games/yow.el") - -(autoload 'yow "yow" "\ -Return or display a random Zippy quotation. With prefix arg, insert it." t nil) - -(autoload 'insert-zippyism "yow" "\ -Prompt with completion for a known Zippy quotation, and insert it at point." t nil) - -(autoload 'apropos-zippy "yow" "\ -Return a list of all Zippy quotes matching REGEXP. -If called interactively, display a list of matches." t nil) - -(autoload 'psychoanalyze-pinhead "yow" "\ -Zippy goes to the analyst." t nil) - -;;;*** - -(provide 'games-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/blackbox.el --- a/lisp/games/blackbox.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,437 +0,0 @@ -;;; blackbox.el --- blackbox game in Emacs Lisp - -;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. - -;; Author: F. Thomas May -;; Adapted-By: ESR -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; by F. Thomas May -;; doc comment by Root Boy Jim , 27 Apr 89 -;; interface improvements by ESR, Dec 5 1991. - -;; The object of the game is to find four hidden balls by shooting rays -;; into the black box. There are four possibilities: 1) the ray will -;; pass thru the box undisturbed, 2) it will hit a ball and be absorbed, -;; 3) it will be deflected and exit the box, or 4) be deflected immediately, -;; not even being allowed entry into the box. - -;; The strange part is the method of deflection. It seems that rays will -;; not pass next to a ball, and change direction at right angles to avoid it. -;; -;; R 3 -;; 1 - - - - - - - - 1 -;; - - - - - - - - -;; - O - - - - - - 3 -;; 2 - - - - O - O - -;; 4 - - - - - - - - -;; 5 - - - - - - - - 5 -;; - - - - - - - - R -;; H - - - - - - - O -;; 2 H 4 H -;; -;; Rays which enter and exit are numbered. You can see that rays 1 & 5 pass -;; thru the box undisturbed. Ray 2 is deflected by the northwesternmost -;; ball. Likewise rays 3 and 4. Rays which hit balls and are absorbed are -;; marked with H. The bottom of the left and the right of the bottom hit -;; the southeastern ball directly. Rays may also hit balls after being -;; reflected. Consider the H on the bottom next to the 4. It bounces off -;; the NW-ern most ball and hits the central ball. A ray shot from above -;; the right side 5 would hit the SE-ern most ball. The R beneath the 5 -;; is because the ball is returned instantly. It is not allowed into -;; the box if it would reflect immediately. The R on the top is a more -;; leisurely return. Both central balls would tend to deflect it east -;; or west, but it cannot go either way, so it just retreats. - -;; At the end of the game, if you've placed guesses for as many balls as -;; there are in the box, the true board position will be revealed. Each -;; `x' is an incorrect guess of yours;; `o' is the true location of a ball. - -;;; Code: - -(defvar blackbox-mode-map nil "") - -(if blackbox-mode-map - () - (setq blackbox-mode-map (make-keymap)) - (suppress-keymap blackbox-mode-map t) - (define-key blackbox-mode-map "\C-f" 'bb-right) - (define-key blackbox-mode-map [right] 'bb-right) - (define-key blackbox-mode-map "\C-b" 'bb-left) - (define-key blackbox-mode-map [left] 'bb-left) - (define-key blackbox-mode-map "\C-p" 'bb-up) - (define-key blackbox-mode-map [up] 'bb-up) - (define-key blackbox-mode-map "\C-n" 'bb-down) - (define-key blackbox-mode-map [down] 'bb-down) - (define-key blackbox-mode-map "\C-e" 'bb-eol) - (define-key blackbox-mode-map "\C-a" 'bb-bol) - (define-key blackbox-mode-map " " 'bb-romp) - (define-key blackbox-mode-map [insert] 'bb-romp) - (define-key blackbox-mode-map "\C-m" 'bb-done) - (define-key blackbox-mode-map [kp-enter] 'bb-done)) - -;; Blackbox mode is suitable only for specially formatted data. -(put 'blackbox-mode 'mode-class 'special) - -(defvar bb-board) -(defvar bb-balls-placed) -(defvar bb-x) -(defvar bb-y) -(defvar bb-score) -(defvar bb-detour-count) - -(defun blackbox-mode () - "Major mode for playing blackbox. To learn how to play blackbox, -see the documentation for function `blackbox'. - -The usual mnemonic keys move the cursor around the box. -\\\\[bb-bol] and \\[bb-eol] move to the beginning and end of line, respectively. - -\\[bb-romp] -- send in a ray from point, or toggle a ball at point -\\[bb-done] -- end game and get score -" - (interactive) - (kill-all-local-variables) - (use-local-map blackbox-mode-map) - (setq truncate-lines t) - (setq major-mode 'blackbox-mode) - (setq mode-name "Blackbox")) - -;;;###autoload -(defun blackbox (num) - "Play blackbox. Optional prefix argument is the number of balls; -the default is 4. - -What is blackbox? - -Blackbox is a game of hide and seek played on an 8 by 8 grid (the -Blackbox). Your opponent (Emacs, in this case) has hidden several -balls (usually 4) within this box. By shooting rays into the box and -observing where they emerge it is possible to deduce the positions of -the hidden balls. The fewer rays you use to find the balls, the lower -your score. - -Overview of play: - -\\\ -To play blackbox, type \\[blackbox]. An optional prefix argument -specifies the number of balls to be hidden in the box; the default is -four. - -The cursor can be moved around the box with the standard cursor -movement keys. - -To shoot a ray, move the cursor to the edge of the box and press SPC. -The result will be determined and the playfield updated. - -You may place or remove balls in the box by moving the cursor into the -box and pressing \\[bb-romp]. - -When you think the configuration of balls you have placed is correct, -press \\[bb-done]. You will be informed whether you are correct or -not, and be given your score. Your score is the number of letters and -numbers around the outside of the box plus five for each incorrectly -placed ball. If you placed any balls incorrectly, they will be -indicated with `x', and their actual positions indicated with `o'. - -Details: - -There are three possible outcomes for each ray you send into the box: - - Detour: the ray is deflected and emerges somewhere other than - where you sent it in. On the playfield, detours are - denoted by matching pairs of numbers -- one where the - ray went in, and the other where it came out. - - Reflection: the ray is reflected and emerges in the same place - it was sent in. On the playfield, reflections are - denoted by the letter `R'. - - Hit: the ray strikes a ball directly and is absorbed. It does - not emerge from the box. On the playfield, hits are - denoted by the letter `H'. - -The rules for how balls deflect rays are simple and are best shown by -example. - -As a ray approaches a ball it is deflected ninety degrees. Rays can -be deflected multiple times. In the diagrams below, the dashes -represent empty box locations and the letter `O' represents a ball. -The entrance and exit points of each ray are marked with numbers as -described under \"Detour\" above. Note that the entrance and exit -points are always interchangeable. `*' denotes the path taken by the -ray. - -Note carefully the relative positions of the ball and the ninety -degree deflection it causes. - - 1 - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - -1 * * - - - - - - - - - - - - - - - O - - - - O - - - - O - - - - - - - O - - - - - - - * * * * - - - - - - - - - - - - - - * * * * * 2 3 * * * - - * - - - - - - - - - - - - - - * - - - - - - - O - * - - - - - - - - - - - - - - * - - - - - - - - * * - - - - - - - - - - - - - - * - - - - - - - - * - O - - 2 3 - -As mentioned above, a reflection occurs when a ray emerges from the same point -it was sent in. This can happen in several ways: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - O - O - - - - - - - - - - - -R * * * * - - - - - - - * - - - - O - - - - - - - - - - - - O - - - - - - * - - - - R - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - R * * * * - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - -In the first example, the ray is deflected downwards by the upper -ball, then left by the lower ball, and finally retraces its path to -its point of origin. The second example is similar. The third -example is a bit anomalous but can be rationalized by realizing the -ray never gets a chance to get into the box. Alternatively, the ray -can be thought of as being deflected downwards and immediately -emerging from the box. - -A hit occurs when a ray runs straight into a ball: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - - - - - O - - - H * * * * - - - - - - - - - - - - - H * * * * O - - - - - - * - - - - - - - - - - - - - - - - - O - - - - - - O - - - - -H * * * O - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Be sure to compare the second example of a hit with the first example of -a reflection." - (interactive "P") - (switch-to-buffer "*Blackbox*") - (blackbox-mode) - (setq buffer-read-only t) - (buffer-disable-undo (current-buffer)) - ;; XEmacs makes some local variables here and FSF doesn't. - (make-local-variable 'bb-board) - (setq bb-board (bb-init-board (or num 4))) - (make-local-variable 'bb-balls-placed) - (setq bb-balls-placed nil) - (make-local-variable 'bb-x) - (setq bb-x -1) - (make-local-variable 'bb-y) - (setq bb-y -1) - (make-local-variable 'bb-score) - (setq bb-score 0) - (make-local-variable 'bb-detour-count) - (setq bb-detour-count 0) - (bb-insert-board) - (bb-goto (cons bb-x bb-y))) - -(defun bb-init-board (num-balls) - (random t) - (let (board pos) - (while (>= (setq num-balls (1- num-balls)) 0) - (while - (progn - (setq pos (cons (random 8) (random 8))) - (bb-member pos board))) - (setq board (cons pos board))) - board)) - -(defun bb-insert-board () - (let (i (buffer-read-only nil)) - (erase-buffer) - (insert " \n") - (setq i 8) - (while (>= (setq i (1- i)) 0) - (insert " - - - - - - - - \n")) - (insert " \n") - (insert (format "\nThere are %d balls in the box" (length bb-board))) - )) - -(defun bb-right () - (interactive) - (if (= bb-x 8) - () - (forward-char 2) - (setq bb-x (1+ bb-x)))) - -(defun bb-left () - (interactive) - (if (= bb-x -1) - () - (backward-char 2) - (setq bb-x (1- bb-x)))) - -(defun bb-up () - (interactive) - (if (= bb-y -1) - () - (previous-line 1) - (setq bb-y (1- bb-y)))) - -(defun bb-down () - (interactive) - (if (= bb-y 8) - () - (next-line 1) - (setq bb-y (1+ bb-y)))) - -(defun bb-eol () - (interactive) - (setq bb-x 8) - (bb-goto (cons bb-x bb-y))) - -(defun bb-bol () - (interactive) - (setq bb-x -1) - (bb-goto (cons bb-x bb-y))) - -(defun bb-romp () - (interactive) - (cond - ((and - (or (= bb-x -1) (= bb-x 8)) - (or (= bb-y -1) (= bb-y 8)))) - ((bb-outside-box bb-x bb-y) - (bb-trace-ray bb-x bb-y)) - (t - (bb-place-ball bb-x bb-y)))) - -(defun bb-place-ball (x y) - (let ((coord (cons x y))) - (cond - ((bb-member coord bb-balls-placed) - (setq bb-balls-placed (bb-delete coord bb-balls-placed)) - (bb-update-board "-")) - (t - (setq bb-balls-placed (cons coord bb-balls-placed)) - (bb-update-board "O"))))) - -(defun bb-trace-ray (x y) - (let ((result (bb-trace-ray-2 - t - x - (cond - ((= x -1) 1) - ((= x 8) -1) - (t 0)) - y - (cond - ((= y -1) 1) - ((= y 8) -1) - (t 0))))) - (cond - ((eq result 'hit) - (bb-update-board "H") - (setq bb-score (1+ bb-score))) - ((equal result (cons x y)) - (bb-update-board "R") - (setq bb-score (1+ bb-score))) - (t - (setq bb-detour-count (1+ bb-detour-count)) - (bb-update-board (format "%d" bb-detour-count)) - (save-excursion - (bb-goto result) - (bb-update-board (format "%d" bb-detour-count))) - (setq bb-score (+ bb-score 2)))))) - -(defun bb-trace-ray-2 (first x dx y dy) - (cond - ((and (not first) - (bb-outside-box x y)) - (cons x y)) - ((bb-member (cons (+ x dx) (+ y dy)) bb-board) - 'hit) - ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board) - (bb-trace-ray-2 nil x (- dy) y (- dx))) - ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board) - (bb-trace-ray-2 nil x dy y dx)) - (t - (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy)))) - -(defun bb-done () - "Finish the game and report score." - (interactive) - (let (bogus-balls) - (cond - ((not (= (length bb-balls-placed) (length bb-board))) - (message "There %s %d hidden ball%s; you have placed %d." - (if (= (length bb-board) 1) "is" "are") - (length bb-board) - (if (= (length bb-board) 1) "" "s") - (length bb-balls-placed))) - (t - (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board)) - (if (= bogus-balls 0) - (message "Right! Your score is %d." bb-score) - (message "Oops! You missed %d ball%s. Your score is %d." - bogus-balls - (if (= bogus-balls 1) "" "s") - (+ bb-score (* 5 bogus-balls)))) - (bb-goto '(-1 . -1)))))) - -(defun bb-show-bogus-balls (balls-placed board) - (bb-show-bogus-balls-2 balls-placed board "x") - (bb-show-bogus-balls-2 board balls-placed "o")) - -(defun bb-show-bogus-balls-2 (list-1 list-2 c) - (cond - ((null list-1) - 0) - ((bb-member (car list-1) list-2) - (bb-show-bogus-balls-2 (cdr list-1) list-2 c)) - (t - (bb-goto (car list-1)) - (bb-update-board c) - (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c))))) - -(defun bb-outside-box (x y) - (or (= x -1) (= x 8) (= y -1) (= y 8))) - -(defun bb-goto (pos) - (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26))) - -(defun bb-update-board (c) - (let ((buffer-read-only nil)) - (backward-char (1- (length c))) - (delete-char (length c)) - (insert c) - (backward-char 1))) - -(defun bb-member (elt list) - "Returns non-nil if ELT is an element of LIST." - (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list)))) - -(defun bb-delete (item list) - "Deletes ITEM from LIST and returns a copy." - (cond - ((equal item (car list)) (cdr list)) - (t (cons (car list) (bb-delete item (cdr list)))))) - -;;; blackbox.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/conx.el --- a/lisp/games/conx.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,806 +0,0 @@ -;;; conx.el --- Yet another dissociater - -;; Copyright status unknown - -;; Author: Jamie Zawinski -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not in FSF - -;;; Commentary: - -;;; conx.el: Yet Another Dissociator. -;;; Original design by Skef Wholey ; -;;; ported to Emacs-Lisp by Jamie Zawinski , 5-mar-91. -;;; Run this compiled. It will be an order of magnitude faster. -;;; -;;; Select a buffer with a lot of text in it. Say M-x conx-buffer -;;; or M-x conx-region. Repeat on as many other bodies of text as -;;; you like. -;;; -;;; M-x conx will use the word-frequency tree the above generated -;;; to produce random sentences in a popped-up buffer. It will pause -;;; at the end of each paragraph for two seconds; type ^G to stop it. -;;; -;;; M-x conx-init will clear the data structures so you can start -;;; over. Note that if you run it twice consecutively on the same -;;; body of text, word sequences in that buffer will be twice as -;;; likely to be generated. -;;; -;;; Once you have sucked in a lot of text and like the kinds of -;;; sentences conx is giving you, you can save the internal data -;;; structures to a file with the M-x conx-save command. Loading -;;; this file with M-x conx-load will be a lot faster and easier -;;; than re-absorbing all of the text files. Beware that loading a -;;; saved conx-file clears the conx database in memory. -;;; -;;; M-x conx-emit-c will write out C source code which, when compiled, -;;; will produce a standalone program which generates sentences from -;;; a copy of the database currently loaded. -;;; -;;; Ideas for future improvement: -;;; -;;; o It would be nice if we could load in more than one saved -;;; file at a time. -;;; -;;; o use it to collect statistics on newsgroup conversations by -;;; examining the tree for the most common words and phrases -;;; -;;; o when replying to mail, insert an X-CONX: header field which -;;; contains a sentence randomly generated from the body of the -;;; message being replied to. -;;; -;;; o It could stand to be faster... - -;;; Code: -(defconst conx-version "1.6, 6-may-94.") - -(defvar conx-bounce 10) ; 1/x -(defvar conx-hashtable-size 9923) ; 9923 is prime -(defconst conx-words-hashtable nil) -(defconst conx-words-vector nil) -(defconst conx-words-vector-fp 0) - -(defconst conx-last-word nil) -p -(defvar conx-files nil "FYI") - -(defun conx-init () - "Forget the current word-frequency tree." - (interactive) - (if (and conx-words-hashtable - (>= (length conx-words-hashtable) conx-hashtable-size)) - (fillarray conx-words-hashtable 0) - (setq conx-words-hashtable (make-vector conx-hashtable-size 0))) - (if conx-words-vector - (fillarray conx-words-vector nil) - (setq conx-words-vector (make-vector 1000 nil))) ; this grows - (setq conx-words-vector-fp 0) - (setq conx-last-word nil - conx-files nil)) - -(defun conx-rehash () - ;; misnomer; this just grows the linear vector, growing the hash table - ;; is too hard. - (message "Rehashing...") - (let* ((L (length conx-words-vector)) - (v2 (make-vector (+ L L) nil))) - (while (< 0 L) - (aset v2 (1- L) (aref conx-words-vector (setq L (1- L))))) - (setq conx-words-vector v2) - ) - (message "Rehashing...done")) - -(defmacro conx-count (word) (list 'aref word 0)) -(defmacro conx-cap (word) (list 'aref word 1)) -(defmacro conx-comma (word) (list 'aref word 2)) -(defmacro conx-period (word) (list 'aref word 3)) -(defmacro conx-quem (word) (list 'aref word 4)) -(defmacro conx-bang (word) (list 'aref word 5)) -(defmacro conx-succ (word) (list 'aref word 6)) -(defmacro conx-pred (word) (list 'aref word 7)) -(defmacro conx-succ-c (word) (list 'aref word 8)) -(defmacro conx-pred-c (word) (list 'aref word 9)) -(defconst conx-length 10) - -(defmacro conx-make-word () - '(copy-sequence '[1 0 0 0 0 0 nil nil 0 0])) - -(defmacro conx-setf (form val) ; mind-numbingly simple - (setq form (macroexpand form (and (boundp 'byte-compile-macro-environment) - byte-compile-macro-environment))) - (cond ((symbolp form) (list 'setq form val)) - ((eq (car form) 'aref) (cons 'aset (append (cdr form) (list val)))) - ((eq (car form) 'cdr) (list 'setcdr (nth 1 form) val)) - ((eq (car form) 'car) (list 'setcar (nth 1 form) val)) - (t (error "can't setf %s" form)))) - -(defmacro conx-push (thing list) - (list 'conx-setf list (list 'cons thing list))) - -(defconst conx-most-positive-fixnum (lsh -1 -1) - "The largest positive integer that can be represented in this emacs.") - -(defmacro conx-rand (n) - (list '% (list 'logand 'conx-most-positive-fixnum '(random)) n)) - -(defmacro conx-relate-succ (word related) - (` (let ((vec (symbol-value (, word)))) - (conx-setf (conx-succ-c vec) (1+ (conx-succ-c vec))) - (let ((rel (assq (, related) (conx-succ vec)))) - (if rel - (setcdr rel (1+ (cdr rel))) - (conx-push (cons (, related) 1) (conx-succ vec))))))) - -(defmacro conx-relate-pred (word related) - (` (let ((vec (symbol-value (, word)))) - (conx-setf (conx-pred-c vec) (1+ (conx-pred-c vec))) - (let ((rel (assq (, related) (conx-pred vec)))) - (if rel - (setcdr rel (1+ (cdr rel))) - (conx-push (cons (, related) 1) (conx-pred vec))))))) - -(defmacro conx-add-word (word) - (` (let* ((word (, word)) - (fc (aref word 0))) - (setq word (intern (downcase word) conx-words-hashtable)) - (let ((vec (and (boundp word) (symbol-value word)))) - (if vec - (conx-setf (conx-count vec) (1+ (conx-count vec))) - (if (= conx-words-vector-fp (length conx-words-vector)) - (conx-rehash)) - (set word (setq vec (conx-make-word))) - (aset conx-words-vector conx-words-vector-fp word) - (setq conx-words-vector-fp (1+ conx-words-vector-fp))) - (or (< fc ?A) (> fc ?Z) - (conx-setf (conx-cap vec) (1+ (conx-cap vec))))) - (if conx-last-word - (progn - (conx-relate-succ conx-last-word word) - (conx-relate-pred word conx-last-word))) - (setq conx-last-word word)))) - -(defmacro conx-punx (char) - (` (if conx-last-word - (let ((char (, char)) - (vec (symbol-value conx-last-word))) - (cond ((eq char ?\,) - (conx-setf (conx-comma vec) (1+ (conx-comma vec)))) - ((or (eq char ?\.) - (eq char ?\;)) - (conx-setf (conx-period vec) (1+ (conx-period vec))) - (setq conx-last-word nil)) - ((eq char ?\?) - (conx-setf (conx-quem vec) (1+ (conx-quem vec))) - (setq conx-last-word nil)) - ((eq char ?\!) - (conx-setf (conx-bang vec) (1+ (conx-bang vec))) - (setq conx-last-word nil))))))) - -(defun conxify-internal () - (let (p w) - (while (not (eobp)) - (skip-chars-forward "^A-Za-z0-9'") - (while (memq (following-char) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?\')) - ;; ignore words beginning with digits - (skip-chars-forward "A-Za-z0-9'") - (skip-chars-forward "^A-Za-z0-9'")) - (setq p (point)) - (skip-chars-forward "A-Za-z0-9'") - (if (= ?\' (preceding-char)) (forward-char -1)) - (if (eq p (point)) - nil - (setq w (buffer-substring p (point))) - (if (equal "nil" w) ; hey, nil is totally magic, this doesn't work! - nil - (conx-add-word w) - (setq n (1+ n)) - (skip-chars-forward " \t\n\r") - (if (memq (setq p (following-char)) '(?\, ?\. ?\! ?\? ?\;)) - (conx-punx p))))))) - -;;;###autoload -(defun conx-buffer () - "Absorb the text in the current buffer into the tree." - (interactive) - (or conx-words-vector (conx-init)) - (let ((i conx-words-vector-fp) - (n 0) - (pm (point-max))) - (save-excursion - (goto-char (point-min)) - (save-restriction - (widen) - (while (< (setq p (point)) pm) - (search-forward "\n\n" pm 0) - (narrow-to-region p (point)) - (goto-char (prog1 p (setq p (point)))) - (conxify-internal) - (widen) - (message "%d%%..." (/ (* p 100) (point-max)))))) - (if buffer-file-name - (setq conx-files (nconc conx-files (list buffer-file-name)))) - (message "%s words, %d unique" n (- conx-words-vector-fp i)))) - -;;;###autoload -(defun conx-region (p m) - "Absorb the text in the current region into the tree." - (interactive "r") - (save-restriction - (widen) - (narrow-to-region p m) - (conx-buffer))) - -(defun conx-mail-buffer () - "Conxify a buffer in /bin/mail format." - (interactive) - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "\n \t") - (let ((case-fold-search nil) - (buffer-file-name nil) - p p2 p3) - (or (looking-at "^From ") (error "not in /bin/mail format")) - (while (not (eobp)) - (search-forward "\n\n" nil 0) - (setq p (point)) - (search-forward "\nFrom " nil 0) - (setq p3 (setq p2 (point))) - ;; don't count ".signature" sections. - (and (re-search-backward "\n--+\n" nil t) - (< (count-lines (point) p2) 9) - (setq p2 (point))) - (conx-region p (point)) - (goto-char p3))) - (if buffer-file-name - (setq conx-files (nconc conx-files (list buffer-file-name)))) - )) - -;;; output - -(defun conx-random-related (count list) - (let ((foll (if (= 0 count) 0 (conx-rand count))) - ans) - (while list - (if (<= foll (cdr (car list))) - (setq ans (car (car list)) - list nil) - (setq foll (- foll (cdr (car list))) - list (cdr list)))) - ans)) - -(defun conx-random-succ (word) - (if (= 0 (conx-succ-c (symbol-value word))) - word - (let ((next (conx-random-related - (conx-succ-c (symbol-value word)) - (conx-succ (symbol-value word))))) - (if (= 0 (conx-rand conx-bounce)) - (conx-random-succ - (conx-random-related - (conx-pred-c (symbol-value next)) - (conx-pred (symbol-value next)))) - next)))) - - -(defun conx-sentence () - (or (> conx-words-vector-fp 0) - (error "no conx data is loaded; see `conx-buffer'.")) - (let* ((word (aref conx-words-vector (conx-rand conx-words-vector-fp))) - (first-p t) - (p (point)) - vec punc str) - (while word - (setq punc (conx-rand (conx-count (setq vec (symbol-value word))))) - (if (or first-p - ;; (< (conx-rand (conx-count vec)) (conx-cap vec)) - (= (conx-count vec) (conx-cap vec)) - ) - (progn - (setq first-p nil) - (setq str (symbol-name word)) - (insert (+ (- ?A ?a) (aref str 0))) - (insert (substring str 1))) - (insert (symbol-name word))) - (cond ((< punc (conx-comma vec)) - (insert ", ")) - ((< (setq punc (- punc (conx-comma vec))) (conx-period vec)) - (setq word nil) - (if (= 0 (conx-rand 5)) - (if (= 0 (conx-rand 4)) - (insert ": ") - (insert "; ")) - (insert ". "))) - ((< (setq punc (- punc (conx-period vec))) (conx-quem vec)) - (setq word nil) - (insert "? ")) - ((< (setq punc (- punc (conx-quem vec))) (conx-bang vec)) - (setq word nil) - (insert "! ")) - (t - (insert " ") - (if (= 0 (conx-succ-c vec)) (setq word nil)))) - (if word - (setq word (conx-random-succ word)))) - (fill-region-as-paragraph (save-excursion - (goto-char p) - (beginning-of-line) - (point)) - (point)) - (if (= (preceding-char) ?\n) - (if (= 0 (conx-rand 4)) - (insert "\n") - (delete-char -1) - (insert " ")))) - nil) - -;;;###autoload -(defun conx () - "Generate some random sentences in the *conx* buffer." - (interactive) - (display-buffer (set-buffer (get-buffer-create "*conx*"))) - (select-window (get-buffer-window "*conx*")) - (message "type ^G to stop.") - (while t - (goto-char (point-max)) - (sit-for (if (= (preceding-char) ?\n) 2 0)) - (conx-sentence))) - - -;;; GNUS interface; grab words from the current message. - -(defun conx-gnus-snarf () - "For use as a gnus-select-article-hook." - (set-buffer gnus-article-buffer) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (conx-region (point) (point-max))))) - -;;(add-hook 'gnus-select-article-hook 'conx-gnus-snarf) - -(defun psychoanalyze-conx () - "Mr. Random goes to the analyst." - (interactive) - (doctor) ; start the psychotherapy - (message "") - (switch-to-buffer "*doctor*") - (sit-for 0) - (while (not (input-pending-p)) - (conx-sentence) - (if (= (random 2) 0) - (conx-sentence)) - (sit-for 0) - (doctor-ret-or-read 1))) - - -;;; Saving the database - -(defun conx-save (file) - "Save the current CONX database to a file for future retrieval. -You can re-load this database with the \\[conx-load] command." - (interactive "FSave CONX corpus to file: ") - (save-excursion - (let (b) - (unwind-protect - (progn - (set-buffer (setq b (get-buffer-create "*conx-save-tmp*"))) - (delete-region (point-min) (point-max)) - (insert ";;; -*- Mode:Emacs-Lisp -*-\n") - (insert ";;; This is a CONX database file. Load it with `conx-load'.\n") - (if conx-files - (insert ";;; Corpus: " (mapconcat 'identity conx-files ", ") "\n")) - (insert ";;; Date: " (current-time-string) "\n\n") - ;; The file format used here is such a cute hack that I'm going to - ;; leave it as an excercise to the reader to figure it out. - (let ((p (point)) - (fill-column 78) - (fill-prefix "\t") - (i 0)) - (insert "(!! [\t") - (while (< i conx-words-vector-fp) - (prin1 (aref conx-words-vector i) (current-buffer)) - (insert " ") - (setq i (1+ i))) - (insert "])\n") - (fill-region-as-paragraph p (point)) - (insert "\n")) - (mapatoms (function (lambda (sym) - (if (not (boundp sym)) - nil - (insert "\(! ") - (prin1 sym (current-buffer)) - (insert " ") - (prin1 (symbol-value sym) (current-buffer)) - (insert "\)\n")))) - conx-words-hashtable) - (goto-char (point-min)) - (while (re-search-forward "\\bnil\\b" nil t) - (replace-match "()")) - (set-visited-file-name file) - (save-buffer))) - (and b (kill-buffer b))))) - -;;;###autoload -(defun conx-load (file) - "Load in a CONX database written by the \\[conx-save] command. -This clears the database currently in memory." - (interactive "fLoad CONX corpus from file: ") - (conx-init) - (fset (intern "!!" conx-words-hashtable) - (function (lambda (vec) - (setq conx-words-vector vec - conx-words-vector-fp (length vec))))) - (fset (intern "!" conx-words-hashtable) - (symbol-function 'setq)) - (let ((obarray conx-words-hashtable)) - (load file))) - - -;;; Emitting C code - -(defun conx-emit-c-data (&optional ansi-p) - (let ((all '()) - (standard-output (current-buffer)) - (after-change-functions nil) ; turning off font-lock speeds it up x2 - (before-change-functions nil) - (after-change-function nil) - (before-change-function nil) - (float-output-format "%.2f") - count total total100) - (or conx-words-hashtable (error "no words")) - (let ((i 0)) - (mapatoms (function (lambda (x) - (if (boundp x) - (setq all (cons (cons i x) all) - i (1+ i))))) - conx-words-hashtable)) - (setq all (nreverse all)) - (setq total (* 4 (length all)) - total100 (max 1 (if (featurep 'lisp-float-type) - (/ (float total) 100) - (/ total 100))) - count 0) - (let ((rest all) - (i 5) - rest2 - word) - (insert "static unsigned short D[] = {") - (while rest - (setq word (symbol-value (cdr (car rest)))) - (setq rest2 (conx-pred word)) - (setq count (1+ count)) - (while rest2 - (princ (cdr (car rest2))) (insert ",") - (princ (car (rassq (car (car rest2)) all))) - (insert ",") - (setq i (1+ i)) - (cond ((> i 10) - (insert "\n") - (setq i 0))) - (setq rest2 (cdr rest2))) - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest2 (conx-succ word)) - (while rest2 - (princ (cdr (car rest2))) - (insert ",") - (princ (car (rassq (car (car rest2)) all))) - (insert ",") - (setq i (1+ i)) - (cond ((> i 10) - (insert "\n") - (setq i 0))) - (setq rest2 (cdr rest2))) - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest (cdr rest)))) - (insert "0};\nstatic char T[] = \"") - (let ((rest all) - (i 0) (j 20) - k word) - (while rest - (setq word (symbol-name (cdr (car rest)))) - (setq k (1+ (length word)) - i (+ i k) - j (+ j k 3)) - (cond ((> j 77) - (insert (if ansi-p "\"\n\"" "\\\n")) - (setq j (+ k 3)))) - (insert word) ; assumes word has no chars needing backslashes - (insert "\\000") - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest (cdr rest)))) - (insert "\";\nstatic struct conx_word words [] = {") - (let ((rest all) - (i 0) (j 0) - cons name word) - (while rest - (setq cons (car rest) - name (symbol-name (cdr cons)) - word (symbol-value (cdr cons))) - (insert "{") (princ (conx-count word)) - (insert ",") (princ (conx-cap word)) - (insert ",") (princ (conx-comma word)) - (insert ",") (princ (conx-period word)) - (insert ",") (princ (conx-quem word)) - (insert ",") (princ (conx-bang word)) - (if (null (conx-pred word)) - (insert ",0") - (insert ",") - (princ i) - (setq i (+ i (* 2 (length (conx-pred word)))))) - (if (null (conx-succ word)) - (insert ",0,") - (insert ",") - (princ i) - (insert ",") - (setq i (+ i (* 2 (length (conx-succ word)))))) - (princ (conx-pred-c word)) (insert ",") - (princ (conx-succ-c word)) (insert ",") - (princ j) - (setq j (+ j (length name) 1)) - (insert (if (cdr rest) (if (= 0 (% (car cons) 2)) "},\n" "},") "}")) - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest (cdr rest)) - )) - (insert "};\n#define conx_bounce ") - (princ conx-bounce) - (insert "\n") - (message "Writing C code... done.") - )) - -(defvar conx-c-prolog "\ -#if __STDC__ -#include -#include -extern long random (void); -extern void srandom (int); -extern void abort (void); -#endif -#include -#include - -struct conx_word { - unsigned short count; - unsigned short cap; - unsigned short comma; - unsigned short period; - unsigned short quem; - unsigned short bang; - unsigned short pred; - unsigned short succ; - unsigned short npred; - unsigned short nsucc; - unsigned short text; -}; -") - -(defvar conx-c-code "\ -#define countof(x) (sizeof((x)) / sizeof(*(x))) -#define conx_rand(n) (random()%(n)) - -static struct conx_word * -conx_random_related (count, which_list) - unsigned short count, which_list; -{ - unsigned short *list = D + which_list; - int i = 0; - unsigned short foll = (count == 0 ? 0 : conx_rand (count)); - while (1) - { - if (foll <= list [i * 2]) - { - if ((list [i * 2 + 1]) > countof (words)) - abort (); - return &words [list [i * 2 + 1]]; - } - foll -= list [i * 2]; - i++; - } -} - -static struct conx_word * -conx_random_succ (word) - struct conx_word *word; -{ - if (word->nsucc == 0) - return word; - else - { - struct conx_word *next = conx_random_related (word->nsucc, word->succ); - if (conx_rand (conx_bounce) != 0) - return next; - return conx_random_succ (conx_random_related (next->npred, next->pred)); - } -} - -static void -conx_sentence () -{ - static int x = 0; - struct conx_word *word = 0; - int first_p = 1; - int done = 0; - int count = 0; - while (!done) - { - int punc; - char *text; - int L; - if (word) - word = conx_random_succ (word); - else - word = &words [conx_rand (countof (words))]; - count++; - punc = conx_rand (word->count); - text = T + word->text; - L = strlen (text); - if (x + L > 70) - { - putchar ('\\n'); - x = 0; - } - x += L+1; - - if (first_p || (word->count == word->cap)) - { - putchar ((*text >= 'a' && *text <= 'z') ? *text + ('A'-'a') : *text); - fputs (text+1, stdout); - first_p = 0; - } - else - fputs (text, stdout); - - if (punc < word->comma) - { - fputs (\", \", stdout); - x++; - } - else if ((punc -= word->comma) < word->period) - { - x++; - if (count > 120 || conx_rand (5) != 0) - { - done = 1; - fputs (\". \", stdout); - x++; - } - else - { - word = 0; - if (conx_rand (4) == 0) - fputs (\": \", stdout); - else - fputs (\"; \", stdout); - } - } - else if ((punc -= word->period) < word->quem) - { - done = 1; - fputs (\"? \", stdout); - x += 2; - } - else if ((punc -= word->quem) < word->bang) - { - done = 1; - fputs (\"! \", stdout); - x += 2; - } - else - { - if (word->nsucc == 0) - { - fputs (\". \", stdout); - x += 2; - done = 1; - } - else - putchar (' '); - } - } - if (conx_rand (3) == 0) - { - fputs (\"\\n\\n\", stdout); - x = 0; - } -} - -main (argc, argv) - int argc; - char **argv; -{ - unsigned int howmany, delay; - char dummy; - if (argc == 1) - { - howmany = 1; - delay = 0; - } - else if (argc == 2 && - 1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy)) - delay = 0; - else if (argc == 3 && - 1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy) && - 1 == sscanf (argv[2], \"%ud%c\", &delay, &dummy)) - ; - else - { - fprintf (stderr, \"usage: %s [count [delay]]\\n\", argv [0]); - exit (1); - } - - srandom (time (0)); - if (howmany == 0) - howmany = ~0; - while (howmany > 0) - { - conx_sentence (); - fflush (stdout); - howmany--; - if (delay) sleep (delay); - } - putchar ('\\n'); - exit (0); -} -") - -(defun conx-emit-c (file &optional non-ansi-p) - "Write the current CONX database to a file as C source code. -The generated program will have the same effect as M-x conx, -except that it runs without emacs. - -With a prefix argument, write K&R C instead of ANSI C. ANSI is -the default because, without a certain ANSI feature, large databases -will overflow static limits in most K&R preprocessors." - (interactive "FWrite C file: \nP") - (find-file file) - (erase-buffer) - (let ((buffer-undo-list t)) - (insert conx-c-prolog) - (if (not non-ansi-p) - (insert "\n#if !__STDC__\n" - "error! this file requires an ANSI C compiler\n" - "#endif\n\n")) - (conx-emit-c-data (not non-ansi-p)) - (insert conx-c-code)) - (goto-char (point-min))) - - -;;; Reporting stats - -(defun conx-stats () - (set-buffer (get-buffer-create "*conx-stats*")) - (delete-region (point-min) (point-max)) - (mapatoms (function (lambda (x) - (or (not (boundp x)) - (progn - (insert (format "%s" (conx-count (symbol-value x)))) - (insert "\t\t") - (insert (symbol-name x)) - (insert "\n"))))) - conx-words-hashtable) - (sort-numeric-fields -1 (point-min) (point-max))) - -;;; conx.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/cookie1.el --- a/lisp/games/cookie1.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,173 +0,0 @@ -;;; cookie1.el --- retrieve random phrases from fortune cookie files - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond -;; Maintainer: FSF -;; Keywords: games -;; Created: Mon Mar 22 17:06:26 1993 - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Support for random cookie fetches from phrase files, used for such -;; critical applications as emulating Zippy the Pinhead and confounding -;; the NSA Trunk Trawler. -;; -;; The two entry points are `cookie' and `cookie-insert'. The helper -;; function `shuffle-vector' may be of interest to programmers. -;; -;; The code expects phrase files to be in one of two formats: -;; -;; * ITS-style LINS format (strings terminated by ASCII 0 characters, -;; leading whitespace ignored). -;; -;; * UNIX fortune file format (quotes terminated by %% on a line by itself). -;; -;; Everything up to the first delimiter is treated as a comment. Other -;; formats could be supported by adding alternates to the regexp -;; `cookie-delimiter'. -;; -;; This code derives from Steve Strassman's 1987 spook.el package, but -;; has been generalized so that it supports multiple simultaneous -;; cookie databases and fortune files. It is intended to be called -;; from other packages such as yow.el and spook.el. -;; -;; TO DO: teach cookie-snarf to auto-detect ITS PINS or UNIX fortune(6) -;; format and do the right thing. - -;;; Code: - -; Randomize the seed in the random number generator. -(random t) - -(defconst cookie-delimiter "\n%%\n\\|\0" - "Delimiter used to separate cookie file entries.") - -(defvar cookie-cache (make-vector 511 0) - "Cache of cookie files that have already been snarfed.") - -;;;###autoload -(defun cookie (phrase-file startmsg endmsg) - "Return a random phrase from PHRASE-FILE. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." - (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg))) - (shuffle-vector cookie-vector) - (aref cookie-vector 1))) - -;;;###autoload -(defun cookie-insert (phrase-file &optional count startmsg endmsg) - "Insert random phrases from PHRASE-FILE; COUNT of them. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." - (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg))) - (shuffle-vector cookie-vector) - (let ((start (point))) - (insert ?\n) - (cookie1 (min (- (length cookie-vector) 1) (or count 1)) cookie-vector) - (insert ?\n) - (fill-region-as-paragraph start (point) nil)))) - -(defun cookie1 (arg cookie-vec) - "Inserts a cookie phrase ARG times." - (cond ((zerop arg) t) - (t (insert (aref cookie-vec arg)) - (insert " ") - (cookie1 (1- arg) cookie-vec)))) - -;;;###autoload -(defun cookie-snarf (phrase-file startmsg endmsg) - "Reads in the PHRASE-FILE, returns it as a vector of strings. -Emit STARTMSG and ENDMSG before and after. Caches the result; second -and subsequent calls on the same file won't go to disk." - (let ((sym (intern-soft phrase-file cookie-cache))) - (and sym (not (equal (symbol-function sym) - (nth 5 (file-attributes phrase-file)))) - (yes-or-no-p (concat phrase-file - " has changed. Read new contents? ")) - (setq sym nil)) - (if sym - (symbol-value sym) - (setq sym (intern phrase-file cookie-cache)) - (message "%s" startmsg) - (save-excursion - (let ((buf (generate-new-buffer "*cookie*")) - (result nil)) - (set-buffer buf) - (fset sym (nth 5 (file-attributes phrase-file))) - (insert-file-contents (expand-file-name phrase-file)) - (re-search-forward cookie-delimiter) - (while (progn (skip-chars-forward " \t\n\r\f") (not (eobp))) - (let ((beg (point))) - (re-search-forward cookie-delimiter) - ;; XEmacs change - ;; DBC --- here's the change - ;; This used to be (buffer-substring beg (1- (point))), - ;; which only worked if the regexp matched was one - ;; character long - (setq result (cons (buffer-substring beg - (match-beginning 0)) - result)))) - (kill-buffer buf) - (message "%s" endmsg) - (set sym (apply 'vector result))))))) - -(defun read-cookie (prompt phrase-file startmsg endmsg &optional require-match) - "Prompt with PROMPT and read with completion among cookies in PHRASE-FILE. -STARTMSG and ENDMSG are passed along to `cookie-snarf'. -Optional fifth arg REQUIRE-MATCH non-nil forces a matching cookie." - ;; Make sure the cookies are in the cache. - (or (intern-soft phrase-file cookie-cache) - (cookie-snarf phrase-file startmsg endmsg)) - (completing-read prompt - (let ((sym (intern phrase-file cookie-cache))) - ;; We cache the alist form of the cookie in a property. - (or (get sym 'completion-alist) - (let* ((alist nil) - (vec (cookie-snarf phrase-file - startmsg endmsg)) - (i (length vec))) - (while (> (setq i (1- i)) 0) - (setq alist (cons (list (aref vec i)) alist))) - (put sym 'completion-alist alist)))) - nil require-match nil nil)) - -; Thanks to Ian G Batten -; [of the University of Birmingham Computer Science Department] -; for the iterative version of this shuffle. -; -;;;###autoload -(defun shuffle-vector (vector) - "Randomly permute the elements of VECTOR (all permutations equally likely)" - (let ((i 0) - j - temp - (len (length vector))) - (while (< i len) - (setq j (+ i (random (- len i)))) - (setq temp (aref vector i)) - (aset vector i (aref vector j)) - (aset vector j temp) - (setq i (1+ i)))) - vector) - -(provide 'cookie1) - -;;; cookie1.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/custom-load.el --- a/lisp/games/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sat Oct 4 18:11:32 1997 - -;;; Code: - -(custom-put 'games 'custom-loads '("xmine")) -(custom-put 'xmine 'custom-loads '("xmine")) - -;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/decipher.el --- a/lisp/games/decipher.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1051 +0,0 @@ -;;; decipher.el --- Cryptanalyze monoalphabetic substitution ciphers -;; -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. -;; -;; Author: Christopher J. Madsen -;; Keywords: games -;; -;; This file is part of GNU Emacs. -;; -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Quick Start: -;; -;; To decipher a message, type or load it into a buffer and type -;; `M-x decipher'. This will format the buffer and place it into -;; Decipher mode. You can save your work to a file with the normal -;; Emacs save commands; when you reload the file it will automatically -;; enter Decipher mode. -;; -;; I'm not going to discuss how to go about breaking a cipher; try -;; your local library for a book on cryptanalysis. One book you might -;; find is: -;; Cryptanalysis: A study of ciphers and their solution -;; Helen Fouche Gaines -;; ISBN 0-486-20097-3 - -;;; Commentary: -;; -;; This package is designed to help you crack simple substitution -;; ciphers where one letter stands for another. It works for ciphers -;; with or without word divisions. (You must set the variable -;; decipher-ignore-spaces for ciphers without word divisions.) -;; -;; First, some quick definitions: -;; ciphertext The encrypted message (what you start with) -;; plaintext The decrypted message (what you are trying to get) -;; -;; Decipher mode displays ciphertext in uppercase and plaintext in -;; lowercase. You must enter the plaintext in lowercase; uppercase -;; letters are interpreted as commands. The ciphertext may be entered -;; in mixed case; `M-x decipher' will convert it to uppercase. -;; -;; Decipher mode depends on special characters in the first column of -;; each line. The command `M-x decipher' inserts these characters for -;; you. The characters and their meanings are: -;; ( The plaintext & ciphertext alphabets on the first line -;; ) The ciphertext & plaintext alphabets on the second line -;; : A line of ciphertext (with plaintext below) -;; > A line of plaintext (with ciphertext above) -;; % A comment -;; Each line in the buffer MUST begin with one of these characters (or -;; be left blank). In addition, comments beginning with `%!' are reserved -;; for checkpoints; see decipher-make-checkpoint & decipher-restore-checkpoint -;; for more information. -;; -;; While the cipher message may contain digits or punctuation, Decipher -;; mode will ignore these characters. -;; -;; The buffer is made read-only so it can't be modified by normal -;; Emacs commands. -;; -;; Decipher supports Font Lock mode. To use it, you can also add -;; (add-hook 'decipher-mode-hook 'turn-on-font-lock) -;; See the variable `decipher-font-lock-keywords' if you want to customize -;; the faces used. I'd like to thank Simon Marshall for his help in making -;; Decipher work well with Font Lock. - -;;; Things To Do: -;; -;; Email me if you have any suggestions or would like to help. -;; But be aware that I work on Decipher only sporadically. -;; -;; 1. The consonant-line shortcut -;; 2. More functions for analyzing ciphertext - -;;;=================================================================== -;;; Variables: -;;;=================================================================== - -(eval-when-compile - (require 'cl)) - -(defvar decipher-force-uppercase t - "*Non-nil means to convert ciphertext to uppercase. -Nil means the case of the ciphertext is preserved. -This variable must be set before typing `\\[decipher]'.") - -(defvar decipher-ignore-spaces nil - "*Non-nil means to ignore spaces and punctuation when counting digrams. -You should set this to `nil' if the cipher message is divided into words, -or `t' if it is not. -This variable is buffer-local.") -(make-variable-buffer-local 'decipher-ignore-spaces) - -(defvar decipher-undo-limit 5000 - "The maximum number of entries in the undo list. -When the undo list exceeds this number, 100 entries are deleted from -the tail of the list.") - -;; End of user modifiable variables -;;-------------------------------------------------------------------- - -(defvar decipher-font-lock-keywords - '(("^:.*" . font-lock-keyword-face) - ("^>.*" . font-lock-string-face) - ("^%!.*" . font-lock-reference-face) - ("^%.*" . font-lock-comment-face) - ("\\`(\\([a-z]+\\) +\\([A-Z]+\\)" - (1 font-lock-string-face) - (2 font-lock-keyword-face)) - ("^)\\([A-Z ]+\\)\\([a-z ]+\\)" - (1 font-lock-keyword-face) - (2 font-lock-string-face))) - "Expressions to fontify in Decipher mode. -Ciphertext uses `font-lock-keyword-face', plaintext uses -`font-lock-string-face', comments use `font-lock-comment-face', and -checkpoints use `font-lock-reference-face'. You can customize the -display by changing these variables. For best results, I recommend -that all faces use the same background color. -For example, to display ciphertext in the `bold' face, use - (add-hook 'decipher-mode-hook - (lambda () (set (make-local-variable 'font-lock-keyword-face) - 'bold))) -in your `.emacs' file.") - -(defvar decipher-mode-map nil - "Keymap for Decipher mode.") -(if (not decipher-mode-map) - (progn - (setq decipher-mode-map (make-keymap)) - (suppress-keymap decipher-mode-map) - (define-key decipher-mode-map "A" 'decipher-show-alphabet) - (define-key decipher-mode-map "C" 'decipher-complete-alphabet) - (define-key decipher-mode-map "D" 'decipher-digram-list) - (define-key decipher-mode-map "F" 'decipher-frequency-count) - (define-key decipher-mode-map "M" 'decipher-make-checkpoint) - (define-key decipher-mode-map "N" 'decipher-adjacency-list) - (define-key decipher-mode-map "R" 'decipher-restore-checkpoint) - (define-key decipher-mode-map "U" 'decipher-undo) - (define-key decipher-mode-map " " 'decipher-keypress) - (substitute-key-definition 'undo 'decipher-undo - decipher-mode-map global-map) - (substitute-key-definition 'advertised-undo 'decipher-undo - decipher-mode-map global-map) - (let ((key ?a)) - (while (<= key ?z) - (define-key decipher-mode-map (vector key) 'decipher-keypress) - (incf key))))) - -(defvar decipher-stats-mode-map nil - "Keymap for Decipher-Stats mode.") -(if (not decipher-stats-mode-map) - (progn - (setq decipher-stats-mode-map (make-keymap)) - (suppress-keymap decipher-stats-mode-map) - (define-key decipher-stats-mode-map "D" 'decipher-digram-list) - (define-key decipher-stats-mode-map "F" 'decipher-frequency-count) - (define-key decipher-stats-mode-map "N" 'decipher-adjacency-list) - )) - -(defvar decipher-mode-syntax-table nil - "Decipher mode syntax table") - -(if decipher-mode-syntax-table - () - (let ((table (make-syntax-table)) - (c ?0)) - (while (<= c ?9) - (modify-syntax-entry c "_" table) ;Digits are not part of words - (incf c)) - (setq decipher-mode-syntax-table table))) - -(defvar decipher-alphabet nil) -;; This is an alist containing entries (PLAIN-CHAR . CIPHER-CHAR), -;; where PLAIN-CHAR runs from ?a to ?z and CIPHER-CHAR is an uppercase -;; letter or space (which means no mapping is known for that letter). -;; This *must* contain entries for all lowercase characters. -(make-variable-buffer-local 'decipher-alphabet) - -(defvar decipher-stats-buffer nil - "The buffer which displays statistics for this ciphertext. -Do not access this variable directly, use the function -`decipher-stats-buffer' instead.") -(make-variable-buffer-local 'decipher-stats-buffer) - -(defvar decipher-undo-list-size 0 - "The number of entries in the undo list.") -(make-variable-buffer-local 'decipher-undo-list-size) - -(defvar decipher-undo-list nil - "The undo list for this buffer. -Each element is either a cons cell (PLAIN-CHAR . CIPHER-CHAR) or a -list of such cons cells.") -(make-variable-buffer-local 'decipher-undo-list) - -(defvar decipher-pending-undo-list nil) - -;; The following variables are used by the analysis functions -;; and are defined here to avoid byte-compiler warnings. -;; Don't mess with them unless you know what you're doing. -(defvar decipher-char nil - "See the functions decipher-loop-with-breaks and decipher-loop-no-breaks.") -(defvar decipher--prev-char) -(defvar decipher--digram) -(defvar decipher--digram-list) -(defvar decipher--before) -(defvar decipher--after) -(defvar decipher--freqs) - -;;;=================================================================== -;;; Code: -;;;=================================================================== -;; Main entry points: -;;-------------------------------------------------------------------- - -;;;###autoload -(defun decipher () - "Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." - (interactive) - ;; Make sure the buffer ends in a newline: - (goto-char (point-max)) - (or (bolp) - (insert "\n")) - ;; See if it's already in decipher format: - (goto-char (point-min)) - (if (looking-at "^(abcdefghijklmnopqrstuvwxyz \ -ABCDEFGHIJKLMNOPQRSTUVWXYZ -\\*-decipher-\\*-\n)") - (message "Buffer is already formatted, entering Decipher mode...") - ;; Add the alphabet at the beginning of the file - (insert "(abcdefghijklmnopqrstuvwxyz \ -ABCDEFGHIJKLMNOPQRSTUVWXYZ -*-decipher-*-\n)\n\n") - ;; Add lines for the solution: - (let (begin) - (while (not (eobp)) - (if (looking-at "^%") - (forward-line) ;Leave comments alone - (delete-horizontal-space) - (if (eolp) - (forward-line) ;Just leave blank lines alone - (insert ":") ;Mark ciphertext line - (setq begin (point)) - (forward-line) - (if decipher-force-uppercase - (upcase-region begin (point))) ;Convert ciphertext to uppercase - (insert ">\n"))))) ;Mark plaintext line - (delete-blank-lines) ;Remove any blank lines - (delete-blank-lines)) ; at end of buffer - (goto-line 4) - (decipher-mode)) - -;;;###autoload -(defun decipher-mode () - "Major mode for decrypting monoalphabetic substitution ciphers. -Lower-case letters enter plaintext. -Upper-case letters are commands. - -The buffer is made read-only so that normal Emacs commands cannot -modify it. - -The most useful commands are: -\\ -\\[decipher-digram-list] Display a list of all digrams & their frequency -\\[decipher-frequency-count] Display the frequency of each ciphertext letter -\\[decipher-adjacency-list]\ - Show adjacency list for current letter (lists letters appearing next to it) -\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) -\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" - (interactive) - (kill-all-local-variables) - (setq buffer-undo-list t ;Disable undo - indent-tabs-mode nil ;Do not use tab characters - major-mode 'decipher-mode - mode-name "Decipher") - (if decipher-force-uppercase - (setq case-fold-search nil)) ;Case is significant when searching - (use-local-map decipher-mode-map) - (set-syntax-table decipher-mode-syntax-table) - (decipher-read-alphabet) - (set (make-local-variable 'font-lock-defaults) - '(decipher-font-lock-keywords t)) - ;; Make the buffer writable when we exit Decipher mode: - (make-local-hook 'change-major-mode-hook) - (add-hook 'change-major-mode-hook - (lambda () (setq buffer-read-only nil - buffer-undo-list nil)) - nil t) - (run-hooks 'decipher-mode-hook) - (setq buffer-read-only t)) -(put 'decipher-mode 'mode-class 'special) - -;;-------------------------------------------------------------------- -;; Normal key handling: -;;-------------------------------------------------------------------- - -(defmacro decipher-last-command-char () - ;; Return the char which ran this command (for compatibility with XEmacs) - (if (fboundp 'event-to-character) - '(event-to-character last-command-event) - 'last-command-event)) - -(defun decipher-keypress () - "Enter a plaintext or ciphertext character." - (interactive) - (let ((decipher-function 'decipher-set-map) - buffer-read-only) ;Make buffer writable - (save-excursion - (or (save-excursion - (beginning-of-line) - (let ((first-char (following-char))) - (cond - ((= ?: first-char) - t) - ((= ?> first-char) - nil) - ((= ?\( first-char) - (setq decipher-function 'decipher-alphabet-keypress) - t) - ((= ?\) first-char) - (setq decipher-function 'decipher-alphabet-keypress) - nil) - (t - (error "Bad location"))))) - (let (goal-column) - (previous-line 1))) - (let ((char-a (following-char)) - (char-b (decipher-last-command-char))) - (or (and (not (= ?w (char-syntax char-a))) - (= char-b ?\ )) ;Spacebar just advances on non-letters - (funcall decipher-function char-a char-b))))) - (forward-char)) - -(defun decipher-alphabet-keypress (a b) - ;; Handle keypresses in the alphabet lines. - ;; A is the character in the alphabet row (which starts with '(') - ;; B is the character pressed - (cond ((and (>= a ?A) (<= a ?Z)) - ;; If A is uppercase, then it is in the ciphertext alphabet: - (decipher-set-map a b)) - ((and (>= a ?a) (<= a ?z)) - ;; If A is lowercase, then it is in the plaintext alphabet: - (if (= b ?\ ) - ;; We are clearing the association (if any): - (if (/= ?\ (setq b (cdr (assoc a decipher-alphabet)))) - (decipher-set-map b ?\ )) - ;; Associate the plaintext char with the char pressed: - (decipher-set-map b a))) - (t - ;; If A is not a letter, that's a problem: - (error "Bad character")))) - -;;-------------------------------------------------------------------- -;; Undo: -;;-------------------------------------------------------------------- - -(defun decipher-undo () - "Undo a change in Decipher mode." - (interactive) - ;; If we don't get all the way thru, make last-command indicate that - ;; for the following command. - (setq this-command t) - (or (eq major-mode 'decipher-mode) - (error "This buffer is not in Decipher mode")) - (or (eq last-command 'decipher-undo) - (setq decipher-pending-undo-list decipher-undo-list)) - (or decipher-pending-undo-list - (error "No further undo information")) - (let ((undo-rec (pop decipher-pending-undo-list)) - buffer-read-only ;Make buffer writable - redo-map redo-rec undo-map) - (or (consp (car undo-rec)) - (setq undo-rec (list undo-rec))) - (while (setq undo-map (pop undo-rec)) - (setq redo-map (decipher-get-undo (cdr undo-map) (car undo-map))) - (if redo-map - (setq redo-rec - (if (consp (car redo-map)) - (append redo-map redo-rec) - (cons redo-map redo-rec)))) - (decipher-set-map (cdr undo-map) (car undo-map) t)) - (decipher-add-undo redo-rec)) - (setq this-command 'decipher-undo) - (message "Undo!")) - -(defun decipher-add-undo (undo-rec) - "Add UNDO-REC to the undo list." - (if undo-rec - (progn - (push undo-rec decipher-undo-list) - (incf decipher-undo-list-size) - (if (> decipher-undo-list-size decipher-undo-limit) - (let ((new-size (- decipher-undo-limit 100))) - ;; Truncate undo list to NEW-SIZE elements: - (setcdr (nthcdr (1- new-size) decipher-undo-list) nil) - (setq decipher-undo-list-size new-size)))))) - -(defun decipher-get-undo (cipher-char plain-char) - ;; Return an undo record that will undo the result of - ;; (decipher-set-map CIPHER-CHAR PLAIN-CHAR) - ;; We must use copy-list because the original cons cells will be - ;; modified using setcdr. - (let ((cipher-map (copy-list (rassoc cipher-char decipher-alphabet))) - (plain-map (copy-list (assoc plain-char decipher-alphabet)))) - (cond ((equal ?\ plain-char) - cipher-map) - ((equal cipher-char (cdr plain-map)) - nil) ;We aren't changing anything - ((equal ?\ (cdr plain-map)) - (or cipher-map (cons ?\ cipher-char))) - (cipher-map - (list plain-map cipher-map)) - (t - plain-map)))) - -;;-------------------------------------------------------------------- -;; Mapping ciphertext and plaintext: -;;-------------------------------------------------------------------- - -(defun decipher-set-map (cipher-char plain-char &optional no-undo) - ;; Associate a ciphertext letter with a plaintext letter - ;; CIPHER-CHAR must be an uppercase or lowercase letter - ;; PLAIN-CHAR must be a lowercase letter (or a space) - ;; NO-UNDO if non-nil means do not record undo information - ;; Any existing associations for CIPHER-CHAR or PLAIN-CHAR will be erased. - (setq cipher-char (upcase cipher-char)) - (or (and (>= cipher-char ?A) (<= cipher-char ?Z)) - (error "Bad character")) ;Cipher char must be uppercase letter - (or no-undo - (decipher-add-undo (decipher-get-undo cipher-char plain-char))) - (let ((cipher-string (char-to-string cipher-char)) - (plain-string (char-to-string plain-char)) - case-fold-search ;Case is significant - mapping bound) - (save-excursion - (goto-char (point-min)) - (if (setq mapping (rassoc cipher-char decipher-alphabet)) - (progn - (setcdr mapping ?\ ) - (search-forward-regexp (concat "^([a-z]*" - (char-to-string (car mapping)))) - (decipher-insert ?\ ) - (beginning-of-line))) - (if (setq mapping (assoc plain-char decipher-alphabet)) - (progn - (if (/= ?\ (cdr mapping)) - (decipher-set-map (cdr mapping) ?\ t)) - (setcdr mapping cipher-char) - (search-forward-regexp (concat "^([a-z]*" plain-string)) - (decipher-insert cipher-char) - (beginning-of-line))) - (search-forward-regexp (concat "^([a-z]+ [A-Z]*" cipher-string)) - (decipher-insert plain-char) - (setq case-fold-search t ;Case is not significant - cipher-string (downcase cipher-string)) - (let ((font-lock-fontify-region-function 'ignore)) - ;; insert-and-inherit will pick the right face automatically - (while (search-forward-regexp "^:" nil t) - (setq bound (save-excursion (end-of-line) (point))) - (while (search-forward cipher-string bound 'end) - (decipher-insert plain-char))))))) - -(defun decipher-insert (char) - ;; Insert CHAR in the row below point. It replaces any existing - ;; character in that position. - (let ((col (1- (current-column)))) - (save-excursion - (forward-line) - (or (= ?\> (following-char)) - (= ?\) (following-char)) - (error "Bad location")) - (move-to-column col t) - (or (eolp) - (delete-char 1)) - (insert-and-inherit char)))) - -;;-------------------------------------------------------------------- -;; Checkpoints: -;;-------------------------------------------------------------------- -;; A checkpoint is a comment of the form: -;; %!ABCDEFGHIJKLMNOPQRSTUVWXYZ! Description -;; Such comments are usually placed at the end of the buffer following -;; this header (which is inserted by decipher-make-checkpoint): -;; %--------------------------- -;; % Checkpoints: -;; % abcdefghijklmnopqrstuvwxyz -;; but this is not required; checkpoints can be placed anywhere. -;; -;; The description is optional; all that is required is the alphabet. - -(defun decipher-make-checkpoint (desc) - "Checkpoint the current cipher alphabet. -This records the current alphabet so you can return to it later. -You may have any number of checkpoints. -Type `\\[decipher-restore-checkpoint]' to restore a checkpoint." - (interactive "sCheckpoint description: ") - (or (stringp desc) - (setq desc "")) - (let (alphabet - buffer-read-only ;Make buffer writable - mapping) - (goto-char (point-min)) - (re-search-forward "^)") - (move-to-column 27 t) - (setq alphabet (buffer-substring-no-properties (- (point) 26) (point))) - (if (re-search-forward "^%![A-Z ]+!" nil 'end) - nil ; Add new checkpoint with others - (if (re-search-backward "^% *Local Variables:" nil t) - ;; Add checkpoints before local variables list: - (progn (forward-line -1) - (or (looking-at "^ *$") - (progn (forward-line) (insert ?\n) (forward-line -1))))) - (insert "\n%" (make-string 69 ?\-) - "\n% Checkpoints:\n% abcdefghijklmnopqrstuvwxyz\n")) - (beginning-of-line) - (insert "%!" alphabet "! " desc ?\n))) - -(defun decipher-restore-checkpoint () - "Restore the cipher alphabet from a checkpoint. -If point is not on a checkpoint line, moves to the first checkpoint line. -If point is on a checkpoint, restores that checkpoint. - -Type `\\[decipher-make-checkpoint]' to make a checkpoint." - (interactive) - (beginning-of-line) - (if (looking-at "%!\\([A-Z ]+\\)!") - ;; Restore this checkpoint: - (let ((alphabet (match-string 1)) - buffer-read-only) ;Make buffer writable - (goto-char (point-min)) - (re-search-forward "^)") - (or (eolp) - (delete-region (point) (progn (end-of-line) (point)))) - (insert alphabet) - (decipher-resync)) - ;; Move to the first checkpoint: - (goto-char (point-min)) - (if (re-search-forward "^%![A-Z ]+!" nil t) - (message "Select the checkpoint to restore and type `%s'" - (substitute-command-keys "\\[decipher-restore-checkpoint]")) - (error "No checkpoints in this buffer")))) - -;;-------------------------------------------------------------------- -;; Miscellaneous commands: -;;-------------------------------------------------------------------- - -(defun decipher-complete-alphabet () - "Complete the cipher alphabet. -This fills any blanks in the cipher alphabet with the unused letters -in alphabetical order. Use this when you have a keyword cipher and -you have determined the keyword." - (interactive) - (let ((cipher-char ?A) - (ptr decipher-alphabet) - buffer-read-only ;Make buffer writable - plain-map undo-rec) - (while (setq plain-map (pop ptr)) - (if (equal ?\ (cdr plain-map)) - (progn - (while (rassoc cipher-char decipher-alphabet) - ;; Find the next unused letter - (incf cipher-char)) - (push (cons ?\ cipher-char) undo-rec) - (decipher-set-map cipher-char (car plain-map) t)))) - (decipher-add-undo undo-rec))) - -(defun decipher-show-alphabet () - "Display the current cipher alphabet in the message line." - (interactive) - (message - (mapconcat (lambda (a) - (concat - (char-to-string (car a)) - (char-to-string (cdr a)))) - decipher-alphabet - ""))) - -(defun decipher-resync () - "Reprocess the buffer using the alphabet from the top. -This regenerates all deciphered plaintext and clears the undo list. -You should use this if you edit the ciphertext." - (interactive) - (message "Reprocessing buffer...") - (let (alphabet - buffer-read-only ;Make buffer writable - mapping) - (save-excursion - (decipher-read-alphabet) - (setq alphabet decipher-alphabet) - (goto-char (point-min)) - (and (re-search-forward "^).+" nil t) - (replace-match ")" nil nil)) - (while (re-search-forward "^>.+" nil t) - (replace-match ">" nil nil)) - (decipher-read-alphabet) - (while (setq mapping (pop alphabet)) - (or (equal ?\ (cdr mapping)) - (decipher-set-map (cdr mapping) (car mapping)))))) - (setq decipher-undo-list nil - decipher-undo-list-size 0) - (message "Reprocessing buffer...done")) - -;;-------------------------------------------------------------------- -;; Miscellaneous functions: -;;-------------------------------------------------------------------- - -(defun decipher-read-alphabet () - "Build the decipher-alphabet from the alphabet line in the buffer." - (save-excursion - (goto-char (point-min)) - (search-forward-regexp "^)") - (move-to-column 27 t) - (setq decipher-alphabet nil) - (let ((plain-char ?z)) - (while (>= plain-char ?a) - (backward-char) - (push (cons plain-char (following-char)) decipher-alphabet) - (decf plain-char))))) - -;;;=================================================================== -;;; Analyzing ciphertext: -;;;=================================================================== - -(defun decipher-frequency-count () - "Display the frequency count in the statistics buffer." - (interactive) - (decipher-analyze) - (decipher-display-regexp "^A" "^[A-Z][A-Z]")) - -(defun decipher-digram-list () - "Display the list of digrams in the statistics buffer." - (interactive) - (decipher-analyze) - (decipher-display-regexp "[A-Z][A-Z] +[0-9]" "^$")) - -(defun decipher-adjacency-list (cipher-char) - "Display the adjacency list for the letter at point. -The adjacency list shows all letters which come next to CIPHER-CHAR. - -An adjacency list (for the letter X) looks like this: - 1 1 1 1 1 3 2 1 3 8 -X: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z * 11 14 9% - 1 1 1 2 1 1 2 5 7 -This says that X comes before D once, and after B once. X begins 5 -words, and ends 3 words (`*' represents a space). X comes before 8 -different letters, after 7 differerent letters, and is next to a total -of 11 different letters. It occurs 14 times, making up 9% of the -ciphertext." - (interactive (list (upcase (following-char)))) - (decipher-analyze) - (let (start end) - (save-excursion - (set-buffer (decipher-stats-buffer)) - (goto-char (point-min)) - (or (re-search-forward (format "^%c: " cipher-char) nil t) - (error "Character `%c' is not used in ciphertext." cipher-char)) - (forward-line -1) - (setq start (point)) - (forward-line 3) - (setq end (point))) - (decipher-display-range start end))) - -;;-------------------------------------------------------------------- -(defun decipher-analyze () - "Perform frequency analysis on the current buffer if necessary." - (cond - ;; If this is the statistics buffer, do nothing: - ((eq major-mode 'decipher-stats-mode)) - ;; If this is the Decipher buffer, see if the stats buffer exists: - ((eq major-mode 'decipher-mode) - (or (and (bufferp decipher-stats-buffer) - (buffer-name decipher-stats-buffer)) - (decipher-analyze-buffer))) - ;; Otherwise: - (t (error "This buffer is not in Decipher mode")))) - -;;-------------------------------------------------------------------- -(defun decipher-display-range (start end) - "Display text between START and END in the statistics buffer. -START and END are positions in the statistics buffer. Makes the -statistics buffer visible and sizes the window to just fit the -displayed text, but leaves the current window selected." - (let ((stats-buffer (decipher-stats-buffer)) - (current-window (selected-window)) - (pop-up-windows t)) - (or (eq (current-buffer) stats-buffer) - (pop-to-buffer stats-buffer)) - (goto-char start) - (or (one-window-p t) - (enlarge-window (- (1+ (count-lines start end)) (window-height)))) - (recenter 0) - (select-window current-window))) - -(defun decipher-display-regexp (start-regexp end-regexp) - "Display text between two regexps in the statistics buffer. - -START-REGEXP matches the first line to display. -END-REGEXP matches the line after that which ends the display. -The ending line is included in the display unless it is blank." - (let (start end) - (save-excursion - (set-buffer (decipher-stats-buffer)) - (goto-char (point-min)) - (re-search-forward start-regexp) - (beginning-of-line) - (setq start (point)) - (re-search-forward end-regexp) - (beginning-of-line) - (or (looking-at "^ *$") - (forward-line 1)) - (setq end (point))) - (decipher-display-range start end))) - -;;-------------------------------------------------------------------- -(defun decipher-loop-with-breaks (func) - "Loop through ciphertext, calling FUNC once for each letter & word division. - -FUNC is called with no arguments, and its return value is unimportant. -It may examine `decipher-char' to see the current ciphertext -character. `decipher-char' contains either an uppercase letter or a space. - -FUNC is called exactly once between words, with `decipher-char' set to -a space. - -See `decipher-loop-no-breaks' if you do not care about word divisions." - (let ((decipher-char ?\ ) - (decipher--loop-prev-char ?\ )) - (save-excursion - (goto-char (point-min)) - (funcall func) ;Space marks beginning of first word - (while (search-forward-regexp "^:" nil t) - (while (not (eolp)) - (setq decipher-char (upcase (following-char))) - (or (and (>= decipher-char ?A) (<= decipher-char ?Z)) - (setq decipher-char ?\ )) - (or (and (equal decipher-char ?\ ) - (equal decipher--loop-prev-char ?\ )) - (funcall func)) - (setq decipher--loop-prev-char decipher-char) - (forward-char)) - (or (equal decipher-char ?\ ) - (progn - (setq decipher-char ?\ ; - decipher--loop-prev-char ?\ ) - (funcall func))))))) - -(defun decipher-loop-no-breaks (func) - "Loop through ciphertext, calling FUNC once for each letter. - -FUNC is called with no arguments, and its return value is unimportant. -It may examine `decipher-char' to see the current ciphertext letter. -`decipher-char' contains an uppercase letter. - -Punctuation and spacing in the ciphertext are ignored. -See `decipher-loop-with-breaks' if you care about word divisions." - (let (decipher-char) - (save-excursion - (goto-char (point-min)) - (while (search-forward-regexp "^:" nil t) - (while (not (eolp)) - (setq decipher-char (upcase (following-char))) - (and (>= decipher-char ?A) - (<= decipher-char ?Z) - (funcall func)) - (forward-char)))))) - -;;-------------------------------------------------------------------- -;; Perform the analysis: -;;-------------------------------------------------------------------- - -(defun decipher-insert-frequency-counts (freq-list total) - "Insert frequency counts in current buffer. -Each element of FREQ-LIST is a list (LETTER FREQ ...). -TOTAL is the total number of letters in the ciphertext." - (let ((i 4) temp-list) - (while (> i 0) - (setq temp-list freq-list) - (while temp-list - (insert (caar temp-list) - (format "%4d%3d%% " - (cadar temp-list) - (/ (* 100 (cadar temp-list)) total))) - (setq temp-list (nthcdr 4 temp-list))) - (insert ?\n) - (setq freq-list (cdr freq-list) - i (1- i))))) - -(defun decipher--analyze () - ;; Perform frequency analysis on ciphertext. - ;; - ;; This function is called repeatedly with decipher-char set to each - ;; character of ciphertext. It uses decipher--prev-char to remember - ;; the previous ciphertext character. - ;; - ;; It builds several data structures, which must be initialized - ;; before the first call to decipher--analyze. The arrays are - ;; indexed with A = 0, B = 1, ..., Z = 25, SPC = 26 (if used). - ;; decipher--after: (initialize to zeros) - ;; A vector of 26 vectors of 27 integers. The first vector - ;; represents the number of times A follows each character, the - ;; second vector represents B, and so on. - ;; decipher--before: (initialize to zeros) - ;; The same as decipher--after, but representing the number of - ;; times the character precedes each other character. - ;; decipher--digram-list: (initialize to nil) - ;; An alist with an entry for each digram (2-character sequence) - ;; encountered. Each element is a cons cell (DIGRAM . FREQ), - ;; where DIGRAM is a 2 character string and FREQ is the number - ;; of times it occurs. - ;; decipher--freqs: (initialize to zeros) - ;; A vector of 26 integers, counting the number of occurrences - ;; of the corresponding characters. - (setq decipher--digram (format "%c%c" decipher--prev-char decipher-char)) - (incf (cdr (or (assoc decipher--digram decipher--digram-list) - (car (push (cons decipher--digram 0) - decipher--digram-list))))) - (and (>= decipher--prev-char ?A) - (incf (aref (aref decipher--before (- decipher--prev-char ?A)) - (if (equal decipher-char ?\ ) - 26 - (- decipher-char ?A))))) - (and (>= decipher-char ?A) - (incf (aref decipher--freqs (- decipher-char ?A))) - (incf (aref (aref decipher--after (- decipher-char ?A)) - (if (equal decipher--prev-char ?\ ) - 26 - (- decipher--prev-char ?A))))) - (setq decipher--prev-char decipher-char)) - -(defun decipher--digram-counts (counts) - "Generate the counts for an adjacency list." - (let ((total 0)) - (concat - (mapconcat (lambda (x) - (cond ((> x 99) (incf total) "XX") - ((> x 0) (incf total) (format "%2d" x)) - (t " "))) - counts - "") - (format "%4d" (if (> (aref counts 26) 0) - (1- total) ;Don't count space - total))))) - -(defun decipher--digram-total (before-count after-count) - "Count the number of different letters a letter appears next to." - ;; We do not include spaces (word divisions) in this count. - (let ((total 0) - (i 26)) - (while (>= (decf i) 0) - (if (or (> (aref before-count i) 0) - (> (aref after-count i) 0)) - (incf total))) - total)) - -(defun decipher-analyze-buffer () - "Perform frequency analysis and store results in statistics buffer. -Creates the statistics buffer if it doesn't exist." - (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\*)) - (decipher--before (make-vector 26 nil)) - (decipher--after (make-vector 26 nil)) - (decipher--freqs (make-vector 26 0)) - (total-chars 0) - decipher--digram decipher--digram-list freq-list) - (message "Scanning buffer...") - (let ((i 26)) - (while (>= (decf i) 0) - (aset decipher--before i (make-vector 27 0)) - (aset decipher--after i (make-vector 27 0)))) - (if decipher-ignore-spaces - (progn - (decipher-loop-no-breaks 'decipher--analyze) - ;; The first character of ciphertext was marked as following a space: - (let ((i 26)) - (while (>= (decf i) 0) - (aset (aref decipher--after i) 26 0)))) - (decipher-loop-with-breaks 'decipher--analyze)) - (message "Processing results...") - (setcdr (last decipher--digram-list 2) nil) ;Delete the phony "* " digram - ;; Sort the digram list by frequency and alphabetical order: - (setq decipher--digram-list (sort (sort decipher--digram-list - (lambda (a b) (string< (car a) (car b)))) - (lambda (a b) (> (cdr a) (cdr b))))) - ;; Generate the frequency list: - ;; Each element is a list of 3 elements (LETTER FREQ DIFFERENT), - ;; where LETTER is the ciphertext character, FREQ is the number - ;; of times it occurs, and DIFFERENT is the number of different - ;; letters it appears next to. - (let ((i 26)) - (while (>= (decf i) 0) - (setq freq-list - (cons (list (+ i ?A) - (aref decipher--freqs i) - (decipher--digram-total (aref decipher--before i) - (aref decipher--after i))) - freq-list) - total-chars (+ total-chars (aref decipher--freqs i))))) - (save-excursion - ;; Switch to statistics buffer, creating it if necessary: - (set-buffer (decipher-stats-buffer t)) - ;; This can't happen, but it never hurts to double-check: - (or (eq major-mode 'decipher-stats-mode) - (error "Buffer %s is not in Decipher-Stats mode" (buffer-name))) - (setq buffer-read-only nil) - (erase-buffer) - ;; Display frequency counts for letters A-Z: - (decipher-insert-frequency-counts freq-list total-chars) - (insert ?\n) - ;; Display frequency counts for letters in order of frequency: - (setq freq-list (sort freq-list - (lambda (a b) (> (second a) (second b))))) - (decipher-insert-frequency-counts freq-list total-chars) - ;; Display letters in order of frequency: - (insert ?\n (mapconcat (lambda (a) (char-to-string (car a))) - freq-list nil) - "\n\n") - ;; Display list of digrams in order of frequency: - (let* ((rows (floor (+ (length decipher--digram-list) 9) 10)) - (i rows) - temp-list) - (while (> i 0) - (setq temp-list decipher--digram-list) - (while temp-list - (insert (caar temp-list) - (format "%3d " - (cdar temp-list))) - (setq temp-list (nthcdr rows temp-list))) - (delete-horizontal-space) - (insert ?\n) - (setq decipher--digram-list (cdr decipher--digram-list) - i (1- i)))) - ;; Display adjacency list for each letter, sorted in descending - ;; order of the number of adjacent letters: - (setq freq-list (sort freq-list - (lambda (a b) (> (third a) (third b))))) - (let ((temp-list freq-list) - entry i) - (while (setq entry (pop temp-list)) - (if (equal 0 (second entry)) - nil ;This letter was not used - (setq i (- (car entry) ?A)) - (insert ?\n " " - (decipher--digram-counts (aref decipher--before i)) ?\n - (car entry) - ": A B C D E F G H I J K L M N O P Q R S T U V W X Y Z *" - (format "%4d %4d %3d%%\n " - (third entry) (second entry) - (/ (* 100 (second entry)) total-chars)) - (decipher--digram-counts (aref decipher--after i)) ?\n)))) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - )) - (message nil)) - -;;==================================================================== -;; Statistics Buffer: -;;==================================================================== - -(defun decipher-stats-mode () - "Major mode for displaying ciphertext statistics." - (interactive) - (kill-all-local-variables) - (setq buffer-read-only t - buffer-undo-list t ;Disable undo - case-fold-search nil ;Case is significant when searching - indent-tabs-mode nil ;Do not use tab characters - major-mode 'decipher-stats-mode - mode-name "Decipher-Stats") - (use-local-map decipher-stats-mode-map) - (run-hooks 'decipher-stats-mode-hook)) -(put 'decipher-stats-mode 'mode-class 'special) - -;;-------------------------------------------------------------------- - -(defun decipher-display-stats-buffer () - "Make the statistics buffer visible, but do not select it." - (let ((stats-buffer (decipher-stats-buffer)) - (current-window (selected-window))) - (or (eq (current-buffer) stats-buffer) - (progn - (pop-to-buffer stats-buffer) - (select-window current-window))))) - -(defun decipher-stats-buffer (&optional create) - "Return the buffer used for decipher statistics. -If CREATE is non-nil, create the buffer if it doesn't exist. -This is guaranteed to return a buffer in Decipher-Stats mode; -if it can't, it signals an error." - (cond - ;; We may already be in the statistics buffer: - ((eq major-mode 'decipher-stats-mode) - (current-buffer)) - ;; See if decipher-stats-buffer exists: - ((and (bufferp decipher-stats-buffer) - (buffer-name decipher-stats-buffer)) - (or (save-excursion - (set-buffer decipher-stats-buffer) - (eq major-mode 'decipher-stats-mode)) - (error "Buffer %s is not in Decipher-Stats mode" - (buffer-name decipher-stats-buffer))) - decipher-stats-buffer) - ;; Create a new buffer if requested: - (create - (let ((stats-name (concat "*" (buffer-name) "*"))) - (setq decipher-stats-buffer - (if (eq 'decipher-stats-mode - (cdr-safe (assoc 'major-mode - (buffer-local-variables - (get-buffer stats-name))))) - ;; We just lost track of the statistics buffer: - (get-buffer stats-name) - (generate-new-buffer stats-name)))) - (save-excursion - (set-buffer decipher-stats-buffer) - (decipher-stats-mode)) - decipher-stats-buffer) - ;; Give up: - (t (error "No statistics buffer")))) - -;;==================================================================== - -(provide 'decipher) - -;;;(defun decipher-show-undo-list () -;;; "Display the undo list (for debugging purposes)." -;;; (interactive) -;;; (with-output-to-temp-buffer "*Decipher Undo*" -;;; (let ((undo-list decipher-undo-list) -;;; undo-rec undo-map) -;;; (save-excursion -;;; (set-buffer "*Decipher Undo*") -;;; (while (setq undo-rec (pop undo-list)) -;;; (or (consp (car undo-rec)) -;;; (setq undo-rec (list undo-rec))) -;;; (insert ?\() -;;; (while (setq undo-map (pop undo-rec)) -;;; (insert (cdr undo-map) (car undo-map) ?\ )) -;;; (delete-backward-char 1) -;;; (insert ")\n")))))) - -;;; decipher.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/dissociate.el --- a/lisp/games/dissociate.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -;;; dissociate.el --- scramble text amusingly for Emacs. - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; The single entry point, `dissociated-press', applies a travesty -;; generator to the current buffer. The results can be quite amusing. - -;;; Code: - -;;;###autoload -(defun dissociated-press (&optional arg) - "Dissociate the text of the current buffer. -Output goes in buffer named *Dissociation*, -which is redisplayed each time text is added to it. -Every so often the user must say whether to continue. -If ARG is positive, require ARG chars of continuity. -If ARG is negative, require -ARG words of continuity. -Default is 2." - (interactive "P") - (setq arg (if arg (prefix-numeric-value arg) 2)) - (let* ((inbuf (current-buffer)) - (outbuf (get-buffer-create "*Dissociation*")) - (move-function (if (> arg 0) 'forward-char 'forward-word)) - (move-amount (if (> arg 0) arg (- arg))) - (search-function (if (> arg 0) 'search-forward 'word-search-forward)) - (last-query-point 0)) - (if (= (point-max) (point-min)) - (error "The buffer contains no text to start from")) - (switch-to-buffer outbuf) - (erase-buffer) - (while - (save-excursion - (goto-char last-query-point) - (vertical-motion (- (window-height) 4)) - (or (= (point) (point-max)) - (and (progn (goto-char (point-max)) - (y-or-n-p "Continue dissociation? ")) - (progn - (message "") - (recenter 1) - (setq last-query-point (point-max)) - t)))) - (let (start end) - (save-excursion - (set-buffer inbuf) - (setq start (point)) - (if (eq move-function 'forward-char) - (progn - (setq end (+ start (+ move-amount (random 16)))) - (if (> end (point-max)) - (setq end (+ 1 move-amount (random 16)))) - (goto-char end)) - (funcall move-function - (+ move-amount (random 16)))) - (setq end (point))) - (let ((opoint (point))) - (insert-buffer-substring inbuf start end) - (save-excursion - (goto-char opoint) - (end-of-line) - (and (> (current-column) fill-column) - (do-auto-fill))))) - (save-excursion - (set-buffer inbuf) - (if (eobp) - (goto-char (point-min)) - (let ((overlap - (buffer-substring (prog1 (point) - (funcall move-function - (- move-amount))) - (point)))) - (goto-char (1+ (random (1- (point-max))))) - (or (funcall search-function overlap nil t) - (let ((opoint (point))) - (goto-char 1) - (funcall search-function overlap opoint t)))))) - (sit-for 0)))) - -;;; dissociate.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/doctor.el --- a/lisp/games/doctor.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1641 +0,0 @@ -;;; doctor.el --- psychological help for frustrated users. -;;; (uncensored version--see below) - -;; Copyright (C) 1985, 1987, 1994, 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; The single entry point `doctor', simulates a Rogerian analyst using -;; phrase-production techniques similar to the classic ELIZA demonstration -;; of pseudo-AI. - -;; Original Censorship message: -;; This file has been censored by the Communications Decency Act. -;; Some of its features were removed. The law was promoted as a ban -;; on pornography, but it bans far more than that. The doctor program -;; did not contain pornography, but part of it was prohibited -;; nonetheless. - -;; For information on US government censorship of the Internet, and -;; what you can do to bring back freedom of the press, see the web -;; site http://www.vtw.org/ - -;;; Code: - -(defun doctor-cadr (x) (car (cdr x))) -(defun doctor-caddr (x) (car (cdr (cdr x)))) -(defun doctor-cddr (x) (cdr (cdr x))) - -(defun // (x) x) - -(defmacro $ (what) - "quoted arg form of doctor-$" - (list 'doctor-$ (list 'quote what))) - -(defun doctor-$ (what) - "Return the car of a list, rotating the list each time" - (let* ((vv (symbol-value what)) - (first (car vv)) - (ww (append (cdr vv) (list first)))) - (set what ww) - first)) - -(defvar doctor-mode-map nil) -(if doctor-mode-map - nil - (setq doctor-mode-map (make-sparse-keymap)) - (define-key doctor-mode-map "\n" 'doctor-read-print) - (define-key doctor-mode-map "\r" 'doctor-ret-or-read)) - -(defun doctor-mode () - "Major mode for running the Doctor (Eliza) program. -Like Text mode with Auto Fill mode -except that RET when point is after a newline, or LFD at any time, -reads the sentence before point, and prints the Doctor's answer." - (interactive) - (text-mode) - (make-doctor-variables) - (use-local-map doctor-mode-map) - (setq major-mode 'doctor-mode) - (setq mode-name "Doctor") - (turn-on-auto-fill) - (doctor-type '(i am the psychotherapist \. - ($ please) ($ describe) your ($ problems) \. - each time you are finished talking, type \R\E\T twice \.)) - (insert "\n")) - -(defun make-doctor-variables () - (make-local-variable 'monosyllables) - (setq monosyllables - " - Your attitude at the end of the session was wholly unacceptable. - Please try to come back next time with a willingness to speak more - freely. If you continue to refuse to talk openly, there is little - I can do to help! -") - (make-local-variable 'typos) - (setq typos - (mapcar (function (lambda (x) - (put (car x) 'doctor-correction (doctor-cadr x)) - (put (doctor-cadr x) 'doctor-expansion (doctor-caddr x)) - (car x))) - '((theyll they\'ll (they will)) - (theyre they\'re (they are)) - (hes he\'s (he is)) - (he7s he\'s (he is)) - (im i\'m (you are)) - (i7m i\'m (you are)) - (isa is\ a (is a)) - (thier their (their)) - (dont don\'t (do not)) - (don7t don\'t (do not)) - (you7re you\'re (i am)) - (you7ve you\'ve (i have)) - (you7ll you\'ll (i will))))) - (make-local-variable 'found) - (setq found nil) - (make-local-variable 'owner) - (setq owner nil) - (make-local-variable 'history) - (setq history nil) - (make-local-variable '*debug*) - (setq *debug* nil) - (make-local-variable 'inter) - (setq inter - '((well\,) - (hmmm \.\.\.\ so\,) - (so) - (\.\.\.and) - (then))) - (make-local-variable 'continue) - (setq continue - '((continue) - (proceed) - (go on) - (keep going) )) - (make-local-variable 'relation) - (setq relation - '((your relationship with) - (something you remember about) - (your feelings toward) - (some experiences you have had with) - (how you feel about))) - (make-local-variable 'fears) - (setq fears '( (($ whysay) you are ($ afraidof) (// feared) \?) - (you seem terrified by (// feared) \.) - (when did you first feel ($ afraidof) (// feared) \?) )) - (make-local-variable 'sure) - (setq sure '((sure)(positive)(certain)(absolutely sure))) - (make-local-variable 'afraidof) - (setq afraidof '( (afraid of) (frightened by) (scared of) )) - (make-local-variable 'areyou) - (setq areyou '( (are you)(have you been)(have you been) )) - (make-local-variable 'isrelated) - (setq isrelated '( (has something to do with)(is related to) - (could be the reason for) (is caused by)(is because of))) - (make-local-variable 'arerelated) - (setq arerelated '((have something to do with)(are related to) - (could have caused)(could be the reason for) (are caused by) - (are because of))) - (make-local-variable 'moods) - (setq moods '( (($ areyou)(// found) often \?) - (what causes you to be (// found) \?) - (($ whysay) you are (// found) \?) )) - (make-local-variable 'maybe) - (setq maybe - '((maybe) - (perhaps) - (possibly))) - (make-local-variable 'whatwhen) - (setq whatwhen - '((what happened when) - (what would happen if))) - (make-local-variable 'hello) - (setq hello - '((how do you do \?) (hello \.) (howdy!) (hello \.) (hi \.) (hi there \.))) - (make-local-variable 'drnk) - (setq drnk - '((do you drink a lot of (// found) \?) - (do you get drunk often \?) - (($ describe) your drinking habits \.) )) - (make-local-variable 'drugs) - (setq drugs '( (do you use (// found) often \?)(($ areyou) - addicted to (// found) \?)(do you realize that drugs can - be very harmful \?)(($ maybe) you should try to quit using (// found) - \.))) - (make-local-variable 'whywant) - (setq whywant '( (($ whysay) (// subj) might ($ want) (// obj) \?) - (how does it feel to want \?) - (why should (// subj) get (// obj) \?) - (when did (// subj) first ($ want) (// obj) \?) - (($ areyou) obsessed with (// obj) \?) - (why should i give (// obj) to (// subj) \?) - (have you ever gotten (// obj) \?) )) - (make-local-variable 'canyou) - (setq canyou '((of course i can \.) - (why should i \?) - (what makes you think i would even want to \?) - (i am the doctor\, i can do anything i damn please \.) - (not really\, it\'s not up to me \.) - (depends\, how important is it \?) - (i could\, but i don\'t think it would be a wise thing to do \.) - (can you \?) - (maybe i can\, maybe i can\'t \.\.\.) - (i don\'t think i should do that \.))) - (make-local-variable 'want) - (setq want '( (want) (desire) (wish) (want) (hope) )) - (make-local-variable 'shortlst) - (setq shortlst - '((can you elaborate on that \?) - (($ please) continue \.) - (go on\, don\'t be afraid \.) - (i need a little more detail please \.) - (you\'re being a bit brief\, ($ please) go into detail \.) - (can you be more explicit \?) - (and \?) - (($ please) go into more detail \?) - (you aren\'t being very talkative today\!) - (is that all there is to it \?) - (why must you respond so briefly \?))) - - (make-local-variable 'famlst) - (setq famlst - '((tell me ($ something) about (// owner) family \.) - (you seem to dwell on (// owner) family \.) - (($ areyou) hung up on (// owner) family \?))) - (make-local-variable 'huhlst) - (setq huhlst - '((($ whysay)(// sent) \?) - (is it because of ($ things) that you say (// sent) \?) )) - (make-local-variable 'longhuhlst) - (setq longhuhlst - '((($ whysay) that \?) - (i don\'t understand \.) - (($ thlst)) - (($ areyou) ($ afraidof) that \?))) - (make-local-variable 'feelings-about) - (setq feelings-about - '((feelings about) - (apprehensions toward) - (thoughts on) - (emotions toward))) - (make-local-variable 'random-adjective) - (setq random-adjective - '((vivid) - (emotionally stimulating) - (exciting) - (boring) - (interesting) - (recent) - (random) ;How can we omit this? - (unusual) - (shocking) - (embarrassing))) - (make-local-variable 'whysay) - (setq whysay - '((why do you say) - (what makes you believe) - (are you sure that) - (do you really think) - (what makes you think) )) - (make-local-variable 'isee) - (setq isee - '((i see \.\.\.) - (yes\,) - (i understand \.) - (oh \.) )) - (make-local-variable 'please) - (setq please - '((please\,) - (i would appreciate it if you would) - (perhaps you could) - (please\,) - (would you please) - (why don\'t you) - (could you))) - (make-local-variable 'bye) - (setq bye - '((my secretary will send you a bill \.) - (bye bye \.) - (see ya \.) - (ok\, talk to you some other time \.) - (talk to you later \.) - (ok\, have fun \.) - (ciao \.))) - (make-local-variable 'something) - (setq something - '((something) - (more) - (how you feel))) - (make-local-variable 'things) - (setq things - '(;(your interests in computers) ;; let's make this less computer oriented - ;(the machines you use) - (your plans) - ;(your use of computers) - (your life) - ;(other machines you use) - (the people you hang around with) - ;(computers you like) - (problems at school) - (any hobbies you have) - ;(other computers you use) - (your sex life) - (hangups you have) - (your inhibitions) - (some problems in your childhood) - ;(knowledge of computers) - (some problems at home))) - (make-local-variable 'describe) - (setq describe - '((describe) - (tell me about) - (talk about) - (discuss) - (tell me more about) - (elaborate on))) - (make-local-variable 'ibelieve) - (setq ibelieve - '((i believe) (i think) (i have a feeling) (it seems to me that) - (it looks like))) - (make-local-variable 'problems) - (setq problems '( (problems) - (inhibitions) - (hangups) - (difficulties) - (anxieties) - (frustrations) )) - (make-local-variable 'bother) - (setq bother - '((does it bother you that) - (are you annoyed that) - (did you ever regret) - (are you sorry) - (are you satisfied with the fact that))) - (make-local-variable 'machlst) - (setq machlst - '((you have your mind on (// found) \, it seems \.) - (you think too much about (// found) \.) - (you should try taking your mind off of (// found)\.) - (are you a computer hacker \?))) - (make-local-variable 'qlist) - (setq qlist - '((what do you think \?) - (i\'ll ask the questions\, if you don\'t mind!) - (i could ask the same thing myself \.) - (($ please) allow me to do the questioning \.) - (i have asked myself that question many times \.) - (($ please) try to answer that question yourself \.))) - (make-local-variable 'elist) - (setq elist - '((($ please) try to calm yourself \.) - (you seem very excited \. relax \. ($ please) ($ describe) ($ things) - \.) - (you\'re being very emotional \. calm down \.))) - (make-local-variable 'foullst) - (setq foullst - '((($ please) watch your tongue!) - (($ please) avoid such unwholesome thoughts \.) - (($ please) get your mind out of the gutter \.) - (such lewdness is not appreciated \.))) - (make-local-variable 'deathlst) - (setq deathlst - '((this is not a healthy way of thinking \.) - (($ bother) you\, too\, may die someday \?) - (i am worried by your obsession with this topic!) - (did you watch a lot of crime and violence on television as a child \?)) - ) - (make-local-variable 'sexlst) - (setq sexlst - '((($ areyou) ($ afraidof) sex \?) - (($ describe)($ something) about your sexual history \.) - (($ please)($ describe) your sex life \.\.\.) - (($ describe) your ($ feelings-about) your sexual partner \.) - (($ describe) your most ($ random-adjective) sexual experience \.) - (($ areyou) satisfied with (// lover) \.\.\. \?))) - (make-local-variable 'neglst) - (setq neglst - '((why not \?) - (($ bother) i ask that \?) - (why not \?) - (why not \?) - (how come \?) - (($ bother) i ask that \?))) - (make-local-variable 'beclst) - (setq beclst '( - (is it because (// sent) that you came to me \?) - (($ bother)(// sent) \?) - (when did you first know that (// sent) \?) - (is the fact that (// sent) the real reason \?) - (does the fact that (// sent) explain anything else \?) - (($ areyou)($ sure)(// sent) \? ) )) - (make-local-variable 'shortbeclst) - (setq shortbeclst '( - (($ bother) i ask you that \?) - (that\'s not much of an answer!) - (($ inter) why won\'t you talk about it \?) - (speak up!) - (($ areyou) ($ afraidof) talking about it \?) - (don\'t be ($ afraidof) elaborating \.) - (($ please) go into more detail \.))) - (make-local-variable 'thlst) - (setq thlst '( - (($ maybe)($ things)($ arerelated) this \.) - (is it because of ($ things) that you are going through all this \?) - (how do you reconcile ($ things) \? ) - (($ maybe) this ($ isrelated)($ things) \?) )) - (make-local-variable 'remlst) - (setq remlst '( (earlier you said ($ history) \?) - (you mentioned that ($ history) \?) - (($ whysay)($ history) \? ) )) - (make-local-variable 'toklst) - (setq toklst - '((is this how you relax \?) - (how long have you been smoking grass \?) - (($ areyou) ($ afraidof) of being drawn to using harder stuff \?))) - (make-local-variable 'states) - (setq states - '((do you get (// found) often \?) - (do you enjoy being (// found) \?) - (what makes you (// found) \?) - (how often ($ areyou)(// found) \?) - (when were you last (// found) \?))) - (make-local-variable 'replist) - (setq replist - '((i . (you)) - (my . (your)) - (me . (you)) - (you . (me)) - (your . (my)) - (mine . (yours)) - (yours . (mine)) - (our . (your)) - (ours . (yours)) - (we . (you)) - (dunno . (do not know)) -;; (yes . ()) - (no\, . ()) - (yes\, . ()) - (ya . (i)) - (aint . (am not)) - (wanna . (want to)) - (gimme . (give me)) - (gotta . (have to)) - (gonna . (going to)) - (never . (not ever)) - (doesn\'t . (does not)) - (don\'t . (do not)) - (aren\'t . (are not)) - (isn\'t . (is not)) - (won\'t . (will not)) - (can\'t . (cannot)) - (haven\'t . (have not)) - (i\'m . (you are)) - (ourselves . (yourselves)) - (myself . (yourself)) - (yourself . (myself)) - (you\'re . (i am)) - (you\'ve . (i have)) - (i\'ve . (you have)) - (i\'ll . (you will)) - (you\'ll . (i shall)) - (i\'d . (you would)) - (you\'d . (i would)) - (here . (there)) - (please . ()) - (eh\, . ()) - (eh . ()) - (oh\, . ()) - (oh . ()) - (shouldn\'t . (should not)) - (wouldn\'t . (would not)) - (won\'t . (will not)) - (hasn\'t . (has not)))) - (make-local-variable 'stallmanlst) - (setq stallmanlst '( - (($ describe) your ($ feelings-about) him \.) - (($ areyou) a friend of Stallman \?) - (($ bother) Stallman is ($ random-adjective) \?) - (($ ibelieve) you are ($ afraidof) him \.))) - (make-local-variable 'schoollst) - (setq schoollst '( - (($ describe) your (// found) \.) - (($ bother) your grades could ($ improve) \?) - (($ areyou) ($ afraidof) (// found) \?) - (($ maybe) this ($ isrelated) to your attitude \.) - (($ areyou) absent often \?) - (($ maybe) you should study ($ something) \.))) - (make-local-variable 'improve) - (setq improve '((improve) (be better) (be improved) (be higher))) - (make-local-variable 'elizalst) - (setq elizalst '( - (($ areyou) ($ sure) \?) - (($ ibelieve) you have ($ problems) with (// found) \.) - (($ whysay) (// sent) \?))) - (make-local-variable 'sportslst) - (setq sportslst '( - (tell me ($ something) about (// found) \.) - (($ describe) ($ relation) (// found) \.) - (do you find (// found) ($ random-adjective) \?))) - (make-local-variable 'mathlst) - (setq mathlst '( - (($ describe) ($ something) about math \.) - (($ maybe) your ($ problems) ($ arerelated) (// found) \.) - (i do\'nt know much (// found) \, but ($ continue) - anyway \.))) - (make-local-variable 'zippylst) - (setq zippylst '( - (($ areyou) Zippy \?) - (($ ibelieve) you have some serious ($ problems) \.) - (($ bother) you are a pinhead \?))) - (make-local-variable 'chatlst) - (setq chatlst '( - (($ maybe) we could chat \.) - (($ please) ($ describe) ($ something) about chat mode \.) - (($ bother) our discussion is so ($ random-adjective) \?))) - (make-local-variable 'abuselst) - (setq abuselst '( - (($ please) try to be less abusive \.) - (($ describe) why you call me (// found) \.) - (i\'ve had enough of you!))) - (make-local-variable 'abusewords) - (setq abusewords '(boring bozo clown clumsy cretin dumb dummy - fool foolish gnerd gnurd idiot jerk - lose loser louse lousy luse luser - moron nerd nurd oaf oafish reek - stink stupid tool toolish twit)) - (make-local-variable 'howareyoulst) - (setq howareyoulst '((how are you) (hows it going) (hows it going eh) - (how\'s it going) (how\'s it going eh) (how goes it) - (whats up) (whats new) (what\'s up) (what\'s new) - (howre you) (how\'re you) (how\'s everything) - (how is everything) (how do you do) - (how\'s it hanging) (que pasa) - (how are you doing) (what do you say))) - (make-local-variable 'whereoutp) - (setq whereoutp '( huh remem rthing ) ) - (make-local-variable 'subj) - (setq subj nil) - (make-local-variable 'verb) - (setq verb nil) - (make-local-variable 'obj) - (setq obj nil) - (make-local-variable 'feared) - (setq feared nil) - (make-local-variable 'observation-list) - (setq observation-list nil) - (make-local-variable 'repetitive-shortness) - (setq repetitive-shortness '(0 . 0)) - (make-local-variable '**mad**) - (setq **mad** nil) - (make-local-variable 'rms-flag) - (setq rms-flag nil) - (make-local-variable 'eliza-flag) - (setq eliza-flag nil) - (make-local-variable 'zippy-flag) - (setq zippy-flag nil) - (make-local-variable 'lover) - (setq lover '(your partner)) - (make-local-variable 'bak) - (setq bak nil) - (make-local-variable 'lincount) - (setq lincount 0) - (make-local-variable '*print-upcase*) - (setq *print-upcase* nil) - (make-local-variable '*print-space*) - (setq *print-space* nil) - (make-local-variable 'howdyflag) - (setq howdyflag nil) - (make-local-variable 'object) - (setq object nil)) - -;; Define equivalence classes of words that get treated alike. - -(defun doctor-meaning (x) (get x 'doctor-meaning)) - -(defmacro doctor-put-meaning (symb val) - "Store the base meaning of a word on the property list." - (list 'put (list 'quote symb) ''doctor-meaning val)) - -(doctor-put-meaning howdy 'howdy) -(doctor-put-meaning hi 'howdy) -(doctor-put-meaning greetings 'howdy) -(doctor-put-meaning hello 'howdy) -(doctor-put-meaning tops20 'mach) -(doctor-put-meaning tops-20 'mach) -(doctor-put-meaning tops 'mach) -(doctor-put-meaning pdp11 'mach) -(doctor-put-meaning computer 'mach) -(doctor-put-meaning unix 'mach) -(doctor-put-meaning machine 'mach) -(doctor-put-meaning computers 'mach) -(doctor-put-meaning machines 'mach) -(doctor-put-meaning pdp11s 'mach) -(doctor-put-meaning foo 'mach) -(doctor-put-meaning foobar 'mach) -(doctor-put-meaning multics 'mach) -(doctor-put-meaning macsyma 'mach) -(doctor-put-meaning teletype 'mach) -(doctor-put-meaning la36 'mach) -(doctor-put-meaning vt52 'mach) -(doctor-put-meaning zork 'mach) -(doctor-put-meaning trek 'mach) -(doctor-put-meaning startrek 'mach) -(doctor-put-meaning advent 'mach) -(doctor-put-meaning pdp 'mach) -(doctor-put-meaning dec 'mach) -(doctor-put-meaning commodore 'mach) -(doctor-put-meaning vic 'mach) -(doctor-put-meaning bbs 'mach) -(doctor-put-meaning modem 'mach) -(doctor-put-meaning baud 'mach) -(doctor-put-meaning macintosh 'mach) -(doctor-put-meaning vax 'mach) -(doctor-put-meaning vms 'mach) -(doctor-put-meaning ibm 'mach) -(doctor-put-meaning pc 'mach) -(doctor-put-meaning bitching 'foul) -(doctor-put-meaning shit 'foul) ; Censored -(doctor-put-meaning bastard 'foul) -(doctor-put-meaning damn 'foul) -(doctor-put-meaning damned 'foul) -(doctor-put-meaning hell 'foul) -(doctor-put-meaning suck 'foul) -(doctor-put-meaning sucking 'foul) -(doctor-put-meaning sux 'foul) -(doctor-put-meaning ass 'foul) -(doctor-put-meaning whore 'foul) -(doctor-put-meaning bitch 'foul) -(doctor-put-meaning asshole 'foul) -(doctor-put-meaning shrink 'foul) -(doctor-put-meaning pot 'toke) -(doctor-put-meaning grass 'toke) -(doctor-put-meaning weed 'toke) -(doctor-put-meaning marijuana 'toke) -(doctor-put-meaning acapulco 'toke) -(doctor-put-meaning columbian 'toke) -(doctor-put-meaning tokin 'toke) -(doctor-put-meaning joint 'toke) -(doctor-put-meaning toke 'toke) -(doctor-put-meaning toking 'toke) -(doctor-put-meaning tokin\' 'toke) -(doctor-put-meaning toked 'toke) -(doctor-put-meaning roach 'toke) -(doctor-put-meaning pills 'drug) -(doctor-put-meaning dope 'drug) -(doctor-put-meaning acid 'drug) -(doctor-put-meaning lsd 'drug) -(doctor-put-meaning speed 'drug) -(doctor-put-meaning heroin 'drug) -(doctor-put-meaning hash 'drug) -(doctor-put-meaning cocaine 'drug) -(doctor-put-meaning uppers 'drug) -(doctor-put-meaning downers 'drug) -(doctor-put-meaning loves 'loves) -(doctor-put-meaning love 'love) -(doctor-put-meaning loved 'love) -(doctor-put-meaning hates 'hates) -(doctor-put-meaning dislikes 'hates) -(doctor-put-meaning hate 'hate) -(doctor-put-meaning hated 'hate) -(doctor-put-meaning dislike 'hate) -(doctor-put-meaning stoned 'state) -(doctor-put-meaning drunk 'state) -(doctor-put-meaning drunken 'state) -(doctor-put-meaning high 'state) -(doctor-put-meaning horny 'state) -(doctor-put-meaning blasted 'state) -(doctor-put-meaning happy 'state) -(doctor-put-meaning paranoid 'state) -(doctor-put-meaning wish 'desire) -(doctor-put-meaning wishes 'desire) -(doctor-put-meaning want 'desire) -(doctor-put-meaning desire 'desire) -(doctor-put-meaning like 'desire) -(doctor-put-meaning hope 'desire) -(doctor-put-meaning hopes 'desire) -(doctor-put-meaning desires 'desire) -(doctor-put-meaning wants 'desire) -(doctor-put-meaning desires 'desire) -(doctor-put-meaning likes 'desire) -(doctor-put-meaning needs 'desire) -(doctor-put-meaning need 'desire) -(doctor-put-meaning frustrated 'mood) -(doctor-put-meaning depressed 'mood) -(doctor-put-meaning annoyed 'mood) -(doctor-put-meaning upset 'mood) -(doctor-put-meaning unhappy 'mood) -(doctor-put-meaning excited 'mood) -(doctor-put-meaning worried 'mood) -(doctor-put-meaning lonely 'mood) -(doctor-put-meaning angry 'mood) -(doctor-put-meaning mad 'mood) -(doctor-put-meaning pissed 'mood) ; censored -(doctor-put-meaning jealous 'mood) -(doctor-put-meaning afraid 'fear) -(doctor-put-meaning terrified 'fear) -(doctor-put-meaning fear 'fear) -(doctor-put-meaning scared 'fear) -(doctor-put-meaning frightened 'fear) -(doctor-put-meaning virginity 'sexnoun) -(doctor-put-meaning virgins 'sexnoun) -(doctor-put-meaning virgin 'sexnoun) -(doctor-put-meaning cock 'sexnoun) -(doctor-put-meaning cocks 'sexnoun) -(doctor-put-meaning dick 'sexnoun) -(doctor-put-meaning dicks 'sexnoun) -(doctor-put-meaning cunt 'sexnoun) ; censored -(doctor-put-meaning cunts 'sexnoun) ; censored -(doctor-put-meaning prostitute 'sexnoun) -(doctor-put-meaning condom 'sexnoun) -(doctor-put-meaning sex 'sexnoun) -(doctor-put-meaning rapes 'sexnoun) -(doctor-put-meaning wife 'family) -(doctor-put-meaning family 'family) -(doctor-put-meaning brothers 'family) -(doctor-put-meaning sisters 'family) -(doctor-put-meaning parent 'family) -(doctor-put-meaning parents 'family) -(doctor-put-meaning brother 'family) -(doctor-put-meaning sister 'family) -(doctor-put-meaning father 'family) -(doctor-put-meaning mother 'family) -(doctor-put-meaning husband 'family) -(doctor-put-meaning siblings 'family) -(doctor-put-meaning grandmother 'family) -(doctor-put-meaning grandfather 'family) -(doctor-put-meaning maternal 'family) -(doctor-put-meaning paternal 'family) -(doctor-put-meaning stab 'death) -(doctor-put-meaning murder 'death) -(doctor-put-meaning murders 'death) -(doctor-put-meaning suicide 'death) -(doctor-put-meaning suicides 'death) -(doctor-put-meaning kill 'death) -(doctor-put-meaning kills 'death) -(doctor-put-meaning die 'death) -(doctor-put-meaning dies 'death) -(doctor-put-meaning died 'death) -(doctor-put-meaning dead 'death) -(doctor-put-meaning death 'death) -(doctor-put-meaning deaths 'death) -(doctor-put-meaning pain 'symptoms) -(doctor-put-meaning ache 'symptoms) -(doctor-put-meaning fever 'symptoms) -(doctor-put-meaning sore 'symptoms) -(doctor-put-meaning aching 'symptoms) -(doctor-put-meaning stomachache 'symptoms) -(doctor-put-meaning headache 'symptoms) -(doctor-put-meaning hurts 'symptoms) -(doctor-put-meaning disease 'symptoms) -(doctor-put-meaning virus 'symptoms) -(doctor-put-meaning vomit 'symptoms) -(doctor-put-meaning vomiting 'symptoms) -(doctor-put-meaning barf 'symptoms) -(doctor-put-meaning toothache 'symptoms) -(doctor-put-meaning hurt 'symptoms) -(doctor-put-meaning rum 'alcohol) -(doctor-put-meaning gin 'alcohol) -(doctor-put-meaning vodka 'alcohol) -(doctor-put-meaning alcohol 'alcohol) -(doctor-put-meaning bourbon 'alcohol) -(doctor-put-meaning beer 'alcohol) -(doctor-put-meaning wine 'alcohol) -(doctor-put-meaning whiskey 'alcohol) -(doctor-put-meaning scotch 'alcohol) -(doctor-put-meaning fuck 'sexverb) ; censored -(doctor-put-meaning fucked 'sexverb) ; censored -(doctor-put-meaning screw 'sexverb) -(doctor-put-meaning screwing 'sexverb) -(doctor-put-meaning fucking 'sexverb) ; censored -(doctor-put-meaning rape 'sexverb) -(doctor-put-meaning raped 'sexverb) -(doctor-put-meaning kiss 'sexverb) -(doctor-put-meaning kissing 'sexverb) -(doctor-put-meaning kisses 'sexverb) -(doctor-put-meaning screws 'sexverb) -(doctor-put-meaning fucks 'sexverb) ; censored -(doctor-put-meaning because 'conj) -(doctor-put-meaning but 'conj) -(doctor-put-meaning however 'conj) -(doctor-put-meaning besides 'conj) -(doctor-put-meaning anyway 'conj) -(doctor-put-meaning that 'conj) -(doctor-put-meaning except 'conj) -(doctor-put-meaning why 'conj) -(doctor-put-meaning how 'conj) -(doctor-put-meaning until 'when) -(doctor-put-meaning when 'when) -(doctor-put-meaning whenever 'when) -(doctor-put-meaning while 'when) -(doctor-put-meaning since 'when) -(doctor-put-meaning rms 'rms) -(doctor-put-meaning stallman 'rms) -(doctor-put-meaning school 'school) -(doctor-put-meaning schools 'school) -(doctor-put-meaning skool 'school) -(doctor-put-meaning grade 'school) -(doctor-put-meaning grades 'school) -(doctor-put-meaning teacher 'school) -(doctor-put-meaning teachers 'school) -(doctor-put-meaning classes 'school) -(doctor-put-meaning professor 'school) -(doctor-put-meaning prof 'school) -(doctor-put-meaning profs 'school) -(doctor-put-meaning professors 'school) -(doctor-put-meaning mit 'school) -(doctor-put-meaning emacs 'eliza) -(doctor-put-meaning eliza 'eliza) -(doctor-put-meaning liza 'eliza) -(doctor-put-meaning elisa 'eliza) -(doctor-put-meaning weizenbaum 'eliza) -(doctor-put-meaning doktor 'eliza) -(doctor-put-meaning athletics 'sports) -(doctor-put-meaning baseball 'sports) -(doctor-put-meaning basketball 'sports) -(doctor-put-meaning football 'sports) -(doctor-put-meaning frisbee 'sports) -(doctor-put-meaning gym 'sports) -(doctor-put-meaning gymnastics 'sports) -(doctor-put-meaning hockey 'sports) -(doctor-put-meaning lacrosse 'sports) -(doctor-put-meaning soccer 'sports) -(doctor-put-meaning softball 'sports) -(doctor-put-meaning sports 'sports) -(doctor-put-meaning swimming 'sports) -(doctor-put-meaning swim 'sports) -(doctor-put-meaning tennis 'sports) -(doctor-put-meaning volleyball 'sports) -(doctor-put-meaning math 'math) -(doctor-put-meaning mathematics 'math) -(doctor-put-meaning mathematical 'math) -(doctor-put-meaning theorem 'math) -(doctor-put-meaning axiom 'math) -(doctor-put-meaning lemma 'math) -(doctor-put-meaning algebra 'math) -(doctor-put-meaning algebraic 'math) -(doctor-put-meaning trig 'math) -(doctor-put-meaning trigonometry 'math) -(doctor-put-meaning trigonometric 'math) -(doctor-put-meaning geometry 'math) -(doctor-put-meaning geometric 'math) -(doctor-put-meaning calculus 'math) -(doctor-put-meaning arithmetic 'math) -(doctor-put-meaning zippy 'zippy) -(doctor-put-meaning zippy 'zippy) -(doctor-put-meaning pinhead 'zippy) -(doctor-put-meaning chat 'chat) - -;;;###autoload -(defun doctor () - "Switch to *doctor* buffer and start giving psychotherapy." - (interactive) - (switch-to-buffer "*doctor*") - (doctor-mode)) - -(defun doctor-ret-or-read (arg) - "Insert a newline if preceding character is not a newline. -Otherwise call the Doctor to parse preceding sentence." - (interactive "*p") - (if (= (preceding-char) ?\n) - (doctor-read-print) - (newline arg))) - -(defun doctor-read-print nil - "top level loop" - (interactive) - (let ((sent (doctor-readin))) - (insert "\n") - (setq lincount (1+ lincount)) - (doctor-doc sent) - (insert "\n") - (setq bak sent))) - -(defun doctor-readin nil - "Read a sentence. Return it as a list of words." - (let (sentence) - (backward-sentence 1) - (while (not (eobp)) - (setq sentence (append sentence (list (doctor-read-token))))) - sentence)) - -(defun doctor-read-token () - "read one word from buffer" - (prog1 (intern (downcase (buffer-substring (point) - (progn - (forward-word 1) - (point))))) - (re-search-forward "\\Sw*"))) - -;; Main processing function for sentences that have been read. - -(defun doctor-doc (sent) - (cond - ((equal sent '(foo)) - (doctor-type '(bar! ($ please)($ continue) \.))) - ((member sent howareyoulst) - (doctor-type '(i\'m ok \. ($ describe) yourself \.))) - ((or (member sent '((good bye) (see you later) (i quit) (so long) - (go away) (get lost))) - (memq (car sent) - '(bye halt break quit done exit goodbye - bye\, stop pause goodbye\, stop pause))) - (doctor-type ($ bye))) - ((and (eq (car sent) 'you) - (memq (doctor-cadr sent) abusewords)) - (setq found (doctor-cadr sent)) - (doctor-type ($ abuselst))) - ((eq (car sent) 'whatmeans) - (doctor-def (doctor-cadr sent))) - ((equal sent '(parse)) - (doctor-type (list 'subj '= subj ", " - 'verb '= verb "\n" - 'object 'phrase '= obj "," - 'noun 'form '= object "\n" - 'current 'keyword 'is found - ", " - 'most 'recent 'possessive - 'is owner "\n" - 'sentence 'used 'was - "..." - '(// bak)))) - ;; ((eq (car sent) 'forget) - ;; (set (doctor-cadr sent) nil) - ;; (doctor-type '(($ isee)($ please) - ;; ($ continue)\.))) - (t - (if (doctor-defq sent) (doctor-define sent found)) - (if (> (length sent) 12)(doctor-shorten sent)) - (setq sent (doctor-correct-spelling (doctor-replace sent replist))) - (cond ((and (not (memq 'me sent))(not (memq 'i sent)) - (memq 'am sent)) - (setq sent (doctor-replace sent '((am . (are))))))) - (cond ((equal (car sent) 'yow) (doctor-zippy)) - ((< (length sent) 2) - (cond ((eq (doctor-meaning (car sent)) 'howdy) - (doctor-howdy)) - (t (doctor-short)))) - (t - (if (memq 'am sent) - (setq sent (doctor-replace sent '((me . (i)))))) - (setq sent (doctor-fixup sent)) - (if (and (eq (car sent) 'do) (eq (doctor-cadr sent) 'not)) - (cond ((zerop (random 3)) - (doctor-type '(are you ($ afraidof) that \?))) - ((zerop (random 2)) - (doctor-type '(don\'t tell me what to do \. i am the - psychiatrist here!)) - (doctor-rthing)) - (t - (doctor-type '(($ whysay) that i shouldn\'t - (doctor-cddr sent) - \?)))) - (doctor-go (doctor-wherego sent)))))))) - -;; Things done to process sentences once read. - -(defun doctor-correct-spelling (sent) - "Correct the spelling and expand each word in sentence." - (if sent - (apply 'append (mapcar '(lambda (word) - (if (memq word typos) - (get (get word 'doctor-correction) 'doctor-expansion) - (list word))) - sent)))) - -(defun doctor-shorten (sent) - "Make a sentence manageably short using a few hacks." - (let (foo - retval - (temp '(because but however besides anyway until - while that except why how))) - (while temp - (setq foo (memq (car temp) sent)) - (if (and foo - (> (length foo) 3)) - (setq sent foo - sent (doctor-fixup sent) - temp nil - retval t) - (setq temp (cdr temp)))) - retval)) - -(defun doctor-define (sent found) - (doctor-svo sent found 1 nil) - (and - (doctor-nounp subj) - (not (doctor-pronounp subj)) - subj - (doctor-meaning object) - (put subj 'doctor-meaning (doctor-meaning object)) - t)) - -(defun doctor-defq (sent) - "Set global var FOUND to first keyword found in sentence SENT." - (setq found nil) - (let ((temp '(means applies mean refers refer related - similar defined associated linked like same))) - (while temp - (if (memq (car temp) sent) - (setq found (car temp) - temp nil) - (setq temp (cdr temp))))) - found) - -(defun doctor-def (x) - (progn - (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me)) - nil)) - -(defun doctor-forget () - "Delete the last element of the history list." - (setq history (reverse (cdr (reverse history))))) - -(defun doctor-query (x) - "Prompt for a line of input from the minibuffer until a noun or verb is seen. -Put dialogue in buffer." - (let (a - (prompt (concat (doctor-make-string x) - " what \? ")) - retval) - (while (not retval) - (while (not a) - (insert ?\n - prompt - (read-string prompt) - ?\n) - (setq a (doctor-readin))) - (while (and a (not retval)) - (cond ((doctor-nounp (car a)) - (setq retval (car a))) - ((doctor-verbp (car a)) - (setq retval (doctor-build - (doctor-build x " ") - (car a)))) - ((setq a (cdr a)))))) - retval)) - -(defun doctor-subjsearch (sent key type) - "Search for the subject of a sentence SENT, looking for the noun closest -to and preceding KEY by at least TYPE words. Set global variable subj to -the subject noun, and return the portion of the sentence following it." - (let ((i (- (length sent) (length (memq key sent)) type))) - (while (and (> i -1) (not (doctor-nounp (nth i sent)))) - (setq i (1- i))) - (cond ((> i -1) - (setq subj (nth i sent)) - (nthcdr (1+ i) sent)) - (t - (setq subj 'you) - nil)))) - -(defun doctor-nounp (x) - "Returns t if the symbol argument is a noun." - (or (doctor-pronounp x) - (not (or (doctor-verbp x) - (equal x 'not) - (doctor-prepp x) - (doctor-modifierp x) )) )) - -(defun doctor-pronounp (x) - "Returns t if the symbol argument is a pronoun." - (memq x '( - i me mine myself - we us ours ourselves ourself - you yours yourself yourselves - he him himself she hers herself - it that those this these things thing - they them themselves theirs - anybody everybody somebody - anyone everyone someone - anything something everything))) - -(mapcar (function (lambda (x) (put x 'doctor-sentence-type 'verb))) - '(abort aborted aborts ask asked asks am - applied applies apply are associate - associated ate - be became become becomes becoming - been being believe believed believes - bit bite bites bore bored bores boring bought buy buys buying - call called calling calls came can caught catch come - contract contracted contracts control controlled controls - could croak croaks croaked cut cuts - dare dared define defines dial dialed dials did die died dies - dislike disliked - dislikes do does drank drink drinks drinking - drive drives driving drove dying - eat eating eats expand expanded expands - expect expected expects expel expels expelled - explain explained explains - fart farts feel feels felt fight fights find finds finding - forget forgets forgot fought found fuck fucked ; censored - fucking fucks ; censored - gave get gets getting give gives go goes going gone got gotten - had harm harms has hate hated hates have having - hear heard hears hearing help helped helping helps - hit hits hope hoped hopes hurt hurts - implies imply is - join joined joins jump jumped jumps - keep keeping keeps kept - kill killed killing kills kiss kissed kisses kissing - knew know knows - laid lay lays let lets lie lied lies like liked likes - liking listen listens - login look looked looking looks - lose losing lost - love loved loves loving - luse lusing lust lusts - made make makes making may mean means meant might - move moved moves moving must - need needed needs - order ordered orders ought - paid pay pays pick picked picking picks - placed placing prefer prefers put puts - ran rape raped rapes - read reading reads recall receive received receives - refer refered referred refers - relate related relates remember remembered remembers - romp romped romps run running runs - said sang sat saw say says - screw screwed screwing screws scrod see sees seem seemed - seems seen sell selling sells - send sendind sends sent shall shoot shot should - sing sings sit sits sitting sold studied study - take takes taking talk talked talking talks tell tells telling - think thinks - thought told took tooled touch touched touches touching - transfer transferred transfers transmit transmits transmitted - type types types typing - walk walked walking walks want wanted wants was watch - watched watching went were will wish would work worked works - write writes writing wrote use used uses using)) - -(defun doctor-verbp (x) (if (symbolp x) - (eq (get x 'doctor-sentence-type) 'verb))) - -(defun doctor-plural (x) - "Form the plural of the word argument." - (let ((foo (doctor-make-string x))) - (cond ((string-equal (substring foo -1) "s") - (cond ((string-equal (substring foo -2 -1) "s") - (intern (concat foo "es"))) - (t x))) - ((string-equal (substring foo -1) "y") - (intern (concat (substring foo 0 -1) - "ies"))) - (t (intern (concat foo "s")))))) - -(defun doctor-setprep (sent key) - (let ((val) - (foo (memq key sent))) - (cond ((doctor-prepp (doctor-cadr foo)) - (setq val (doctor-getnoun (doctor-cddr foo))) - (cond (val val) - (t 'something))) - ((doctor-articlep (doctor-cadr foo)) - (setq val (doctor-getnoun (doctor-cddr foo))) - (cond (val (doctor-build (doctor-build (doctor-cadr foo) " ") val)) - (t 'something))) - (t 'something)))) - -(defun doctor-getnoun (x) - (cond ((null x)(setq object 'something)) - ((atom x)(setq object x)) - ((eq (length x) 1) - (setq object (cond - ((doctor-nounp (setq object (car x))) object) - (t (doctor-query object))))) - ((eq (car x) 'to) - (doctor-build 'to\ (doctor-getnoun (cdr x)))) - ((doctor-prepp (car x)) - (doctor-getnoun (cdr x))) - ((not (doctor-nounp (car x))) - (doctor-build (doctor-build (cdr (assq (car x) - (append - '((a . this) - (some . this) - (one . that)) - (list - (cons - (car x) (car x)))))) - " ") - (doctor-getnoun (cdr x)))) - (t (setq object (car x))) )) - -(defun doctor-modifierp (x) - (or (doctor-adjectivep x) - (doctor-adverbp x) - (doctor-othermodifierp x))) - -(defun doctor-adjectivep (x) - (or (numberp x) - (doctor-nmbrp x) - (doctor-articlep x) - (doctor-colorp x) - (doctor-sizep x) - (doctor-possessivepronounp x))) - -(defun doctor-adverbp (xx) - (let ((xxstr (doctor-make-string xx))) - (and (>= (length xxstr) 2) - (string-equal (substring (doctor-make-string xx) -2) "ly")))) - -(defun doctor-articlep (x) - (memq x '(the a an))) - -(defun doctor-nmbrp (x) - (memq x '(one two three four five six seven eight nine ten - eleven twelve thirteen fourteen fifteen - sixteen seventeen eighteen nineteen - twenty thirty forty fifty sixty seventy eighty ninety - hundred thousand million billion - half quarter - first second third fourth fifth - sixth seventh eighth ninth tenth))) - -(defun doctor-colorp (x) - (memq x '(beige black blue brown crimson - gray grey green - orange pink purple red tan tawny - violet white yellow))) - -(defun doctor-sizep (x) - (memq x '(big large tall fat wide thick - small petite short thin skinny))) - -(defun doctor-possessivepronounp (x) - (memq x '(my your his her our their))) - -(defun doctor-othermodifierp (x) - (memq x '(all also always amusing any anyway associated awesome - bad beautiful best better but certain clear - ever every fantastic fun funny - good great grody gross however if ignorant - less linked losing lusing many more much - never nice obnoxious often poor pretty real related rich - similar some stupid super superb - terrible terrific too total tubular ugly very))) - -(defun doctor-prepp (x) - (memq x '(about above after around as at - before beneath behind beside between by - for from in inside into - like near next of on onto over - same through thru to toward towards - under underneath with without))) - -(defun doctor-remember (thing) - (cond ((null history) - (setq history (list thing))) - (t (setq history (append history (list thing)))))) - -(defun doctor-type (x) - (setq x (doctor-fix-2 x)) - (doctor-txtype (doctor-assm x))) - -(defun doctor-fixup (sent) - (setq sent (append - (cdr - (assq (car sent) - (append - '((me i) - (him he) - (her she) - (them they) - (okay) - (well) - (sigh) - (hmm) - (hmmm) - (hmmmm) - (hmmmmm) - (gee) - (sure) - (great) - (oh) - (fine) - (ok) - (no)) - (list (list (car sent) - (car sent)))))) - (cdr sent))) - (doctor-fix-2 sent)) - -(defun doctor-fix-2 (sent) - (let ((foo sent)) - (while foo - (if (and (eq (car foo) 'me) - (doctor-verbp (doctor-cadr foo))) - (rplaca foo 'i) - (cond ((eq (car foo) 'you) - (cond ((memq (doctor-cadr foo) '(am be been is)) - (rplaca (cdr foo) 'are)) - ((memq (doctor-cadr foo) '(has)) - (rplaca (cdr foo) 'have)) - ((memq (doctor-cadr foo) '(was)) - (rplaca (cdr foo) 'were)))) - ((equal (car foo) 'i) - (cond ((memq (doctor-cadr foo) '(are is be been)) - (rplaca (cdr foo) 'am)) - ((memq (doctor-cadr foo) '(were)) - (rplaca (cdr foo) 'was)) - ((memq (doctor-cadr foo) '(has)) - (rplaca (cdr foo) 'have)))) - ((and (doctor-verbp (car foo)) - (eq (doctor-cadr foo) 'i) - (not (doctor-verbp (car (doctor-cddr foo))))) - (rplaca (cdr foo) 'me)) - ((and (eq (car foo) 'a) - (doctor-vowelp (string-to-char - (doctor-make-string (doctor-cadr foo))))) - (rplaca foo 'an)) - ((and (eq (car foo) 'an) - (not (doctor-vowelp (string-to-char - (doctor-make-string (doctor-cadr foo)))))) - (rplaca foo 'a))) - (setq foo (cdr foo)))) - sent)) - -(defun doctor-vowelp (x) - (memq x '(?a ?e ?i ?o ?u))) - -(defun doctor-replace (sent rlist) - "Replace any element of SENT that is the car of a replacement -element pair in RLIST." - (apply 'append - (mapcar - (function - (lambda (x) - (cdr (or (assq x rlist) ; either find a replacement - (list x x))))) ; or fake an identity mapping - sent))) - -(defun doctor-wherego (sent) - (cond ((null sent)($ whereoutp)) - ((null (doctor-meaning (car sent))) - (doctor-wherego (cond ((zerop (random 2)) - (reverse (cdr sent))) - (t (cdr sent))))) - (t - (setq found (car sent)) - (doctor-meaning (car sent))))) - -(defun doctor-svo (sent key type mem) - "Find subject, verb and object in sentence SENT with focus on word KEY. -TYPE is number of words preceding KEY to start looking for subject. -MEM is t if results are to be put on Doctor's memory stack. -Return in the global variables SUBJ, VERB and OBJECT." - (let ((foo (doctor-subjsearch sent key type))) - (or foo - (setq foo sent - mem nil)) - (while (and (null (doctor-verbp (car foo))) (cdr foo)) - (setq foo (cdr foo))) - (setq verb (car foo)) - (setq obj (doctor-getnoun (cdr foo))) - (cond ((eq object 'i)(setq object 'me)) - ((eq subj 'me)(setq subj 'i))) - (cond (mem (doctor-remember (list subj verb obj)))))) - -(defun doctor-possess (sent key) - "Set possessive in SENT for keyword KEY. -Hack on previous word, setting global variable OWNER to correct result." - (let* ((i (- (length sent) (length (memq key sent)) 1)) - (prev (if (< i 0) 'your - (nth i sent)))) - (setq owner (if (or (doctor-possessivepronounp prev) - (string-equal "s" - (substring (doctor-make-string prev) - -1))) - prev - 'your)))) - -;; Output of replies. - -(defun doctor-txtype (ans) - "Output to buffer a list of symbols or strings as a sentence." - (setq *print-upcase* t *print-space* nil) - (mapcar 'doctor-type-symbol ans) - (insert "\n")) - -(defun doctor-type-symbol (word) - "Output a symbol to the buffer with some fancy case and spacing hacks." - (setq word (doctor-make-string word)) - (if (string-equal word "i") (setq word "I")) - (if *print-upcase* - (progn - (setq word (capitalize word)) - (if *print-space* - (insert " ")))) - (cond ((or (string-match "^[.,;:?! ]" word) - (not *print-space*)) - (insert word)) - (t (insert ?\ word))) - (and auto-fill-function - (> (current-column) fill-column) - (apply auto-fill-function nil)) - (setq *print-upcase* (string-match "[.?!]$" word) - *print-space* t)) - -(defun doctor-build (str1 str2) - "Make a symbol out of the concatenation of the two non-list arguments." - (cond ((null str1) str2) - ((null str2) str1) - ((and (atom str1) - (atom str2)) - (intern (concat (doctor-make-string str1) - (doctor-make-string str2)))) - (t nil))) - -(defun doctor-make-string (obj) - (cond ((stringp obj) obj) - ((symbolp obj) (symbol-name obj)) - ((numberp obj) (int-to-string obj)) - (t ""))) - -(defun doctor-concat (x y) - "Like append, but force atomic arguments to be lists." - (append - (if (and x (atom x)) (list x) x) - (if (and y (atom y)) (list y) y))) - -(defun doctor-assm (proto) - (cond ((null proto) nil) - ((atom proto) (list proto)) - ((atom (car proto)) - (cons (car proto) (doctor-assm (cdr proto)))) - (t (doctor-concat (doctor-assm (eval (car proto))) (doctor-assm (cdr proto)))))) - -;; Functions that handle specific words or meanings when found. - -(defun doctor-go (destination) - "Call a `doctor-*' function." - (funcall (intern (concat "doctor-" (doctor-make-string destination))))) - -(defun doctor-desire1 () - (doctor-go ($ whereoutp))) - -(defun doctor-huh () - (cond ((< (length sent) 9) (doctor-type ($ huhlst))) - (t (doctor-type ($ longhuhlst))))) - -(defun doctor-rthing () (doctor-type ($ thlst))) - -(defun doctor-remem () (cond ((null history)(doctor-huh)) - ((doctor-type ($ remlst))))) - -(defun doctor-howdy () - (cond ((not howdyflag) - (doctor-type '(($ hello) what brings you to see me \?)) - (setq howdyflag t)) - (t - (doctor-type '(($ ibelieve) we\'ve introduced ourselves already \.)) - (doctor-type '(($ please) ($ describe) ($ things) \.))))) - -(defun doctor-when () - (cond ((< (length (memq found sent)) 3)(doctor-short)) - (t - (setq sent (cdr (memq found sent))) - (setq sent (doctor-fixup sent)) - (doctor-type '(($ whatwhen)(// sent) \?))))) - -(defun doctor-conj () - (cond ((< (length (memq found sent)) 4)(doctor-short)) - (t - (setq sent (cdr (memq found sent))) - (setq sent (doctor-fixup sent)) - (cond ((eq (car sent) 'of) - (doctor-type '(are you ($ sure) that is the real reason \?)) - (setq things (cons (cdr sent) things))) - (t - (doctor-remember sent) - (doctor-type ($ beclst))))))) - -(defun doctor-short () - (cond ((= (car repetitive-shortness) (1- lincount)) - (rplacd repetitive-shortness - (1+ (cdr repetitive-shortness)))) - (t - (rplacd repetitive-shortness 1))) - (rplaca repetitive-shortness lincount) - (cond ((> (cdr repetitive-shortness) 6) - (cond ((not **mad**) - (doctor-type '(($ areyou) - just trying to see what kind of things - i have in my vocabulary \? please try to - carry on a reasonable conversation!)) - (setq **mad** t)) - (t - (doctor-type '(i give up \. you need a lesson in creative - writing \.\.\.)) - ;;(push monosyllables observation-list) - ))) - (t - (cond ((equal sent (doctor-assm '(yes))) - (doctor-type '(($ isee) ($ inter) ($ whysay) this is so \?))) - ((equal sent (doctor-assm '(because))) - (doctor-type ($ shortbeclst))) - ((equal sent (doctor-assm '(no))) - (doctor-type ($ neglst))) - (t (doctor-type ($ shortlst))))))) - -(defun doctor-alcohol () (doctor-type ($ drnk))) - -(defun doctor-desire () - (let ((foo (memq found sent))) - (cond ((< (length foo) 2) - (doctor-go (doctor-build (doctor-meaning found) 1))) - ((memq (doctor-cadr foo) '(a an)) - (rplacd foo (append '(to have) (cdr foo))) - (doctor-svo sent found 1 nil) - (doctor-remember (list subj 'would 'like obj)) - (doctor-type ($ whywant))) - ((not (eq (doctor-cadr foo) 'to)) - (doctor-go (doctor-build (doctor-meaning found) 1))) - (t - (doctor-svo sent found 1 nil) - (doctor-remember (list subj 'would 'like obj)) - (doctor-type ($ whywant)))))) - -(defun doctor-drug () - (doctor-type ($ drugs)) - (doctor-remember (list 'you 'used found))) - -(defun doctor-toke () - (doctor-type ($ toklst))) - -(defun doctor-state () - (doctor-type ($ states))(doctor-remember (list 'you 'were found))) - -(defun doctor-mood () - (doctor-type ($ moods))(doctor-remember (list 'you 'felt found))) - -(defun doctor-fear () - (setq feared (doctor-setprep sent found)) - (doctor-type ($ fears)) - (doctor-remember (list 'you 'were 'afraid 'of feared))) - -(defun doctor-hate () - (doctor-svo sent found 1 t) - (cond ((memq 'not sent) (doctor-forget) (doctor-huh)) - ((equal subj 'you) - (doctor-type '(why do you (// verb)(// obj) \?))) - (t (doctor-type '(($ whysay)(list subj verb obj)))))) - -(defun doctor-symptoms () - (doctor-type '(($ maybe) you should consult a doctor of medicine\, - i am a psychiatrist \.))) - -(defun doctor-hates () - (doctor-svo sent found 1 t) - (doctor-hates1)) - -(defun doctor-hates1 () - (doctor-type '(($ whysay)(list subj verb obj)))) - -(defun doctor-loves () - (doctor-svo sent found 1 t) - (doctor-qloves)) - -(defun doctor-qloves () - (doctor-type '(($ bother)(list subj verb obj) \?))) - -(defun doctor-love () - (doctor-svo sent found 1 t) - (cond ((memq 'not sent) (doctor-forget) (doctor-huh)) - ((memq 'to sent) (doctor-hates1)) - (t - (cond ((equal object 'something) - (setq object '(this person you love)))) - (cond ((equal subj 'you) - (setq lover obj) - (cond ((equal lover '(this person you love)) - (setq lover '(your partner)) - (doctor-forget) - (doctor-type '(with whom are you in love \?))) - ((doctor-type '(($ please) - ($ describe) - ($ relation) - (// lover) - \.))))) - ((equal subj 'i) - (doctor-txtype '(we were discussing you!))) - (t (doctor-forget) - (setq obj 'someone) - (setq verb (doctor-build verb 's)) - (doctor-qloves)))))) - -(defun doctor-mach () - (setq found (doctor-plural found)) - (doctor-type ($ machlst))) - -(defun doctor-sexnoun () (doctor-sexverb)) - -(defun doctor-sexverb () - (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent)) - (doctor-foul) - (doctor-type ($ sexlst)))) - -(defun doctor-death () (doctor-type ($ deathlst))) - -(defun doctor-foul () - (doctor-type ($ foullst))) - -(defun doctor-family () - (doctor-possess sent found) - (doctor-type ($ famlst))) - -;; I did not add this -- rms. -;; But he might have removed it. I put it back. --roland -(defun doctor-rms () - (cond (rms-flag (doctor-type ($ stallmanlst))) - (t (setq rms-flag t) (doctor-type '(do you know Stallman \?))))) - -(defun doctor-school nil (doctor-type ($ schoollst))) - -(defun doctor-eliza () - (cond (eliza-flag (doctor-type ($ elizalst))) - (t (setq eliza-flag t) - (doctor-type '((// found) \? hah ! - ($ please) ($ continue) \.))))) - -(defun doctor-sports () (doctor-type ($ sportslst))) - -(defun doctor-math () (doctor-type ($ mathlst))) - -(defun doctor-zippy () - (cond (zippy-flag (doctor-type ($ zippylst))) - (t (setq zippy-flag t) - (doctor-type '(yow! are we interactive yet \?))))) - - -(defun doctor-chat () (doctor-type ($ chatlst))) - -(defun doctor-strangelove () - (interactive) - (insert "Mein fuehrer!!\n") - (doctor-read-print)) - -;;; doctor.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/dunnet.el --- a/lisp/games/dunnet.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3340 +0,0 @@ -;;; dunnet.el --- Text adventure for Emacs - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Ron Schnell -;; Created: 25 Jul 1992 -;; Version: 2.0 -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; This game can be run in batch mode. To do this, use: -;; emacs -batch -l dunnet - -;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -;;; The log file should be set for your system, and it must -;;; be writable by all. - - -(defvar dun-log-file "/usr/local/dunnet.score" - "Name of file to store score information for dunnet.") - -(if nil - (eval-and-compile (setq byte-compile-warnings nil))) - -(eval-when-compile - (require 'cl)) - -;;;; Mode definitions for interactive mode - -(defun dun-mode () - "Major mode for running dunnet." - (interactive) - (text-mode) - (make-local-variable 'scroll-step) - (setq scroll-step 2) - (use-local-map dungeon-mode-map) - (setq major-mode 'dungeon-mode) - (setq mode-name "Dungeon")) - -(defun dun-parse (arg) - "Function called when return is pressed in interactive mode to parse line." - (interactive "*p") - (beginning-of-line) - (setq beg (+ (point) 1)) - (end-of-line) - (if (and (not (= beg (point))) (not (< (point) beg)) - (string= ">" (buffer-substring (- beg 1) beg))) - (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) - (dun-mprinc "I don't understand that.\n"))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (dun-messages)) - -(defun dun-messages () - (if dun-dead - (text-mode) - (if (eq dungeon-mode 'dungeon) - (progn - (if (not (= room dun-current-room)) - (progn - (dun-describe-room dun-current-room) - (setq room dun-current-room))) - (dun-fix-screen) - (dun-mprinc ">"))))) - - -;;;###autoload -(defun dunnet () - "Switch to *dungeon* buffer and start game." - (interactive) - (switch-to-buffer "*dungeon*") - (dun-mode) - (setq dun-dead nil) - (setq room 0) - (dun-messages)) - -;;;; -;;;; This section contains all of the verbs and commands. -;;;; - -;;; Give long description of room if haven't been there yet. Otherwise -;;; short. Also give long if we were called with negative room number. - -(defun dun-describe-room (room) - (if (and (not (member (abs room) dun-light-rooms)) - (not (member obj-lamp dun-inventory))) - (dun-mprincl "It is pitch dark. You are likely to be eaten by a grue.") - (dun-mprincl (cadr (nth (abs room) dun-rooms))) - (if (and (and (or (member room dun-visited) - (string= dun-mode "dun-superb")) (> room 0)) - (not (string= dun-mode "long"))) - nil - (dun-mprinc (car (nth (abs room) dun-rooms))) - (dun-mprinc "\n")) - (if (not (string= dun-mode "long")) - (if (not (member (abs room) dun-visited)) - (setq dun-visited (append (list (abs room)) dun-visited)))) - (dolist (xobjs (nth dun-current-room dun-room-objects)) - (if (= xobjs obj-special) - (dun-special-object) - (if (>= xobjs 0) - (dun-mprincl (car (nth xobjs dun-objects))) - (if (not (and (= xobjs obj-bus) dun-inbus)) - (progn - (dun-mprincl (car (nth (abs xobjs) dun-perm-objects))))))) - (if (and (= xobjs obj-jar) dun-jar) - (progn - (dun-mprincl "The jar contains:") - (dolist (x dun-jar) - (dun-mprinc " ") - (dun-mprincl (car (nth x dun-objects))))))) - (if (and (member obj-bus (nth dun-current-room dun-room-objects)) dun-inbus) - (dun-mprincl "You are on the bus.")))) - -;;; There is a special object in the room. This object's description, -;;; or lack thereof, depends on certain conditions. - -(defun dun-special-object () - (if (= dun-current-room computer-room) - (if dun-computer - (dun-mprincl -"The panel lights are flashing in a seemingly organized pattern.") - (dun-mprincl "The panel lights are steady and motionless."))) - - (if (and (= dun-current-room red-room) - (not (member obj-towel (nth red-room dun-room-objects)))) - (dun-mprincl "There is a hole in the floor here.")) - - (if (and (= dun-current-room marine-life-area) dun-black) - (dun-mprincl -"The room is lit by a black light, causing the fish, and some of -your objects, to give off an eerie glow.")) - (if (and (= dun-current-room fourth-vermont-intersection) dun-hole) - (progn - (if (not dun-inbus) - (progn - (dun-mprincl"You fall into a hole in the ground.") - (setq dun-current-room vermont-station) - (dun-describe-room vermont-station)) - (progn - (dun-mprincl -"The bus falls down a hole in the ground and explodes.") - (dun-die "burning"))))) - - (if (> dun-current-room endgame-computer-room) - (progn - (if (not dun-correct-answer) - (dun-endgame-question) - (dun-mprincl "Your question is:") - (dun-mprincl dun-endgame-question)))) - - (if (= dun-current-room sauna) - (progn - (dun-mprincl (nth dun-sauna-level '( -"It is normal room temperature in here." -"It is luke warm in here." -"It is comfortably hot in here." -"It is refreshingly hot in here." -"You are dead now."))) - (if (and (= dun-sauna-level 3) - (or (member obj-rms dun-inventory) - (member obj-rms (nth dun-current-room dun-room-objects)))) - (progn - (dun-mprincl -"You notice the wax on your statuette beginning to melt, until it completely -melts off. You are left with a beautiful diamond!") - (if (member obj-rms dun-inventory) - (progn - (dun-remove-obj-from-inven obj-rms) - (setq dun-inventory (append dun-inventory - (list obj-diamond)))) - (dun-remove-obj-from-room dun-current-room obj-rms) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-diamond)))) - (if (member obj-floppy dun-inventory) - (progn - (dun-mprincl -"You notice your floppy disk beginning to melt. As you grab for it, the -disk bursts into flames, and disintegrates.") - (dun-remove-obj-from-inven obj-floppy) - (dun-remove-obj-from-room dun-current-room obj-floppy))))) - ))) - -(defun dun-die (murderer) - (dun-mprinc "\n") - (if murderer - (dun-mprincl "You are dead.")) - (dun-do-logfile 'dun-die murderer) - (dun-score nil) - (setq dun-dead t)) - -(defun dun-quit (args) - (dun-die nil)) - -;;; Print every object in player's inventory. Special case for the jar, -;;; as we must also print what is in it. - -(defun dun-inven (args) - (dun-mprinc "You currently have:") - (dun-mprinc "\n") - (dolist (curobj dun-inventory) - (if curobj - (progn - (dun-mprincl (cadr (nth curobj dun-objects))) - (if (and (= curobj obj-jar) dun-jar) - (progn - (dun-mprincl "The jar contains:") - (dolist (x dun-jar) - (dun-mprinc " ") - (dun-mprincl (cadr (nth x dun-objects)))))))))) - -(defun dun-shake (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (member objnum dun-inventory) - (progn -;;; If shaking anything will do anything, put here. - (dun-mprinc "Shaking ") - (dun-mprinc (downcase (cadr (nth objnum dun-objects)))) - (dun-mprinc " seems to have no effect.") - (dun-mprinc "\n") - ) - (if (and (not (member objnum (nth dun-current-room dun-room-silents))) - (not (member objnum (nth dun-current-room dun-room-objects)))) - (dun-mprincl "I don't see that here.") -;;; Shaking trees can be deadly - (if (= objnum obj-tree) - (progn - (dun-mprinc - "You begin to shake a tree, and notice a coconut begin to fall from the air. -As you try to get your hand up to block it, you feel the impact as it lands -on your head.") - (dun-die "a coconut")) - (if (= objnum obj-bear) - (progn - (dun-mprinc -"As you go up to the bear, it removes your head and places it on the ground.") - (dun-die "a bear")) - (if (< objnum 0) - (dun-mprincl "You cannot shake that.") - (dun-mprincl "You don't have that."))))))))) - - -(defun dun-drop (obj) - (if dun-inbus - (dun-mprincl "You can't drop anything while on the bus.") - (let (objnum ptr) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (setq ptr (member objnum dun-inventory))) - (dun-mprincl "You don't have that.") - (progn - (dun-remove-obj-from-inven objnum) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list objnum))) - (dun-mprincl "Done.") - (if (member objnum (list obj-food obj-weight obj-jar)) - (dun-drop-check objnum)))))))) - -;;; Dropping certain things causes things to happen. - -(defun dun-drop-check (objnum) - (if (and (= objnum obj-food) (= room bear-hangout) - (member obj-bear (nth bear-hangout dun-room-objects))) - (progn - (dun-mprincl -"The bear takes the food and runs away with it. He left something behind.") - (dun-remove-obj-from-room dun-current-room obj-bear) - (dun-remove-obj-from-room dun-current-room obj-food) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-key))))) - - (if (and (= objnum obj-jar) (member obj-nitric dun-jar) - (member obj-glycerine dun-jar)) - (progn - (dun-mprincl - "As the jar impacts the ground it explodes into many pieces.") - (setq dun-jar nil) - (dun-remove-obj-from-room dun-current-room obj-jar) - (if (= dun-current-room fourth-vermont-intersection) - (progn - (setq dun-hole t) - (setq dun-current-room vermont-station) - (dun-mprincl -"The explosion causes a hole to open up in the ground, which you fall -through."))))) - - (if (and (= objnum obj-weight) (= dun-current-room maze-button-room)) - (dun-mprincl "A passageway opens."))) - -;;; Give long description of current room, or an object. - -(defun dun-examine (obj) - (let (objnum) - (setq objnum (dun-objnum-from-args obj)) - (if (eq objnum obj-special) - (dun-describe-room (* dun-current-room -1)) - (if (and (eq objnum obj-computer) - (member obj-pc (nth dun-current-room dun-room-silents))) - (dun-examine '("pc")) - (if (eq objnum nil) - (dun-mprincl "I don't know what that is.") - (if (and (not (member objnum - (nth dun-current-room dun-room-objects))) - (not (member objnum - (nth dun-current-room dun-room-silents))) - (not (member objnum dun-inventory))) - (dun-mprincl "I don't see that here.") - (if (>= objnum 0) - (if (and (= objnum obj-bone) - (= dun-current-room marine-life-area) dun-black) - (dun-mprincl -"In this light you can see some writing on the bone. It says: -For an explosive time, go to Fourth St. and Vermont.") - (if (nth objnum dun-physobj-desc) - (dun-mprincl (nth objnum dun-physobj-desc)) - (dun-mprincl "I see nothing special about that."))) - (if (nth (abs objnum) dun-permobj-desc) - (progn - (dun-mprincl (nth (abs objnum) dun-permobj-desc))) - (dun-mprincl "I see nothing special about that."))))))))) - -(defun dun-take (obj) - (if dun-inbus - (dun-mprincl "You can't take anything while on the bus.") - (setq obj (dun-firstword obj)) - (if (not obj) - (dun-mprincl "You must supply an object.") - (if (string= obj "all") - (let (gotsome) - (setq gotsome nil) - (dolist (x (nth dun-current-room dun-room-objects)) - (if (and (>= x 0) (not (= x obj-special))) - (progn - (setq gotsome t) - (dun-mprinc (cadr (nth x dun-objects))) - (dun-mprinc ": ") - (dun-take-object x)))) - (if (not gotsome) - (dun-mprincl "Nothing to take."))) - (let (objnum) - (setq objnum (cdr (assq (intern obj) dun-objnames))) - (if (eq objnum nil) - (progn - (dun-mprinc "I don't know what that is.") - (dun-mprinc "\n")) - (dun-take-object objnum))))))) - -(defun dun-take-object (objnum) - (if (and (member objnum dun-jar) (member obj-jar dun-inventory)) - (let (newjar) - (dun-mprincl "You remove it from the jar.") - (setq newjar nil) - (dolist (x dun-jar) - (if (not (= x objnum)) - (setq newjar (append newjar (list x))))) - (setq dun-jar newjar) - (setq dun-inventory (append dun-inventory (list objnum)))) - (if (not (member objnum (nth dun-current-room dun-room-objects))) - (if (not (member objnum (nth dun-current-room dun-room-silents))) - (dun-mprinc "I do not see that here.") - (dun-try-take objnum)) - (if (>= objnum 0) - (progn - (if (and (car dun-inventory) - (> (+ (dun-inven-weight) (nth objnum dun-object-lbs)) 11)) - (dun-mprinc "Your load would be too heavy.") - (setq dun-inventory (append dun-inventory (list objnum))) - (dun-remove-obj-from-room dun-current-room objnum) - (dun-mprinc "Taken. ") - (if (and (= objnum obj-towel) (= dun-current-room red-room)) - (dun-mprinc - "Taking the towel reveals a hole in the floor.")))) - (dun-try-take objnum))) - (dun-mprinc "\n"))) - -(defun dun-inven-weight () - (let (total) - (setq total 0) - (dolist (x dun-jar) - (setq total (+ total (nth x dun-object-lbs)))) - (dolist (x dun-inventory) - (setq total (+ total (nth x dun-object-lbs)))) total)) - -;;; We try to take an object that is untakable. Print a message -;;; depending on what it is. - -(defun dun-try-take (obj) - (dun-mprinc "You cannot take that.")) - -(defun dun-dig (args) - (if dun-inbus - (dun-mprincl "You can't dig while on the bus.") - (if (not (member 0 dun-inventory)) - (dun-mprincl "You have nothing with which to dig.") - (if (not (nth dun-current-room dun-diggables)) - (dun-mprincl "Digging here reveals nothing.") - (dun-mprincl "I think you found something.") - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (nth dun-current-room dun-diggables))) - (dun-replace dun-diggables dun-current-room nil))))) - -(defun dun-climb (obj) - (let (objnum) - (setq objnum (dun-objnum-from-args obj)) - (cond ((null objnum) - (dun-mprincl "I don't know that name.")) - ((and (not (eq objnum obj-special)) - (not (member objnum (nth dun-current-room dun-room-objects))) - (not (member objnum (nth dun-current-room dun-room-silents))) - (not (member objnum dun-inventory))) - (dun-mprincl "I don't see that here.")) - ((and (eq objnum obj-special) - (not (member obj-tree (nth dun-current-room dun-room-silents)))) - (dun-mprincl "There is nothing here to climb.")) - ((and (not (eq objnum obj-tree)) (not (eq objnum obj-special))) - (dun-mprincl "You can't climb that.")) - (t - (dun-mprincl - "You manage to get about two feet up the tree and fall back down. You -notice that the tree is very unsteady."))))) - -(defun dun-eat (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (member objnum dun-inventory)) - (dun-mprincl "You don't have that.") - (if (not (= objnum obj-food)) - (progn - (dun-mprinc "You forcefully shove ") - (dun-mprinc (downcase (cadr (nth objnum dun-objects)))) - (dun-mprincl " down your throat, and start choking.") - (dun-die "choking")) - (dun-mprincl "That tasted horrible.") - (dun-remove-obj-from-inven obj-food)))))) - -(defun dun-put (args) - (if dun-inbus - (dun-mprincl "You can't do that while on the bus") - (let (newargs objnum objnum2 obj) - (setq newargs (dun-firstwordl args)) - (if (not newargs) - (dun-mprincl "You must supply an object") - (setq obj (intern (car newargs))) - (setq objnum (cdr (assq obj dun-objnames))) - (if (not objnum) - (dun-mprincl "I don't know what that object is.") - (if (not (member objnum dun-inventory)) - (dun-mprincl "You don't have that.") - (setq newargs (dun-firstwordl (cdr newargs))) - (setq newargs (dun-firstwordl (cdr newargs))) - (if (not newargs) - (dun-mprincl "You must supply an indirect object.") - (setq objnum2 (cdr (assq (intern (car newargs)) dun-objnames))) - (if (and (eq objnum2 obj-computer) (= dun-current-room pc-area)) - (setq objnum2 obj-pc)) - (if (not objnum2) - (dun-mprincl "I don't know what that indirect object is.") - (if (and (not (member objnum2 - (nth dun-current-room dun-room-objects))) - (not (member objnum2 - (nth dun-current-room dun-room-silents))) - (not (member objnum2 dun-inventory))) - (dun-mprincl "That indirect object is not here.") - (dun-put-objs objnum objnum2)))))))))) - -(defun dun-put-objs (obj1 obj2) - (if (and (= obj2 obj-drop) (not dun-nomail)) - (setq obj2 obj-chute)) - - (if (= obj2 obj-disposal) (setq obj2 obj-chute)) - - (if (and (= obj1 obj-cpu) (= obj2 obj-computer)) - (progn - (dun-remove-obj-from-inven obj-cpu) - (setq dun-computer t) - (dun-mprincl -"As you put the CPU board in the computer, it immediately springs to life. -The lights start flashing, and the fans seem to startup.")) - (if (and (= obj1 obj-weight) (= obj2 obj-button)) - (dun-drop '("weight")) - (if (= obj2 obj-jar) ;; Put something in jar - (if (not (member obj1 (list obj-paper obj-diamond obj-emerald - obj-license obj-coins obj-egg - obj-nitric obj-glycerine))) - (dun-mprincl "That will not fit in the jar.") - (dun-remove-obj-from-inven obj1) - (setq dun-jar (append dun-jar (list obj1))) - (dun-mprincl "Done.")) - (if (= obj2 obj-chute) ;; Put something in chute - (progn - (dun-remove-obj-from-inven obj1) - (dun-mprincl -"You hear it slide down the chute and off into the distance.") - (dun-put-objs-in-treas (list obj1))) - (if (= obj2 obj-box) ;; Put key in key box - (if (= obj1 obj-key) - (progn - (dun-mprincl -"As you drop the key, the box begins to shake. Finally it explodes -with a bang. The key seems to have vanished!") - (dun-remove-obj-from-inven obj1) - (dun-replace dun-room-objects computer-room (append - (nth computer-room - dun-room-objects) - (list obj1))) - (dun-remove-obj-from-room dun-current-room obj-box) - (setq dun-key-level (1+ dun-key-level))) - (dun-mprincl "You can't put that in the key box!")) - - (if (and (= obj1 obj-floppy) (= obj2 obj-pc)) - (progn - (setq dun-floppy t) - (dun-remove-obj-from-inven obj1) - (dun-mprincl "Done.")) - - (if (= obj2 obj-urinal) ;; Put object in urinal - (progn - (dun-remove-obj-from-inven obj1) - (dun-replace dun-room-objects urinal (append - (nth urinal dun-room-objects) - (list obj1))) - (dun-mprincl - "You hear it plop down in some water below.")) - (if (= obj2 obj-mail) - (dun-mprincl "The mail chute is locked.") - (if (member obj1 dun-inventory) - (dun-mprincl -"I don't know how to combine those objects. Perhaps you should -just try dropping it.") - (dun-mprincl"You can't put that there."))))))))))) - -(defun dun-type (args) - (if (not (= dun-current-room computer-room)) - (dun-mprincl "There is nothing here on which you could type.") - (if (not dun-computer) - (dun-mprincl -"You type on the keyboard, but your characters do not even echo.") - (dun-unix-interface)))) - -;;; Various movement directions - -(defun dun-n (args) - (dun-move north)) - -(defun dun-s (args) - (dun-move south)) - -(defun dun-e (args) - (dun-move east)) - -(defun dun-w (args) - (dun-move west)) - -(defun dun-ne (args) - (dun-move northeast)) - -(defun dun-se (args) - (dun-move southeast)) - -(defun dun-nw (args) - (dun-move northwest)) - -(defun dun-sw (args) - (dun-move southwest)) - -(defun dun-up (args) - (dun-move up)) - -(defun dun-down (args) - (dun-move down)) - -(defun dun-in (args) - (dun-move in)) - -(defun dun-out (args) - (dun-move out)) - -(defun dun-go (args) - (if (or (not (car args)) - (eq (dun-doverb dun-ignore dun-verblist (car args) - (cdr (cdr args))) -1)) - (dun-mprinc "I don't understand where you want me to go.\n"))) - -;;; Uses the dungeon-map to figure out where we are going. If the -;;; requested direction yields 255, we know something special is -;;; supposed to happen, or perhaps you can't go that way unless -;;; certain conditions are met. - -(defun dun-move (dir) - (if (and (not (member dun-current-room dun-light-rooms)) - (not (member obj-lamp dun-inventory))) - (progn - (dun-mprinc -"You trip over a grue and fall into a pit and break every bone in your -body.") - (dun-die "a grue")) - (let (newroom) - (setq newroom (nth dir (nth dun-current-room dungeon-map))) - (if (eq newroom -1) - (dun-mprinc "You can't go that way.\n") - (if (eq newroom 255) - (dun-special-move dir) - (setq room -1) - (setq dun-lastdir dir) - (if dun-inbus - (progn - (if (or (< newroom 58) (> newroom 83)) - (dun-mprincl "The bus cannot go this way.") - (dun-mprincl - "The bus lurches ahead and comes to a screeching halt.") - (dun-remove-obj-from-room dun-current-room obj-bus) - (setq dun-current-room newroom) - (dun-replace dun-room-objects newroom - (append (nth newroom dun-room-objects) - (list obj-bus))))) - (setq dun-current-room newroom))))))) - -;;; Movement in this direction causes something special to happen if the -;;; right conditions exist. It may be that you can't go this way unless -;;; you have a key, or a passage has been opened. - -;;; coding note: Each check of the current room is on the same 'if' level, -;;; i.e. there aren't else's. If two rooms next to each other have -;;; specials, and they are connected by specials, this could cause -;;; a problem. Be careful when adding them to consider this, and -;;; perhaps use else's. - -(defun dun-special-move (dir) - (if (= dun-current-room building-front) - (if (not (member obj-key dun-inventory)) - (dun-mprincl "You don't have a key that can open this door.") - (setq dun-current-room old-building-hallway)) - (if (= dun-current-room north-end-of-cave-passage) - (let (combo) - (dun-mprincl -"You must type a 3 digit combination code to enter this room.") - (dun-mprinc "Enter it here: ") - (setq combo (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (string= combo dun-combination) - (setq dun-current-room gamma-computing-center) - (dun-mprincl "Sorry, that combination is incorrect.")))) - - (if (= dun-current-room bear-hangout) - (if (member obj-bear (nth bear-hangout dun-room-objects)) - (progn - (dun-mprinc -"The bear is very annoyed that you would be so presumptuous as to try -and walk right by it. He tells you so by tearing your head off. -") - (dun-die "a bear")) - (dun-mprincl "You can't go that way."))) - - (if (= dun-current-room vermont-station) - (progn - (dun-mprincl -"As you board the train it immediately leaves the station. It is a very -bumpy ride. It is shaking from side to side, and up and down. You -sit down in one of the chairs in order to be more comfortable.") - (dun-mprincl -"\nFinally the train comes to a sudden stop, and the doors open, and some -force throws you out. The train speeds away.\n") - (setq dun-current-room museum-station))) - - (if (= dun-current-room old-building-hallway) - (if (and (member obj-key dun-inventory) - (> dun-key-level 0)) - (setq dun-current-room meadow) - (dun-mprincl "You don't have a key that can open this door."))) - - (if (and (= dun-current-room maze-button-room) (= dir northwest)) - (if (member obj-weight (nth maze-button-room dun-room-objects)) - (setq dun-current-room 18) - (dun-mprincl "You can't go that way."))) - - (if (and (= dun-current-room maze-button-room) (= dir up)) - (if (member obj-weight (nth maze-button-room dun-room-objects)) - (dun-mprincl "You can't go that way.") - (setq dun-current-room weight-room))) - - (if (= dun-current-room classroom) - (dun-mprincl "The door is locked.")) - - (if (or (= dun-current-room lakefront-north) - (= dun-current-room lakefront-south)) - (dun-swim nil)) - - (if (= dun-current-room reception-area) - (if (not (= dun-sauna-level 3)) - (setq dun-current-room health-club-front) - (dun-mprincl -"As you exit the building, you notice some flames coming out of one of the -windows. Suddenly, the building explodes in a huge ball of fire. The flames -engulf you, and you burn to death.") - (dun-die "burning"))) - - (if (= dun-current-room red-room) - (if (not (member obj-towel (nth red-room dun-room-objects))) - (setq dun-current-room long-n-s-hallway) - (dun-mprincl "You can't go that way."))) - - (if (and (> dir down) (> dun-current-room gamma-computing-center) - (< dun-current-room museum-lobby)) - (if (not (member obj-bus (nth dun-current-room dun-room-objects))) - (dun-mprincl "You can't go that way.") - (if (= dir in) - (if (member obj-license dun-inventory) - (progn - (dun-mprincl - "You board the bus and get in the driver's seat.") - (setq dun-nomail t) - (setq dun-inbus t)) - (dun-mprincl "You are not licensed for this type of vehicle.")) - (dun-mprincl "You hop off the bus.") - (setq dun-inbus nil))) - (if (= dun-current-room fifth-oaktree-intersection) - (if (not dun-inbus) - (progn - (dun-mprincl "You fall down the cliff and land on your head.") - (dun-die "a cliff")) - (dun-mprincl -"The bus flies off the cliff, and plunges to the bottom, where it explodes.") - (dun-die "a bus accident"))) - (if (= dun-current-room main-maple-intersection) - (progn - (if (not dun-inbus) - (dun-mprincl "The gate will not open.") - (dun-mprincl -"As the bus approaches, the gate opens and you drive through.") - (dun-remove-obj-from-room main-maple-intersection obj-bus) - (dun-replace dun-room-objects museum-entrance - (append (nth museum-entrance dun-room-objects) - (list obj-bus))) - (setq dun-current-room museum-entrance))))) - (if (= dun-current-room cave-entrance) - (progn - (dun-mprincl -"As you enter the room you hear a rumbling noise. You look back to see -huge rocks sliding down from the ceiling, and blocking your way out.\n") - (setq dun-current-room misty-room))))) - -(defun dun-long (args) - (setq dun-mode "long")) - -(defun dun-turn (obj) - (let (objnum direction) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (not (= objnum obj-dial)) - (dun-mprincl "You can't turn that.") - (setq direction (dun-firstword (cdr obj))) - (if (or (not direction) - (not (or (string= direction "clockwise") - (string= direction "counterclockwise")))) - (dun-mprincl "You must indicate clockwise or counterclockwise.") - (if (string= direction "clockwise") - (setq dun-sauna-level (+ dun-sauna-level 1)) - (setq dun-sauna-level (- dun-sauna-level 1))) - - (if (< dun-sauna-level 0) - (progn - (dun-mprincl - "The dial will not turn further in that direction.") - (setq dun-sauna-level 0)) - (dun-sauna-heat)))))))) - -(defun dun-sauna-heat () - (if (= dun-sauna-level 0) - (dun-mprincl - "The temperature has returned to normal room temperature.")) - (if (= dun-sauna-level 1) - (dun-mprincl "It is now luke warm in here. You begin to sweat.")) - (if (= dun-sauna-level 2) - (dun-mprincl "It is pretty hot in here. It is still very comfortable.")) - (if (= dun-sauna-level 3) - (progn - (dun-mprincl -"It is now very hot. There is something very refreshing about this.") - (if (or (member obj-rms dun-inventory) - (member obj-rms (nth dun-current-room dun-room-objects))) - (progn - (dun-mprincl -"You notice the wax on your statuette beginning to melt, until it completely -melts off. You are left with a beautiful diamond!") - (if (member obj-rms dun-inventory) - (progn - (dun-remove-obj-from-inven obj-rms) - (setq dun-inventory (append dun-inventory - (list obj-diamond)))) - (dun-remove-obj-from-room dun-current-room obj-rms) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-diamond)))))) - (if (or (member obj-floppy dun-inventory) - (member obj-floppy (nth dun-current-room dun-room-objects))) - (progn - (dun-mprincl -"You notice your floppy disk beginning to melt. As you grab for it, the -disk bursts into flames, and disintegrates.") - (if (member obj-floppy dun-inventory) - (dun-remove-obj-from-inven obj-floppy) - (dun-remove-obj-from-room dun-current-room obj-floppy)))))) - - (if (= dun-sauna-level 4) - (progn - (dun-mprincl -"As the dial clicks into place, you immediately burst into flames.") - (dun-die "burning")))) - -(defun dun-press (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (not (member objnum (list obj-button obj-switch))) - (progn - (dun-mprinc "You can't ") - (dun-mprinc (car line-list)) - (dun-mprincl " that.")) - (if (= objnum obj-button) - (dun-mprincl -"As you press the button, you notice a passageway open up, but -as you release it, the passageway closes.")) - (if (= objnum obj-switch) - (if dun-black - (progn - (dun-mprincl "The button is now in the off position.") - (setq dun-black nil)) - (dun-mprincl "The button is now in the on position.") - (setq dun-black t)))))))) - -(defun dun-swim (args) - (if (not (member dun-current-room (list lakefront-north lakefront-south))) - (dun-mprincl "I see no water!") - (if (not (member obj-life dun-inventory)) - (progn - (dun-mprincl -"You dive in the water, and at first notice it is quite cold. You then -start to get used to it as you realize that you never really learned how -to swim.") - (dun-die "drowning")) - (if (= dun-current-room lakefront-north) - (setq dun-current-room lakefront-south) - (setq dun-current-room lakefront-north))))) - - -(defun dun-score (args) - (if (not dun-endgame) - (let (total) - (setq total (dun-reg-score)) - (dun-mprinc "You have scored ") - (dun-mprinc total) - (dun-mprincl " out of a possible 90 points.") total) - (dun-mprinc "You have scored ") - (dun-mprinc (dun-endgame-score)) - (dun-mprincl " endgame points out of a possible 110.") - (if (= (dun-endgame-score) 110) - (dun-mprincl -"\n\nCongratulations. You have won. The wizard password is 'moby'")))) - -(defun dun-help (args) - (dun-mprincl -"Welcome to dunnet (2.0), by Ron Schnell (ronnie@media.mit.edu). -Here is some useful information (read carefully because there are one -or more clues in here): -- If you have a key that can open a door, you do not need to explicitly - open it. You may just use 'in' or walk in the direction of the door. - -- If you have a lamp, it is always lit. - -- You will not get any points until you manage to get treasures to a certain - place. Simply finding the treasures is not good enough. There is more - than one way to get a treasure to the special place. It is also - important that the objects get to the special place *unharmed* and - *untarnished*. You can tell if you have successfully transported the - object by looking at your score, as it changes immediately. Note that - an object can become harmed even after you have received points for it. - If this happens, your score will decrease, and in many cases you can never - get credit for it again. - -- You can save your game with the 'save' command, and use restore it - with the 'restore' command. - -- There are no limits on lengths of object names. - -- Directions are: north,south,east,west,northeast,southeast,northwest, - southwest,up,down,in,out. - -- These can be abbreviated: n,s,e,w,ne,se,nw,sw,u,d,in,out. - -- If you go down a hole in the floor without an aid such as a ladder, - you probably won't be able to get back up the way you came, if at all. - -- To run this game in batch mode (no emacs window), use: - emacs -batch -l dunnet - -If you have questions or comments, please contact ronnie@media.mit.edu.")) - -(defun dun-flush (args) - (if (not (= dun-current-room bathroom)) - (dun-mprincl "I see nothing to flush.") - (dun-mprincl "Whoooosh!!") - (dun-put-objs-in-treas (nth urinal dun-room-objects)) - (dun-replace dun-room-objects urinal nil))) - -(defun dun-piss (args) - (if (not (= dun-current-room bathroom)) - (dun-mprincl "You can't do that here, don't even bother trying.") - (if (not dun-gottago) - (dun-mprincl "I'm afraid you don't have to go now.") - (dun-mprincl "That was refreshing.") - (setq dun-gottago nil) - (dun-replace dun-room-objects urinal (append - (nth urinal dun-room-objects) - (list obj-URINE)))))) - - -(defun dun-sleep (args) - (if (not (= dun-current-room bedroom)) - (dun-mprincl -"You try to go to sleep while standing up here, but can't seem to do it.") - (setq dun-gottago t) - (dun-mprincl -"As soon as you start to doze off you begin dreaming. You see images of -workers digging caves, slaving in the humid heat. Then you see yourself -as one of these workers. While no one is looking, you leave the group -and walk into a room. The room is bare except for a horseshoe -shaped piece of stone in the center. You see yourself digging a hole in -the ground, then putting some kind of treasure in it, and filling the hole -with dirt again. After this, you immediately wake up."))) - -(defun dun-break (obj) - (let (objnum) - (if (not (member obj-axe dun-inventory)) - (dun-mprincl "You have nothing you can use to break things.") - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (member objnum dun-inventory) - (progn - (dun-mprincl -"You take the object in your hands and swing the axe. Unfortunately, you miss -the object and slice off your hand. You bleed to death.") - (dun-die "an axe")) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum - (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (= objnum obj-cable) - (progn - (dun-mprincl -"As you break the ethernet cable, everything starts to blur. You collapse -for a moment, then straighten yourself up. -") - (dun-replace dun-room-objects gamma-computing-center - (append - (nth gamma-computing-center dun-room-objects) - dun-inventory)) - (if (member obj-key dun-inventory) - (progn - (setq dun-inventory (list obj-key)) - (dun-remove-obj-from-room - gamma-computing-center obj-key)) - (setq dun-inventory nil)) - (setq dun-current-room computer-room) - (setq dun-ethernet nil) - (dun-mprincl "Connection closed.") - (dun-unix-interface)) - (if (< objnum 0) - (progn - (dun-mprincl "Your axe shatters into a million pieces.") - (dun-remove-obj-from-inven obj-axe)) - (dun-mprincl "Your axe breaks it into a million pieces.") - (dun-remove-obj-from-room dun-current-room objnum))))))))) - -(defun dun-drive (args) - (if (not dun-inbus) - (dun-mprincl "You cannot drive when you aren't in a vehicle.") - (dun-mprincl "To drive while you are in the bus, just give a direction."))) - -(defun dun-superb (args) - (setq dun-mode 'dun-superb)) - -(defun dun-reg-score () - (let (total) - (setq total 0) - (dolist (x (nth treasure-room dun-room-objects)) - (setq total (+ total (nth x dun-object-pts)))) - (if (member obj-URINE (nth treasure-room dun-room-objects)) - (setq total 0)) total)) - -(defun dun-endgame-score () - (let (total) - (setq total 0) - (dolist (x (nth endgame-treasure-room dun-room-objects)) - (setq total (+ total (nth x dun-object-pts)))) total)) - -(defun dun-answer (args) - (if (not dun-correct-answer) - (dun-mprincl "I don't believe anyone asked you anything.") - (setq args (car args)) - (if (not args) - (dun-mprincl "You must give the answer on the same line.") - (if (dun-members args dun-correct-answer) - (progn - (dun-mprincl "Correct.") - (if (= dun-lastdir 0) - (setq dun-current-room (1+ dun-current-room)) - (setq dun-current-room (- dun-current-room 1))) - (setq dun-correct-answer nil)) - (dun-mprincl "That answer is incorrect."))))) - -(defun dun-endgame-question () -(if (not dun-endgame-questions) - (progn - (dun-mprincl "Your question is:") - (dun-mprincl "No more questions, just do 'answer foo'.") - (setq dun-correct-answer '("foo"))) - (let (which i newques) - (setq i 0) - (setq newques nil) - (setq which (random (length dun-endgame-questions))) - (dun-mprincl "Your question is:") - (dun-mprincl (setq dun-endgame-question (car - (nth which - dun-endgame-questions)))) - (setq dun-correct-answer (cdr (nth which dun-endgame-questions))) - (while (< i which) - (setq newques (append newques (list (nth i dun-endgame-questions)))) - (setq i (1+ i))) - (setq i (1+ which)) - (while (< i (length dun-endgame-questions)) - (setq newques (append newques (list (nth i dun-endgame-questions)))) - (setq i (1+ i))) - (setq dun-endgame-questions newques)))) - -(defun dun-power (args) - (if (not (= dun-current-room pc-area)) - (dun-mprincl "That operation is not applicable here.") - (if (not dun-floppy) - (dun-dos-no-disk) - (dun-dos-interface)))) - -(defun dun-feed (args) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std args)) - (if (and (= objnum obj-bear) - (member obj-bear (nth dun-current-room dun-room-objects))) - (progn - (if (not (member obj-food dun-inventory)) - (dun-mprincl "You have nothing with which to feed it.") - (dun-drop '("food")))) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum dun-inventory) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (dun-mprincl "You cannot feed that.")))))) - - -;;;; -;;;; This section defines various utility functions used -;;;; by dunnet. -;;;; - - -;;; Function which takes a verb and a list of other words. Calls proper -;;; function associated with the verb, and passes along the other words. - -(defun dun-doverb (dun-ignore dun-verblist verb rest) - (if (not verb) - nil - (if (member (intern verb) dun-ignore) - (if (not (car rest)) -1 - (dun-doverb dun-ignore dun-verblist (car rest) (cdr rest))) - (if (not (cdr (assq (intern verb) dun-verblist))) -1 - (setq dun-numcmds (1+ dun-numcmds)) - (eval (list (cdr (assq (intern verb) dun-verblist)) (quote rest))))))) - - -;;; Function to take a string and change it into a list of lowercase words. - -(defun dun-listify-string (strin) - (let (pos ret-list end-pos) - (setq pos 0) - (setq ret-list nil) - (while (setq end-pos (string-match "[ ,:;]" (substring strin pos))) - (setq end-pos (+ end-pos pos)) - (if (not (= end-pos pos)) - (setq ret-list (append ret-list (list - (downcase - (substring strin pos end-pos)))))) - (setq pos (+ end-pos 1))) ret-list)) - -(defun dun-listify-string2 (strin) - (let (pos ret-list end-pos) - (setq pos 0) - (setq ret-list nil) - (while (setq end-pos (string-match " " (substring strin pos))) - (setq end-pos (+ end-pos pos)) - (if (not (= end-pos pos)) - (setq ret-list (append ret-list (list - (downcase - (substring strin pos end-pos)))))) - (setq pos (+ end-pos 1))) ret-list)) - -(defun dun-replace (list n number) - (rplaca (nthcdr n list) number)) - - -;;; Get the first non-ignored word from a list. - -(defun dun-firstword (list) - (if (not (car list)) - nil - (while (and list (member (intern (car list)) dun-ignore)) - (setq list (cdr list))) - (car list))) - -(defun dun-firstwordl (list) - (if (not (car list)) - nil - (while (and list (member (intern (car list)) dun-ignore)) - (setq list (cdr list))) - list)) - -;;; parse a line passed in as a string Call the proper verb with the -;;; rest of the line passed in as a list. - -(defun dun-vparse (dun-ignore dun-verblist line) - (dun-mprinc "\n") - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-parse2 (dun-ignore dun-verblist line) - (dun-mprinc "\n") - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -;;; Read a line, in window mode - -(defun dun-read-line () - (let (line) - (setq line (read-string "")) - (dun-mprinc line) line)) - -;;; Insert something into the window buffer - -(defun dun-minsert (string) - (if (stringp string) - (insert string) - (insert (prin1-to-string string)))) - -;;; Print something out, in window mode - -(defun dun-mprinc (string) - (if (stringp string) - (insert string) - (insert (prin1-to-string string)))) - -;;; In window mode, keep screen from jumping by keeping last line at -;;; the bottom of the screen. - -(defun dun-fix-screen () - (interactive) - (forward-line (- 0 (- (window-height) 2 ))) - (set-window-start (selected-window) (point)) - (end-of-buffer)) - -;;; Insert something into the buffer, followed by newline. - -(defun dun-minsertl (string) - (dun-minsert string) - (dun-minsert "\n")) - -;;; Print something, followed by a newline. - -(defun dun-mprincl (string) - (dun-mprinc string) - (dun-mprinc "\n")) - -;;; Function which will get an object number given the list of -;;; words in the command, except for the verb. - -(defun dun-objnum-from-args (obj) - (let (objnum) - (setq obj (dun-firstword obj)) - (if (not obj) - obj-special - (setq objnum (cdr (assq (intern obj) dun-objnames)))))) - -(defun dun-objnum-from-args-std (obj) - (let (result) - (if (eq (setq result (dun-objnum-from-args obj)) obj-special) - (dun-mprincl "You must supply an object.")) - (if (eq result nil) - (dun-mprincl "I don't know what that is.")) - (if (eq result obj-special) - nil - result))) - -;;; Take a short room description, and change spaces and slashes to dashes. - -(defun dun-space-to-hyphen (string) - (let (space) - (if (setq space (string-match "[ /]" string)) - (progn - (setq string (concat (substring string 0 space) "-" - (substring string (1+ space)))) - (dun-space-to-hyphen string)) - string))) - -;;; Given a unix style pathname, build a list of path components (recursive) - -(defun dun-get-path (dirstring startlist) - (let (slash pos) - (if (= (length dirstring) 0) - startlist - (if (string= (substring dirstring 0 1) "/") - (dun-get-path (substring dirstring 1) (append startlist (list "/"))) - (if (not (setq slash (string-match "/" dirstring))) - (append startlist (list dirstring)) - (dun-get-path (substring dirstring (1+ slash)) - (append startlist - (list (substring dirstring 0 slash))))))))) - - -;;; Is a string a member of a string list? - -(defun dun-members (string string-list) - (let (found) - (setq found nil) - (dolist (x string-list) - (if (string= x string) - (setq found t))) found)) - -;;; Function to put objects in the treasure room. Also prints current -;;; score to let user know he has scored. - -(defun dun-put-objs-in-treas (objlist) - (let (oscore newscore) - (setq oscore (dun-reg-score)) - (dun-replace dun-room-objects 0 (append (nth 0 dun-room-objects) objlist)) - (setq newscore (dun-reg-score)) - (if (not (= oscore newscore)) - (dun-score nil)))) - -;;; Load an encrypted file, and eval it. - -(defun dun-load-d (filename) - (let (old-buffer result) - (setq result t) - (setq old-buffer (current-buffer)) - (switch-to-buffer (get-buffer-create "*loadc*")) - (erase-buffer) - (condition-case nil - (insert-file-contents filename) - (error (setq result nil))) - (unless (not result) - (condition-case nil - (dun-rot13) - (error (yank))) - (eval-current-buffer) - (kill-buffer (current-buffer)) - (switch-to-buffer old-buffer)) - result)) - -;;; Functions to remove an object either from a room, or from inventory. - -(defun dun-remove-obj-from-room (room objnum) - (let (newroom) - (setq newroom nil) - (dolist (x (nth room dun-room-objects)) - (if (not (= x objnum)) - (setq newroom (append newroom (list x))))) - (rplaca (nthcdr room dun-room-objects) newroom))) - -(defun dun-remove-obj-from-inven (objnum) - (let (new-inven) - (setq new-inven nil) - (dolist (x dun-inventory) - (if (not (= x objnum)) - (setq new-inven (append new-inven (list x))))) - (setq dun-inventory new-inven))) - - -(let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (setq dun-translate-table (make-vector 256 0)) - (while (< i 256) - (aset dun-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower)) - (setq upper (upcase lower)) - (setq i 0) - (while (< i 26) - (aset dun-translate-table (+ ?a i) (aref lower (+ i 13))) - (aset dun-translate-table (+ ?A i) (aref upper (+ i 13))) - (setq i (1+ i)))) - -(defun dun-rot13 () - (let (str len (i 0)) - (setq str (buffer-substring (point-min) (point-max))) - (setq len (length str)) - (while (< i len) - (aset str i (aref dun-translate-table (aref str i))) - (setq i (1+ i))) - (erase-buffer) - (insert str))) - -;;;; -;;;; This section defines the globals that are used in dunnet. -;;;; -;;;; IMPORTANT -;;;; All globals which can change must be saved from 'save-game. Add -;;;; all new globals to bottom of file. - -(setq dun-visited '(27)) -(setq dun-current-room 1) -(setq dun-exitf nil) -(setq dun-badcd nil) -(defvar dungeon-mode-map nil) -(setq dungeon-mode-map (make-sparse-keymap)) -(define-key dungeon-mode-map "\r" 'dun-parse) -;; XEmacs -(defvar dungeon-batch-map - (let ((map (make-keymap)) - (n 32)) - (while (< 0 (setq n (- n 1))) - (define-key map (make-string 1 n) 'dungeon-nil)) - (define-key map "\r" 'exit-minibuffer) - (define-key map "\n" 'exit-minibuffer) - map)) -(setq dun-computer nil) -(setq dun-floppy nil) -(setq dun-key-level 0) -(setq dun-hole nil) -(setq dun-correct-answer nil) -(setq dun-lastdir 0) -(setq dun-numsaves 0) -(setq dun-jar nil) -(setq dun-dead nil) -(setq room 0) -(setq dun-numcmds 0) -(setq dun-wizard nil) -(setq dun-endgame-question nil) -(setq dun-logged-in nil) -(setq dungeon-mode 'dungeon) -(setq dun-unix-verbs '((ls . dun-ls) (ftp . dun-ftp) (echo . dun-echo) - (exit . dun-uexit) (cd . dun-cd) (pwd . dun-pwd) - (rlogin . dun-rlogin) (uncompress . dun-uncompress) - (cat . dun-cat) (zippy . dun-zippy))) - -(setq dun-dos-verbs '((dir . dun-dos-dir) (type . dun-dos-type) - (exit . dun-dos-exit) (command . dun-dos-spawn) - (b: . dun-dos-invd) (c: . dun-dos-invd) - (a: . dun-dos-nil))) - - -(setq dun-batch-mode nil) - -(setq dun-cdpath "/usr/toukmond") -(setq dun-cdroom -10) -(setq dun-uncompressed nil) -(setq dun-ethernet t) -(setq dun-restricted - '(dun-room-objects dungeon-map dun-rooms - dun-room-silents dun-combination)) -(setq dun-ftptype 'ascii) -(setq dun-endgame nil) -(setq dun-gottago t) -(setq dun-black nil) - -(setq dun-rooms '( - ( -"You are in the treasure room. A door leads out to the north." - "Treasure room" - ) - ( -"You are at a dead end of a dirt road. The road goes to the east. -In the distance you can see that it will eventually fork off. The -trees here are very tall royal palms, and they are spaced equidistant -from each other." - "Dead end" - ) - ( -"You are on the continuation of a dirt road. There are more trees on -both sides of you. The road continues to the east and west." - "E/W Dirt road" - ) - ( -"You are at a fork of two passages, one to the northeast, and one to the -southeast. The ground here seems very soft. You can also go back west." - "Fork" - ) - ( -"You are on a northeast/southwest road." - "NE/SW road" - ) - ( -"You are at the end of the road. There is a building in front of you -to the northeast, and the road leads back to the southwest." - "Building front" - ) - ( -"You are on a southeast/northwest road." - "SE/NW road" - ) - ( -"You are standing at the end of a road. A passage leads back to the -northwest." - "Bear hangout" - ) - ( -"You are in the hallway of an old building. There are rooms to the east -and west, and doors leading out to the north and south." - "Old Building hallway" - ) - ( -"You are in a mailroom. There are many bins where the mail is usually -kept. The exit is to the west." - "Mailroom" - ) - ( -"You are in a computer room. It seems like most of the equipment has -been removed. There is a VAX 11/780 in front of you, however, with -one of the cabinets wide open. A sign on the front of the machine -says: This VAX is named 'pokey'. To type on the console, use the -'type' command. The exit is to the east." - "Computer room" - ) - ( -"You are in a meadow in the back of an old building. A small path leads -to the west, and a door leads to the south." - "Meadow" - ) - ( -"You are in a round, stone room with a door to the east. There -is a sign on the wall that reads: 'receiving room'." - "Receiving room" - ) - ( -"You are at the south end of a hallway that leads to the north. There -are rooms to the east and west." - "Northbound Hallway" - ) - ( -"You are in a sauna. There is nothing in the room except for a dial -on the wall. A door leads out to west." - "Sauna" - ) - ( -"You are at the end of a north/south hallway. You can go back to the south, -or off to a room to the east." - "End of N/S Hallway" - ) - ( -"You are in an old weight room. All of the equipment is either destroyed -or completely broken. There is a door out to the west, and there is a ladder -leading down a hole in the floor." - "Weight room" ;16 - ) - ( -"You are in a maze of twisty little passages, all alike. -There is a button on the ground here." - "Maze button room" - ) - ( -"You are in a maze of little twisty passages, all alike." - "Maze" - ) - ( -"You are in a maze of thirsty little passages, all alike." - "Maze" ;19 - ) - ( -"You are in a maze of twenty little passages, all alike." - "Maze" - ) - ( -"You are in a daze of twisty little passages, all alike." - "Maze" ;21 - ) - ( -"You are in a maze of twisty little cabbages, all alike." - "Maze" ;22 - ) - ( -"You are in a reception area for a health and fitness center. The place -appears to have been recently ransacked, and nothing is left. There is -a door out to the south, and a crawlspace to the southeast." - "Reception area" - ) - ( -"You are outside a large building to the north which used to be a health -and fitness center. A road leads to the south." - "Health Club front" - ) - ( -"You are at the north side of a lake. On the other side you can see -a road which leads to a cave. The water appears very deep." - "Lakefront North" - ) - ( -"You are at the south side of a lake. A road goes to the south." - "Lakefront South" - ) - ( -"You are in a well-hidden area off to the side of a road. Back to the -northeast through the brush you can see the bear hangout." - "Hidden area" - ) - ( -"The entrance to a cave is to the south. To the north, a road leads -towards a deep lake. On the ground nearby there is a chute, with a sign -that says 'put treasures here for points'." - "Cave Entrance" ;28 - ) - ( -"You are in a misty, humid room carved into a mountain. -To the north is the remains of a rockslide. To the east, a small -passage leads away into the darkness." ;29 - "Misty Room" - ) - ( -"You are in an east/west passageway. The walls here are made of -multicolored rock and are quite beautiful." - "Cave E/W passage" ;30 - ) - ( -"You are at the junction of two passages. One goes north/south, and -the other goes west." - "N/S/W Junction" ;31 - ) - ( -"You are at the north end of a north/south passageway. There are stairs -leading down from here. There is also a door leading west." - "North end of cave passage" ;32 - ) - ( -"You are at the south end of a north/south passageway. There is a hole -in the floor here, into which you could probably fit." - "South end of cave passage" ;33 - ) - ( -"You are in what appears to be a worker's bedroom. There is a queen- -sized bed in the middle of the room, and a painting hanging on the -wall. A door leads to another room to the south, and stairways -lead up and down." - "Bedroom" ;34 - ) - ( -"You are in a bathroom built for workers in the cave. There is a -urinal hanging on the wall, and some exposed pipes on the opposite -wall where a sink used to be. To the north is a bedroom." - "Bathroom" ;35 - ) - ( -"This is a marker for the urinal. User will not see this, but it -is a room that can contain objects." - "Urinal" ;36 - ) - ( -"You are at the northeast end of a northeast/southwest passageway. -Stairs lead up out of sight." - "Ne end of ne/sw cave passage" ;37 - ) - ( -"You are at the junction of northeast/southwest and east/west passages." - "Ne/sw-e/w junction" ;38 - ) - ( -"You are at the southwest end of a northeast/southwest passageway." - "Sw end of ne/sw cave passage" ;39 - ) - ( -"You are at the east end of an e/w passage. There are stairs leading up -to a room above." - "East end of e/w cave passage" ;40 - ) - ( -"You are at the west end of an e/w passage. There is a hole on the ground -which leads down out of sight." - "West end of e/w cave passage" ;41 - ) - ( -"You are in a room which is bare, except for a horseshoe shaped boulder -in the center. Stairs lead down from here." ;42 - "Horseshoe boulder room" - ) - ( -"You are in a room which is completely empty. Doors lead out to the north -and east." - "Empty room" ;43 - ) - ( -"You are in an empty room. Interestingly enough, the stones in this -room are painted blue. Doors lead out to the east and south." ;44 - "Blue room" - ) - ( -"You are in an empty room. Interestingly enough, the stones in this -room are painted yellow. Doors lead out to the south and west." ;45 - "Yellow room" - ) - ( -"You are in an empty room. Interestingly enough, the stones in this room -are painted red. Doors lead out to the west and north." - "Red room" ;46 - ) - ( -"You are in the middle of a long north/south hallway." ;47 - "Long n/s hallway" - ) - ( -"You are 3/4 of the way towards the north end of a long north/south hallway." - "3/4 north" ;48 - ) - ( -"You are at the north end of a long north/south hallway. There are stairs -leading upwards." - "North end of long hallway" ;49 - ) - ( -"You are 3/4 of the way towards the south end of a long north/south hallway." - "3/4 south" ;50 - ) - ( -"You are at the south end of a long north/south hallway. There is a hole -to the south." - "South end of long hallway" ;51 - ) - ( -"You are at a landing in a stairwell which continues up and down." - "Stair landing" ;52 - ) - ( -"You are at the continuation of an up/down staircase." - "Up/down staircase" ;53 - ) - ( -"You are at the top of a staircase leading down. A crawlway leads off -to the northeast." - "Top of staircase." ;54 - ) - ( -"You are in a crawlway that leads northeast or southwest." - "Ne crawlway" ;55 - ) - ( -"You are in a small crawlspace. There is a hole in the ground here, and -a small passage back to the southwest." - "Small crawlspace" ;56 - ) - ( -"You are in the Gamma Computing Center. An IBM 3090/600s is whirring -away in here. There is an ethernet cable coming out of one of the units, -and going through the ceiling. There is no console here on which you -could type." - "Gamma computing center" ;57 - ) - ( -"You are near the remains of a post office. There is a mail drop on the -face of the building, but you cannot see where it leads. A path leads -back to the east, and a road leads to the north." - "Post office" ;58 - ) - ( -"You are at the intersection of Main Street and Maple Ave. Main street -runs north and south, and Maple Ave runs east off into the distance. -If you look north and east you can see many intersections, but all of -the buildings that used to stand here are gone. Nothing remains except -street signs. -There is a road to the northwest leading to a gate that guards a building." - "Main-Maple intersection" ;59 - ) - ( -"You are at the intersection of Main Street and the west end of Oaktree Ave." - "Main-Oaktree intersection" ;60 - ) - ( -"You are at the intersection of Main Street and the west end of Vermont Ave." - "Main-Vermont intersection" ;61 - ) - ( -"You are at the north end of Main Street at the west end of Sycamore Ave." ;62 - "Main-Sycamore intersection" - ) - ( -"You are at the south end of First Street at Maple Ave." ;63 - "First-Maple intersection" - ) - ( -"You are at the intersection of First Street and Oaktree Ave." ;64 - "First-Oaktree intersection" - ) - ( -"You are at the intersection of First Street and Vermont Ave." ;65 - "First-Vermont intersection" - ) - ( -"You are at the north end of First Street at Sycamore Ave." ;66 - "First-Sycamore intersection" - ) - ( -"You are at the south end of Second Street at Maple Ave." ;67 - "Second-Maple intersection" - ) - ( -"You are at the intersection of Second Street and Oaktree Ave." ;68 - "Second-Oaktree intersection" - ) - ( -"You are at the intersection of Second Street and Vermont Ave." ;69 - "Second-Vermont intersection" - ) - ( -"You are at the north end of Second Street at Sycamore Ave." ;70 - "Second-Sycamore intersection" - ) - ( -"You are at the south end of Third Street at Maple Ave." ;71 - "Third-Maple intersection" - ) - ( -"You are at the intersection of Third Street and Oaktree Ave." ;72 - "Third-Oaktree intersection" - ) - ( -"You are at the intersection of Third Street and Vermont Ave." ;73 - "Third-Vermont intersection" - ) - ( -"You are at the north end of Third Street at Sycamore Ave." ;74 - "Third-Sycamore intersection" - ) - ( -"You are at the south end of Fourth Street at Maple Ave." ;75 - "Fourth-Maple intersection" - ) - ( -"You are at the intersection of Fourth Street and Oaktree Ave." ;76 - "Fourth-Oaktree intersection" - ) - ( -"You are at the intersection of Fourth Street and Vermont Ave." ;77 - "Fourth-Vermont intersection" - ) - ( -"You are at the north end of Fourth Street at Sycamore Ave." ;78 - "Fourth-Sycamore intersection" - ) - ( -"You are at the south end of Fifth Street at the east end of Maple Ave." ;79 - "Fifth-Maple intersection" - ) - ( -"You are at the intersection of Fifth Street and the east end of Oaktree Ave. -There is a cliff off to the east." - "Fifth-Oaktree intersection" ;80 - ) - ( -"You are at the intersection of Fifth Street and the east end of Vermont Ave." - "Fifth-Vermont intersection" ;81 - ) - ( -"You are at the north end of Fifth Street and the east end of Sycamore Ave." - "Fifth-Sycamore intersection" ;82 - ) - ( -"You are in front of the Museum of Natural History. A door leads into -the building to the north, and a road leads to the southeast." - "Museum entrance" ;83 - ) - ( -"You are in the main lobby for the Museum of Natural History. In the center -of the room is the huge skeleton of a dinosaur. Doors lead out to the -south and east." - "Museum lobby" ;84 - ) - ( -"You are in the geological display. All of the objects that used to -be on display are missing. There are rooms to the east, west, and -north." - "Geological display" ;85 - ) - ( -"You are in the marine life area. The room is filled with fish tanks, -which are filled with dead fish that have apparently died due to -starvation. Doors lead out to the south and east." - "Marine life area" ;86 - ) - ( -"You are in some sort of maintenance room for the museum. There is a -switch on the wall labeled 'BL'. There are doors to the west and north." - "Maintenance room" ;87 - ) - ( -"You are in a classroom where school children were taught about natural -history. On the blackboard is written, 'No children allowed downstairs.' -There is a door to the east with an 'exit' sign on it. There is another -door to the west." - "Classroom" ;88 - ) - ( -"You are at the Vermont St. subway station. A train is sitting here waiting." - "Vermont station" ;89 - ) - ( -"You are at the Museum subway stop. A passage leads off to the north." - "Museum station" ;90 - ) - ( -"You are in a north/south tunnel." - "N/S tunnel" ;91 - ) - ( -"You are at the north end of a north/south tunnel. Stairs lead up and -down from here. There is a garbage disposal here." - "North end of n/s tunnel" ;92 - ) - ( -"You are at the top of some stairs near the subway station. There is -a door to the west." - "Top of subway stairs" ;93 - ) - ( -"You are at the bottom of some stairs near the subway station. There is -a room to the northeast." - "Bottom of subway stairs" ;94 - ) - ( -"You are in another computer room. There is a computer in here larger -than you have ever seen. It has no manufacturers name on it, but it -does have a sign that says: This machine's name is 'endgame'. The -exit is to the southwest. There is no console here on which you could -type." - "Endgame computer room" ;95 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;96 - ) - ( -"You have reached a question room. You must answer a question correctly in -order to get by. Use the 'answer' command to answer the question." - "Question room 1" ;97 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;98 - ) - ( -"You are in a second question room." - "Question room 2" ;99 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;100 - ) - ( -"You are in a third question room." - "Question room 3" ;101 - ) - ( -"You are in the endgame treasure room. A door leads out to the north, and -a hallway leads to the south." - "Endgame treasure room" ;102 - ) - ( -"You are in the winner's room. A door leads back to the south." - "Winner's room" ;103 - ) - ( -"You have reached a dead end. There is a PC on the floor here. Above -it is a sign that reads: - Type the 'reset' command to type on the PC. -A hole leads north." - "PC area" ;104 - ) -)) - -(setq dun-light-rooms '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 24 25 26 27 28 58 59 - 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 - 77 78 79 80 81 82 83)) - -(setq dun-verblist '((die . dun-die) (ne . dun-ne) (north . dun-n) - (south . dun-s) (east . dun-e) (west . dun-w) - (u . dun-up) (d . dun-down) (i . dun-inven) - (inventory . dun-inven) (look . dun-examine) (n . dun-n) - (s . dun-s) (e . dun-e) (w . dun-w) (se . dun-se) - (nw . dun-nw) (sw . dun-sw) (up . dun-up) - (down . dun-down) (in . dun-in) (out . dun-out) - (go . dun-go) (drop . dun-drop) (southeast . dun-se) - (southwest . dun-sw) (northeast . dun-ne) - (northwest . dun-nw) (save . dun-save-game) - (restore . dun-restore) (long . dun-long) (dig . dun-dig) - (shake . dun-shake) (wave . dun-shake) - (examine . dun-examine) (describe . dun-examine) - (climb . dun-climb) (eat . dun-eat) (put . dun-put) - (type . dun-type) (insert . dun-put) - (score . dun-score) (help . dun-help) (quit . dun-quit) - (read . dun-examine) (verbose . dun-long) - (urinate . dun-piss) (piss . dun-piss) ; censored - (flush . dun-flush) (sleep . dun-sleep) (lie . dun-sleep) - (x . dun-examine) (break . dun-break) (drive . dun-drive) - (board . dun-in) (enter . dun-in) (turn . dun-turn) - (press . dun-press) (push . dun-press) (swim . dun-swim) - (on . dun-in) (off . dun-out) (chop . dun-break) - (switch . dun-press) (cut . dun-break) (exit . dun-out) - (leave . dun-out) (reset . dun-power) (flick . dun-press) - (superb . dun-superb) (answer . dun-answer) - (throw . dun-drop) (l . dun-examine) (take . dun-take) - (get . dun-take) (feed . dun-feed))) - -(setq dun-inbus nil) -(setq dun-nomail nil) -(setq dun-ignore '(the to at)) -(setq dun-mode 'moby) -(setq dun-sauna-level 0) - -(defconst north 0) -(defconst south 1) -(defconst east 2) -(defconst west 3) -(defconst northeast 4) -(defconst southeast 5) -(defconst northwest 6) -(defconst southwest 7) -(defconst up 8) -(defconst down 9) -(defconst in 10) -(defconst out 11) - -(setq dungeon-map '( -; no so ea we ne se nw sw up do in ot - ( 96 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;0 - ( -1 -1 2 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;1 - ( -1 -1 3 1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;2 - ( -1 -1 -1 2 4 6 -1 -1 -1 -1 -1 -1 ) ;3 - ( -1 -1 -1 -1 5 -1 -1 3 -1 -1 -1 -1 ) ;4 - ( -1 -1 -1 -1 255 -1 -1 4 -1 -1 255 -1 ) ;5 - ( -1 -1 -1 -1 -1 7 3 -1 -1 -1 -1 -1 ) ;6 - ( -1 -1 -1 -1 -1 255 6 27 -1 -1 -1 -1 ) ;7 - ( 255 5 9 10 -1 -1 -1 5 -1 -1 -1 5 ) ;8 - ( -1 -1 -1 8 -1 -1 -1 -1 -1 -1 -1 -1 ) ;9 - ( -1 -1 8 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;10 - ( -1 8 -1 58 -1 -1 -1 -1 -1 -1 -1 -1 ) ;11 - ( -1 -1 13 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;12 - ( 15 -1 14 12 -1 -1 -1 -1 -1 -1 -1 -1 ) ;13 - ( -1 -1 -1 13 -1 -1 -1 -1 -1 -1 -1 -1 ) ;14 - ( -1 13 16 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;15 - ( -1 -1 -1 15 -1 -1 -1 -1 -1 17 16 -1 ) ;16 - ( -1 -1 17 17 17 17 255 17 255 17 -1 -1 ) ;17 - ( 18 18 18 18 18 -1 18 18 19 18 -1 -1 ) ;18 - ( -1 18 18 19 19 20 19 19 -1 18 -1 -1 ) ;19 - ( -1 -1 -1 18 -1 -1 -1 -1 -1 21 -1 -1 ) ;20 - ( -1 -1 -1 -1 -1 20 22 -1 -1 -1 -1 -1 ) ;21 - ( 18 18 18 18 16 18 23 18 18 18 18 18 ) ;22 - ( -1 255 -1 -1 -1 19 -1 -1 -1 -1 -1 -1 ) ;23 - ( 23 25 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;24 - ( 24 255 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;25 - (255 28 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;26 - ( -1 -1 -1 -1 7 -1 -1 -1 -1 -1 -1 -1 ) ;27 - ( 26 255 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;28 - ( -1 -1 30 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;29 - ( -1 -1 31 29 -1 -1 -1 -1 -1 -1 -1 -1 ) ;30 - ( 32 33 -1 30 -1 -1 -1 -1 -1 -1 -1 -1 ) ;31 - ( -1 31 -1 255 -1 -1 -1 -1 -1 34 -1 -1 ) ;32 - ( 31 -1 -1 -1 -1 -1 -1 -1 -1 35 -1 -1 ) ;33 - ( -1 35 -1 -1 -1 -1 -1 -1 32 37 -1 -1 ) ;34 - ( 34 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;35 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;36 - ( -1 -1 -1 -1 -1 -1 -1 38 34 -1 -1 -1 ) ;37 - ( -1 -1 40 41 37 -1 -1 39 -1 -1 -1 -1 ) ;38 - ( -1 -1 -1 -1 38 -1 -1 -1 -1 -1 -1 -1 ) ;39 - ( -1 -1 -1 38 -1 -1 -1 -1 42 -1 -1 -1 ) ;40 - ( -1 -1 38 -1 -1 -1 -1 -1 -1 43 -1 -1 ) ;41 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 40 -1 -1 ) ;42 - ( 44 -1 46 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;43 - ( -1 43 45 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;44 - ( -1 46 -1 44 -1 -1 -1 -1 -1 -1 -1 -1 ) ;45 - ( 45 -1 -1 43 -1 -1 -1 -1 -1 255 -1 -1 ) ;46 - ( 48 50 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;47 - ( 49 47 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;48 - ( -1 48 -1 -1 -1 -1 -1 -1 52 -1 -1 -1 ) ;49 - ( 47 51 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;50 - ( 50 104 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;51 - ( -1 -1 -1 -1 -1 -1 -1 -1 53 49 -1 -1 ) ;52 - ( -1 -1 -1 -1 -1 -1 -1 -1 54 52 -1 -1 ) ;53 - ( -1 -1 -1 -1 55 -1 -1 -1 -1 53 -1 -1 ) ;54 - ( -1 -1 -1 -1 56 -1 -1 54 -1 -1 -1 54 ) ;55 - ( -1 -1 -1 -1 -1 -1 -1 55 -1 31 -1 -1 ) ;56 - ( -1 -1 32 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;57 - ( 59 -1 11 -1 -1 -1 -1 -1 -1 -1 255 255) ;58 - ( 60 58 63 -1 -1 -1 255 -1 -1 -1 255 255) ;59 - ( 61 59 64 -1 -1 -1 -1 -1 -1 -1 255 255) ;60 - ( 62 60 65 -1 -1 -1 -1 -1 -1 -1 255 255) ;61 - ( -1 61 66 -1 -1 -1 -1 -1 -1 -1 255 255) ;62 - ( 64 -1 67 59 -1 -1 -1 -1 -1 -1 255 255) ;63 - ( 65 63 68 60 -1 -1 -1 -1 -1 -1 255 255) ;64 - ( 66 64 69 61 -1 -1 -1 -1 -1 -1 255 255) ;65 - ( -1 65 70 62 -1 -1 -1 -1 -1 -1 255 255) ;66 - ( 68 -1 71 63 -1 -1 -1 -1 -1 -1 255 255) ;67 - ( 69 67 72 64 -1 -1 -1 -1 -1 -1 255 255) ;68 - ( 70 68 73 65 -1 -1 -1 -1 -1 -1 255 255) ;69 - ( -1 69 74 66 -1 -1 -1 -1 -1 -1 255 255) ;70 - ( 72 -1 75 67 -1 -1 -1 -1 -1 -1 255 255) ;71 - ( 73 71 76 68 -1 -1 -1 -1 -1 -1 255 255) ;72 - ( 74 72 77 69 -1 -1 -1 -1 -1 -1 255 255) ;73 - ( -1 73 78 70 -1 -1 -1 -1 -1 -1 255 255) ;74 - ( 76 -1 79 71 -1 -1 -1 -1 -1 -1 255 255) ;75 - ( 77 75 80 72 -1 -1 -1 -1 -1 -1 255 255) ;76 - ( 78 76 81 73 -1 -1 -1 -1 -1 -1 255 255) ;77 - ( -1 77 82 74 -1 -1 -1 -1 -1 -1 255 255) ;78 - ( 80 -1 -1 75 -1 -1 -1 -1 -1 -1 255 255) ;79 - ( 81 79 255 76 -1 -1 -1 -1 -1 -1 255 255) ;80 - ( 82 80 -1 77 -1 -1 -1 -1 -1 -1 255 255) ;81 - ( -1 81 -1 78 -1 -1 -1 -1 -1 -1 255 255) ;82 - ( 84 -1 -1 -1 -1 59 -1 -1 -1 -1 255 255) ;83 - ( -1 83 85 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;84 - ( 86 -1 87 84 -1 -1 -1 -1 -1 -1 -1 -1 ) ;85 - ( -1 85 88 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;86 - ( 88 -1 -1 85 -1 -1 -1 -1 -1 -1 -1 -1 ) ;87 - ( -1 87 255 86 -1 -1 -1 -1 -1 -1 -1 -1 ) ;88 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;89 - ( 91 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;90 - ( 92 90 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;91 - ( -1 91 -1 -1 -1 -1 -1 -1 93 94 -1 -1 ) ;92 - ( -1 -1 -1 88 -1 -1 -1 -1 -1 92 -1 -1 ) ;93 - ( -1 -1 -1 -1 95 -1 -1 -1 92 -1 -1 -1 ) ;94 - ( -1 -1 -1 -1 -1 -1 -1 94 -1 -1 -1 -1 ) ;95 - ( 97 0 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;96 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;97 - ( 99 97 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;98 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;99 - ( 101 99 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;100 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;101 - ( 103 101 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;102 - ( -1 102 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;103 - ( 51 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;104 - ) -; no so ea we ne se nw sw up do in ot -) - - -;;; How the user references *all* objects, permanent and regular. -(setq dun-objnames '( - (shovel . 0) - (lamp . 1) - (cpu . 2) (board . 2) (card . 2) - (food . 3) - (key . 4) - (paper . 5) - (rms . 6) (statue . 6) (statuette . 6) (stallman . 6) - (diamond . 7) - (weight . 8) - (life . 9) (preserver . 9) - (bracelet . 10) (emerald . 10) - (gold . 11) - (platinum . 12) - (towel . 13) (beach . 13) - (axe . 14) - (silver . 15) - (license . 16) - (coins . 17) - (egg . 18) - (jar . 19) - (bone . 20) - (acid . 21) (nitric . 21) - (glycerine . 22) - (ruby . 23) - (amethyst . 24) - (mona . 25) - (bill . 26) - (floppy . 27) (disk . 27) - - (boulder . -1) - (tree . -2) (trees . -2) (palm . -2) - (bear . -3) - (bin . -4) (bins . -4) - (cabinet . -5) (computer . -5) (vax . -5) (ibm . -5) - (protoplasm . -6) - (dial . -7) - (button . -8) - (chute . -9) - (painting . -10) - (bed . -11) - (urinal . -12) - (URINE . -13) - (pipes . -14) (pipe . -14) - (box . -15) (slit . -15) - (cable . -16) (ethernet . -16) - (mail . -17) (drop . -17) - (bus . -18) - (gate . -19) - (cliff . -20) - (skeleton . -21) (dinosaur . -21) - (fish . -22) - (tanks . -23) - (switch . -24) - (blackboard . -25) - (disposal . -26) (garbage . -26) - (ladder . -27) - (subway . -28) (train . -28) - (pc . -29) (drive . -29) -)) - -(dolist (x dun-objnames) - (let (name) - (setq name (concat "obj-" (prin1-to-string (car x)))) - (eval (list 'defconst (intern name) (cdr x))))) - -(defconst obj-special 255) - -;;; The initial setup of what objects are in each room. -;;; Regular objects have whole numbers lower than 255. -;;; Objects that cannot be taken but might move and are -;;; described during room description are negative. -;;; Stuff that is described and might change are 255, and are -;;; handled specially by 'dun-describe-room. - -(setq dun-room-objects (list nil - - (list obj-shovel) ;; treasure-room - (list obj-boulder) ;; dead-end - nil nil nil - (list obj-food) ;; se-nw-road - (list obj-bear) ;; bear-hangout - nil nil - (list obj-special) ;; computer-room - (list obj-lamp obj-license obj-silver);; meadow - nil nil - (list obj-special) ;; sauna - nil - (list obj-weight obj-life) ;; weight-room - nil nil - (list obj-rms obj-floppy) ;; thirsty-maze - nil nil nil nil nil nil nil - (list obj-emerald) ;; hidden-area - nil - (list obj-gold) ;; misty-room - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - (list obj-towel obj-special) ;; red-room - nil nil nil nil nil - (list obj-box) ;; stair-landing - nil nil nil - (list obj-axe) ;; smal-crawlspace - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil - (list obj-special) ;; fourth-vermont-intersection - nil nil - (list obj-coins) ;; fifth-oaktree-intersection - nil - (list obj-bus) ;; fifth-sycamore-intersection - nil - (list obj-bone) ;; museum-lobby - nil - (list obj-jar obj-special obj-ruby) ;; marine-life-area - (list obj-nitric) ;; maintenance-room - (list obj-glycerine) ;; classroom - nil nil nil nil nil - (list obj-amethyst) ;; bottom-of-subway-stairs - nil nil - (list obj-special) ;; question-room-1 - nil - (list obj-special) ;; question-room-2 - nil - (list obj-special) ;; question-room-three - nil - (list obj-mona) ;; winner's-room -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil)) - -;;; These are objects in a room that are only described in the -;;; room description. They are permanent. - -(setq dun-room-silents (list nil - (list obj-tree) ;; dead-end - (list obj-tree) ;; e-w-dirt-road - nil nil nil nil nil nil - (list obj-bin) ;; mailroom - (list obj-computer) ;; computer-room - nil nil nil - (list obj-dial) ;; sauna - nil - (list obj-ladder) ;; weight-room - (list obj-button obj-ladder) ;; maze-button-room - nil nil nil - nil nil nil nil nil nil nil - (list obj-chute) ;; cave-entrance - nil nil nil nil nil - (list obj-painting obj-bed) ;; bedroom - (list obj-urinal obj-pipes) ;; bathroom - nil nil nil nil nil nil - (list obj-boulder) ;; horseshoe-boulder-room - nil nil nil nil nil nil nil nil nil nil nil nil nil nil - (list obj-computer obj-cable) ;; gamma-computing-center - (list obj-mail) ;; post-office - (list obj-gate) ;; main-maple-intersection - nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil - (list obj-cliff) ;; fifth-oaktree-intersection - nil nil nil - (list obj-dinosaur) ;; museum-lobby - nil - (list obj-fish obj-tanks) ;; marine-life-area - (list obj-switch) ;; maintenance-room - (list obj-blackboard) ;; classroom - (list obj-train) ;; vermont-station - nil nil - (list obj-disposal) ;; north-end-of-n-s-tunnel - nil nil - (list obj-computer) ;; endgame-computer-room - nil nil nil nil nil nil nil nil - (list obj-pc) ;; pc-area - nil nil nil nil nil nil -)) -(setq dun-inventory '(1)) - -;;; Descriptions of objects, as they appear in the room description, and -;;; the inventory. - -(setq dun-objects '( - ("There is a shovel here." "A shovel") ;0 - ("There is a lamp nearby." "A lamp") ;1 - ("There is a CPU card here." "A computer board") ;2 - ("There is some food here." "Some food") ;3 - ("There is a shiny brass key here." "A brass key") ;4 - ("There is a slip of paper here." "A slip of paper") ;5 - ("There is a wax statuette of Richard Stallman here." ;6 - "An RMS statuette") - ("There is a shimmering diamond here." "A diamond") ;7 - ("There is a 10 pound weight here." "A weight") ;8 - ("There is a life preserver here." "A life preserver");9 - ("There is an emerald bracelet here." "A bracelet") ;10 - ("There is a gold bar here." "A gold bar") ;11 - ("There is a platinum bar here." "A platinum bar") ;12 - ("There is a beach towel on the ground here." "A beach towel") - ("There is an axe here." "An axe") ;14 - ("There is a silver bar here." "A silver bar") ;15 - ("There is a bus driver's license here." "A license") ;16 - ("There are some valuable coins here." "Some valuable coins") - ("There is a jewel-encrusted egg here." "A valuable egg") ;18 - ("There is a glass jar here." "A glass jar") ;19 - ("There is a dinosaur bone here." "A bone") ;20 - ("There is a packet of nitric acid here." "Some nitric acid") - ("There is a packet of glycerine here." "Some glycerine") ;22 - ("There is a valuable ruby here." "A ruby") ;23 - ("There is a valuable amethyst here." "An amethyst") ;24 - ("The Mona Lisa is here." "The Mona Lisa") ;25 - ("There is a 100 dollar bill here." "A $100 bill") ;26 - ("There is a floppy disk here." "A floppy disk") ;27 - ) -) - -;;; Weight of objects - -(setq dun-object-lbs - '(2 1 1 1 1 0 2 2 10 3 1 1 1 0 1 1 0 1 1 1 1 0 0 2 2 1 0 0)) -(setq dun-object-pts - '(0 0 0 0 0 0 0 10 0 0 10 10 10 0 0 10 0 10 10 0 0 0 0 10 10 10 10 0)) - - -;;; Unix representation of objects. -(setq dun-objfiles '( - "shovel.o" "lamp.o" "cpu.o" "food.o" "key.o" "paper.o" - "rms.o" "diamond.o" "weight.o" "preserver.o" "bracelet.o" - "gold.o" "platinum.o" "towel.o" "axe.o" "silver.o" "license.o" - "coins.o" "egg.o" "jar.o" "bone.o" "nitric.o" "glycerine.o" - "ruby.o" "amethyst.o" - )) - -;;; These are the descriptions for the negative numbered objects from -;;; dun-room-objects - -(setq dun-perm-objects '( - nil - ("There is a large boulder here.") - nil - ("There is a ferocious bear here!") - nil - nil - ("There is a worthless pile of protoplasm here.") - nil - nil - nil - nil - nil - nil - ("There is a strange smell in this room.") - nil - ( -"There is a box with a slit in it, bolted to the wall here." - ) - nil - nil - ("There is a bus here.") - nil - nil - nil -)) - - -;;; These are the descriptions the user gets when regular objects are -;;; examined. - -(setq dun-physobj-desc '( -"It is a normal shovel with a price tag attached that says $19.99." -"The lamp is hand-crafted by Geppetto." -"The CPU board has a VAX chip on it. It seems to have -2 Megabytes of RAM onboard." -"It looks like some kind of meat. Smells pretty bad." -nil -"The paper says: Don't forget to type 'help' for help. Also, remember -this word: 'worms'" -"The statuette is of the likeness of Richard Stallman, the author of the -famous EMACS editor. You notice that he is not wearing any shoes." -nil -"You observe that the weight is heavy." -"It says S. S. Minnow." -nil -nil -nil -"It has a picture of snoopy on it." -nil -nil -"It has your picture on it!" -"They are old coins from the 19th century." -"It is a valuable Fabrege egg." -"It is a a plain glass jar." -nil -nil -nil -nil -nil - ) -) - -;;; These are the descriptions the user gets when non-regular objects -;;; are examined. - -(setq dun-permobj-desc '( - nil -"It is just a boulder. It cannot be moved." -"They are palm trees with a bountiful supply of coconuts in them." -"It looks like a grizzly to me." -"All of the bins are empty. Looking closely you can see that there -are names written at the bottom of each bin, but most of them are -faded away so that you cannot read them. You can only make out three -names: - Jeffrey Collier - Robert Toukmond - Thomas Stock -" - nil -"It is just a garbled mess." -"The dial points to a temperature scale which has long since faded away." -nil -nil -"It is a velvet painting of Elvis Presly. It seems to be nailed to the -wall, and you cannot move it." -"It is a queen sized bed, with a very firm mattress." -"The urinal is very clean compared with everything else in the cave. There -isn't even any rust. Upon close examination you realize that the drain at the -bottom is missing, and there is just a large hole leading down the -pipes into nowhere. The hole is too small for a person to fit in. The -flush handle is so clean that you can see your reflection in it." -nil -nil -"The box has a slit in the top of it, and on it, in sloppy handwriting, is -written: 'For key upgrade, put key in here.'" -nil -"It says 'express mail' on it." -"It is a 35 passenger bus with the company name 'mobytours' on it." -"It is a large metal gate that is too big to climb over." -"It is a HIGH cliff." -"Unfortunately you do not know enough about dinosaurs to tell very much about -it. It is very big, though." -"The fish look like they were once quite beautiful." -nil -nil -nil -nil -"It is a normal ladder that is permanently attached to the hole." -"It is a passenger train that is ready to go." -"It is a personal computer that has only one floppy disk drive." - ) -) - -(setq dun-diggables - (list nil nil nil (list obj-cpu) nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil ;11-20 - nil nil nil nil nil nil nil nil nil nil ;21-30 - nil nil nil nil nil nil nil nil nil nil ;31-40 - nil (list obj-platinum) nil nil nil nil nil nil nil nil)) - -(setq dun-room-shorts nil) -(dolist (x dun-rooms) - (setq dun-room-shorts - (append dun-room-shorts (list (downcase - (dun-space-to-hyphen - (cadr x))))))) - -(setq dun-endgame-questions '( - ( -"What is your password on the machine called 'pokey'?" "robert") - ( -"What password did you use during anonymous ftp to gamma?" "foo") - ( -"Excluding the endgame, how many places are there where you can put -treasures for points?" "4" "four") - ( -"What is your login name on the 'endgame' machine?" "toukmond" -) - ( -"What is the nearest whole dollar to the price of the shovel?" "20" "twenty") - ( -"What is the name of the bus company serving the town?" "mobytours") - ( -"Give either of the two last names in the mailroom, other than your own." -"collier" "stock") - ( -"What cartoon character is on the towel?" "snoopy") - ( -"What is the last name of the author of EMACS?" "stallman") - ( -"How many megabytes of memory is on the CPU board for the Vax?" "2") - ( -"Which street in town is named after a U.S. state?" "vermont") - ( -"How many pounds did the weight weigh?" "ten" "10") - ( -"Name the STREET which runs right over the subway stop." "fourth" "4" "4th") - ( -"How many corners are there in town (excluding the one with the Post Office)?" - "24" "twentyfour" "twenty-four") - ( -"What type of bear was hiding your key?" "grizzly") - ( -"Name either of the two objects you found by digging." "cpu" "card" "vax" -"board" "platinum") - ( -"What network protocol is used between pokey and gamma?" "tcp/ip" "ip" "tcp") -)) - -(let (a) - (setq a 0) - (dolist (x dun-room-shorts) - (eval (list 'defconst (intern x) a)) - (setq a (+ a 1)))) - - - -;;;; -;;;; This section defines the UNIX emulation functions for dunnet. -;;;; - -(defun dun-unix-parse (args) - (interactive "*p") - (beginning-of-line) - (let (beg esign) - (setq beg (+ (point) 2)) - (end-of-line) - (if (and (not (= beg (point))) - (string= "$" (buffer-substring (- beg 2) (- beg 1)))) - (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) - (progn - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) - (dun-mprincl ": not found."))))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (if (eq dungeon-mode 'unix) - (progn - (dun-fix-screen) - (dun-mprinc "$ "))))) - -(defun dun-doassign (line esign) - (if (not dun-wizard) - (let (passwd) - (dun-mprinc "Enter wizard password: ") - (setq passwd (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (string= passwd "moby") - (progn - (setq dun-wizard t) - (dun-doassign line esign)) - (dun-mprincl "Incorrect."))) - - (let (varname epoint afterq i value) - (setq varname (substring line 0 esign)) - (if (not (setq epoint (string-match ")" line))) - (if (string= (substring line (1+ esign) (+ esign 2)) - "\"") - (progn - (setq afterq (substring line (+ esign 2))) - (setq epoint (+ - (string-match "\"" afterq) - (+ esign 3)))) - - (if (not (setq epoint (string-match " " line))) - (setq epoint (length line)))) - (setq epoint (1+ epoint)) - (while (and - (not (= epoint (length line))) - (setq i (string-match ")" (substring line epoint)))) - (setq epoint (+ epoint i 1)))) - (setq value (substring line (1+ esign) epoint)) - (dun-eval varname value)))) - -(defun dun-eval (varname value) - (let (eval-error) - (switch-to-buffer (get-buffer-create "*dungeon-eval*")) - (erase-buffer) - (insert "(setq ") - (insert varname) - (insert " ") - (insert value) - (insert ")") - (setq eval-error nil) - (condition-case nil - (eval-current-buffer) - (error (setq eval-error t))) - (kill-buffer (current-buffer)) - (switch-to-buffer "*dungeon*") - (if eval-error - (dun-mprincl "Invalid syntax.")))) - - -(defun dun-unix-interface () - (dun-login) - (if dun-logged-in - (progn - (setq dungeon-mode 'unix) - (define-key dungeon-mode-map "\r" 'dun-unix-parse) - (dun-mprinc "$ ")))) - -(defun dun-login () - (let (tries username password) - (setq tries 4) - (while (and (not dun-logged-in) (> (setq tries (- tries 1)) 0)) - (dun-mprinc "\n\nUNIX System V, Release 2.2 (pokey)\n\nlogin: ") - (setq username (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (dun-mprinc "password: ") - (setq password (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (or (not (string= username "toukmond")) - (not (string= password "robert"))) - (dun-mprincl "login incorrect") - (setq dun-logged-in t) - (dun-mprincl " -Welcome to Unix\n -Please clean up your directories. The filesystem is getting full. -Our tcp/ip link to gamma is a little flaky, but seems to work. -The current version of ftp can only send files from the current -directory, and deletes them after they are sent! Be careful. - -Note: Restricted bourne shell in use.\n"))) - (setq dungeon-mode 'dungeon))) - -(defun dun-ls (args) - (if (car args) - (let (ocdpath ocdroom) - (setq ocdpath dun-cdpath) - (setq ocdroom dun-cdroom) - (if (not (eq (dun-cd args) -2)) - (dun-ls nil)) - (setq dun-cdpath ocdpath) - (setq dun-cdroom ocdroom)) - (if (= dun-cdroom -10) - (dun-ls-inven)) - (if (= dun-cdroom -2) - (dun-ls-rooms)) - (if (= dun-cdroom -3) - (dun-ls-root)) - (if (= dun-cdroom -4) - (dun-ls-usr)) - (if (> dun-cdroom 0) - (dun-ls-room)))) - -(defun dun-ls-root () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. -drwxr-xr-x 3 root staff 2048 Jan 1 1970 usr -drwxr-xr-x 3 root staff 2048 Jan 1 1970 rooms")) - -(defun dun-ls-usr () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. -drwxr-xr-x 3 toukmond restricted 512 Jan 1 1970 toukmond")) - -(defun dun-ls-rooms () - (dun-mprincl "total 16 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 ..") - (dolist (x dun-visited) - (dun-mprinc -"drwxr-xr-x 3 root staff 512 Jan 1 1970 ") - (dun-mprincl (nth x dun-room-shorts)))) - -(defun dun-ls-room () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. --rwxr-xr-x 3 root staff 2048 Jan 1 1970 description") - (dolist (x (nth dun-cdroom dun-room-objects)) - (if (and (>= x 0) (not (= x 255))) - (progn - (dun-mprinc "-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 ") - (dun-mprincl (nth x dun-objfiles)))))) - -(defun dun-ls-inven () - (dun-mprinc "total 467 -drwxr-xr-x 3 toukmond restricted 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 ..") - (dolist (x dun-unix-verbs) - (if (not (eq (car x) 'IMPOSSIBLE)) - (progn - (dun-mprinc" --rwxr-xr-x 1 toukmond restricted 10423 Jan 1 1970 ") - (dun-mprinc (car x))))) - (dun-mprinc "\n") - (if (not dun-uncompressed) - (dun-mprincl -"-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 paper.o.Z")) - (dolist (x dun-inventory) - (dun-mprinc -"-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 ") - (dun-mprincl (nth x dun-objfiles)))) - -(defun dun-echo (args) - (let (nomore var) - (setq nomore nil) - (dolist (x args) - (if (not nomore) - (progn - (if (not (string= (substring x 0 1) "$")) - (progn - (dun-mprinc x) - (dun-mprinc " ")) - (setq var (intern (substring x 1))) - (if (not (boundp var)) - (dun-mprinc " ") - (if (member var dun-restricted) - (progn - (dun-mprinc var) - (dun-mprinc ": Permission denied") - (setq nomore t)) - (eval (list 'dun-mprinc var)) - (dun-mprinc " "))))))) - (dun-mprinc "\n"))) - - -(defun dun-ftp (args) - (let (host username passwd ident newlist) - (if (not (car args)) - (dun-mprincl "ftp: hostname required on command line.") - (setq host (intern (car args))) - (if (not (member host '(gamma dun-endgame))) - (dun-mprincl "ftp: Unknown host.") - (if (eq host 'dun-endgame) - (dun-mprincl "ftp: connection to endgame not allowed") - (if (not dun-ethernet) - (dun-mprincl "ftp: host not responding.") - (dun-mprincl "Connected to gamma. FTP ver 0.9 00:00:00 01/01/70") - (dun-mprinc "Username: ") - (setq username (dun-read-line)) - (if (string= username "toukmond") - (if dun-batch-mode - (dun-mprincl "toukmond ftp access not allowed.") - (dun-mprincl "\ntoukmond ftp access not allowed.")) - (if (string= username "anonymous") - (if dun-batch-mode - (dun-mprincl - "Guest login okay, send your user ident as password.") - (dun-mprincl - "\nGuest login okay, send your user ident as password.")) - (if dun-batch-mode - (dun-mprinc "Password required for ") - (dun-mprinc "\nPassword required for ")) - (dun-mprincl username)) - (dun-mprinc "Password: ") - (setq ident (dun-read-line)) - (if (not (string= username "anonymous")) - (if dun-batch-mode - (dun-mprincl "Login failed.") - (dun-mprincl "\nLogin failed.")) - (if dun-batch-mode - (dun-mprincl - "Guest login okay, user access restrictions apply.") - (dun-mprincl - "\nGuest login okay, user access restrictions apply.")) - (dun-ftp-commands) - (setq newlist -'("What password did you use during anonymous ftp to gamma?")) - (setq newlist (append newlist (list ident))) - (rplaca (nthcdr 1 dun-endgame-questions) newlist))))))))) - -(defun dun-ftp-commands () - (setq dun-exitf nil) - (let (line) - (while (not dun-exitf) - (dun-mprinc "ftp> ") - (setq line (dun-read-line)) - (if - (eq - (dun-parse2 nil - '((type . dun-ftptype) (binary . dun-bin) (bin . dun-bin) - (send . dun-send) (put . dun-send) (quit . dun-ftpquit) - (help . dun-ftphelp)(ascii . dun-fascii) - ) line) - -1) - (dun-mprincl "No such command. Try help."))) - (setq dun-ftptype 'ascii))) - -(defun dun-ftptype (args) - (if (not (car args)) - (dun-mprincl "Usage: type [binary | ascii]") - (setq args (intern (car args))) - (if (eq args 'binary) - (dun-bin nil) - (if (eq args 'ascii) - (dun-fascii 'nil) - (dun-mprincl "Unknown type."))))) - -(defun dun-bin (args) - (dun-mprincl "Type set to binary.") - (setq dun-ftptype 'binary)) - -(defun dun-fascii (args) - (dun-mprincl "Type set to ascii.") - (setq dun-ftptype 'ascii)) - -(defun dun-ftpquit (args) - (setq dun-exitf t)) - -(defun dun-send (args) - (if (not (car args)) - (dun-mprincl "Usage: send ") - (setq args (car args)) - (let (counter foo) - (setq foo nil) - (setq counter 0) - -;;; User can send commands! Stupid user. - - - (if (assq (intern args) dun-unix-verbs) - (progn - (rplaca (assq (intern args) dun-unix-verbs) 'IMPOSSIBLE) - (dun-mprinc "Sending ") - (dun-mprinc dun-ftptype) - (dun-mprinc " file for ") - (dun-mprincl args) - (dun-mprincl "Transfer complete.")) - - (dolist (x dun-objfiles) - (if (string= args x) - (progn - (if (not (member counter dun-inventory)) - (progn - (dun-mprincl "No such file.") - (setq foo t)) - (dun-mprinc "Sending ") - (dun-mprinc dun-ftptype) - (dun-mprinc " file for ") - (dun-mprinc (downcase (cadr (nth counter dun-objects)))) - (dun-mprincl ", (0 bytes)") - (if (not (eq dun-ftptype 'binary)) - (progn - (if (not (member obj-protoplasm - (nth receiving-room - dun-room-objects))) - (dun-replace dun-room-objects receiving-room - (append (nth receiving-room - dun-room-objects) - (list obj-protoplasm)))) - (dun-remove-obj-from-inven counter)) - (dun-remove-obj-from-inven counter) - (dun-replace dun-room-objects receiving-room - (append (nth receiving-room dun-room-objects) - (list counter)))) - (setq foo t) - (dun-mprincl "Transfer complete.")))) - (setq counter (+ 1 counter))) - (if (not foo) - (dun-mprincl "No such file.")))))) - -(defun dun-ftphelp (args) - (dun-mprincl - "Possible commands are:\nsend quit type ascii binary help")) - -(defun dun-uexit (args) - (setq dungeon-mode 'dungeon) - (dun-mprincl "\nYou step back from the console.") - (define-key dungeon-mode-map "\r" 'dun-parse) - (if (not dun-batch-mode) - (dun-messages))) - -(defun dun-pwd (args) - (dun-mprincl dun-cdpath)) - -(defun dun-uncompress (args) - (if (not (car args)) - (dun-mprincl "Usage: uncompress ") - (setq args (car args)) - (if (or dun-uncompressed - (and (not (string= args "paper.o")) - (not (string= args "paper.o.z")))) - (dun-mprincl "Uncompress command failed.") - (setq dun-uncompressed t) - (setq dun-inventory (append dun-inventory (list obj-paper)))))) - -(defun dun-rlogin (args) - (let (passwd) - (if (not (car args)) - (dun-mprincl "Usage: rlogin ") - (setq args (car args)) - (if (string= args "endgame") - (dun-rlogin-endgame) - (if (not (string= args "gamma")) - (dun-mprincl "No such host.") - (if (not dun-ethernet) - (dun-mprincl "Host not responding.") - (dun-mprinc "Password: ") - (setq passwd (dun-read-line)) - (if (not (string= passwd "worms")) - (dun-mprincl "\nlogin incorrect") - (dun-mprinc -"\nYou begin to feel strange for a moment, and you lose your items." -) - (dun-replace dun-room-objects computer-room - (append (nth computer-room dun-room-objects) - dun-inventory)) - (setq dun-inventory nil) - (setq dun-current-room receiving-room) - (dun-uexit nil)))))))) - -(defun dun-cd (args) - (let (tcdpath tcdroom path-elements room-check) - (if (not (car args)) - (dun-mprincl "Usage: cd ") - (setq tcdpath dun-cdpath) - (setq tcdroom dun-cdroom) - (setq dun-badcd nil) - (condition-case nil - (setq path-elements (dun-get-path (car args) nil)) - (error (dun-mprincl "Invalid path.") - (setq dun-badcd t))) - (dolist (pe path-elements) - (unless dun-badcd - (if (not (string= pe ".")) - (if (string= pe "..") - (progn - (if (> tcdroom 0) ;In a room - (progn - (setq tcdpath "/rooms") - (setq tcdroom -2)) - ;In /rooms,/usr,root - (if (or - (= tcdroom -2) (= tcdroom -4) - (= tcdroom -3)) - (progn - (setq tcdpath "/") - (setq tcdroom -3)) - (if (= tcdroom -10) ;In /usr/toukmond - (progn - (setq tcdpath "/usr") - (setq tcdroom -4)))))) - (if (string= pe "/") - (progn - (setq tcdpath "/") - (setq tcdroom -3)) - (if (= tcdroom -4) - (if (string= pe "toukmond") - (progn - (setq tcdpath "/usr/toukmond") - (setq tcdroom -10)) - (dun-nosuchdir)) - (if (= tcdroom -10) - (dun-nosuchdir) - (if (> tcdroom 0) - (dun-nosuchdir) - (if (= tcdroom -3) - (progn - (if (string= pe "rooms") - (progn - (setq tcdpath "/rooms") - (setq tcdroom -2)) - (if (string= pe "usr") - (progn - (setq tcdpath "/usr") - (setq tcdroom -4)) - (dun-nosuchdir)))) - (if (= tcdroom -2) - (progn - (dolist (x dun-visited) - (setq room-check - (nth x - dun-room-shorts)) - (if (string= room-check pe) - (progn - (setq tcdpath - (concat "/rooms/" room-check)) - (setq tcdroom x)))) - (if (= tcdroom -2) - (dun-nosuchdir))))))))))))) - (if (not dun-badcd) - (progn - (setq dun-cdpath tcdpath) - (setq dun-cdroom tcdroom) - 0) - -2)))) - -(defun dun-nosuchdir () - (dun-mprincl "No such directory.") - (setq dun-badcd t)) - -(defun dun-cat (args) - (let (doto checklist) - (if (not (setq args (car args))) - (dun-mprincl "Usage: cat ") - (if (string-match "/" args) - (dun-mprincl "cat: only files in current directory allowed.") - (if (and (> dun-cdroom 0) (string= args "description")) - (dun-mprincl (car (nth dun-cdroom dun-rooms))) - (if (setq doto (string-match "\\.o" args)) - (progn - (if (= dun-cdroom -10) - (setq checklist dun-inventory) - (setq checklist (nth dun-cdroom dun-room-objects))) - (if (not (member (cdr - (assq (intern - (substring args 0 doto)) - dun-objnames)) - checklist)) - (dun-mprincl "File not found.") - (dun-mprincl "Ascii files only."))) - (if (assq (intern args) dun-unix-verbs) - (dun-mprincl "Ascii files only.") - (dun-mprincl "File not found.")))))))) - -(defun dun-zippy (args) - (dun-mprincl (yow))) - -(defun dun-rlogin-endgame () - (if (not (= (dun-score nil) 90)) - (dun-mprincl - "You have not achieved enough points to connect to endgame.") - (dun-mprincl"\nWelcome to the endgame. You are a truly noble adventurer.") - (setq dun-current-room treasure-room) - (setq dun-endgame t) - (dun-replace dun-room-objects endgame-treasure-room (list obj-bill)) - (dun-uexit nil))) - - -(random t) -(setq tloc (+ 60 (random 18))) -(dun-replace dun-room-objects tloc - (append (nth tloc dun-room-objects) (list 18))) - -(setq tcomb (+ 100 (random 899))) -(setq dun-combination (prin1-to-string tcomb)) - -;;;; -;;;; This section defines the DOS emulation functions for dunnet -;;;; - -(defun dun-dos-parse (args) - (interactive "*p") - (beginning-of-line) - (let (beg) - (setq beg (+ (point) 3)) - (end-of-line) - (if (not (= beg (point))) - (let (line) - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-parse2 nil dun-dos-verbs line) -1) - (progn - (sleep-for 1) - (dun-mprincl "Bad command or file name")))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (if (eq dungeon-mode 'dos) - (progn - (dun-fix-screen) - (dun-dos-prompt))))) - -(defun dun-dos-interface () - (dun-dos-boot-msg) - (setq dungeon-mode 'dos) - (define-key dungeon-mode-map "\r" 'dun-dos-parse) - (dun-dos-prompt)) - -(defun dun-dos-type (args) - (sleep-for 2) - (if (setq args (car args)) - (if (string= args "foo.txt") - (dun-dos-show-combination) - (if (string= args "command.com") - (dun-mprincl "Cannot type binary files") - (dun-mprinc "File not found - ") - (dun-mprincl (upcase args)))) - (dun-mprincl "Must supply file name"))) - -(defun dun-dos-invd (args) - (sleep-for 1) - (dun-mprincl "Invalid drive specification")) - -(defun dun-dos-dir (args) - (sleep-for 1) - (if (or (not (setq args (car args))) (string= args "\\")) - (dun-mprincl " - Volume in drive A is FOO - Volume Serial Number is 1A16-08C9 - Directory of A:\\ - -COMMAND COM 47845 04-09-91 2:00a -FOO TXT 40 01-20-93 1:01a - 2 file(s) 47845 bytes - 1065280 bytes free -") - (dun-mprincl " - Volume in drive A is FOO - Volume Serial Number is 1A16-08C9 - Directory of A:\\ - -File not found"))) - - -(defun dun-dos-prompt () - (dun-mprinc "A> ")) - -(defun dun-dos-boot-msg () - (sleep-for 3) - (dun-mprinc "Current time is ") - (dun-mprincl (substring (current-time-string) 12 20)) - (dun-mprinc "Enter new time: ") - (dun-read-line) - (if (not dun-batch-mode) - (dun-mprinc "\n"))) - -(defun dun-dos-spawn (args) - (sleep-for 1) - (dun-mprincl "Cannot spawn subshell")) - -(defun dun-dos-exit (args) - (setq dungeon-mode 'dungeon) - (dun-mprincl "\nYou power down the machine and step back.") - (define-key dungeon-mode-map "\r" 'dun-parse) - (if (not dun-batch-mode) - (dun-messages))) - -(defun dun-dos-no-disk () - (sleep-for 3) - (dun-mprincl "Boot sector not found")) - - -(defun dun-dos-show-combination () - (sleep-for 2) - (dun-mprinc "\nThe combination is ") - (dun-mprinc dun-combination) - (dun-mprinc ".\n")) - -(defun dun-dos-nil (args)) - - -;;;; -;;;; This section defines the save and restore game functions for dunnet. -;;;; - -(defun dun-save-game (filename) - (if (not (setq filename (car filename))) - (dun-mprincl "You must supply a filename for the save.") - (if (file-exists-p filename) - (delete-file filename)) - (setq dun-numsaves (1+ dun-numsaves)) - (dun-make-save-buffer) - (dun-save-val "dun-current-room") - (dun-save-val "dun-computer") - (dun-save-val "dun-combination") - (dun-save-val "dun-visited") - (dun-save-val "dun-diggables") - (dun-save-val "dun-key-level") - (dun-save-val "dun-floppy") - (dun-save-val "dun-numsaves") - (dun-save-val "dun-numcmds") - (dun-save-val "dun-logged-in") - (dun-save-val "dungeon-mode") - (dun-save-val "dun-jar") - (dun-save-val "dun-lastdir") - (dun-save-val "dun-black") - (dun-save-val "dun-nomail") - (dun-save-val "dun-unix-verbs") - (dun-save-val "dun-hole") - (dun-save-val "dun-uncompressed") - (dun-save-val "dun-ethernet") - (dun-save-val "dun-sauna-level") - (dun-save-val "dun-room-objects") - (dun-save-val "dun-room-silents") - (dun-save-val "dun-inventory") - (dun-save-val "dun-endgame-questions") - (dun-save-val "dun-endgame") - (dun-save-val "dun-cdroom") - (dun-save-val "dun-cdpath") - (dun-save-val "dun-correct-answer") - (dun-save-val "dun-inbus") - (if (dun-compile-save-out filename) - (dun-mprincl "Error saving to file.") - (dun-do-logfile 'save nil) - (switch-to-buffer "*dungeon*") - (princ "") - (dun-mprincl "Done.")))) - -(defun dun-make-save-buffer () - (switch-to-buffer (get-buffer-create "*save-dungeon*")) - (erase-buffer)) - -(defun dun-compile-save-out (filename) - (let (ferror) - (setq ferror nil) - (condition-case nil - (dun-rot13) - (error (setq ferror t))) - (if (not ferror) - (progn - (goto-char (point-min)))) - (condition-case nil - (write-region 1 (point-max) filename nil 1) - (error (setq ferror t))) - (kill-buffer (current-buffer)) - ferror)) - - -(defun dun-save-val (varname) - (let (value) - (setq varname (intern varname)) - (setq value (eval varname)) - (dun-minsert "(setq ") - (dun-minsert varname) - (dun-minsert " ") - (if (or (listp value) - (symbolp value)) - (dun-minsert "'")) - (if (stringp value) - (dun-minsert "\"")) - (dun-minsert value) - (if (stringp value) - (dun-minsert "\"")) - (dun-minsertl ")"))) - - -(defun dun-restore (args) - (let (file) - (if (not (setq file (car args))) - (dun-mprincl "You must supply a filename.") - (if (not (dun-load-d file)) - (dun-mprincl "Could not load restore file.") - (dun-mprincl "Done.") - (setq room 0))))) - - -(defun dun-do-logfile (type how) - (let (ferror newscore) - (setq ferror nil) - (switch-to-buffer (get-buffer-create "*score*")) - (erase-buffer) - (condition-case nil - (insert-file-contents dun-log-file) - (error (setq ferror t))) - (unless ferror - (goto-char (point-max)) - (dun-minsert (current-time-string)) - (dun-minsert " ") - (dun-minsert (user-login-name)) - (dun-minsert " ") - (if (eq type 'save) - (dun-minsert "saved ") - (if (= (dun-endgame-score) 110) - (dun-minsert "won ") - (if (not how) - (dun-minsert "quit ") - (dun-minsert "killed by ") - (dun-minsert how) - (dun-minsert " ")))) - (dun-minsert "at ") - (dun-minsert (cadr (nth (abs room) dun-rooms))) - (dun-minsert ". score: ") - (if (> (dun-endgame-score) 0) - (dun-minsert (setq newscore (+ 90 (dun-endgame-score)))) - (dun-minsert (setq newscore (dun-reg-score)))) - (dun-minsert " saves: ") - (dun-minsert dun-numsaves) - (dun-minsert " commands: ") - (dun-minsert dun-numcmds) - (dun-minsert "\n") - (write-region 1 (point-max) dun-log-file nil 1)) - (kill-buffer (current-buffer)))) - - -;;;; -;;;; These are functions, and function re-definitions so that dungeon can -;;;; be run in batch mode. - - -(defun dun-batch-mprinc (arg) - (if (stringp arg) - (send-string-to-terminal arg) - (send-string-to-terminal (prin1-to-string arg)))) - - -(defun dun-batch-mprincl (arg) - (if (stringp arg) - (progn - (send-string-to-terminal arg) - (send-string-to-terminal "\n")) - (send-string-to-terminal (prin1-to-string arg)) - (send-string-to-terminal "\n"))) - -(defun dun-batch-parse (dun-ignore dun-verblist line) - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-batch-parse2 (dun-ignore dun-verblist line) - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-batch-read-line () - (read-from-minibuffer "" nil dungeon-batch-map)) - - -(defun dun-batch-loop () - (setq dun-dead nil) - (setq room 0) - (while (not dun-dead) - (if (eq dungeon-mode 'dungeon) - (progn - (if (not (= room dun-current-room)) - (progn - (dun-describe-room dun-current-room) - (setq room dun-current-room))) - (dun-mprinc ">") - (setq line (downcase (dun-read-line))) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) - (dun-mprinc "I don't understand that.\n")))))) - -(defun dun-batch-dos-interface () - (dun-dos-boot-msg) - (setq dungeon-mode 'dos) - (while (eq dungeon-mode 'dos) - (dun-dos-prompt) - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-dos-verbs line) -1) - (progn - (sleep-for 1) - (dun-mprincl "Bad command or file name")))) - (goto-char (point-max)) - (dun-mprinc "\n")) - -(defun dun-batch-unix-interface () - (dun-login) - (if dun-logged-in - (progn - (setq dungeon-mode 'unix) - (while (eq dungeon-mode 'unix) - (dun-mprinc "$ ") - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) - (let (esign) - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) - (dun-mprincl ": not found."))))) - (goto-char (point-max)) - (dun-mprinc "\n")))) - -(defun dungeon-nil (arg) - "noop" - (interactive "*p")) - -(defun dun-batch-dungeon () - (load "dun-batch") - (setq dun-visited '(27)) - (dun-mprinc "\n") - (dun-batch-loop)) - -(unless (not noninteractive) - (fset 'dun-mprinc 'dun-batch-mprinc) - (fset 'dun-mprincl 'dun-batch-mprincl) - (fset 'dun-vparse 'dun-batch-parse) - (fset 'dun-parse2 'dun-batch-parse2) - (fset 'dun-read-line 'dun-batch-read-line) - (fset 'dun-dos-interface 'dun-batch-dos-interface) - (fset 'dun-unix-interface 'dun-batch-unix-interface) - (dun-mprinc "\n") - (setq dun-batch-mode t) - (dun-batch-loop)) - -;;; dunnet.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/flame.el --- a/lisp/games/flame.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,342 +0,0 @@ -;;; flame.el --- Automated insults - -;; Copyright status Unknown - -;; Author: Unknown -;; Adapted-By: Ian G. Batten, Batten@uk.ac.bham.multics -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not in FSF - -;;; Commentary: - -;;; "Flame" program. This has a chequered past. -;;; -;;; The original was on a Motorola 286 running Vanilla V.1, -;;; about 2 years ago. It was couched in terms of a yacc (I think) -;;; script. I pulled the data out of it and rewrote it as a piece -;;; of PL/1 on Multics. Now I've moved it into an emacs-lisp -;;; form. If the original author cares to contact me, I'd -;;; be very happy to credit you! -;;; -;;; Ian G. Batten, Batten@uk.ac.bham.multics -;;; - -;;; Code: -(random t) - -(defvar sentence - '((how can you say that (statement) \?) - (I can\'t believe how (adjective) you are\.) - (only a (der-term) like you would say that (statement) \.) - ((statement) \, huh\?) (so\, (statement) \?) - ((statement) \, right\?) (I mean\, (sentence)) - (don\'t you realise that (statement) \?) - (I firmly believe that (statement) \.) - (let me tell you something\, you (der-term) \, (statement) \.) - (furthermore\, you (der-term) \, (statement) \.) - (I couldn\'t care less about your (thing) \.) - (How can you be so (adjective) \?) - (you make me sick\.) - (it\'s well known that (statement) \.) - ((statement) \.) - (it takes a (group-adj) (der-term) like you to say that (statement) \.) - (I don\'t want to hear about your (thing) \.) - (you\'re always totally wrong\.) - (I\'ve never heard anything as ridiculous as the idea that (statement) \.) - (you must be a real (der-term) to think that (statement) \.) - (you (adjective) (group-adj) (der-term) \!) - (you\'re probably (group-adj) yourself\.) - (you sound like a real (der-term) \.) - (why\, (statement) \!) - (I have many (group-adj) friends\.) - (save the (thing) s\!) (no nukes\!) (ban (thing) s\!) - (I\'ll bet you think that (thing) s are (adjective) \.) - (you know\, (statement) \.) - (your (quality) reminds me of a (thing) \.) - (you have the (quality) of a (der-term) \.) - ((der-term) \!) - ((adjective) (group-adj) (der-term) \!) - (you\'re a typical (group-adj) person\, totally (adjective) \.) - (man\, (sentence)))) - -(defvar sentence-loop (nconc sentence sentence)) - - -(defvar quality - '((ignorance) (stupidity) (worthlessness) - (prejudice) (lack of intelligence) (lousiness) - (bad grammar) (lousy spelling) - (lack of common decency) (ugliness) (nastiness) - (subtlety) (dishonesty) ((adjective) (quality)))) - - -(defvar quality-loop (nconc quality quality)) - -(defvar adjective - '((ignorant) (crass) (pathetic) (sick) - (bloated) (malignant) (perverted) (sadistic) - (stupid) (unpleasant) (lousy) (abusive) (bad) - (braindamaged) (selfish) (improper) (nasty) - (disgusting) (foul) (intolerable) (primitive) - (depressing) (dumb) (phoney) - ((adjective) and (adjective)) - (as (adjective) as a (thing)))) - -(defvar adjective-loop (nconc adjective adjective)) - -(defvar der-term - '(((adjective) (der-term)) (sexist) (fascist) - (weakling) (coward) (beast) (peasant) (racist) - (cretin) (fool) (jerk) (ignoramus) (idiot) - (wanker) (rat) (slimebag) (DAF driver) - (Neanderthal) (sadist) (drunk) (capitalist) - (wimp) (dogmatist) (wally) (maniac) - (whimpering scumbag) (pea brain) (arsehole) - (moron) (goof) (incompetent) (lunkhead) (Nazi) - (SysThug) ((der-term) (der-term)))) - -(defvar der-term-loop (nconc der-term der-term)) - - -(defvar thing - '(((adjective) (thing)) (computer) - (Honeywell dps8) (whale) (operation) - (sexist joke) (ten-incher) (dog) (MicroVAX II) - (source license) (real-time clock) - (mental problem) (sexual fantasy) - (venereal disease) (Jewish grandmother) - (cardboard cut-out) (punk haircut) (surfboard) - (system call) (wood-burning stove) - (graphics editor) (right wing death squad) - (disease) (vegetable) (religion) - (cruise missile) (bug fix) (lawyer) (copyright) - (PAD))) - -(defvar thing-loop (nconc thing thing)) - - -(defvar group-adj - '((gay) (old) (lesbian) (young) (black) - (Polish) ((adjective)) (white) - (mentally retarded) (Nicaraguan) (homosexual) - (dead) (underpriviledged) (religious) - ((thing) \-loving) (feminist) (foreign) - (intellectual) (crazy) (working) (unborn) - (Chinese) (short) ((adjective)) (poor) (rich) - (funny-looking) (Puerto Rican) (Mexican) - (Italian) (communist) (fascist) (Iranian) - (Moonie))) - -(defvar group-adj-loop (nconc group-adj group-adj)) - -(defvar statement - '((your (thing) is great) ((thing) s are fun) - ((person) is a (der-term)) - ((group-adj) people are (adjective)) - (every (group-adj) person is a (der-term)) - (most (group-adj) people have (thing) s) - (all (group-adj) dudes should get (thing) s) - ((person) is (group-adj)) (trees are (adjective)) - (if you\'ve seen one (thing) \, you\'ve seen them all) - (you\'re (group-adj)) (you have a (thing)) - (my (thing) is pretty good) - (the Martians are coming) - (the (paper) is always right) - (just because you read it in the (paper) that doesn\'t mean it\'s true) - ((person) was (group-adj)) - ((person) \'s ghost is living in your (thing)) - (you look like a (thing)) - (the oceans are full of dirty fish) - (people are dying every day) - (a (group-adj) man ain\'t got nothing in the world these days) - (women are inherently superior to men) - (the system staff is fascist) - (there is life after death) - (the world is full of (der-term) s) - (you remind me of (person)) (technology is evil) - ((person) killed (person)) - (the Russians are tapping your phone) - (the Earth is flat) - (it\'s OK to run down (group-adj) people) - (Multics is a really (adjective) operating system) - (the CIA killed (person)) - (the sexual revolution is over) - (Lassie was (group-adj)) - (the (group-adj) people have really got it all together) - (I was (person) in a previous life) - (breathing causes cancer) - (it\'s fun to be really (adjective)) - ((quality) is pretty fun) (you\'re a (der-term)) - (the (group-adj) culture is fascinating) - (when ya gotta go ya gotta go) - ((person) is (adjective)) - ((person) \'s (quality) is (adjective)) - (it\'s a wonderful day) - (everything is really a (thing)) - (there\'s a (thing) in (person) \'s brain) - ((person) is a cool dude) - ((person) is just a figment of your imagination) - (the more (thing) s you have, the better) - (life is a (thing)) (life is (quality)) - ((person) is (adjective)) - ((group-adj) people are all (adjective) (der-term) s) - ((statement) \, and (statement)) - ((statement) \, but (statement)) - (I wish I had a (thing)) - (you should have a (thing)) - (you hope that (statement)) - ((person) is secretly (group-adj)) - (you wish you were (group-adj)) - (you wish you were a (thing)) - (I wish I were a (thing)) - (you think that (statement)) - ((statement) \, because (statement)) - ((group-adj) people don\'t get married to (group-adj) people because (reason)) - ((group-adj) people are all (adjective) because (reason)) - ((group-adj) people are (adjective) \, and (reason)) - (you must be a (adjective) (der-term) to think that (person) said (statement)) - ((group-adj) people are inherently superior to (group-adj) people) - (God is Dead))) - -(defvar statement-loop (nconc statement statement)) - - -(defvar paper - '((Daily Mail) (Daily Express) - (Centre Bulletin) (Sun) (Daily Mirror) (Pravda) - (Daily Telegraph) (Beano) (Multics Manual))) - -(defvar paper-loop (nconc paper paper)) - - -(defvar person - '((Reagan) (Ken Thompson) (Dennis Ritchie) - (JFK) (the Pope) (Gadaffi) (Napoleon) - (Karl Marx) (Groucho) (Michael Jackson) - (Caesar) (Nietzsche) (Heidegger) (\"Head-for-the-mountains\" Bush) - (Henry Kissinger) (Nixon) (Castro) (Thatcher) - (Attilla the Hun) (Alaric the Visigoth) (Hitler))) - -(defvar person-loop (nconc person person)) - -(defvar reason - '((they don\'t want their children to grow up to be too lazy to steal) - (they can\'t tell them apart from (group-adj) dudes) - (they\'re too (adjective)) - ((person) wouldn\'t have done it) - (they can\'t spray paint that small) - (they don\'t have (thing) s) (they don\'t know how) - (they can\'t afford (thing) s))) - -(defvar reason-loop (nconc reason reason)) - -(defmacro define-element (name) - (let ((loop-to-use (intern (concat name "-loop")))) - (` (defun (, (intern name)) nil - (let ((step-forward (random 10))) - (if (< step-forward 0) (setq step-forward (- step-forward))) - (prog1 - (nth step-forward (, loop-to-use)) - (setq (, loop-to-use) (nthcdr (1+ step-forward) (, loop-to-use))))))))) - -(define-element "sentence") -(define-element "quality") -(define-element "adjective") -(define-element "der-term") -(define-element "group-adj") -(define-element "statement") -(define-element "thing") -(define-element "paper") -(define-element "person") -(define-element "reason") - -(defun *flame nil - (flame-expand '(sentence))) - -(defun flame-expand (object) - (cond ((atom object) - object) - (t (mapcar 'flame-expand (funcall (car object)))))) - -(defun flatten (list) - (cond ((atom list) - (list list)) - (t (apply 'append (mapcar 'flatten list))))) - -;;;###autoload -(defun flame (arg) - "Generate ARG (default 1) sentences of half-crazed gibberish." - (interactive "p") - (let ((w (selected-window))) - (pop-to-buffer (get-buffer-create "*Flame*")) - (goto-char (point-max)) - (insert ?\n) - (flame2 arg) - (select-window w))) - -(defun flame2 (arg) - (let ((start (point))) - (flame1 arg) - (fill-region-as-paragraph start (point) t))) - -(defun flame1 (arg) - (cond ((zerop arg) t) - (t (insert (concat (sentence-ify (string-ify (append-suffixes-hack (flatten (*flame))))))) - (flame1 (1- arg))))) - -(defun sentence-ify (string) - (concat (upcase (substring string 0 1)) - (substring string 1 (length string)) - " ")) - -(defun string-ify (list) - (mapconcat - 'symbol-name -; '(lambda (x) -; (format "%s" x)) - list - " ")) - -(defun append-suffixes-hack (list) - (cond ((null list) - nil) - ((memq (nth 1 list) - '(\? \. \, s\! \! s \'s \-loving)) - (cons (intern (concat (symbol-name (nth 0 list)) - (symbol-name (nth 1 list)))) - ;;(intern (format "%s%s" (nth 0 list) (nth 1 list))) - (append-suffixes-hack (nthcdr 2 list)))) - (t (cons (nth 0 list) - (append-suffixes-hack (nthcdr 1 list)))))) - -(defun psychoanalyze-flamer () - "Mr. Angry goes to the analyst." - (interactive) - (doctor) ; start the psychotherapy - (message "") - (switch-to-buffer "*doctor*") - (sit-for 0) - (while (not (input-pending-p)) - (flame2 (if (= (random 2) 0) 2 1)) - (sit-for 0) - (doctor-ret-or-read 1))) - -;;; flame.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/gomoku.el --- a/lisp/games/gomoku.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1136 +0,0 @@ -;;; gomoku.el --- Gomoku game between you and Emacs - -;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. - -;; Author: Philippe Schnoebelen -;; Adapted-By: ESR -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;;; Commentary: - -;;; Gomoku game between you and GNU Emacs. Last modified on 13 Sep 1988 -;;; -;;; Written by Ph. Schnoebelen (phs@lifia.imag.fr), 1987, 1988 -;;; with precious advices from J.-F. Rit. -;;; This has been tested with GNU Emacs 18.50. - -;; RULES: -;; -;; Gomoku is a game played between two players on a rectangular board. Each -;; player, in turn, marks a free square of its choice. The winner is the first -;; one to mark five contiguous squares in any direction (horizontally, -;; vertically or diagonally). -;; -;; I have been told that, in "The TRUE Gomoku", some restrictions are made -;; about the squares where one may play, or else there is a known forced win -;; for the first player. This program has no such restriction, but it does not -;; know about the forced win, nor do I. Furthermore, you probably do not know -;; it yourself :-). - - -;; There are two main places where you may want to customize the program: key -;; bindings and board display. These features are commented in the code. Go -;; and see. - - -;; HOW TO USE: -;; -;; The command "M-x gomoku" displays a -;; board, the size of which depends on the size of the current window. The -;; size of the board is easily modified by giving numeric arguments to the -;; gomoku command and/or by customizing the displaying parameters. -;; -;; Emacs plays when it is its turn. When it is your turn, just put the cursor -;; on the square where you want to play and hit RET, or X, or whatever key you -;; bind to the command gomoku-human-plays. When it is your turn, Emacs is -;; idle: you may switch buffers, read your mail, ... Just come back to the -;; *Gomoku* buffer and resume play. - - -;; ALGORITHM: -;; -;; The algorithm is briefly described in section "THE SCORE TABLE". Some -;; parameters may be modified if you want to change the style exhibited by the -;; program. - -;;; Code: - -;;; -;;; GOMOKU MODE AND KEYMAP. -;;; -(defvar gomoku-mode-hook nil - "If non-nil, its value is called on entry to Gomoku mode.") - -(defvar gomoku-mode-map nil - "Local keymap to use in Gomoku mode.") - -(if gomoku-mode-map - nil - (setq gomoku-mode-map (make-sparse-keymap)) - (set-keymap-name gomoku-mode-map 'gomoku-mode-map) - - ;; Key bindings for cursor motion. Arrow keys are just "function" - ;; keys, see below. - (define-key gomoku-mode-map "y" 'gomoku-move-nw) ; Y - (define-key gomoku-mode-map "u" 'gomoku-move-ne) ; U - (define-key gomoku-mode-map "b" 'gomoku-move-sw) ; B - (define-key gomoku-mode-map "n" 'gomoku-move-se) ; N - (define-key gomoku-mode-map "h" 'gomoku-move-left) ; H - (define-key gomoku-mode-map "l" 'gomoku-move-right) ; L - (define-key gomoku-mode-map "j" 'gomoku-move-down) ; J - (define-key gomoku-mode-map "k" 'gomoku-move-up) ; K - (define-key gomoku-mode-map "\C-n" 'gomoku-move-down) ; C-N - (define-key gomoku-mode-map "\C-p" 'gomoku-move-up) ; C-P - (define-key gomoku-mode-map "\C-f" 'gomoku-move-right) ; C-F - (define-key gomoku-mode-map "\C-b" 'gomoku-move-left) ; C-B - - ;; Key bindings for entering Human moves. - ;; If you have a mouse, you may also bind some mouse click ... - (define-key gomoku-mode-map "X" 'gomoku-human-plays) ; X - (define-key gomoku-mode-map "x" 'gomoku-human-plays) ; x - (define-key gomoku-mode-map "\C-m" 'gomoku-human-plays) ; RET - (define-key gomoku-mode-map "\C-c\C-p" 'gomoku-human-plays) ; C-C C-P - (define-key gomoku-mode-map "\C-c\C-b" 'gomoku-human-takes-back) ; C-C C-B - (define-key gomoku-mode-map "\C-c\C-r" 'gomoku-human-resigns) ; C-C C-R - (define-key gomoku-mode-map "\C-c\C-e" 'gomoku-emacs-plays) ; C-C C-E - - (define-key gomoku-mode-map [up] 'gomoku-move-up) - (define-key gomoku-mode-map [down] 'gomoku-move-down) - (define-key gomoku-mode-map [left] 'gomoku-move-left) - (define-key gomoku-mode-map [right] 'gomoku-move-right) - (define-key gomoku-mode-map [kp-enter] 'gomoku-human-plays) - (define-key gomoku-mode-map [button2] 'gomoku-click) - (define-key gomoku-mode-map [insert] 'gomoku-human-plays)) - - -(defun gomoku-mode () - "Major mode for playing Gomoku against Emacs. -You and Emacs play in turn by marking a free square. You mark it with X -and Emacs marks it with O. The winner is the first to get five contiguous -marks horizontally, vertically or in diagonal. -You play by moving the cursor over the square you choose and hitting \\[gomoku-human-plays]. -Other useful commands: -\\{gomoku-mode-map} -Entry to this mode calls the value of `gomoku-mode-hook' if that value -is non-nil." - (interactive) - (setq major-mode 'gomoku-mode - mode-name "Gomoku") - (gomoku-display-statistics) - (use-local-map gomoku-mode-map) - (run-hooks 'gomoku-mode-hook)) - -;;; -;;; THE BOARD. -;;; - -;; The board is a rectangular grid. We code empty squares with 0, X's with 1 -;; and O's with 6. The rectangle is recorded in a one dimensional vector -;; containing padding squares (coded with -1). These squares allow us to -;; detect when we are trying to move out of the board. We denote a square by -;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The -;; leftmost topmost square has coords (1,1) and index gomoku-board-width + 2. -;; Similarly, vectors between squares may be given by two DX, DY coords or by -;; one DEPL (the difference between indexes). - -(defvar gomoku-board-width nil - "Number of columns on the Gomoku board.") - -(defvar gomoku-board-height nil - "Number of lines on the Gomoku board.") - -(defvar gomoku-board nil - "Vector recording the actual state of the Gomoku board.") - -(defvar gomoku-vector-length nil - "Length of gomoku-board vector.") - -(defvar gomoku-draw-limit nil - ;; This is usually set to 70% of the number of squares. - "After how many moves will Emacs offer a draw?") - - -(defun gomoku-xy-to-index (x y) - "Translate X, Y cartesian coords into the corresponding board index." - (+ (* y gomoku-board-width) x y)) - -(defun gomoku-index-to-x (index) - "Return corresponding x-coord of board INDEX." - (% index (1+ gomoku-board-width))) - -(defun gomoku-index-to-y (index) - "Return corresponding y-coord of board INDEX." - (/ index (1+ gomoku-board-width))) - -(defun gomoku-init-board () - "Create the gomoku-board vector and fill it with initial values." - (setq gomoku-board (make-vector gomoku-vector-length 0)) - ;; Every square is 0 (i.e. empty) except padding squares: - (let ((i 0) (ii (1- gomoku-vector-length))) - (while (<= i gomoku-board-width) ; The squares in [0..width] and in - (aset gomoku-board i -1) ; [length - width - 1..length - 1] - (aset gomoku-board ii -1) ; are padding squares. - (setq i (1+ i) - ii (1- ii)))) - (let ((i 0)) - (while (< i gomoku-vector-length) - (aset gomoku-board i -1) ; and also all k*(width+1) - (setq i (+ i gomoku-board-width 1))))) - -;;; -;;; THE SCORE TABLE. -;;; - -;; Every (free) square has a score associated to it, recorded in the -;; GOMOKU-SCORE-TABLE vector. The program always plays in the square having -;; the highest score. - -(defvar gomoku-score-table nil - "Vector recording the actual score of the free squares.") - - -;; The key point point about the algorithm is that, rather than considering -;; the board as just a set of squares, we prefer to see it as a "space" of -;; internested 5-tuples of contiguous squares (called qtuples). -;; -;; The aim of the program is to fill one qtuple with its O's while preventing -;; you from filling another one with your X's. To that effect, it computes a -;; score for every qtuple, with better qtuples having better scores. Of -;; course, the score of a qtuple (taken in isolation) is just determined by -;; its contents as a set, i.e. not considering the order of its elements. The -;; highest score is given to the "OOOO" qtuples because playing in such a -;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because -;; not playing in it is just loosing the game, and so on. Note that a -;; "polluted" qtuple, i.e. one containing at least one X and at least one O, -;; has score zero because there is no more any point in playing in it, from -;; both an attacking and a defending point of view. -;; -;; Given the score of every qtuple, the score of a given free square on the -;; board is just the sum of the scores of all the qtuples to which it belongs, -;; because playing in that square is playing in all its containing qtuples at -;; once. And it is that function which takes into account the internesting of -;; the qtuples. -;; -;; This algorithm is rather simple but anyway it gives a not so dumb level of -;; play. It easily extends to "n-dimensional Gomoku", where a win should not -;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !) -;; should be preferred. - - -;; Here are the scores of the nine "non-polluted" configurations. Tuning -;; these values will change (hopefully improve) the strength of the program -;; and may change its style (rather aggressive here). - -(defconst nil-score 7 "Score of an empty qtuple.") -(defconst Xscore 15 "Score of a qtuple containing one X.") -(defconst XXscore 400 "Score of a qtuple containing two X's.") -(defconst XXXscore 1800 "Score of a qtuple containing three X's.") -(defconst XXXXscore 100000 "Score of a qtuple containing four X's.") -(defconst Oscore 35 "Score of a qtuple containing one O.") -(defconst OOscore 800 "Score of a qtuple containing two O's.") -(defconst OOOscore 15000 "Score of a qtuple containing three O's.") -(defconst OOOOscore 800000 "Score of a qtuple containing four O's.") - -;; These values are not just random: if, given the following situation: -;; -;; . . . . . . . O . -;; . X X a . . . X . -;; . . . X . . . X . -;; . . . X . . . X . -;; . . . . . . . b . -;; -;; you want Emacs to play in "a" and not in "b", then the parameters must -;; satisfy the inequality: -;; -;; 6 * XXscore > XXXscore + XXscore -;; -;; because "a" mainly belongs to six "XX" qtuples (the others are less -;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other -;; conditions are required to obtain sensible moves, but the previous example -;; should illustrate the point. If you manage to improve on these values, -;; please send me a note. Thanks. - - -;; As we choosed values 0, 1 and 6 to denote empty, X and O squares, the -;; contents of a qtuple is uniquely determined by the sum of its elements and -;; we just have to set up a translation table. - -(defconst gomoku-score-trans-table - (vector nil-score Xscore XXscore XXXscore XXXXscore 0 - Oscore 0 0 0 0 0 - OOscore 0 0 0 0 0 - OOOscore 0 0 0 0 0 - OOOOscore 0 0 0 0 0 - 0) - "Vector associating qtuple contents to their score.") - - -;; If you do not modify drastically the previous constants, the only way for a -;; square to have a score higher than OOOOscore is to belong to a "OOOO" -;; qtuple, thus to be a winning move. Similarly, the only way for a square to -;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX" -;; qtuple. We may use these considerations to detect when a given move is -;; winning or loosing. - -(defconst gomoku-winning-threshold OOOOscore - "Threshold score beyond which an Emacs move is winning.") - -(defconst gomoku-loosing-threshold XXXXscore - "Threshold score beyond which a human move is winning.") - - -(defun gomoku-strongest-square () - "Compute index of free square with highest score, or nil if none." - ;; We just have to loop other all squares. However there are two problems: - ;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed - ;; up future searches, we set the score of padding or occupied squares - ;; to -1 whenever we meet them. - ;; 2/ We want to choose randomly between equally good moves. - (let ((score-max 0) - (count 0) ; Number of equally good moves - (square (gomoku-xy-to-index 1 1)) ; First square - (end (gomoku-xy-to-index gomoku-board-width gomoku-board-height)) - best-square score) - (while (<= square end) - (cond - ;; If score is lower (i.e. most of the time), skip to next: - ((< (aref gomoku-score-table square) score-max)) - ;; If score is better, beware of non free squares: - ((> (setq score (aref gomoku-score-table square)) score-max) - (if (zerop (aref gomoku-board square)) ; is it free ? - (setq count 1 ; yes: take it ! - best-square square - score-max score) - (aset gomoku-score-table square -1))) ; no: kill it ! - ;; If score is equally good, choose randomly. But first check freeness: - ((not (zerop (aref gomoku-board square))) - (aset gomoku-score-table square -1)) - ((zerop (random (setq count (1+ count)))) - (setq best-square square - score-max score))) - (setq square (1+ square))) ; try next square - best-square)) - -;;; -;;; INITIALIZING THE SCORE TABLE. -;;; - -;; At initialization the board is empty so that every qtuple amounts for -;; nil-score. Therefore, the score of any square is nil-score times the number -;; of qtuples that pass through it. This number is 3 in a corner and 20 if you -;; are sufficiently far from the sides. As computing the number is time -;; consuming, we initialize every square with 20*nil-score and then only -;; consider squares at less than 5 squares from one side. We speed this up by -;; taking symmetry into account. -;; Also, as it is likely that successive games will be played on a board with -;; same size, it is a good idea to save the initial SCORE-TABLE configuration. - -(defvar gomoku-saved-score-table nil - "Recorded initial value of previous score table.") - -(defvar gomoku-saved-board-width nil - "Recorded value of previous board width.") - -(defvar gomoku-saved-board-height nil - "Recorded value of previous board height.") - - -(defun gomoku-init-score-table () - "Create the score table vector and fill it with initial values." - (if (and gomoku-saved-score-table ; Has it been stored last time ? - (= gomoku-board-width gomoku-saved-board-width) - (= gomoku-board-height gomoku-saved-board-height)) - (setq gomoku-score-table (copy-sequence gomoku-saved-score-table)) - ;; No, compute it: - (setq gomoku-score-table - (make-vector gomoku-vector-length (* 20 nil-score))) - (let (i j maxi maxj maxi2 maxj2) - (setq maxi (/ (1+ gomoku-board-width) 2) - maxj (/ (1+ gomoku-board-height) 2) - maxi2 (min 4 maxi) - maxj2 (min 4 maxj)) - ;; We took symmetry into account and could use it more if the board - ;; would have been square and not rectangular ! - ;; In our case we deal with all (i,j) in the set [1..maxi2]*[1..maxj] U - ;; [maxi2+1..maxi]*[1..maxj2]. Maxi2 and maxj2 are used because the - ;; board may well be less than 8 by 8 ! - (setq i 1) - (while (<= i maxi2) - (setq j 1) - (while (<= j maxj) - (gomoku-init-square-score i j) - (setq j (1+ j))) - (setq i (1+ i))) - (while (<= i maxi) - (setq j 1) - (while (<= j maxj2) - (gomoku-init-square-score i j) - (setq j (1+ j))) - (setq i (1+ i)))) - (setq gomoku-saved-score-table (copy-sequence gomoku-score-table) - gomoku-saved-board-width gomoku-board-width - gomoku-saved-board-height gomoku-board-height))) - -(defun gomoku-nb-qtuples (i j) - "Return the number of qtuples containing square I,J." - ;; This function is complicated because we have to deal - ;; with ugly cases like 3 by 6 boards, but it works. - ;; If you have a simpler (and correct) solution, send it to me. Thanks ! - (let ((left (min 4 (1- i))) - (right (min 4 (- gomoku-board-width i))) - (up (min 4 (1- j))) - (down (min 4 (- gomoku-board-height j)))) - (+ -12 - (min (max (+ left right) 3) 8) - (min (max (+ up down) 3) 8) - (min (max (+ (min left up) (min right down)) 3) 8) - (min (max (+ (min right up) (min left down)) 3) 8)))) - -(defun gomoku-init-square-score (i j) - "Give initial score to square I,J and to its mirror images." - (let ((ii (1+ (- gomoku-board-width i))) - (jj (1+ (- gomoku-board-height j))) - (sc (* (gomoku-nb-qtuples i j) (aref gomoku-score-trans-table 0)))) - (aset gomoku-score-table (gomoku-xy-to-index i j) sc) - (aset gomoku-score-table (gomoku-xy-to-index ii j) sc) - (aset gomoku-score-table (gomoku-xy-to-index i jj) sc) - (aset gomoku-score-table (gomoku-xy-to-index ii jj) sc))) - -;;; -;;; MAINTAINING THE SCORE TABLE. -;;; - -;; We do not provide functions for computing the SCORE-TABLE given the -;; contents of the BOARD. This would involve heavy nested loops, with time -;; proportional to the size of the board. It is better to update the -;; SCORE-TABLE after each move. Updating needs not modify more than 36 -;; squares: it is done in constant time. - -(defun gomoku-update-score-table (square dval) - "Update score table after SQUARE received a DVAL increment." - ;; The board has already been updated when this function is called. - ;; Updating scores is done by looking for qtuples boundaries in all four - ;; directions and then calling update-score-in-direction. - ;; Finally all squares received the right increment, and then are up to - ;; date, except possibly for SQUARE itself if we are taking a move back for - ;; its score had been set to -1 at the time. - (let* ((x (gomoku-index-to-x square)) - (y (gomoku-index-to-y square)) - (imin (max -4 (- 1 x))) - (jmin (max -4 (- 1 y))) - (imax (min 0 (- gomoku-board-width x 4))) - (jmax (min 0 (- gomoku-board-height y 4)))) - (gomoku-update-score-in-direction imin imax - square 1 0 dval) - (gomoku-update-score-in-direction jmin jmax - square 0 1 dval) - (gomoku-update-score-in-direction (max imin jmin) (min imax jmax) - square 1 1 dval) - (gomoku-update-score-in-direction (max (- 1 y) -4 - (- x gomoku-board-width)) - (min 0 (- x 5) - (- gomoku-board-height y 4)) - square -1 1 dval))) - -(defun gomoku-update-score-in-direction (left right square dx dy dval) - "Update scores for all squares in the qtuples starting between the LEFTth -square and the RIGHTth after SQUARE, along the DX, DY direction, considering -that DVAL has been added on SQUARE." - ;; We always have LEFT <= 0, RIGHT <= 0 and DEPL > 0 but we may very well - ;; have LEFT > RIGHT, indicating that no qtuple contains SQUARE along that - ;; DX,DY direction. - (cond - ((> left right)) ; Quit - (t ; Else .. - (let (depl square0 square1 square2 count delta) - (setq depl (gomoku-xy-to-index dx dy) - square0 (+ square (* left depl)) - square1 (+ square (* right depl)) - square2 (+ square0 (* 4 depl))) - ;; Compute the contents of the first qtuple: - (setq square square0 - count 0) - (while (<= square square2) - (setq count (+ count (aref gomoku-board square)) - square (+ square depl))) - (while (<= square0 square1) - ;; Update the squares of the qtuple beginning in SQUARE0 and ending - ;; in SQUARE2. - (setq delta (- (aref gomoku-score-trans-table count) - (aref gomoku-score-trans-table (- count dval)))) - (cond ((not (zerop delta)) ; or else nothing to update - (setq square square0) - (while (<= square square2) - (if (zerop (aref gomoku-board square)) ; only for free squares - (aset gomoku-score-table square - (+ (aref gomoku-score-table square) delta))) - (setq square (+ square depl))))) - ;; Then shift the qtuple one square along DEPL, this only requires - ;; modifying SQUARE0 and SQUARE2. - (setq square2 (+ square2 depl) - count (+ count (- (aref gomoku-board square0)) - (aref gomoku-board square2)) - square0 (+ square0 depl))))))) - -;;; -;;; GAME CONTROL. -;;; - -;; Several variables are used to monitor a game, including a GAME-HISTORY (the -;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back -;; (anti-updating the score table) and to compute the table from scratch in -;; case of an interruption. - -(defvar gomoku-game-in-progress nil - "Non-nil if a game is in progress.") - -(defvar gomoku-game-history nil - "A record of all moves that have been played during current game.") - -(defvar gomoku-number-of-moves nil - "Number of moves already played in current game.") - -(defvar gomoku-number-of-human-moves nil - "Number of moves already played by human in current game.") - -(defvar gomoku-emacs-played-first nil - "Non-nil if Emacs played first.") - -(defvar gomoku-human-took-back nil - "Non-nil if Human took back a move during the game.") - -(defvar gomoku-human-refused-draw nil - "Non-nil if Human refused Emacs offer of a draw.") - -(defvar gomoku-emacs-is-computing nil - ;; This is used to detect interruptions. Hopefully, it should not be needed. - "Non-nil if Emacs is in the middle of a computation.") - - -(defun gomoku-start-game (n m) - "Initialize a new game on an N by M board." - (setq gomoku-emacs-is-computing t) ; Raise flag - (setq gomoku-game-in-progress t) - (setq gomoku-board-width n - gomoku-board-height m - gomoku-vector-length (1+ (* (+ m 2) (1+ n))) - gomoku-draw-limit (/ (* 7 n m) 10)) - (setq gomoku-game-history nil - gomoku-number-of-moves 0 - gomoku-number-of-human-moves 0 - gomoku-emacs-played-first nil - gomoku-human-took-back nil - gomoku-human-refused-draw nil) - (gomoku-init-display n m) ; Display first: the rest takes time - (gomoku-init-score-table) ; INIT-BOARD requires that the score - (gomoku-init-board) ; table be already created. - (setq gomoku-emacs-is-computing nil)) - -(defun gomoku-play-move (square val &optional dont-update-score) - "Go to SQUARE, play VAL and update everything." - (setq gomoku-emacs-is-computing t) ; Raise flag - (cond ((= 1 val) ; a Human move - (setq gomoku-number-of-human-moves (1+ gomoku-number-of-human-moves))) - ((zerop gomoku-number-of-moves) ; an Emacs move. Is it first ? - (setq gomoku-emacs-played-first t))) - (setq gomoku-game-history - (cons (cons square (aref gomoku-score-table square)) - gomoku-game-history) - gomoku-number-of-moves (1+ gomoku-number-of-moves)) - (gomoku-plot-square square val) - (aset gomoku-board square val) ; *BEFORE* UPDATE-SCORE ! - (if dont-update-score nil - (gomoku-update-score-table square val) ; previous val was 0: dval = val - (aset gomoku-score-table square -1)) - (setq gomoku-emacs-is-computing nil)) - -(defun gomoku-take-back () - "Take back last move and update everything." - (setq gomoku-emacs-is-computing t) - (let* ((last-move (car gomoku-game-history)) - (square (car last-move)) - (oldval (aref gomoku-board square))) - (if (= 1 oldval) - (setq gomoku-number-of-human-moves (1- gomoku-number-of-human-moves))) - (setq gomoku-game-history (cdr gomoku-game-history) - gomoku-number-of-moves (1- gomoku-number-of-moves)) - (gomoku-plot-square square 0) - (aset gomoku-board square 0) ; *BEFORE* UPDATE-SCORE ! - (gomoku-update-score-table square (- oldval)) - (aset gomoku-score-table square (cdr last-move))) - (setq gomoku-emacs-is-computing nil)) - -;;; -;;; SESSION CONTROL. -;;; - -(defvar gomoku-number-of-emacs-wins 0 - "Number of games Emacs won in this session.") - -(defvar gomoku-number-of-human-wins 0 - "Number of games you won in this session.") - -(defvar gomoku-number-of-draws 0 - "Number of games already drawn in this session.") - - -(defun gomoku-terminate-game (result) - "Terminate the current game with RESULT." - (let (message) - (cond - ((eq result 'emacs-won) - (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) - (setq message - (cond ((< gomoku-number-of-moves 20) - "This was a REALLY QUICK win.") - (gomoku-human-refused-draw - "I won... Too bad you refused my offer of a draw !") - (gomoku-human-took-back - "I won... Taking moves back will not help you !") - ((not gomoku-emacs-played-first) - "I won... Playing first did not help you much !") - ((and (zerop gomoku-number-of-human-wins) - (zerop gomoku-number-of-draws) - (> gomoku-number-of-emacs-wins 1)) - "I'm becoming tired of winning...") - (t - "I won.")))) - ((eq result 'human-won) - (setq gomoku-number-of-human-wins (1+ gomoku-number-of-human-wins)) - (setq message - (cond - (gomoku-human-took-back - "OK, you won this one. I, for one, never take my moves back...") - (gomoku-emacs-played-first - "OK, you won this one... so what ?") - (t - "OK, you won this one. Now, let me play first just once.")))) - ((eq result 'human-resigned) - (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) - (setq message "So you resign. That's just one more win for me.")) - ((eq result 'nobody-won) - (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) - (setq message - (cond - (gomoku-human-took-back - "This is a draw. I, for one, never take my moves back...") - (gomoku-emacs-played-first - "This is a draw. Just chance, I guess.") - (t - "This is a draw. Now, let me play first just once.")))) - ((eq result 'draw-agreed) - (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) - (setq message - (cond - (gomoku-human-took-back - "Draw agreed. I, for one, never take my moves back...") - (gomoku-emacs-played-first - "Draw agreed. You were lucky.") - (t - "Draw agreed. Now, let me play first just once.")))) - ((eq result 'crash-game) - (setq message - "Sorry, I have been interrupted and cannot resume that game..."))) - - (gomoku-display-statistics) - (if message (message message)) - (ding) - (setq gomoku-game-in-progress nil))) - -(defun gomoku-crash-game () - "What to do when Emacs detects it has been interrupted." - (setq gomoku-emacs-is-computing nil) - (gomoku-terminate-game 'crash-game) - (sit-for 4) ; Let's see the message - (gomoku-prompt-for-other-game)) - -;;; -;;; INTERACTIVE COMMANDS. -;;; - -;;;###autoload -(defun gomoku (&optional n m) - "Start a Gomoku game between you and Emacs. -If a game is in progress, this command allow you to resume it. -If optional arguments N and M are given, an N by M board is used. - -You and Emacs play in turn by marking a free square. You mark it with X -and Emacs marks it with O. The winner is the first to get five contiguous -marks horizontally, vertically or in diagonal. -You play by moving the cursor over the square you choose and hitting -\\\\[gomoku-human-plays]. -Use \\[describe-mode] for more info." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (let ((max-width (gomoku-max-width)) - (max-height (gomoku-max-height))) - (or n (setq n max-width)) - (or m (setq m max-height)) - (cond ((< n 1) - (error "I need at least 1 column")) - ((< m 1) - (error "I need at least 1 row")) - ((> n max-width) - (error "I cannot display %d columns in that window" n))) - (if (and (> m max-height) - (not (equal m gomoku-saved-board-height)) - ;; Use EQUAL because SAVED-BOARD-HEIGHT may be nil - (not (y-or-n-p (format "Do you really want %d rows " m)))) - (setq m max-height))) - (message "One moment, please...") - (gomoku-start-game n m) - (if (y-or-n-p "Do you allow me to play first ") - (gomoku-emacs-plays) - (gomoku-prompt-for-move))) - ((y-or-n-p "Shall we continue our game ") - (gomoku-prompt-for-move)) - (t - (gomoku-human-resigns)))) - -(defun gomoku-emacs-plays () - "Compute Emacs next move and play it." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (gomoku-prompt-for-other-game)) - (t - (message "Let me think...") - (let (square score) - (setq square (gomoku-strongest-square)) - (cond ((null square) - (gomoku-terminate-game 'nobody-won)) - (t - (setq score (aref gomoku-score-table square)) - (gomoku-play-move square 6) - (cond ((>= score gomoku-winning-threshold) - (gomoku-find-filled-qtuple square 6) - (gomoku-cross-winning-qtuple) - (gomoku-terminate-game 'emacs-won)) - ((zerop score) - (gomoku-terminate-game 'nobody-won)) - ((and (> gomoku-number-of-moves gomoku-draw-limit) - (not gomoku-human-refused-draw) - (gomoku-offer-a-draw)) - (gomoku-terminate-game 'draw-agreed)) - (t - (gomoku-prompt-for-move))))))))) - -(defun gomoku-click (click) - "Play at the square where you click." - (interactive "e") - (mouse-set-point click) - (gomoku-human-plays)) - -(defun gomoku-human-plays () - "Signal to the Gomoku program that you have played. -You must have put the cursor on the square where you want to play. -If the game is finished, this command requests for another game." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (gomoku-prompt-for-other-game)) - (t - (let (square score) - (setq square (gomoku-point-square)) - (cond ((null square) - (error "Your point is not on a square. Retry !")) - ((not (zerop (aref gomoku-board square))) - (error "Your point is not on a free square. Retry !")) - (t - (setq score (aref gomoku-score-table square)) - (gomoku-play-move square 1) - (cond ((and (>= score gomoku-loosing-threshold) - ;; Just testing SCORE > THRESHOLD is not enough for - ;; detecting wins, it just gives an indication that - ;; we confirm with GOMOKU-FIND-FILLED-QTUPLE. - (gomoku-find-filled-qtuple square 1)) - (gomoku-cross-winning-qtuple) - (gomoku-terminate-game 'human-won)) - (t - (gomoku-emacs-plays))))))))) - -(defun gomoku-human-takes-back () - "Signal to the Gomoku program that you wish to take back your last move." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (message "Too late for taking back...") - (sit-for 4) - (gomoku-prompt-for-other-game)) - ((zerop gomoku-number-of-human-moves) - (message "You have not played yet... Your move ?")) - (t - (message "One moment, please...") - ;; It is possible for the user to let Emacs play several consecutive - ;; moves, so that the best way to know when to stop taking back moves is - ;; to count the number of human moves: - (setq gomoku-human-took-back t) - (let ((number gomoku-number-of-human-moves)) - (while (= number gomoku-number-of-human-moves) - (gomoku-take-back))) - (gomoku-prompt-for-move)))) - -(defun gomoku-human-resigns () - "Signal to the Gomoku program that you may want to resign." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (message "There is no game in progress")) - ((y-or-n-p "You mean, you resign ") - (gomoku-terminate-game 'human-resigned)) - ((y-or-n-p "You mean, we continue ") - (gomoku-prompt-for-move)) - (t - (gomoku-terminate-game 'human-resigned)))) ; OK. Accept it - -;;; -;;; PROMPTING THE HUMAN PLAYER. -;;; - -(defun gomoku-prompt-for-move () - "Display a message asking for Human's move." - (message (if (zerop gomoku-number-of-human-moves) - "Your move ? (move to a free square and hit X, RET ...)" - "Your move ?")) - ;; This may seem silly, but if one omits the following line (or a similar - ;; one), the cursor may very well go to some place where POINT is not. - (save-excursion (set-buffer (other-buffer)))) - -(defun gomoku-prompt-for-other-game () - "Ask for another game, and start it." - (if (y-or-n-p "Another game ") - (gomoku gomoku-board-width gomoku-board-height) - (message "Chicken !"))) - -(defun gomoku-offer-a-draw () - "Offer a draw and return T if Human accepted it." - (or (y-or-n-p "I offer you a draw. Do you accept it ") - (prog1 (setq gomoku-human-refused-draw t) - nil))) - -;;; -;;; DISPLAYING THE BOARD. -;;; - -;; You may change these values if you have a small screen or if the squares -;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1). - -(defconst gomoku-square-width 4 - "*Horizontal spacing between squares on the Gomoku board.") - -(defconst gomoku-square-height 2 - "*Vertical spacing between squares on the Gomoku board.") - -(defconst gomoku-x-offset 3 - "*Number of columns between the Gomoku board and the side of the window.") - -(defconst gomoku-y-offset 1 - "*Number of lines between the Gomoku board and the top of the window.") - - -(defun gomoku-max-width () - "Largest possible board width for the current window." - (1+ (/ (- (window-width (selected-window)) - gomoku-x-offset gomoku-x-offset 1) - gomoku-square-width))) - -(defun gomoku-max-height () - "Largest possible board height for the current window." - (1+ (/ (- (window-height (selected-window)) - gomoku-y-offset gomoku-y-offset 2) - ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line ! - gomoku-square-height))) - -(defun gomoku-point-x () - "Return the board column where point is, or nil if it is not a board column." - (let ((col (- (current-column) gomoku-x-offset))) - (if (and (>= col 0) - (zerop (% col gomoku-square-width)) - (<= (setq col (1+ (/ col gomoku-square-width))) - gomoku-board-width)) - col))) - -(defun gomoku-point-y () - "Return the board row where point is, or nil if it is not a board row." - (let ((row (- (count-lines 1 (point)) gomoku-y-offset 1))) - (if (and (>= row 0) - (zerop (% row gomoku-square-height)) - (<= (setq row (1+ (/ row gomoku-square-height))) - gomoku-board-height)) - row))) - -(defun gomoku-point-square () - "Return the index of the square point is on, or nil if not on the board." - (let (x y) - (and (setq x (gomoku-point-x)) - (setq y (gomoku-point-y)) - (gomoku-xy-to-index x y)))) - -(defun gomoku-goto-square (index) - "Move point to square number INDEX." - (gomoku-goto-xy (gomoku-index-to-x index) (gomoku-index-to-y index))) - -(defun gomoku-goto-xy (x y) - "Move point to square at X, Y coords." - (goto-line (+ 1 gomoku-y-offset (* gomoku-square-height (1- y)))) - (move-to-column (+ gomoku-x-offset (* gomoku-square-width (1- x))))) - -(defun gomoku-plot-square (square value) - "Draw 'X', 'O' or '.' on SQUARE (depending on VALUE), leave point there." - (gomoku-goto-square square) - (gomoku-put-char (cond ((= value 1) ?X) - ((= value 6) ?O) - (t ?.))) - (sit-for 0)) ; Display NOW - -(defun gomoku-put-char (char) - "Draw CHAR on the Gomoku screen." - (let ((inhibit-read-only t)) - (insert char) - (delete-char 1) - (backward-char 1))) - -(defun gomoku-init-display (n m) - "Display an N by M Gomoku board." - (buffer-disable-undo (current-buffer)) - (let ((inhibit-read-only t)) - (erase-buffer) - (let (string1 string2 string3 string4) - ;; We do not use gomoku-plot-square which would be too slow for - ;; initializing the display. Rather we build STRING1 for lines where - ;; board squares are to be found, and STRING2 for empty lines. STRING1 is - ;; like STRING2 except for dots every DX squares. Empty lines are filled - ;; with spaces so that cursor moving up and down remains on the same - ;; column. - (setq string1 (concat (make-string (1- gomoku-square-width) ? ) ".") - string1 (apply 'concat - (make-list (1- n) string1)) - string1 (concat (make-string gomoku-x-offset ? ) "." string1 "\n") - string2 (make-string (+ 1 gomoku-x-offset - (* (1- n) gomoku-square-width)) - ? ) - string2 (concat string2 "\n") - string3 (apply 'concat - (make-list (1- gomoku-square-height) string2)) - string3 (concat string3 string1) - string3 (apply 'concat - (make-list (1- m) string3)) - string4 (apply 'concat - (make-list gomoku-y-offset string2))) - (insert string4 string1 string3)) - (gomoku-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board - (sit-for 0))) ; Display NOW - -(defun gomoku-display-statistics () - "Obnoxiously display some statistics about previous games in mode line." - ;; We store this string in the mode-line-process local variable. - ;; This is certainly not the cleanest way out ... - (setq mode-line-process - (cond - ((not (zerop gomoku-number-of-draws)) - (format ": Won %d, lost %d, drew %d" - gomoku-number-of-human-wins - gomoku-number-of-emacs-wins - gomoku-number-of-draws)) - (t - (format ": Won %d, lost %d" - gomoku-number-of-human-wins - gomoku-number-of-emacs-wins)))) - (force-mode-line-update)) - -(defun gomoku-switch-to-window () - "Find or create the Gomoku buffer, and display it." - (interactive) - (let ((buff (get-buffer "*Gomoku*"))) - (if buff ; Buffer exists: - (switch-to-buffer buff) ; no problem. - (if gomoku-game-in-progress - (gomoku-crash-game)) ; buffer has been killed or something - (switch-to-buffer "*Gomoku*") ; Anyway, start anew. - (gomoku-mode)))) - -;;; -;;; CROSSING WINNING QTUPLES. -;;; - -;; When someone succeeds in filling a qtuple, we draw a line over the five -;; corresponding squares. One problem is that the program does not know which -;; squares ! It only knows the square where the last move has been played and -;; who won. The solution is to scan the board along all four directions. - -(defvar gomoku-winning-qtuple-beg nil - "First square of the winning qtuple.") - -(defvar gomoku-winning-qtuple-end nil - "Last square of the winning qtuple.") - -(defvar gomoku-winning-qtuple-dx nil - "Direction of the winning qtuple (along the X axis).") - -(defvar gomoku-winning-qtuple-dy nil - "Direction of the winning qtuple (along the Y axis).") - - -(defun gomoku-find-filled-qtuple (square value) - "Return T if SQUARE belongs to a qtuple filled with VALUEs." - (or (gomoku-check-filled-qtuple square value 1 0) - (gomoku-check-filled-qtuple square value 0 1) - (gomoku-check-filled-qtuple square value 1 1) - (gomoku-check-filled-qtuple square value -1 1))) - -(defun gomoku-check-filled-qtuple (square value dx dy) - "Return T if SQUARE belongs to a qtuple filled with VALUEs along DX, DY." - ;; And record it in the WINNING-QTUPLE-... variables. - (let ((a 0) (b 0) - (left square) (right square) - (depl (gomoku-xy-to-index dx dy)) - a+4) - (while (and (> a -4) ; stretch tuple left - (= value (aref gomoku-board (setq left (- left depl))))) - (setq a (1- a))) - (setq a+4 (+ a 4)) - (while (and (< b a+4) ; stretch tuple right - (= value (aref gomoku-board (setq right (+ right depl))))) - (setq b (1+ b))) - (cond ((= b a+4) ; tuple length = 5 ? - (setq gomoku-winning-qtuple-beg (+ square (* a depl)) - gomoku-winning-qtuple-end (+ square (* b depl)) - gomoku-winning-qtuple-dx dx - gomoku-winning-qtuple-dy dy) - t)))) - -(defun gomoku-cross-winning-qtuple () - "Cross winning qtuple, as found by `gomoku-find-filled-qtuple'." - (gomoku-cross-qtuple gomoku-winning-qtuple-beg - gomoku-winning-qtuple-end - gomoku-winning-qtuple-dx - gomoku-winning-qtuple-dy)) - -(defun gomoku-cross-qtuple (square1 square2 dx dy) - "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction." - (save-excursion ; Not moving point from last square - (let ((depl (gomoku-xy-to-index dx dy))) - ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1 - (while (not (= square1 square2)) - (gomoku-goto-square square1) - (setq square1 (+ square1 depl)) - (cond - ((and (= dx 1) (= dy 0)) ; Horizontal - (let ((n 1)) - (while (< n gomoku-square-width) - (setq n (1+ n)) - (forward-char 1) - (gomoku-put-char ?-)))) - ((and (= dx 0) (= dy 1)) ; Vertical - (let ((n 1)) - (while (< n gomoku-square-height) - (setq n (1+ n)) - (next-line 1) - (gomoku-put-char ?|)))) - ((and (= dx -1) (= dy 1)) ; 1st Diagonal - (backward-char (/ gomoku-square-width 2)) - (next-line (/ gomoku-square-height 2)) - (gomoku-put-char ?/)) - ((and (= dx 1) (= dy 1)) ; 2nd Diagonal - (forward-char (/ gomoku-square-width 2)) - (next-line (/ gomoku-square-height 2)) - (gomoku-put-char ?\\)))))) - (sit-for 0)) ; Display NOW - -;;; -;;; CURSOR MOTION. -;;; -(defun gomoku-move-left () - "Move point backward one column on the Gomoku board." - (interactive) - (let ((x (gomoku-point-x))) - (backward-char (cond ((null x) 1) - ((> x 1) gomoku-square-width) - (t 0))))) - -(defun gomoku-move-right () - "Move point forward one column on the Gomoku board." - (interactive) - (let ((x (gomoku-point-x))) - (forward-char (cond ((null x) 1) - ((< x gomoku-board-width) gomoku-square-width) - (t 0))))) - -(defun gomoku-move-down () - "Move point down one row on the Gomoku board." - (interactive) - (let ((y (gomoku-point-y))) - (next-line (cond ((null y) 1) - ((< y gomoku-board-height) gomoku-square-height) - (t 0))))) - -(defun gomoku-move-up () - "Move point up one row on the Gomoku board." - (interactive) - (let ((y (gomoku-point-y))) - (previous-line (cond ((null y) 1) - ((> y 1) gomoku-square-height) - (t 0))))) - -(defun gomoku-move-ne () - "Move point North East on the Gomoku board." - (interactive) - (gomoku-move-up) - (gomoku-move-right)) - -(defun gomoku-move-se () - "Move point South East on the Gomoku board." - (interactive) - (gomoku-move-down) - (gomoku-move-right)) - -(defun gomoku-move-nw () - "Move point North West on the Gomoku board." - (interactive) - (gomoku-move-up) - (gomoku-move-left)) - -(defun gomoku-move-sw () - "Move point South West on the Gomoku board." - (interactive) - (gomoku-move-down) - (gomoku-move-left)) - -(provide 'gomoku) - -;;; gomoku.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/hanoi.el --- a/lisp/games/hanoi.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,249 +0,0 @@ -;;; hanoi.el --- towers of hanoi in GNUmacs - -;; Author: Damon Anton Permezel -;; Maintainer: FSF -;; Keywords: games - -; Author (a) 1985, Damon Anton Permezel -; This is in the public domain -; since he distributed it without copyright notice in 1985. - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Solves the Towers of Hanoi puzzle while-U-wait. -;; -;; The puzzle: Start with N rings, decreasing in sizes from bottom to -;; top, stacked around a post. There are two other posts. Your mission, -;; should you choose to accept it, is to shift the pile, stacked in its -;; original order, to another post. -;; -;; The challenge is to do it in the fewest possible moves. Each move -;; shifts one ring to a different post. But there's a rule; you can -;; only stack a ring on top of a larger one. -;; -;; The simplest nontrivial version of this puzzle is N = 3. Solution -;; time rises as 2**N, and programs to solve it have long been considered -;; classic introductory exercises in the use of recursion. -;; -;; The puzzle is called `Towers of Hanoi' because an early popular -;; presentation wove a fanciful legend around it. According to this -;; myth (uttered long before the Vietnam War), there is a Buddhist -;; monastery at Hanoi which contains a large room with three time-worn -;; posts in it surrounded by 21 golden discs. Monks, acting out the -;; command of an ancient prophecy, have been moving these disks, in -;; accordance with the rules of the puzzle, once every day since the -;; monastery was founded over a thousand years ago. They are said -;; believe that when the last move of the puzzle is completed, the -;; world will end in a clap of thunder. Fortunately, they are nowhere -;; even close to being done... - -;;; Code: - -;;; -;;; hanoi-topos - direct cursor addressing -;;; -(defun hanoi-topos (row col) - (goto-line row) - (beginning-of-line) - (forward-char col)) - -;;; -;;; hanoi - user callable Towers of Hanoi -;;; -;;;###autoload -(defun hanoi (nrings) - "Towers of Hanoi diversion. Argument is number of rings." - (interactive - (list (if (null current-prefix-arg) - 3 - (prefix-numeric-value current-prefix-arg)))) - (if (<= nrings 0) (error "Negative number of rings")) - (let* (floor-row - fly-row - (window-height (1- (window-height (selected-window)))) - (window-width (window-width (selected-window))) - - ;; This is half the spacing to use between poles. - (pole-spacing (/ window-width 6))) - (if (not (and (> window-height (1+ nrings)) - (> pole-spacing nrings))) - (progn - (delete-other-windows) - (if (not (and (> (setq window-height - (1- (window-height (selected-window)))) - (1+ nrings)) - (> (setq pole-spacing (/ window-width 6)) - nrings))) - (error "Window is too small (need at least %dx%d)" - (* 6 (1+ nrings)) (+ 2 nrings))))) - (setq floor-row (if (> (- window-height 3) (1+ nrings)) - (- window-height 3) window-height)) - (let ((fly-row (- floor-row nrings 1)) - ;; pole: column . fill height - (pole-1 (cons (1- pole-spacing) floor-row)) - (pole-2 (cons (1- (* 3 pole-spacing)) floor-row)) - (pole-3 (cons (1- (* 5 pole-spacing)) floor-row)) - (rings (make-vector nrings nil))) - ;; construct the ring list - (let ((i 0)) - (while (< i nrings) - ;; ring: [pole-number string empty-string] - (aset rings i (vector nil - (make-string (+ i i 3) (+ ?0 (% i 10))) - (make-string (+ i i 3) ?\ ))) - (setq i (1+ i)))) - ;; - ;; init the screen - ;; - (switch-to-buffer "*Hanoi*") - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (let ((i 0)) - (while (< i floor-row) - (setq i (1+ i)) - (insert-char ?\ (1- window-width)) - (insert ?\n))) - (insert-char ?= (1- window-width)) - - (let ((n 1)) - (while (< n 6) - (hanoi-topos fly-row (1- (* n pole-spacing))) - (setq n (+ n 2)) - (let ((i fly-row)) - (while (< i floor-row) - (setq i (1+ i)) - (next-line 1) - (insert ?\|) - (delete-char 1) - (backward-char 1))))) - ;(sit-for 0) - ;; - ;; now draw the rings in their initial positions - ;; - (let ((i 0) - ring) - (while (< i nrings) - (setq ring (aref rings (- nrings 1 i))) - (aset ring 0 (- floor-row i)) - (hanoi-topos (cdr pole-1) - (- (car pole-1) (- nrings i))) - (hanoi-draw-ring ring t nil) - (setcdr pole-1 (1- (cdr pole-1))) - (setq i (1+ i)))) - (setq buffer-read-only t) - (sit-for 0) - ;; Disable display of line and column numbers, for speed. - (let ((line-number-mode nil) - (column-number-mode nil)) - ;; do it! - (hanoi0 (1- nrings) pole-1 pole-2 pole-3)) - (goto-char (point-min)) - (message "Done") - (setq buffer-read-only t) - (force-mode-line-update) - (sit-for 0)))) - -;;; -;;; hanoi0 - work horse of hanoi -;;; -(defun hanoi0 (n from to work) - (cond ((input-pending-p) - (signal 'quit (list "I can tell you've had enough"))) - ((< n 0)) - (t - (hanoi0 (1- n) from work to) - (hanoi-move-ring n from to) - (hanoi0 (1- n) work to from)))) - -;;; -;;; hanoi-move-ring - move ring 'n' from 'from' to 'to' -;;; -;;; -(defun hanoi-move-ring (n from to) - (let ((ring (aref rings n)) ; ring <- ring: (ring# . row) - (buffer-read-only nil)) - (let ((row (aref ring 0)) ; row <- row ring is on - (col (- (car from) n 1)) ; col <- left edge of ring - (dst-col (- (car to) n 1)) ; dst-col <- dest col for left edge - (dst-row (cdr to))) ; dst-row <- dest row for ring - (hanoi-topos row col) - (while (> row fly-row) ; move up to the fly row - (hanoi-draw-ring ring nil t) ; blank out ring - (previous-line 1) ; move up a line - (hanoi-draw-ring ring t nil) ; redraw - (sit-for 0) - (setq row (1- row))) - (setcdr from (1+ (cdr from))) ; adjust top row - ;; - ;; fly the ring over to the right pole - ;; - (while (not (equal dst-col col)) - (cond ((> dst-col col) ; dst-col > col: right shift - (end-of-line 1) - (delete-backward-char 2) - (beginning-of-line 1) - (insert ?\ ?\ ) - (sit-for 0) - (setq col (1+ (1+ col)))) - ((< dst-col col) ; dst-col < col: left shift - (beginning-of-line 1) - (delete-char 2) - (end-of-line 1) - (insert ?\ ?\ ) - (sit-for 0) - (setq col (1- (1- col)))))) - ;; - ;; let the ring float down - ;; - (hanoi-topos fly-row dst-col) - (while (< row dst-row) ; move down to the dest row - (hanoi-draw-ring ring nil (> row fly-row)) ; blank out ring - (next-line 1) ; move down a line - (hanoi-draw-ring ring t nil) ; redraw ring - (sit-for 0) - (setq row (1+ row))) - (aset ring 0 dst-row) - (setcdr to (1- (cdr to)))))) ; adjust top row - -;;; -;;; draw-ring - draw the ring at point, leave point unchanged -;;; -;;; Input: -;;; ring -;;; f1 - flag: t -> draw, nil -> erase -;;; f2 - flag: t -> erasing and need to draw ?\| -;;; -(defun hanoi-draw-ring (ring f1 f2) - (save-excursion - (let* ((string (if f1 (aref ring 1) (aref ring 2))) - (len (length string))) - (delete-char len) - (insert string) - (if f2 - (progn - (backward-char (/ (+ len 1) 2)) - (delete-char 1) (insert ?\|)))))) - -(provide 'hanoi) - -;;; hanoi.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/life.el --- a/lisp/games/life.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,288 +0,0 @@ -;;; life.el --- John Horton Conway's `Life' game for GNU Emacs - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Kyle Jones -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; A demonstrator for John Horton Conway's "Life" cellular automaton -;; in Emacs Lisp. Picks a random one of a set of interesting Life -;; patterns and evolves it according to the familiar rules. - -;;; Code: - -(defconst life-patterns - [("@@@" " @@" "@@@") - ("@@@ @@@" "@@ @@ " "@@@ @@@") - ("@@@ @@@" "@@ @@" "@@@ @@@") - ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@") - ("@@@@@@@@@@") - (" @@@@@@@@@@ " - " @@@@@@@@@@ " - " @@@@@@@@@@ " - "@@@@@@@@@@ " - "@@@@@@@@@@ ") - ("@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@") - ("@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @") - ("@@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@") - ("@@@@@@@@@" "@ @ @" "@ @@@@@ @" "@ @ @ @" "@@@ @@@" - "@ @ @ @" "@ @@@@@ @" "@ @ @" "@@@@@@@@@")] - "Vector of rectangles containing some Life startup patterns.") - -;; Macros are used macros for manifest constants instead of variables -;; because the compiler will convert them to constants, which should -;; eval faster than symbols. -;; -;; Don't change any of the life-* macro constants unless you thoroughly -;; understand the `life-grim-reaper' function. - -(defmacro life-life-char () ?@) -(defmacro life-death-char () (1+ (life-life-char))) -(defmacro life-birth-char () 3) -(defmacro life-void-char () ?\ ) - -(defmacro life-life-string () (char-to-string (life-life-char))) -(defmacro life-death-string () (char-to-string (life-death-char))) -(defmacro life-birth-string () (char-to-string (life-birth-char))) -(defmacro life-void-string () (char-to-string (life-void-char))) -(defmacro life-not-void-regexp () (concat "[^" (life-void-string) "\n]")) - -(defmacro life-increment (variable) (list 'setq variable (list '1+ variable))) - - -;; list of numbers that tell how many characters to move to get to -;; each of a cell's eight neighbors. -(defconst life-neighbor-deltas nil) - -;; window display always starts here. Easier to deal with than -;; (scroll-up) and (scroll-down) when trying to center the display. -(defconst life-window-start nil) - -;; For mode line -(defconst life-current-generation nil) -;; Sadly, mode-line-format won't display numbers. -(defconst life-generation-string nil) - -(defvar life-initialized nil - "Non-nil if `life' has been run at least once.") - -;;;###autoload -(defun life (&optional sleeptime) - "Run Conway's Life simulation. -The starting pattern is randomly selected. Prefix arg (optional first -arg non-nil from a program) is the number of seconds to sleep between -generations (this defaults to 1)." - (interactive "p") - (or life-initialized - (random t)) - (setq life-initialized t) - (or sleeptime (setq sleeptime 1)) - (life-setup) - (life-display-generation sleeptime) - (catch 'life-exit - (while t - (let ((inhibit-quit t)) - (life-grim-reaper) - (life-expand-plane-if-needed) - (life-increment-generation) - (life-display-generation sleeptime))))) - -(defalias 'life-mode 'life) -(put 'life-mode 'mode-class 'special) - -(defun life-setup () - (let (n) - (switch-to-buffer (get-buffer-create "*Life*") t) - (erase-buffer) - (kill-all-local-variables) - ;; XEmacs change: - (set-specifier scrollbar-height 0 (current-buffer)) - (set-specifier scrollbar-width 0 (current-buffer)) - (setq case-fold-search nil - mode-name "Life" - major-mode 'life-mode - truncate-lines t - life-current-generation 0 - life-generation-string "0" - mode-line-buffer-identification '("Life: generation " - life-generation-string) - fill-column (1- (window-width)) - life-window-start 1) - (buffer-disable-undo (current-buffer)) - ;; stuff in the random pattern - (life-insert-random-pattern) - ;; make sure (life-life-char) is used throughout - (goto-char (point-min)) - (while (re-search-forward (life-not-void-regexp) nil t) - (replace-match (life-life-string) t t)) - ;; center the pattern horizontally - (goto-char (point-min)) - (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2)) - (while (not (eobp)) - (indent-to n) - (forward-line)) - ;; center the pattern vertically - (setq n (/ (- (1- (window-height)) - (count-lines (point-min) (point-max))) - 2)) - (goto-char (point-min)) - (newline n) - (goto-char (point-max)) - (newline n) - ;; pad lines out to fill-column - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (indent-to fill-column) - (move-to-column fill-column) - (delete-region (point) (progn (end-of-line) (point))) - (forward-line)) - ;; expand tabs to spaces - (untabify (point-min) (point-max)) - ;; before starting be sure the automaton has room to grow - (life-expand-plane-if-needed) - ;; compute initial neighbor deltas - (life-compute-neighbor-deltas))) - -(defun life-compute-neighbor-deltas () - (setq life-neighbor-deltas - (list -1 (- fill-column) - (- (1+ fill-column)) (- (+ 2 fill-column)) - 1 fill-column (1+ fill-column) - (+ 2 fill-column)))) - -(defun life-insert-random-pattern () - (insert-rectangle - (elt life-patterns (random (length life-patterns)))) - (insert ?\n)) - -(defun life-increment-generation () - (life-increment life-current-generation) - (setq life-generation-string (int-to-string life-current-generation))) - -(defun life-grim-reaper () - ;; Clear the match information. Later we check to see if it - ;; is still clear, if so then all the cells have died. - (store-match-data nil) - (goto-char (point-min)) - ;; For speed declare all local variable outside the loop. - (let (point char pivot living-neighbors list) - (while (search-forward (life-life-string) nil t) - (setq list life-neighbor-deltas - living-neighbors 0 - pivot (1- (point))) - (while list - (setq point (+ pivot (car list)) - char (char-after point)) - (cond ((eq char (life-void-char)) - (subst-char-in-region point (1+ point) - (life-void-char) 1 t)) - ((< char 3) - (subst-char-in-region point (1+ point) char (1+ char) t)) - ((< char 9) - (subst-char-in-region point (1+ point) char 9 t)) - ((>= char (life-life-char)) - (life-increment living-neighbors))) - (setq list (cdr list))) - (if (memq living-neighbors '(2 3)) - () - (subst-char-in-region pivot (1+ pivot) - (life-life-char) (life-death-char) t)))) - (if (null (match-beginning 0)) - (life-extinct-quit)) - (subst-char-in-region 1 (point-max) 9 (life-void-char) t) - (subst-char-in-region 1 (point-max) 1 (life-void-char) t) - (subst-char-in-region 1 (point-max) 2 (life-void-char) t) - (subst-char-in-region 1 (point-max) (life-birth-char) (life-life-char) t) - (subst-char-in-region 1 (point-max) (life-death-char) (life-void-char) t)) - -(defun life-expand-plane-if-needed () - (catch 'done - (goto-char (point-min)) - (while (not (eobp)) - ;; check for life at beginning or end of line. If found at - ;; either end, expand at both ends, - (cond ((or (eq (following-char) (life-life-char)) - (eq (progn (end-of-line) (preceding-char)) (life-life-char))) - (goto-char (point-min)) - (while (not (eobp)) - (insert (life-void-char)) - (end-of-line) - (insert (life-void-char)) - (forward-char)) - (setq fill-column (+ 2 fill-column)) - (scroll-left 1) - (life-compute-neighbor-deltas) - (throw 'done t))) - (forward-line))) - (goto-char (point-min)) - ;; check for life within the first two lines of the buffer. - ;; If present insert two lifeless lines at the beginning.. - (cond ((search-forward (life-life-string) - (+ (point) fill-column fill-column 2) t) - (goto-char (point-min)) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (setq life-window-start (+ life-window-start fill-column 1)))) - (goto-char (point-max)) - ;; check for life within the last two lines of the buffer. - ;; If present insert two lifeless lines at the end. - (cond ((search-backward (life-life-string) - (- (point) fill-column fill-column 2) t) - (goto-char (point-max)) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (setq life-window-start (+ life-window-start fill-column 1))))) - -(defun life-display-generation (sleeptime) - (goto-char life-window-start) - (recenter 0) - - ;; Redisplay; if the user has hit a key, exit the loop. - (or (eq t (sit-for sleeptime)) - (throw 'life-exit nil))) - -(defun life-extinct-quit () - (life-display-generation 0) - (signal 'life-extinct nil)) - -;; XEmacs change -(define-error 'life-extinct "All life has perished" 'quit) - -(provide 'life) - -;;; life.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/mpuz.el --- a/lisp/games/mpuz.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,445 +0,0 @@ -;;; mpuz.el --- multiplication puzzle for XEmacs - -;; Copyright (C) 1990 Free Software Foundation, Inc. - -;; Author: Philippe Schnoebelen -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; When this package is loaded, `M-x mpuz' generates a random multiplication -;; puzzle. This is a multiplication example in which each digit has been -;; consistently replaced with some letter. Your job is to reconstruct -;; the original digits. Type `?' while the mode is active for detailed help. - -;;; Code: - -(random t) ; randomize - -(defvar mpuz-silent nil - "*Set this to T if you don't want dings on inputs.") - -(defun mpuz-ding () - "Dings, unless global variable `mpuz-silent' forbids it." - (or mpuz-silent (ding t))) - - -;; Mpuz mode and keymaps -;;---------------------- -(defvar mpuz-mode-hook nil) - -(defvar mpuz-mode-map nil - "Local keymap to use in Mult Puzzle.") - -(if mpuz-mode-map nil - (setq mpuz-mode-map (make-sparse-keymap)) - (define-key mpuz-mode-map "a" 'mpuz-try-letter) - (define-key mpuz-mode-map "b" 'mpuz-try-letter) - (define-key mpuz-mode-map "c" 'mpuz-try-letter) - (define-key mpuz-mode-map "d" 'mpuz-try-letter) - (define-key mpuz-mode-map "e" 'mpuz-try-letter) - (define-key mpuz-mode-map "f" 'mpuz-try-letter) - (define-key mpuz-mode-map "g" 'mpuz-try-letter) - (define-key mpuz-mode-map "h" 'mpuz-try-letter) - (define-key mpuz-mode-map "i" 'mpuz-try-letter) - (define-key mpuz-mode-map "j" 'mpuz-try-letter) - (define-key mpuz-mode-map "A" 'mpuz-try-letter) - (define-key mpuz-mode-map "B" 'mpuz-try-letter) - (define-key mpuz-mode-map "C" 'mpuz-try-letter) - (define-key mpuz-mode-map "D" 'mpuz-try-letter) - (define-key mpuz-mode-map "E" 'mpuz-try-letter) - (define-key mpuz-mode-map "F" 'mpuz-try-letter) - (define-key mpuz-mode-map "G" 'mpuz-try-letter) - (define-key mpuz-mode-map "H" 'mpuz-try-letter) - (define-key mpuz-mode-map "I" 'mpuz-try-letter) - (define-key mpuz-mode-map "J" 'mpuz-try-letter) - (define-key mpuz-mode-map "\C-g" 'mpuz-offer-abort) - (define-key mpuz-mode-map "?" 'describe-mode)) - -(defun mpuz-mode () - "Multiplication puzzle mode. - -You have to guess which letters stand for which digits in the -multiplication displayed inside the `*Mult Puzzle*' buffer. - -You may enter a guess for a letter's value by typing first the letter, -then the digit. Thus, to guess that A=3, type A 3. - -To leave the game to do other editing work, just switch buffers. -Then you may resume the game with M-x mpuz. -You may abort a game by typing \\\\[mpuz-offer-abort]." - (interactive) - (setq major-mode 'mpuz-mode - mode-name "Mult Puzzle") - (use-local-map mpuz-mode-map) - (run-hooks 'mpuz-mode-hook)) - - -;; Some variables for statistics -;;------------------------------ -(defvar mpuz-nb-errors 0 - "Number of errors made in current game.") - -(defvar mpuz-nb-completed-games 0 - "Number of games completed.") - -(defvar mpuz-nb-cumulated-errors 0 - "Number of errors made in previous games.") - - -;; Some variables for game tracking -;;--------------------------------- -(defvar mpuz-in-progress nil - "True if a game is currently in progress.") - -(defvar mpuz-found-digits (make-vector 10 nil) - "A vector recording which digits have been decrypted.") - -(defmacro mpuz-digit-solved-p (digit) - (list 'aref 'mpuz-found-digits digit)) - - -;; A puzzle uses a permutation of [0..9] into itself. -;; We use both the permutation and its inverse. -;;--------------------------------------------------- -(defvar mpuz-digit-to-letter (make-vector 10 0) - "A permutation from [0..9] to [0..9].") - -(defvar mpuz-letter-to-digit (make-vector 10 0) - "The inverse of mpuz-digit-to-letter.") - -(defmacro mpuz-to-digit (letter) - (list 'aref 'mpuz-letter-to-digit letter)) - -(defmacro mpuz-to-letter (digit) - (list 'aref 'mpuz-digit-to-letter digit)) - -(defun mpuz-build-random-perm () - "Initialize puzzle coding with a random permutation." - (let ((letters (list 0 1 2 3 4 5 6 7 8 9)) ; new cons cells, because of delq - (index 10) - elem) - (while letters - (setq elem (nth (random index) letters) - letters (delq elem letters) - index (1- index)) - (aset mpuz-digit-to-letter index elem) - (aset mpuz-letter-to-digit elem index)))) - - -;; A puzzle also uses a board displaying a multiplication. -;; Every digit appears in the board, crypted or not. -;;------------------------------------------------------ -(defvar mpuz-board (make-vector 10 nil) - "The board associates to any digit the list of squares where it appears.") - -(defun mpuz-put-digit-on-board (number square) - "Put (last digit of) NUMBER on SQUARE of the puzzle board." - ;; i.e. push SQUARE on NUMBER square-list - (setq number (% number 10)) - (aset mpuz-board number (cons square (aref mpuz-board number)))) - -(defun mpuz-check-all-solved () - "Check whether all digits have been solved. Return t if yes." - (catch 'found - (let ((digit -1)) - (while (> 10 (setq digit (1+ digit))) - (if (and (not (mpuz-digit-solved-p digit)) ; unsolved - (aref mpuz-board digit)) ; and appearing in the puzzle ! - (throw 'found nil)))) - t)) - - -;; To build a puzzle, we take two random numbers and multiply them. -;; We also take a random permutation for encryption. -;; The random numbers are only use to see which digit appears in which square -;; of the board. Everything is stored in individual squares. -;;--------------------------------------------------------------------------- -(defun mpuz-random-puzzle () - "Draw random values to be multiplied in a puzzle." - (mpuz-build-random-perm) - (fillarray mpuz-board nil) ; erase the board - (let (A B C D E) - ;; A,B,C,D & E, are the five rows of our multiplication. - ;; Choose random values, discarding uninteresting cases. - (while (progn - (setq A (random 1000) - B (random 100) - C (* A (% B 10)) - D (* A (/ B 10)) - E (* A B)) - (or (< C 1000) (< D 1000)))) ; forbid leading zeros in C or D - ;; Individual digits are now put on their respective squares. - ;; [NB: A square is a pair of the screen.] - (mpuz-put-digit-on-board A '(2 . 9)) - (mpuz-put-digit-on-board (/ A 10) '(2 . 7)) - (mpuz-put-digit-on-board (/ A 100) '(2 . 5)) - (mpuz-put-digit-on-board B '(4 . 9)) - (mpuz-put-digit-on-board (/ B 10) '(4 . 7)) - (mpuz-put-digit-on-board C '(6 . 9)) - (mpuz-put-digit-on-board (/ C 10) '(6 . 7)) - (mpuz-put-digit-on-board (/ C 100) '(6 . 5)) - (mpuz-put-digit-on-board (/ C 1000) '(6 . 3)) - (mpuz-put-digit-on-board D '(8 . 7)) - (mpuz-put-digit-on-board (/ D 10) '(8 . 5)) - (mpuz-put-digit-on-board (/ D 100) '(8 . 3)) - (mpuz-put-digit-on-board (/ D 1000) '(8 . 1)) - (mpuz-put-digit-on-board E '(10 . 9)) - (mpuz-put-digit-on-board (/ E 10) '(10 . 7)) - (mpuz-put-digit-on-board (/ E 100) '(10 . 5)) - (mpuz-put-digit-on-board (/ E 1000) '(10 . 3)) - (mpuz-put-digit-on-board (/ E 10000) '(10 . 1)))) - -;; Display -;;-------- -(defconst mpuz-framework - " - . . . - Number of errors (this game): 0 - x . . - ------- - . . . . - Number of completed games: 0 - . . . . - --------- Average number of errors: 0.00 - . . . . ." - "The general picture of the puzzle screen, as a string.") - -(defun mpuz-create-buffer () - "Create (or recreate) the puzzle buffer. Return it." - (let ((buff (get-buffer-create "*Mult Puzzle*"))) - (save-excursion - (set-buffer buff) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert mpuz-framework) - (mpuz-paint-board) - (mpuz-paint-errors) - (mpuz-paint-statistics))) - buff)) - -(defun mpuz-paint-errors () - "Paint error count on the puzzle screen." - (mpuz-switch-to-window) - (let ((buffer-read-only nil)) - (goto-line 3) - (move-to-column 49) - (mpuz-delete-line) - (insert (prin1-to-string mpuz-nb-errors)))) - -(defun mpuz-paint-statistics () - "Paint statistics about previous games on the puzzle screen." - (let* ((mean (if (zerop mpuz-nb-completed-games) 0 - (/ (+ mpuz-nb-completed-games (* 200 mpuz-nb-cumulated-errors)) - (* 2 mpuz-nb-completed-games)))) - (frac-part (% mean 100))) - (let ((buffer-read-only nil)) - (goto-line 7) - (move-to-column 51) - (mpuz-delete-line) - (insert (prin1-to-string mpuz-nb-completed-games)) - (goto-line 9) - (move-to-column 50) - (mpuz-delete-line) - (insert (format "%d.%d%d" (/ mean 100) (/ frac-part 10) (% frac-part 10)))))) - -(defun mpuz-paint-board () - "Paint board situation on the puzzle screen." - (mpuz-switch-to-window) - (let ((letter -1)) - (while (> 10 (setq letter (1+ letter))) - (mpuz-paint-digit (mpuz-to-digit letter)))) - (goto-char (point-min))) - -(defun mpuz-paint-digit (digit) - "Paint all occurrences of DIGIT on the puzzle board." - ;; (mpuz-switch-to-window) - (let ((char (if (mpuz-digit-solved-p digit) - (+ digit ?0) - (+ (mpuz-to-letter digit) ?A))) - (square-l (aref mpuz-board digit))) - (let ((buffer-read-only nil)) - (while square-l - (goto-line (car (car square-l))) ; line before column ! - (move-to-column (cdr (car square-l))) - (insert char) - (delete-char 1) - (backward-char 1) - (setq square-l (cdr square-l)))))) - -(defun mpuz-delete-line () - "Clear from point to next newline." ; & put nothing in the kill ring - (while (not (= ?\n (char-after (point)))) - (delete-char 1))) - -(defun mpuz-get-buffer () - "Get the puzzle buffer if it exists." - (get-buffer "*Mult Puzzle*")) - -(defun mpuz-switch-to-window () - "Find or create the Mult-Puzzle buffer, and display it." - (let ((buff (mpuz-get-buffer))) - (or buff (setq buff (mpuz-create-buffer))) - (switch-to-buffer buff) - (or buffer-read-only (toggle-read-only)) - (mpuz-mode))) - - -;; Game control -;;------------- -(defun mpuz-abort-game () - "Abort any puzzle in progress." - (message "Mult Puzzle aborted.") - (setq mpuz-in-progress nil - mpuz-nb-errors 0) - (fillarray mpuz-board nil) - (let ((buff (mpuz-get-buffer))) - (if buff (kill-buffer buff)))) - -(defun mpuz-start-new-game () - "Start a new puzzle." - (message "Here we go...") - (setq mpuz-nb-errors 0 - mpuz-in-progress t) - (fillarray mpuz-found-digits nil) ; initialize mpuz-found-digits - (mpuz-random-puzzle) - (mpuz-switch-to-window) - (mpuz-paint-board) - (mpuz-paint-errors) - (mpuz-ask-for-try)) - -(defun mpuz-offer-new-game () - "Ask if user wants to start a new puzzle." - (if (y-or-n-p "Start a new game ") - (mpuz-start-new-game) - (message "OK. I won't."))) - -;;;###autoload -(defun mpuz () - "Multiplication puzzle with GNU Emacs." - ;; Main entry point - (interactive) - (mpuz-switch-to-window) - (if mpuz-in-progress - (mpuz-offer-abort) - (mpuz-start-new-game))) - -(defun mpuz-offer-abort () - "Ask if user wants to abort current puzzle." - (interactive) - (if (y-or-n-p "Abort game ") - (mpuz-abort-game) - (mpuz-ask-for-try))) - -(defun mpuz-ask-for-try () - "Ask for user proposal in puzzle." - (message "Your try ?")) - -(defun mpuz-try-letter () - "Propose a digit for a letter in puzzle." - (interactive) - (if mpuz-in-progress - (let (letter-char digit digit-char message) - (setq letter-char (upcase last-command-char) - digit (mpuz-to-digit (- letter-char ?A))) - (cond ((mpuz-digit-solved-p digit) - (message "%c already solved." letter-char)) - ((null (aref mpuz-board digit)) - (message "%c does not appear." letter-char)) - ((progn (message "%c = " letter-char) - ;; has been entered. - ;; Print " =" and - ;; read or = - (setq digit-char (read-char)) - (if (eq digit-char ?=) - (setq digit-char (read-char))) - (message "%c = %c" letter-char digit-char) - (or (> digit-char ?9) (< digit-char ?0))) ; bad input - (ding t)) - (t - (mpuz-try-proposal letter-char digit-char)))) - (mpuz-offer-new-game))) - -(defun mpuz-try-proposal (letter-char digit-char) - "Propose LETTER-CHAR as code for DIGIT-CHAR." - (let* ((letter (- letter-char ?A)) - (digit (- digit-char ?0)) - (correct-digit (mpuz-to-digit letter))) - (cond ((mpuz-digit-solved-p correct-digit) - (message "%c has already been found.")) - ((= digit correct-digit) - (message "%c = %c correct !" letter-char digit-char) - (mpuz-ding) - (mpuz-correct-guess digit)) - (t ;;; incorrect guess - (message "%c = %c incorrect !" letter-char digit-char) - (mpuz-ding) - (setq mpuz-nb-errors (1+ mpuz-nb-errors)) - (mpuz-paint-errors))))) - -(defun mpuz-correct-guess (digit) - "Handle correct guessing of DIGIT." - (aset mpuz-found-digits digit t) ; Mark digit as solved - (mpuz-paint-digit digit) ; Repaint it (now as a digit) - (if (mpuz-check-all-solved) - (mpuz-close-game))) - -(defun mpuz-close-game () - "Housecleaning when puzzle has been solved." - (setq mpuz-in-progress nil - mpuz-nb-cumulated-errors (+ mpuz-nb-cumulated-errors mpuz-nb-errors) - mpuz-nb-completed-games (1+ mpuz-nb-completed-games)) - (mpuz-paint-statistics) - (let ((message (mpuz-congratulate))) - (message message) - (sit-for 4) - (if (y-or-n-p (concat message " Start a new game ")) - (mpuz-start-new-game) - (message "Good Bye !")))) - -(defun mpuz-congratulate () - "Build a congratulation message when puzzle is solved." - (format "Puzzle solved with %d errors. %s" - mpuz-nb-errors - (cond ((= mpuz-nb-errors 0) "That's perfect !") - ((= mpuz-nb-errors 1) "That's very good !") - ((= mpuz-nb-errors 2) "That's good.") - ((= mpuz-nb-errors 3) "That's not bad.") - ((= mpuz-nb-errors 4) "That's not too bad...") - ((and (>= mpuz-nb-errors 5) - (< mpuz-nb-errors 10)) "That's bad !") - ((and (>= mpuz-nb-errors 10) - (< mpuz-nb-errors 15)) "That's awful.") - ((>= mpuz-nb-errors 15) "That's not serious.")))) - -(defun mpuz-show-solution () - "Display solution for debugging purposes." - (interactive) - (mpuz-switch-to-window) - (let (digit list) - (setq digit -1) - (while (> 10 (setq digit (1+ digit))) - (or (mpuz-digit-solved-p digit) - (setq list (cons digit list)))) - (mapcar 'mpuz-correct-guess list))) - -;;; mpuz.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/spook.el --- a/lisp/games/spook.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -;;; spook.el --- spook phrase utility for overloading the NSA line eater - -;; Copyright (C) 1988, 1993 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games -;; Created: May 1987 - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Steve Strassmann didn't write -;; this, and even if he did, he really didn't mean for you to use it -;; in an anarchistic way. -;; -;; To use this: -;; Just before sending mail, do M-x spook. -;; A number of phrases will be inserted into your buffer, to help -;; give your message that extra bit of attractiveness for automated -;; keyword scanners. - -;;; Code: - -(require 'cookie1) - -; Variables -(defvar spook-phrases-file (concat data-directory "spook.lines") - "Keep your favorite phrases here.") - -(defvar spook-phrase-default-count 15 - "Default number of phrases to insert") - -;;;###autoload -(defun spook () - "Adds that special touch of class to your outgoing mail." - (interactive) - (cookie-insert spook-phrases-file - spook-phrase-default-count - "Checking authorization..." - "Checking authorization...Approved")) - -;;;###autoload -(defun snarf-spooks () - "Return a vector containing the lines from `spook-phrases-file'." - (cookie-snarf spook-phrases-file - "Checking authorization..." - "Checking authorization...Approved")) - -;; Note: the implementation that used to take up most of this file has been -;; cleaned up, generalized, gratuitously broken by esr, and now resides in -;; cookie1.el. - -;;; spook.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/studly.el --- a/lisp/games/studly.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -;;; studly.el --- StudlyCaps (tm)(r)(c)(xxx) - -;; This is in the public domain, since it was distributed -;; by its author without a copyright notice in 1986. - -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not in FSF - -;;; Commentary: - -;; Functions to studlycapsify a region, word, or buffer. Possibly the -;; esoteric significance of studlycapsification escapes you; that is, -;; you suffer from autostudlycapsifibogotification. Too bad. - -;;; Code: - -(defun studlify-region (begin end) - "Studlify-case the region" - (interactive "*r") - (save-excursion - (goto-char begin) - (setq begin (point)) - (while (and (<= (point) end) - (not (looking-at "\\W*\\'"))) - (forward-word 1) - (backward-word 1) - (setq begin (max (point) begin)) - (forward-word 1) - (let ((offset 0) - (word-end (min (point) end)) - c) - (goto-char begin) - (while (< (point) word-end) - (setq offset (+ offset (following-char))) - (forward-char 1)) - (setq offset (+ offset (following-char))) - (goto-char begin) - (while (< (point) word-end) - (setq c (following-char)) - (if (and (= (% (+ c offset) 4) 2) - (let ((ch (following-char))) - (or (and (>= ch ?a) (<= ch ?z)) - (and (>= ch ?A) (<= ch ?Z))))) - (progn - (delete-char 1) - (insert (logxor c ? )))) - (forward-char 1)) - (setq begin (point)))))) - -(defun studlify-word (count) - "Studlify-case the current word, or COUNT words if given an argument" - (interactive "*p") - (let ((begin (point)) end rb re) - (forward-word count) - (setq end (point)) - (setq rb (min begin end) re (max begin end)) - (studlify-region rb re))) - -(defun studlify-buffer () - "Studlify-case the current buffer" - (interactive "*") - (studlify-region (point-min) (point-max))) - -;;; studly.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/tetris.el --- a/lisp/games/tetris.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,840 +0,0 @@ -;;; tetris.el -- Implementation of Tetris for Emacs. - -;; Copyright (C) 1997 Glynn Clements - -;; Author: Glynn Clements -;; Version: 1.8 -;; Created: 1997-08-13 -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not synched. - -;;; Commentary: - -;; Modified: 1997-08-17, added tetris-move-bottom -;; Modified: 1997-08-22, changed setting of display table for compatibility -;; with XEmacs 19.15 -;; Modified: 1997-08-23, changed setting of display table for TTY compatibility -;; Modified: 1997-08-24, various changes for FSF Emacs compatibility -;; Modified: 1997-08-25 -;; modified existing docstrings, added new docstrings -;; L now rotates the same way as T and mirror-L -;; now adds tetris-end-game to buffer-local value of kill-buffer-hook -;; Modified: 1997-08-26, miscellaneous bugfixes -;; Modified: 1997-08-27 -;; added color support for non-glyph mode -;; added tetris-mode-hook -;; added tetris-update-speed-function -;; Modified: 1997-09-09, changed layout to work in a 22 line window -;; Modified: 1997-09-12 -;; fixed tetris-shift-down to deal with multiple rows correctly -;; Modified: 1997-09-14, added tetris-setup-default-face -;; URL: ftp://sensei.co.uk/misc/tetris.el.gz -;; Tested with XEmacs 20.3-beta and Emacs 19.34 -;; Reported to work with XEmacs 19.15 and 20.2 - -(eval-when-compile - (require 'cl)) - -;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar tetris-use-glyphs t - "Non-nil means use glyphs when available") - -(defvar tetris-use-color t - "Non-nil means use color when available") - -(defvar tetris-draw-border-with-glyphs t - "Non-nil means draw a border even when using glyphs") - -(defvar tetris-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*" - "Name of the font used for tetris in X mode") - -(defvar tetris-default-tick-period 0.3 - "The default time taken for a shape to drop one row") - -(defvar tetris-update-speed-function - 'tetris-default-update-speed-function - "Function run whenever the Tetris score changes -Called with two arguments: (SHAPES ROWS) -SHAPES is the number of shapes which have been dropped -ROWS is the number of rows which have been completed - -If the return value is a number, it is used as the timer period") - -(defvar tetris-mode-hook nil - "Hook run upon starting Tetris") - -;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst tetris-buffer-name "*Tetris*" - "Name used for Tetris buffer") - -(defconst tetris-space-char [?\040] - "Character vector used for a space") - -(defconst tetris-block-char [?\040] - "Character vector for a full square in text mode") - -(defconst tetris-emacs-block-char [?O] - "Character vector for a full square in text mode under Emacs") - -(defconst tetris-border-char [?\+] - "Character vector for a border square in text mode") - -(defconst tetris-buffer-width 30 - "Width of used portion of buffer") - -(defconst tetris-buffer-height 22 - "Height of used portion of buffer") - -(defconst tetris-width 10 - "Width of playing area") - -(defconst tetris-height 20 - "Height of playing area") - -(defconst tetris-top-left-x 3 - "X position of top left of playing area") - -(defconst tetris-top-left-y 1 - "Y position of top left of playing area") - -(defconst tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width) - "X position of next shape") - -(defconst tetris-next-y tetris-top-left-y - "Y position of next shape") - -(defconst tetris-score-x tetris-next-x - "X position of score") - -(defconst tetris-score-y (+ tetris-next-y 6) - "Y position of score") - -(defconst tetris-blank 0) - -(defconst tetris-space ?\.) - -(defconst tetris-border ?\*) - -(defconst tetris-shapes - [[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]] - [[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]] - [[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]] - [[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]] - [[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]] - [[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]] - [[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]] - [[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]] - [[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]] - [[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]] - [[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]] - [[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]] - [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]] - [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]] - [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]]) - -(defconst tetris-shape-dimensions - [[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]]) - -(defconst tetris-text-colors - ["black" "blue" "white" "yellow" - "magenta" "cyan" "green" "red"] - "Vector of colors of the various shapes in text mode -Element 0 is the background color") - -(defconst tetris-colors - [[0 0 0] [0 0 1] [0.7 0 1] [1 1 0] - [1 0 1] [0 1 1] [0 1 0] [1 0 0] - [0.5 0.5 0.5]] - "Vector of colors of the various shapes -Element 0 is the background color -Element 8 is the border color") - -(defconst tetris-xpm "\ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -\"16 16 3 1\", -/* colors */ -\"+ s col1\", -\". s col2\", -\"- s col3\", -/* pixels */ -\"---------------+\", -\"--------------++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"-+++++++++++++++\", -\"++++++++++++++++\" -}; -" - "XPM format image used for each square") - -(defun tetris-default-update-speed-function (shapes rows) - (/ 20.0 (+ 50.0 rows))) - -;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar tetris-faces (make-vector 256 nil)) - -(defvar tetris-buffer-start 1) - -(defvar tetris-display-mode nil) - -(defvar tetris-shape 0) -(defvar tetris-rot 0) -(defvar tetris-next-shape 0) -(defvar tetris-n-shapes 0) -(defvar tetris-n-rows 0) -(defvar tetris-pos-x 0) -(defvar tetris-pos-y 0) - -(defvar tetris-timer nil) - -(defvar tetris-display-table nil) - -;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar tetris-mode-map - (make-sparse-keymap 'tetris-mode-map)) - -(define-key tetris-mode-map "n" 'tetris-start-game) -(define-key tetris-mode-map "q" 'tetris-end-game) - -(define-key tetris-mode-map " " 'tetris-move-bottom) -(define-key tetris-mode-map [left] 'tetris-move-left) -(define-key tetris-mode-map [right] 'tetris-move-right) -(define-key tetris-mode-map [up] 'tetris-rotate-prev) -(define-key tetris-mode-map [down] 'tetris-rotate-next) - -(defvar tetris-null-map - (make-sparse-keymap 'tetris-null-map)) - -(define-key tetris-null-map "n" 'tetris-start-game) - -;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun tetris-start-timer (period) - (setq tetris-timer - (if (featurep 'itimer) - (start-itimer - "Tetris" - 'tetris-update-game period period - nil t (current-buffer)) - (run-with-timer - period period - 'tetris-update-game (current-buffer))))) - -(defun tetris-set-timer (delay) - (if tetris-timer - (if (featurep 'itimer) - (set-itimer-restart tetris-timer delay) - (timer-set-time tetris-timer - (list (aref tetris-timer 1) - (aref tetris-timer 2) - (aref tetris-timer 3)) - delay)))) - -(defun tetris-kill-timer () - (if tetris-timer - (if (featurep 'itimer) - (delete-itimer tetris-timer) - (timer-set-time tetris-timer '(0 0 0) nil))) - (setq tetris-timer nil)) - -;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun tetris-color (col shade) - (let* ((vec (aref tetris-colors col)) - (v (floor (* shade 255))) - (r (* v (aref vec 0))) - (g (* v (aref vec 1))) - (b (* v (aref vec 2)))) - (format "#%02x%02x%02x" r g b))) - -(defun tetris-set-font (face) - (if tetris-font - (condition-case nil - (set-face-font face tetris-font) - ('error nil)))) - -(defun tetris-setup-face (face color) - (set-face-foreground face color) - (set-face-background face color) - (tetris-set-font face) - (condition-case nil - (set-face-background-pixmap face [nothing]) ;; XEmacs - ('error nil)) - (condition-case nil - (set-face-background-pixmap face nil) ;; Emacs - ('error nil))) - -(defun tetris-make-mono-tty-face () - (let ((face (make-face 'tetris-mono-tty-face))) - (condition-case nil - (set-face-property face 'reverse t) - ('error nil)) - face)) - -(defun tetris-make-color-tty-face (c) - (let* ((name (intern (format "tetris-color-tty-face-%d" c))) - (face (make-face name))) - (tetris-setup-face face (aref tetris-text-colors c)) - face)) - -(defun tetris-make-x-border-face () - (let ((face (make-face 'tetris-x-border-face))) - (tetris-set-font face) - face)) - -(defun tetris-make-mono-x-face () - (let ((face (make-face 'tetris-mono-x-face)) - (color (face-foreground 'default))) - (if (null color) - (setq color - (cdr-safe (assq 'foreground-color (frame-parameters))))) - (tetris-setup-face face color) - face)) - -(defun tetris-make-color-x-face (c) - (let* ((name (intern (format "tetris-color-x-face-%d" c))) - (face (make-face name))) - (tetris-setup-face face (tetris-color c 1.0)) - face)) - -(defun tetris-make-mono-tty-faces () - (let ((face (tetris-make-mono-tty-face))) - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((or (= c 0) (> c 7)) - 'default) - (t - face)))))) - -(defun tetris-make-color-tty-faces () - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((> c 7) - 'default) - (t - (tetris-make-color-tty-face c)))))) - -(defun tetris-make-mono-x-faces () - (let ((face (tetris-make-mono-x-face)) - (face2 (tetris-make-x-border-face))) - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((or (= c 0) (= c tetris-border)) - face2) - ((> c 7) - 'default) - (t - face)))))) - -(defun tetris-make-color-x-faces () - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((= c tetris-border) - (tetris-make-x-border-face)) - ((> c 7) - 'default) - (t - (tetris-make-color-x-face c)))))) - -(defun tetris-make-glyph (index) - (make-glyph - (vector - 'xpm - :data tetris-xpm - :color-symbols (list - (cons "col1" (tetris-color index 0.6)) - (cons "col2" (tetris-color index 0.8)) - (cons "col3" (tetris-color index 1.0)))))) - -(defun tetris-make-display-table () - (setq tetris-display-table (make-display-table)) - (aset tetris-display-table tetris-space tetris-space-char) - (case tetris-display-mode - ('glyph - (aset tetris-display-table tetris-border (tetris-make-glyph 8)) - (aset tetris-display-table tetris-blank (tetris-make-glyph 0))) - (otherwise - (aset tetris-display-table tetris-border tetris-border-char) - (aset tetris-display-table tetris-blank tetris-space-char))) - (loop for i from 1 to 7 do - (aset tetris-display-table - (+ tetris-blank i) - (case tetris-display-mode - ('glyph - (tetris-make-glyph i)) - ('emacs-tty - tetris-emacs-block-char) - (otherwise - tetris-block-char))))) - -(defun tetris-color-display-p () - (if (fboundp 'device-class) - (eq (device-class (selected-device)) 'color) - (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color))) - -(defun tetris-display-type () - (cond ((and tetris-use-glyphs (eq window-system 'x) (featurep 'xpm)) - 'glyph) - ((and tetris-use-color (eq window-system 'x) (tetris-color-display-p)) - 'color-x) - ((eq window-system 'x) - 'mono-x) - ((and tetris-use-color (tetris-color-display-p)) - 'color-tty) - (t - (if (fboundp 'set-face-property) - 'mono-tty - 'emacs-tty)))) - -(defun tetris-initialize-display () - (setq tetris-display-mode (tetris-display-type)) - (tetris-make-display-table) - (case tetris-display-mode - ('mono-tty - (tetris-make-mono-tty-faces)) - ('color-tty - (tetris-make-color-tty-faces)) - ('mono-x - (tetris-make-mono-x-faces)) - ('color-x - (tetris-make-color-x-faces)))) - -(defun tetris-set-display-table () - (if (fboundp 'specifierp) - (add-spec-to-specifier current-display-table - tetris-display-table - (current-buffer) - nil 'remove-locale) - (setq buffer-display-table tetris-display-table))) - -(defun tetris-setup-default-face () - (cond ((eq tetris-display-mode 'glyph) - (let* ((font-spec (face-property 'default 'font)) - (name (font-name font-spec)) - (glyph (aref tetris-display-table tetris-blank)) - (height (glyph-height glyph))) - (while (> (font-height font-spec) height) - (setq name (x-find-smaller-font name)) - (add-spec-to-specifier font-spec name (current-buffer))))))) - -(defun tetris-hide-cursor () - (if (fboundp 'specifierp) - (set-specifier text-cursor-visible-p nil (current-buffer)))) - -(defun tetris-draw-border-p () - (or (not (eq tetris-display-mode 'glyph)) - tetris-draw-border-with-glyphs)) - -(defun tetris-set-color (c) - (unless (eq tetris-display-mode 'glyph) - (put-text-property - (1- (point)) (point) 'face (aref tetris-faces c)))) - -;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun tetris-get-tick-period () - (if (boundp 'tetris-update-speed-function) - (let ((period (apply tetris-update-speed-function - tetris-n-shapes - tetris-n-rows nil))) - (and (numberp period) period)))) - -(defun tetris-cell-offset (x y) - (+ tetris-buffer-start - (* (1+ tetris-buffer-width) y) - x)) - -(defun tetris-get-cell (x y) - (char-after (tetris-cell-offset x y))) - -(defun tetris-set-cell (x y c) - (save-excursion - (let ((buffer-read-only nil)) - (goto-char (tetris-cell-offset x y)) - (delete-char 1) - (insert-char c 1) - (tetris-set-color c)))) - -(defun tetris-get-shape-cell (x y) - (aref - (aref - (aref - (aref tetris-shapes tetris-shape) - y) - tetris-rot) - x)) - -(defun tetris-shape-width () - (aref (aref tetris-shape-dimensions tetris-shape) - (% tetris-rot 2))) - -(defun tetris-shape-height () - (aref (aref tetris-shape-dimensions tetris-shape) - (- 1 (% tetris-rot 2)))) - -(defun tetris-draw-score () - (let ((strings (vector - (format "Shapes: %05d" tetris-n-shapes) - (format "Rows: %05d" tetris-n-rows)))) - (loop for y from 0 to 1 do - (let* ((string (aref strings y)) - (len (length string))) - (loop for x from 0 to (1- len) do - (tetris-set-cell - (+ tetris-score-x x) - (+ tetris-score-y y) - (aref string x))))))) - -(defun tetris-update-score () - (tetris-draw-score) - (let ((period (tetris-get-tick-period))) - (if period (tetris-set-timer period)))) - -(defun tetris-new-shape () - (setq tetris-shape tetris-next-shape) - (setq tetris-rot 0) - (setq tetris-next-shape (random 7)) - (setq tetris-pos-x (random (- tetris-width (tetris-shape-width)))) - (setq tetris-pos-y 0) - (setq tetris-n-shapes (1+ tetris-n-shapes)) - (tetris-draw-next-shape) - (tetris-update-score)) - -(defun tetris-draw-next-shape () - (loop for y from 0 to 3 do - (loop for x from 0 to 3 do - (tetris-set-cell - (+ tetris-next-x x) - (+ tetris-next-y y) - (let ((tetris-shape tetris-next-shape) - (tetris-rot 0)) - (tetris-get-shape-cell x y)))))) - -(defun tetris-draw-shape () - (loop for y from 0 to (1- (tetris-shape-height)) do - (loop for x from 0 to (1- (tetris-shape-width)) do - (let ((c (tetris-get-shape-cell x y))) - (if (/= c tetris-blank) - (tetris-set-cell - (+ tetris-top-left-x tetris-pos-x x) - (+ tetris-top-left-y tetris-pos-y y) - c)))))) - -(defun tetris-erase-shape () - (loop for y from 0 to (1- (tetris-shape-height)) do - (loop for x from 0 to (1- (tetris-shape-width)) do - (let ((c (tetris-get-shape-cell x y))) - (if (/= c tetris-blank) - (tetris-set-cell - (+ tetris-top-left-x tetris-pos-x x) - (+ tetris-top-left-y tetris-pos-y y) - tetris-blank)))))) - -(defun tetris-test-shape () - (let ((hit nil)) - (loop for y from 0 to (1- (tetris-shape-height)) do - (loop for x from 0 to (1- (tetris-shape-width)) do - (unless hit - (setq hit - (let ((c (tetris-get-shape-cell x y)) - (xx (+ tetris-pos-x x)) - (yy (+ tetris-pos-y y))) - (and (/= c tetris-blank) - (or (>= xx tetris-width) - (>= yy tetris-height) - (/= (tetris-get-cell - (+ tetris-top-left-x xx) - (+ tetris-top-left-y yy)) - tetris-blank)))))))) - hit)) - -(defun tetris-full-row (y) - (let ((full t)) - (loop for x from 0 to (1- tetris-width) do - (if (= (tetris-get-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y)) - tetris-blank) - (setq full nil))) - full)) - -(defun tetris-shift-row (y) - (loop for x from 0 to (1- tetris-width) do - (let ((c (tetris-get-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y -1)))) - (tetris-set-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - c)))) - -(defun tetris-shift-down () - (loop for y0 from 0 to (1- tetris-height) do - (if (tetris-full-row y0) - (progn - (setq tetris-n-rows (1+ tetris-n-rows)) - (tetris-update-score) - (loop for y from y0 downto 1 do - (tetris-shift-row y)))))) - -(defun tetris-init-buffer () - (let ((line (concat - (make-string tetris-buffer-width tetris-space) - "\n")) - (buffer-read-only nil)) - (erase-buffer) - (setq tetris-buffer-start (point)) - (dotimes (i tetris-buffer-height) - (insert-string line)) - (goto-char (point-min)) - (if (tetris-draw-border-p) - (loop for y from -1 to tetris-height do - (loop for x from -1 to tetris-width do - (tetris-set-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-border)))) - (loop for y from 0 to (1- tetris-height) do - (loop for x from 0 to (1- tetris-width) do - (tetris-set-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-blank))) - (if (tetris-draw-border-p) - (loop for y from -1 to 4 do - (loop for x from -1 to 4 do - (tetris-set-cell - (+ tetris-next-x x) - (+ tetris-next-y y) - tetris-border)))))) - -(defun tetris-reset-game () - (tetris-kill-timer) - (tetris-init-buffer) - (setq tetris-next-shape (random 7)) - (setq tetris-shape 0 - tetris-rot 0 - tetris-n-shapes 0 - tetris-n-rows 0 - tetris-pos-x 0 - tetris-pos-y 0) - (tetris-new-shape) - (tetris-draw-shape)) - -(defun tetris-shape-done () - (tetris-shift-down) - (tetris-new-shape) - (if (tetris-test-shape) - (progn - (tetris-end-game)) - (tetris-draw-shape))) - -(defun tetris-update-game (tetris-buffer) - "Called on each clock tick. -Drops the shape one square, testing for collision." - (if (eq (current-buffer) tetris-buffer) - (let (hit) - (tetris-erase-shape) - (setq tetris-pos-y (1+ tetris-pos-y)) - (setq hit (tetris-test-shape)) - (if hit - (setq tetris-pos-y (1- tetris-pos-y))) - (tetris-draw-shape) - (if hit - (tetris-shape-done))))) - -(defun tetris-move-bottom () - "Drops the shape to the bottom of the playing area" - (interactive) - (let ((hit nil)) - (tetris-erase-shape) - (while (not hit) - (setq tetris-pos-y (1+ tetris-pos-y)) - (setq hit (tetris-test-shape))) - (setq tetris-pos-y (1- tetris-pos-y)) - (tetris-draw-shape) - (tetris-shape-done))) - -(defun tetris-move-left () - "Moves the shape one square to the left" - (interactive) - (unless (= tetris-pos-x 0) - (tetris-erase-shape) - (setq tetris-pos-x (1- tetris-pos-x)) - (if (tetris-test-shape) - (setq tetris-pos-x (1+ tetris-pos-x))) - (tetris-draw-shape))) - -(defun tetris-move-right () - "Moves the shape one square to the right" - (interactive) - (unless (= (+ tetris-pos-x (tetris-shape-width)) - tetris-width) - (tetris-erase-shape) - (setq tetris-pos-x (1+ tetris-pos-x)) - (if (tetris-test-shape) - (setq tetris-pos-x (1- tetris-pos-x))) - (tetris-draw-shape))) - -(defun tetris-rotate-prev () - "Rotates the shape clockwise" - (interactive) - (tetris-erase-shape) - (setq tetris-rot (% (+ 1 tetris-rot) 4)) - (if (tetris-test-shape) - (setq tetris-rot (% (+ 3 tetris-rot) 4))) - (tetris-draw-shape)) - -(defun tetris-rotate-next () - "Rotates the shape anticlockwise" - (interactive) - (tetris-erase-shape) - (setq tetris-rot (% (+ 3 tetris-rot) 4)) - (if (tetris-test-shape) - (setq tetris-rot (% (+ 1 tetris-rot) 4))) - (tetris-draw-shape)) - -(defun tetris-end-game () - "Terminates the current game" - (interactive) - (tetris-kill-timer) - (use-local-map tetris-null-map)) - -(defun tetris-start-game () - "Starts a new game of Tetris" - (interactive) - (tetris-reset-game) - (use-local-map tetris-mode-map) - (let ((period (or (tetris-get-tick-period) - tetris-default-tick-period))) - (tetris-start-timer period))) - -(put 'tetris-mode 'mode-class 'special) - -(defun tetris-mode () - "A mode for playing Tetris. - -tetris-mode keybindings: - \\{tetris-mode-map} -" - (kill-all-local-variables) - - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'tetris-end-game nil t) - - (make-local-variable 'tetris-display-mode) - (make-local-variable 'tetris-display-table) - (make-local-variable 'tetris-faces) - (make-local-variable 'tetris-timer) - (make-local-variable 'tetris-buffer-start) - (make-local-variable 'tetris-shape) - (make-local-variable 'tetris-rot) - (make-local-variable 'tetris-next-shape) - (make-local-variable 'tetris-n-shapes) - (make-local-variable 'tetris-n-rows) - (make-local-variable 'tetris-pos-x) - (make-local-variable 'tetris-pos-y) - - (use-local-map tetris-null-map) - - (setq buffer-read-only t) - (setq truncate-lines 't) - (setq major-mode 'tetris-mode) - (setq mode-name "Tetris") - - (buffer-disable-undo (current-buffer)) - - (tetris-initialize-display) - (tetris-setup-default-face) - (tetris-set-display-table) - (tetris-hide-cursor) - - (run-hooks 'tetris-mode-hook)) - -;;;###autoload -(defun tetris () - "Tetris - -Shapes drop from the top of the screen, and the user has to move and -rotate the shape to fit in with those at the bottom of the screen so -as to form complete rows. - -tetris-mode keybindings: - \\ -\\[tetris-start-game] Starts a new game of Tetris -\\[tetris-end-game] Terminates the current game -\\[tetris-move-left] Moves the shape one square to the left -\\[tetris-move-right] Moves the shape one square to the right -\\[tetris-rotate-prev] Rotates the shape clockwise -\\[tetris-rotate-next] Rotates the shape anticlockwise -\\[tetris-move-bottom] Drops the shape to the bottom of the playing area - -" - (interactive) - - (switch-to-buffer tetris-buffer-name) - (tetris-kill-timer) - (tetris-mode) - (tetris-start-game)) - -(provide 'tetris) - -;;; tetris.el ends here - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/xmine.el --- a/lisp/games/xmine.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,862 +0,0 @@ -;;; xmine.el --- Mine game for XEmacs - -;; Author: Jens Lautenbacher -;; Keywords: games -;; Version: 1.8 - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Commentary: This is a complete reimplementation of the classical -;; mine searching game known from various OS/GUIs under names like -;; xmine, minesweeper etc. - -;; The idea to implement this in elisp is from -;; Jacques Duthen , -;; the author of the original mine game for GNU Emacs. This version -;; has to the best of my knowledge no code in common with his version, -;; but cudos go to him for first starting this... -;; -;; I mainly wrote this as an example how graphics handling in XEmacs -;; is possible. I think I did it the right way, using an extension to -;; the annotation mechanism and via extensive use of `slots' (realized -;; as properties of extents) to hold the data in the object itself. -;; (Of course this is not true. The keyboard handling is controlled from -;; the "outside" of the objects. But at one time during development -;; before hacking the keyboard controls the code really _was_ nice... -;; now it's a bad messing with slots and controls from the outside) -;; -;; Code: -;; -;;; First of all we'll define the needed varibles. - -(defconst xmine-version-number "1.8" "XEmacs Mine version number.") -(defconst xmine-version (format "XEmacs Mine v%s by Jens Lautenbacher © 1997" - xmine-version-number) - "Full XEmacs Mine version number.") - -(defgroup xmine nil - "The well known mine searching game." - :group 'games) - -(defcustom xmine-width 25 - "The width of the mine field" - :group 'xmine - :type 'integer) - -(defcustom xmine-height 20 - "The height of the mine field" - :group 'xmine - :type 'integer) - -(defcustom xmine-glyph-dir (concat data-directory "mine/") - "The directory where the mine glyphs reside" - :group 'xmine - :type 'directory) - -(defface xmine-hidden-face - '((t - (:background "blue"))) - "The face used for hidden tiles on ttys" - :group 'xmine) - -(defface xmine-flagged-face - '((t - (:background "red"))) - "The face used for flagged tiles on ttys" - :group 'xmine) - -(defface xmine-number-face - '((t - (:background "green"))) - "The face used for unhidden, numbered tiles on ttys" - :group 'xmine) - - -(defvar xmine-pad-glyph - (make-glyph - (if (and (eq window-system 'x) (featurep 'xpm)) - (concat xmine-glyph-dir "pad.xpm") - " "))) - -(defvar xmine-title-glyph - (make-glyph - (if (and (eq window-system 'x) (featurep 'xpm)) - (concat xmine-glyph-dir "splash.xpm") - "------------------ XEmacs XMine ------------------"))) - -(defvar xmine-glyph-production-list - '(("xmine-new-up" "new_up.gif" "new" nil) - ("xmine-new-down" "new_down.gif" "NEW" nil) - ("xmine-quit-up" "quit_up.gif" "quit" nil) - ("xmine-quit-down" "quit_down.gif" "QUIT" nil) - ("xmine-up-glyph" "empty_16_up.gif" "@ " xmine-hidden-face) - ("xmine-up-sel-glyph" "empty_16_up_sel.gif" "@<" xmine-hidden-face) - ("xmine-down-glyph" "empty_16_down.gif" "? " nil) - ("xmine-flagged-glyph" "flagged_16_up.gif" "! " xmine-flagged-face) - ("xmine-flagged-sel-glyph" "flagged_16_up_sel.gif" "!<" xmine-flagged-face) - ("xmine-mine-glyph" "bomb_16_flat.gif" "* " nil) - ("xmine-mine-sel-glyph" "bomb_16_flat.gif" "*<" nil) - ("xmine-trapped-glyph" "bomb_trapped_16_flat.gif" "X " nil) - ("xmine-0-glyph" "empty_16_flat.gif" ". " nil) - ("xmine-0-sel-glyph" "empty_16_flat_sel.gif" ".<" nil) - ("xmine-1-glyph" "1_16_flat.gif" "1 " xmine-number-face) - ("xmine-1-sel-glyph" "1_16_flat_sel.gif" "1<" xmine-number-face) - ("xmine-2-glyph" "2_16_flat.gif" "2 " xmine-number-face) - ("xmine-2-sel-glyph" "2_16_flat_sel.gif" "2<" xmine-number-face) - ("xmine-3-glyph" "3_16_flat.gif" "3 " xmine-number-face) - ("xmine-3-sel-glyph" "3_16_flat_sel.gif" "3<" xmine-number-face) - ("xmine-4-glyph" "4_16_flat.gif" "4 " xmine-number-face) - ("xmine-4-sel-glyph" "4_16_flat_sel.gif" "4<" xmine-number-face) - ("xmine-5-glyph" "5_16_flat.gif" "5 " xmine-number-face) - ("xmine-5-sel-glyph" "5_16_flat_sel.gif" "5<" xmine-number-face) - ("xmine-6-glyph" "6_16_flat.gif" "6 " xmine-number-face) - ("xmine-6-sel-glyph" "6_16_flat_sel.gif" "6<" xmine-number-face) - ("xmine-7-glyph" "7_16_flat.gif" "7 " xmine-number-face) - ("xmine-7-sel-glyph" "7_16_flat_sel.gif" "7<" xmine-number-face) - ("xmine-8-glyph" "8_16_flat.gif" "8 " xmine-number-face) - ("xmine-8-sel-glyph" "8_16_flat_sel.gif" "8<" xmine-number-face))) - -(defvar xmine-force-textual nil - "This is for debugging purposes only. No need to set it. Really.") - -(defun xmine-generate-glyphs () - (let ((list xmine-glyph-production-list) - elem var gif text face) - (while (setq elem (pop list)) - (setq var (car elem) - gif (cadr elem) - text (caddr elem) - face (cadddr elem)) - (set (intern var) - (make-glyph (if (and (not xmine-force-textual) - (eq window-system 'x)) - (concat xmine-glyph-dir gif) - text))) - (if face - (set-glyph-face (eval (intern-soft var)) face))))) - -(xmine-generate-glyphs) - -(defvar xmine-key-sel-button nil) - -(defun xmine-up-glyph (ext) - (if (equal ext xmine-key-sel-button) - (progn - (set-extent-property ext 'xmine-non-selected-glyph xmine-up-glyph) - xmine-up-sel-glyph) - xmine-up-glyph)) - -(defun xmine-flagged-glyph (ext) - (if (equal ext xmine-key-sel-button) - (progn - (set-extent-property ext 'xmine-non-selected-glyph xmine-flagged-glyph) - xmine-flagged-sel-glyph) - xmine-flagged-glyph)) - -(defcustom xmine-%-of-mines 12 - "The percentage of tiles that should be mines." - :group 'xmine - :type 'integer) - -(defcustom xmine-balloon-list (list "What are you waiting for?" - "Push me!" - "Come on. Don't sleep." - "Are you sure?" - "Are you sleeping?" - "Yes! Do it!" - "I'm getting bored." - "You will NEVER beat me.") - "(Random) texts for the balloon-help property of the tiles" - :group 'xmine - :type '(repeat (string))) - -(defcustom xmine-background "white" - "The background color of XMine's buffer. -Many colors will not blend nicely with the logo. Shades of light grey are -preferred if you don't want to use white." - :group 'xmine - :type 'color) - -(defvar xmine-keymap nil) - -(if xmine-keymap () - (setq xmine-keymap (make-sparse-keymap)) - (suppress-keymap xmine-keymap) - (define-key xmine-keymap [up] 'xmine-key-up) - (define-key xmine-keymap [down] 'xmine-key-down) - (define-key xmine-keymap [right] 'xmine-key-right) - (define-key xmine-keymap [left] 'xmine-key-left) - (define-key xmine-keymap "e" 'xmine-key-up) - (define-key xmine-keymap "c" 'xmine-key-down) - (define-key xmine-keymap "f" 'xmine-key-right) - (define-key xmine-keymap "s" 'xmine-key-left) - (define-key xmine-keymap "w" 'xmine-key-up-left) - (define-key xmine-keymap "x" 'xmine-key-down-left) - (define-key xmine-keymap "r" 'xmine-key-up-right) - (define-key xmine-keymap "v" 'xmine-key-down-right) - (define-key xmine-keymap [return] 'xmine-key-action3) - (define-key xmine-keymap "d" 'xmine-key-action3) - (define-key xmine-keymap [(shift space)] 'xmine-key-action2) - (define-key xmine-keymap "a" 'xmine-key-action2) - (define-key xmine-keymap [space] 'xmine-key-action1) - (define-key xmine-keymap [Q] 'xmine-key-quit) - (define-key xmine-keymap [N] 'xmine-key-new)) - -(defvar xmine-number-of-flagged 0) - -(defvar xmine-number-of-opened 0) - -(defvar xmine-number-of-mines 0) - -(defvar xmine-field nil) - -(defvar xmine-buffer nil) - -(defvar xmine-quit-ann nil) - -(defvar xmine-new-ann nil) - -(defvar xmine-count-ann nil) - -(defvar xmine-count-glyph (make-glyph "Mines: 00")) - -(defvar xmine-mode-hook nil - "*Hook called by `xmine-mode-hook'.") - -;; the next function is more or less stolen from annotation.el and -;; modified to fit in our scheme were all three buttons should trigger -;; actions - -(defun xmine-activate-function-button (event) - (interactive "e") - (let* ((extent (event-glyph-extent event)) - (button (number-to-string (event-button event))) - (action (intern (concat "action" button))) - (down-action (intern (concat "down-action" button))) - (restore-down-action (intern (concat "restore-down-action" button))) - (mouse-down t) - (action-do-it t) - up-glyph) - ;; make the glyph look pressed - (cond ((annotation-down-glyph extent) - (setq up-glyph (annotation-glyph extent)) - (set-annotation-glyph extent (annotation-down-glyph extent)))) - (if (extent-property extent down-action) - (setq action-do-it - (funcall (extent-property extent down-action) extent))) - (while mouse-down - (setq event (next-event event)) - (if (button-release-event-p event) - (setq mouse-down nil))) - ;; make the glyph look released - (cond ((annotation-down-glyph extent) - (set-annotation-glyph extent up-glyph))) - (if (eq extent (event-glyph-extent event)) - (if (and (extent-property extent action) action-do-it) - (funcall (extent-property extent action) extent) - (if (extent-property extent restore-down-action) - (funcall (extent-property extent restore-down-action) extent))) - (if (extent-property extent restore-down-action) - (funcall (extent-property extent restore-down-action) extent))))) - -;;; Here we define the button object's constructor function - -(defun xmine-button-create (x y type) - (let ((ext (make-annotation - xmine-up-glyph nil 'text nil nil xmine-down-glyph nil))) - (set-extent-property ext 'action1 'xmine-action1) - (set-extent-property ext 'action2 'xmine-beep) - (set-extent-property ext 'action3 'xmine-action3) - (set-extent-property ext 'down-action2 'xmine-down-action2) - (set-extent-property ext 'restore-down-action2 'xmine-restore-down-action2) - (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type)) - (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type)) - (set-extent-property ext 'xmine-type type) - (set-extent-property ext 'xmine-x x) - (set-extent-property ext 'xmine-y y) - (set-extent-property ext 'xmine-flagged nil) - (set-extent-property ext 'xmine-hidden t) - (set-extent-property ext 'end-open t) - (set-extent-property ext 'balloon-help (xmine-balloon-text)) - (aset xmine-field (+ (* (1- y) xmine-width) (1- x)) ext))) - -;;; ...and this is the second global function to change a -;;; button object. It is only needed during creation of the board. - -(defun xmine-button-change-type (ext type) - (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type)) - (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type)) - (set-extent-property ext 'xmine-type type)) - -;;; some needed predicates. - -(defun xmine-flat-button-p (ext) - (and ext - (not (extent-property ext 'xmine-hidden)) - (equal "0" (extent-property ext 'xmine-type)))) - -(defun xmine-enough-flagged-p (ext) - (let ((list (xmine-get-neighbours ext)) - (number (extent-property ext 'xmine-type)) - (flagged 0) elem res) - (if (not (or (equal number "mine") - (equal number "0"))) - (progn - (setq number (string-to-number number)) - (while (setq elem (pop list)) - (if (extent-property elem 'xmine-flagged) - (setq flagged (1+ flagged)))) - (setq res (>= flagged number)) - )) - res)) - - -(defun xmine-mine-button-p (ext) - (and ext - (equal "mine" (extent-property ext 'xmine-type)))) - -;;; the next three functions are helper functions used inside a button -;;; object. - -(defun xmine-balloon-text () - (nth (random (length xmine-balloon-list)) xmine-balloon-list)) - -(defun xmine-beep (&rest forget) - (beep)) - -(defun xmine-type-to-glyph (type) - (eval (intern-soft (concat "xmine-" type "-glyph")))) - -(defun xmine-type-to-sel-glyph (type) - (eval (intern-soft (concat "xmine-" type "-sel-glyph")))) - -;;; the next 3 functions are the main functions that are used -;;; inside the button objects and which are bound to the 'action1, -;;; 'action2 and 'action3 slots respectively - -(defun xmine-action1 (ext &optional no-repaint force) - "This unhides a hidden button" - (if (or force - (not (extent-property ext 'xmine-flagged))) - (progn - (if (and (not force) - (extent-property ext 'xmine-hidden)) - (setq xmine-number-of-opened (1+ xmine-number-of-opened))) - (set-extent-property ext 'xmine-hidden nil) - (set-annotation-glyph ext (if (equal ext xmine-key-sel-button) - (progn - (set-extent-property - ext 'xmine-non-selected-glyph - (extent-property ext 'xmine-glyph)) - (extent-property ext 'xmine-sel-glyph)) - (extent-property ext 'xmine-glyph))) - (set-extent-property ext 'action3 nil) - (set-extent-property ext 'action1 nil) - (set-extent-property ext 'balloon-help nil) - (set-extent-property ext 'action2 'xmine-action2) - (if (not no-repaint) - (progn - (xmine-unhide-sound) - (xmine-field-repaint ext) - (if (and (xmine-game-solved-p) - (not (xmine-mine-button-p ext))) - (xmine-end-game))))))) - -(defun xmine-action2 (ext) - "This unhides all hidden neighbours of a button. -It is meant as convenience function you can use if you're sure that -you've marked all mines around the button correctly (or you're sure -there isn't one)" - (let ((list (xmine-get-neighbours ext)) - (xmine-no-unhide-sound t) - next) -;; (xmine-restore-down-action2 ext) - (if list (xmine-unhide-many-sound)) - (while (setq next (pop list)) - (if (not (xmine-flat-button-p next)) (xmine-action1 next))))) - -(defun xmine-action3 (ext) - "This toggles the flagged status of a button. -You flag a button if you know - or think - that there's a mine under it" - (if (extent-property ext 'xmine-flagged) - (progn - (set-annotation-glyph ext (xmine-up-glyph ext)) - (set-extent-property ext 'action1 'xmine-action1) - (set-extent-property ext 'xmine-flagged nil) - (setq xmine-number-of-flagged (1- xmine-number-of-flagged)) - (xmine-flag-sound) - (set-annotation-glyph xmine-count-ann - (make-glyph - (format "Mines: %2d" - (- xmine-number-of-mines - xmine-number-of-flagged))))) - (if (= xmine-number-of-flagged xmine-number-of-mines) - (progn - (beep) - (message - "Impossible. You seem to have marked too many tiles as mines?")) - (set-annotation-glyph ext (xmine-flagged-glyph ext)) - (set-extent-property ext 'action1 nil) - (set-extent-property ext 'xmine-flagged t) - (setq xmine-number-of-flagged (1+ xmine-number-of-flagged)) - (xmine-flag-sound) - (if (xmine-game-solved-p) (xmine-end-game) - (set-annotation-glyph xmine-count-ann - (make-glyph - (format "Mines: %2d" - (- xmine-number-of-mines - xmine-number-of-flagged)))))))) - - -(defun xmine-down-action2 (ext) - (let ((list (xmine-get-neighbours ext)) - (do-it (xmine-enough-flagged-p ext)) - elem) - (if (not do-it) - (while (setq elem (pop list)) - (set-extent-property elem 'xmine-temp-glyph (annotation-glyph elem)) - (set-annotation-glyph elem (annotation-down-glyph elem)))) - do-it)) - -(defun xmine-restore-down-action2 (ext) - (let ((list (xmine-get-neighbours ext)) - elem) - (while (setq elem (pop list)) - (set-annotation-glyph elem (extent-property elem 'xmine-temp-glyph))))) - -;;; the sounds... -(defcustom xmine-play-sounds nil - "If XMine should play some sounds for various events to happen." - :group 'xmine - :type 'boolean) - -(defun xmine-play-sounds-p () - (and xmine-play-sounds - (or (featurep 'native-sound) - (featurep 'nas-sound)) - (or (device-sound-enabled-p) - (and (featurep 'native-sound) - (not native-sound-only-on-console) - (eq (device-type) 'x))))) - - -(defcustom xmine-flag-sound (concat data-directory "sounds/click.au") - "The sound played when flagging/un-flagging a tile" - :group 'xmine - :type 'file) - -(defcustom xmine-unhide-sound (concat data-directory "sounds/drip.au") - "The sound played when unhiding a tile" - :group 'xmine - :type 'file) - -(defcustom xmine-unhide-many-sound (concat data-directory "sounds/boing.au") - "The sound played when unhiding all neighbours of a tile" - :group 'xmine - :type 'file) - -(defcustom xmine-explode-sound (concat xmine-glyph-dir "explosion3.au") - "The sound played when you unhide a mine" - :group 'xmine - :type 'file) - -(defcustom xmine-solved-sound (concat data-directory "sounds/im_so_happy.au") - "The sound played if you managed to win the game." - :group 'xmine - :type 'file) - -(defun xmine-flag-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-flag-sound))) - -(defvar xmine-no-unhide-sound nil) - -(defun xmine-unhide-sound () - (if (and (xmine-play-sounds-p) - (not xmine-no-unhide-sound)) - (play-sound-file xmine-unhide-sound))) - -(defun xmine-unhide-many-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-unhide-many-sound))) - -(defun xmine-explode-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-explode-sound) - (beep))) - -(defun xmine-solved-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-solved-sound) - (beep))) - - -;;; what to do after a button is unhidden: We (maybe) have to repaint -;;; parts of the board. This is done here recursively. - -(defun xmine-field-repaint (ext) - (let* ((flatp (xmine-flat-button-p ext)) - (minep (xmine-mine-button-p ext)) - (neighbours (xmine-get-neighbours ext)) - (max-lisp-eval-depth (* 8 xmine-width xmine-height)) - next-ext ext-list) - (cond (flatp - (while (setq next-ext (pop neighbours)) - (if (extent-property next-ext 'xmine-hidden) - (progn - (xmine-action1 next-ext 'no-repaint) - (and (equal "0" (extent-property next-ext 'xmine-type)) - (push next-ext ext-list))))) - (while ext-list - (setq next-ext (pop ext-list)) - (xmine-field-repaint next-ext))) - (minep - (set-extent-property ext 'xmine-glyph xmine-trapped-glyph) - (set-extent-property ext 'xmine-sel-glyph xmine-trapped-glyph) - (xmine-show-all) - (xmine-end-game-trapped))))) - - -(defun xmine-get-neighbours (ext) - "This gives back a list of all neighbours of a button, correctly - handling buttons at the side or corner of course" -(let* ((x (extent-property ext 'xmine-x)) - (y (extent-property ext 'xmine-y)) - next-coord next list - (neighbours (list (list (1- x) (1+ y)) - (list x (1+ y)) - (list (1+ x) (1+ y)) - (list (1- x) (1- y)) - (list x (1- y)) - (list (1+ x) (1- y)) - (list (1+ x) y) - (list (1- x) y)))) - (while (setq next-coord (pop neighbours)) - (if (setq next (xmine-field-button-at (car next-coord) - (cadr next-coord))) - (push next list))) - list)) - - -;;; the next four functions are used to know if we're at the end of -;;; the game (either successfully or exploded) and do the approbate -;;; action - -(defun xmine-game-solved-p () - "You have solved the game successfully if the number of flagged -mines plus the number of unhidden buttons equals width*height of the field" - (equal (+ xmine-number-of-flagged xmine-number-of-opened) - (* xmine-width xmine-height))) - -(defun xmine-end-game () - (set-annotation-glyph xmine-count-ann - (make-glyph " Solved. ")) - (sit-for 0) - (xmine-solved-sound)) - -(defun xmine-end-game-trapped () - (xmine-explode-sound) - (set-annotation-glyph xmine-count-ann - (make-glyph "++ RIP ++"))) - -(defun xmine-show-all () - (let ((list (append xmine-field nil)) - next) - (while (setq next (pop list)) - (xmine-action1 next 'no-repaint 'force)))) - - -(defun xmine-field-button-at (x y) - "This function gives back the button at a given coordinate pair (x y) -It is only used during creation of the board and when getting the -neighbours of a button (and for keyboard handling...), as we don't -want to use coordinates in the main loop, only the button object -itself should be referenced. Of course the use of this function could -be avoided in xmine-get-neighbours by storing the neighbour buttons -directly in the button, but this seems to be a bit oversized for this -little game." - (if (or (> x xmine-width) (< x 1) - (> y xmine-height) (< y 1)) nil - (aref xmine-field (+ (* (1- y) xmine-width) (1- x))))) - -;;;###autoload -(defun xmine-mode () -"A mode for playing the well known mine searching game. - - `\\\\[xmine-activate-function-button1]' or `\\\\[xmine-key-action1]' unhides a tile, - `\\\\[xmine-activate-function-button2]' or `\\\\[xmine-key-action2]' unhides all neighbours of a tile, - `\\\\[xmine-activate-function-button3]' or `\\\\[xmine-key-action3]' (un)flagges a tile to hold a mine. - - `\\[xmine-key-new]' starts a new game. - `\\[xmine-key-quit]' ends a game. - -All keybindings (with alternatives) currently in effect: - \\{xmine-keymap} - -The rules are quite easy: You start by unhiding (random) tiles. An unhidden -tile showing a number tells you something about the number of mines in it's -neighborhood, where the neighborhood are all 8 tiles (or less if it's -at a border) around the tile. - -E.g. a \"1\" shows you that there is only one mine in the neighborhood of -this tile. Empty tiles have no mines around them, and empty tiles in -the neighborhood of another empty tile are all automatically unhidden -if you unhide one of them. You need to find a strategy to use the -information you have from the numbers to \"flag\" the tiles with mines -under them and unhide all other tiles. If you correctly made this -without accidently unhiding a mine, you've won. - -If you are sure you have correctly flagged all mines around a unhidden tile, -you can use Button-2 or \\[xmine-key-action2] on it to unhide all it's -neighbors. But beware: If you made a mistake by flagging the wrong mines, -you'll blow up! - -Have Fun." - (interactive) - (xmine-field-create)) - -;;;###autoload -(fset 'xmine 'xmine-mode) - -(defun xmine-field-create () - "We create the playing board here." - (let ((width 1) - (height 1) - (pop-up-windows nil) - total) - (xmine-buffer-init) - (pop-to-buffer xmine-buffer) - (setq total (* xmine-height xmine-width)) - (setq xmine-field (make-vector total nil)) - (xmine-init-mines - (setq xmine-number-of-mines - (min 99 (round (* (/ (float xmine-%-of-mines) 100) total))))) - (insert "\n ") - (set-extent-end-glyph (make-extent (point) (point)) xmine-title-glyph) - (insert "\n\n") - (while (<= height xmine-height) - (insert " ") - (while (<= width xmine-width) - (if (xmine-field-button-at width height) - (xmine-button-create width height "mine") - (xmine-button-create width height "0")) - (setq width (+ width 1))) - (insert " \n") - (setq width 1) - (setq height (+ height 1))) - (insert "\n ") - (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph) - (setq xmine-new-ann - (make-annotation xmine-new-up nil - 'text nil nil xmine-new-down nil)) - (set-extent-property xmine-new-ann 'action1 '(lambda (&rest egal) - (xmine-field-create))) - (set-extent-property xmine-new-ann 'action2 nil) - (set-extent-property xmine-new-ann 'action3 nil) - (set-extent-property xmine-new-ann 'end-open t) - (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph) - (setq xmine-count-ann - (make-annotation xmine-count-glyph nil - 'text nil nil nil nil)) - (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph) - (setq xmine-quit-ann - (make-annotation xmine-quit-up nil - 'text nil nil xmine-quit-down nil)) - (set-extent-property xmine-quit-ann 'action1 - '(lambda (&rest egal) - (kill-buffer (current-buffer)))) - (set-extent-property xmine-quit-ann 'action2 nil) - (set-extent-property xmine-quit-ann 'action3 nil) - (set-extent-property xmine-quit-ann 'end-open t) - (xmine-attach-numbers) - (setq xmine-number-of-flagged 0) - (setq xmine-number-of-opened 0) - (set-annotation-glyph xmine-count-ann - (make-glyph - (format "Mines: %2d" xmine-number-of-mines))) - (goto-char (point-min)) - (setq buffer-read-only 't) - (if (eq window-system 'x) - (set-specifier (face-background 'default) - xmine-background xmine-buffer)) - (set-specifier (face-background 'text-cursor) - xmine-background xmine-buffer) - (setq xmine-key-sel-button nil) - (xmine-select-button (xmine-field-button-at (/ xmine-width 2) - (/ xmine-height 2))))) - - -(defun xmine-init-mines (num) - "A subroutine for xmine-field create. -We randomly set a part of the nil-filled board vector with t to -indicate the places where mines should reside." - (let (x y elem) - (random t) - (while (> num 0) - (setq x (1+ (random xmine-width))) - (setq y (1+ (random xmine-height))) - (setq elem (xmine-field-button-at x y)) - (if (not elem) - (progn - (aset xmine-field (+ (* (1- y) xmine-width) (1- x)) t) - (setq num (1- num))))))) - -(defun xmine-attach-numbers () - "A subroutine for xmine-field-create. -The board is populated by now with empty buttons and mines. Here we -change the correct empty buttons to \"numbered\" buttons" - (let - ((buttons (append xmine-field nil)) - ext) - (while (setq ext (pop buttons)) - (let ((num 0) - (minep (xmine-mine-button-p ext)) - (neighbours (xmine-get-neighbours ext)) - next) - (if (not minep) - (progn - (while (setq next (pop neighbours)) - (if (xmine-mine-button-p next) (setq num (1+ num)))) - (if (> num 0) - (xmine-button-change-type ext (number-to-string num))))))))) - - -(defun xmine-buffer-init () - "A subroutine for xmine-create-field. -We set up the XMine buffer, set up the keymap and so on." - (if xmine-buffer (kill-buffer xmine-buffer)) - (setq xmine-buffer (get-buffer-create "XEmacs Mine")) - (save-excursion - (set-buffer xmine-buffer) - (kill-all-local-variables) - (make-local-variable 'annotation-local-map-default) - (setq truncate-lines 't) - (setq major-mode 'xmine-mode) - (setq mode-name "XMine") - (put 'xmine-mode 'mode-class 'special) - (use-local-map xmine-keymap) - (buffer-disable-undo (current-buffer)) - (setq annotation-local-map-default - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'annotation-local-map) - (define-key map 'button1 'xmine-activate-function-button) - (define-key map 'button2 'xmine-activate-function-button) - (define-key map 'button3 'xmine-activate-function-button) - map)) - (run-hooks 'xmine-mode-hook))) - -;;; The keyboard navigation. - -(defun xmine-select-button (ext) - (let ((flagged (extent-property ext 'xmine-flagged)) - (hidden (extent-property ext 'xmine-hidden)) - sel-glyph) - (setq sel-glyph (if hidden - (if flagged xmine-flagged-sel-glyph - xmine-up-sel-glyph) - (extent-property ext 'xmine-sel-glyph))) - (if xmine-key-sel-button - (set-annotation-glyph xmine-key-sel-button - (extent-property xmine-key-sel-button - 'xmine-non-selected-glyph))) - (set-extent-property ext 'xmine-non-selected-glyph - (annotation-glyph ext)) - (set-annotation-glyph ext sel-glyph) - (setq xmine-key-sel-button ext))) - -(defun xmine-key-action1 () - (interactive) - (let ((action (extent-property xmine-key-sel-button 'action1))) - (if action - (funcall action xmine-key-sel-button)))) - -(defun xmine-key-action2 () - (interactive) - (let ((action (extent-property xmine-key-sel-button 'action2))) - (if (and action (xmine-enough-flagged-p xmine-key-sel-button)) - (funcall action xmine-key-sel-button) - (beep)))) - -(defun xmine-key-action3 () - (interactive) - (let ((action (extent-property xmine-key-sel-button 'action3))) - (if action - (funcall action xmine-key-sel-button)))) - -(defun xmine-key-quit () - (interactive) - (kill-buffer (current-buffer))) - -(defun xmine-key-new () - (interactive) - (xmine-field-create)) - -(defun xmine-key-down-right () - (interactive) - (xmine-key-down) - (xmine-key-right)) - -(defun xmine-key-down-left () - (interactive) - (xmine-key-down) - (xmine-key-left)) - -(defun xmine-key-up-right () - (interactive) - (xmine-key-up) - (xmine-key-right)) - -(defun xmine-key-up-left () - (interactive) - (xmine-key-up) - (xmine-key-left)) - -(defun xmine-key-down () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at x (1+ y)))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at x 1))))) - -(defun xmine-key-up () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at x (1- y)))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at x xmine-height))))) - -(defun xmine-key-right () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at (1+ x) y))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at 1 y))))) - -(defun xmine-key-left () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at (1- x) y))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at xmine-width y))))) - -(provide 'xmine) - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/games/yow.el --- a/lisp/games/yow.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,131 +0,0 @@ -;;; yow.el --- quote random zippyisms - -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Author: Richard Mlynarik -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Important pinheadery for GNU Emacs. -;; -;; See cookie1.el for implementation. Note --- the `n' argument of yow -;; from the 18.xx implementation is no longer; we only support *random* -;; random access now. - -;;; Code: - -(require 'cookie1) - -(defvar yow-file (concat data-directory "yow.lines") - "File containing pertinent Pinhead Phrases.") - -(defconst yow-load-message "Am I CONSING yet?...") -(defconst yow-after-load-message "I have SEEN the CONSING!!") - -;;;###autoload -(defun yow (&optional insert) - "Return or display a random Zippy quotation. With prefix arg, insert it." - (interactive "P") - (let ((yow (cookie yow-file yow-load-message yow-after-load-message))) - (cond (insert - (insert yow)) - ((not (interactive-p)) - yow) - ((not (string-match "\n" yow)) - (delete-windows-on (get-buffer-create "*Help*")) - (message "%s" yow)) - (t - (message "Yow!") - (with-output-to-temp-buffer "*Help*" - (princ yow) - (save-excursion - (set-buffer standard-output) - (help-mode))))))) - -(defun read-zippyism (prompt &optional require-match) - "Read a Zippyism from the minibuffer with completion, prompting with PROMPT. -If optional second arg is non-nil, require input to match a completion." - (read-cookie prompt yow-file yow-load-message yow-after-load-message - require-match)) - -;;;###autoload -(defun insert-zippyism (&optional zippyism) - "Prompt with completion for a known Zippy quotation, and insert it at point." - (interactive (list (read-zippyism "Pinhead wisdom: " t))) - (insert zippyism)) - -;;;###autoload -(defun apropos-zippy (regexp) - "Return a list of all Zippy quotes matching REGEXP. -If called interactively, display a list of matches." - (interactive "sApropos Zippy (regexp): ") - ;; Make sure yows are loaded - (cookie yow-file yow-load-message yow-after-load-message) - (let* ((case-fold-search t) - (cookie-table-symbol (intern yow-file cookie-cache)) - (string-table (symbol-value cookie-table-symbol)) - (matches nil) - (len (length string-table)) - (i 0)) - (save-match-data - (while (< i len) - (and (string-match regexp (aref string-table i)) - (setq matches (cons (aref string-table i) matches))) - (setq i (1+ i)))) - (and matches - (setq matches (sort matches 'string-lessp))) - (and (interactive-p) - (cond ((null matches) - (message "No matches found.")) - (t - (let ((l matches)) - (with-output-to-temp-buffer "*Zippy Apropos*" - (while l - (princ (car l)) - (setq l (cdr l)) - (and l (princ "\n\n")))))))) - matches)) - - -;; Yowza!! Feed zippy quotes to the doctor. Watch results. -;; fun, fun, fun. Entertainment for hours... -;; -;; written by Kayvan Aghaiepour - -;;;###autoload -(defun psychoanalyze-pinhead () - "Zippy goes to the analyst." - (interactive) - (doctor) ; start the psychotherapy - (message "") - (switch-to-buffer "*doctor*") - (sit-for 0) - (while (not (input-pending-p)) - (insert-string (yow)) - (sit-for 0) - (doctor-ret-or-read 1) - (doctor-ret-or-read 1))) - -(provide 'yow) - -;;; yow.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/ANNOUNCEMENT --- a/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,131 +0,0 @@ -Hello, - -I've written a new version (5.8) of my html package for the XEmacs -and the GNU Emacs 19. The name of the package is: - - hm--html-menus-5.8.tar.gz - -With this package it is very easy to write html pages for the World Wide -Web (WWW). Eg: In most cases the user gets help to construct a specific -link by examples or by a completition list with possible input strings. -It is also possible to insert links and images by just clicking on its -source and destination (drag and drop feature). - -The biggest new features compared with release 5.7 are: -- use of the customize package for customization -- the header of the main files should no be 'package finder' compatible -- in the XEmacs a drag and drop mouse pointer will be used - during drag and drop -- the minor mode (hm--html-minor-mode) could now be used in many - other major modes -- better popup menu support for the hm--html-minor-mode in the - Emacs 19 -- the emacs start up options -u, -q, -no-site-file are now - respected -- some bug fixes -Read the NEWS file to see news in detail... - -You should find hm--html-menus-5.8.tar.gz on the following ftp server: - sunsite.unc.edu in /pub/Linux/apps/editors/emacs/ - ftp.tnt.uni-hannover.de in /pub/editors/xemacs/contrib - -It may take some time, before the package is copied by the ftp admins -from the incoming directories to the above listed directories. - -There is a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html - -This package provides also a minor mode (hm--html-minor-mode), which -can be used together with other html major modes, like the psgml-html -mode or other major edit modes, like the perl-mode. - -The package provides functions to insert the following stuff in html-pages: -1. Anchors: - relative links, general link; - html link, info link, gopher link, file link; - ftp link, news link, mailbox link, mailto link, wais (direct) link, - wais (gateway) link; - proggate link, local proggate link, - link target; -2. Frame elements: - full html frame with doctype, doctype, html, head, body, title, - header and signature elements or only the single elements; - meta, isindex, link and base element; - html 'created'- and 'changed'- comments; - the current date in the title; -3. Structure elements: - menu or list item, menu, unordered list, ordered list, directory list; - description list, description title, description entry; - table, table title, table header, table row, table entry; - new paragraph, new line, horizontal rule, document division; -4. for formatting paragraphs: - preformated, blockquote; - basefont, font, center, style; - html comment; -5. formatting: - bold, italic, underline, typewriter, strikethru, super and subscript, - emphasized, strong, small, big, - definition, keyboard, variable, code, sample, citation, -6. include: - top aligned image, middle aligned image, bottom aligned image; - general image element, map, area and all together; - applet, parameter, script; -7. forms: - form; - text, password, isindex, integer, float, date, url, scribble fields; - checkbox, radio, reset, image, audio and submit buttons; - option menus, scrolled lists and option entries; - textarea; -8. entities: - most of the special ISO- characters, less, greater and ampersand; - -If it makes sense, the functions worked also on selected regions. -I've used the same menu items and the same keystrokes. Therefore, you -don't need to learn different menus or keys for similar functions. - -You can choose the popup menus between an expert menu and an novice -menu interactively. - -With the pulldown menu, you can do the following things: -- select the popup menu -- start a drag and drop command -- get help on a drag and drop command -- remove numeric names -- quotify hrefs -- reload the config files -- load html templates from a template directory (two templates are included - in the package); templates written in a special template language are - expanded automatically; -- preview html documents with the netscape -- preview html documents with the xmosaic -- preview html documents with the w3 package for the XEmacs and emacs - -You can insert links and images by clicking with Meta Control Button1 -on its source and then on its destination. For this drag and drop -interface the following destinations and links are supported: - the -inclusion of an GIF- or JPEG- image by clicking on its name - in a dired buffer -- a file or relative link to any other file by clicking on its name - in a dired buffer -- a file or relative link to a directory by clicking on a line without - a filename in the dired buffer -- a file or relative link to a file by clicking in a buffer with this - file -- a http or relative link to a html page by clicking in the w3 buffer, - which displays this page -- a http or relative link, which is in another html page by clicking - on the link in a w3 buffer -If there is an activated region in the source buffer, then the link -is inserted around it, so that the region is used as the name of the -link. - -You can configure the html mode with a special configuration file for -your site and with another file specific for a user. - -The html specification is under development and therefore this -package is also under development. So, if you have any ideas to -extend the package, feel free to email them to -muenkel@tnt.uni-hannover.de. - - -Heiko diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/NEWS --- a/lisp/hm--html-menus/NEWS Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,624 +0,0 @@ -20.07.97 - -- BUILDED the version 5.8 of the package -- -19.07.97 - The minor mode (hm--html-minor-mode) in the Emacs 19 has now - an entry to get the major mode menu - propably not the best - solution, but better than nothing. - Updated the Texinfo documentation. -17.07.97 - Added dummy definitions for defgroup and defcustom for the - Emacs 19. - The variable `site-run-file' is now used, if `site-start-file' - doesn't exists (for Emacs 19 compatibility). - Fixed a bug in the minor mode popup menu, which occured - in the XEmacs together with the html-mode of the psgml - package. -15.07.97 - The minor mode (hm--html-minor-mode) could now be used in many - other (non html) major modes in the XEmacs, like the java-mode - or the perl-mode. In these modes, in the XEmacs it adds it's - own popup menu at the beginning of the major mode menu. -06.07.97 - Changed the file header of hm--html-mode.el, - internal-drag-and-drop.el and tmpl-minor-mode.el. - They should now be compliant with standards. - The mouse pointer in the XEmacs changes now it's shape, - during the drag and drop. -01.07.97 - The package uses now the customisation stuff. - Applied a patch from Dave Love , which fixed - some font-lock bugs. - Fixed a bug in `hm--html-insert-modified-line'. Thanks to - David M. Cook , who reported this bug. - The package respects now the emacs flags -q, -u and - -no-site-file. -u is only respected, if the user config - file isn't given neither by the environment variable nor by the - lisp variable. -31.05.97 - Added the functions `define-obsolete-variable-alias' and - `define-obsolete-variable-alias' for the Emacs 19 to the file - adapt.el. This fixed a load bug in the Emacs 19. -24.05.97 - Added `hm--html-automatic-create-title-date' and changed the - variable `hm--html-automatic-new-date' to - `hm--html-automatic-update-title-date'. `hm--html-automatic-new-date' - is now an obsolete variable and will be deleted in the future. - Applied a patch from Luca Pisati , which - fixed a bug in `hm--html-indent-region'. - Fixed a bug in the `hm--html-minor-region-mode-map'. Thanks to - Luca Pisati, for the bug report. - Applied a patch from Gary D. Foster - to fix the misspelled words *formatted and *formating. Thanks Gary. - Changed `hm--html-indent-line' so that the indentation leaves the - point now at the old text position, if it was behind the - indentation column. - -- BUILDED the version 5.7 of the package -- -23.05.97 - Changed the special character entities &circumflex to &circ, - thanks to Guylaine Prat , for the bug report. - Added the variables `hm--html-automatic-changed-comment-prefix', - `hm--html-automatic-created-comment-prefix' and - `hm--html-automatic-comment-infix' to make the automatic insertation - of created and changed comments more flexible. - Added the command `hm--html-insert-modified-line' and the - variables `hm--html-automatic-create-modified-line', - `hm--html-automatic-update-modified-line', `hm--html-modified-prefix', - `hm--html-modified-start-tag', `hm--html-modified-end-tag' and - `hm--html-modified-insert-before', for inserting and updating - a visible "Modified line". -08.05.97 - Added the function `idd-get-buffer'. -29.03.97 - Fixed the problem with `:keys "\\[idd-help-mouse-drag-and-drop]"' - in the Emacs 19. - Fixed the template commands for the Emacs 19. - Added the commands `tmpl-util-indent-region' and - `tmpl-util-indent-buffer', which are useful utilities in - template files. - Changed frame.html.tmpl and command-description.html.tmpl, so that - they now will be indented after their insertation. -28.03.97 - Fixed the commands `idd-mouse-drag-and-drop-click' and - `idd-mouse-drag-and-drop-press-button-during-move' for the Emacs 19. - Fixed also the mouse keybinding for these commands in the Emacs 19. - Fixed the command `idd-start-mouse-drag-and-drop' for the Emacs 19. - Therefore the internal drag and drop is now working again in the - Emacs 19. - The idd help functions are fixed for the Emacs 19. - Fixed the function `hm--html-is-one-element-tag-p' for the Emacs 19. -26.03.97 - Applied a patch from Michael D. Harnois to fix the documentation. - Fixed a bug in adapt.el. - -- BUILDED the version 5.6 of the package -- -25.03.97 - Fixed a bug in `hm--html-search-place-for-element-in-head'. - Fixed bugs in `hm--html-add-base' and `hm--html-add-isindex'. - Renamed all calls to `hm--html-add-mail-link*' to - `hm--html-add-mail-box-link*' - this fixed bugs in the menus and - keybindings. - Fixed `hm--html-frame-template-file'. - Fixed some keybinding bugs. - -- BUILDED the version 5.5 of the package -- -24.03.97 - Added the function `mouse-event-p' for the Emacs 19 to adapt.el. - The internal-drag-and-drop package uses know the function - `file-remote-p' instead of `ange-ftp-ftp-path'. If this - function is not available in an emacs, the function will be - defined and will use the function `ange-ftp-ftp-path'. - Fixed bugs in `idd-mouse-drag-and-drop-click' for the Emacs 19. -23.03.97 - Fixed some bugs, so that the package is now again loadable - in the Emacs 19 (19.34). - Changed popup-menu-up-p to popup-up-p, menu-event-p to - misc-user-event-p. - Fixed some other XEmacs compilation bugs. - Fixed bugs in `hm--html-add-isindex' and `hm--html-add-base'. - Moved the commands `hm--html-add-server-side-include-file', - `hm--html-add-server-side-include-command' and - `hm--html-add-server-side-include-command-with-isindex-parameter' - to hm--html-not-standard.el. - Fixed a bug in `hm--html-add-document-division-to-region'. - Deleted some obsolete stuff in `hm--html-add-link'. - Fixed bugs in `hm--html-add-basefont', `hm--html-add-mail-box-link', - `hm--html-add-mail-box-link-to-region', `idd-list-1-subset-of-list-2', - `idd-same-elements-p', `idd-start-mouse-drag-and-drop', - `idd-mouse-drag-and-drop-click', `idd-if-minor-mode-p', - `idd-if-modifiers-p' and `tmpl-read-template-filename'. -22.03.97 - Fixed some documentation bugs in tmpl-minor-mode.el. - Changed the key bindings in the tmpl-minor-mode. They are now - using all the prefix C-c C-c. - Fixed some documentation bugs in internal-drag-and-drop.el. - Added a package documentation as Texinfo file. It documents also - the included packages for internal drag and drop and for - templates. - -- BUILDED the version 5.4 of the package -- -18.03.97 - Applied a patch from Martin Buchholz , - to fix some spelling errors. - Changed the value of the variable `tmpl-sign' to \000. -25.02.97 - Fixed two bugs, which occured during loading the mode - after the psgml-html-mode. - In the minor mode, the HM--HTML menu will now be added before - the HTML menu. - Due to a patch of psgm-html.el it is now possible to call the minor - mode from a hook variable in the html-mode and the html3-mode. - -- BUILDED the version 5.3 of the package -- -22.02.97 - Fixed 'hm--html-add-strikethru-to-region'. - Changed `hm--html-view-www-package-docu' for the new location - of the package documentation. - Moved all functions, which added obsolete or non HTML 3.2 elements, - to hm--html-not-standard.el. This file is not used by default. - Therefore this mode fulfils now the whole HTML 3.2 standard! - Added keybindings for new html functions. - Changed some old keybindings. - Moved the menu items for inserting HTML comments to the - "Formating Paragraphs" menu. - Fixed a bug in the function `hm--html-add-meta'. - The variable `indent-line-function' is now local in all - hm--html-mode buffers. This fixed the bug, that the hm--html-mode - had set the indentation function to `hm--html-indent-line' global. - Added the html elements STYLE and SCRIPT. - -- 23:20: My doughter Sarah Madeleine is born! -- -18.02.97 - Fixed a compilation bug. - -- BUILDED the version 5.2 of the package -- -17.02.97 - Changed the function `hm--html-read-alignment' according to the - HTML version 3.2. - Added a more general command for adding images. - Added the HTML elements MAP and AREA. - Added a command for adding an image and a map. -15.02.97 - Fixed some bugs in the insert full frame stuff. - Added the DOCTYPE to the full frame stuff. - Added the HTML elements DIV, FONT and BASEFONT. -14.02.97 - Added the HTML elements DOCTYPE, ISINDEX, BASE, META. - Added all one tag elements used in HTML 3.2 to the list - `hm--html-tag-name-alist' to make the indentation happy. - Fixed a bug in the indentation after one tag elements. -12.02.97 - Renamed command-description.tmpl to command-description.html.tmpl. - The indentation stuff can now be disabled by setting the - variable `hm--html-disable-indentation' to t. - Fixed the long annoying bug, that the directory in the pop up - frame for selecting the template file was wrong in most cases. - -- BUILDED the version 5.1 of the package -- -11.02.97: - Changed the whole indentation stuff. It is now all working - - with the exceptions, that the list `hm--html-tag-name-alist' - contains not all "one element tags", and also text between - pre tags will be intended. -09.02.97: - Fixed a bug in the template stuff. - Moved the whole indentation stuff to the new file - hm--html-indentation.el. -06.02.97: - The indentation of two tag elements are now working. -03.02.97: - It is now possible to use an own site specific configuration file. - For that the variable `hm--html-site-config-file' was added. - Added some code from Bob Weiner to modify the syntax table, - change the comment start and end and the sentence end. - Started to add the indentation. - The indentation in comments is now working. -01.02.97: - In the source and destination description of a drag and drop - are now used marks instead of points. This fixed bugs, which - occured, if the source and the destination buffer are the same. - A help feature was implemented. -30.01.97: - Added some new features to the drag and drop interface, like - the macro `idd-start-mouse-drag-and-drop', which is usefull to - define action functions. The event is now also stored in the source - and destination description. - Changed the order of the arguments destination and source - to source and destination. - Changed the name of all idd specification type functions - to idd-if-*-p. -27.01.97: - Changed the source and destination in the drag and drop functions, - so that they are now used in a standard way. - Added the command `idd-start-mouse-drag-and-drop', which could - be used to start a drag and drop command without a button-press-event. - Used the command `idd-start-mouse-drag-and-drop' in the hm--html - menus. -26.01.97: - Renamed the function `tmpl-insert-template-file' to - `tmpl-insert-template-file-from-fixed-dirs'. - Added a function `tmpl-insert-template-file', which doesn't use - a file filter and a list of directories. - Changed both functions, so that they now use the variables - `tmpl-template-dir-list', `tmpl-automatic-expand', - `tmpl-filter-regexp' and `tmpl-history-variable-name' - instead of optional arguments. - Changed the name of the file frame.html to frame.html.tmpl. This is - usefull, if you've templates for multiple modes in one directory and - you want to use the new filter feature of the command - `tmpl-insert-template-file-from-fixed-dirs'. - Changed the function `hm--html-insert-template' and added - the function `hm--html-insert-template-from-fixed-dirs'. They are - using the functions `tmpl-insert-template-file' and - `tmpl-insert-template-file-from-fixed-dirs'. - The function `hm--html-insert-created-comment' is no longer - called in this functions. If needed, then this function must be - inserted in the template file. This is done now with the file - frame.html.tmpl. -22.01.97: - Changed the function `tmpl-insert-template-file': - It is now possible to use a file filter and a list - of directories, in which template files could be. -19.01.97: - Applied a patch from Andreas Ernst to fix bugs in the table stuff. - Added a '(let ((case-fold-seach t))' in all functions of hm--html.el, - which are call a search function with lowercase letters. - The functions to insert ordered, normal and dired list are fixed to - use
  • tags instead of only
  • . - Fixed a keybind bug for C-c C-s i. - Fixed a wrong call to `hm--html-add-only-description-entry'. - Fixed a bug in the argument list of hm--html-add-tags-to-region. - Fixed a bug in `hm--html-add-tags-to-region', which was caused by the - indentation. - Fixed a bug in `hm--html-add-relative-link-to-region' and - `hm--html-add-relative-link'. - Replaced `hm--html-file-relative-name' with `file-relative-name'. - Changed the font-lock stuff. It uses now the property list of - `font-lock-defaults' and the three keyword lists - 'html-font-lock-keywords', `html-font-lock-keywords-1' and - `html-font-lock-keywords-2'. - Fixed a bug in the drag and drop variables. - Changed the drag and drop command, so that it could be called - also from a menu. - Added the drag and drop command to the pop up menus. -15.08.96: - The items of the menu "Set popup menu" are now radio items. - -- BUILDED the version 5.0 of the package -- -03.08.96: - Applied a patch from Jerry G. DeLapp to - `html-font-lock-keywords'. - Added the param tag for the applet element. - Added the functions `hm--html-add-relative-link' and - `hm--html-add-relative-link-to-region', which have better - support for relative links than the functions for inserting - general links. - Added functions to insert the center element. - Added functions to insert the small and big elements. -31.07.96: - Added the applet element. - The tags for menu items and description entries and titles - are now inserted with a start and a end tag. - Fixed some keybinding bugs. - Added the function 'hm--html-indent-region'. At the moment - the indentation works only in the minor mode and if the major - mode provides an indentation function, like it is in the psgml - mode. -20.07.96: - Fixed bugs in the popup and pulldown menu handling in the Emacs 19. - Speeded up the first popup of some of the menus in the Emacs 19. - The keybinding for the popup menu in the Emacs 19 has changed to - C-down-mouse-3. The variables - `hm--html-emacs19-popup-noregion-menu-button' and - `hm--html-emacs19-popup-region-menu-button' should be used in the Emacs - 19 to change the keybindings. They are defined in hm--html-keys.el. - Fixed a bug in the font-lock stuff for the Emacs 19. - The popup menus of the minor mode worked now also in the Emacs 19. - The pulldown menu of the minor mode worked now also in the Emacs 19. - The name of the pulldown menu can now be changed with the variable - `hm--html-mode-pulldown-menu-name'. - All settings in hm--configuration.el are now made with `defvar'. - So it's easier now to overwrite this values in other files. - All old lisp stuff deleted. - Added Keybindings for the commands in the include and the forms - submenu. - Fixed a bug in the command `hm--html-smart-less-than'. -19.07.96: - Changed the functions hm--popup-html* to hm--html-popup*. - The Emacs 19 popup menus are now realized as direct bindings of - the menu maps to the mouse button. This fixed a bug. -18.07.96: - The popup menus in the Emacs 19 are now much faster, because - the keymaps are only computed once from the XEmacs menu - description instead of each time. - Fixed a bug in the keybinding stuff for the Emacs 19. -16.07.96: - Added the function `hm--html-smart-ampersand'. - Added the minor modes `hm--html-minor-mode' and - `hm--html-minor-region-mode'. They should provide - the menus and commands of this package for the - psgml-html-mode. - The prefix key of the minor and of the major modes - could now be changed with `hm--html-minor-mode-prefix-key' - and `hm--html-mode-prefix-key'. -14.07.96: - Ported the internal drag and drop interface for the Emacs 19. - Changed the Keybinding for the drag and drop function to - M-C-button1 (M-C-mouse-1). - Changed hm--install-html-menu for the Emacs 19. It uses now the - package easy-menu to install the pulldown menu. This fixes the - bug, that the HTML pulldown menu is a global menu. -13.07.96: - Updated the file header comments a little bit. -10.07.96: - Added the file hm--html-mode.el instead of html-mode.el. - Changed the mode name to hm--html-mode. - Fixed a bug in the function `hm--html-generate-help-buffer-faces', - which occurs, if a color is set to nil. - The font-lock mode is no longer called direct from the - hm--html-mode. - The file html-mode.el should no longer be needed for this mode. -09.07.96: - Added the functions `hm--html-add-normal-link', - `hm--html-add-address', `html-add-list-or-menu-item`, - `hm--html-add-list', `hm--html-add-menu', - `hm--html-add-description-list', `hm--html-add-description-entry', - `hm--html-add-plaintext', `hm--html-add-blockquote', - `hm--html-add-listing', `hm--html-add-fixed', - `hm--html-add-emphasized', `hm--html-add-strong', - `hm--html-add-keyboard', `hm--html-add-variable', - `hm--html-add-sample', `hm--html-add-citation', - `hm--html-quotify-hrefs' to the file hm--html.el. Similar - functions are defined in the past in the file html-mode without - the prefix hm--. - Removed Marc's menu. Maybe a simple flat menu will be added - in the future, similar to Marc's menu. - Removed the old keymaps from the configuration file. - Moved the provide forms to the end of the files. -07.07.96: - Added the drag and drop interface. With that it is possible - to insert links and images by just Meta Button 1 clicking - on its source and destination. -01.03.96: - Added the function `tmpl-insert-template-file'. -18.02.96: - -- BUILDED the version 4.16 of the package -- -17.02.96: - Added the mailto link. -03.02.96: - Fixed the 'void function font-lock-hack-keywords' bug. -15.10.95: - Added support for the swedish ISO-Characters aring and Aring. - It was a patch from Ola Stromfors . -17.09.95: - It is now possible to disable the keybindings for the ISO Latin 1 - character entities. - -- BUILDED the version 4.15 of the package -- -05.09.95: - Fixed a bug in the changed comment functions. - Fixed a description typo. - -- BUILDED the version 4.14 of the package -- -24.08.95: - Fixed the new keybindings for the Emacs 19. -22.08.95: - Added smart functions for inserting <,> or their html entities. - Added the function 'hm--html-send-buffer-to-netscape' to support - netscape. - Added a menu item to view the WWW page of the package. - -- BUILDED the version 4.13 of the package -- -18.08.95: - Fixed the Makefile to include also the file hm--html-keys.el. - Fixed the 'missing util-return-end-of-line' bug. - Fixed the read-file-name bug in the Emacs 19. - Fixed a bug in the changed comment functions. -29.07.95: - Fixed some bugs in the table code. - New, better and more key bindings. - Added functions to insert ISO 8851-1 characters as html entities. - Thanks to Berthold Crysmann for - providing the code for it. - -- BUILDED the version 4.12 of the package -- -12.05.95: - Changed the color handling functions, so that the font-lock colors - are now longer overwritten by this mode. - Added functions to insert the paragraph element with start and - end tag. - Applied a patch from Noriaki Seki , - which fixes a bug in searching the string . - Fixed a typo in hm--html-load-config-files (Thanks to - "Valeriy E. Ushakov" ). - Added a command to insert a element as suggested by - ssd@tad.eds.com (Sean Dowd). - Fixed a typo in hm--html-set-point-for-signature. - Added a new template file: frame.tmpl. - Changed the name of command-description-template-2.html to - command-description.tmpl and deleted the file - command-description-template.html. - Added the new menu item: "Frame Template" as suggested by - ssd@tad.eds.com (Sean Dowd). - Fixed a bug hm--html-remove-numeric-names (Thanks to - D-P Deng ). - Added a command to submit bug reports (suggested by - D-P Deng ). - Changed `(defconst html-font-lock-keywords' to - `(defvar html-font-lock-keywords' (suggested by - rickb@isdn-szerelem.mti.sgi.com (Rick Braumoeller). - Fixed the table functions. - -- BUILDED the version 4.11 of the package -- -02.03.95: - -- BUILDED the version 4.8 of the package -- - Included the changes from the XEmacs 19.12 Beta 26. - Added Support for the finder package. - -- BUILDED the version 4.9 of the package -- - Fixed some minor documentation bugs. - -- BUILDED the version 4.10 of the package -- -30.03.95: - Changed all calls of `concat', so that no longer numbers are - given as arguments to concat. - Removed the file .hm--html-configuration.el from the distribution. - This does not mean, that the file is no longer supported. The - file was only an example and the user has to build his own one. - The example is now given in the README file. - Fixed a bug in the region minor mode. - -14.01.95: - -- BUILDED the version 4.7 of the package -- -12.01.95: - Changed the behaviour of the function `hm--html-add-table'. -06.01.95: - Added the variable `hm--html-user-config-file', as onother way - to specify the user config file. - -- BUILDED the version 4.6 of the package -- -04.01.95: - Added functions to insert tables. - -- BUILDED the version 4.5 of the package -- -03.01.95: - Faces are only modified, if they don't exist (I hope :-). - html-view.el works now with Mosaic 2.4. - `hm--html-add-full-html-frame' now tries only to insert a signature, - if `hm--html-signature-file' is non-nil. - Added the functions: - `hm--html-add-strikethru' and `hm--html-add-strikethru-to-region', - `hm--html-add-superscript' and `hm--html-add-superscript-to-region', - `hm--html-add-subscript' and `hm--html-add-subscript-to-region', - `hm--html-add-command' and `hm--html-add-command-to-region', - `hm--html-add-argument' and `hm--html-add-argument-to-region', - `hm--html-add-quote' and `hm--html-add-quote-to-region', - `hm--html-add-person' and `hm--html-add-person-to-region', - `hm--html-add-acronym' and `hm--html-add-acronym-to-region', - `hm--html-add-abbrevation' and `hm--html-add-abbrevation-to-region', - `hm--html-add-literature' and `hm--html-add-literature-to-region', - `hm--html-add-abstract' and `hm--html-add-abstract-to-region', - `hm--html-add-footnote' and `hm--html-add-footnote-to-region', - `hm--html-add-margin' and `hm--html-add-margin-to-region', - `hm--html-add-author' and `hm--html-add-author-to-region', - `hm--html-add-publication' and `hm--html-add-publication-to-region', - `hm--html-add-editor' and `hm--html-add-editor-to-region', - `hm--html-add-credits' and `hm--html-add-credits-to-region', - `hm--html-add-copyright' and `hm--html-add-copyright-to-region', - `hm--html-add-isbn' and `hm--html-add-isbn-to-region', - `hm--html-form-add-input-integer', - `hm--html-form-add-input-float', - `hm--html-form-add-input-date', - `hm--html-form-add-input-url', - `hm--html-form-add-input-scribble', - `hm--html-form-add-input-audio'. -15.03.94: - -- ANNOUNCEMENT of version 4.0 of the package -- - Added the missing file hm--date.el to the package. - Changed the line ` (let ((config-file (format "/tmp/xmosaic.%d"' - to `(let ((config-file (format "/tmp/Mosaic.%d"' in the file - html-mode.el for the new Mosaic. -03.03.94: - Deleted the wrong "external viewer stuff" for the include images. -17.02.94: - Fixed a bug in the function `hm--html-insert-changed-comment'. - -- ANNOUNCEMENT of version 3.9 of the package -- -14.02.94: - Changed the function adapt-emacsp to adapt-emacs19p. - -- ANNOUNCEMENT of version 3.8 of the package -- -13.02.94: - One can now set the font lock color also in the GNU Emacs 19. - Deleted the highlighting stuff. -01.02.94: - Fixed a lot of spelling errors by jml. -18.01.94: - -- ANNOUNCEMENT of version 3.7 of the package -- -11.01.94: - Fixed a bug in html-view.el. -10.01.94: - Fixed a bug in the function read-number. - The automatic switch between region and noregion commands is now - working also in the GNU Emacs 19. - Fixed a bug in the region popup menu fo novice users. - The font-lock-mode (except of the use of colors) is now working in - then GNU Emacs 19. - -- ANNOUNCEMENT of version 3.6 of the package -- -09.01.94: - Added the highlighting feature of the examples for the GNU Emacs 19. -07.01.94: - The pulldown menu and the popup menus are now working in the - GNU Emacs 19. - -- ANNOUNCEMENT of version 3.5 of the package -- -29.12.93: - Added a function to insert the image input field. - Added a function to insert the form tags to an active region. - Changed the function hm--html-select-directory. - Added a function to remove numeric names. - The variable hm--html-delete-wrong-path-prefix can now be used as - string and as list of strings. Therfore it is now possible to - specify more than one path prefixes, which should be removed. - Changed the pulldown menu. - The package can now be loaded in the GNU Emacs 19. But the menus - doesn't work correct and the functions are not tested. -28.12.93: - Added a function to expand templates (Look at templates.el). - Whitespaces are now allowed between the closing bracket of the date - and the tag , if you want to update the date of the document. - Fixed the wrong use of the html command . - Fixed a little Bug in the function, which includes the tags for a form. - The config files are now searched on standard places, if no environment - variables are specified. - Changed the file html-view.el for the use of the Mosaic-2.1. It uses - now also the variable html-sigusr1-signal-value instead of a hard coded - value for the SIGUSR1 value. - Added a function to insert the isindex input field in a form tag. -15.12.93: - -- ANNOUNCEMENT of version 3.0 of the package -- - -11.12.93: - New functions, to insert the tags
    ,
    and

    (

    without a - leading Blank). - Fixed a Bug in the function hm--html-add-description-list-to-region - (

    instead of
    ). - Added the function hm--html-add-normal-link-to-region to fix the - problem with inactivating the region during the link generation. - Added functions to insert direct links to wais server - (HREF="wais://...). - Changed the wrong functionnamess html-add-definion-to-region and - html-add-definion in the menus to hm--html-add-definion-to-region - and hm--html-add-definion (the old symbols were void). - Added function to insert middle aligned inline images. - Added the 'ALT'- attribute to the 'add-image'- functions. - Changed the submenu "Inligned images". - Added support for the server side include directives. - Added functions to insert "created" and "changed" comments. - Added function to update the date in the title. - Added support for forms. -27.10.93: - Setting of hm--html-font-lock-color in one of the files - .hm--html-configuration.el or hm--html-configuration.el to determine - the color of the html-tags works now correct. -24.10.93: - -- ANNOUNCEMENT of version 2.0 of the package -- - The file hm--date.el is now also in this package. - Deleted the numeric anchor name stuff altogether. Therefore the - package can now use the version 2.1 of Marc Andreessens html-mode.el - instead of the version 2.0. - Added some keytable entrys. - Added the minor mode html-region-mode, which is active, if a region - is active. The minor-mode has its own keytable. That is why it is now - possible to use the same key sequences with different two functions, - one for adding something to an active region and one for adding some- - thing without a region. - All keys, without the keys which are defined by Marc Andreessen in - his file html-mode.el, are now defined in the general configuration - file hm--html-configuration.el. -25.09.93: - Fixed the wrong string "adress". - Added functions and menu items to insert html, head, and body elements - and to insert a complete html frame with the above elements, the title - the header and the signature. - The functions, which adds the header and the title at the same time - are now only using the header size 1. - Added functions for inserting underline and definition styles. - Changed the menu "Formated" according to the HTML quick reference - from Michael Grobe. - Changed the menu item name "Fixed" to "Typewriter". - Added functions to insert directory lists. - Changed the names of menu items in the submenu "Structure" according - to the HTML quick reference from Michael Grobe. -23.09.93: - Changed the functions to add the signature and the title. - This functions uses now the new tags , , - , and to places the signature and - the title in a html-file. - Fixed also some minor bugs; - - -Local Variables: -mode: text -minor-mode: auto-fill-mode -fill-prefix: " " -End: \ No newline at end of file diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/README --- a/lisp/hm--html-menus/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,286 +0,0 @@ -This README file describes the emacs lisp package hm--html-menus-5.8. - -The package provides functions and various popup and pulldown menus -for a html mode called hm--html-mode, a mode for writing html pages. -It provides also a minor mode (hm--html-minor-mode), which can be used -together with another html major mode, like the psgml-html mode in the -XEmacs 19.15. - -It has an interface to view the html documents in a W3 browser with -Netscape, the w3-package from William M. Perry and Mosaic with the -file html-view.el from Ron Tapia. It provides also a drag and drop -interface, which makes it very easy to insert links or images, by just -clicking on them. - -Look at the file NEWS, to see what is new in this release. Some -of the major changes are also listed in the ANNOUNCEMENT file. - -You should (but don't need) also get the w3 package from: - - cs.indiana.edu:/pub/elisp/w3/w3.tar.z - -which provides an world wide web browser mode for the xemacs, emacs -and epoch. - - -This package is tested with the xemacs 19.15 on Suns with SunOS 5.5 -and on PC's with linux. But it should work also on other (possibly -only UNIX ?) platforms. - -Read the file README-EMACS-19, if you want to use this package with -GNU Emacs 19. - -Thanks to Richard Stallman, who helped me to port this package to the -Emacs 19, thanks to John Ladwig, who corrected a lot of the text and -comments in this package and thanks to Michael D. Harnois, who -corrected the Texinfo documentation and to all the other people like -Jerry G. DeLapp, Andreas Ernst, Bob Weiner, Luca Pisati, Guylaine -Prat, Gary D. Foster, Martin Buchholz, Ola Stromfors, Berthold -Crysmann, Noriaki Seki, Valeriy E. Ushakov, D-P Deng, Rick -Braumoeller, Sean Dowd and so on, who provided code, ideas, bug fixes -or bug reports for this package. - - -The package consists of the following files: - -README : this file; -README-EMACS-19 : only for the GNU Emacs 19 user; -ANNOUNCEMENT : Text of the announcement of this package; -LSM : Entry for the Linux Software Map; -NEWS : Change logfile; -adapt.el : provides functions to use this package - with the GNU Emacs 19 -hm--html.el : provides functions to write html pages; - in this file are all commands defined, - which inserts html elements and entities; -hm--html-indentation.el : provides the indentation stuff; -hm--html-keys.el : provides the keybindings; -hm--html-menu.el : provides the menus; -hm--html-mode.el : provides the functions for the definition - of the hm--html-mode; this is now the - main file of the package; -hm--html-not-standard.el : provides functions to insert some - non standard html elements; - this file is not evaluated by default; -hm--html-configuration.el : configuration file for the html mode; - choose this as system configuration file; -hm--html-drag-and-drop.el : defines the HTML- specific functions - for the drag and drop interface; -hm--date.el : defines the function hm--date, which - returns the date in the format - "day-month-year" like "30-Jun-1993". -html-view.el : Ron Tapia's html-view.el to view html-pages - in the Xmosaic; it is patched for the use - with the xemacs; -internal-drag-and-drop.el : provides the general (html-mode - independend functions) of the drag and - drop interface; -templates.doc : describes the syntax of the templates - provided in the file tmpl-minor-mode.el -tmpl-minor-mode.el : provides functions for the tmpl-minor-mode; - with this mode you can expand templates, - which are described in the file - templates-syntax.doc (look at the files - command-description.html.tmpl and - frame.html.tmpl for examples); - templates can be expanded automatically, if - you include a file with templates via the - html pulldown menu item "Templates ..." - or with the item "Templates (fixed dirs)..."; -command-description.html.tmpl : Templatefile for the use with the - tmpl-minor-mode; -frame.html.tmpl : Templatefile, provides a simple frame; -drop : xbm file with the drag and drop mouse pointer -dropmsk : xbm file with mask for the d&d mouse pointer -doc/hm--html-mode.texinfo : Package documentation in the Texinfo format; -doc/umlaute.texinfo : Texinfo include file for german vowel - mutation (deutsche Umlaute); - - - - -INSTALLATION: -============= - -Note: In this version the setting of the environment variables -HTML_CONFIG_FILE and HTML_USER_CONFIG_FILE are no longer necessary, -if you put the user configuration file in the home directory and -the system configuration file in one of the load path directories -of your XEmacs or Emacs 19. - -1. Put all the *.el files in one of your xemacs (or emacs) lisp load - directories (i.e. lisp/packages). - -2. For XEmacs only: Put the files drop and dropmask in the - directory specified by the lisp variable `idd-data-directory'. - By default this directory is /lib/xemacs-/etc/idd. - (eg: if you've installed the Xemacs 19.15 in /usr/local, it is - /usr/local/xemacs/lib/xemacs-19.15/etc/idd). - If you'd like to put the files in another directory, then you must - set the variable `idd-data-directory' to this directory (eg: - (setq idd-data-directory "/usr/local/data") - -3. Put the following in your .emacs (or default.el or site-init.el): - - (autoload 'hm--html-mode "hm--html-mode" "HTML major mode." t) - (autoload 'hm--html-minor-mode "hm--html-mode" "HTML minor mode." t) - (or (assoc "\\.html$" auto-mode-alist) - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist))) - - (autoload 'tmpl-expand-templates-in-buffer "tmpl-minor-mode" - "Expand all templates in the current buffer." t) - - (autoload 'html-view-start-mosaic "html-view" "Start Xmosaic." t) - (autoload 'html-view-view-buffer - "html-view" - "View the current buffer in Xmosaic." - t) - (autoload 'html-view-view-file - "html-view" - "View a file in Xmosaic." - t) - (autoload 'html-view-goto-url - "html-view" - "Goto url in Xmosaic." - t) - (autoload 'html-view-get-display - "html-view" - "Get the display for Xmosaic (i.e. hostxy:0.0)." - t) - (autoload 'w3-preview-this-buffer "w3" "WWW Previewer" t) - (autoload 'w3 "w3" "WWW Browser" t) - (autoload 'w3-open-local "w3" "Open local file for WWW browsing" t) - (autoload 'w3-fetch "w3" "Open remote file for WWW browsing" t) - (autoload 'w3-use-hotlist "w3" "Use shortcuts to view WWW docs" t) - - The above lines assume that you have not installed already another - html mode. If this isn't true, then you should use the following - - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist)) - - instead of - - (or (assoc "\\.html$" auto-mode-alist) - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist))) - - It could also be, that you've already the autoload lines for - the w3 package in your emacs. - - If you want to use this the hm--html-minor-mode together - with the psgml-html modes, then you should add the following - line (works only in XEmacs version >= 19.15 and != 20.0) - (add-hook 'html-mode-hook 'hm--html-minor-mode) - -4. Set (if you want) the environment variable HTML_CONFIG_FILE - to the html system configuration file i.e.: - setenv HTML_CONFIG_FILE /usr/xemacs/lisp/hm--html-configuration.el - -5. Set (if you want) the environment variable HTML_USER_CONFIG_FILE to - the html user configuration file i.e.: - setenv HTML_USER_CONFIG_FILE ~/.hm--html-configuration.el - And put the file .hm--html-configuration.el in your Home directory. - An example for this user specific file is given below. - -6. Check the files hm--html-configuration.el and - .hm--html-configuration.el whether all variables are set suitable for - you and your site or not. You can make changes in both of these files - and you can also create a site specific configuration file, called - hm--html-site-config-file.el and specified by the lisp variable - hm--html-site-config-file or the environment variable - HTML_SITE_CONFIG_FILE, and put your site specific settings in this - file. A site specific configuration file is useful, if you're a - system administrator and want to make site specific settings - without changing a file of this package or use the normal emacs - configuration files. - Note that .hm--html-configuration.el precedes the settings in - hm--html-site-config-file.el, which precedes the settings in - hm--html-configuration.el (user specific configuration overwrites - site specific configuration and site specific configuration - overwrites the settings made by the package). - - Look at first at the following variables: - - hm--html-signaturefile - hm--html-username - hm--html-template-dir - hm--html-favorite-http-server-host-name - html-document-previewer - html-view-mosaic-command - w3-default-homepage - -7. If you want to use templatefiles, you should put these files - in the directory to which `hm--html-template-dir' points. - You can use the file command-description.html.tmpl as - an example. - -8. If you don't want to use the feature of adding html comments - about the creation date and author and with a change log, then - you should set the following three variables to nil: - hm--html-automatic-changed-comment - hm--html-automatic-created-comment - -9. If you don't want to set a date in the title line, than you should - set the following to nil: - hm--html-automatic-new-date - -The following is an example for a user specific configuration file -called .hm--html-configuration.el. You should put such a file in your -home directory and put all the variable settings in it, which are user -specific. - ----- BEGIN of .hm--html-configuration.el ---- -;;; Private html configuration file - -;; Signature file -(setq hm--html-signature-file - "http://www.tnt.uni-hannover.de:80/data/info/www/tnt/org/tnt/whois/wissmit/muenkel.html") - -;; Username (Only necessary if it differs from the passwd entry) -(setq hm--html-username "Heiko Münkel") - - -;; X Window System display for the html-view -(setq html-view-display "daedalus:0.0") - - -;; Use the expert menus? -(setq hm--html-expert t) - - -;; Delete the automounter path prefix /tmp_mount -(setq hm--html-delete-wrong-path-prefix "/tmp_mount") - - -;;; -; -; W3 - -;; Default Home Page for w3-mode in lemacs or GNU Emacs -(setq w3-default-homepage "file:/home/muenkel/data/docs/www/home.html") ----- END of .hm--html-configuration.el ---- - - -Every hm--*.el file has a description and installation part. Look at first -at these parts, if you have any questions. - -Look at first at the configuration files, if you have problems with -this package! - -You should also look at the Texinfo documentation of this package. - -There is a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html - - -Please send any bug reports, fixes or comments to - muenkel@daedalus.tnt.uni-hannover.de - - -I hope these files will be useful, - -Heiko - - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/adapt.el --- a/lisp/hm--html-menus/adapt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,490 +0,0 @@ -;;; $Id: adapt.el,v 1.5 1997/07/26 22:09:44 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; General functions to port XEmacs functions to GNU Emacs 19. -;;; -;;; Installation: -;;; -;;; Put this file in one of your lisp load directories. -;;; - - -(defun adapt-xemacsp () - "Returns non nil if the editor is the XEmacs." - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - - -(defun adapt-lemacsp () - "Returns non nil if the editor is the XEmacs. -Old version, use `adapt-xemacsp' instead of this." - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - - -(defun adapt-emacs19p () - "Returns non nil if the editor is the GNU Emacs 19." - (and - (not (adapt-xemacsp)) - (string= (substring emacs-version 0 2) "19"))) - -;;; Functions, which don't exist in both emacs versions - -(defun adapt-region-active-p () - "Returns t, if a region is active." - (if (adapt-xemacsp) - (mark) - mark-active)) - -(if (not (fboundp 'file-remote-p)) - (defun file-remote-p (file) - "Test wether file resides on the local system. -The special value 'unknown is returned if no remote file acess package -has been loaded." - (if (not (featurep 'ange-ftp)) - (require 'ange-ftp)) - (if (not (fboundp 'ange-ftp-ftp-p)) - nil ; better than nothing, if no ange-ftp-ftp-p exists - (ange-ftp-ftp-path file)))) - - -;;; Functions, which don't exist in the Emacs 19 -(if (adapt-emacs19p) - (progn - (load-library "lucid") - - (load-library "lmenu") - - (if window-system - (require 'font-lock) - ) - - (make-face 'font-lock-comment-face) - - (defun read-number (prompt &optional integers-only) - "Reads a number from the minibuffer." - (interactive) - (let ((error t) - (number nil)) - (if integers-only - (while error - (let ((input-string (read-string prompt))) - (setq number (if (string= "" input-string) - nil - (read input-string))) - (if (integerp number) - (setq error nil)))) - (while error - (let ((input-string (read-string prompt))) - (setq number (if (string= "" input-string) - nil - (read input-string))) - (if (numberp number) - (setq error nil))))) - number)) - - (defvar original-read-string-function nil - "Points to the original Emacs 19 function read-string.") - - (if (not original-read-string-function) - (fset 'original-read-string-function - (symbol-function 'read-string))) - - (defun read-string (prompt &optional initial-contents history) - "Return a string from the minibuffer, prompting with string PROMPT. -If non-nil, optional second arg INITIAL-CONTENTS is a string to insert -in the minibuffer before reading. -Third arg HISTORY, if non-nil, specifies a history list." - (read-from-minibuffer prompt initial-contents nil nil history)) - - (defun make-extent (beg end &optional buffer) - (make-overlay beg end buffer)) - - (defun set-extent-property (extent prop value) - (if (eq prop 'duplicable) - (cond ((and value (not (overlay-get extent prop))) - ;; If becoming duplicable, - ;; copy all overlay props to text props. - (add-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent))) - ;; If becoming no longer duplicable, remove these text props. - ((and (not value) (overlay-get extent prop)) - (remove-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent)))) - ;; If extent is already duplicable, put this property - ;; on the text as well as on the overlay. - (if (overlay-get extent 'duplicable) - (put-text-property (overlay-start extent) - (overlay-end extent) - prop value (overlay-buffer extent)))) - (overlay-put extent prop value)) - - (defun set-extent-face (extent face) - (set-extent-property extent 'face face)) - - (defun delete-extent (extent) - (set-extent-property extent 'duplicable nil) - (delete-overlay extent)) - -; (defun make-extent (from to &optional buffer) -; "Make extent for range [FROM, TO) in BUFFER -- BUFFER defaults to -;current buffer. Insertions at point TO will be outside of the extent; -;insertions at FROM will be inside the extent (and the extent will grow.). -;This is only a simple emulation of the Lucid Emacs extents !" -; (list 'extent from to buffer)) -; -; (defun set-extent-face (extent face) -; "Make the given EXTENT have the graphic attributes specified by FACE. -;This is only a simple emulation of the Lucid Emacs extents !" -; (put-text-property (car (cdr extent)) -; (car (cdr (cdr extent))) -; 'face -; face -; (car (cdr (cdr (cdr extent)))))) -; -; (defun delete-extent (extent_obj) -; "Remove EXTENT from its buffer; this does not modify the buffer's text, -;only its display properties. -;This is only a simple emulation of the Lucid Emacs extents !" -; (remove-text-properties (car (cdr extent_obj)) -; (car (cdr (cdr extent_obj))) -; (list 'face nil) -; (car (cdr (cdr (cdr extent_obj)))))) -; - - (if (not (fboundp 'emacs-pid)) - (defun emacs-pid () - "Return the process ID of Emacs, as an integer. -This is a dummy function for old versions of the Emacs 19. -You should install a new version, which has `emacs-pid' implemented." - 0) - ) - - (if (not (fboundp 'facep)) - (defun facep (object) - "Whether OBJECT is a FACE. -It's only a dummy function in the Emacs 19, which returns always nil." - nil)) - -; (if (not (fboundp 'set-extent-property)) -; (defun set-extent-property (extent property value) -; "Change a property of an extent. -;Only a dummy version in Emacs 19.")) - - (if (not (fboundp 'region-active-p)) - (defun region-active-p () - "Non-nil iff the region is active. -If `zmacs-regions' is true, this is equivalent to `region-exists-p'. -Otherwise, this function always returns false." - (adapt-region-active-p))) - - (if (not (fboundp 'next-command-event)) - (defun next-command-event (&optional event prompt) - "Unlike the XEmacs version it reads the next event, if -it is a command event or not. - -Return the next available \"user\" event. - Pass this object to `dispatch-event' to handle it. - - If EVENT is non-nil, it should be an event object and will be filled in - and returned; otherwise a new event object will be created and returned. - If PROMPT is non-nil, it should be a string and will be displayed in the - echo area while this function is waiting for an event. - - The event returned will be a keyboard, mouse press, or mouse release event. - If there are non-command events available (mouse motion, sub-process output, - etc) then these will be executed (with `dispatch-event') and discarded. This - function is provided as a convenience; it is equivalent to the lisp code - - (while (progn - (next-event event prompt) - (not (or (key-press-event-p event) - (button-press-event-p event) - (button-release-event-p event) - (misc-user-event-p event)))) - (dispatch-event event))" - (message prompt) - (or event - (read-event)))) - - (if (not (fboundp 'button-event-p)) - (defun button-event-p (obj) - "True if OBJ is a button-press or button-release event object." - (and (eventp obj) - (or (eq 'mouse-1 (event-basic-type obj)) - (eq 'mouse-2 (event-basic-type obj)) - (eq 'mouse-3 (event-basic-type obj)) - (eq 'down-mouse-1 (event-basic-type obj)) - (eq 'down-mouse-2 (event-basic-type obj)) - (eq 'down-mouse-3 (event-basic-type obj)) - (eq 'up-mouse-1 (event-basic-type obj)) - (eq 'up-mouse-2 (event-basic-type obj)) - (eq 'up-mouse-3 (event-basic-type obj)) - (eq 'drag-mouse-1 (event-basic-type obj)) - (eq 'drag-mouse-2 (event-basic-type obj)) - (eq 'drag-mouse-3 (event-basic-type obj)) - )))) - - (if (not (fboundp 'button-drag-event-p)) - (defun button-drag-event-p (obj) - "True if OBJ is a mouse-button-drag event object." - (and (button-event-p obj) - (member 'drag (event-modifiers obj))))) - - (if (not (fboundp 'button-press-event-p)) - (defun button-press-event-p (obj) - "True if OBJ is a mouse-button-press event object." - (and (button-event-p obj) - (member 'down (event-modifiers obj))))) - - (if (not (fboundp 'button-release-event-p)) - (defun button-release-event-p (obj) - "True if OBJ is a mouse-button-release event object." - (and (button-event-p obj) - (not (button-press-event-p obj))))) - - (if (not (fboundp 'button-click-event-p)) - (defun button-click-event-p (obj) - "True if OBJ is a click event obkect." - ;; only for the Emacs 19 - ;; doesn't exist and can't (?) exist in the XEmacs - (and (button-event-p obj) - (member 'click (event-modifiers obj))))) - - (if (not (fboundp 'mouse-event-p)) - (defun mouse-event-p (obj) - "True if OBJ is a button-press, button-release, or mouse-motion event object." - (or (button-event-p obj) - (member 'drag (event-modifiers obj))))) - - (if (not (fboundp 'event-window)) - (defun event-window (event) - "Return the window of the given mouse EVENT. -This may be nil if the event occurred in the border or over a toolbar. -The modeline is considered to be in the window it represents. - -If the EVENT is a mouse drag event, then the end event window is returned." - (if (button-drag-event-p event) - (and (listp event) - (third event) - (listp (third event)) - (windowp (car (third event))) - (car (third event))) - (and (eventp event) - (listp event) - (second event) - (listp (second event)) - (windowp (car (second event))) - (car (second event)))))) - -; (listp (cdr event)) -; (listp (car (cdr event))) -; (windowp (car (car (cdr event)))) -; (car (car (cdr event)))))) - - (if (not (fboundp 'event-buffer)) - (defun event-buffer (event) - "Given a mouse-motion, button-press, or button-release event, -return the buffer on which that event occurred. This will be nil for -non-mouse events. If event-over-text-area-p is nil, this will also be nil." - (if (button-event-p event) - (window-buffer (event-window event))))) - - - (if (not (fboundp 'event-closest-point)) - (defun event-closest-point (event) - "Return the character position of the given mouse EVENT. -If the EVENT did not occur over a window or over text, return the -closest point to the location of the EVENT. If the Y pixel position -overlaps a window and the X pixel position is to the left of that -window, the closest point is the beginning of the line containing the -Y position. If the Y pixel position overlaps a window and the X pixel -position is to the right of that window, the closest point is the end -of the line containing the Y position. If the Y pixel position is -above a window, return 0. If it is below a window, return the value -of (window-end). - -If the EVENT is a drag event, the event-end will be used." - (if (button-drag-event-p event) - (posn-point (event-end event)) - (posn-point (event-start event))))) - - (if (not (fboundp 'add-minor-mode)) - (defun add-minor-mode (toggle - name - &optional - keymap - after - toggle-fun) - "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. -TOGGLE is a symbol whose value as a variable specifies whether the -minor mode is active. NAME is the name that should appear in the -modeline (it should be a string beginning with a space). KEYMAP is a -keymap to make active when the minor mode is active. AFTER is the -toggling symbol used for another minor mode. If AFTER is non-nil, -then it is used to position the new mode in the minor-mode alists. - -TOGGLE-FUN is only a dummy variable in the Emacs 19. In the XEmacs -it has the following description: -TOGGLE-FUN specifies an interactive function that is called to toggle -the mode on and off; this affects what happens when button2 is pressed -on the mode, and when button3 is pressed somewhere in the list of -modes. If TOGGLE-FUN is nil and TOGGLE names an interactive function, -TOGGLE is used as the toggle function. - -Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map) - -WARNING: THIS FUNCTION ISN'T READ YET." - (if after - (add-minor-mode-1 toggle name keymap after) - (if (not (assq toggle minor-mode-alist)) - (progn - (setq minor-mode-alist - (cons (list toggle name) - minor-mode-alist)))) - (if (not (assq toggle minor-mode-map-alist)) - (progn - (setq minor-mode-map-alist - (cons (cons toggle keymap) - minor-mode-map-alist)))) - )) - ) - - (if (not (fboundp 'redraw-modeline)) - (defalias 'redraw-modeline 'force-mode-line-update)) - - (if (not (fboundp 'mouse-track)) - (defalias 'mouse-track 'mouse-drag-region)) - - (if (not (fboundp 'windows-of-buffer)) - (defun windows-of-buffer (&optional buffer) - "Returns a list of windows that have BUFFER in them. -If BUFFER is not specified, the current buffer will be used." - (get-buffer-window-list buffer))) - - (if (not (boundp 'help-selects-help-window)) - (defvar help-selects-help-window t - "*If nil, use the \"old Emacs\" behavior for Help buffers. -This just displays the buffer in another window, rather than selecting -the window.")) - - (if (not (fboundp 'with-displaying-help-buffer)) - (defun with-displaying-help-buffer (thunk) - (let ((winconfig (current-window-configuration)) - (was-one-window (one-window-p)) - (help-not-visible - (not (and (windows-of-buffer "*Help*") ;shortcut - (member (selected-frame) - (mapcar 'window-frame - (windows-of-buffer "*Help*"))))))) - (prog1 (with-output-to-temp-buffer "*Help*" - (prog1 (funcall thunk) - (save-excursion - (set-buffer standard-output) - (help-mode)))) - (let ((helpwin (get-buffer-window "*Help*"))) - (if helpwin - (progn - (save-excursion - (set-buffer (window-buffer helpwin)) - ;;If the *Help* buffer is already displayed on this - ;; frame, don't override the previous configuration -; (if help-not-visible -; (set-frame-property -; (selected-frame) -; 'help-window-config winconfig))) - ) - (if help-selects-help-window - (select-window helpwin)) - (cond ((eq helpwin (selected-window)) - (message - (substitute-command-keys - "\\[scroll-up] to scroll the help." - ))) - (was-one-window - (message - (substitute-command-keys - "\\[scroll-other-window] to scroll the help." - ))) - (t - (message - (substitute-command-keys - "\\[scroll-other-window] to scroll the help." - ))))))))))) - - (if (not (fboundp 'set-extent-mouse-face)) - (defun set-extent-mouse-face (extent face) - "Set the face used to highlight EXTENT when the mouse passes over it. -FACE can also be a list of faces, and all faces listed will apply, -with faces earlier in the list taking priority over those later in the -list. - -In the Emacs 19, the argument FACE could not be a list of faces." - (put-text-property (overlay-start extent) - (overlay-end extent) - 'mouse-face face) - )) - - - (if (not (fboundp 'read-directory-name)) - (defalias 'read-directory-name 'read-file-name)) - - (if (not (fboundp 'define-obsolete-function-alias)) - (defsubst define-obsolete-function-alias (oldfun newfun) - "Define OLDFUN as an obsolete alias for function NEWFUN. -This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN -as obsolete." - (define-function oldfun newfun) - (make-obsolete oldfun newfun))) - - (if (not (fboundp 'define-obsolete-variable-alias)) - (defsubst define-obsolete-variable-alias (oldvar newvar) - "Define OLDVAR as an obsolete alias for varction NEWVAR. -This makes referencing or setting OLDVAR equivalent to referencing or -setting NEWVAR and marks OLDVAR as obsolete. - -It is not full implemented in the Emacs 19, because of the lack of -the function defvaralias.y" - ;;(defvaralias oldvar newvar) <- doesn't exist in the Emacs 19.34 - (make-obsolete-variable oldvar newvar))) - - (if (not (fboundp 'defgroup)) - (defmacro defgroup (symbol members doc &rest args) - "Dummy definition. Used, if the custom package isn't installed. -The dummy definition makes nothing, it returns only nil." - nil)) - - (if (not (fboundp 'defcustom)) - (defmacro defcustom (symbol value doc &rest args) - "Simulates the defcustom definition from the custom package. -It calles a `defvar' with the arguments SYMBOL, VALUE and DOC." - `(defvar ,symbol ,value ,doc))) - - - )) - - -(provide 'adapt) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/auto-autoloads.el --- a/lisp/hm--html-menus/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'hm--html-menus-autoloads) (error "Already loaded")) - -;;;### (autoloads (hm--html-minor-mode hm--html-mode) "hm--html-mode" "hm--html-menus/hm--html-mode.el") - -(autoload 'hm--html-mode "hm--html-mode" "\ -Major mode for editing HTML hypertext documents. -Special commands:\\{hm--html-mode-map} -Turning on hm--html-mode calls the value of the variable hm--html-mode-hook, -if that value is non-nil." t nil) - -(autoload 'hm--html-minor-mode "hm--html-mode" "\ -Toggle hm--html-minor-mode. -With arg, turn hm--html-minor-mode on iff arg is positive." t nil) - -;;;*** - -;;;### (autoloads (html-view-get-display html-view-goto-url html-view-view-buffer html-view-view-file html-view-start-mosaic) "html-view" "hm--html-menus/html-view.el") - -(autoload 'html-view-start-mosaic "html-view" "\ -Start Mosaic." t nil) - -(autoload 'html-view-view-file "html-view" "\ -View an html file with Mosaic." t nil) - -(autoload 'html-view-view-buffer "html-view" "\ -View html buffer with Mosaic. -If BUFFER-TO-VIEW is nil, then the current buffer is used." t nil) - -(autoload 'html-view-goto-url "html-view" "\ -Goto an URL in Mosaic." t nil) - -(autoload 'html-view-get-display "html-view" "\ -Get the display for Mosaic." t nil) - -;;;*** - -;;;### (autoloads (tmpl-insert-template-file tmpl-insert-template-file-from-fixed-dirs tmpl-expand-templates-in-buffer tmpl-expand-templates-in-region) "tmpl-minor-mode" "hm--html-menus/tmpl-minor-mode.el") - -(autoload 'tmpl-expand-templates-in-region "tmpl-minor-mode" "\ -Expands the templates in the region from BEGIN to END. -If BEGIN and END are nil, then the current region is used." t nil) - -(autoload 'tmpl-expand-templates-in-buffer "tmpl-minor-mode" "\ -Expands all templates in the current buffer." t nil) - -(autoload 'tmpl-insert-template-file-from-fixed-dirs "tmpl-minor-mode" "\ -Inserts a template FILE and expands it, if `tmpl-automatic-expand' is t. -This command tries to read the template file from a list of -predefined directories (look at `tmpl-template-dir-list') and it filters -the contents of these directories with the regular expression -`tmpl-filter-regexp' (look also at this variable). -The command uses a history variable, which could be changed with the -variable `tmpl-history-variable-name'. - -The user of the command is able to change interactively to another -directory by entering at first the string \"Change the directory\". -This may be too difficult for the user. Therefore another command -called `tmpl-insert-template-file' exist, which doesn't use fixed -directories and filters." t nil) - -(autoload 'tmpl-insert-template-file "tmpl-minor-mode" "\ -Inserts a template FILE and expand it, if `tmpl-automatic-expand' is t. -Look also at `tmpl-template-dir-list', to specify a default template directory. -You should also take a look at `tmpl-insert-template-file-from-fixed-dirs' -which has additional advantages (and disadvantages :-). - -ATTENTION: The interface of this function has changed. The old -function had the argument list (&optional TEMPLATE-DIR AUTOMATIC-EXPAND). -The variables `tmpl-template-dir-list' and `tmpl-automatic-expand' must -now be used instead of the args TEMPLATE-DIR and AUTOMATIC-EXPAND." t nil) - -;;;*** - -(provide 'hm--html-menus-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/command-description.html.tmpl Binary file lisp/hm--html-menus/command-description.html.tmpl has changed diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/custom-load.el --- a/lisp/hm--html-menus/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -(custom-put 'hm--html-links 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-menus 'custom-loads '("hm--html-configuration")) -(custom-put 'mouse 'custom-loads '("internal-drag-and-drop")) -(custom-put 'hm--html-display 'custom-loads '("hm--html-configuration")) -(custom-put 'idd-drag-and-drop 'custom-loads '("internal-drag-and-drop")) -(custom-put 'hypermedia 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-keys 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-indentation 'custom-loads '("hm--html-configuration")) -(custom-put 'data 'custom-loads '("tmpl-minor-mode")) -(custom-put 'hm--html-hooks 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-document-information 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-templates 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-files 'custom-loads '("hm--html-configuration")) -(custom-put 'tmpl-minor 'custom-loads '("tmpl-minor-mode")) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/frame.html.tmpl Binary file lisp/hm--html-menus/frame.html.tmpl has changed diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--date.el --- a/lisp/hm--html-menus/hm--date.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -;;; $Id: hm--date.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ -;;; -;;; Copyright (C) 1993, 1996 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines the function hm--date, which returns the date in the -;;; format "day-month-year" like "30-Jun-1993". -;;; -;;; Installation: -;;; -;;; Put this file in one of your lisp load path directories. -;;; The files which uses this function must only have -;;; following line: -;;; (require 'hm--date) -;;; - - -(provide 'hm--date) - - - -(defun hm--date () - "Returns the current date in the format \"day-month-year\"." - (let* ((time-string (current-time-string)) - (day (substring time-string 8 10)) - (month (substring time-string 4 7)) - (year (substring time-string 20 24))) - (concat day "-" month "-" year))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html-configuration.el --- a/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1040 +0,0 @@ -;;; hm--html-configuration.el - Configurationfile for the html-mode -;;; -;;; $Id: hm--html-configuration.el,v 1.7 1997/07/26 22:09:45 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; This file is for the system wide configuration of the html mode. -;;; User specific configuration should be done in the file -;;; ~/.hm--html-configuration.el, which precedes the settings in -;;; this file. -;;; All settings in this file are done with defvar's, therefore -;;; you could overwrite them also with the function setq in your -;;; .emacs or default.el and so on. -;;; -;;; Installation: -;;; -;;; Put this file in one of your lisp load path directories or -;;; set the environment variable HTML_CONFIG_FILE to this file. -;;; For example: -;;; setenv HTML_CONFIG_FILE "~/data/hm--htm-environment.el" -;;; if you have put this file in the directory "~/data/" -;;; - -;(require 'adapt) - -(defgroup hm--html nil - "A package for writing HTML pages. -It provides a major mode and a minor mode. The minor mode can be -used together with the psgml html-mode." - :group 'hypermedia) - -(defgroup hm--html-files nil - "hm--html configuration files." - :group 'hm--html) - -(defgroup hm--html-document-information nil - "Variables relating to the insertation of document information. -This contains the user name of the document author, his signature, -the creation and change dates, the HTML doctype and the meta element." - :group 'hm--html) - -(defgroup hm--html-menus nil - "Variables relating to the pulldown and popup menus." - :group 'hm--html) - -(defgroup hm--html-links nil - "Variables relating to the insertation of links." - :group 'hm--html) - -(defgroup hm--html-templates nil - "Variables relating to inserting HTML templates." - :group 'hm--html) - -(defgroup hm--html-keys nil - "Variables relating to the key and mouse bindings and drag and drop." - :group 'hm--html) - -(defgroup hm--html-display nil - "Variables relating to the display of the HTML sources and the previewing." - :group 'hm--html) - -(defgroup hm--html-hooks nil - "Hooks relating to the hm--html modes." - :group 'hm--html) - -(defgroup hm--html-indentation nil - "Variables relating to the indentation in the `hm--html-mode'." - :group 'hm--html) - - -;;; The User config file (an proposal of Manoj Srivastava) -(defcustom hm--html-user-config-file nil - "*The location of the users config file. -This variable will only be used, if no environment variable -\"HTML_USER_CONFIG_FILE\" is set. -Example value: \"~/.hm--html-configuration.el\". - -If this is set to nil and no \"HTML_USER_CONFIG_FILE\" is set, -then the file ~/.hm--html-configuration.el will be used. In this case -also the variable `init-file-user' will be respected." - :group 'hm--html-files - :type '(choice (const :tag "~/.hm--html-configuration.el" :value nil) - file)) - -;;; The site specific config file -(defcustom hm--html-site-config-file nil - "*The location of a site specific config file. -This variable will only be used, if no environment variable -\"HTML_SITE_CONFIG_FILE\" is set." - :group 'hm--html-files - :type '(choice (const :tag "No Site Specific Configuration" :value nil) - file)) - -;;; Chose the initial popup menu -(defcustom hm--html-expert nil - "*t : Use the HTML expert popup menu, -nil : Use the HTML novice (simple) menu. - -NOTE: In the Emacs 19 you should set this variable only before - loading the mode." - :group 'hm--html-menus - :type '(choice (const :tag "Use Expert Popup Menu" :value t) - (const :tag "Use Novice Popup Menu" :value nil))) - -;;; Your Signature - -(defcustom hm--html-signature-file nil - "*Your Signature file. -For example: \"http://www.tnt.uni-hannover.de:80/data/info/www/tnt/info/tnt/whois/muenkel.html\"." - :group 'hm--html-document-information - :type '(choice (const :tag "No Signature file" :value nil) - string)) - - -(defcustom hm--html-username nil - "*Your Name for the signature. For example: \"Heiko Münkel\"." - :group 'hm--html-document-information - :type '(choice (const :tag "Use Value Of `(user-full-name)'" :value nil) - string)) - - -;;; HTML Doctype -(defcustom hm--html-html-doctype-version "-//W3C//DTD HTML 3.2 Final//EN" - "*The HTML version. This is used in the doctype element." - :group 'hm--html-document-information - :type 'string) - - -;;; Your favorite server (eg: the name of the host of your own http server) -;;; This is used in some other variables - -(defcustom hm--html-favorite-http-server-host-name "www.tnt.uni-hannover.de" - "*The name of your favorite http server host. It must be specified !" - :group 'hm--html-links - :type 'string) - - -;;; For links to Info Gateways - -(defcustom hm--html-info-hostname:port-alist - '(("www.tnt.uni-hannover.de:8005")) - "*Alist with hostnames and ports for the Info gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-info-hostname:port-default "www.tnt.uni-hannover.de:8005" - "*Default hostname with port for the Info gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-info-path-alist '((1 . "/appl/lemacs/Global/emacs/info") - (2 . "/appl/emacs/info") - (3 . "/appl/gnu/Global/info") - (4 . "/appl/emacs-19/Global/info") - (5 . "/")) - "*Alist with directories for the Info gateway." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to WAIS Gateways - -(defcustom hm--html-wais-hostname:port-alist '(("www.tnt.uni-hannover.de:8001") - ("info.cern.ch:8001")) - "*Alist with hostnames and ports for the WAIS gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-wais-hostname:port-default "www.tnt.uni-hannover.de:8001" - "*Default hostname with port for the WAIS gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-wais-servername:port-alist - '(("wais.tnt.uni-hannover.de:210") - ("daedalus.tnt.uni-hannover.de:21408") - ("ikarus.tnt.uni-hannover.de:21401")) - "*Alist with servernames and ports for the WAIS gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-wais-servername:port-default "www.tnt.uni-hannover.de:210" - "*Default servername with port for the WAIS gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-wais-path-alist nil - "*Alist with directories for the wais gateway." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For links to HTML servers - -(defcustom hm--html-html-hostname:port-alist '(("www.tnt.uni-hannover.de:80") - ("vxcrna.cern.ch:80") - ("www.ncsa.uiuc.edu:80")) - "*Alist with hostnames and ports for the HTML server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-html-hostname:port-default "www.tnt.uni-hannover.de:80" - "*Default hostname with port for the HTML server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-html-path-alist '((1 . "/data/info/www/tnt/") - (2 . "/data/info/www/") - (3 . "/data/info/") - (4 . "/data/") - (5 . "/appl/") - (6 . "/project/") - (7 . "~/") - (8 . "/")) - "*Alist with directories for the HTML server." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to file gateways - -(defcustom hm--html-file-path-alist '((1 . "/data/info/www/tnt/") - (2 . "/data/info/www/") - (3 . "/data/info/") - (4 . "/data/") - (5 . "/appl/") - (6 . "/project/") - (7 . "~/") - (8 . "/")) - "*Alist with directories for the file gateway." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to ftp servers - -(defcustom hm--html-ftp-hostname:port-alist - '(("ftp.tnt.uni-hannover.de") - ("ftp.rrzn.uni-hannover.de") - ("wega.informatik.uni-hannover.de") - ("rusmv1.rus.uni-stuttgart.de") - ("export.lcs.mit.edu") - ) - "*Alist with hostnames and ports for the ftp server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-ftp-hostname:port-default "ftp.rrzn.uni-hannover.de" - "*Default hostname with port for the ftp server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-ftp-path-alist '((1 . "/pub") - (2 . "/pub/gnu") - (3 . "/pub/linux") - (4 . "/pub/unix") - (5 . "/incoming") - (6 . "/")) - "*Alist with directories for the ftp server." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to gopher servers - -(defcustom hm--html-gopher-hostname:port-alist - '(("newsserver.rrzn.uni-hannover.de:70") - ("solaris.rz.tu-clausthal.de:70") - ("veronica.scs.unr.edu:70") - ("pinus.slu.se:70") - ("sunic.sunet.se:70") - ) - "*Alist with hostnames and ports for the gopher server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-gopher-hostname:port-default - "newsserver.rrzn.uni-hannover.de:70" - "*Default hostname with port for the gopher server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-gopher-doctype-alist '(("/1") - ("/11") - ("/00")) - "*Alist with doctype strings for the gopher server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-gopher-doctype-default "/1" - "*Default doctype string for the gopher server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-gopher-anchor-alist - '(("veronica") - ("Wide%20Area%20Information%20Services%20databases") - ("Subject%20Tree")) - "*Alist with directories for the gopher server." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For the links to the Program Gateway - -(defcustom hm--html-proggate-hostname:port-alist - '(("www.tnt.uni-hannover.de:8007") - ) - "*Alist with hostnames and ports for the proggate server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-proggate-hostname:port-default - "www.tnt.uni-hannover.de:8007" - "*Default hostname with port for the proggate server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-proggate-allowed-file "/appl/www/bin/proggate.allowed" - "*The filename (with path) of the proggate allowed file." - :group 'hm--html-links - :type 'file) - - -;;; For links to the Local Program Gatewy - -(defcustom hm--html-local-proggate-path-alist '((1 . "/bin/") - (2 . "/usr/bin/") - (3 . "/usr/local/bin/") - (4 . "/appl/util/bin/") - (5 . "/appl/gnu/Global/bin/") - (6 . "/") - (7 . "/appl/") - (8 . "~/appl/Global/bin/") - (9 . "~/")) - "*Alist with directories for the local program gateway." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to the mail gateway - -(defcustom hm--html-mail-hostname:port-alist '(("www.tnt.uni-hannover.de:8003") - ) - "*Alist with hostnames and ports for the mail gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-mail-hostname:port-default "www.tnt.uni-hannover.de:8003" - "*Default hostname with port for the mail gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-mail-path-alist '((1 . "~/data/docs/mail") - (2 . "~/data/docs/news") - (3 . "~/docs/mail") - (4 . "~/docs/news") - (5 . "~/mail") - (6 . "~/news") - (7 . "~/") - (8 . "/data/info/mail") - (9 . "/data/info/news") - (10 . "/")) - "*Alist with directories for the mail gateway." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For mailto links - -(defcustom hm--html-mailto-alist '(("muenkel@tnt.uni-hannover.de")) - "*Alist with mail adresses for the mailto alist. -The value of `user-mail-address' will also be added by the package to -this alist." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For the server side include directive -;;; not sure, if these directives works on any server - -(defcustom hm--html-server-side-include-command-alist '(("/bin/date") - ("/usr/bin/finger") - ("/bin/df")) - "*Alist with commands for the server side include directive. -These commands needs no parameter." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-server-side-include-command-with-parameter-alist - '(("/usr/bin/man") - ("/usr/bin/finger") - ("/usr/bin/ls") - ("/bin/cat")) - "*Alist with commands for the server side include directive. -These commands needs parameters." - :group 'hm--html-links - :type '(repeat string)) - - -;;; Alist with URL'S for FORMS and IMAGE tags - -(defcustom hm--html-url-alist - (list - '("http://hoohoo.ncsa.uiuc.edu/htbin-post/post-query" - POST) - '("http://hoohoo.ncsa.uiuc.edu/htbin/query" - GET) - (list - (concat "http://" - hm--html-favorite-http-server-host-name - "/") - 'IMAGE)) - "*Alist with URL's for FORMS and IMAGE tags. -The cdr of each list contains symbols, which specifys the use of the -URL." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For the marking of examples in the help buffer - -(defcustom hm--html-help-foreground "red" - "The foreground color to highlight examples." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-help-background nil - "The background color to highlight examples." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-help-font (face-font 'bold) - "The font to highlight examples." - :group 'hm--html-links - :type 'string) - - -;;; For the Templates - -(defcustom hm--html-template-dir "/data/info/www/tnt/guide/templates" - "*A directory with templatefiles. -It is now also possible to use it as a list of directories. -Look at the variable `tmpl-template-dir-list' for further descriptions." - :group 'hm--html-templates - :type 'directory) - -(if (listp hm--html-template-dir) - (unless (file-exists-p (car hm--html-template-dir)) - ;; Use a system directory, if the above one doesn't exist - ;; This may only be useful, in the XEmacs >= 19.12 - (setq hm--html-template-dir (cons (concat data-directory - "../lisp/hm--html-menus/") - hm--html-template-dir))) - (unless (file-exists-p hm--html-template-dir) - ;; Use a system directory, if the above one doesn't exist - ;; This may only be useful, in the XEmacs >= 19.12 - (setq hm--html-template-dir (concat data-directory - "../lisp/hm--html-menus/")))) - -(defcustom hm--html-frame-template-file (concat data-directory - "../lisp/hm--html-menus/" - "frame.html.tmpl") - "File, which is used as template for a html frame." - :group 'hm--html-templates - :type 'file) - -(defcustom hm--html-automatic-expand-templates t - "*Automatic expansion of templates. This feature needs the file -tmpl-minor-mode.el from Heiko Muenkel (muenkel@tnt.uni-hannover.de), -which is distributed with the package hm--html-menus." - :group 'hm--html-templates - :type 'boolean) - -(defcustom hm--html-template-filter-regexp ".*\\.html\\.tmpl$" - "*Regexp for filtering out non template files in a directory." - :group 'hm--html-templates - :type 'string) - -;;; for deleting the automounter path-prefix -(defcustom hm--html-delete-wrong-path-prefix '("/tmp_mnt" "/phys/[^/]+") - "If non nil, it specifies path-prefixes, which should be deleted in pathes. -The Sun automounter adds a temporary prefix to the automounted directories - (At our site the prefix is /tmp_mnt). But you can't select such a path, if -the automounter has currently not mounted the directory and so you can't -follow a html-link, which consists of such a path. To overcome this behaviour, -you can set this variable to the prefix (eg. \"/tmp_mnt\"). After that, the -prefix should be stripped from the pathes during the creation of the links. -ATTENTION: This variable is used as regular expression ! -It can be set to a string or to a list of strings." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For insertation of created and changed comments and automatic -;;; date update in the title line and a visible modification date - -(defcustom hm--html-automatic-create-title-date t - "*t => A date string will be inserted in the title line. -This will be updated each time before file saving, if -`hm--html-automatic-update-title-date' is also set to t." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-automatic-update-title-date t - "*t => The date in the title line will be updated before filesaving. -nil => No automatic update of the date." - :group 'hm--html-document-information - :type 'boolean) - -(define-obsolete-variable-alias 'hm--html-automatic-new-date - 'hm--html-automatic-update-title-date) - -(defcustom hm--html-automatic-changed-comment t - "*t => A \"changed comment\" line will be added before filesaving. -nil => No automatic insertation of a \"changed comment\" line." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-changed-comment-prefix "Changed by: " - "*The prefix text of the \"changed comment\" lines." - :group 'hm--html-document-information - :type 'string) - -(defcustom hm--html-created-comment-prefix "Created by: " - "*The prefix text of the \"created comment\" lines." - :group 'hm--html-document-information - :type 'string) - -(defcustom hm--html-comment-infix nil - "*The infix (second part) of the \"changed/created comment\" lines. -By default, if this variable is nil, the username is used. -Then the infix looks like \"Heiko Münkel, \". -Set it to an empty string, if you don't want to have your name -in the comments." - :group 'hm--html-document-information - :type '(choice (const :tag "Use The Username" :value nil) - string)) - -(defcustom hm--html-automatic-created-comment t - "*t => A \"created comment\" line will be added. -nil => No automatic insertation of a \"created comment\" line." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-automatic-create-modified-line nil - "*t => Inserts a visible \"modified\" line with the current date. -Visible means, that it is not a HTML comment." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-automatic-update-modified-line nil - "*t => Updates a visible \"modified\" line with the current date. -Visible means, that it is not a HTML comment." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-modified-prefix "Modified: " - "*Prefix of the last modified entry." - :group 'hm--html-document-information - :type 'string) - -(defcustom hm--html-modified-start-tag "" - "*Start tag of the modified line. -If you change this, you'll need to change also -`hm--html-modified-end-tag'." - :group 'hm--html-document-information - :type '(choice (const :tag "Emphasized" :value "") - (const :tag "Strong" :value "") - (const :tag "No Tags" :value "") - (const :tag "Bold" :value "") - (const :tag "Italic" :value "") - (const :tag "Typewriter" :value "") - (const :tag "Small" :value "") - (const :tag "Big" :value "") - (const :tag "Underline" :value "") - string)) - -(defcustom hm--html-modified-end-tag "" - "*End tag of the modified line. -If you change this, you'll need to change also -`hm--html-modified-start-tag'." - :group 'hm--html-document-information - :type '(choice (const :tag "Emphasized" :value "") - (const :tag "Strong" :value "") - (const :tag "No Tags" :value "") - (const :tag "Bold" :value "") - (const :tag "Italic" :value "") - (const :tag "Typewriter" :value "") - (const :tag "Small" :value "") - (const :tag "Big" :value "") - (const :tag "Underline" :value "") - string)) - -(defcustom hm--html-modified-insert-before "" - "Insert modified line before this string. -The search will be done from the end to the beginning." - :group 'hm--html-document-information - :type 'string) - - -;;; Keybindings: - -(defcustom hm--html-bind-latin-1-char-entities t - "Set this to nil, if you don't want to use the ISO Latin 1 character entities. -This is only useful, if `hm--html-use-old-keymap' is set to nil. It is only -used during loading the html package the first time." - :group 'hm--html-keys - :type 'boolean) - - -;;; The drag and drop interface -(defcustom hm--html-idd-create-relative-links t - "If t, then the hm--html-idd-* functions are creating relative links. -Otherwise absolute links are used. The idd functions are used for -drag and drop." - :group 'hm--html-keys - :type 'boolean) - -(defcustom hm--html-idd-actions - '((nil (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpg\\)")) - hm--html-idd-add-include-image-from-dired-line) - (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-no-file-on-line-p . nil)) - hm--html-idd-add-file-link-to-file-on-dired-line) - (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-no-file-on-line-p . t)) - hm--html-idd-add-file-link-to-directory-of-buffer) - (((idd-if-major-mode-p . w3-mode) - (idd-if-url-at-point-p . t)) - hm--html-idd-add-html-link-from-w3-buffer-point) - (((idd-if-major-mode-p . w3-mode)) - hm--html-idd-add-html-link-to-w3-buffer) - (((idd-if-local-file-p . t)) - hm--html-idd-add-file-link-to-buffer))) - "The action list for the destination mode `hm--html-mode'. -Look at the description of the variable idd-actions." - :group 'hm--html-keys - :type 'list) - - -;;; The font lock keywords - -(defcustom hm--html-font-lock-keywords-1 - (list - '("" . font-lock-comment-face) - '("<[^>]*>" . font-lock-keyword-face) -; '("<[^>=]*href[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t) -; '("<[^>=]src[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t) - '("<[^>=]*\\(href\\|src\\)[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" - 2 font-lock-string-face t)) - "Subdued level highlighting for hm--html-mode." - :group 'hm--html-display - :type '(repeat cons)) - -(defcustom hm--html-font-lock-keywords-2 - (append hm--html-font-lock-keywords-1 - (list - '(">\\([^<]+\\)" 1 font-lock-reference-face) - '("\\([^<]+\\)" 1 bold) - '("\\([^<]+\\)" 1 italic) - )) - "Gaudy level highlighting for hm--html-mode." - :group 'hm--html-display - :type '(repeat cons)) - -(defcustom hm--html-font-lock-keywords hm--html-font-lock-keywords-1 - "Default expressions to highlight in the hm--html-mode." - :group 'hm--html-display - :type '(repeat cons)) - - - -;;; The Prefix- Key for the keytables -(defcustom hm--html-minor-mode-prefix-key "\C-z" - "The prefix key for the keytables in the `hm--html-minor-mode'." - :group 'hm--html-keys - :type 'string) - -(defcustom hm--html-mode-prefix-key "\C-c" - "The prefix key for the hm--html keys in the `hm--html-mode'." - :group 'hm--html-keys - :type 'string) - - -;;; The pulldown menu names -(defcustom hm--html-minor-mode-pulldown-menu-name "HM-HTML" - "The name of the pulldown menu in the minor html mode." - :group 'hm--html-menus - :type 'string - ) - -(defcustom hm--html-mode-pulldown-menu-name "HTML" - "The name of the pulldown menu in the major html mode." - :group 'hm--html-menus - :type 'string) - - -;;; The hook variables -(defcustom hm--html-load-hook nil - "*Hook variable to execute functions after loading the package." - :group 'hm--html-hooks - :type 'hook) - -(defcustom hm--html-mode-hook nil - "*This hook will be called each time, when the hm--html-mode is invoked." - :group 'hm--html-hooks - :type 'hook) - - -;;; For the file html-view.el -;;; There are also some other variables in hmtl-view.el -;;; Look at that file, if you've trouble with the functions -;;; to preview the html document with the Mosaic -(defcustom html-view-mosaic-command "/sol/www/bin/mosaic" - "The command that runs Mosaic on your system." - :group 'hm--html-display - :type '(choice (const :tag "mosaic" :value "mosaic") - (const :value "/usr/local/bin/mosaic") - file)) - -(defcustom html-sigusr1-signal-value 16 - "Value for the SIGUSR1 signal on your system. -See, usually, /usr/include/sys/signal.h. - SunOS 4.1.x : (setq html-sigusr1-signal-value 30) - SunOS 5.x : (setq html-sigusr1-signal-value 16) - Linux : (setq html-sigusr1-signal-value 10))" - :group 'hm--html-display - :type '(choice (const :tag "On SunOS 4.1.x" :value 30) - (const :tag "On SunOS 5.x" :value 16) - (const :tag "On Linux" :value 10) - integer)) - - -;;; Meta information -(defcustom hm--html-meta-name-alist '(("Expires") ("Keys") ("Author")) - "*Alist with possible names for the name or http-equiv attribute of meta." - :group 'hm--html-document-information - :type '(repeat (list (choice (const "Expires") - (const "Keys") - (const "Author") - string)))) - -;;; indentation - -(defcustom hm--html-disable-indentation nil - "*Set this to t, if you want to disable the indentation in the hm--html-mode. -And may be send me (muenkel@tnt.uni-hannover.de) a note, why you've -done this." - :group 'hm--html-indentation - :type 'boolean) - -(defcustom hm--html-inter-tag-indent 2 - "*The indentation after a start tag." - :group 'hm--html-indentation - :type 'integer) - -(defcustom hm--html-comment-indent 5 - "*The indentation of a comment." - :group 'hm--html-indentation - :type 'integer) - -(defcustom hm--html-intra-tag-indent 2 - "*The indentation after the start of a tag." - :group 'hm--html-indentation - :type 'integer) - -(defcustom hm--html-tag-name-alist - '(("!--" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("!doctype" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("isindex" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (prompt))) - ("base" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (href)) - (:hm--html-optional-attributes nil)) - ("meta" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (content)) - (:hm--html-optional-attributes (http-equiv name))) - ("link" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (href rel rev title))) - ("hr" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align noshade size width))) - ("input" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (type name value checked size maxlength src align))) - ("img" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (src)) - (:hm--html-optional-attributes - (alt align height width border hspace vspace usemap ismap))) - ("param" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (name)) - (:hm--html-optional-attributes (value))) - ("br" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (clear))) - ("basefont" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes size)) - ("area" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (alt)) - (:hm--html-optional-attributes (shape coords href nohref))) - ("option" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (selected value))) - - ("html" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("head" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("body" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (bgcolor text link vlink alink background)) - ) - ("h1" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h2" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h3" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h4" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h5" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h6" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("address" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("p" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("ul" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (type compact))) - ("ol" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (type start compact))) - ("dl" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (compact))) - ("li" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (type (value "ol")))) - ("dt" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("dd" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("dir" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (compact))) - ("menu" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (compact))) - ("pre" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (width))) - ("div" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("center" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("blockquote" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("form" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (action method enctype))) - ("select" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (name)) - (:hm--html-optional-attributes (size multiple))) - ("textarea" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (name rows cols)) - (:hm--html-optional-attributes nil)) - ("table" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (align width border cellspacing cellpading))) - ("caption" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("tr" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align valign))) - ("th" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (nowrap rowspan colspan align valign width height))) - ("td" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (nowrap rowspan colspan align valign width height))) - ("tt" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("i" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("b" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("u" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("strike" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("big" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("small" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("sub" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("sup" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("em" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("strong" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("dfn" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("code" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("samp" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("kbd" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("var" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("cite" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("a" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (name href rel rev title))) - ("applet" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (code width height)) - (:hm--html-optional-attributes (codebase alt name align hspace vspace))) - ("font" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (size color))) - ("map" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (name)) - (:hm--html-optional-attributes nil)) - ("style" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("script" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ) - "An alist with tag names known by the `hm--html-mode'. -CURRENTLY THIS LIST MIGHT NOT CONTAIN ALL TAGS!!!!. - -It is used to determine, if a tag is a one element tag or not. - -In the future it should also be used to get possible parameters of -the tag. - -Use lower case characters in this list!!!!" - :group 'hm--html-indentation - :type 'list) -; :type '(repeat lisp)) -; :type '(repeat (list string -; (list (const -; :tag "Element with one tag" -; :value (:hm--html-one-element-tag t)) -; (const -; :tag "Element with two tags" -; :value (:hm--html-two-element-tag t)) -; (const -; :tag "Element with one or two tags" -; :value (:hm--html-one-or-two-element-tag t)) -; ) -; (list :format "%t%v" -; :tag "" -; (const :format "" -; :value :hm--html-required-attributes) -; (repeat :tag "Repeat Required Attributes" -; symbol)) -; (list :format "%t%v" -; :tag "" -; (const :format "" -; :value :hm--html-optional-attributes) -; (repeat :tag "Repeat Optional Attributes" -; symbol)) -; ))) - - -;;; Announce the feature hm--html-configuration -(provide 'hm--html-configuration) - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html-drag-and-drop.el --- a/lisp/hm--html-menus/hm--html-drag-and-drop.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,167 +0,0 @@ -;;; $Id: hm--html-drag-and-drop.el,v 1.2 1997/02/15 22:21:03 steve Exp $ -;;; -;;; Copyright (C) 1996, 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; This package contains functions to insert links and other -;;; HTML stuff with the mouse with drag and drop. -;;; -;;; For further descriptions look at the file -;;; internal-drag-and-drop.el, which implements the basic (and -;;; more genreal functions) for the drag and drop interface. -;;; -;;; Installation: -;;; -;;; Put this file in your load path. -;;; - -(require 'internal-drag-and-drop) -(require 'cl) - -;(defun hm--html-first-non-matching-position (string1 string2) -; "Compares both strings and returns the first position, which is not equal." -; (let ((n 0) -; (max-n (min (length string1) (length string2))) -; (continue t)) -; (while (and continue (< n max-n)) -; (when (setq continue (= (aref string1 n) (aref string2 n))) -; (setq n (1+ n)))) -; n)) - -;(defun hm--html-count-subdirs (directory) -; "Returns the number of subdirectories of DIRECTORY." -; (let ((n 0) -; (max-n (1- (length directory))) -; (count 0)) -; (while (< n max-n) -; (when (= ?/ (aref directory n)) -; (setq count (1+ count))) -; (setq n (1+ n))) -; (when (and (not (= 0 (length directory))) -; (not (= ?/ (aref directory 0)))) -; (setq count (1+ count))) -; count)) - -;(defun hm--html-return-n-backwards (n) -; "Returns a string with N ../" -; (cond ((= n 0) "") -; (t (concat "../" (hm--html-return-n-backwards (1- n)))))) - -;(defun* hm--html-file-relative-name (file-name -; &optional (directory default-directory)) -; "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." -; (let* ((pos (hm--html-first-non-matching-position file-name directory)) -; (backwards (hm--html-count-subdirs (substring directory pos))) -; (relative-name (concat (hm--html-return-n-backwards backwards) -; (substring file-name pos)))) -; (if (= 0 (length relative-name)) -; "./" -; (if (= ?/ (aref relative-name 0)) -; (if (= 1 (length relative-name)) -; "./" -; (substring relative-name 1)) -; relative-name)))) - -(defun hm--html-idd-add-include-image-from-dired-line (source destination) - "Inserts an include image tag at the DESTINATION. -The name of the image is on a line in a dired buffer. It is specified by the -SOURCE." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-add-image-top (file-relative-name - (idd-get-dired-filename-from-line source)) - (file-name-nondirectory - (idd-get-dired-filename-from-line source))) - (hm--html-add-image-top (idd-get-dired-filename-from-line source) - (file-name-nondirectory - (idd-get-dired-filename-from-line source))))) - -(defun hm--html-idd-add-link-to-region (link-object destination) - "Inserts a link with the LINK-OBJECT in the DESTINATION. -It uses the region as the name of the link." - (idd-set-region destination) - (hm--html-add-normal-link-to-region link-object) - ) - -(defun hm--html-idd-add-link (link-object destination) - "Inserts a link with the LINK-OBJECT in the DESTINATION." - (idd-set-point destination) - (hm--html-add-normal-link link-object)) - -(defun hm--html-idd-add-link-to-point-or-region (link-object destination) - "Inserts a link with the LINK-OBJECT in the DESTINATION. -It uses the region as the name of the link, if the region was active -in the DESTINATION." - (if (cdr (assoc ':region-active destination)) - (hm--html-idd-add-link-to-region link-object destination) - (hm--html-idd-add-link link-object destination))) - -(defun hm--html-idd-add-file-link-to-file-on-dired-line (source destination) - "Inserts a file link in DESTINATION to the file on the dired line of SOURCE." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-idd-add-link-to-point-or-region - (file-relative-name - (idd-get-dired-filename-from-line source)) - destination) - (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-dired-filename-from-line source)) - destination))) - -(defun hm--html-idd-add-file-link-to-buffer (source destination) - "Inserts a file link at DESTINATION to the file of the SOURCE buffer." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-idd-add-link-to-point-or-region - (file-relative-name (idd-get-local-filename source)) - destination) - (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-local-filename source)) - destination))) - -(defun hm--html-idd-add-file-link-to-directory-of-buffer (source - destination) - "Inserts a file link at DESTINATION to the directory of the SOURCE buffer." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-idd-add-link-to-point-or-region - (file-relative-name (idd-get-directory-of-buffer source)) - destination) - (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-directory-of-buffer source)) - destination))) - -(defun hm--html-idd-add-html-link-to-w3-buffer (source destination) - "Inserts a link at DESTINATION to the w3 buffer specified by the SOURCE. -Note: Relative links are currently not supported for this function." - (idd-set-point destination) - (hm--html-idd-add-link-to-point-or-region (idd-get-buffer-url source) - destination)) - -(defun hm--html-idd-add-html-link-from-w3-buffer-point (source destination) - "Inserts a link at DESTINATION to a lin in the w3 buffer. -The link in the w3-buffer is specified by the SOURCE. -Note: Relative links are currently not supported for this function." - (idd-set-point destination) - (hm--html-idd-add-link-to-point-or-region (idd-get-url-at-point source) - destination)) - -;;; Announce the feature hm--html-drag-and-drop -(provide 'hm--html-drag-and-drop) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html-indentation.el --- a/lisp/hm--html-menus/hm--html-indentation.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,271 +0,0 @@ -;;; hm--html-indentation.el -;;; v1.00; 9-Feb-1997 -;;; Copyright (C) 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines functions for the indentation. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; - -(defun hm--html-point-between-strings-p (string-1 - string-2 - &optional boundary) - "Returns non nil, if the current point is between STRING-1 and STRING-2." - (when (and (re-search-backward (concat "\\(" - (regexp-quote string-1) - "\\)\\|\\(" - (regexp-quote string-2) - "\\)") - boundary - t) - (match-string 1)) - (point))) - -(defun hm--html-in-comment-p () - "Checks if the current point is in a comment block. -If this is the case, then the start point of the comment is returned. -Otherwise nil is returned." - (save-excursion - (hm--html-point-between-strings-p comment-start comment-end))) - -(defun hm--html-previous-line-start () - "Returns the start of the previous non blank line." - (save-excursion - (beginning-of-line) - (skip-chars-backward " \t\n") - (beginning-of-line) - (point))) - -(defun hm--html-look-at-comment-end-p () - "T, if the current line starts with the comment end." - (looking-at (regexp-quote comment-end))) - -(defun hm--html-column-of-previous-regexp (regexp) - "Returns the column of the start of the previous REGEXP. -It searches backward until the REGEXP is found. If no -REGEXP is found, then it returns 0." - (save-excursion - (if (re-search-backward regexp nil t) - (current-column) - 0))) - -(defun hm--html-look-at-end-tag-p () - "Returns the end tag name if the point is at the start of an end tag. -nil is returned otherwise." - (when (looking-at "\\(<[ \t\n]*/[ \t\n]*\\)\\([^ \t\n>]+\\)") - (match-string 2))) - - -(defun hm--html-previous-line-indentation () - "Returns the indentation of the previous non blank line." - (save-excursion - (beginning-of-line) - (skip-chars-backward " \t\n") - (back-to-indentation) - (current-column))) - -(defun hm--html-in-tag-p () - "Checks if the current point is in a tag. -If this is the case, then the start point of the tag is returned. -Otherwise nil is returned." - (save-excursion - (let ((start (re-search-backward "\\(<\\)\\|\\(>\\)" nil t))) - (when (match-string 1) - start)))) - -(defun hm--html-return-beginning-of-line () - "Returns the beginning of the current line." - (save-excursion - (beginning-of-line) - (point))) - -(defun hm--html-return-end-of-line () - "Returns the end of the current line." - (save-excursion - (end-of-line) - (point))) - -(defun hm--html-paramter-column-in-line-after-point (point) - "Returns the column where the second non blank text after POINT starts. -This point must be in the line with POINT otherwise it returns nil." - (save-excursion - (goto-char point) - (when (re-search-forward "<[ \t]*[^ \t]+[ \t]" - (hm--html-return-end-of-line) - t) - (when (looking-at "[^\n]") - (current-column))))) - -(defun hm--html-column-of-point (point) - "Returns the column of the POINT." - (save-excursion - (goto-char point) - (current-column))) - -(defun hm--html-search-previous-tag-in-current-line () - "Searches tags from the `(point)' to the beginning of the line. -It returns nil, if there is no tag and the tag name, if there is -a tag. The tag name contains a leading /, if it is an end tag." - (when (re-search-backward ">" (hm--html-return-beginning-of-line) t) - (when (re-search-backward - "\\(<[ \t\n]*\\(/?\\)\\([ \t\n]*[^> \t\n]+\\)[^>]*\\)" - nil - t) - (concat (match-string 2) (match-string 3))))) - -(defun hm--html-search-start-tag (tag-name until) - "Searches start tag backwards from the current point until the point UNTIL. -The name of the tag is TAG-NAME. After this function the point is at UNTIL - (then it returns nil) or at the start of the tag, then it returns t." - (if (re-search-backward (concat "\\(<[ \t\n]*\\)\\(/?\\)\\(" - tag-name - "\\)\\([^>]*>\\)") until t) - (if (string= "/" (match-string 2)) - (progn - (hm--html-search-start-tag tag-name until) - (hm--html-search-start-tag tag-name until)) - t) - (goto-char until) - nil)) - -(defun hm--html-is-one-element-tag-p (tag-name) - "Returns t, if the tag with the tag-name is a one element tag." - (assoc ':hm--html-one-element-tag - (cdr (assoc* (downcase tag-name) - hm--html-tag-name-alist - :test 'string=)))) - -(defun hm--html-calculate-indent-according-to-previous-tags () - "Calculate the indent according to the previous tags in this line. -If no tags are found, then nil is returned." - (save-excursion - (let ((tag (hm--html-search-previous-tag-in-current-line))) - (cond ((not tag) nil) - - ((eq ?/ (elt tag 0)) ; end tag found - (if (hm--html-search-start-tag - (substring tag 1) - (point-min)) - (or (hm--html-calculate-indent-according-to-previous-tags) - (progn - (backward-to-indentation 0) - (current-column))) - 0)) ; it may be that the current indentation is better here - - ((hm--html-is-one-element-tag-p tag) ; one element tag - (or (hm--html-calculate-indent-according-to-previous-tags) - (progn - (backward-to-indentation 0) - (current-column)))) - - (t ; start tag found - (+ (current-column) hm--html-inter-tag-indent)))))) - - -(defun hm--html-calculate-indent () - "Calculate the indentation of the current line." - (let ((match-point) - (tag)) - (save-excursion - (beginning-of-line) - (back-to-indentation) - (cond ((eq (count-lines (point-min) (point)) 0) 0) ; Filestart - - ((setq match-point (hm--html-in-comment-p)) ; in a comment - (if (>= match-point (hm--html-previous-line-start)) ; 1. line - (if (hm--html-look-at-comment-end-p) - (hm--html-column-of-previous-regexp - (regexp-quote comment-start)) - (+ (hm--html-column-of-previous-regexp - (regexp-quote comment-start)) - hm--html-comment-indent)) - (if (hm--html-look-at-comment-end-p) - (- (hm--html-previous-line-indentation) - hm--html-comment-indent) - (hm--html-previous-line-indentation)))) - - ((setq tag (hm--html-look-at-end-tag-p)) ; look at end tag - (hm--html-search-start-tag tag (point-min)) - (current-column)) - - ((looking-at ">") - (hm--html-column-of-previous-regexp "<")) - - ((setq match-point (hm--html-in-tag-p)) - (if (>= match-point (hm--html-previous-line-start)) ; 1. line - (or (hm--html-paramter-column-in-line-after-point match-point) - (+ (hm--html-column-of-point match-point) - hm--html-intra-tag-indent)) - (hm--html-previous-line-indentation))) - - (t (or (save-excursion ; check previous line - (skip-chars-backward " \t\n") - (hm--html-calculate-indent-according-to-previous-tags)) - (hm--html-previous-line-indentation))) - )))) - - -;;; Indentation commands - -(defun hm--html-indent-line () - "Indent the current line line." - (interactive) - (unless hm--html-disable-indentation - (let ((pos (- (point-max) (point)))) - (indent-line-to (max 0 (hm--html-calculate-indent))) - (when (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))))) - -;(defun hm--html-indent-region (begin end) -; "Indents the region between BEGIN and END according to the major mode." -; (interactive "d\nm") -; (when (< end begin) -; (let ((a end)) -; (setq end begin) -; (setq begin a))) -; (save-excursion -; (goto-char begin) -; (let ((old-point)) -; (while (and (<= (point) end) -; (not (eq (point) old-point))) -; (setq old-point (point)) -; (indent-according-to-mode) -; (forward-line) -; )))) - -(defun hm--html-indent-region (begin end) - "Indents the region between BEGIN and END according to the major mode." - (interactive "d\nm") - (when (< end begin) - (let ((a end)) - (setq end begin) - (setq begin a))) - (let ((lines (count-lines begin end))) - (save-excursion - (goto-char begin) - (loop repeat lines - do (indent-according-to-mode) - (forward-line)))) - ) - -(provide 'hm--html-indentation) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html-keys.el --- a/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,766 +0,0 @@ -;;; $Id: hm--html-keys.el,v 1.7 1997/05/29 23:49:42 steve Exp $ -;;; -;;; Copyright (C) 1995, 1996, 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines the new keybindigs for the hm--html-menus package. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; - -(if (adapt-emacs19p) - (progn - - (defvar hm--html-emacs19-popup-noregion-menu-button [C-down-mouse-3] - "This is the mouse button , which pops up the noregion menus. -It could have the same value as -`hm--html-emacs19-popup-region-menu-button'.") - - (defvar hm--html-emacs19-popup-region-menu-button [C-down-mouse-3] - "This is the mouse button , which pops up the region menus. -It could have the same value as -`hm--html-emacs19-popup-noregion-menu-button'.") - - )) - - -(defvar hm--html-noregion-anchor-map nil - "Noregion sub keymap for inserting anchors.") - -(if hm--html-noregion-anchor-map - () - (setq hm--html-noregion-anchor-map (make-sparse-keymap)) - (define-key hm--html-noregion-anchor-map "r" 'hm--html-add-relative-link) - (define-key hm--html-noregion-anchor-map "h" 'hm--html-add-html-link) - (define-key hm--html-noregion-anchor-map "i" 'hm--html-add-info-link) - (define-key hm--html-noregion-anchor-map "g" 'hm--html-add-gopher-link) - (define-key hm--html-noregion-anchor-map "f" 'hm--html-add-file-link) - (define-key hm--html-noregion-anchor-map "\C-f" 'hm--html-add-ftp-link) - (define-key hm--html-noregion-anchor-map "n" 'hm--html-add-news-link) - (define-key hm--html-noregion-anchor-map "m" 'hm--html-add-mail-box-link) - (define-key hm--html-noregion-anchor-map - [(control m)] 'hm--html-add-mailto-link) - (define-key hm--html-noregion-anchor-map "w" 'hm--html-add-direct-wais-link) - (define-key hm--html-noregion-anchor-map "\C-w" 'hm--html-add-wais-link) - (define-key hm--html-noregion-anchor-map "p" 'hm--html-add-proggate-link) - (define-key hm--html-noregion-anchor-map - "\C-p" 'hm--html-add-local-proggate-link) - (define-key hm--html-noregion-anchor-map "l" 'hm--html-add-normal-link) - (define-key hm--html-noregion-anchor-map "t" 'hm--html-add-link-target) - ) - -(defvar hm--html-region-anchor-map nil - "Region sub keymap for inserting anchors.") - -(if hm--html-region-anchor-map - () - (setq hm--html-region-anchor-map (make-sparse-keymap)) - (define-key hm--html-region-anchor-map - "r" 'hm--html-add-relative-link-to-region) - (define-key hm--html-region-anchor-map "h" 'hm--html-add-html-link-to-region) - (define-key hm--html-region-anchor-map "i" 'hm--html-add-info-link-to-region) - (define-key hm--html-region-anchor-map - "g" 'hm--html-add-gopher-link-to-region) - (define-key hm--html-region-anchor-map "f" 'hm--html-add-file-link-to-region) - (define-key hm--html-region-anchor-map - "\C-f" 'hm--html-add-ftp-link-to-region) - (define-key hm--html-region-anchor-map "n" 'hm--html-add-news-link-to-region) - (define-key hm--html-region-anchor-map "m" 'hm--html-add-mail-box-link-to-region) - (define-key hm--html-region-anchor-map - [(control m)] 'hm--html-add-mailto-link-to-region) - (define-key hm--html-region-anchor-map - "w" 'hm--html-add-direct-wais-link-to-region) - (define-key hm--html-region-anchor-map - "\C-w" 'hm--html-add-wais-link-to-region) - (define-key hm--html-region-anchor-map - "p" 'hm--html-add-proggate-link-to-region) - (define-key hm--html-region-anchor-map - "\C-p" 'hm--html-add-local-proggate-link-to-region) - (define-key hm--html-region-anchor-map - "l" 'hm--html-add-normal-link-to-region) - (define-key hm--html-region-anchor-map - "t" 'hm--html-add-link-target-to-region) - ) - -(defvar hm--html-noregion-frame-map nil - "Noregion sub keymap for inserting frame elements.") - -(if hm--html-noregion-frame-map - () - (setq hm--html-noregion-frame-map (make-sparse-keymap)) - (define-key hm--html-noregion-frame-map "f" 'hm--html-add-full-html-frame) - (define-key hm--html-noregion-frame-map [(control d)] 'hm--html-add-doctype) - (define-key hm--html-noregion-frame-map [(control h)] 'hm--html-add-html) - (define-key hm--html-noregion-frame-map [(meta h)] 'hm--html-add-head) - (define-key hm--html-noregion-frame-map "b" 'hm--html-add-body) - (define-key hm--html-noregion-frame-map - [(control t)] 'hm--html-add-title-and-header) - (define-key hm--html-noregion-frame-map "t" 'hm--html-add-title) - (define-key hm--html-noregion-frame-map "h" 'hm--html-add-header) - (define-key hm--html-noregion-frame-map "m" 'hm--html-add-meta) - (define-key hm--html-noregion-frame-map "n" 'hm--html-add-normal-node-link) - (define-key hm--html-noregion-frame-map "i" 'hm--html-add-isindex) - (define-key hm--html-noregion-frame-map [(meta d)] 'hm--html-add-base) - (define-key hm--html-noregion-frame-map "a" 'hm--html-add-address) - (define-key hm--html-noregion-frame-map "s" 'hm--html-add-signature) - (define-key hm--html-noregion-frame-map - [(control c)] 'hm--html-insert-created-comment) - (define-key hm--html-noregion-frame-map "c" 'hm--html-insert-changed-comment) - (define-key hm--html-noregion-frame-map - [(control m)] 'hm--html-insert-modified-line) - (define-key hm--html-noregion-frame-map "d" 'hm--html-new-date) - ) - -(defvar hm--html-region-frame-map nil - "Region sub keymap for inserting frame elements.") - -(if hm--html-region-frame-map - () - (setq hm--html-region-frame-map (make-sparse-keymap)) - (define-key hm--html-region-frame-map - "f" 'hm--html-add-full-html-frame-with-region) - (define-key hm--html-region-frame-map - [(meta h)] 'hm--html-add-head-to-region) - (define-key hm--html-region-frame-map "b" 'hm--html-add-body-to-region) - (define-key hm--html-region-frame-map - [(control t)] 'hm--html-add-title-and-header-to-region) - (define-key hm--html-region-frame-map "t" 'hm--html-add-title-to-region) - (define-key hm--html-region-frame-map "h" 'hm--html-add-header-to-region) - (define-key hm--html-region-frame-map "a" 'hm--html-add-address-to-region) - ) - -(defvar hm--html-noregion-structure-map nil - "Noregion sub keymap for inserting entities.") - -(if hm--html-noregion-structure-map - () - (setq hm--html-noregion-structure-map (make-sparse-keymap)) - (define-key hm--html-noregion-structure-map - "i" 'hm--html-add-list-or-menu-item) - (define-key hm--html-noregion-structure-map "m" 'hm--html-add-menu) - (define-key hm--html-noregion-structure-map "u" 'hm--html-add-list) - (define-key hm--html-noregion-structure-map "o" 'hm--html-add-numberlist) - (define-key hm--html-noregion-structure-map "d" 'hm--html-add-directory-list) - (define-key hm--html-noregion-structure-map - "\C-dl" 'hm--html-add-description-list) - (define-key hm--html-noregion-structure-map - "\C-dt" 'hm--html-add-description-title) - (define-key hm--html-noregion-structure-map - "\C-de" 'hm--html-add-description-entry) - (define-key hm--html-noregion-structure-map - "\C-d\C-t" 'hm--html-add-description-title-and-entry) - (define-key hm--html-noregion-structure-map - "\C-tt" 'hm--html-add-table) - (define-key hm--html-noregion-structure-map - "\C-t\C-t" 'hm--html-add-table-title) - (define-key hm--html-noregion-structure-map - "\C-th" 'hm--html-add-table-header) - (define-key hm--html-noregion-structure-map - "\C-tr" 'hm--html-add-first-table-row) - (define-key hm--html-noregion-structure-map - "\C-t\C-r" 'hm--html-add-additional-table-row) - (define-key hm--html-noregion-structure-map "p" 'hm--html-add-paragraph) - (define-key hm--html-noregion-structure-map - "\C-p" 'hm--html-add-paragraph-separator) - (define-key hm--html-noregion-structure-map - [(meta d)] 'hm--html-add-document-division) - (define-key hm--html-noregion-structure-map "\C-m" 'hm--html-add-line-break) - (define-key hm--html-noregion-structure-map - "h" 'hm--html-add-horizontal-rule) - ) - -(defvar hm--html-region-structure-map nil - "Region sub keymap for inserting entities.") - -(if hm--html-region-structure-map - () - (setq hm--html-region-structure-map (make-sparse-keymap)) - (define-key hm--html-region-structure-map - "i" 'hm--html-add-list-or-menu-item-to-region) - (define-key hm--html-region-structure-map "m" 'hm--html-add-menu-to-region) - (define-key hm--html-region-structure-map "u" 'hm--html-add-list-to-region) - (define-key hm--html-region-structure-map - "o" 'hm--html-add-numberlist-to-region) - (define-key hm--html-region-structure-map - "d" 'hm--html-add-directorylist-to-region) - (define-key hm--html-region-structure-map - "\C-dl" 'hm--html-add-description-list-to-region) - (define-key hm--html-region-structure-map - "\C-dt" 'hm--html-add-description-title-to-region) - (define-key hm--html-region-structure-map - "\C-de" 'hm--html-add-description-entry-to-region) - (define-key hm--html-region-structure-map - "\C-tt" 'hm--html-add-table-to-region) - (define-key hm--html-region-structure-map - "\C-t\C-t" 'hm--html-add-table-title-to-region) - (define-key hm--html-region-structure-map - "p" 'hm--html-add-paragraph-to-region) - (define-key hm--html-region-structure-map - [(meta d)] 'hm--html-add-document-division-to-region) - ) - -(defvar hm--html-noregion-formatting-paragraph-map nil - "Noregion sub keymap for inserting paragraph formatting elements.") - -(if hm--html-noregion-formatting-paragraph-map - () - (setq hm--html-noregion-formatting-paragraph-map (make-sparse-keymap)) -; (define-key hm--html-noregion-formatting-paragraph-map -; "o" 'hm--html-add-plaintext) - (define-key hm--html-noregion-formatting-paragraph-map - "p" 'hm--html-add-preformatted) - (define-key hm--html-noregion-formatting-paragraph-map - "b" 'hm--html-add-blockquote) - (define-key hm--html-noregion-formatting-paragraph-map - "\C-b" 'hm--html-add-basefont) - (define-key hm--html-noregion-formatting-paragraph-map - "f" 'hm--html-add-font) - (define-key hm--html-noregion-formatting-paragraph-map - "c" 'hm--html-add-center) - (define-key hm--html-noregion-formatting-paragraph-map - "\C-c" 'hm--html-add-comment) -; (define-key hm--html-noregion-formatting-paragraph-map -; "l" 'hm--html-add-listing) -; (define-key hm--html-noregion-formatting-paragraph-map -; "a" 'hm--html-add-abstract) - ) - -(defvar hm--html-region-formatting-paragraph-map nil - "Region sub keymap for inserting paragraph formatting elements.") - -(if hm--html-region-formatting-paragraph-map - () - (setq hm--html-region-formatting-paragraph-map (make-sparse-keymap)) -; (define-key hm--html-region-formatting-paragraph-map -; "o" 'hm--html-add-plaintext-to-region) - (define-key hm--html-region-formatting-paragraph-map - "p" 'hm--html-add-preformatted-to-region) - (define-key hm--html-region-formatting-paragraph-map - "b" 'hm--html-add-blockquote-to-region) - (define-key hm--html-region-formatting-paragraph-map - "\C-b" 'hm--html-add-basefont-to-region) - (define-key hm--html-region-formatting-paragraph-map - "f" 'hm--html-add-font-to-region) - (define-key hm--html-region-formatting-paragraph-map - "c" 'hm--html-add-center-to-region) - (define-key hm--html-region-formatting-paragraph-map - "\C-c" 'hm--html-add-comment-to-region) -; (define-key hm--html-region-formatting-paragraph-map -; "l" 'hm--html-add-listing-to-region) -; (define-key hm--html-region-formatting-paragraph-map -; "a" 'hm--html-add-abstract-to-region) - ) - -(defvar hm--html-noregion-formatting-word-map nil - "Norgion sub keymap for inserting physical text formatting elements.") - -(if hm--html-noregion-formatting-word-map - () - (setq hm--html-noregion-formatting-word-map (make-sparse-keymap)) - (define-key hm--html-noregion-formatting-word-map - "b" 'hm--html-add-bold) - (define-key hm--html-noregion-formatting-word-map - "i" 'hm--html-add-italic) - (define-key hm--html-noregion-formatting-word-map - "u" 'hm--html-add-underline) - (define-key hm--html-noregion-formatting-word-map - "t" 'hm--html-add-fixed) - (define-key hm--html-noregion-formatting-word-map - "s" 'hm--html-add-strikethru) - (define-key hm--html-noregion-formatting-word-map - "\C-p" 'hm--html-add-superscript) - (define-key hm--html-noregion-formatting-word-map - "\C-b" 'hm--html-add-subscript) - (define-key hm--html-noregion-formatting-word-map - "e" 'hm--html-add-emphasized) - (define-key hm--html-noregion-formatting-word-map - "\C-s" 'hm--html-add-strong) - (define-key hm--html-noregion-formatting-word-map - "\M-s" 'hm--html-add-small) - (define-key hm--html-noregion-formatting-word-map - "\M-b" 'hm--html-add-big) - ) - -(defvar hm--html-region-formatting-word-map nil - "Region sub keymap for inserting word text formatting elements.") - -(if hm--html-region-formatting-word-map - () - (setq hm--html-region-formatting-word-map (make-sparse-keymap)) - (define-key hm--html-region-formatting-word-map - "b" 'hm--html-add-bold-to-region) - (define-key hm--html-region-formatting-word-map - "i" 'hm--html-add-italic-to-region) - (define-key hm--html-region-formatting-word-map - "u" 'hm--html-add-underline-to-region) - (define-key hm--html-region-formatting-word-map - "t" 'hm--html-add-fixed-to-region) - (define-key hm--html-region-formatting-word-map - "s" 'hm--html-add-strikethru-to-region) - (define-key hm--html-region-formatting-word-map - "\C-p" 'hm--html-add-superscript-to-region) - (define-key hm--html-region-formatting-word-map - "\C-b" 'hm--html-add-subscript-to-region) - (define-key hm--html-region-formatting-word-map - "e" 'hm--html-add-emphasized-to-region) - (define-key hm--html-region-formatting-word-map - "\C-s" 'hm--html-add-strong-to-region) - (define-key hm--html-region-formatting-word-map - "\M-s" 'hm--html-add-small-to-region) - (define-key hm--html-region-formatting-word-map - "\M-b" 'hm--html-add-big-to-region) - ) - -(defvar hm--html-noregion-include-map nil - "Noregion sub keymap for include images and other stuff.") - -(if hm--html-noregion-include-map - () - (setq hm--html-noregion-include-map (make-sparse-keymap)) - (define-key hm--html-noregion-include-map - [(control i) (t)] 'hm--html-add-image-top) - (define-key hm--html-noregion-include-map - [(control i) (m)] 'hm--html-add-image-middle) - (define-key hm--html-noregion-include-map - [(control i) (b)] 'hm--html-add-image-bottom) - (define-key hm--html-noregion-include-map "i" 'hm--html-add-image) - (define-key hm--html-noregion-include-map [(meta i)] 'hm--html-add-image-map) - (define-key hm--html-noregion-include-map "m" 'hm--html-add-map) - (define-key hm--html-noregion-include-map [(control a)] 'hm--html-add-area) - (define-key hm--html-noregion-include-map "a" 'hm--html-add-applet) - (define-key hm--html-noregion-include-map "p" 'hm--html-add-applet-parameter) - ) - -(defvar hm--html-region-include-map nil - "Region sub keymap for include images and other stuff.") - -(if hm--html-region-include-map - () - (setq hm--html-region-include-map (make-sparse-keymap)) - (define-key hm--html-region-include-map "m" 'hm--html-add-map-to-region) - (define-key hm--html-region-include-map "a" 'hm--html-add-applet-to-region) - ) - -;(defvar hm--html-noregion-text-elements-map nil -; "Noregion sub keymap for inserting text elements.") - -;(if hm--html-noregion-text-elements-map -; () -; (setq hm--html-noregion-text-elements-map (make-sparse-keymap)) -; ) - -;(defvar hm--html-region-text-elements-map nil -; "Region sub keymap for inserting text elements.") - -;(if hm--html-region-text-elements-map -; () -; (setq hm--html-region-text-elements-map (make-sparse-keymap)) -; ) - -(defvar hm--html-noregion-forms-map nil - "Noregion sub keymap for inserting forms.") - -(if hm--html-noregion-forms-map - () - (setq hm--html-noregion-forms-map (make-sparse-keymap)) - - (define-key hm--html-noregion-forms-map "f" 'hm--html-add-form) - (define-key hm--html-noregion-forms-map "a" 'hm--html-form-add-input-audio) - (define-key hm--html-noregion-forms-map - "c" 'hm--html-form-add-input-checkbox) - (define-key hm--html-noregion-forms-map - "d" 'hm--html-form-add-input-date) - (define-key hm--html-noregion-forms-map - "\C-f" 'hm--html-form-add-input-float) - (define-key hm--html-noregion-forms-map "i" 'hm--html-form-add-input-image) - (define-key hm--html-noregion-forms-map - "\C-i" 'hm--html-form-add-input-integer) - (define-key hm--html-noregion-forms-map - "\M-i" 'hm--html-form-add-input-isindex) - (define-key hm--html-noregion-forms-map - "p" 'hm--html-form-add-input-password) - (define-key hm--html-noregion-forms-map "r" 'hm--html-form-add-input-radio) - (define-key hm--html-noregion-forms-map - "\C-r" 'hm--html-form-add-input-reset) - (define-key hm--html-noregion-forms-map - "\C-s" 'hm--html-form-add-input-scribble) - (define-key hm--html-noregion-forms-map "s" 'hm--html-form-add-input-submit) - (define-key hm--html-noregion-forms-map "t" 'hm--html-form-add-input-text) - (define-key hm--html-noregion-forms-map "u" 'hm--html-form-add-input-url) - (define-key hm--html-noregion-forms-map "o" 'hm--html-form-add-select-option) - (define-key hm--html-noregion-forms-map - "m" 'hm--html-form-add-select-option-menu) - (define-key hm--html-noregion-forms-map - "l" 'hm--html-form-add-select-scrolled-list) - (define-key hm--html-noregion-forms-map "\C-t" 'hm--html-form-add-textarea) - ) - -(defvar hm--html-region-forms-map nil - "Region sub keymap for inserting forms.") - -(if hm--html-region-forms-map - () - (setq hm--html-region-forms-map (make-sparse-keymap)) - - (define-key hm--html-region-forms-map "f" 'hm--html-add-form-to-region) - ) - -(defvar hm--html-region-sub-map-1 nil - "Region sub keymap for the `hm--html-mode'.") - -(if hm--html-region-sub-map-1 - () - (setq hm--html-region-sub-map-1 (make-sparse-keymap)) - (define-key hm--html-region-sub-map-1 "\C-o" hm--html-region-forms-map) - (define-key hm--html-region-sub-map-1 "\C-a" hm--html-region-anchor-map) - (define-key hm--html-region-sub-map-1 "\C-i" hm--html-region-include-map) -; (define-key hm--html-region-sub-map-1 -; "\C-t" hm--html-region-text-elements-map) - (define-key hm--html-region-sub-map-1 "\C-f" hm--html-region-frame-map) - (define-key hm--html-region-sub-map-1 "\C-s" hm--html-region-structure-map) - (define-key hm--html-region-sub-map-1 - "\C-p" hm--html-region-formatting-paragraph-map) - (define-key hm--html-region-sub-map-1 - "\C-w" hm--html-region-formatting-word-map) - ) - -(defvar hm--html-noregion-sub-map-1 nil - "Noregion sub keymap for the `hm--html-mode'.") - -(if hm--html-noregion-sub-map-1 - () - (setq hm--html-noregion-sub-map-1 (make-sparse-keymap)) - - (define-key hm--html-noregion-sub-map-1 "\C-o" hm--html-noregion-forms-map) - (define-key hm--html-noregion-sub-map-1 "\C-a" hm--html-noregion-anchor-map) - (define-key hm--html-noregion-sub-map-1 - [(control i)] hm--html-noregion-include-map) -; (define-key hm--html-noregion-sub-map-1 -; "\C-t" hm--html-noregion-text-elements-map) - (define-key hm--html-noregion-sub-map-1 "\C-f" hm--html-noregion-frame-map) - (define-key hm--html-noregion-sub-map-1 - "\C-s" hm--html-noregion-structure-map) - (define-key hm--html-noregion-sub-map-1 - "\C-p" hm--html-noregion-formatting-paragraph-map) - (define-key hm--html-noregion-sub-map-1 - "\C-w" hm--html-noregion-formatting-word-map) - ) - -(defvar hm--html-region-sub-map nil - "Region sub keymap for the `hm--html-mode'.") - -(if hm--html-region-sub-map - () - (setq hm--html-region-sub-map (make-sparse-keymap)) -; (define-key hm--html-region-sub-map "\C-n" hm--html-noregion-sub-map-1) -; (define-key hm--html-region-sub-map "\C-r" hm--html-region-sub-map-1) - (define-key hm--html-region-sub-map "\M-n" hm--html-noregion-sub-map-1) - (define-key hm--html-region-sub-map "\M-r" hm--html-region-sub-map-1) - - (if (adapt-emacs19p) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-region-sub-map - (vector key-description-list) binding)) -; (single-key-description key-description-list) binding)) - hm--html-region-sub-map-1) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-region-sub-map - key-description-list binding)) - hm--html-region-sub-map-1) - ) - ) - -(defvar hm--html-noregion-sub-map nil - "Noregion keymap for the `hm--html-mode'.") - -(if hm--html-noregion-sub-map - () - (setq hm--html-noregion-sub-map (make-sparse-keymap)) -; (define-key hm--html-noregion-sub-map "\C-n" hm--html-noregion-sub-map-1) -; (define-key hm--html-noregion-sub-map "\C-r" hm--html-region-sub-map-1) - (define-key hm--html-noregion-sub-map "\M-n" hm--html-noregion-sub-map-1) - (define-key hm--html-noregion-sub-map "\M-r" hm--html-region-sub-map-1) - - (if (adapt-emacs19p) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-noregion-sub-map - (vector key-description-list) binding)) -; (single-key-description key-description-list) binding)) - hm--html-noregion-sub-map-1) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-noregion-sub-map - key-description-list binding)) - hm--html-noregion-sub-map-1) - ) - ) - -(defvar hm--html-mode-map nil - "Normal and noregion keymap for the `hm--html-mode'.") - -(if hm--html-mode-map - () - (setq hm--html-mode-map (make-sparse-keymap)) - (define-key hm--html-mode-map - hm--html-mode-prefix-key hm--html-noregion-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-mode-map '(button3) 'hm--html-popup-menu) - (define-key hm--html-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) -; (define-key hm--html-mode-map [down-mouse-3] 'hm--html-popup-menu) - (if hm--html-expert - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - (define-key hm--html-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - (if hm--html-bind-latin-1-char-entities - (progn - (define-key hm--html-mode-map [adiaeresis] 'hm--html_ae) - (define-key hm--html-mode-map [odiaeresis] 'hm--html_oe) - (define-key hm--html-mode-map [udiaeresis] 'hm--html_ue) - (define-key hm--html-mode-map [aring] 'hm--html_aa) - (define-key hm--html-mode-map [Adiaeresis] 'hm--html_Ae) - (define-key hm--html-mode-map [Odiaeresis] 'hm--html_Oe) - (define-key hm--html-mode-map [Udiaeresis] 'hm--html_Ue) - (define-key hm--html-mode-map [Aring] 'hm--html_Aa) - (define-key hm--html-mode-map [ediaeresis] 'hm--html_ediaeresis) - (define-key hm--html-mode-map [Ediaeresis] 'hm--html_Ediaeresis) - (define-key hm--html-mode-map [idiaeresis] 'hm--html_idiaeresis) - (define-key hm--html-mode-map [Idiaeresis] 'hm--html_Idiaeresis) - (define-key hm--html-mode-map [ssharp] 'hm--html_sz) - (define-key hm--html-mode-map [aacute] 'hm--html_aacute) - (define-key hm--html-mode-map [eacute] 'hm--html_eacute) - (define-key hm--html-mode-map [iacute] 'hm--html_iacute) - (define-key hm--html-mode-map [oacute] 'hm--html_oacute) - (define-key hm--html-mode-map [uacute] 'hm--html_uacute) - (define-key hm--html-mode-map [Aacute] 'hm--html_Aacute) - (define-key hm--html-mode-map [Eacute] 'hm--html_Eacute) - (define-key hm--html-mode-map [Iacute] 'hm--html_Iacute) - (define-key hm--html-mode-map [Oacute] 'hm--html_Oacute) - (define-key hm--html-mode-map [Uacute] 'hm--html_Uacute) - (define-key hm--html-mode-map [agrave] 'hm--html_agrave) - (define-key hm--html-mode-map [egrave] 'hm--html_egrave) - (define-key hm--html-mode-map [igrave] 'hm--html_igrave) - (define-key hm--html-mode-map [ograve] 'hm--html_ograve) - (define-key hm--html-mode-map [ugrave] 'hm--html_ugrave) - (define-key hm--html-mode-map [Agrave] 'hm--html_Agrave) - (define-key hm--html-mode-map [Egrave] 'hm--html_Egrave) - (define-key hm--html-mode-map [Igrave] 'hm--html_Igrave) - (define-key hm--html-mode-map [Ograve] 'hm--html_Ograve) - (define-key hm--html-mode-map [Ugrave] 'hm--html_Ugrave) - (define-key hm--html-mode-map [ccedilla] 'hm--html_ccedilla) - (define-key hm--html-mode-map [Ccedilla] 'hm--html_Ccedilla) - (define-key hm--html-mode-map [acircumflex] 'hm--html_acircumflex) - (define-key hm--html-mode-map [ecircumflex] 'hm--html_ecircumflex) - (define-key hm--html-mode-map [icircumflex] 'hm--html_icircumflex) - (define-key hm--html-mode-map [ocircumflex] 'hm--html_ocircumflex) - (define-key hm--html-mode-map [ucircumflex] 'hm--html_ucircumflex) - (define-key hm--html-mode-map [Acircumflex] 'hm--html_Acircumflex) - (define-key hm--html-mode-map [Ecircumflex] 'hm--html_Ecircumflex) - (define-key hm--html-mode-map [Icircumflex] 'hm--html_Icircumflex) - (define-key hm--html-mode-map [Ocircumflex] 'hm--html_Ocircumflex) - (define-key hm--html-mode-map [Ucircumflex] 'hm--html_Ucircumflex) - (define-key hm--html-mode-map [atilde] 'hm--html_atilde) - (define-key hm--html-mode-map [otilde] 'hm--html_otilde) - (define-key hm--html-mode-map [ntilde] 'hm--html_ntilde) - (define-key hm--html-mode-map [Atilde] 'hm--html_Atilde) - (define-key hm--html-mode-map [Otilde] 'hm--html_Otilde) - (define-key hm--html-mode-map [Ntilde] 'hm--html_Ntilde) - (define-key hm--html-mode-map [eth] 'hm--html_eth) - (define-key hm--html-mode-map [ETH] 'hm--html_Eth) - (define-key hm--html-mode-map [thorn] 'hm--html_thorn) - (define-key hm--html-mode-map [THORN] 'hm--html_Thorn) - )) - (define-key hm--html-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-mode-map "&" 'hm--html-smart-ampersand) - ) - -(defvar hm--html-region-mode-map nil - "Region keymap for the `hm--html-mode'.") - -(if hm--html-region-mode-map - () - (setq hm--html-region-mode-map (make-sparse-keymap)) - (define-key hm--html-region-mode-map - hm--html-mode-prefix-key hm--html-region-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-region-mode-map - '(button3) 'hm--html-popup-menu-region) - (define-key hm--html-region-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) -; (define-key hm--html-region-mode-map -; [down-mouse-3] 'hm--html-popup-menu-region) - (if hm--html-expert - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map)) - (define-key hm--html-region-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - ;; It maybe a better idea to set the following to undefine in this list... -; (if hm--html-bind-latin-1-char-entities -; (progn -; (define-key hm--html-region-mode-map [adiaeresis] 'hm--html_ae) -; (define-key hm--html-region-mode-map [odiaeresis] 'hm--html_oe) -; (define-key hm--html-region-mode-map [udiaeresis] 'hm--html_ue) -; (define-key hm--html-region-mode-map [aring] 'hm--html_aa) -; (define-key hm--html-region-mode-map [Adiaeresis] 'hm--html_Ae) -; (define-key hm--html-region-mode-map [Odiaeresis] 'hm--html_Oe) -; (define-key hm--html-region-mode-map [Udiaeresis] 'hm--html_Ue) -; (define-key hm--html-region-mode-map [Aring] 'hm--html_Aa) -; (define-key hm--html-region-mode-map -; [ediaeresis] 'hm--html_ediaeresis) -; (define-key hm--html-region-mode-map -; [Ediaeresis] 'hm--html_Ediaeresis) -; (define-key hm--html-region-mode-map -; [idiaeresis] 'hm--html_idiaeresis) -; (define-key hm--html-region-mode-map -; [Idiaeresis] 'hm--html_Idiaeresis) -; (define-key hm--html-region-mode-map [ssharp] 'hm--html_sz) -; (define-key hm--html-region-mode-map [aacute] 'hm--html_aacute) -; (define-key hm--html-region-mode-map [eacute] 'hm--html_eacute) -; (define-key hm--html-region-mode-map [iacute] 'hm--html_iacute) -; (define-key hm--html-region-mode-map [oacute] 'hm--html_oacute) -; (define-key hm--html-region-mode-map [uacute] 'hm--html_uacute) -; (define-key hm--html-region-mode-map [Aacute] 'hm--html_Aacute) -; (define-key hm--html-region-mode-map [Eacute] 'hm--html_Eacute) -; (define-key hm--html-region-mode-map [Iacute] 'hm--html_Iacute) -; (define-key hm--html-region-mode-map [Oacute] 'hm--html_Oacute) -; (define-key hm--html-region-mode-map [Uacute] 'hm--html_Uacute) -; (define-key hm--html-region-mode-map [agrave] 'hm--html_agrave) -; (define-key hm--html-region-mode-map [egrave] 'hm--html_egrave) -; (define-key hm--html-region-mode-map [igrave] 'hm--html_igrave) -; (define-key hm--html-region-mode-map [ograve] 'hm--html_ograve) -; (define-key hm--html-region-mode-map [ugrave] 'hm--html_ugrave) -; (define-key hm--html-region-mode-map [Agrave] 'hm--html_Agrave) -; (define-key hm--html-region-mode-map [Egrave] 'hm--html_Egrave) -; (define-key hm--html-region-mode-map [Igrave] 'hm--html_Igrave) -; (define-key hm--html-region-mode-map [Ograve] 'hm--html_Ograve) -; (define-key hm--html-region-mode-map [Ugrave] 'hm--html_Ugrave) -; (define-key hm--html-region-mode-map [ccedilla] 'hm--html_ccedilla) -; (define-key hm--html-region-mode-map [Ccedilla] 'hm--html_Ccedilla) -; (define-key hm--html-region-mode-map -; [acircumflex] 'hm--html_acircumflex) -; (define-key hm--html-region-mode-map -; [ecircumflex] 'hm--html_ecircumflex) -; (define-key hm--html-region-mode-map -; [icircumflex] 'hm--html_icircumflex) -; (define-key hm--html-region-mode-map -; [ocircumflex] 'hm--html_ocircumflex) -; (define-key hm--html-region-mode-map -; [ucircumflex] 'hm--html_ucircumflex) -; (define-key hm--html-region-mode-map -; [Acircumflex] 'hm--html_Acircumflex) -; (define-key hm--html-region-mode-map -; [Ecircumflex] 'hm--html_Ecircumflex) -; (define-key hm--html-region-mode-map -; [Icircumflex] 'hm--html_Icircumflex) -; (define-key hm--html-region-mode-map -; [Ocircumflex] 'hm--html_Ocircumflex) -; (define-key hm--html-region-mode-map -; [Ucircumflex] 'hm--html_Ucircumflex) -; (define-key hm--html-region-mode-map [atilde] 'hm--html_atilde) -; (define-key hm--html-region-mode-map [otilde] 'hm--html_otilde) -; (define-key hm--html-region-mode-map [ntilde] 'hm--html_ntilde) -; (define-key hm--html-region-mode-map [Atilde] 'hm--html_Atilde) -; (define-key hm--html-region-mode-map [Otilde] 'hm--html_Otilde) -; (define-key hm--html-region-mode-map [Ntilde] 'hm--html_Ntilde) -; (define-key hm--html-region-mode-map [eth] 'hm--html_eth) -; (define-key hm--html-region-mode-map [ETH] 'hm--html_Eth) -; (define-key hm--html-region-mode-map [thorn] 'hm--html_thorn) -; (define-key hm--html-region-mode-map [THORN] 'hm--html_Thorn) -; )) - (define-key hm--html-region-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-region-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-region-mode-map "&" 'hm--html-smart-ampersand) - ) - - -;;; For the hm--html minor modes -(defvar hm--html-minor-mode-map nil - "Normal and noregion keymap for the `hm--html-minor-mode'.") - -(if hm--html-minor-mode-map - () - (setq hm--html-minor-mode-map (make-sparse-keymap)) - (define-key hm--html-minor-mode-map - hm--html-minor-mode-prefix-key hm--html-noregion-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-minor-mode-map - '(button3) 'hm--html-popup-minor-html-menu) - (define-key hm--html-minor-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) - (if hm--html-expert - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - (define-key hm--html-minor-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - (define-key hm--html-minor-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-minor-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-minor-mode-map "&" 'hm--html-smart-ampersand) - ) - - -(defvar hm--html-minor-region-mode-map nil - "Region keymap for the `hm--html-minor-mode'.") - -(if hm--html-minor-region-mode-map - () - (setq hm--html-minor-region-mode-map (make-sparse-keymap)) - (define-key hm--html-minor-region-mode-map - hm--html-minor-mode-prefix-key hm--html-region-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-minor-region-mode-map - '(button3) 'hm--html-popup-minor-html-menu-region) - (define-key hm--html-minor-region-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) - (if hm--html-expert - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map)) - (define-key hm--html-minor-region-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - (define-key hm--html-minor-region-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-minor-region-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-minor-region-mode-map "&" 'hm--html-smart-ampersand) - ) - - -;;; Announce the feature hm--html-keys -(provide 'hm--html-keys) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html-menu.el --- a/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,860 +0,0 @@ -;;; hm--html-menu --- A menu for the hm--html-mode. -;;; -;;; $Id: hm--html-menu.el,v 1.8 1997/07/26 22:09:45 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines pulldown and popup menus for the html mode (hm--html-mode). -;;; -;;; You should also have the w3 package from William M. Perry, for -;;; browsing html- files in the xemacs and the program Xmosaic together -;;; with the file html-view.el from Ron Tapia for browsing html- files -;;; in the Xmosaic. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; -;;; Look at the files hm--html-mode.el and hm--html-configuration -;;; for further installation points. -;;; - -;; -;; Menu "HTML" -;; - -(defvar hm--html-pulldown-menu nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-region-expert nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-region-novice nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-noregion-expert nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-noregion-novice nil "*A List with the HTML-Menu.") - -(setq hm--html-menu-noregion-expert - '("HTML Noregion Expert Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link t] - ["General link..." hm--html-add-normal-link t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link t] - ["Info link..." hm--html-add-info-link t] - ["Gopher link..." hm--html-add-gopher-link t] - ["File link..." hm--html-add-file-link t] - "----" - ["Ftp link..." hm--html-add-ftp-link t] - ["News link..." hm--html-add-news-link t] - ["Mailbox link..." hm--html-add-mail-box-link t] - ["Mailto link..." hm--html-add-mailto-link t] - ["Wais link (direct)..." hm--html-add-direct-wais-link t] - ["Wais link (gateway)..." hm--html-add-wais-link t] - "----" - ["Proggate link..." hm--html-add-proggate-link t] - ["Local Proggate link..." hm--html-add-local-proggate-link t] - "----" - ["Link target..." hm--html-add-link-target t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame t] - ["Frame template..." - (hm--html-insert-template hm--html-frame-template-file) - (file-exists-p hm--html-frame-template-file)] - "----" - ["Doctype" hm--html-add-doctype t] - ["Html" hm--html-add-html t] - ["Head" hm--html-add-head t] - ["Body" hm--html-add-body t] - "----" - ["Title and Header..." hm--html-add-title-and-header t] - ["Title..." hm--html-add-title t] - ["Header..." hm--html-add-header t] - ["Address" hm--html-add-address t] - ["Signature" hm--html-add-signature t] - "----" - ["Meta information..." hm--html-add-meta t] - ["Node Link..." hm--html-add-normal-node-link t] - ["Isindex..." hm--html-add-isindex t] - ["Document Base..." hm--html-add-base t] - "----" - ["Created comment" hm--html-insert-created-comment t] - ["Changed comment" hm--html-insert-changed-comment t] - ["Modified line" hm--html-insert-modified-line t] - ["New date in title" hm--html-new-date t] - ) - ("Structure" - ["Menu or list item" hm--html-add-list-or-menu-item t] - ["Menu" hm--html-add-menu t] - ["Unordered list" hm--html-add-list t] - ["Ordered list" hm--html-add-numberlist t] - ["Directory list" hm--html-add-directory-list t] - "----" - ["Description list" hm--html-add-description-list t] - ["Description title" hm--html-add-description-title t] - ["Description entry" hm--html-add-description-entry t] - ["Description title + entry" - hm--html-add-description-title-and-entry t] - "----" - ["Table..." hm--html-add-table t] - ["Table title..." hm--html-add-table-title t] - ["Table header..." hm--html-add-table-header t] - ["Table first row..." hm--html-add-first-table-row t] - ["Table additional row..." hm--html-add-additional-table-row t] - ("Additional Commands" - ["Table row frame..." hm--html-add-row-frame t] - ["Table header entry..." hm--html-add-header-entry t] - ["Table row entry..." hm--html-add-row-entry t] - ["Span columns..." hm--html-table-add-colspan-attribute t] - ["Span rows..." hm--html-table-add-rowspan-attribute t] - ) - "----" - ["Paragraph container" hm--html-add-paragraph t] - ["Paragraph start tag" hm--html-add-paragraph-separator t] - ["Document division" hm--html-add-document-division t] - ["New line" hm--html-add-line-break t] - ["Horizontal rule" hm--html-add-horizontal-rule t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext t] - ["Preformatted" hm--html-add-preformatted t] - ["Blockquote" hm--html-add-blockquote t] - "----" - ["Basefont..." hm--html-add-basefont t] - ["Font..." hm--html-add-font t] - ["Center" hm--html-add-center t] - ["Style" hm--html-add-style t] - "----" - ["HTML Comment" hm--html-add-comment t] -; ["Listing" hm--html-add-listing t] -; ["Abstract" hm--html-add-abstract t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold t] - ["Italic" hm--html-add-italic t] - ["Typewriter" hm--html-add-fixed t] - ["Small" hm--html-add-small t] - ["Big" hm--html-add-big t] - ["Superscript" hm--html-add-superscript t] - ["Subscript" hm--html-add-subscript t] - "----" - ["Underline" hm--html-add-underline t] - ["Strikethru" hm--html-add-strikethru t] - "----" -; ["Emphasized" hm--html-add-emphasized t] -; ["Strong" hm--html-add-strong t] -; "----" - ("Phrase" - ["Emphasized" hm--html-add-emphasized t] - ["Strong" hm--html-add-strong t] - "----" - ["Definition" hm--html-add-definition t] - ["Keyboard" hm--html-add-keyboard t] - ["Variable" hm--html-add-variable t] - ["Code" hm--html-add-code t] - ["Sample" hm--html-add-sample t] - ["Citation" hm--html-add-citation t] - ) -;; All the following commands are still implemented, but most -;; of them are not defined in HTM 3.2 -;; You've to load hm--html-not-standard.el to use them -; ("Computing" -; ["Definition" hm--html-add-definition t] -; ["Keyboard" hm--html-add-keyboard t] -; ["Command" hm--html-add-command t] -; ["Argument" hm--html-add-argument t] -; ["Option" hm--html-add-option t] -; ["Variable" hm--html-add-variable t] -; ["Instance" hm--html-add-instance t] -; ["Code" hm--html-add-code t] -; ["Sample" hm--html-add-sample t] -; ) -; ("Literature" -; ["Quote" hm--html-add-quote t] -; ["Acronym" hm--html-add-acronym t] -; ["Abbreviation" hm--html-add-abbreviation t] -; ["Citation" hm--html-add-citation t] -; ["Literature" hm--html-add-literature t] -; ["Publication" hm--html-add-publication t] -; ["ISBN" hm--html-add-isbn t] -; ) -; ("Person" -; ["Person" hm--html-add-person t] -; ["Author" hm--html-add-author t] -; ["Editor" hm--html-add-editor t] -; ["Credits" hm--html-add-credits t] -; ["Copyright" hm--html-add-copyright t] -; ) -; "----" -; ["Footnote" hm--html-add-footnote t] -; ["Margin" hm--html-add-margin t] -; "----" -; ["HTML Comment" hm--html-add-comment t] - ) - ("Include" - ["Top aligned image..." hm--html-add-image-top t] - ["Middle aligned image..." hm--html-add-image-middle t] - ["Bottom aligned image..." hm--html-add-image-bottom t] - ["Image as map? ..." hm--html-add-image t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Image map..." hm--html-add-image-map t] - ["Map..." hm--html-add-map t] - ["Area..." hm--html-add-area t] - "----" - ["Applet..." hm--html-add-applet t] - ["Parameter..." hm--html-add-applet-parameter t] - ["Script" hm--html-add-script t] -; "----" -; ["File..." hm--html-add-server-side-include-file t] -; ["Command..." hm--html-add-server-side-include-command t] -; ["Command with isindex parameter..." -; hm--html-add-server-side-include-command-with-isindex-parameter -; t] - ) - ("Forms" - ["Form..." hm--html-add-form t] - "----" - ["Text field..." hm--html-form-add-input-text t] - ["Password field..." hm--html-form-add-input-password t] - ["Isindex field..." hm--html-form-add-input-isindex t] - ["Integer field..." hm--html-form-add-input-integer t] - ["Float field..." hm--html-form-add-input-float t] - ["Date field..." hm--html-form-add-input-date t] - ["Url field..." hm--html-form-add-input-url t] - ["Scribble field..." hm--html-form-add-input-scribble t] - "----" - ["Checkbox button..." hm--html-form-add-input-checkbox t] - ["Radio button..." hm--html-form-add-input-radio t] - ["Reset button..." hm--html-form-add-input-reset t] - ["Submit button..." hm--html-form-add-input-submit t] - ["Image button..." hm--html-form-add-input-image t] - ["Audio button..." hm--html-form-add-input-audio t] - "----" - ["Option Menu..." hm--html-form-add-select-option-menu t] - ["Scrolled List..." hm--html-form-add-select-scrolled-list t] - ["Option..." hm--html-form-add-select-option t] - "----" - ["Textarea..." hm--html-form-add-textarea t] - ) - )) - - -(setq hm--html-menu-noregion-novice - '("HTML No-region Novice Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link t] - ["File link..." hm--html-add-file-link t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame t] - "----" - ["Title and Header..." hm--html-add-title-and-header t] - ["Signature" hm--html-add-signature t] - ) - ("Structure" - ["Menu item" hm--html-add-list-or-menu-item t] - ["Menu" hm--html-add-menu t] - "----" - ["Paragraph Container" hm--html-add-paragraph t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext t] - ["Preformatted" hm--html-add-preformatted t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold t] - ["Italic" hm--html-add-italic t] - ["Underline" hm--html-add-underline t] - ["Typewriter" hm--html-add-fixed t] - ))) - -(setq hm--html-menu-region-expert - '("HTML Region Expert Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link-to-region t] - ["General link..." hm--html-add-normal-link-to-region t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link-to-region t] - ["Info link..." hm--html-add-info-link-to-region t] - ["Gopher link..." hm--html-add-gopher-link-to-region t] - ["File link..." hm--html-add-file-link-to-region t] - "----" - ["Ftp link..." hm--html-add-ftp-link-to-region t] - ["News link..." hm--html-add-news-link-to-region t] - ["Mailbox link..." hm--html-add-mail-box-link-to-region t] - ["Mailto link..." hm--html-add-mailto-link-to-region t] - ["WAIS link (direct)..." hm--html-add-direct-wais-link-to-region t] - ["WAIS link (gateway)..." hm--html-add-wais-link-to-region t] - "----" - ["Proggate link..." hm--html-add-proggate-link-to-region t] - ["Local Proggate link..." - hm--html-add-local-proggate-link-to-region - t] - "----" - ["Link target..." hm--html-add-link-target-to-region t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame-with-region t] - "----" - ["Head" hm--html-add-head-to-region t] - ["Body" hm--html-add-body-to-region t] - "----" - ["Title and Header..." hm--html-add-title-and-header-to-region t] - ["Title" hm--html-add-title-to-region t] - ["Header..." hm--html-add-header-to-region t] - ["Address" hm--html-add-address-to-region t] - ) - ("Structure" - ["Menu item" hm--html-add-list-or-menu-item-to-region t] - ["Menu" hm--html-add-menu-to-region t] - ["Unordered list" hm--html-add-list-to-region t] - ["Ordered list" hm--html-add-numberlist-to-region t] - ["Directory list" hm--html-add-directorylist-to-region t] - "----" - ["Description list" hm--html-add-description-list-to-region t] - ["Description title" hm--html-add-description-title-to-region t] - ["Description entry" hm--html-add-description-entry-to-region t] - "----" - ["Table..." hm--html-add-table-to-region t] - ["Table Title..." hm--html-add-table-title-to-region t] - ("Additional Commands" - ["Table row frame..." hm--html-add-row-frame-to-region t] - ) - "----" - ["Paragraph container" hm--html-add-paragraph-to-region t] - ["Document division" hm--html-add-document-division-to-region t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext-to-region t] - ["Preformatted" hm--html-add-preformatted-to-region t] - ["Blockquote" hm--html-add-blockquote-to-region t] - "----" - ["Font..." hm--html-add-font-to-region t] - ["Center" hm--html-add-center-to-region t] - ["Style" hm--html-add-style-to-region t] - "----" - ["HTML Comment" hm--html-add-comment-to-region t] -; ["Listing" hm--html-add-listing-to-region t] -; ["Abstract" hm--html-add-abstract-to-region t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold-to-region t] - ["Italic" hm--html-add-italic-to-region t] - ["Typewriter" hm--html-add-fixed-to-region t] - ["Small" hm--html-add-small-to-region t] - ["Big" hm--html-add-big-to-region t] - ["Superscript" hm--html-add-superscript-to-region t] - ["Subscript" hm--html-add-subscript-to-region t] - "----" - ["Underline" hm--html-add-underline-to-region t] - ["Strikethru" hm--html-add-strikethru-to-region t] - ;; ["Render" hm--html-add-render-to-region t] - "----" -; ["Emphasized" hm--html-add-emphasized-to-region t] -; ["Strong" hm--html-add-strong-to-region t] -; "----" - ("Phrase" - ["Emphasized" hm--html-add-emphasized-to-region t] - ["Strong" hm--html-add-strong-to-region t] - "----" - ["Definition" hm--html-add-definition-to-region t] - ["Keyboard" hm--html-add-keyboard-to-region t] - ["Variable" hm--html-add-variable-to-region t] - ["Code" hm--html-add-code-to-region t] - ["Sample" hm--html-add-sample-to-region t] - ["Citation" hm--html-add-citation-to-region t] - ) -;; All the following commands are still implemented, but most -;; of them are not defined in HTM 3.2 -; ("Computing" -; ["Definition" hm--html-add-definition-to-region t] -; ["Keyboard" hm--html-add-keyboard-to-region t] -; ["Command" hm--html-add-command-to-region t] -; ["Argument" hm--html-add-argument-to-region t] -; ["Option" hm--html-add-option-to-region t] -; ["Variable" hm--html-add-variable-to-region t] -; ["Instance" hm--html-add-instance-to-region t] -; ["Code" hm--html-add-code-to-region t] -; ["Sample" hm--html-add-sample-to-region t] -; ) -; ("Literature" -; ["Quote" hm--html-add-quote-to-region t] -; ["Acronym" hm--html-add-acronym-to-region t] -; ["Abbrevation" hm--html-add-abbrevation-to-region t] -; ["Citation" hm--html-add-citation-to-region t] -; ["Literature" hm--html-add-literature-to-region t] -; ["Publication" hm--html-add-publication-to-region t] -; ["ISBN" hm--html-add-isbn-to-region t] -; ) -; ("Person" -; ["Person" hm--html-add-person-to-region t] -; ["Author" hm--html-add-author-to-region t] -; ["Editor" hm--html-add-editor-to-region t] -; ["Credits" hm--html-add-credits-to-region t] -; ["Copyright" hm--html-add-copyright-to-region t] -; ) -; "----" -; ["Footnote" hm--html-add-footnote-to-region t] -; ["Margin" hm--html-add-margin-to-region t] -; "----" -; ["HTML Comment" hm--html-add-comment-to-region t] - ) - ("Include" - ["Map..." hm--html-add-map-to-region t] - "----" - ["Applet..." hm--html-add-applet-to-region t] - ["Script" hm--html-add-script-to-region t] - ) - ("Forms" - ["Form..." hm--html-add-form-to-region t]) - )) - - -(setq hm--html-menu-region-novice - '("HTML Region Novice Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link-to-region t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link-to-region t] - ["File link..." hm--html-add-file-link-to-region t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame-with-region t] - "----" - ["Title and Header..." hm--html-add-title-and-header-to-region t] - ) - ("Structure" - ["Menu item" hm--html-add-list-or-menu-item-to-region t] - ["Menu" hm--html-add-menu-to-region t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext-to-region t] - ["Preformatted" hm--html-add-preformatted-to-region t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold-to-region t] - ["Italic" hm--html-add-italic-to-region t] - ["Underline" hm--html-add-underline-to-region t] - ["Typewriter" hm--html-add-fixed-to-region t] - ) - )) - - -(if (adapt-xemacsp) - ;; The reason for this if form is, that the Emacs 19 can't - ;; work correct with `:keys "\\[idd-help-mouse-drag-and-drop]"' - (setq hm--html-pulldown-menu - '("HTML Config Menu" - ("Set popup menu" - ["Novice menu" - hm--html-use-novice-menu - :active t - :style radio - :selected (not hm--html-expert)] - ["Expert menu" - hm--html-use-expert-menu - :active t - :style radio - :selected hm--html-expert] - ) - ["Reload config files" hm--html-load-config-files t] - ["Templates (fixed dirs) ..." - hm--html-insert-template-from-fixed-dirs - t] - ["Templates ..." hm--html-insert-template t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - ["Drag & Drop Help" - idd-start-help-mouse-drag-and-drop - :active t - :keys "\\[idd-help-mouse-drag-and-drop]"] - "----" - ["Remove numeric names" hm--html-remove-numeric-names t] - ["Quotify hrefs" hm--html-quotify-hrefs t] - "----" - ["Submit bug report..." hm--html-submit-bug-report t] - ["WWW Package Docs" hm--html-view-www-package-docu t] - "----" - ("Preview Document" - ["Netscape view buffer" (hm--html-send-buffer-to-netscape - (current-buffer)) t] - "----" - ["Xmosaic start" html-view-start-mosaic t] - ["Xmosaic view buffer" html-view-view-buffer t] - ["Xmosaic view file" html-view-view-file t] - ["Xmosaic goto url" html-view-goto-url t] - ["Xmosaic get display" html-view-get-display t] - "----" - ["W3 start" w3 t] - ["W3 view buffer" w3-preview-this-buffer t] - ["W3 open remote file..." w3-fetch t] - ["W3 open local..." w3-open-local t] - ["W3 use hotlist..." w3-use-hotlist t] - ) - )) - (setq hm--html-pulldown-menu - '("HTML Config Menu" - ("Set popup menu" - ["Novice menu" - hm--html-use-novice-menu - :active t - :style radio - :selected (not hm--html-expert)] - ["Expert menu" - hm--html-use-expert-menu - :active t - :style radio - :selected hm--html-expert] - ) - ["Reload config files" hm--html-load-config-files t] - ["Templates (fixed dirs) ..." - hm--html-insert-template-from-fixed-dirs - t] - ["Templates ..." hm--html-insert-template t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t] - ["Drag & Drop Help" - idd-start-help-mouse-drag-and-drop - :active t] - "----" - ["Remove numeric names" hm--html-remove-numeric-names t] - ["Quotify hrefs" hm--html-quotify-hrefs t] - "----" - ["Submit bug report..." hm--html-submit-bug-report t] - ["WWW Package Docs" hm--html-view-www-package-docu t] - "----" - ("Preview Document" - ["Netscape view buffer" (hm--html-send-buffer-to-netscape - (current-buffer)) t] - "----" - ["Xmosaic start" html-view-start-mosaic t] - ["Xmosaic view buffer" html-view-view-buffer t] - ["Xmosaic view file" html-view-view-file t] - ["Xmosaic goto url" html-view-goto-url t] - ["Xmosaic get display" html-view-get-display t] - "----" - ["W3 start" w3 t] - ["W3 view buffer" w3-preview-this-buffer t] - ["W3 open remote file..." w3-fetch t] - ["W3 open local..." w3-open-local t] - ["W3 use hotlist..." w3-use-hotlist t] - ) - )) - ) - -(if (adapt-xemacsp) - (defun hm--install-html-menu (menu-name) - (if (and current-menubar (not (assoc menu-name current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-submenu nil - (cons menu-name (cdr hm--html-pulldown-menu)) - "HTML")))) - - (defun hm--install-html-menu (menu-name) - (if (eq major-mode 'hm--html-mode) - (easy-menu-define hm--html-menu-map - hm--html-mode-map - "The hm--html-mode pulldown menu." - (cons menu-name - (cdr hm--html-pulldown-menu))) - (easy-menu-define hm--html-minor-menu-map - hm--html-minor-mode-map - "The hm--html-minor-mode pulldown menu." - (cons menu-name - (cdr hm--html-pulldown-menu)))) - )) - -(if (adapt-emacs19p) - (progn - - (setq hm--html-menu-noregion-expert-map - (make-lucid-menu-keymap (car hm--html-menu-noregion-expert) - (cdr hm--html-menu-noregion-expert))) - - (setq hm--html-menu-region-expert-map - (make-lucid-menu-keymap (car hm--html-menu-region-expert) - (cdr hm--html-menu-region-expert))) - - (setq hm--html-menu-noregion-novice-map - (make-lucid-menu-keymap (car hm--html-menu-noregion-novice) - (cdr hm--html-menu-noregion-novice))) - - (setq hm--html-menu-region-novice-map - (make-lucid-menu-keymap (car hm--html-menu-region-novice) - (cdr hm--html-menu-region-novice))) - - ;; Speeds up the first popup of a menu - (if hm--html-expert - (progn - (x-popup-menu nil hm--html-menu-noregion-expert-map) - (x-popup-menu nil hm--html-menu-region-expert-map) - ) - (x-popup-menu nil hm--html-menu-noregion-novice-map) - (x-popup-menu nil hm--html-menu-region-novice-map)) - - - ) - - (defun hm--html-popup-menu (event) - "Pops the HTML- menu up, if no region is active." - (interactive "@e") - (if hm--html-expert - (popup-menu hm--html-menu-noregion-expert) - (popup-menu hm--html-menu-noregion-novice))) - - - (defun hm--html-popup-menu-region (event) - "Pops the HTML- menu up, if a region is active." - (interactive "@e") - (if hm--html-expert - (popup-menu hm--html-menu-region-expert) - (popup-menu hm--html-menu-region-novice))) - ) - - -(if (adapt-xemacsp) - (progn - - (defun hm--html-use-novice-menu () - "Changes the HTML popup menu to the novice menu." - (interactive) - (setq hm--html-expert nil) - ) - - - (defun hm--html-use-expert-menu () - "Changes the HTML popup menu to the expert menu." - (interactive) - (setq hm--html-expert t) - ) - ) - - ;; For the Emacs 19 - (defun hm--html-use-novice-menu () - "Changes the HTML popup menu to the novice menu." - (interactive) - (setq hm--html-expert nil) - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map) - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map) - (if (not hm--html-region-mode) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - (if (not hm--html-minor-region-mode) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - ) - - (defun hm--html-use-expert-menu () - "Changes the HTML popup menu to the expert menu." - (interactive) - (setq hm--html-expert t) - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (if (not hm--html-region-mode) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map)) - (if (not hm--html-minor-region-mode) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map)) - ) - ) - - -(defvar hm--html-use-psgml t - "Set this to t, if functions from the psgml-mode should be used.") - -;;; Popup the menus in the minor mode - -(if (adapt-xemacsp) - (progn - - (defadvice sgml-xemacs-get-popup-value (around - hm--html-popup-menu-advice - activate) - "Calls `hm--html-sgml-xemacs-get-popup-value' instead of the original. -`hm--html-sgml-xemacs-get-popup-value' is only called, if the -`hm--html-minor-mode' is active. -`hm--html-sgml-xemacs-get-popup-value' adds the 'hm--html-mode' popup -menus to the psgml popup menu." - (if hm--html-minor-mode - (setq ad-return-value - (hm--html-sgml-xemacs-get-popup-value (ad-get-arg 0))) - ad-do-it)) - - (defun hm--html-sgml-xemacs-get-popup-value (menudesc) - (let ((value nil) - (event nil)) - ;; (popup-menu menudesc) - (popup-menu (append hm--html-popup-menu ; for the hm--html-menu - (list "==" ; - (car menudesc) ; - "==") ; - (cdr menudesc))) ; - (while (popup-up-p) - (setq event (next-command-event event)) - (cond ((misc-user-event-p event) - (cond - ((eq (event-object event) 'abort) - (signal 'quit nil)) - ((eq (event-object event) 'menu-no-selection-hook) - nil) - ((commandp (event-object event)) ; for the - (set-mark hm--html-mark) ; - (goto-char hm--html-point) ; - (call-interactively (event-object event)) ; hm--html-menu - (signal 'quit nil)) ; items - (t - (eval (event-object event))))) - ((button-release-event-p event) ; don't beep twice - nil) - ((and (fboundp 'event-matches-key-specifier-p) - (event-matches-key-specifier-p event (quit-char))) - (signal 'quit nil)) - (t - (beep) - (message "please make a choice from the menu.")))) - value)) - ) - - ;; For the Emacs 19 - (defun hm--html-add-major-menu-to-minor-menus () - "Adds an entry to get the general major menu in the minor mode menus. -This function is only used in the Emacs 19." - (define-key hm--html-menu-noregion-novice-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu)) - (define-key hm--html-menu-noregion-expert-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu)) - (define-key hm--html-menu-region-novice-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu)) - (define-key hm--html-menu-region-expert-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu))) - - (defun hm--html-remove-major-menu-from-minor-menus () - "Removes the entry to get the general major menu in the minor mode menus. -This function is only used in the Emacs 19." - (define-key hm--html-menu-noregion-novice-map - [mouse-major-mode-menu] 'undefined) - (define-key hm--html-menu-noregion-expert-map - [mouse-major-mode-menu] 'undefined) - (define-key hm--html-menu-region-novice-map - [mouse-major-mode-menu] 'undefined) - (define-key hm--html-menu-region-expert-map - [mouse-major-mode-menu] 'undefined)) - ) - -(if (adapt-xemacsp) - (progn - - (defun hm--html-popup-minor-html-menu (event) - "Pops the HTML- menu up, if no region is active." - (interactive "@e") - (if (eq major-mode 'html-mode) - (if hm--html-use-psgml - (let ((hm--html-popup-menu (if hm--html-expert - hm--html-menu-noregion-expert - hm--html-menu-noregion-novice)) - (hm--html-point (point)) - (hm--html-mark (mark))) - (sgml-tags-menu event)) - (if hm--html-expert - (popup-menu hm--html-menu-noregion-expert) - (popup-menu hm--html-menu-noregion-novice)) - ) - (popup-menu (append ;mode-popup-menu - ;'("===") - (if hm--html-expert - hm--html-menu-noregion-expert - hm--html-menu-noregion-novice) - (list "===" - (car mode-popup-menu) - "===") - (cdr mode-popup-menu) - )))) - - - - (defun hm--html-popup-minor-html-menu-region (event) - "Pops the HTML- menu up, if a region is active." - (interactive "@e") - (if (eq major-mode 'html-mode) - (if hm--html-use-psgml - (let ((hm--html-popup-menu (if hm--html-expert - hm--html-menu-region-expert - hm--html-menu-region-novice)) - (hm--html-point (point)) - (hm--html-mark (mark))) - (sgml-tags-menu event)) - (if hm--html-expert - (popup-menu hm--html-menu-region-expert) - (popup-menu hm--html-menu-region-novice)) - ) - (popup-menu (append mode-popup-menu - '("---") - (if hm--html-expert - hm--html-menu-noregion-expert - hm--html-menu-noregion-novice))))) - - )) - - -(run-hooks 'hm--html-menu-load-hook) - - -;;; Announce the feature hm--html-menu -(provide 'hm--html-menu) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html-mode.el --- a/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,348 +0,0 @@ -;;; hm--html-mode --- Major mode for editing HTML documents for the WWW - -;; Copyright (C) 1996, 1997 Heiko Muenkel - -;; Author: Heiko Muenkel -;; Keywords: hypermedia languages help docs wp - -;; $Id: hm--html-mode.el,v 1.7 1997/07/26 22:09:45 steve Exp $ - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your -;; option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; See the file COPYING. if not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA - -;;; Synched up with: Not part of Emacs. - -;;; Commentary: - -;; Description: - -;; This file defines the hm--html-mode, a mode for editing html -;; files. It is the main file of the package hm--html-menus. -;; Previous releases had used the file html-mode.el from Marc -;; Andreessen. In that times the mode was called html-mode. I've -;; changed the name of the mode to distinquish it from other -;; html modes. But feel free to set a -;; (defalias 'hm--html-mode 'html-mode) -;; to get back the old name of the mode. - -;; In the earlier releases of the package the main file was -;; hm--html-menu.el. This has been changed to hm--html-mode.el. - - -;; Installation: - -;; Put this file and all the other files of the package -;; in one of your load path directories and the -;; following lines in your .emacs: - -;; (autoload 'hm--html-mode "hm--html-mode" "HTML major mode." t) - -;; (or (assoc "\\.html$" auto-mode-alist) -;; (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) -;; auto-mode-alist))) -;; If there is already another html-mode (like psgml in the XEmacs -;; 19.14, then you must put the following instead of the last form -;; in your .emacs: -;; (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) -;; auto-mode-alist)) - -;; But you can also use the hm--html-minor-mode as an addition to -;; the psgml html modes. For that you've to put the following line in -;; your .emacs: -;; (add-hook 'html-mode-hook 'hm--html-minor-mode) - -;; Note: This works only in an XEmacs version greater than 19.14 and -;; also not in the XEmacs 20.0. - -;; Look at the file hm--html-configuration for further installation -;; points. - -;;; Code: - -(require 'font-lock) -(require 'cl) -(require 'adapt) -(require 'hm--date) -(require 'hm--html) -;(require 'hm--html-not-standard) - -(eval-when-compile - (require 'hm--html-configuration)) - -(hm--html-load-config-files) -(require 'hm--html-indentation) - -(defvar hm--html-minor-mode nil - "Non-nil, if the `hm--html-minor-mode' is active.") - -(require 'hm--html-menu) - -(require 'hm--html-keys) - -;(defvar hm--html-minor-mode nil -; "Non-nil, if the `hm--html-minor-mode' is active.") -; -;(require 'hm--html-menu) -(require 'hm--html-drag-and-drop) - - -;;; The package version -(defconst hm--html-menus-package-maintainer "muenkel@tnt.uni-hannover.de") - -(defconst hm--html-menus-package-name "hm--html-menus") - -(defconst hm--html-menus-package-version "5.8") - - -;;; Generate the help buffer faces -(hm--html-generate-help-buffer-faces) - -;;; syntax table - -(defvar hm--html-mode-syntax-table nil - "Syntax table used while in html mode.") - -(if hm--html-mode-syntax-table - () - (setq hm--html-mode-syntax-table (make-syntax-table)) -; (modify-syntax-entry ?\" ". " hm--html-mode-syntax-table) -; (modify-syntax-entry ?\\ ". " hm--html-mode-syntax-table) -; (modify-syntax-entry ?' "w " hm--html-mode-syntax-table) - (modify-syntax-entry ?\\ "." hm--html-mode-syntax-table) - (modify-syntax-entry ?' "w" hm--html-mode-syntax-table) - (modify-syntax-entry ?< "(>" hm--html-mode-syntax-table) - (modify-syntax-entry ?> ")<" hm--html-mode-syntax-table) - (modify-syntax-entry ?\" "\"" hm--html-mode-syntax-table) - (modify-syntax-entry ?= "." hm--html-mode-syntax-table)) - - -;;; abbreviation table - -(defvar hm--html-mode-abbrev-table nil - "Abbrev table used while in html mode.") - -(define-abbrev-table 'hm--html-mode-abbrev-table ()) - -;;; the hm--html-mode - -(defvar hm--html-mode-name-string "HTML" - "The hm--html-mode name string.") - -;;;###autoload -(defun hm--html-mode () - "Major mode for editing HTML hypertext documents. -Special commands:\\{hm--html-mode-map} -Turning on hm--html-mode calls the value of the variable hm--html-mode-hook, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map hm--html-mode-map) - (setq mode-name hm--html-mode-name-string) - (setq major-mode 'hm--html-mode) - (setq local-abbrev-table hm--html-mode-abbrev-table) - (set-syntax-table hm--html-mode-syntax-table) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (setq comment-start "") - (make-local-variable 'sentence-end) - (setq sentence-end "[<>.?!][]\"')}]*\\($\\| $\\|\t\\| \\)[ \t\n]*") - (make-local-variable 'indent-line-function) - (setq indent-line-function 'hm--html-indent-line) - (setq idd-actions hm--html-idd-actions) - (hm--install-html-menu hm--html-mode-pulldown-menu-name) - (make-variable-buffer-local 'write-file-hooks) - (add-hook 'write-file-hooks 'hm--html-maybe-new-date-and-changed-comment) - (if (adapt-xemacsp) - (put major-mode 'font-lock-defaults '((hm--html-font-lock-keywords - hm--html-font-lock-keywords-1 - hm--html-font-lock-keywords-2) - t - t - nil - nil)) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((hm--html-font-lock-keywords - hm--html-font-lock-keywords-1 - hm--html-font-lock-keywords-2) - t - t - nil - nil))) - (run-hooks 'hm--html-mode-hook)) - -;;;; Minor Modes - -;;; hm--html-region-mode - -(defvar hm--html-region-mode nil - "T, if the region is active in the `hm--html-mode'.") - -(make-variable-buffer-local 'hm--html-region-mode) - -(add-minor-mode 'hm--html-region-mode " Region" hm--html-region-mode-map) - -(if (adapt-xemacsp) - - (defun hm--html-region-mode (&optional arg) - "Toggle 'hm--html-region-mode'. -With ARG, turn hm--html-region-mode on iff ARG is positive. - -If the `major-mode' isn't the `hm--html-mode' then the minor -mode is switched off, regardless of the ARG and the state -of `hm--html-region-mode'." - (interactive "P") - (setq zmacs-regions-stays t) - (setq hm--html-region-mode - (and (eq major-mode 'hm--html-mode) - (if (null arg) (not hm--html-region-mode) - (> (prefix-numeric-value arg) 0)))) - ) - - (defun hm--html-region-mode (&optional arg) - "Toggle 'hm--html-region-mode'. -With ARG, turn hm--html-region-mode on iff ARG is positive. - -If the `major-mode' isn't the `hm--html-mode' then the minor -mode is switched off, regardless of the ARG and the state -of `hm--html-region-mode'." - (interactive "P") - (setq hm--html-region-mode - (and (eq major-mode 'hm--html-mode) - (if (null arg) (not hm--html-region-mode) - (> (prefix-numeric-value arg) 0)))) - (if hm--html-region-mode - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - nil) - (if hm--html-expert - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map))) - ) - - ) - - -;;; hm--html-minor-mode -(make-variable-buffer-local 'hm--html-minor-mode) - -(add-minor-mode 'hm--html-minor-mode " HM-HTML" hm--html-minor-mode-map) - -;;;###autoload -(defun hm--html-minor-mode (&optional arg) - "Toggle hm--html-minor-mode. -With arg, turn hm--html-minor-mode on iff arg is positive." - (interactive "P") - (setq hm--html-minor-mode - (if (null arg) (not hm--html-minor-mode) - (> (prefix-numeric-value arg) 0))) - (if hm--html-minor-mode - (progn - (hm--install-html-menu hm--html-minor-mode-pulldown-menu-name) - (when (adapt-emacs19p) - (hm--html-add-major-menu-to-minor-menus))) - (when (and current-menubar (assoc hm--html-minor-mode-pulldown-menu-name - current-menubar)) - (delete-menu-item (list hm--html-minor-mode-pulldown-menu-name))) - (when (adapt-emacs19p) - (hm--html-remove-major-menu-from-minor-menus))) - ) - - -;;; hm--html-minor-region-mode - -(defvar hm--html-minor-region-mode nil - "Non-nil, if the `hm--html-minor-region-mode' is active.") - -(make-variable-buffer-local 'hm--html-minor-region-mode) - -(add-minor-mode 'hm--html-minor-region-mode - " Region" - hm--html-minor-region-mode-map) - - -(if (adapt-xemacsp) - - (defun hm--html-minor-region-mode (&optional arg) - "Toggle `hm--html-minor-region-mode'. -With arg, turn `hm--html-minor-region-mode' on iff arg is positive. - -But however, if the `hm--html-minor-mode' isn't active, then it -turns `hm--html-minor-region-mode' off." - (interactive "P") - (setq zmacs-regions-stays t) - (setq hm--html-minor-region-mode - (and hm--html-minor-mode - (if (null arg) (not hm--html-minor-region-mode) - (> (prefix-numeric-value arg) 0)))) - ) - - (defun hm--html-minor-region-mode (&optional arg) - "Toggle `hm--html-minor-region-mode'. -With arg, turn `hm--html-minor-region-mode' on iff arg is positive. - -But however, if the `hm--html-minor-mode' isn't active, then it -turns `hm--html-minor-region-mode' off." - (interactive "P") - (setq hm--html-minor-region-mode - (and hm--html-minor-mode - (if (null arg) (not hm--html-minor-region-mode) - (> (prefix-numeric-value arg) 0)))) - (if hm--html-minor-region-mode - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - nil) - (if hm--html-expert - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map))) - ) - ) - - - -;;; Hook function for toggling the region minor modes -(defun hm--html-switch-region-modes-on () - "Switches the region minor modes of the hm--html-menus package on. -This function should be only be used for the `zmacs-activate-region-hook' -or for the `activate-mark-hook'." - (hm--html-region-mode 1) - (hm--html-minor-region-mode 1)) - -(defun hm--html-switch-region-modes-off () - "Switches the region minor modes of the hm--html-menus package on. -This function should be only be used for the `zmacs-deactivate-region-hook' -or for the `deactivate-mark-hook'." - (hm--html-region-mode -1) - (hm--html-minor-region-mode -1)) - - -;;; Run the load hook -(run-hooks 'hm--html-load-hook) - - -;;; Announce the feature hm--html-configuration -(provide 'hm--html-mode) - - -;;; hm--html-mode.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html-not-standard.el --- a/lisp/hm--html-menus/hm--html-not-standard.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,439 +0,0 @@ -;;; hm--html-not-standard.el -;;; v1.00; 22-Feb-1997 -;;; Copyright (C) 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; This file contains lisp code for the insertation of non standard -;;; HTML 3.2 elements. I don't think, that's a good idea to use this -;;; elements in any HTML documents :-) -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; -;;; Put a (require 'hm--html-not-standard) in your .emacs -;;; -;;; Look at the files hm--html-mode.el and hm--html-configuration -;;; for further installation points. -;;; - -;(require 'hm--html-mode) - -(defun hm--html-add-server-side-include-command-with-parameter (command - parameter) - "This function adds a server side include command directive in the buffer. -The directive is only supported by the NCSA http daemon." - (interactive (list - (completing-read - "Include Command: " - hm--html-server-side-include-command-with-parameter-alist) - (read-string "Parameterlist sepearted by '?': "))) - (if (string= command "") - (error "ERROR: No command specified !") - (if (string= parameter "") - (error "ERROR: No parameter specified !") - (if (= ?| (string-to-char command)) - (if (= ?? (string-to-char parameter)) - (insert "") - (insert "")) - (if (= ?? (string-to-char parameter)) - (insert "") - (insert "")))))) - - -(defun hm--html-add-server-side-include-command-with-isindex-parameter - (command) - "This function adds a server side include command directive in the buffer. -The include command uses the \"isindex\"- parameter for the specified command." - (interactive (list - (completing-read "Include Command: " - hm--html-server-side-include-command-alist))) - (hm--html-add-server-side-include-command command t)) - - -(defun hm--html-add-server-side-include-command (command &optional srvurl) - "This function adds a server side include command directive in the buffer. -The directive is only supported by the NCSA http daemon. -If SRVURL is t, then the attribute srvurl instead of srv is used for the -include command. With srvurl, the include command uses the \"isindex\"- -parameter for the specified command." - (interactive (list - (completing-read "Include Command: " - hm--html-server-side-include-command-alist))) - (let ((attribute (if srvurl "SRVURL" "SRV"))) - (if (string= command "") - (error "ERROR: No command specified !") - (if (= ?| (string-to-char command)) - (insert "") - (insert ""))))) - - -(defun hm--html-add-server-side-include-file (file) - "This function adds a server side include file directive in the buffer. -The directive is only supported by the NCSA http daemon." - (interactive "FInclude File: ") - (if (string= file "") - (error "ERROR: No filename specified !") - (insert ""))) - - -(defun hm--html-add-plaintext () - "Adds the HTML tags for plaintext." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-plaintext-to-region () - "Adds the HTML tags for plaintext to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-abstract () - "Adds the HTML tags for abstract text at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-abstract-to-region () - "Adds the HTML tags for abstract text to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-quote () - "Adds the HTML tags for Quote at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-quote-to-region () - "Adds the HTML tags for Quote to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-person () - "Adds the HTML tags for Person at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-person-to-region () - "Adds the HTML tags for Person to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-instance () - "Adds the HTML tags for Instance at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-instance-to-region () - "Adds the HTML tags for Instance to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-publication () - "Adds the HTML tags for Publication at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-publication-to-region () - "Adds the HTML tags for Publication to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-author () - "Adds the HTML tags for Author at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-author-to-region () - "Adds the HTML tags for Author to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-editor () - "Adds the HTML tags for Editor at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-editor-to-region () - "Adds the HTML tags for Editor to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-credits () - "Adds the HTML tags for Credits at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-credits-to-region () - "Adds the HTML tags for Credits to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-copyright () - "Adds the HTML tags for Copyright at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-copyright-to-region () - "Adds the HTML tags for Copyright to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-isbn () - "Adds the HTML tags for ISBN at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-isbn-to-region () - "Adds the HTML tags for ISBN to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-acronym () - "Adds the HTML tags for Acronym at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-acronym-to-region () - "Adds the HTML tags for Acronym to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-abbrevation () - "Adds the HTML tags for Abbrevation at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-abbrev-to-region () - "Adds the HTML tags for Abbrev to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-command () - "Adds the HTML tags for Command at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-command-to-region () - "Adds the HTML tags for Command to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-argument () - "Adds the HTML tags for Argument at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-argument-to-region () - "Adds the HTML tags for Argument to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-literature () - "Adds the HTML tags for Literature at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-literature-to-region () - "Adds the HTML tags for Literature to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-footnote () - "Adds the HTML tags for Footnote at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-footnote-to-region () - "Adds the HTML tags for Footnote to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-margin () - "Adds the HTML tags for Margin at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-margin-to-region () - "Adds the HTML tags for Margin to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-listing () - "Adds the HTML tags for listing." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-listing-to-region () - "Adds the HTML tags for listing to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(provide 'hm--html-not-standard) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/hm--html-menus/hm--html.el --- a/lisp/hm--html-menus/hm--html.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4338 +0,0 @@ -;;; $Id: hm--html.el,v 1.9 1997/07/26 22:09:45 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines functions for the file hm--html-menu.el. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; - -(defun hm--html-set-marker-at-position (&optional position) - "Creates a new marker and set the marker at the POSITION. -If POSITION is nil, then the marker is set at the current point. -The return value is the marker." - (let ((marker (make-marker))) - (if position - (set-marker marker position) - (set-marker marker (point))))) - -;;; Functions for adding html commands which consists of a start and a -;;; end tag and some text between them. (Basicfunctions) - -(defun hm--html-add-tags (function-insert-start-tag - start-tag - &optional - function-insert-end-tag - end-tag - function-insert-middle-start-tag - middle-start-tag - function-insert-middle-end-tag - middle-end-tag) - "Adds the start and the end html tag at point. -The first parameter specifies the funtion which insert the start tag -and the third parameter specifies the function which insert the end tag. -The second parameter is the string for the start tag and the fourth parameter -is the string for the end tag. The third and fourth parameters are optional. -The fifth parameter is optional. If it exists, it specifies a function which -inserts the sixth parameter (the middle-start-tag) between the start and the -end tag." - (eval (list function-insert-start-tag start-tag)) - (if function-insert-middle-start-tag - (eval (list function-insert-middle-start-tag middle-start-tag))) - (let ((position (hm--html-set-marker-at-position (point)))) - (if function-insert-middle-end-tag - (eval (list function-insert-middle-end-tag middle-end-tag))) - (if function-insert-end-tag - (eval (list function-insert-end-tag end-tag))) - (goto-char position))) - - -(defun hm--html-add-tags-to-region (function-insert-start-tag - start-tag - function-insert-end-tag - end-tag - &optional - function-insert-middle-tag - middle-tag) - "Adds the start and the end html tag to the active region. -The first parameter specifies the funtion which insert the start tag -and the third parameter specifies the function which insert the end tag. -The second parameter is the string for the start tag and the fourth parameter -is the string for the end tag. -The fifth parameter is optional. If it exists, it specifies a function which -inserts the sixth parameter (the middle-tag) between the start and the end -tag." - (save-window-excursion - (let ((start (hm--html-set-marker-at-position (region-beginning))) - (end (region-end))) - (goto-char end) - (eval (list function-insert-end-tag end-tag)) - (goto-char start) - (eval (list function-insert-start-tag start-tag)) - (if function-insert-middle-tag - (eval (list function-insert-middle-tag middle-tag))) - ))) - - -(defun hm--html-insert-start-tag (tag) - "Inserts the HTML start tag 'tag' without a Newline. -The parameter must be a string (i.e. \"\")" - (let ((start (point))) - (insert tag) - (hm--html-indent-region start (point)))) - - -(defun hm--html-insert-end-tag (tag) - "Inserts the HTML end tag 'tag' without a Newline. -The parameter must be a string (i.e. \"\")" - (let ((start (point))) - (insert tag) - (hm--html-indent-region start (point)))) - - -(defun hm--html-insert-start-tag-with-newline (tag) - "Inserts the HTML start tag 'tag' with a Newline. -The parameter must be a string (i.e. \"
    \")"
    -  (let ((start (point)))
    -    (insert tag)
    -    (hm--html-indent-region start (point))
    -    )
    -  (insert "\n"))
    -
    -
    -(defun hm--html-insert-end-tag-with-newline (tag)
    -  "Inserts the HTML end tag 'tag' with a Newline.
    -The parameter must be a string (i.e. \"
    \")" - (insert "\n") - (let ((start (point))) - (insert tag) - (hm--html-indent-region start (point)))) - - - -;;; Functions which add simple tags of the form - -(defun hm--html-add-list-or-menu-item-separator () - "Adds a list or menu item. Assume we're at the end of the last item." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline "
  • ")) - -(defun hm--html-add-list-or-menu-item () - "Adds the tags for a menu item at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline "
  • " - 'hm--html-insert-end-tag "
  • ")) - -(defun hm--html-add-list-or-menu-item-to-region () - "Adds the tags for a menu item to the region in the current buffer." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag "
  • " - 'hm--html-insert-end-tag "
  • ")) - -(defun hm--html-add-basefont (size) - "Adds the HTML tag for a basefont." - (interactive (list (hm--html-read-font-size t))) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat ""))) - -(defun hm--html-add-line-break () - "Adds the HTML tag for a line break." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag "
    ")) - - -(defun hm--html-add-horizontal-rule () - "Adds the HTML tag for a horizontal rule (line)." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag "
    ")) - - -(defun hm--html-add-paragraph () - "Adds the HTML tags for a paragraph at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "

    " - 'hm--html-insert-end-tag-with-newline - "

    ")) - - -(defun hm--html-add-paragraph-to-region () - "Adds the HTML tags for a paragraph to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "

    " - 'hm--html-insert-end-tag-with-newline - "

    ")) - - -(defun hm--html-add-paragraph-separator () - "Adds the tag for a paragraph seperator." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag "

    ")) - -(defun hm--html-add-doctype () - "Adds the tag with the doctype." - (interactive) - (goto-char (point-min)) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "")) - (newline)) - -(defun hm--html-search-place-for-element-in-head (end-point) - "Searches the point for inserting an element between the head tags." - (let ((point (point))) - (if (and end-point (< (point) end-point)) - (point) - (goto-char (point-min)) - (if (re-search-forward - (concat ;"\\(]*>" head-end-point t) - (delete-region (match-beginning 0) (match-end 0))) - (t (goto-char point) - (hm--html-search-place-for-element-in-head head-end-point))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "") - ">")))))) - -(defun hm--html-add-base (href) - "Inserts the base tag. HREF is the value of the href attribute." - (interactive (list (hm--html-read-url "URL of this document: " - nil - nil - t - nil))) - (save-excursion - (let ((point (point)) - (case-fold-search t) - (head-end-point)) - (goto-char (point-min)) - (setq head-end-point (when (re-search-forward - "\\(]*>" head-end-point t) - (delete-region (match-beginning 0) (match-end 0))) - (t (goto-char point) - (hm--html-search-place-for-element-in-head head-end-point))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "") - ">")))))) - -(defun hm--html-add-meta (name content &optional name-instead-of-http-equiv) - "Inserts the meta tag." - (interactive (list (completing-read "Name: " hm--html-meta-name-alist) - (read-string "Content: "))) - (save-excursion - (let ((point (point)) - (case-fold-search t) - (head-end-point)) - (goto-char (point-min)) - (setq head-end-point (when (re-search-forward - "\\("))))) - - -;;; Functions which include something in HTML- documents - -(defvar hm--html-url-history-list nil - "History list for the function 'hm--html-read-url'") - - -(defun hm--html-read-url-predicate (table-element-list usagesymbol) - "Predicatefunction for hm--html-read-url." - (hm--html-read-url-predicate-1 (cdr table-element-list) usagesymbol)) - - -(defun hm--html-read-url-predicate-1 (table-element-list usagesymbol) - "Internal function of hm--html-read-url-predicate." - (cond ((not table-element-list) nil) - ((eq (car table-element-list) usagesymbol)) - (t (hm--html-read-url-predicate-1 (cdr table-element-list) - usagesymbol)))) - - -(defun hm--html-read-url (prompt &optional - table - predicate - require-match - initial-contents) - "Function prompts for a URL string. -TABLE is an alist whose elements' cars are URL's. -PREDICATE limits completion to a subset of TABLE. -If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless -the input is (or completes to) an element of TABLE. -INITIAL-CONTENTS is a string to insert in the minibuffer before reading. -If INITIAL-CONTENTS is nil, the car of the 'hm--html-url-history-list' -is used instead." - (if table - (completing-read prompt - table - predicate - require-match - initial-contents - hm--html-url-history-list) - (read-string prompt - (if initial-contents - initial-contents - (car hm--html-url-history-list)) - hm--html-url-history-list))) - - -(defun hm--html-read-altenate (url) - "Function reads the value for the \"ALT\"- attribute in IMG tags. -URL will be used as the default URL for the external viewer." - (let ((alttype - (string-to-int - (completing-read - "0: No ALT atribute, 1: ALT=\"\", 2: ALT=Text: " - '(("0") ("1") ("2")) - nil - t - "2")))) - (cond ((= alttype 0) nil) - ((= alttype 1) "") - ((= alttype 2) (read-string - "Text for the ALT attribute: " - (substring (file-name-nondirectory url) - 0 - (string-match - "\\." - (file-name-nondirectory url))))) - ))) - -(defun hm--html-read-alignment (prompt) - "Read the value for the align attribute." - (upcase (completing-read prompt - '(("left") ("right") ("top") ("bottom") ("middle")) - nil - t - "left"))) - -(defvar hm--html-shape-history nil - "History variable for reading the shape of an image map.") - -(defun hm--html-read-shape () - "Reads the shap for an area element." - (upcase(completing-read "The shape of the area: " - '(("rect") ("circle") ("poly")) - nil - t - (or (car hm--html-shape-history) "rect") - 'hm--html-shape-history))) - -(defun hm--html-read-rect-coords () - "Reads rectangle coordinates for the area element." - (concat (read-string "Left x position of the rectangle: ") ", " - (read-string "Top y position of the rectangle: ") ", " - (read-string "Right x position of the rectangle: ") ", " - (read-string "Bottom y position of the rectangle: "))) - -(defun hm--html-read-circle-coords () - "Reads circle coordinates for the area element." - (concat (read-string "x position of the center of the circle: ") ", " - (read-string "y position of the center of the circle: ") ", " - (read-string "Radius: "))) - -(defun hm--html-read-one-poly-coordinate (&optional empty-string-prompt) - "Reads one poly coordinate pair." - (let* ((x (read-string (concat "x coordinate" - (or empty-string-prompt "") - ": "))) - (y (unless (string= "" x) - (read-string "y coordinate: ")))) - (if (string= "" x) - "" - (concat x ", " y)))) - -(defun hm--html-read-more-poly-coordinates () - "Reads poly coordinates until an empty string is given." - (let ((coord (hm--html-read-one-poly-coordinate - " (Empty string for no further coords!)"))) - (cond ((string= "" coord) "") - (t (concat ", " coord (hm--html-read-more-poly-coordinates)))))) - -(defun hm--html-read-poly-coords () - "Reads poly coordinates for the area element." - (concat (hm--html-read-one-poly-coordinate) ", " - (hm--html-read-one-poly-coordinate) ", " - (hm--html-read-one-poly-coordinate) - (hm--html-read-more-poly-coordinates))) - -(defun hm--html-add-area (href alt shape coords) - "Adds the tags for an area at the current point." - (interactive (let* ((href (hm--html-read-url "Url for the image area: ")) - (alt (hm--html-read-altenate href)) - (shape (hm--html-read-shape)) - (coords (cond ((string= shape "RECT") - (hm--html-read-rect-coords)) - ((string= shape "CIRCLE") - (hm--html-read-circle-coords)) - ((string= shape "POLY") - (hm--html-read-poly-coords)) - (t (error "No function to read \"" - shape - "\" coordinates!"))))) - (list href alt shape coords))) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - (concat ""))) - - -(when (adapt-emacs19p) - (defvar :ask ':ask)) - -(defvar hm--html-use-image-as-map ':ask - "Internal variable of `hm--html-add-image'. -nil => insert the image element without an usemap attribute. -t => insert the image element with an usemap attribute. -:ask => ask, if the image element should have an usemap attribute.") - -(defun hm--html-add-image (href alt alignment mapname) - "Add an image." - (interactive (let* ((href (hm--html-read-url "Image URL: ")) - (alt (hm--html-read-altenate href)) - (alignment (hm--html-read-alignment - "Alignment of the image: ")) - (use-as-map (if (eq hm--html-use-image-as-map ':ask) - (y-or-n-p - "Use the image as a map with links? ") - hm--html-use-image-as-map)) - (mapname (and use-as-map (hm--html-read-mapname)))) - (list href alt alignment mapname))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat ""))) - - -(defun hm--html-add-image-bottom (href alt) - "Add an image, bottom aligned." - (interactive (let ((url (hm--html-read-url "Image URL: "))) - (list url (hm--html-read-altenate url)))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat ""))) - - -(defun hm--html-add-image-middle (href alt) - "Add an image, middle aligned." - (interactive (let ((url (hm--html-read-url "Image URL: "))) - (list url (hm--html-read-altenate url)))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat ""))) - - -(defun hm--html-add-image-top (href alt) - "Add an image, top aligned." - (interactive (let ((url (hm--html-read-url "Image URL: "))) - (list url (hm--html-read-altenate url)))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat ""))) - - -(defun hm--html-add-applet (name code width height) - "Add an applet." - (interactive (let ((name (read-string "Applet Name: " "applet")) - (code (read-file-name "Applet Class File: ")) - (width (read-number "Width (i.e.: 100): " t)) - (height (read-number "Height (i.e.: 100): " t))) - (list name code width height))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "") - 'hm--html-insert-start-tag-with-newline - "")) - -(defun hm--html-add-applet-parameter (name value) - "Adds the tag for an applet parameter at the current point. -This tag must be added between and ." - (interactive "sParameter Name: \nsParameter Value: ") - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat ""))) - - - -;;; Functions, which adds tags of the form ... - -(defun hm--html-add-big () - "Adds the HTML tags for Big at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-big-to-region () - "Adds the HTML tags for Big to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-small () - "Adds the HTML tags for Small at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-small-to-region () - "Adds the HTML tags for Small to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-bold () - "Adds the HTML tags for Bold at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-bold-to-region () - "Adds the HTML tags for Bold to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-italic () - "Adds the HTML tags for Italic at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-italic-to-region () - "Adds the HTML tags for Italic to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-underline () - "Adds the HTML tags for Underline at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-underline-to-region () - "Adds the HTML tags for Underline to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-definition () - "Adds the HTML tags for Definition at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-definition-to-region () - "Adds the HTML tags for Definition to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-code () - "Adds the HTML tags for Code at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-code-to-region () - "Adds the HTML tags for Code to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-citation () - "Adds the HTML tags for Citation." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - -(defun hm--html-add-citation-to-region () - "Adds the HTML tags for Citation to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-emphasized () - "Adds the HTML tags for Emphasized." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-emphasized-to-region () - "Adds the HTML tags for Emphasized to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-fixed () - "Adds the HTML tags for Fixed." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-fixed-to-region () - "Adds the HTML tags for Fixed to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-keyboard () - "Adds the HTML tags for Keyboard." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-keyboard-to-region () - "Adds the HTML tags for Keyboard to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-sample () - "Adds the HTML tags for Sample." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - -(defun hm--html-add-sample-to-region () - "Adds the HTML tags for Sample to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-strong () - "Adds the HTML tags for Strong." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-strong-to-region () - "Adds the HTML tags for Strong to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-variable () - "Adds the HTML tags for Variable." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - -(defun hm--html-add-variable-to-region () - "Adds the HTML tags for Variable to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-comment () - "Adds the HTML tags for Comment at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "")) - - -(defun hm--html-add-comment-to-region () - "Adds the HTML tags for Comment to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "")) - - -(defun hm--html-add-document-division (alignment) - "Adds the HTML tags for document division at the current point." - (interactive (list (hm--html-read-alignment "Alignment of the division: "))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "

    ") - 'hm--html-insert-end-tag-with-newline - "
    ")) - - -(defun hm--html-add-document-division-to-region (alignment) - "Adds the HTML tags for document division to the region." - (interactive (list (hm--html-read-alignment "Alignment of the division: "))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "
    ") - 'hm--html-insert-end-tag-with-newline - "
    ")) - - -(defun hm--html-add-preformatted () - "Adds the HTML tags for preformatted text at the current point." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "
    "
    -		     'hm--html-insert-end-tag-with-newline
    -		     "
    ")) - -(define-obsolete-function-alias 'hm--html-add-preformated - 'hm--html-add-preformatted) - -(defun hm--html-add-preformatted-to-region () - "Adds the HTML tags for preformatted text to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "
    "
    -			       'hm--html-insert-end-tag-with-newline
    -			       "
    ")) - -(define-obsolete-function-alias 'hm--html-add-preformated-to-region - 'hm--html-add-preformatted-to-region) - -(defun hm--html-add-blockquote () - "Adds the HTML tags for blockquote." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "
    " - 'hm--html-insert-end-tag-with-newline - "
    ")) - - -(defun hm--html-add-blockquote-to-region () - "Adds the HTML tags for blockquote to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "
    " - 'hm--html-insert-end-tag-with-newline - "
    ")) - -(defun hm--html-add-script () - "Adds the HTML tags for script." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "")) - - -(defun hm--html-add-script-to-region () - "Adds the HTML tags for script to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "")) - -(defun hm--html-add-style () - "Adds the HTML tags for style." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "")) - - -(defun hm--html-add-style-to-region () - "Adds the HTML tags for style to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "")) - -(defun hm--html-add-strikethru () - "Adds the HTML tags for Strikethru at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-strikethru-to-region () - "Adds the HTML tags for Strikethru to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-superscript () - "Adds the HTML tags for Superscript at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-superscript-to-region () - "Adds the HTML tags for Superscript to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-subscript () - "Adds the HTML tags for Subscript at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-subscript-to-region () - "Adds the HTML tags for Subscript to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-option () - "Adds the HTML tags for Option at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-option-to-region () - "Adds the HTML tags for Option to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-read-font-size (&optional only-absolute-size) - "Reads the size for the FONT element. -It returns nil, if the size should not be changed." - (let ((size - (if only-absolute-size - (completing-read "The absolute font size (1 .. 7): " - '(("7") ("6") ("5") ("4") ("3") ("2") ("1")) - nil - t - "4") - (completing-read "The relative (+/-) or absolute font size: " - '(("-7") ("-6") ("-5") ("-4") ("-3") ("-2") ("-1") - ("+7") ("+6") ("+5") ("+4") ("+3") ("+2") ("+1") - ("7") ("6") ("5") ("4") ("3") ("2") ("1") - ("use-basefont")) - nil - t - "use-basefont-size")))) - (if (string= size "use-basefont-size") - nil - size))) - -(defun hm--html-read-font-color () - "Reads the size for the FONT element. -It returns nil, if the color should not be changed." - (let ((color - (completing-read "The font color: " - '(("Black") ("Silver") ("Gray") ("White") ("Maroon") - ("Green") ("Lime") ("Olive") ("Yellow") ("Navy") - ("Red") ("Purple") ("Fuchsia") ("Blue") ("Teal") - ("Aqua") ("dont-set-color")) - nil - nil - "dont-set-color"))) - (if (string= color "dont-set-color") - nil - color))) - - -(defun hm--html-add-font (size color) - "Adds the HTML tags for Font at the point in the current buffer." - (interactive (list (hm--html-read-font-size) - (hm--html-read-font-color))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "") - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-font-to-region (size color) - "Adds the HTML tags for Font to the region." - (interactive (list (hm--html-read-font-size) - (hm--html-read-font-color))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "") - 'hm--html-insert-end-tag-with-newline - "")) - - -;;; Lists - - -(defun hm--html-add-center () - "Adds the HTML tags for center at the current point." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "
    " - 'hm--html-insert-end-tag-with-newline - "
    ")) - -(defun hm--html-add-center-to-region () - "Adds the HTML tags for center to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "
    " - 'hm--html-insert-end-tag-with-newline - "
    ")) - - -(defvar hm--html-mapname-history nil - "The history variable for the function `hm--html-read-mapname'.") - -(defun hm--html-read-mapname () - "Reads the name of an image map." - (let ((name (read-string "The name of the image map: " - (or (car hm--html-mapname-history) - "map") - 'hm--html-mapname-history))) - name)) - -(defun hm--html-add-image-map () - "Adds an image and a map element." - (interactive) - (let* ((href (hm--html-read-url "Image URL: ")) - (alt (hm--html-read-altenate href)) - (alignment (hm--html-read-alignment - "Alignment of the image: ")) - (mapname (hm--html-read-mapname))) - (hm--html-add-image href alt alignment mapname) - (newline) - (hm--html-add-map mapname) - (call-interactively 'hm--html-add-area))) - -(defun hm--html-add-map (name) - "Adds the HTML tags for map at the current point." - (interactive (list (hm--html-read-mapname))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "") - 'hm--html-insert-end-tag - "") - (end-of-line 0)) - -(defun hm--html-add-map-to-region (name) - "Adds the HTML tags for map to the region." - (interactive (list (hm--html-read-mapname))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "") - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-numberlist () - "Adds the HTML tags for a numbered list at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "
      " - 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-start-tag - "
  • " - 'hm--html-insert-end-tag - "
  • ")) - -(defun hm--html-add-numberlist-to-region () - "Adds the HTML tags for a numbered list to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "
      " - 'hm--html-insert-end-tag-with-newline - "
    ")) - - -(defun hm--html-add-directory-list () - "Adds the HTML tags for a directory list at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "" - 'hm--html-insert-start-tag - "
  • " - 'hm--html-insert-end-tag - "
  • ")) - -(defun hm--html-add-directorylist-to-region () - "Adds the HTML tags for a directory list to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-list () - "Adds the HTML tags for a (unnumbered) list to the region." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "
      " - 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-start-tag - "
  • " - 'hm--html-insert-end-tag - "
  • ")) - - -(defun hm--html-add-list-to-region () - "Adds the HTML tags for a (unnumbered) list to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "
      " - 'hm--html-insert-end-tag-with-newline - "
    ")) - - -(defun hm--html-add-menu () - "Adds the HTML tags for a menu." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "" - 'hm--html-insert-start-tag - "
  • " - 'hm--html-insert-end-tag - "
  • ")) - - -(defun hm--html-add-menu-to-region () - "Adds the HTML tags for a menu to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-description-title-and-entry () - "Adds a definition title and entry. -Assumes we're at the end of a previous entry." - (interactive) - (hm--html-add-description-title) - (let ((position (point)) - (case-fold-search t)) - (search-forward "") - (hm--html-add-description-entry) - (goto-char position))) - - -(defun hm--html-add-description-list () - "Adds the HTML tags for a description list. -It also inserts a tag for the description title." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "
    " - 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-start-tag - "
    " - 'hm--html-insert-end-tag - "
    ")) - - -(defun hm--html-add-description-list-to-region () - "Adds the HTML tags for a description list to a region. -It also inserts a tag for the description title." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "
    " - 'hm--html-insert-end-tag-with-newline - "
    ")) - - -(defun hm--html-add-description-title () - "Adds the HTML tags for a description title at current point in the buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-end-tag - "
    ")) - - -(defun hm--html-add-description-title-to-region () - "Adds the HTML tags for a description title to the region in the buffer." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "
    " - 'hm--html-insert-end-tag - "
    ")) - - -(defun hm--html-add-description-entry () - "Adds the HTML tags for a description entry at current point in the buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-end-tag - "
    ")) - - -(defun hm--html-add-description-entry-to-region () - "Adds the HTML tags for a description entry to the region in the buffer." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "
    " - 'hm--html-insert-end-tag - "
    ")) - - -(defun hm--html-add-address () - "Adds the HTML tags for an address." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "
    " - 'hm--html-insert-end-tag - "
    ")) - -(defun hm--html-add-address-to-region () - "Adds the HTML tags for an address to the region" - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "
    " - 'hm--html-insert-end-tag - "
    ")) - - -(defvar hm--html-signature-reference-name "Signature" - "The signature reference name.") - - -(defun hm--html-make-signature-link-string (signature-file-name) - "Returns a string which is a link to a signature file." - (concat - "")) - - -(defun hm--html-delete-old-signature () - "Searches for the old signature and deletes it, if the user want it" - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (re-search-forward (concat "
    [ \t\n]*" - "[ \t]*[\n]?" - nil - t) - (point)))) - (when (yes-or-no-p "Delete the old signature (yes or no) ?") - (delete-region signature-start signature-end) - (hm--html-indent-line))))))) - - -(defun hm--html-set-point-for-signature () - "Searches and sets the point for inserting the signature. -It searches from the end to the beginning of the file. At first it -tries to use the point before the tag then the point before -the tag and the the end of the file." - (goto-char (point-max)) - (let ((case-fold-search t)) - (cond ((search-backward "" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 1))) - ((search-backward "" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 2))) - ((> (current-column) 0) - (newline 2)) - (t)))) - - -(defun hm--html-add-signature () - "Adds the owner's signature at the end of the buffer." - (interactive) - (if hm--html-signature-file - (progn - (if (not hm--html-username) - (setq hm--html-username (user-full-name))) - (save-excursion - (hm--html-delete-old-signature) - (hm--html-set-point-for-signature) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "
    " - 'hm--html-insert-end-tag - "\n
    " - 'hm--html-insert-start-tag - (hm--html-make-signature-link-string - hm--html-signature-file) - ) - (insert hm--html-username))) - (error "ERROR: Define your hm--html-signature-file first !"))) - - -(defun hm--html-add-header (size &optional header) - "Adds the HTML tags for a header at the point in the current buffer." - (interactive "nSize (1 .. 6; 1 biggest): ") - (if (or (< size 1) (> size 6)) - (message "The size must be a number from 1 to 6 !") - (hm--html-add-tags 'hm--html-insert-start-tag - (format "" size) - 'hm--html-insert-start-tag-with-newline - (format "" size)) - (if header - (insert header)))) - - -(defun hm--html-add-header-to-region (size) - "Adds the HTML tags for a header to the region. -The parameter 'size' specifies the size of the header." - (interactive "nSize (1 .. 6; 1 biggest): ") - (if (or (< size 1) (> size 6)) - (message "The size must be a number from 1 to 6 !") - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (format "" size) - 'hm--html-insert-end-tag - (format "" size)))) - - -(defun hm--html-set-point-for-title () - "Searches and sets the point for inserting the HTML element title. -The functions start at the beginning of the file and searches first -for the HTML tag . If such a tag exists, the point is set to the -position after the tag. If not, the function next searches for the -tag and sets the point after the tag, if it exists, or searches for -the tag . If this tag exists, the point is set to the position after -this tag or the beginning of the file otherwise." - (goto-char (point-min)) - (let ((case-fold-search t)) - (cond ((search-forward-regexp "]*>" nil t) (newline)) - ((search-forward-regexp "]*>" nil t) (newline)) - ((search-forward-regexp "]*>" nil t) (newline)) - (t)))) - - -(defun hm--html-add-title (title) - "Adds the HTML tags for a title at the beginning of the buffer." - (interactive "sTitle: ") - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (search-forward "" nil t) - (let ((point-after-start-tag (point))) - (if (not (search-forward "" nil t)) - nil - (goto-char (- (point) 8)) - (delete-backward-char (- (point) point-after-start-tag)) - (let ((start (point))) - (if hm--html-automatic-create-title-date - (insert title " (" (hm--date) ")") - (insert title)) - (goto-char start)))) - ;; Noch kein im Buffer vorhanden - (hm--html-set-point-for-title) - (hm--html-add-tags 'hm--html-insert-start-tag - "<TITLE>" - 'hm--html-insert-end-tag - "" - 'insert - (if hm--html-automatic-create-title-date - (concat title " (" (hm--date) ")") - title)) - (forward-char 8) - (newline 1) - )))) - - -(defun hm--html-add-title-to-region () - "Adds the HTML tags for a title to the region." - (interactive) - (let ((title (buffer-substring (region-beginning) (region-end))) - (case-fold-search t)) - (save-excursion - (goto-char (point-min)) - (if (search-forward "" nil t) - (let ((point-after-start-tag (point))) - (if (not (search-forward "" nil t)) - nil - (goto-char (- (point) 8)) - (delete-backward-char (- (point) point-after-start-tag)) - (if hm--html-automatic-create-title-date - (insert title " (" (hm--date) ")") - (insert title)))) - ;; Noch kein im Buffer vorhanden - (hm--html-set-point-for-title) - (hm--html-add-tags 'hm--html-insert-start-tag - "<TITLE>" - 'hm--html-insert-end-tag - "" - 'insert - (if hm--html-automatic-create-title-date - (concat title " (" (hm--date) ")") - title)) - (forward-char 8) - ;(newline 1) - )))) - - -(defun hm--html-add-html () - "Adds the HTML tags and in the buffer. -The tag will be inserted at the beginning (after the -, if it is already there.) and at the -end of the file." - (interactive) - (let ((new-cursor-position nil) - (case-fold-search t)) - (save-excursion - (goto-char (point-min)) - (if (search-forward "" nil t) - (error "There is an old tag in the current buffer !") - (re-search-forward "]*>[ \t\n]*" nil t) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "") -; (newline 1) - ) - (setq new-cursor-position (point)) - (goto-char (point-max)) - (if (search-backward "" nil t) - (error "There is an old tag in the current buffer !") - (newline 1) - (hm--html-add-tags 'hm--html-insert-end-tag ""))) - (goto-char new-cursor-position))) - - -(defun hm--html-add-head () - "Adds the HTML tags and in the buffer. -The tags will be inserted after or at the beginning -of the file after (if it is already there). -The function also looks for the tags and ." - (interactive) - (let ((case-fold-search t)) - (goto-char (point-min)) - (re-search-forward "]*>[ \t\n]*" nil t) - (if (search-forward "" nil t) - (if (search-forward "" nil t) - (error "There is an old tag in the current buffer !") - (if (search-forward "" nil t) - (error "There is an old tag in the current buffer !") - (newline 1)))) - (let ((start-tag-position (point))) - (if (search-forward "" nil t) - (progn - (forward-line 0) - (forward-char -1) - (if (= (point) (point-min)) - (progn - (newline) - (forward-line -1))) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "") - (goto-char start-tag-position) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "") - ) - (if (search-forward "" nil t) - (progn - (newline 1) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "") - (goto-char start-tag-position) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "")) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")))))) - - -(defun hm--html-add-head-to-region () - "Adds the HTML tags and to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-body () - "Adds the HTML tags and in the buffer. -The tags will be inserted before or at the end of the file." - (interactive) - (let ((case-fold-search t)) - (goto-char (point-max)) - (if (search-backward "" nil t) - (progn - (if (search-backward "" nil t) - (error "There is an old tag in the current buffer !") - (if (search-backward "" nil t) - (error "There is an old tag in the current buffer !"))) - (forward-char -1))) - (let ((end-tag-position (set-marker (make-marker) (point)))) - (if (search-backward "" nil t) - (progn - (forward-char 7) - (newline 1) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "") - (let ((cursor-position (point))) - (goto-char end-tag-position) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "") - (goto-char cursor-position) - )) - (if (not (= (current-column) 0)) - (newline)) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "" - 'hm--html-insert-end-tag-with-newline ""))))) - - -(defun hm--html-add-body-to-region () - "Adds the HTML tags and to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(defun hm--html-add-title-and-header (title) - "Adds the HTML tags for a title and a header in the current buffer." - (interactive "sTitle and Header String: ") - (let ((case-fold-search t)) - (hm--html-add-title title) - (save-excursion - (goto-char (point-min)) - (search-forward "" nil t) - (if (search-forward "" nil t) - (progn - (search-forward "" nil t) - (newline 1)) - (if (search-forward "" nil t) - (newline 1) - (if (string= (what-line) "Line 1") - (progn - (end-of-line) - (newline 1))))) - (hm--html-add-header 1 title)))) - - -(defun hm--html-add-title-and-header-to-region () - "Adds the HTML tags for a title and a header to the region." - (interactive) - (let ((title (buffer-substring (region-beginning) (region-end)))) - (hm--html-add-header-to-region 1) - (hm--html-add-title title))) - - -(defun hm--html-add-full-html-frame (title) - "Adds a full HTML frame to the current buffer. -The frame consists of the elements html, head, body, title, -header and the signature. The parameter TITLE specifies the -title and the header of the document." - (interactive "sTitle and Header String: ") - (let ((case-fold-search t)) - (hm--html-add-doctype) - (hm--html-add-html) - (hm--html-add-head) - (hm--html-add-body) - (hm--html-add-title-and-header title) - (when hm--html-signature-file - (hm--html-add-signature)) - (goto-char (point-min)) - (search-forward "" nil t) - (forward-line 1) - (when hm--html-automatic-created-comment - (hm--html-insert-created-comment)) - (when hm--html-automatic-create-modified-line - (hm--html-insert-modified-line)))) - - -(defun hm--html-add-full-html-frame-with-region () - "Adds a full HTML frame to the current buffer with the use of a region. -The frame consists of the elements html, head, body, title, -header and the signature. The function uses the region as -the string for the title and the header of the document." - (interactive) - (hm--html-add-title-and-header-to-region) - (hm--html-add-doctype) - (hm--html-add-html) - (hm--html-add-head) - (hm--html-add-body) - (hm--html-add-signature) - (when hm--html-automatic-created-comment - (hm--html-insert-created-comment)) - (when hm--html-automatic-create-modified-line - (hm--html-insert-modified-line))) - - -(defun hm--html-add-link-target-to-region (name) - "Adds the HTML tags for a link target to the region." - (interactive "sName: ") - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "") - 'hm--html-insert-end-tag - "")) - -(defun hm--html-add-link-target (name) - "Adds the HTML tags for a link target at point in the current buffer." - (interactive "sName: ") - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "") - 'hm--html-insert-end-tag - "")) - - -;;; Functions which add links - -(defun hm--html-mark-example (parameter-list) - "Marks the example of the parameterlist in the current buffer. -It returns the example extent." - (let ((case-fold-search t)) - (if (hm--html-get-example-from-parameter-list parameter-list) - (progn - (search-forward (hm--html-get-example-from-parameter-list - parameter-list)) - (let ((extent (make-extent (match-beginning 0) - (match-end 0)))) - (set-extent-face extent 'hm--html-help-face) - extent))))) - - -(defun hm--html-unmark-example (extent) - "Unmarks the example for the current question." - (if extent - (delete-extent extent))) - - -(defun hm--html-write-alist-in-buffer (alist) - "The function writes the contents of the ALIST in the currentbuffer." - (cond ((car alist) - (insert (int-to-string (car (car alist))) ":\t" (cdr (car alist))) - (newline) - (hm--html-write-alist-in-buffer (cdr alist))))) - - -(defun hm--html-select-directory (alist default) - "The function selects one of the directories of the ALIST, -or the DEFAULT or the 'default-directory' by number. See also the -documentation of the function hm--html-read-filename." - (if (or (string= default "") (not default)) - (setq default default-directory)) - (if alist - (save-window-excursion - (let ((buffername (generate-new-buffer "*html-directories*"))) - (set-buffer buffername) - (insert "Select one of the following directories by number !") - (newline) - (insert "===================================================") - (newline) - (insert "0:\t" default) - (newline) - (hm--html-write-alist-in-buffer alist) - (goto-char (point-min)) - (pop-to-buffer buffername)) - (let ((dirnumber (read-number - "Select directory prefix by number: " - t))) - (kill-buffer "*html-directories*") - (expand-file-name (or (cdr (assoc dirnumber alist)) default)))) - (expand-file-name default)) - ) - - -(defun hm--html-delete-wrong-path-prefix-1 (filename prefix-list) - "The function deletes wrong path prefixes." - (cond (prefix-list (if (string-match (car prefix-list) filename) - (substring filename (match-end 0)) - (hm--html-delete-wrong-path-prefix-1 filename - (cdr prefix-list) - ))) - (t filename))) - - -(defun hm--html-delete-wrong-path-prefix (filename) - "The function deletes wrong path prefixes. -The path prefixes are specified by the variable -`hm--html-delete-wrong-path-prefix'." - (if (not hm--html-delete-wrong-path-prefix) - filename - (if (listp hm--html-delete-wrong-path-prefix) - (hm--html-delete-wrong-path-prefix-1 filename - hm--html-delete-wrong-path-prefix) - (hm--html-delete-wrong-path-prefix-1 filename - (list - hm--html-delete-wrong-path-prefix)) - ))) - - -(defun hm--html-read-filename (parameter-list) - "The function reads a filename with its directory path, -if PARAMETER-LIST is not nil. If the PARAMETER-LIST is nil, only an empty -string will be returned. -The PARAMETER-LIST consists of the following elements: - PROMPT, ALIST, DEFAULT, REQUIRE-MATCH, EXAMPLE. -If the ALIST is nil and DEFAULT is nil, then the function only reads -a filename (without path). These precede the following. -If the ALIST isn't nil, the function lists the contents of the ALIST -in a buffer and reads a number from the minbuffer, which selects one -of the directories (lines) of the buffer. Therefore the ALIST must look -like the following alist: - ((1 . \"/appl/gnu/\") (2 . \"/\")) -If only ALIST is nil, or if you type a number which is not in the ALIST, -the DEFAULT directory is selected. If the DEFAULT is nil or \"\" the -'default-directory' is selected. -After that the function reads the name of the file from the minibuffer. -Therefore the PROMPT is printed in the minibuffer and the selected directory -is taken as the start of the path of the file. -If REQUIRE-MATCH is t, the filename with path must match an existing file." - (if parameter-list - (let ((marked-object (hm--html-mark-example parameter-list)) - (prompt (hm--html-get-prompt-from-parameter-list parameter-list)) - (alist (hm--html-get-alist-from-parameter-list parameter-list)) - (default (hm--html-get-default-from-parameter-list parameter-list)) - (require-match (hm--html-get-require-match-from-parameter-list - parameter-list)) - (filename nil)) - (if (or alist default) - (let ((directory (hm--html-select-directory alist default))) - (setq filename (read-file-name prompt - directory - directory - require-match - nil))) - (setq filename (read-file-name prompt - "" - "" - require-match - nil))) - (hm--html-unmark-example marked-object) - (hm--html-delete-wrong-path-prefix filename)) - "")) - - -(defun hm--html-completing-read (parameter-list) - "Reads a string with completing-read, if alist is non nil. -The PARAMETER-LIST consists of the following elements: - PROMPT, ALIST, DEFAULT, REQUIRE-MATCH, EXAMPLE. -If ALIST is nil, it returns the DEFAULT, or if the DEFAULT is -also nil it returns an empty string." - (let ((marked-object (hm--html-mark-example parameter-list)) - (string - (if (hm--html-get-alist-from-parameter-list parameter-list) - (completing-read - (hm--html-get-prompt-from-parameter-list parameter-list) - (hm--html-get-alist-from-parameter-list parameter-list) - nil - (hm--html-get-require-match-from-parameter-list - parameter-list) - (hm--html-get-default-from-parameter-list - parameter-list)) - (if (hm--html-get-default-from-parameter-list parameter-list) - (hm--html-get-default-from-parameter-list parameter-list) - "")))) - (hm--html-unmark-example marked-object) - string)) - - -(defvar hm--html-faces-exist nil) - - -(defun hm--html-generate-help-buffer-faces () - "Generates faces for the add-link-help-buffer." - (if (not (facep 'hm--html-help-face)) - (progn - (setq hm--html-faces-exist t) - (make-face 'hm--html-help-face) - (if hm--html-help-foreground - (set-face-foreground 'hm--html-help-face hm--html-help-foreground)) - (if hm--html-help-background - (set-face-background 'hm--html-help-face hm--html-help-background)) - (set-face-font 'hm--html-help-face hm--html-help-font) - ))) - - -(defun hm--html-get-prompt-from-parameter-list (parameter-list) - "Returns the prompt from the PARAMETER-LIST." - (car parameter-list)) - - -(defun hm--html-get-alist-from-parameter-list (parameter-list) - "Returns the alist from the PARAMETER-LIST." - (car (cdr parameter-list))) - - -(defun hm--html-get-default-from-parameter-list (parameter-list) - "Returns the default from the PARAMETER-LIST." - (car (cdr (cdr parameter-list)))) - - -(defun hm--html-get-require-match-from-parameter-list (parameter-list) - "Returns the require-match from the PARAMETER-LIST." - (car (cdr (cdr (cdr parameter-list))))) - - -(defun hm--html-get-example-from-parameter-list (parameter-list) - "Returns the example from the PARAMETER-LIST." - (car (cdr (cdr (cdr (cdr parameter-list)))))) - - -(defun hm--html-get-anchor-seperator-from-parameter-list (parameter-list) - "Returns the anchor-seperator from the PARAMETER-LIST." - (car (cdr (cdr (cdr (cdr (cdr parameter-list))))))) - - -(defun hm--html-generate-add-link-help-buffer (scheme-parameter-list - host-name:port-parameter-list - servername:port-parameter-list - path+file-parameter-list - anchor-parameter-list) - "Generates and displays a help buffer with an example for adding a link." - (let ((buffername (generate-new-buffer "*Link-Example*"))) - (pop-to-buffer buffername) - (shrink-window (- (window-height) 5)) - (insert "Example:") - (newline 2) - (if (hm--html-get-example-from-parameter-list scheme-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - scheme-parameter-list)) - (if (hm--html-get-example-from-parameter-list - scheme-parameter-list) - (progn - (insert ":") - (if (hm--html-get-example-from-parameter-list - host-name:port-parameter-list) - (insert "//")))))) - (if (hm--html-get-example-from-parameter-list - host-name:port-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - host-name:port-parameter-list)) - (if (and (hm--html-get-example-from-parameter-list - servername:port-parameter-list) - (not (string= "/" - (substring - (hm--html-get-example-from-parameter-list - servername:port-parameter-list) - 0 - 1)))) - (insert "/")))) - (if (hm--html-get-example-from-parameter-list - servername:port-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - servername:port-parameter-list)) - (if (hm--html-get-example-from-parameter-list - path+file-parameter-list) - (insert "/")))) - (if (hm--html-get-example-from-parameter-list path+file-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - path+file-parameter-list)))) - (if (hm--html-get-example-from-parameter-list anchor-parameter-list) - (progn - (insert (hm--html-get-anchor-seperator-from-parameter-list - anchor-parameter-list)) - (insert (hm--html-get-example-from-parameter-list - anchor-parameter-list)))) - (goto-char (point-min)) - buffername - )) - - -(defun hm--html-add-link (function-add-tags - scheme-parameter-list - host-name:port-parameter-list - servername:port-parameter-list - path+file-parameter-list - anchor-parameter-list) - "The function adds a link in the current buffer. -The parameter FUNCTION-ADD-TAGS determines the function which adds the tag -in the buffer (for example: 'hm--html-add-tags or -'hm--html-add-tags-to-region). -The parameters SCHEME-PARAMETER-LIST, HOST-NAME:PORT-PARAMETER-LIST, -SERVERNAME:PORT-PARAMETER-LIST, PATH+FILE-PARAMETER-LIST and -ANCHOR-PARAMETER-LIST are lists with a prompt string, an alist, a default -value and an example string. The ANCHOR-PARAMETER-LIST has as an additional -element an anchor seperator string. All these elements are used to read and -construct the link." -; (let ((point nil)) - (save-window-excursion - (let ((html-buffer (current-buffer)) - (html-help-buffer (hm--html-generate-add-link-help-buffer - scheme-parameter-list - host-name:port-parameter-list - servername:port-parameter-list - path+file-parameter-list - anchor-parameter-list)) - (scheme (hm--html-completing-read scheme-parameter-list)) - (hostname:port (hm--html-completing-read - host-name:port-parameter-list)) - (servername:port (hm--html-completing-read - servername:port-parameter-list)) - (path+file (hm--html-read-filename path+file-parameter-list)) - (anchor (hm--html-completing-read anchor-parameter-list)) -; (hrefname (setq html-link-counter (1+ html-link-counter))) - (anchor-seperator - (hm--html-get-anchor-seperator-from-parameter-list - anchor-parameter-list))) - (if (not (string= scheme "")) - (if (string= hostname:port "") - (setq scheme (concat scheme ":")) - (setq scheme (concat scheme "://")))) - (if (and (not (string= hostname:port "")) - (not (string= servername:port "")) - (not (string= (substring servername:port 0 1) "/"))) - (setq servername:port (concat "/" servername:port))) - (if (and (not (string= path+file "")) - (not (string= "/" (substring path+file 0 1)))) - (setq path+file (concat "/" path+file))) - (if (not (string= anchor "")) - (setq anchor (concat anchor-seperator anchor))) - (kill-buffer html-help-buffer) - (pop-to-buffer html-buffer) - (eval (list function-add-tags - ''hm--html-insert-start-tag - (concat "") - ''hm--html-insert-end-tag - ""))) -; (setq point (point)))) -; (goto-char (point))) - )) - -(defun hm--html-add-info-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link on a GNU Info file." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Gateway and Port: " - hm--html-info-hostname:port-alist - hm--html-info-hostname:port-default - nil - "www.tnt.uni-hannover.de:8005") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-info-path-alist - nil - nil - "/appl/lemacs/Global/info/dir") - (list ; anchor - "Node: " - '(("")) - nil - nil - "emacs" - ","))) - - -(defun hm--html-add-info-link () - "Adds the HTML tags for a link on a GNU Info file." - (interactive) - (hm--html-add-info-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-info-link-to-region () - "Adds the HTML tags for a link on a GNU Info file to the region." - (interactive) - (hm--html-add-info-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-wais-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a WAIS server." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Gateway and Port: " - hm--html-wais-hostname:port-alist - hm--html-wais-hostname:port-default - nil - "www.tnt.uni-hannover.de:8001") - (list ; servername:port - "Wais Servername and Port: " - hm--html-wais-servername:port-alist - hm--html-wais-servername:port-default - nil - "quake.think.com:210") - (list ; path/file - "Database: " - hm--html-wais-path-alist - nil - nil - "database") - (list ; anchor - "Searchstring: " - '(("")) - nil - nil - "searchstring" - "?"))) - - -(defun hm--html-add-wais-link () - "Adds the HTML tags for a link to a WAIS server." - (interactive) - (hm--html-add-wais-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-wais-link-to-region () - "Adds the HTML tags for a link to a WAIS server to the region." - (interactive) - (hm--html-add-wais-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-direct-wais-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a direct link to a WAIS server. -This function uses the new direct WAIS support instead of a WAIS gateway." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "wais" - t - "wais") - (list ; hostname:port - "Wais Servername and Port: " - hm--html-wais-servername:port-alist - hm--html-wais-servername:port-default - nil - "quake.think.com:210") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Database: " - hm--html-wais-path-alist - nil - nil - "database") - (list ; anchor - "Searchstring: " - '(("")) - nil - nil - "searchstring" - "?"))) - - -(defun hm--html-add-direct-wais-link () - "Adds the HTML tags for a direct link to a WAIS server. -This function uses the new direct WAIS support instead of a WAIS gateway." - (interactive) - (hm--html-add-direct-wais-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-direct-wais-link-to-region () - "Adds the HTML tags for a direct link to a WAIS server to the region. -This function uses the new direct WAIS support instead of a WAIS gateway." - (interactive) - (hm--html-add-direct-wais-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-html-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to an HTML page." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Servername and Port: " - hm--html-html-hostname:port-alist - hm--html-html-hostname:port-default - nil - "www.tnt.uni-hannover.de:80") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-html-path-alist - nil - nil - "/data/info/www/tnt/overview.html") - (list ; anchor - "Anchor: " - '(("")) - nil - nil - "1" - "#"))) - - -(defun hm--html-add-html-link () - "Adds the HTML tags for a link to an HTML file." - (interactive) - (hm--html-add-html-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-html-link-to-region () - "Adds the HTML tags for a link to an HTML file to the region." - (interactive) - (hm--html-add-html-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-file-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a filegateway link." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "file" - t - "file") - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-file-path-alist - nil - nil - "/data/info/www/tnt/overview.html") - (list ; anchor - "Anchor: " - '(("")) - nil - nil - "1" - "#"))) - - -(defun hm--html-add-file-link () - "Adds the HTML tags for a for a filegateway link." - (interactive) - (hm--html-add-file-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-file-link-to-region () - "Adds the HTML tags for a for a filegateway link to the region." - (interactive) - (hm--html-add-file-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-ftp-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to an FTP server." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "ftp" - t - "ftp") - (list ; hostname:port - "FTP Servername: " - hm--html-ftp-hostname:port-alist - hm--html-ftp-hostname:port-default - nil - "ftp.rrzn.uni-hannover.de") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-ftp-path-alist - nil - nil - "/pub/gnu/gcc-2.4.5.tar.gz") - (list ; anchor - "" - nil - "" - t - nil - nil))) - - -(defun hm--html-add-ftp-link () - "Adds the HTML tags for a link to an FTP server." - (interactive) - (hm--html-add-ftp-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-ftp-link-to-region () - "Adds the HTML tags for a link to an FTP server to the region." - (interactive) - (hm--html-add-ftp-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-gopher-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a gopher server." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "gopher" - t - "gopher") - (list ; hostname:port - "Gopher Servername: " - hm--html-gopher-hostname:port-alist - hm--html-gopher-hostname:port-default - nil - "newsserver.rrzn.uni-hannover.de:70") - (list ; servername:port - "Documenttype: " - hm--html-gopher-doctype-alist - hm--html-gopher-doctype-default - nil - "/1") - nil ; path/file - (list ; anchor - "Entrypoint: " - hm--html-gopher-anchor-alist - nil - nil - "Subject%20Tree" - "/"))) - - -(defun hm--html-add-gopher-link () - "Adds the HTML tags for a link to a gopher server." - (interactive) - (hm--html-add-gopher-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-gopher-link-to-region () - "Adds the HTML tags for a link to a gopher server to the region." - (interactive) - (hm--html-add-gopher-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-make-proggate-alist (proggate-allowed-file) - "Makes a proggate-alist from the PROGGATE-ALLOWED-FILE." - (if (and (stringp proggate-allowed-file) - (file-exists-p proggate-allowed-file)) - (save-window-excursion - (let ((alist nil) - (buffername (find-file-noselect proggate-allowed-file)) - (case-fold-search t)) - (set-buffer buffername) - (toggle-read-only) - (goto-char (point-min)) - (while (search-forward-regexp "[^ \t\n]+" nil t) - (setq alist (append (list (list (buffer-substring - (match-beginning 0) - (match-end 0)))) - alist))) - (kill-buffer buffername) - alist)) - (error "ERROR: Can't find the 'hm--html-progate-allowed-file !"))) - - -(defun hm--html-add-proggate-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a program. -The program is called via the program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (let ((progname-alist (hm--html-make-proggate-alist - hm--html-proggate-allowed-file))) - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Servername and Port: " - hm--html-proggate-hostname:port-alist - hm--html-proggate-hostname:port-default - nil - "www.tnt.uni-hannover.de:8007") - (list ; program - "Programname: " - progname-alist - nil - nil - "/usr/ucb/man") - nil ; path/file - (list ; Program Parameter - "Programparameter: " - '(("")) - nil - nil - "8+lpd" - "+")))) - - -(defun hm--html-add-proggate-link () - "Adds the HTML tags for a link to a program. -The program is called via the program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-proggate-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-proggate-link-to-region () - "Adds the HTML tags for a link to a program to the region. -The program is called via the program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-proggate-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-local-proggate-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a program. -The program is called via the local program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "" - t - nil) - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/file: " - hm--html-local-proggate-path-alist - nil - nil - "/data/info/programs/lemacs.evlm") - (list ; anchor - "" - nil - "" - t - nil))) - - -(defun hm--html-add-local-proggate-link () - "Adds the HTML tags for a link to a program. -The program is called via the local program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-local-proggate-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-local-proggate-link-to-region () - "Adds the HTML tags for a link to a program to the region. -The program is called via the local program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-local-proggate-link-1 'hm--html-add-tags-to-region)) - - -(defvar hm--html-newsgroup-alist nil - "Alist with newsgroups for the newsgateway.") - - -(defvar gnus-newsrc-assoc nil) - - -(defun hm--html-make-newsgroup-alist () - "Makes a hm--html-make-newsgroup-alist from a .newsrc.el file. -The function looks at the environment variable NNTPSERVER. -If this variable exists, it tries to open the file with the Name -~/$NNTPSERVER.el. If this file exists, the alist of the file is -returned as the newsgroup-alist. If the file doesn't exist, it -tries to use the file ~/$NNTPSERVER to make the alist. The function -returns '((\"\"))" - (if hm--html-newsgroup-alist - hm--html-newsgroup-alist - (if gnus-newsrc-assoc - (setq hm--html-newsgroup-alist gnus-newsrc-assoc) - (if (not (getenv "NNTPSERVER")) - '(("")) - (let ((newsrc-file (expand-file-name (concat "~/.newsrc-" - (getenv "NNTPSERVER"))))) - (if (file-exists-p (concat newsrc-file ".el")) - (progn - (load-file (concat newsrc-file ".el")) - (setq hm--html-newsgroup-alist gnus-newsrc-assoc)) - (if (not (file-exists-p newsrc-file)) - '(("")) - (save-window-excursion - (let ((alist nil) - (buffername (find-file-noselect newsrc-file)) - (case-fold-search t)) - (set-buffer buffername) - (toggle-read-only) - (goto-char (point-min)) - (while (search-forward-regexp "[^:!]+" nil t) - (setq alist (append (list (list (buffer-substring - (match-beginning 0) - (match-end 0)))) - alist)) - (search-forward-regexp "\n")) - (kill-buffer buffername) - (setq hm--html-newsgroup-alist alist)))))))))) - - - -(defun hm--html-add-news-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a news group." - (let ((newsgroup-alist (hm--html-make-newsgroup-alist))) - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "news" - t - "news") - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "NEWS Group: " - newsgroup-alist - nil - nil - "comp.emacs.xemacs") - nil ; path/file - (list ; anchor - "" - nil - "" - t - nil - nil)))) - - -(defun hm--html-add-news-link () - "Adds the HTML tags for a link to a news group." - (interactive) - (hm--html-add-news-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-news-link-to-region () - "Adds the HTML tags for a link to a news group to the region." - (interactive) - (hm--html-add-news-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-mail-box-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a mail box." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Hostname and Port: " - hm--html-mail-hostname:port-alist - hm--html-mail-hostname:port-default - nil - "www.tnt.uni-hannover.de:8003") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-mail-path-alist - nil - nil - "/data/info/mail/mailbox") - (list ; anchor - "" - nil - "" - t - nil - nil))) - - -(defun hm--html-add-mail-box-link () - "Adds the HTML tags for a link to a mail box." - (interactive) - (hm--html-add-mail-box-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-mail-box-link-to-region () - "Adds the HTML tags for a link to a mail box to the region." - (interactive) - (hm--html-add-mail-box-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-mailto-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a mailto link." - (let ((mailto-alist (if (and (boundp 'user-mail-address) - user-mail-address) - (cons (list user-mail-address) - hm--html-mailto-alist) - hm--html-mailto-alist))) - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "mailto" - t - "mailto") - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "Mailaddress: " - mailto-alist - nil - nil - "muenkel@tnt.uni-hannover.de") - nil ; path/file - (list ; anchor - "" - nil - "" - t - nil - nil)))) - -(defun hm--html-add-mailto-link () - "Adds the HTML tags for a mailto link." - (interactive) - (hm--html-add-mailto-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-mailto-link-to-region () - "Adds the HTML tags for a mailto link to the region." - (interactive) - (hm--html-add-mailto-link-1 'hm--html-add-tags-to-region)) - -(defun hm--html-add-relative-link (relative-file-path) - "Adds the HTML tags for a relative link at the current point." - (interactive (list (file-relative-name - (read-file-name "Relative Filename: " - nil - nil - nil - "") - default-directory) - )) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "") - 'hm--html-insert-end-tag - "")) - -(defun hm--html-add-relative-link-to-region (relative-file-path) - "Adds the HTML tags for a relative link to the region." - (interactive (list (file-relative-name - (read-file-name "Relative Filename: " - nil - nil - nil - "")))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "") - 'hm--html-insert-end-tag - "")) - -(defun hm--html-add-normal-link (link-object) - "Adds the HTML tags for a normal general link. -Single argument LINK-OBJECT is value of HREF in the new anchor. -Mark is set after anchor." - (interactive "sNode Link to: ") - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "") - 'hm--html-insert-end-tag - "")) - -(defun hm--html-add-normal-link-to-region (link-object) - "Adds the HTML tags for a normal general link to region. -Single argument LINK-OBJECT is value of HREF in the new anchor. -Mark is set after anchor." - (interactive "sNode Link to: ") - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "") - 'hm--html-insert-end-tag - "")) - - -(defun hm--html-add-normal-node-link () - "Adds the HTML tags for a normal node link () at the point." - (interactive) - (hm--html-insert-start-tag (concat "") - )) - -;;; Functions to update the date and the changelog entries - - -(defun hm--html-maybe-new-date-and-changed-comment () - "Hook function which updates the date in the title line, if -'hm--html-automatic-update-title-date' is t and which inserts a -\"changed comment\" line, if 'hm--html-automatic-changed-comment' is t." - (when hm--html-automatic-update-title-date - (hm--html-new-date)) - (when hm--html-automatic-changed-comment - (hm--html-insert-changed-comment t)) - (when hm--html-automatic-update-modified-line - (hm--html-insert-modified-line))) - - -(defun hm--html-new-date () - "The function sets the date in the title line up." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (end-of-head (if (search-forward "" nil t) - (point) - (if (search-forward "" nil t) - (point) - (point-max))))) - (goto-char (point-min)) - (if (re-search-forward - (concat - "\\((\\)" - "\\([ \t]*[0-3]?[0-9]-[A-Z][a-z][a-z]-[0-9][0-9][0-9][0-9]" - "[ \t]*\\)" - "\\()[ \t\n]*\\)") - end-of-head - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (goto-char (match-beginning 2)) - (insert (hm--date))))))) - - -(defun hm--html-insert-created-comment (&optional noerror) - "The function inserts a \"created comment\". -The comment looks like . -The comment will be inserted after the title line. -An error message is printed, if there is no title line and if -noerror is nil." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (end-of-head (if (search-forward "" nil t) - (point) - (if (search-forward "" nil t) - (point) - (point-max)))) - (comment-infix (or hm--html-comment-infix - (concat (or hm--html-username (user-full-name)) - ", ")))) - (goto-char (point-min)) - (if (not (search-forward "" end-of-head t)) - (if (not noerror) - (error "ERROR: Please insert a title in the document !")) -; (let ((end-of-title-position (point))) - (if (search-forward (concat ". -The comment will be inserted after the last \"changed comment\" line, or, -if there isn't such a line, after the \"created comment\" line, or, -after the title line. If there is no title and NOERROR is nil, an error -message is generated. The line is not inserted after the end of the head -or the beginning of the body. -If the last \"changed line\" is from the same author, it is only replaced -by the new one. - -Look at the variables `hm--html-changed-comment-prefix' and -`hm--html-comment-infix', if you'd like to change the -inserted comments. You should not use different values for this -variables in the same HTML file. - -Attention: Don't write anything else in such a line!" - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (end-of-head (if (search-forward "" nil t) - (point) - (if (search-forward "" nil t) - (point) - (point-max)))) - (comment-infix (or hm--html-comment-infix - hm--html-username - (user-full-name)))) -; (username (or hm--html-username (user-full-name)))) - (goto-char end-of-head) -; (if (search-backward " FIDEL conversion. -The value should be one of: `tigrigna', `amharic' or `english'.") - -(defvar ethio-secondary-language 'english - "*Symbol that defines the secondary language in SERA --> FIDEL conversion. -The value should be one of: `tigrigna', `amharic' or `english'.") - -(defvar ethio-use-colon-for-colon nil - "*Non-nil means associate ASCII colon with Ethiopic colon. -If nil, associate ASCII colon with Ethiopic word separator, i.e., two -vertically stacked dots. All SERA <--> FIDEL converters refer this -variable.") - -(defvar ethio-use-three-dot-question nil - "*Non-nil means associate ASCII question mark with Ethiopic old style question mark (three vertically stacked dots). -If nil, associate ASCII question mark with Ethiopic stylised question -mark. All SERA <--> FIDEL converters refer this variable.") - -(defvar ethio-quote-vowel-always nil - "*Non-nil means always put an apostrophe before an isolated vowel (except at word initial) in FIDEL --> SERA conversion. -If nil, put an apostrophe only between a sixth-form consonant and an -isolated vowel.") - -(defvar ethio-W-sixth-always nil - "*Non-nil means convert the Wu-form of a 12-form consonant to \"W'\" instead of \"Wu\" in FIDEL --> SERA conversion.") - -(defvar ethio-numeric-reduction 0 - "*Degree of reduction in converting Ethiopic digits into Arabic digits. -Should be 0, 1 or 2. -For example, ({10}{9}{100}{80}{7}) is converted into: - `10`9`100`80`7 if `ethio-numeric-reduction' is 0, - `109100807 if `ethio-numeric-reduction' is 1, - `10900807 if `ethio-numeric-reduction' is 2.") - -(defvar ethio-implicit-period-conversion t - "*Non-nil means replacing the Ethiopic dot at the end of an Ethiopic sentence -with an Ethiopic full stop.") - -(defvar ethio-java-save-lowercase nil - "*Non-nil means save Ethiopic characters in lowercase hex numbers to Java files. -If nil, use uppercases.") - -;; -;; SERA to FIDEL -;; - -(defconst ethio-sera-to-fidel-table - [ - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -;;; SP - (" " - (?: (if ethio-use-colon-for-colon " $(3$l(B" "$(3$h(B") - (32 (if ethio-use-colon-for-colon " $(3$l(B " "$(3$h(B")) - (?- " $(3$m(B") - (?: " $(3$i(B") - (?| (if ethio-use-colon-for-colon " $(3$l(B|" " $(3$h(B|") - (?: " $(3$o(B")))) - -;;; ! " # $ % & ' - nil nil nil nil nil nil ("" (?' "$(3%s(B")) -;;; ( ) * + , - . - nil nil nil nil ("$(3$j(B") ("-" (?: "$(3$l(B")) ("$(3%u(B") -;;; / 0 1 2 3 4 5 6 7 8 9 - nil nil nil nil nil nil nil nil nil nil nil -;;; : - ((if ethio-use-colon-for-colon "$(3$l(B" "$(3$h(B") - (32 (if ethio-use-colon-for-colon "$(3$l(B " "$(3$h(B")) - (?- "$(3$m(B") - (?: "$(3$i(B") - (?| (if ethio-use-colon-for-colon "$(3$l(B|" "$(3$h(B|") - (?: "$(3$o(B"))) -;;; ; < = > - ("$(3$k(B") ("<" (?< "$(3%v(B")) nil (">" (?> "$(3%w(B")) -;;; ? - ((if ethio-use-three-dot-question "$(3$n(B" "$(3%x(B")) -;;; @ - nil -;;; A - ("$(3"f(B" (?2 "$(3#8(B")) -;;; B - ("$(3"((B" (?e "$(3"#(B") (?u "$(3"$(B") (?i "$(3"%(B") (?a "$(3"&(B") (?E "$(3"'(B") (?o "$(3")(B") - (?W "$(3%b(B" (?e "$(3%2(B") (?u "$(3%b(B") (?i "$(3%B(B") (?a "$(3"*(B") (?E "$(3%R(B"))) -;;; C - ("$(3$4(B" (?e "$(3$/(B") (?u "$(3$0(B") (?i "$(3$1(B") (?a "$(3$2(B") (?E "$(3$3(B") (?o "$(3$5(B") - (?W "$(3$6(B" (?a "$(3$6(B") - (?e "$(3$4%n(B") (?u "$(3$4%r(B") (?i "$(3$4%o(B") (?E "$(3$4%q(B"))) -;;; D - ("$(3#b(B" (?e "$(3#](B") (?u "$(3#^(B") (?i "$(3#_(B") (?a "$(3#`(B") (?E "$(3#a(B") (?o "$(3#c(B") - (?W "$(3#d(B" (?a "$(3#d(B") - (?e "$(3#b%n(B") (?u "$(3#b%r(B") (?i "$(3#b%o(B") (?E "$(3#b%q(B"))) -;;; E - ("$(3"g(B" (?2 "$(3#9(B")) -;;; F - ("$(3$T(B" (?e "$(3$O(B") (?u "$(3$P(B") (?i "$(3$Q(B") (?a "$(3$R(B") (?E "$(3$S(B") (?o "$(3$U(B") - (?W "$(3%d(B" (?e "$(3%4(B") (?u "$(3%d(B") (?i "$(3%D(B") (?a "$(3$V(B") (?E "$(3%T(B")) - (?Y "$(3$a(B" (?a "$(3$a(B"))) -;;; G - ("$(3$$(B" (?e "$(3#}(B") (?u "$(3#~(B") (?i "$(3$!(B") (?a "$(3$"(B") (?E "$(3$#(B") (?o "$(3$%(B") - (?W "$(3%c(B" (?e "$(3%3(B") (?u "$(3%c(B") (?i "$(3%C(B") (?a "$(3$&(B") (?E "$(3%S(B"))) -;;; H - ("$(3!6(B" (?e "$(3!1(B") (?u "$(3!2(B") (?i "$(3!3(B") (?a "$(3!4(B") (?E "$(3!5(B") (?o "$(3!7(B") - (?W "$(3!8(B" (?a "$(3!8(B") - (?e "$(3!6%n(B") (?u "$(3!6%r(B") (?i "$(3!6%o(B") (?E "$(3!6%q(B"))) -;;; I - ("$(3"h(B" (?2 "$(3#:(B")) -;;; J - ("$(3#j(B" (?e "$(3#e(B") (?u "$(3#f(B") (?i "$(3#g(B") (?a "$(3#h(B") (?E "$(3#i(B") (?o "$(3#k(B") - (?W "$(3#l(B" (?a "$(3#l(B") - (?e "$(3#j%n(B") (?u "$(3#j%r(B") (?i "$(3#j%o(B") (?E "$(3#j%q(B"))) -;;; K - ("$(3#"(B" (?e "$(3"{(B") (?u "$(3"|(B") (?i "$(3"}(B") (?a "$(3"~(B") (?E "$(3#!(B") (?o "$(3##(B") - (?W "$(3#*(B" (?e "$(3#%(B") (?u "$(3#*(B") (?i "$(3#'(B") (?a "$(3#((B") (?E "$(3#)(B"))) -;;; L - ("$(3!.(B" (?e "$(3!)(B") (?u "$(3!*(B") (?i "$(3!+(B") (?a "$(3!,(B") (?E "$(3!-(B") (?o "$(3!/(B") - (?W "$(3!0(B" (?a "$(3!0(B") - (?e "$(3!.%n(B") (?u "$(3!.%r(B") (?i "$(3!.%o(B") (?E "$(3!.%q(B"))) -;;; M - ("$(3!>(B" (?e "$(3!9(B") (?u "$(3!:(B") (?i "$(3!;(B") (?a "$(3!<(B") (?E "$(3!=(B") (?o "$(3!?(B") - (?W "$(3%a(B" (?e "$(3%1(B") (?u "$(3%a(B") (?i "$(3%A(B") (?a "$(3!@(B") (?E "$(3%Q(B")) - (?Y "$(3$_(B" (?a "$(3$_(B"))) -;;; N - ("$(3"`(B" (?e "$(3"[(B") (?u "$(3"\(B") (?i "$(3"](B") (?a "$(3"^(B") (?E "$(3"_(B") (?o "$(3"a(B") - (?W "$(3"b(B" (?a "$(3"b(B") - (?e "$(3"`%n(B") (?u "$(3"`%r(B") (?i "$(3"`%o(B") (?E "$(3"`%q(B"))) -;;; O - ("$(3"i(B" (?2 "$(3#;(B")) -;;; P - ("$(3$<(B" (?e "$(3$7(B") (?u "$(3$8(B") (?i "$(3$9(B") (?a "$(3$:(B") (?E "$(3$;(B") (?o "$(3$=(B") - (?W "$(3$>(B" (?a "$(3$>(B") - (?e "$(3$<%n(B") (?u "$(3$<%r(B") (?i "$(3$<%o(B") (?E "$(3$<%q(B"))) -;;; Q - ("$(3!v(B" (?e "$(3!q(B") (?u "$(3!r(B") (?i "$(3!s(B") (?a "$(3!t(B") (?E "$(3!u(B") (?o "$(3!w(B") - (?W "$(3!~(B" (?e "$(3!y(B") (?u "$(3!~(B") (?i "$(3!{(B") (?a "$(3!|(B") (?E "$(3!}(B"))) -;;; R - ("$(3!N(B" (?e "$(3!I(B") (?u "$(3!J(B") (?i "$(3!K(B") (?a "$(3!L(B") (?E "$(3!M(B") (?o "$(3!O(B") - (?W "$(3!P(B" (?a "$(3!P(B") - (?e "$(3!N%n(B") (?u "$(3!N%r(B") (?i "$(3!N%o(B") (?E "$(3!N%q(B")) - (?Y "$(3$`(B" (?a "$(3$`(B"))) -;;; S - ("$(3$D(B" (?e "$(3$?(B") (?u "$(3$@(B") (?i "$(3$A(B") (?a "$(3$B(B") (?E "$(3$C(B") (?o "$(3$E(B") - (?W "$(3$F(B" (?a "$(3$F(B") - (?e "$(3$D%n(B") (?u "$(3$D%r(B") (?i "$(3$D%o(B") (?E "$(3$D%q(B")) - (?2 "$(3$L(B" - (?e "$(3$G(B") (?u "$(3$H(B") (?i "$(3$I(B") (?a "$(3$J(B") (?E "$(3$K(B") (?o "$(3$M(B") - (?W "$(3$F(B" (?a "$(3$F(B") - (?e "$(3$L%n(B") (?u "$(3$L%r(B") (?i "$(3$L%o(B") (?E "$(3$L%q(B")))) -;;; T - ("$(3$,(B" (?e "$(3$'(B") (?u "$(3$((B") (?i "$(3$)(B") (?a "$(3$*(B") (?E "$(3$+(B") (?o "$(3$-(B") - (?W "$(3$.(B" (?a "$(3$.(B") - (?e "$(3$,%n(B") (?u "$(3$,%r(B") (?i "$(3$,%o(B") (?E "$(3$,%q(B"))) -;;; U - ("$(3"d(B" (?2 "$(3#6(B")) -;;; V - ("$(3"0(B" (?e "$(3"+(B") (?u "$(3",(B") (?i "$(3"-(B") (?a "$(3".(B") (?E "$(3"/(B") (?o "$(3"1(B") - (?W "$(3"2(B" (?a "$(3"2(B") - (?e "$(3"0%n(B") (?u "$(3"0%r(B") (?i "$(3"0%o(B") (?E "$(3"0%q(B"))) -;;; W - ("$(3%r(B" (?e "$(3%n(B") (?u "$(3%r(B") (?i "$(3%o(B") (?a "$(3%p(B") (?E "$(3%q(B")) -;;; X - ("$(3%N(B" (?e "$(3%I(B") (?u "$(3%J(B") (?i "$(3%K(B") (?a "$(3%L(B") (?E "$(3%M(B") (?o "$(3%O(B")) -;;; Y - ("$(3#R(B" (?e "$(3#M(B") (?u "$(3#N(B") (?i "$(3#O(B") (?a "$(3#P(B") (?E "$(3#Q(B") (?o "$(3#S(B") - (?W "$(3#T(B" (?a "$(3#T(B") - (?e "$(3#R%n(B") (?u "$(3#R%r(B") (?i "$(3#R%o(B") (?E "$(3#R%q(B"))) -;;; Z - ("$(3#J(B" (?e "$(3#E(B") (?u "$(3#F(B") (?i "$(3#G(B") (?a "$(3#H(B") (?E "$(3#I(B") (?o "$(3#K(B") - (?W "$(3#L(B" (?a "$(3#L(B") - (?e "$(3#J%n(B") (?u "$(3#J%r(B") (?i "$(3#J%o(B") (?E "$(3#J%q(B"))) -;;; [ \ ] ^ _ - nil nil nil nil nil -;;; ` - ("" - (?: "$(3$h(B") - (?? (if ethio-use-three-dot-question "$(3%x(B" "$(3$n(B")) - (?! "$(3%t(B") - (?e "$(3#5(B") (?u "$(3#6(B") (?U "$(3#6(B") (?i "$(3#7(B") (?a "$(3#8(B") (?A "$(3#8(B") - (?E "$(3#9(B") (?I "$(3#:(B") (?o "$(3#;(B") (?O "$(3#;(B") - (?g "$(3%^(B" - (?e "$(3%Y(B") (?u "$(3%Z(B") (?i "$(3%[(B") (?a "$(3%\(B") (?E "$(3%](B") (?o "$(3%_(B")) - (?h "$(3"H(B" - (?e "$(3"C(B") (?u "$(3"D(B") (?i "$(3"E(B") (?a "$(3"F(B") (?E "$(3"G(B") (?o "$(3"I(B") - (?W "$(3"P(B" (?e "$(3"K(B") (?u "$(3"P(B") (?i "$(3"M(B") (?a "$(3"N(B") (?E "$(3"O(B"))) - (?k "$(3%>(B" - (?e "$(3%9(B") (?u "$(3%:(B") (?i "$(3%;(B") (?a "$(3%<(B") (?E "$(3%=(B") (?o "$(3%?(B")) - (?s "$(3!F(B" - (?e "$(3!A(B") (?u "$(3!B(B") (?i "$(3!C(B") (?a "$(3!D(B") (?E "$(3!E(B") (?o "$(3!G(B") - (?W "$(3!H(B" (?a "$(3!H(B") - (?e "$(3!F%n(B") (?u "$(3!F%r(B") (?i "$(3!F%o(B") (?E "$(3!F%q(B"))) - (?S "$(3$L(B" - (?e "$(3$G(B") (?u "$(3$H(B") (?i "$(3$I(B") (?a "$(3$J(B") (?E "$(3$K(B") (?o "$(3$M(B") - (?W "$(3$F(B" (?a "$(3$F(B") - (?e "$(3$L%n(B") (?u "$(3$L%r(B") (?i "$(3$L%o(B") (?E "$(3$L%q(B"))) - (?q "$(3%.(B" (?e "$(3%)(B") (?u "$(3%*(B") (?i "$(3%+(B") (?a "$(3%,(B") (?E "$(3%-(B") (?o "$(3%/(B"))) -;;; a - ("$(3"f(B" (?2 "$(3#8(B")) -;;; b - ("$(3"((B" (?e "$(3"#(B") (?u "$(3"$(B") (?i "$(3"%(B") (?a "$(3"&(B") (?E "$(3"'(B") (?o "$(3")(B") - (?W "$(3%b(B" (?e "$(3%2(B") (?u "$(3%b(B") (?i "$(3%B(B") (?a "$(3"*(B") (?E "$(3%R(B"))) -;;; c - ("$(3"@(B" (?e "$(3";(B") (?u "$(3"<(B") (?i "$(3"=(B") (?a "$(3">(B") (?E "$(3"?(B") (?o "$(3"A(B") - (?W "$(3"B(B" (?a "$(3"B(B") - (?e "$(3"@%n(B") (?u "$(3"@%r(B") (?i "$(3"@%o(B") (?E "$(3"@%q(B"))) -;;; d - ("$(3#Z(B" (?e "$(3#U(B") (?u "$(3#V(B") (?i "$(3#W(B") (?a "$(3#X(B") (?E "$(3#Y(B") (?o "$(3#[(B") - (?W "$(3#\(B" (?a "$(3#\(B") - (?e "$(3#Z%o(B") (?u "$(3#Z%r(B") (?i "$(3#Z%p(B") (?E "$(3#Z%q(B"))) -;;; e - ("$(3"c(B" (?2 "$(3#5(B") (?a "$(3"j(B")) -;;; f - ("$(3$T(B" (?e "$(3$O(B") (?u "$(3$P(B") (?i "$(3$Q(B") (?a "$(3$R(B") (?E "$(3$S(B") (?o "$(3$U(B") - (?W "$(3%d(B" (?e "$(3%4(B") (?u "$(3%d(B") (?i "$(3%D(B") (?a "$(3$V(B") (?E "$(3%T(B")) - (?Y "$(3$a(B" (?a "$(3$a(B"))) -;;; g - ("$(3#r(B" (?e "$(3#m(B") (?u "$(3#n(B") (?i "$(3#o(B") (?a "$(3#p(B") (?E "$(3#q(B") (?o "$(3#s(B") - (?W "$(3#z(B" (?e "$(3#u(B") (?u "$(3#z(B") (?i "$(3#w(B") (?a "$(3#x(B") (?E "$(3#y(B")) - (?2 "$(3%^(B" (?e "$(3%Y(B") (?u "$(3%Z(B") (?i "$(3%[(B") (?a "$(3%\(B") (?E "$(3%](B") (?o "$(3%_(B"))) -;;; h - ("$(3!&(B" (?e "$(3!!(B") (?u "$(3!"(B") (?i "$(3!#(B") (?a "$(3!$(B") (?E "$(3!%(B") (?o "$(3!'(B") - (?W "$(3"P(B" (?e "$(3"K(B") (?u "$(3"P(B") (?i "$(3"M(B") (?a "$(3"N(B") (?E "$(3"O(B")) - (?2 "$(3"H(B" (?e "$(3"C(B") (?u "$(3"D(B") (?i "$(3"E(B") (?a "$(3"F(B") (?E "$(3"G(B") (?o "$(3"I(B") - (?W "$(3"P(B" (?e "$(3"K(B") (?u "$(3"P(B") (?i "$(3"M(B") (?a "$(3"N(B") (?E "$(3"O(B")))) -;;; i - ("$(3"e(B" (?2 "$(3#7(B")) -;;; j - ("$(3#j(B" (?e "$(3#e(B") (?u "$(3#f(B") (?i "$(3#g(B") (?a "$(3#h(B") (?E "$(3#i(B") (?o "$(3#k(B") - (?W "$(3#l(B" (?a "$(3#l(B") - (?e "$(3#j%n(B") (?u "$(3#j%r(B") (?i "$(3#j%o(B") (?E "$(3#j%q(B"))) -;;; k - ("$(3"p(B" (?e "$(3"k(B") (?u "$(3"l(B") (?i "$(3"m(B") (?a "$(3"n(B") (?E "$(3"o(B") (?o "$(3"q(B") - (?W "$(3"x(B" (?e "$(3"s(B") (?u "$(3"x(B") (?i "$(3"u(B") (?a "$(3"v(B") (?E "$(3"w(B")) - (?2 "$(3%>(B" (?e "$(3%9(B") (?u "$(3%:(B") (?i "$(3%;(B") (?a "$(3%<(B") (?E "$(3%=(B") (?o "$(3%?(B"))) -;;; l - ("$(3!.(B" (?e "$(3!)(B") (?u "$(3!*(B") (?i "$(3!+(B") (?a "$(3!,(B") (?E "$(3!-(B") (?o "$(3!/(B") - (?W "$(3!0(B" (?a "$(3!0(B") - (?e "$(3!.%n(B") (?u "$(3!.%r(B") (?i "$(3!.%o(B") (?E "$(3!.%q(B"))) -;;; m - ("$(3!>(B" (?e "$(3!9(B") (?u "$(3!:(B") (?i "$(3!;(B") (?a "$(3!<(B") (?E "$(3!=(B") (?o "$(3!?(B") - (?W "$(3%a(B" (?e "$(3%1(B") (?u "$(3%a(B") (?i "$(3%A(B") (?a "$(3!@(B") (?E "$(3%Q(B")) - (?Y "$(3$_(B" (?a "$(3$_(B"))) -;;; n - ("$(3"X(B" (?e "$(3"S(B") (?u "$(3"T(B") (?i "$(3"U(B") (?a "$(3"V(B") (?E "$(3"W(B") (?o "$(3"Y(B") - (?W "$(3"Z(B" (?a "$(3"Z(B") - (?e "$(3"X%n(B") (?u "$(3"X%r(B") (?i "$(3"X%o(B") (?E "$(3"X%q(B"))) -;;; o - ("$(3"i(B" (?2 "$(3#;(B")) -;;; p - ("$(3$\(B" (?e "$(3$W(B") (?u "$(3$X(B") (?i "$(3$Y(B") (?a "$(3$Z(B") (?E "$(3$[(B") (?o "$(3$](B") - (?W "$(3%e(B" (?e "$(3%5(B") (?u "$(3%e(B") (?i "$(3%E(B") (?a "$(3$^(B") (?E "$(3%U(B"))) -;;; q - ("$(3!f(B" (?e "$(3!a(B") (?u "$(3!b(B") (?i "$(3!c(B") (?a "$(3!d(B") (?E "$(3!e(B") (?o "$(3!g(B") - (?W "$(3!n(B" (?e "$(3!i(B") (?u "$(3!n(B") (?i "$(3!k(B") (?a "$(3!l(B") (?E "$(3!m(B")) - (?2 "$(3%.(B" (?e "$(3%)(B") (?u "$(3%*(B") (?i "$(3%+(B") (?a "$(3%,(B") (?E "$(3%-(B") (?o "$(3%/(B"))) -;;; r - ("$(3!N(B" (?e "$(3!I(B") (?u "$(3!J(B") (?i "$(3!K(B") (?a "$(3!L(B") (?E "$(3!M(B") (?o "$(3!O(B") - (?W "$(3!P(B" (?a "$(3!P(B") - (?e "$(3!N%n(B") (?u "$(3!N%r(B") (?i "$(3!N%o(B") (?E "$(3!N%q(B")) - (?Y "$(3$`(B" (?a "$(3$`(B"))) -;;; s - ("$(3!V(B" (?e "$(3!Q(B") (?u "$(3!R(B") (?i "$(3!S(B") (?a "$(3!T(B") (?E "$(3!U(B") (?o "$(3!W(B") - (?W "$(3!X(B" (?a "$(3!X(B") - (?e "$(3!V%n(B") (?u "$(3!V%r(B") (?i "$(3!V%o(B") (?E "$(3!V%q(B")) - (?2 "$(3!F(B" (?e "$(3!A(B") (?u "$(3!B(B") (?i "$(3!C(B") (?a "$(3!D(B") (?E "$(3!E(B") (?o "$(3!G(B") - (?W "$(3!H(B" (?a "$(3!H(B") - (?e "$(3!F%n(B") (?u "$(3!F%r(B") (?i "$(3!F%o(B") (?E "$(3!F%q(B")))) -;;; t - ("$(3"8(B" (?e "$(3"3(B") (?u "$(3"4(B") (?i "$(3"5(B") (?a "$(3"6(B") (?E "$(3"7(B") (?o "$(3"9(B") - (?W "$(3":(B" (?a "$(3":(B") - (?e "$(3"8%n(B") (?u "$(3"8%r(B") (?i "$(3"8%o(B") (?E "$(3"8%q(B"))) -;;; u - ("$(3"d(B" (?2 "$(3#6(B")) -;;; v - ("$(3"0(B" (?e "$(3"+(B") (?u "$(3",(B") (?i "$(3"-(B") (?a "$(3".(B") (?E "$(3"/(B") (?o "$(3"1(B") - (?W "$(3"2(B" (?a "$(3"2(B") - (?e "$(3"0%n(B") (?u "$(3"0%r(B") (?i "$(3"0%o(B") (?E "$(3"0%q(B"))) -;;; w - ("$(3#2(B" (?e "$(3#-(B") (?u "$(3#.(B") (?i "$(3#/(B") (?a "$(3#0(B") (?E "$(3#1(B") (?o "$(3#3(B") - (?W "$(3%p(B" (?e "$(3%n(B") (?u "$(3%r(B") (?i "$(3%o(B") (?a "$(3%p(B") (?E "$(3%q(B"))) -;;; x - ("$(3!^(B" (?e "$(3!Y(B") (?u "$(3!Z(B") (?i "$(3![(B") (?a "$(3!\(B") (?E "$(3!](B") (?o "$(3!_(B") - (?W "$(3!`(B" (?a "$(3!`(B") - (?e "$(3!^%n(B") (?u "$(3!^%r(B") (?i "$(3!^%o(B") (?E "$(3!^%q(B"))) -;;; y - ("$(3#R(B" (?e "$(3#M(B") (?u "$(3#N(B") (?i "$(3#O(B") (?a "$(3#P(B") (?E "$(3#Q(B") (?o "$(3#S(B") - (?W "$(3#T(B" (?a "$(3#T(B") - (?e "$(3#R%n(B") (?u "$(3#R%r(B") (?i "$(3#R%o(B") (?E "$(3#R%q(B"))) -;;; z - ("$(3#B(B" (?e "$(3#=(B") (?u "$(3#>(B") (?i "$(3#?(B") (?a "$(3#@(B") (?E "$(3#A(B") (?o "$(3#C(B") - (?W "$(3#D(B" (?a "$(3#D(B") - (?e "$(3#B%n(B") (?u "$(3#B%r(B") (?i "$(3#B%o(B") (?E "$(3#B%q(B"))) -;;; { | } ~ DEL - nil nil nil nil nil - ]) - -;;;###autoload -(defun ethio-sera-to-fidel-region (beg end &optional secondary force) - "Convert the characters in region from SERA to FIDEL. -The variable `ethio-primary-language' specifies the primary language -and `ethio-secondary-language' specifies the secondary. - -If the 3rd parameter SECONDARY is given and non-nil, assume the region -begins begins with the secondary language; otherwise with the primary -language. - -If the 4th parameter FORCE is given and non-nil, perform conversion -even if the buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon' and -`ethio-use-three-dot-question'." - - (interactive "r\nP") - (save-restriction - (narrow-to-region beg end) - (ethio-sera-to-fidel-buffer secondary force))) - -;;;###autoload -(defun ethio-sera-to-fidel-buffer (&optional secondary force) - "Convert the current buffer from SERA to FIDEL. - -The variable `ethio-primary-language' specifies the primary -language and `ethio-secondary-language' specifies the secondary. - -If the 1st optional parameter SECONDARY is non-nil, assume the buffer -begins with the secondary language; otherwise with the primary -language. - -If the 2nd optional parametr FORCE is non-nil, perform conversion even if the -buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon' and -`ethio-use-three-dot-question'." - - (interactive "P") - - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - - (let ((ethio-primary-language ethio-primary-language) - (ethio-secondary-language ethio-secondary-language) - (ethio-use-colon-for-colon ethio-use-colon-for-colon) - (ethio-use-three-dot-question ethio-use-three-dot-question) - ;; The above four variables may be changed temporary - ;; by tilde escapes during conversion. So we bind them to other - ;; variables but of the same names. - (buffer-read-only nil) - (case-fold-search nil) - current-language - next-language) - - (setq current-language - (if secondary - ethio-secondary-language - ethio-primary-language)) - - (goto-char (point-min)) - - (while (not (eobp)) - (setq next-language - (cond - ((eq current-language 'english) - (ethio-sera-to-fidel-english)) - ((eq current-language 'amharic) - (ethio-sera-to-fidel-ethio 'amharic)) - ((eq current-language 'tigrigna) - (ethio-sera-to-fidel-ethio 'tigrigna)) - (t ; we don't know what to do - (ethio-sera-to-fidel-english)))) - - (setq current-language - (cond - - ;; when language tag is explicitly specified - ((not (eq next-language 'toggle)) - next-language) - - ;; found a toggle in a primary language section - ((eq current-language ethio-primary-language) - ethio-secondary-language) - - ;; found a toggle in a secondary, third, fourth, ... - ;; language section - (t - ethio-primary-language)))) - - ;; If ethio-implicit-period-conversion is non-nil, the - ;; Ethiopic dot "$(3%u(B" at the end of an Ethiopic sentence is - ;; replaced with the Ethiopic full stop "$(3$i(B". - (if ethio-implicit-period-conversion - (progn - (goto-char (point-min)) - (while (re-search-forward "\\([$(3!!(B-$(3$a%)(B-$(3%e%n(B-$(3%r%s(B]\\)$(3%u(B\\([ \t]\\)" - nil t) - (replace-match "\\1$(3$i(B\\2")) - (goto-char (point-min)) - (while (re-search-forward "\\([$(3!!(B-$(3$a%)(B-$(3%e%n(B-$(3%r%s(B]\\)$(3%u(B$" nil t) - (replace-match "\\1$(3$i(B")))) - - ;; gemination - (goto-char (point-min)) - (while (re-search-forward "\\ce$(3%s(B" nil 0) - (compose-region - (save-excursion (backward-char 2) (point)) - (point))) - )) - -(defun ethio-sera-to-fidel-english nil - "Handle English section in SERA to FIDEL conversion. -Conversion stops when a language switch is found. Then delete that -switch and return the name of the new language as a symbol." - (let ((new-language nil)) - - (while (and (not (eobp)) (null new-language)) - (cond - - ;; if no more "\", nothing to do. - ((not (search-forward "\\" nil 0))) - - ;; hereafter point is put after a "\". - ;; first delete that "\", then check the following chars - - ;; "\\" : leave the second "\" - ((progn - (delete-backward-char 1) - (= (following-char) ?\\ )) - (forward-char 1)) - - ;; "\ " : delete the following " " - ((= (following-char) 32) - (delete-char 1) - (setq new-language 'toggle)) - - ;; a language flag - ((setq new-language (ethio-process-language-flag))) - - ;; just a "\" : not special sequence. - (t - (setq new-language 'toggle)))) - - new-language)) - -(defun ethio-sera-to-fidel-ethio (lang) - "Handle Ethiopic section in SERA to FIDEL conversion. -Conversion stops when a language switch is found. Then delete that -switch and return the name of the new language as a symbol. - -The parameter LANG (symbol, either `amharic' or `tigrigna') affects -the conversion of \"a\"." - - (let ((new-language nil) - (verbatim nil) - start table table2 ch) - - (setcar (aref ethio-sera-to-fidel-table ?a) - (if (eq lang 'tigrigna) "$(3"f(B" "$(3"c(B")) - - (while (and (not (eobp)) (null new-language)) - (setq ch (following-char)) - (cond - - ;; skip from "<" to ">" (or from "&" to ";") if in w3-mode - ((and (boundp 'sera-being-called-by-w3) - sera-being-called-by-w3 - (or (= ch ?<) (= ch ?&))) - (search-forward (if (= ch ?<) ">" ";") - nil 0)) - - ;; leave non-ASCII characters as they are - ((>= ch 128) - (forward-char 1)) - - ;; ethiopic digits - ((looking-at "`[1-9][0-9]*") - (delete-char 1) - (ethio-convert-digit)) - - ;; if not seeing a "\", do sera to fidel conversion - ((/= ch ?\\ ) - (setq start (point)) - (forward-char 1) - (setq table (aref ethio-sera-to-fidel-table ch)) - (while (setq table2 (cdr (assoc (following-char) table))) - (setq table table2) - (forward-char 1)) - (if (setq ch (car table)) - (progn - (delete-region start (point)) - (if (stringp ch) - (insert ch) - (insert (eval ch)))))) - - ;; if control reaches here, we must be looking at a "\" - - ;; verbatim mode - (verbatim - (if (looking-at "\\\\~! ?") - - ;; "\~!" or "\~! ". switch to non-verbatim mode - (progn - (replace-match "") - (setq verbatim nil)) - - ;; "\" but not "\~!" nor "\~! ". skip the current "\". - (forward-char 1))) - - ;; hereafter, non-verbatim mode and looking at a "\" - ;; first delete that "\", then check the following chars. - - ;; "\ " : delete the following " " - ((progn - (delete-char 1) - (setq ch (following-char)) - (= ch 32)) - (delete-char 1) - (setq new-language 'toggle)) - - ;; "\~!" or "\~! " : switch to verbatim mode - ((looking-at "~! ?") - (replace-match "") - (setq verbatim t)) - - ;; a language flag - ((setq new-language (ethio-process-language-flag))) - - ;; "\~" but not "\~!" nor a language flag - ((= ch ?~) - (delete-char 1) - (ethio-tilde-escape)) - - ;; ASCII punctuation escape. skip - ((looking-at "\\(,\\|\\.\\|;\\|:\\|'\\|`\\|\?\\|\\\\\\)+") - (goto-char (match-end 0))) - - ;; "\", but not special sequence - (t - (setq new-language 'toggle)))) - - new-language)) - -(defun ethio-process-language-flag nil - "Process a language flag of the form \"~lang\" or \"~lang1~lang2\". - -If looking at \"~lang1~lang2\", set `ethio-primary-language' and -`ethio-une-secondary-language' based on \"lang1\" and \"lang2\". -Then delete the language flag \"~lang1~lang2\" from the buffer. -Return value is the new primary language. - -If looking at \"~lang\", delete that language flag \"~lang\" from the -buffer and return that language. In this case -`ethio-primary-language' and `ethio-uni-secondary-language' -are left unchanged. - -If an unsupported language flag is found, just return nil without -changing anything." - - (let (lang1 lang2) - (cond - - ;; ~lang1~lang2 - ((and (looking-at - "~\\([a-z][a-z][a-z]?\\)~\\([a-z][a-z][a-z]?\\)[ \t\n\\]") - (setq lang1 - (ethio-flag-to-language - (buffer-substring (match-beginning 1) (match-end 1)))) - (setq lang2 - (ethio-flag-to-language - (buffer-substring (match-beginning 2) (match-end 2))))) - (setq ethio-primary-language lang1 - ethio-secondary-language lang2) - (delete-region (point) (match-end 2)) - (if (= (following-char) 32) - (delete-char 1)) - ethio-primary-language) - - ;; ~lang - ((and (looking-at "~\\([a-z][a-z][a-z]?\\)[ \t\n\\]") - (setq lang1 - (ethio-flag-to-language - (buffer-substring (match-beginning 1) (match-end 1))))) - (delete-region (point) (match-end 1)) - (if (= (following-char) 32) - (delete-char 1)) - lang1) - - ;; otherwise - (t - nil)))) - -(defun ethio-tilde-escape nil - "Handle a SERA tilde escape in Ethiopic section and delete it. -Delete the escape even it is not recognised." - - (let ((p (point)) command) - (skip-chars-forward "^ \t\n\\\\") - (setq command (buffer-substring p (point))) - (delete-region p (point)) - (if (= (following-char) 32) - (delete-char 1)) - - (cond - - ;; \~-: - ((string= command "-:") - (setq ethio-use-colon-for-colon t)) - - ;; \~`: - ((string= command "`:") - (setq ethio-use-colon-for-colon nil)) - - ;; \~? - ((string= command "?") - (setq ethio-use-three-dot-question nil)) - - ;; \~`| - ((string= command "`|") - (setq ethio-use-three-dot-question t)) - - ;; \~e - ((string= command "e") - (insert "$(3%j(B")) - - ;; \~E - ((string= command "E") - (insert "$(3%k(B")) - - ;; \~a - ((string= command "a") - (insert "$(3%l(B")) - - ;; \~A - ((string= command "A") - (insert "$(3%m(B")) - - ;; \~X - ((string= command "X") - (insert "$(3%i(B")) - - ;; unsupported tilde escape - (t - nil)))) - -(defun ethio-flag-to-language (flag) - (cond - ((or (string= flag "en") (string= flag "eng")) 'english) - ((or (string= flag "ti") (string= flag "tir")) 'tigrigna) - ((or (string= flag "am") (string= flag "amh")) 'amharic) - (t nil))) - -(defun ethio-convert-digit nil - "Convert Arabic digits to Ethiopic digits." - (let (ch z) - (while (and (>= (setq ch (following-char)) ?1) - (<= ch ?9)) - (delete-char 1) - - ;; count up following zeros - (setq z 0) - (while (= (following-char) ?0) - (delete-char 1) - (setq z (1+ z))) - - (cond - - ;; first digit is 10, 20, ..., or 90 - ((= (mod z 2) 1) - (insert (aref [?$(3$y(B ?$(3$z(B ?$(3${(B ?$(3$|(B ?$(3$}(B ?$(3$~(B ?$(3%!(B ?$(3%"(B ?$(3%#(B] (- ch ?1))) - (setq z (1- z))) - - ;; first digit is 2, 3, ..., or 9 - ((/= ch ?1) - (insert (aref [?$(3$q(B ?$(3$r(B ?$(3$s(B ?$(3$t(B ?$(3$u(B ?$(3$v(B ?$(3$w(B ?$(3$x(B] (- ch ?2)))) - - ;; single 1 - ((= z 0) - (insert "$(3$p(B"))) - - ;; 100 - (if (= (mod z 4) 2) - (insert "$(3%$(B")) - - ;; 10000 - (insert-char ?$(3%%(B (/ z 4))))) - -;;;###autoload -(defun ethio-sera-to-fidel-mail (&optional arg) - "Convert SERA to FIDEL to read/write mail and news. - -If the buffer contains the markers \"\" and \"\", -convert the segments between them into FIDEL. - -If invoked interactively and there is no marker, convert the subject field -and the body into FIDEL using `ethio-sera-to-fidel-region'." - - (interactive "p") - (let ((buffer-read-only nil) - border) - (save-excursion - - ;; look for the header-body separator - (goto-char (point-min)) - (if (search-forward - (if (eq major-mode 'rmail-mode) - "\n\n" (concat "\n" mail-header-separator "\n")) - nil t) - (setq border (point)) - (error "header separator not found")) - - ;; note that the point is placed at the border - (if (or (re-search-forward "^$" nil t) - (progn - (goto-char (point-min)) - (re-search-forward "^Subject: " border t))) - - ;; there are markers - (progn - ;; we start with the body so that the border will not change - ;; use "^\n" instead of "^$" not to leave a blank line - (goto-char border) - (while (re-search-forward "^\n" nil t) - (replace-match "") - (ethio-sera-to-fidel-region - (point) - (progn - (if (re-search-forward "^\n" nil 0) - (replace-match "")) - (point)))) - ;; now process the subject - (goto-char (point-min)) - (if (re-search-forward "^Subject: " border t) - (ethio-sera-to-fidel-region - (progn (delete-backward-char 6) (point)) - (progn - (if (re-search-forward "$" (line-end-position) 0) - (replace-match "")) - (point))))) - - ;; in case there are no marks but invoked interactively - (if arg - (progn - (ethio-sera-to-fidel-region border (point-max)) - (goto-char (point-min)) - (if (re-search-forward "^Subject: " border t) - (ethio-sera-to-fidel-region (point) (line-end-position)))))) - - ;; adjust the rmail marker - (if (eq major-mode 'rmail-mode) - (set-marker - (aref rmail-message-vector (1+ rmail-current-message)) - (point-max)))))) - -;;;###autoload -(defun ethio-sera-to-fidel-marker (&optional force) - "Convert the regions surrounded by \"\" and \"\" from SERA to FIDEL. -Assume that each region begins with `ethio-primary-language'. -The markers \"\" and \"\" themselves are not deleted." - (interactive "P") - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "" nil t) - (ethio-sera-to-fidel-region - (point) - (if (re-search-forward "" nil t) - (match-beginning 0) - (point-max)) - nil - 'force)))) - -;; -;; FIDEL to SERA -;; - -(defconst ethio-fidel-to-sera-map - [ "he" "hu" "hi" "ha" "hE" "h" "ho" "" ;; 0 - 7 - "le" "lu" "li" "la" "lE" "l" "lo" "lWa" ;; 8 - "He" "Hu" "Hi" "Ha" "HE" "H" "Ho" "HWa" ;; 16 - "me" "mu" "mi" "ma" "mE" "m" "mo" "mWa" ;; 24 - "`se" "`su" "`si" "`sa" "`sE" "`s" "`so" "`sWa" ;; 32 - "re" "ru" "ri" "ra" "rE" "r" "ro" "rWa" ;; 40 - "se" "su" "si" "sa" "sE" "s" "so" "sWa" ;; 48 - "xe" "xu" "xi" "xa" "xE" "x" "xo" "xWa" ;; 56 - "qe" "qu" "qi" "qa" "qE" "q" "qo" "" ;; 64 - "qWe" "" "qWi" "qWa" "qWE" "qW'" "" "" ;; 72 - "Qe" "Qu" "Qi" "Qa" "QE" "Q" "Qo" "" ;; 80 - "QWe" "" "QWi" "QWa" "QWE" "QW'" "" "" ;; 88 - "be" "bu" "bi" "ba" "bE" "b" "bo" "bWa" ;; 96 - "ve" "vu" "vi" "va" "vE" "v" "vo" "vWa" ;; 104 - "te" "tu" "ti" "ta" "tE" "t" "to" "tWa" ;; 112 - "ce" "cu" "ci" "ca" "cE" "c" "co" "cWa" ;; 120 - "`he" "`hu" "`hi" "`ha" "`hE" "`h" "`ho" "" ;; 128 - "hWe" "" "hWi" "hWa" "hWE" "hW'" "" "" ;; 136 - "ne" "nu" "ni" "na" "nE" "n" "no" "nWa" ;; 144 - "Ne" "Nu" "Ni" "Na" "NE" "N" "No" "NWa" ;; 152 - "e" "u" "i" "A" "E" "I" "o" "ea" ;; 160 - "ke" "ku" "ki" "ka" "kE" "k" "ko" "" ;; 168 - "kWe" "" "kWi" "kWa" "kWE" "kW'" "" "" ;; 176 - "Ke" "Ku" "Ki" "Ka" "KE" "K" "Ko" "" ;; 184 - "KWe" "" "KWi" "KWa" "KWE" "KW'" "" "" ;; 192 - "we" "wu" "wi" "wa" "wE" "w" "wo" "" ;; 200 - "`e" "`u" "`i" "`a" "`E" "`I" "`o" "" ;; 208 - "ze" "zu" "zi" "za" "zE" "z" "zo" "zWa" ;; 216 - "Ze" "Zu" "Zi" "Za" "ZE" "Z" "Zo" "ZWa" ;; 224 - "ye" "yu" "yi" "ya" "yE" "y" "yo" "yWa" ;; 232 - "de" "du" "di" "da" "dE" "d" "do" "dWa" ;; 240 - "De" "Du" "Di" "Da" "DE" "D" "Do" "DWa" ;; 248 - "je" "ju" "ji" "ja" "jE" "j" "jo" "jWa" ;; 256 - "ge" "gu" "gi" "ga" "gE" "g" "go" "" ;; 264 - "gWe" "" "gWi" "gWa" "gWE" "gW'" "" "" ;; 272 - "Ge" "Gu" "Gi" "Ga" "GE" "G" "Go" "GWa" ;; 280 - "Te" "Tu" "Ti" "Ta" "TE" "T" "To" "TWa" ;; 288 - "Ce" "Cu" "Ci" "Ca" "CE" "C" "Co" "CWa" ;; 296 - "Pe" "Pu" "Pi" "Pa" "PE" "P" "Po" "PWa" ;; 304 - "Se" "Su" "Si" "Sa" "SE" "S" "So" "SWa" ;; 312 - "`Se" "`Su" "`Si" "`Sa" "`SE" "`S" "`So" "" ;; 320 - "fe" "fu" "fi" "fa" "fE" "f" "fo" "fWa" ;; 328 - "pe" "pu" "pi" "pa" "pE" "p" "po" "pWa" ;; 336 - "mYa" "rYa" "fYa" "" "" "" "" "" ;; 344 - " " " : " "::" "," ";" "-:" ":-" "`?" ;; 352 - ":|:" "1" "2" "3" "4" "5" "6" "7" ;; 360 - "8" "9" "10" "20" "30" "40" "50" "60" ;; 368 - "70" "80" "90" "100" "10000" "" "" "" ;; 376 - "`qe" "`qu" "`qi" "`qa" "`qE" "`q" "`qo" "" ;; 384 - "mWe" "bWe" "GWe" "fWe" "pWe" "" "" "" ;; 392 - "`ke" "`ku" "`ki" "`ka" "`kE" "`k" "`ko" "" ;; 400 - "mWi" "bWi" "GWi" "fWi" "pWi" "" "" "" ;; 408 - "Xe" "Xu" "Xi" "Xa" "XE" "X" "Xo" "" ;; 416 - "mWE" "bWE" "GWE" "fWE" "pWE" "" "" "" ;; 424 - "`ge" "`gu" "`gi" "`ga" "`gE" "`g" "`go" "" ;; 432 - "mW'" "bW'" "GW'" "fW'" "pW'" "" "" "" ;; 440 - "\\~X " "\\~e " "\\~E " "\\~a " "\\~A " "wWe" "wWi" "wWa" ;; 448 - "wWE" "wW'" "''" "`!" "." "<<" ">>" "?" ]) ;; 456 - -(defun ethio-prefer-amharic-p nil - (or (eq ethio-primary-language 'amharic) - (and (not (eq ethio-primary-language 'tigrigna)) - (eq ethio-secondary-language 'amharic)))) - -(defun ethio-language-to-flag (lang) - (cond - ((eq lang 'english) "eng") - ((eq lang 'tigrigna) "tir") - ((eq lang 'amharic) "amh") - (t ""))) - -;;;###autoload -(defun ethio-fidel-to-sera-region (begin end &optional secondary force) - "Replace all the FIDEL characters in the region to the SERA format. -The variable `ethio-primary-language' specifies the primary -language and `ethio-secondary-language' specifies the secondary. - -If the 3dr parameter SECONDARY is given and non-nil, try to convert -the region so that it begins in the secondary language; otherwise with -the primary language. - -If the 4th parameter FORCE is given and non-nil, convert even if the -buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon', `ethio-use-three-dot-question', -`ethio-quote-vowel-always' and `ethio-numeric-reduction'." - - (interactive "r\nP") - (save-restriction - (narrow-to-region begin end) - (ethio-fidel-to-sera-buffer secondary force))) - -;;;###autoload -(defun ethio-fidel-to-sera-buffer (&optional secondary force) - "Replace all the FIDEL characters in the current buffer to the SERA format. -The variable `ethio-primary-language' specifies the primary -language and `ethio-secondary-language' specifies the secondary. - -If the 1st optional parameter SECONDARY is non-nil, try to convert the -region so that it begins in the secondary language; otherwise with the -primary language. - -If the 2nd optional parameter FORCE is non-nil, convert even if the -buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon', `ethio-use-three-dot-question', -`ethio-quote-vowel-always' and `ethio-numeric-reduction'." - - (interactive "P") - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - - (let ((buffer-read-only nil) - (case-fold-search nil) - (lonec nil) ;; t means previous char was a lone consonant - (fidel nil) ;; t means previous char was a FIDEL - (digit nil) ;; t means previous char was an Ethiopic digit - (flag (if (ethio-prefer-amharic-p) "\\~amh " "\\~tir ")) - mode ch) - - ;; user's preference in transcription - (if ethio-use-colon-for-colon - (progn - (aset ethio-fidel-to-sera-map 353 "`:") - (aset ethio-fidel-to-sera-map 357 ":")) - (aset ethio-fidel-to-sera-map 353 " : ") - (aset ethio-fidel-to-sera-map 357 "-:")) - - (if ethio-use-three-dot-question - (progn - (aset ethio-fidel-to-sera-map 359 "?") - (aset ethio-fidel-to-sera-map 463 "`?")) - (aset ethio-fidel-to-sera-map 359 "`?") - (aset ethio-fidel-to-sera-map 463 "?")) - - (mapcar - '(lambda (x) - (aset (aref ethio-fidel-to-sera-map x) - 2 - (if ethio-W-sixth-always ?' ?u))) - '(77 93 141 181 197 277 440 441 442 443 444 457)) - - (if (ethio-prefer-amharic-p) - (aset ethio-fidel-to-sera-map 160 "a") - (aset ethio-fidel-to-sera-map 160 "e")) - ;; end of user's preference - - ;; first, decompose geminated characters - (decompose-region (point-min) (point-max)) - - ;; main conversion routine - (goto-char (point-min)) - (while (not (eobp)) - (setq ch (following-char)) - - (cond ; ethiopic, english, neutral - - ;; ethiopic character. must go to ethiopic mode, if not in it. - ((eq (char-charset ch) 'ethiopic) - (setq ch (ethio-char-to-ethiocode ch)) - (delete-char 1) - (if (not (eq mode 'ethiopic)) - (progn - (insert flag) - (setq mode 'ethiopic))) - - (cond ; fidel, punc, digit - - ;; fidels - ((or (<= ch 346) ; he - fYa - (and (>= ch 384) (<= ch 444)) ; `qe - pw - (and (>= ch 453) (<= ch 457))) ; wWe - wW - (if (and (memq ch '(160 161 162 163 164 166 167)) ; (e - ea) - (or lonec - (and ethio-quote-vowel-always - fidel))) - (insert "'")) - (insert (aref ethio-fidel-to-sera-map ch)) - (setq lonec (ethio-lone-consonant-p ch) - fidel t - digit nil)) - - ;; punctuations or icons - ((or (and (>= ch 353) (<= ch 360)) ; : - :|: - (>= ch 458) ; '' - ? - (and (>= ch 448) (<= ch 452))) ; \~X \~e \~E \~a \~A - (insert (aref ethio-fidel-to-sera-map ch)) - (setq lonec nil - fidel nil - digit nil)) - - ;; now CH must be an ethiopic digit - - ;; reduction = 0 or not preceded by Ethiopic number(s) - ((or (= ethio-numeric-reduction 0) - (not digit)) - (insert "`" (aref ethio-fidel-to-sera-map ch)) - (setq lonec nil - fidel nil - digit t)) - - ;; reduction = 2 and following 10s, 100s, 10000s - ((and (= ethio-numeric-reduction 2) - (memq ch '(370 379 380))) - (insert (substring (aref ethio-fidel-to-sera-map ch) 1)) - (setq lonec nil - fidel nil - digit t)) - - ;; ordinary following digits - (t - (insert (aref ethio-fidel-to-sera-map ch)) - (setq lonec nil - fidel nil - digit t)))) - - ;; english character. must go to english mode, if not in it. - ((or (and (>= ch ?a) (<= ch ?z)) - (and (>= ch ?A) (<= ch ?Z))) - (if (not (eq mode 'english)) - (insert "\\~eng ")) - (forward-char 1) - (setq mode 'english - lonec nil - fidel nil - digit nil)) - - ;; ch can appear both in ethiopic section and in english section. - (t - - ;; we must decide the mode, if not decided yet - (if (null mode) - (progn - (setq mode - (if secondary - ethio-secondary-language - ethio-primary-language)) - (if (eq mode 'english) - (insert "\\~eng ") - (insert flag) - (setq mode 'ethiopic)))) ; tigrigna & amharic --> ethiopic - - (cond ; \ , eng-mode , punc , w3 , other - - ;; backslash is always quoted - ((= ch ?\\ ) - (insert "\\") - (forward-char 1)) - - ;; nothing to do if in english mode - ((eq mode 'english) - (forward-char 1)) - - ;; now we must be in ethiopic mode and seeing a non-"\" - - ;; ascii punctuations in ethiopic mode - ((looking-at "[,.;:'`?]+") - (insert "\\") - (goto-char (1+ (match-end 0)))) ; because we inserted one byte (\) - - ;; skip from "<" to ">" (or from "&" to ";") if called from w3 - ((and (boundp 'sera-being-called-by-w3) - sera-being-called-by-w3 - (or (= ch ?<) (= ch ?&))) - (search-forward (if (= ch ?<) ">" ";") - nil 0)) - - ;; neutral character. no need to quote. just skip it. - (t - (forward-char 1))) - - (setq lonec nil - fidel nil - digit nil))) - ;; end of main conversion routine - ))) - -(defun ethio-lone-consonant-p (ethiocode) - "If ETHIOCODE is an Ethiopic lone consonant, return t." - (or (and (< ethiocode 344) (= (% ethiocode 8) 5)) - - ;; `q `k X `g mW bW GW fW pW wW - (memq ethiocode '(389 405 421 437 440 441 442 443 444 457)))) - -;;;###autoload -(defun ethio-fidel-to-sera-mail nil - "Convert FIDEL to SERA to read/write mail and news. - -If the body contains at least one Ethiopic character, - 1) insert the string \"\" at the beginning of the body, - 2) insert \"\" at the end of the body, and - 3) convert the body into SERA. - -The very same procedure applies to the subject field, too." - - (interactive) - (let ((buffer-read-only nil) - border) - (save-excursion - - ;; look for the header-body separator - (goto-char (point-min)) - (if (search-forward - (if (eq major-mode 'rmail-mode) - "\n\n" (concat "\n" mail-header-separator "\n")) - nil t) - (setq border (point)) - (error "header separator not found")) - - ;; process body first not to change the border - ;; note that the point is already at the border - (if (re-search-forward "\\ce" nil t) - (progn - (ethio-fidel-to-sera-region border (point-max)) - (goto-char border) - (insert "") - (goto-char (point-max)) - (insert ""))) - - ;; process subject - (goto-char (point-min)) - (if (re-search-forward "^Subject: " border t) - (let ((beg (point)) - (end (line-end-position))) - (if (re-search-forward "\\ce" end t) - (progn - (ethio-fidel-to-sera-region beg end) - (goto-char beg) - (insert "") - (end-of-line) - (insert ""))))) - - ;; adjust the rmail marker - (if (eq major-mode 'rmail-mode) - (set-marker - (aref rmail-message-vector (1+ rmail-current-message)) - (point-max)))))) - -;;;###autoload -(defun ethio-fidel-to-sera-marker (&optional force) - "Convert the regions surrounded by \"\" and \"\" from FIDEL to SERA. -The markers \"\" and \"\" themselves are not deleted." - - (interactive "P") - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "" nil t) - (ethio-fidel-to-sera-region - (point) - (if (re-search-forward "" nil t) - (match-beginning 0) - (point-max)) - nil - 'force)))) - -;; -;; vowel modification -;; - -;;;###autoload -(defun ethio-modify-vowel nil - "Modify the vowel of the FIDEL that is under the cursor." - (interactive) - (let ((ch (following-char)) - (composite nil) ; geminated or not - newch base vowel modulo) - - (cond - ;; in case of gemination - ((eq (char-charset ch) 'composition) - (setq ch (string-to-char (decompose-composite-char ch)) - composite t)) - ;; neither gemination nor fidel - ((not (eq (char-charset ch) 'ethiopic)) - (error "Not a valid character."))) - - ;; set frequently referred character features - (setq ch (ethio-char-to-ethiocode ch) - base (* (/ ch 8) 8) - modulo (% ch 8)) - - (if (or (and (>= ch 344) (<= ch 380)) ;; mYa - `10000 - (and (>= ch 448) (<= ch 452)) ;; \~X - \~A - (>= ch 458)) ;; private punctuations - (error "Not a valid character.")) - - (setq - newch - (cond - - ;; first standalone vowels - ((= base 160) - (if (ethio-prefer-amharic-p) - (message "Modify vowel to: [auiAEIoW\"] ") - (message "Modify vowel to: [euiAEIoW\"] ")) - (setq vowel (read-char)) - (cond - ((= vowel ?e) 160) - ((= vowel ?u) 161) - ((= vowel ?i) 162) - ((= vowel ?A) 163) - ((= vowel ?E) 164) - ((= vowel ?I) 165) - ((= vowel ?o) 166) - ((= vowel ?W) 167) - ((= vowel ?a) (if (ethio-prefer-amharic-p) 160 163)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; second standalone vowels - ((= base 208) - (message "Modify vowel to: [euiaEIo\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 208) - ((= vowel ?u) 209) - ((= vowel ?i) 210) - ((= vowel ?a) 211) - ((= vowel ?E) 212) - ((= vowel ?I) 213) - ((= vowel ?o) 214) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; 12-form consonants, *W* form - ((memq base '(72 88 136 176 192 272)) ; qW QW hW kW KW gW - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) base) - ((= vowel ?u) (+ base 5)) - ((= vowel ?i) (+ base 2)) - ((= vowel ?a) (+ base 3)) - ((= vowel ?E) (+ base 4)) - ((= vowel ?') (+ base 5)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; extended 12-form consonants, mWa bWa GWa fWa pWa - ((= ch 31) ; mWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 392) - ((= vowel ?u) 440) - ((= vowel ?i) 408) - ((= vowel ?a) ch) - ((= vowel ?E) 424) - ((= vowel ?') 440) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 103) ; bWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 393) - ((= vowel ?u) 441) - ((= vowel ?i) 409) - ((= vowel ?a) ch) - ((= vowel ?E) 425) - ((= vowel ?') 441) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 287) ; GWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 394) - ((= vowel ?u) 442) - ((= vowel ?i) 410) - ((= vowel ?a) ch) - ((= vowel ?E) 426) - ((= vowel ?') 442) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 335) ; fWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 395) - ((= vowel ?u) 443) - ((= vowel ?i) 411) - ((= vowel ?a) ch) - ((= vowel ?E) 427) - ((= vowel ?') 443) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 343) ; pWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 396) - ((= vowel ?u) 444) - ((= vowel ?i) 412) - ((= vowel ?a) ch) - ((= vowel ?E) 428) - ((= vowel ?') 444) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; extended 12-form consonatns, mW* bW* GW* fW* pW* - ((memq base '(392 408 424 440)) ; *We *Wi *WE *W - (message "Modify vowel to: [eiEau'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) (+ 392 modulo)) - ((= vowel ?i) (+ 408 modulo)) - ((= vowel ?E) (+ 424 modulo)) - ((= vowel ?a) (cond - ((= modulo 0) 31) ; mWa - ((= modulo 1) 103) ; bWa - ((= modulo 2) 287) ; GWa - ((= modulo 3) 335) ; fWa - ((= modulo 4) 343) ; pWa - (t nil))) ; never reach here - ((= vowel ?') (+ 440 modulo)) - ((= vowel ?u) (+ 440 modulo)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ((and (>= ch 453) (<= ch 457)) ; wWe wWi wWa wWE wW - (message "Modify vowel to: [eiaE'u\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 453) - ((= vowel ?i) 454) - ((= vowel ?a) 455) - ((= vowel ?E) 456) - ((= vowel ?') 457) - ((= vowel ?u) 457) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; 7-form consonants, or - ;; first 7 of 8-form consonants - ((<= modulo 6) - (message "Modify vowel to: [euiaE'o\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) base) - ((= vowel ?u) (+ base 1)) - ((= vowel ?i) (+ base 2)) - ((= vowel ?a) (+ base 3)) - ((= vowel ?E) (+ base 4)) - ((= vowel ?') (+ base 5)) - ((= vowel ?o) (+ base 6)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; otherwise - (t - nil))) - - (cond - - ;; could not get new character - ((null newch) - (error "Invalid vowel")) - - ;; vowel changed on a composite Fidel - (composite - (delete-char 1) - (insert - (compose-string - (concat (char-to-string (ethio-ethiocode-to-char newch)) "$(3%s(B")))) - - ;; simple vowel modification - (t - (delete-char 1) - (insert (ethio-ethiocode-to-char newch)))))) - -(defun ethio-ethiocode-to-char (ethiocode) - (make-char - 'ethiopic - (+ (/ ethiocode 94) 33) - (+ (mod ethiocode 94) 33))) - -(defun ethio-char-to-ethiocode (ch) - (and (eq (char-charset ch) 'ethiopic) - (let ((char-components (split-char ch))) - (+ (* (- (nth 1 char-components) 33) 94) - (- (nth 2 char-components) 33))))) - -;; -;; space replacement -;; - -;;;###autoload -(defun ethio-replace-space (ch begin end) - "Replace ASCII spaces with Ethiopic word separators in the region. - -In the specified region, replace word separators surrounded by two -Ethiopic characters, depending on the first parameter CH, which should -be 1, 2, or 3. - -If CH = 1, word separator will be replaced with an ASCII space. -If CH = 2, with two ASCII spaces. -If CH = 3, with the Ethiopic colon-like word separator. - -The second and third parameters BEGIN and END specify the region." - - (interactive "*cReplace spaces to: 1 (sg col), 2 (dbl col), 3 (Ethiopic)\nr") - (if (not (memq ch '(?1 ?2 ?3))) - (error "")) - (save-excursion - (save-restriction - (narrow-to-region begin end) - - (cond - ((= ch ?1) - ;; an Ethiopic word separator --> an ASCII space - (goto-char (point-min)) - (while (search-forward "$(3$h(B" nil t) - (replace-match " " nil t)) - - ;; two ASCII spaces between Ethiopic characters --> an ASCII space - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) \\(\\ce\\)" nil t) - (replace-match "\\1 \\2") - (goto-char (match-beginning 2)))) - - ((= ch ?2) - ;; An Ethiopic word separator --> two ASCII spaces - (goto-char (point-min)) - (while (search-forward "$(3$h(B" nil t) - (replace-match " ")) - - ;; An ASCII space between Ethiopic characters --> two ASCII spaces - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) \\(\\ce\\)" nil t) - (replace-match "\\1 \\2") - (goto-char (match-beginning 2)))) - - (t - ;; One or two ASCII spaces between Ethiopic characters - ;; --> An Ethiopic word separator - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) ?\\(\\ce\\)" nil t) - (replace-match "\\1$(3$h(B\\2") - (goto-char (match-beginning 2))) - - ;; Three or more ASCII spaces between Ethiopic characters - ;; --> An Ethiopic word separator + (N - 2) ASCII spaces - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) \\( *\\ce\\)" nil t) - (replace-match "\\1$(3$h(B\\2") - (goto-char (match-beginning 2)))))))) - -;; -;; special icons -;; - -;;;###autoload -(defun ethio-input-special-character (arg) - "Allow the user to input special characters." - (interactive "*cInput number: 1.$(3%j(B 2.$(3%k(B 3.$(3%l(B 4.$(3%m(B 5.$(3%i(B") - (cond - ((= arg ?1) - (insert "$(3%j(B")) - ((= arg ?2) - (insert "$(3%k(B")) - ((= arg ?3) - (insert "$(3%l(B")) - ((= arg ?4) - (insert "$(3%m(B")) - ((= arg ?5) - (insert "$(3%i(B")) - (t - (error "")))) - -;; -;; TeX support -;; - -(defconst ethio-fidel-to-tex-map - [ "heG" "huG" "hiG" "haG" "hEG" "hG" "hoG" "" ;; 0 - 7 - "leG" "luG" "liG" "laG" "lEG" "lG" "loG" "lWaG" ;; 8 - "HeG" "HuG" "HiG" "HaG" "HEG" "HG" "HoG" "HWaG" ;; 16 - "meG" "muG" "miG" "maG" "mEG" "mG" "moG" "mWaG" ;; 24 - "sseG" "ssuG" "ssiG" "ssaG" "ssEG" "ssG" "ssoG" "ssWaG" ;; 32 - "reG" "ruG" "riG" "raG" "rEG" "rG" "roG" "rWaG" ;; 40 - "seG" "suG" "siG" "saG" "sEG" "sG" "soG" "sWaG" ;; 48 - "xeG" "xuG" "xiG" "xaG" "xEG" "xG" "xoG" "xWaG" ;; 56 - "qeG" "quG" "qiG" "qaG" "qE" "qG" "qoG" "" ;; 64 - "qWeG" "" "qWi" "qWaG" "qWEG" "qWG" "" "" ;; 72 - "QeG" "QuG" "QiG" "QaG" "QEG" "QG" "QoG" "" ;; 80 - "QWeG" "" "QWiG" "QWaG" "QWEG" "QWG" "" "" ;; 88 - "beG" "buG" "biG" "baG" "bEG" "bG" "boG" "bWaG" ;; 96 - "veG" "vuG" "viG" "vaG" "vEG" "vG" "voG" "vWaG" ;; 104 - "teG" "tuG" "tiG" "taG" "tEG" "tG" "toG" "tWaG" ;; 112 - "ceG" "cuG" "ciG" "caG" "cEG" "cG" "coG" "cWaG" ;; 120 - "hheG" "hhuG" "hhiG" "hhaG" "hhEG" "hhG" "hhoG" "" ;; 128 - "hWeG" "" "hWiG" "hWaG" "hWEG" "hWG" "" "" ;; 136 - "neG" "nuG" "niG" "naG" "nEG" "nG" "noG" "nWaG" ;; 144 - "NeG" "NuG" "NiG" "NaG" "NEG" "NG" "NoG" "NWaG" ;; 152 - "eG" "uG" "iG" "AG" "EG" "IG" "oGG" "eaG" ;; 160 - "keG" "kuG" "kiG" "kaG" "kEG" "kG" "koG" "" ;; 168 - "kWeG" "" "kWiG" "kWa" "kWEG" "kWG" "" "" ;; 176 - "KeG" "KuG" "KiG" "KaG" "KEG" "KG" "KoG" "" ;; 184 - "KWeG" "" "KWiG" "KWa" "KWEG" "KWG" "" "" ;; 192 - "weG" "wuG" "wiG" "waG" "wEG" "wG" "woG" "" ;; 200 - "eeG" "uuG" "iiG" "aaG" "EEG" "IIG" "ooG" "" ;; 208 - "zeG" "zuG" "ziG" "zaG" "zEG" "zG" "zoG" "zWaG" ;; 216 - "ZeG" "ZuG" "ZiG" "ZaG" "ZEG" "ZG" "ZoG" "ZWaG" ;; 224 - "yeG" "yuG" "yiG" "yaG" "yEG" "yG" "yoG" "yWaG" ;; 232 - "deG" "duG" "diG" "daG" "dEG" "dG" "doG" "dWaG" ;; 240 - "DeG" "DuG" "DiG" "DaG" "DEG" "DG" "DoG" "DWaG" ;; 248 - "jeG" "juG" "jiG" "jaG" "jEG" "jG" "joG" "jWaG" ;; 256 - "geG" "guG" "giG" "gaG" "gEG" "gG" "goG" "" ;; 264 - "gWeG" "" "gWiG" "gWaG" "gWEG" "gWG" "" "" ;; 272 - "GeG" "GuG" "GiG" "GaG" "GEG" "GG" "GoG" "GWaG" ;; 280 - "TeG" "TuG" "TiG" "TaG" "TEG" "TG" "ToG" "TWaG" ;; 288 - "CeG" "CuG" "CiG" "CaG" "CEG" "CG" "CoG" "CWaG" ;; 296 - "PeG" "PuG" "PiG" "PaG" "PEG" "PG" "PoG" "PWaG" ;; 304 - "SeG" "SuG" "SiG" "SaG" "SEG" "SG" "SoG" "SWaG" ;; 312 - "SSeG" "SSuG" "SSiG" "SSaG" "SSEG" "SSG" "SSoG" "" ;; 320 - "feG" "fuG" "fiG" "faG" "fEG" "fG" "foG" "fWaG" ;; 328 - "peG" "puG" "piG" "paG" "pEG" "pG" "poG" "pWaG" ;; 336 - "mYaG" "rYaG" "fYaG" "" "" "" "" "" ;; 344 - "" "spaceG" "periodG" "commaG" ;; 352 - "semicolonG" "colonG" "precolonG" "oldqmarkG" ;; 356 - "pbreakG" "andG" "huletG" "sostG" "aratG" "amstG" "sadstG" "sabatG" ;; 360 - "smntG" "zeteNG" "asrG" "heyaG" "selasaG" "arbaG" "hemsaG" "slsaG" ;; 368 - "sebaG" "semanyaG" "zeTanaG" "metoG" "asrxiG" "" "" "" ;; 376 - "qqeG" "qquG" "qqiG" "qqaG" "qqEG" "qqG" "qqoG" "" ;; 384 - "mWeG" "bWeG" "GWeG" "fWeG" "pWeG" "" "" "" ;; 392 - "kkeG" "kkuG" "kkiG" "kkaG" "kkEG" "kkG" "kkoG" "" ;; 400 - "mWiG" "bWiG" "GWiG" "fWiG" "pWiG" "" "" "" ;; 408 - "XeG" "XuG" "GXiG" "XaG" "XEG" "XG" "XoG" "" ;; 416 - "mWEG" "bWEG" "GWEG" "fWEG" "pWEG" "" "" "" ;; 424 - "ggeG" "gguG" "ggiG" "ggaG" "ggEG" "ggG" "ggoG" "" ;; 432 - "mWG" "bWG" "GWG" "fWG" "pWG" "" "" "" ;; 440 - "ornamentG" "flandG" "iflandG" "africaG" ;; 448 - "iafricaG" "wWeG" "wWiG" "wWaG" ;; 452 - "wWEG" "wWG" "" "slaqG" "dotG" "lquoteG" "rquoteG" "qmarkG" ]) ;; 456 - -;; -;; To make tex-to-fidel mapping. -;; The following code makes -;; (get 'ethio-tex-command-he 'ethio-fidel-char) ==> ?$(3!!(B -;; etc. -;; - -(let ((i 0) str) - (while (< i (length ethio-fidel-to-tex-map)) - (setq str (aref ethio-fidel-to-tex-map i)) - (if (not (string= str "")) - (put - (intern (concat "ethio-tex-command-" (aref ethio-fidel-to-tex-map i))) - 'ethio-fidel-char - (ethio-ethiocode-to-char i))) - (setq i (1+ i)))) - -;;;###autoload -(defun ethio-fidel-to-tex-buffer nil - "Convert each fidel characters in the current buffer into a fidel-tex command. -Each command is always surrounded by braces." - (interactive) - (let ((buffer-read-only nil)) - - ;; Isolated gemination marks need special treatement - (goto-char (point-min)) - (while (search-forward "$(3%s(B" nil t) - (replace-match "\\geminateG{}" t t)) - - ;; First, decompose geminations - ;; Here we assume that each composed character consists of - ;; one Ethiopic character and the Ethiopic gemination mark. - (decompose-region (point-min) (point-max)) - - ;; Special treatment for geminated characters - ;; The geminated character (la'') will be "\geminateG{\la}". - (goto-char (point-min)) - (while (search-forward "$(3%s(B" nil t) - (delete-backward-char 1) - (backward-char 1) - (insert "\\geminateG") - (forward-char 1)) - - ;; Ethiopic characters to TeX macros - (goto-char (point-min)) - (while (re-search-forward "\\ce" nil t) - (insert - "{\\" - (aref ethio-fidel-to-tex-map - (prog1 (ethio-char-to-ethiocode (preceding-char)) - (backward-delete-char 1))) - "}")) - (goto-char (point-min)) - (set-buffer-modified-p nil))) - -;;;###autoload -(defun ethio-tex-to-fidel-buffer nil - "Convert fidel-tex commands in the current buffer into fidel chars." - (interactive) - (let ((buffer-read-only nil) - (p) (ch)) - - ;; Special treatment for gemination - ;; "\geminateG{\la}" or "\geminateG{{\la}}" will be "\la$(3%s(B" - ;; "\geminateG{}" remains unchanged. - (goto-char (point-min)) - (while (re-search-forward "\\\\geminateG{\\(\\\\[a-zA-Z]+\\)}" nil t) - (replace-match "\\1$(3%s(B")) - - ;; TeX macros to Ethiopic characters - (goto-char (point-min)) - (while (search-forward "\\" nil t) - (setq p (point)) - (skip-chars-forward "a-zA-Z") - (setq ch - (get (intern (concat "ethio-tex-command-" - (buffer-substring p (point)))) - 'ethio-fidel-char)) - (if ch - (progn - (delete-region (1- p) (point)) ; don't forget the preceding "\" - (if (and (= (preceding-char) ?{) - (= (following-char) ?})) - (progn - (backward-delete-char 1) - (delete-char 1))) - (insert ch)))) - - ;; compose geminated characters - (goto-char (point-min)) - (while (re-search-forward "\\ce$(3%s(B" nil 0) - (compose-region - (save-excursion (backward-char 2) (point)) - (point))) - - ;; Now it's time to convert isolated gemination marks. - (goto-char (point-min)) - (while (search-forward "\\geminateG{}" nil t) - (replace-match "$(3%s(B")) - - (goto-char (point-min)) - (set-buffer-modified-p nil))) - -;; -;; Java support -;; - -;;;###autoload -(defun ethio-fidel-to-java-buffer nil - "Convert Ethiopic characters into the Java escape sequences. - -Each escape sequence is of the form \uXXXX, where XXXX is the -character's codepoint (in hex) in Unicode. - -If `ethio-java-save-lowercase' is non-nil, use [0-9a-f]. -Otherwise, [0-9A-F]." - (let ((ucode)) - - ;; first, decompose geminations - (decompose-region (point-min) (point-max)) - - (goto-char (point-min)) - (while (re-search-forward "\\ce" nil t) - (setq ucode (+ ?\x1200 (ethio-char-to-ethiocode (preceding-char)))) - (if (> ucode ?\x13bc) - (setq ucode (+ ucode 59952))) - (delete-backward-char 1) - (if ethio-java-save-lowercase - (insert (format "\\u%4x" ucode)) - (insert (upcase (format "\\u%4x" ucode))))))) - -;;;###autoload -(defun ethio-java-to-fidel-buffer nil - "Convert the Java escape sequences into corresponding Ethiopic characters." - (let ((ucode)) - (goto-char (point-min)) - (while (re-search-forward "\\\\u\\([0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]\\)" nil t) - (setq ucode - (read - (concat - "?\\x" - (buffer-substring (match-beginning 1) (match-end 1))))) - (cond - ((and (>= ucode ?\x1200) (<= ucode ?\x13bc)) - (replace-match "") - (insert (ethio-ethiocode-to-char (- ucode ?\x1200)))) - ((and (>= ucode ?\xfdf1) (<= ucode ?\xfdff)) - (replace-match "") - (insert (ethio-ethiocode-to-char (- ucode 64560)))) - (t - nil))) - - ;; gemination - (goto-char (point-min)) - (while (re-search-forward "\\ce$(3%s(B" nil 0) - (compose-region - (save-excursion (backward-char 2) (point)) - (point))) - )) - -;; -;; file I/O hooks -;; - -;;;###autoload -(defun ethio-find-file nil - "Transcribe file content into Ethiopic dependig on filename suffix." - (cond - - ((string-match "\\.sera$" (buffer-file-name)) - (save-excursion - (ethio-sera-to-fidel-buffer nil 'force) - (set-buffer-modified-p nil))) - - ((string-match "\\.html$" (buffer-file-name)) - (let ((sera-being-called-by-w3 t)) - (save-excursion - (ethio-sera-to-fidel-marker 'force) - (goto-char (point-min)) - (while (re-search-forward "&[lr]aquote;" nil t) - (if (= (char-after (1+ (match-beginning 0))) ?l) - (replace-match "$(3%v(B") - (replace-match "$(3%w(B"))) - (set-buffer-modified-p nil)))) - - ((string-match "\\.tex$" (buffer-file-name)) - (save-excursion - (ethio-tex-to-fidel-buffer) - (set-buffer-modified-p nil))) - - ((string-match "\\.java$" (buffer-file-name)) - (save-excursion - (ethio-java-to-fidel-buffer) - (set-buffer-modified-p nil))) - - (t - nil))) - -;;;###autoload -(defun ethio-write-file nil - "Transcribe Ethiopic characters in ASCII depending on the file extension." - (cond - - ((string-match "\\.sera$" (buffer-file-name)) - (save-excursion - (ethio-fidel-to-sera-buffer nil 'force) - (goto-char (point-min)) - (ethio-record-user-preference) - (set-buffer-modified-p nil))) - - ((string-match "\\.html$" (buffer-file-name)) - (save-excursion - (let ((sera-being-called-by-w3 t) - (lq (aref ethio-fidel-to-sera-map 461)) - (rq (aref ethio-fidel-to-sera-map 462))) - (aset ethio-fidel-to-sera-map 461 "«te;") - (aset ethio-fidel-to-sera-map 462 "»te;") - (ethio-fidel-to-sera-marker 'force) - (goto-char (point-min)) - (if (search-forward "" nil t) - (ethio-record-user-preference)) - (aset ethio-fidel-to-sera-map 461 lq) - (aset ethio-fidel-to-sera-map 462 rq) - (set-buffer-modified-p nil)))) - - ((string-match "\\.tex$" (buffer-file-name)) - (save-excursion - (ethio-fidel-to-tex-buffer) - (set-buffer-modified-p nil))) - - ((string-match "\\.java$" (buffer-file-name)) - (save-excursion - (ethio-fidel-to-java-buffer) - (set-buffer-modified-p nil))) - - (t - nil))) - -(defun ethio-record-user-preference nil - (if (looking-at "\\\\~\\(tir?\\|amh?\\) ") - (goto-char (match-end 0)) - (insert (if (ethio-prefer-amharic-p) "\\~amh " "\\~tir "))) - (insert (if ethio-use-colon-for-colon "\\~-: " "\\~`: ") - (if ethio-use-three-dot-question "\\~`| " "\\~`? "))) - -(add-hook 'find-file-hooks 'ethio-find-file) -(add-hook 'write-file-hooks 'ethio-write-file) -(add-hook 'after-save-hook 'ethio-find-file) - -;; -(provide 'language/ethio-util) - -;;; Local Variables: -;;; generated-autoload-file: "../loaddefs.el" -;;; End: -;;; ethio-util.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/ethiopic.el --- a/lisp/language/ethiopic.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -;;; ethiopic.el --- Support for Ethiopic - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Keywords: multilingual, Ethiopic - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;; Author: TAKAHASHI Naoto -;; modified by MORIOKA Tomohiko for XEmacs. - -;;; Code: - -;; Ethiopic -(make-charset 'ethiopic "Ethiopic" - '(registry "Ethio" - dimension 2 - chars 94 - final ?3 - graphic 0 - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ETHIOPIC -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-category ?E "Ethiopic (Ge'ez) character.") -(modify-category-entry 'ethiopic ?E) - -;; (define-ccl-program ccl-encode-ethio-font -;; '(0 -;; ;; In: R0:ethiopic (not checked) -;; ;; R1:position code 1 -;; ;; R2:position code 2 -;; ;; Out: R1:font code point 1 -;; ;; R2:font code point 2 -;; ((r1 -= 33) -;; (r2 -= 33) -;; (r1 *= 94) -;; (r2 += r1) -;; (if (r2 < 256) -;; (r1 = ?\x12) -;; (if (r2 < 448) -;; ((r1 = ?\x13) (r2 -= 256)) -;; ((r1 = ?\xfd) (r2 -= 208)) -;; )))) -;; "CCL program to encode an Ehitopic code to code point of Ehitopic font.") -(define-ccl-program ccl-encode-ethio-font - '(((r0 -= #x21) - (r1 -= #x21) - (r0 *= 94) - (r1 += r0) - (if (r1 < 256) (r0 = 0) ((r1 -= 256) (r0 = 1)))))) - -;; (setq font-ccl-encoder-alist -;; (cons (cons "ethiopic" ccl-encode-ethio-font) font-ccl-encoder-alist)) -(set-charset-ccl-program 'ethiopic ccl-encode-ethio-font) - -(register-input-method - "Ethiopic" '("quail-ethio" quail-use-package "quail/ethiopic")) - -(defun setup-ethiopic-environment () - "Setup multilingual environment for Ethiopic." - (interactive) - (setq primary-language "Ethiopic") - - (setq default-input-method '("Ethiopic" . "quail-ethio")) - - ;; - ;; key bindings - ;; - (define-key global-map [f4] 'sera-to-fidel-buffer) - (define-key global-map [S-f4] 'sera-to-fidel-region) - (define-key global-map [C-f4] 'sera-to-fidel-marker) - (define-key global-map [f5] 'fidel-to-sera-buffer) - (define-key global-map [S-f5] 'fidel-to-sera-region) - (define-key global-map [C-f5] 'fidel-to-sera-marker) - (define-key global-map [f6] 'ethio-modify-vowel) - (define-key global-map [f7] 'ethio-replace-space) - (define-key global-map [f8] 'ethio-input-special-character) - (define-key global-map [S-f2] 'ethio-replace-space) ; as requested - - (add-hook - 'rmail-mode-hook - '(lambda () - (define-key rmail-mode-map [C-f4] 'sera-to-fidel-mail) - (define-key rmail-mode-map [C-f5] 'fidel-to-sera-mail))) - - (add-hook - 'mail-mode-hook - '(lambda () - (define-key mail-mode-map [C-f4] 'sera-to-fidel-mail) - (define-key mail-mode-map [C-f5] 'fidel-to-sera-mail))) - ) - -(defun describe-ethiopic-support () - "Describe how Emacs supports Ethiopic." - (interactive) - (describe-language-support-internal "Ethiopic")) - -(set-language-info-alist - "Ethiopic" '((setup-function . setup-ethiopic-environment) - (describe-function . describe-ethiopic-support) - (charset . (ethiopic)) - (sample-text . "$(3$O#U!.(B") - (documentation . nil))) - -;; for XEmacs (will be obsoleted) -(define-language-environment 'ethiopic - "Ethiopic" - #'(lambda () - (setq-default quail-current-package - (assoc "ethio" quail-package-alist)))) - -;;; ethiopic.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/european.el --- a/lisp/language/european.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/european.el Mon Aug 13 10:03:52 2007 +0200 @@ -67,14 +67,16 @@ (defun setup-8-bit-environment (language charset coding-system input-method) (setup-english-environment) (set-default-coding-systems coding-system) - (setq coding-category-iso-8-1 coding-system - coding-category-iso-8-2 coding-system) + ;; (setq coding-category-iso-8-1 coding-system + ;; coding-category-iso-8-2 coding-system) + (set-coding-category-system 'iso-8-1 coding-system) + (set-coding-category-system 'iso-8-2 coding-system) - (if charset - (let ((nonascii-offset (- (make-char charset) 128))) - ;; Set up for insertion of characters in this character set - ;; when codes 0200 - 0377 are typed in. - (setq nonascii-insert-offset nonascii-offset))) + ;; (if charset + ;; (let ((nonascii-offset (- (make-char charset) 128))) + ;; ;; Set up for insertion of characters in this character set + ;; ;; when codes 0200 - 0377 are typed in. + ;; (setq nonascii-insert-offset nonascii-offset))) (if input-method (setq default-input-method input-method)) @@ -82,22 +84,9 @@ ;; If this is a Latin-N character set, set up syntax for it in ;; single-byte mode. We can't use require because the file ;; must be eval'd each time in case we change from one Latin-N to another. - (if (string-match "^Latin-\\([1-9]\\)$" language) - (load (downcase language) nil t))) - -;; (define-language-environment 'european -;; "European (for Latin-1 through Latin-5)" -;; (lambda () -;; (set-coding-category-system 'iso-8-designate 'iso-8859-1) -;; (set-coding-priority-list '(iso-8-designate iso-8-1)) -;; ;;(setq locale-coding-system 'no-conversion) ; iso-8859-1 -;; (set-default-buffer-file-coding-system 'no-conversion) ; iso-8859-1 -;; ;;(set-buffer-file-coding-system-for-read 'no-conversion) ; iso-8859-1 -;; ;;(setq display-coding-system 'iso-8859-1) -;; ;;(setq keyboard-coding-system 'iso-8859-1) -;; ;; (setq-default quail-current-package -;; ;; (assoc "latin-1" quail-package-alist)) -;; )) + ;; (if (string-match "^Latin-\\([1-9]\\)$" language) + ;; (load (downcase language) nil t)) + ) ;; Latin-1 (ISO-8859-1) @@ -130,6 +119,51 @@ Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. " . describe-european-environment-map)) )) + +(set-language-info-alist + "German" '((setup-function . (setup-latin1-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-1)) + (coding-system . (iso-8859-1)) + (tutorial . "TUTORIAL.de") + (sample-text + . "Hello, Hej, Tere, Hei, Bonjour, Gr,A|_(B Gott, Ciao, ,A!(BHola!") + (documentation . ("\ +These languages are supported with the Latin-1 (ISO-8859-1) character set: + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. +" . describe-european-environment-map)) + )) + +(set-language-info-alist + "French" '((setup-function . (setup-latin1-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-1)) + (coding-system . (iso-8859-1)) + (tutorial . "TUTORIAL.fr") + (sample-text + . "Hello, Hej, Tere, Hei, Bonjour, Gr,A|_(B Gott, Ciao, ,A!(BHola!") + (documentation . ("\ +These languages are supported with the Latin-1 (ISO-8859-1) character set: + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. +" . describe-european-environment-map)) + )) + +(set-language-info-alist + "Norwegian" '((setup-function . (setup-latin1-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-1)) + (coding-system . (iso-8859-1)) + (tutorial . "TUTORIAL.no") + (sample-text + . "Hello, Hej, Tere, Hei, Bonjour, Gr,A|_(B Gott, Ciao, ,A!(BHola!") + (documentation . ("\ +These languages are supported with the Latin-1 (ISO-8859-1) character set: + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. +" . describe-european-environment-map)) + )) ;; Latin-2 (ISO-8859-2) @@ -165,9 +199,22 @@ (documentation . ("\ These languages are supported with the Latin-2 (ISO-8859-2) character set: Albanian, Czech, English, German, Hungarian, Polish, Romanian, - Serbo-Croatian or Croatian, Slovak, Slovene, and Swedish. + Serbian or Croatian, Slovak, Slovene, and Swedish. " . describe-european-environment-map)) )) + +(set-language-info-alist + "Croatian" '((setup-function . (setup-latin2-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-2)) + (tutorial . "TUTORIAL.hr") + (coding-system . (iso-8859-2)) + (documentation . ("\ +These languages are supported with the Latin-2 (ISO-8859-2) character set: + Albanian, Czech, English, German, Hungarian, Polish, Romanian, + Serbian or Croatian, Slovak, Slovene, and Swedish. +" . describe-european-environment-map)) + )) ;; Latin-3 (ISO-8859-3) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/greek.el --- a/lisp/language/greek.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/greek.el Mon Aug 13 10:03:52 2007 +0200 @@ -71,8 +71,8 @@ (defun setup-greek-environment () "Setup multilingual environment (MULE) for Greek." (interactive) - (setup-8-bit-environment "Greek" 'greek-iso8859-7 'greek-iso-8bit - "greek")) + (setup-8-bit-environment "Greek" 'greek-iso8859-7 'iso-8859-7 "greek") + ) (set-language-info-alist "Greek" '((setup-function . setup-greek-environment) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/hebrew.el --- a/lisp/language/hebrew.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/hebrew.el Mon Aug 13 10:03:52 2007 +0200 @@ -28,26 +28,64 @@ ;;; Code: +;; Syntax of Hebrew characters +(loop for c from 96 to 122 + do (modify-syntax-entry (make-char 'hebrew-iso8859-8 c) "w")) +(modify-syntax-entry (make-char 'hebrew-iso8859-8 32) "w") ; no-break space + + +;; (make-coding-system +;; 'hebrew-iso-8bit 2 ?8 +;; "ISO 2022 based 8-bit encoding for Hebrew (MIME:ISO-8859-8)" +;; '((ascii t) (hebrew-iso8859-8 t) nil nil +;; nil ascii-eol ascii-cntl nil nil nil nil nil t)) + +;; (define-coding-system-alias 'iso-8859-8 'hebrew-iso-8bit) + (make-coding-system - 'hebrew-iso-8bit 2 ?8 - "ISO 2022 based 8-bit encoding for Hebrew (MIME:ISO-8859-8)" - '((ascii t) (hebrew-iso8859-8 t) nil nil - nil ascii-eol ascii-cntl nil nil nil nil nil t)) + 'iso-8859-8 'iso2022 + "MIME ISO-8859-8" + '(charset-g0 ascii + charset-g1 hebrew-iso8859-8 + charset-g2 t + charset-g3 t + no-iso6429 t + mnemonic "MIME/Hbrw" +)) -(define-coding-system-alias 'iso-8859-8 'hebrew-iso-8bit) +(make-coding-system + 'ctext-hebrew 'iso2022 + "Coding-system of Hebrew." + '(charset-g0 ascii + charset-g1 hebrew-iso8859-8 + charset-g2 t + charset-g3 t + mnemonic "CText/Hbrw" + )) (defun setup-hebrew-environment () "Setup multilingual environment (MULE) for Hebrew. But, please note that right-to-left writing is not yet supported." (interactive) - (setup-8-bit-environment "Hebrew" 'hebrew-iso8859-8 'hebrew-iso-8bit - "hebrew")) + (setup-8-bit-environment "Hebrew" 'hebrew-iso8859-8 'iso-8859-8 + "hebrew") + (set-coding-category-system 'iso-8-designate 'iso-8859-8) + (set-coding-priority-list + '(iso-8-designate + iso-8-1 + iso-7 + iso-8-2 + iso-lock-shift + no-conversion + shift-jis + big5)) + ) (set-language-info-alist "Hebrew" '((setup-function . setup-hebrew-environment) (describe-function . describe-hebrew-support) (charset . (hebrew-iso8859-8)) - (coding-system . (hebrew-iso-8bit)) + (coding-system . (iso-8859-8)) (sample-text . "Hebrew ,Hylem(B") (documentation . "Right-to-left writing is not yet supported.") )) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/indian.el --- a/lisp/language/indian.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,357 +0,0 @@ -;;; indian.el --- Support for Indian Languages - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: KAWABATA, Taichi - -;; Keywords: multilingual, Indian - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; History: -;; 1996.10.18 written by KAWABATA, Taichi - -;; For Indian, the character set IS 13194 is supported. -;; -;; IS 13194 does not specifically assign glyphs for each characters. -;; Following code is not specific to each Indian language. -;; -;; Eventually, this code will support generic information about -;; following scripts. -;; -;; Devanagari -;; Bengali -;; Gurmukhi -;; Gujarati -;; Oriya -;; Tamil -;; Telgu -;; Kannada -;; Malayalam -;; -;; In this file, charsets other than charset-ascii and charset-indian-is13194 -;; should not be used except in the comment. - -;;; Code: - -(defun describe-indian-support () - "Describe how Emacs support Indian languages." - (interactive) - (describe-language-support-internal "Indian")) - -(set-language-info-alist - "Indian" '((describe-function . describe-indian-support) - (charset . (indian-is13194)) - (documentation . "\ -Among Indian languages, such languages using Devanagari scripts as -Hindi and Marathi are supproted. For them, please specify Devanagari -for more detail.") - )) - -;; Followings are what you see when you refer to the Emacs -;; representations of IS 13194 charcters. However, this is merely -;; tentative apperance, and you must convert them by -;; indian-to-xxxxxx(specific script) function to use them. -;; Devanagari is not an exception of this rule. - -;; 0xa0 //(5!"#$%&'()*+,-./(B -;; 0xb0 (50123456789:;<=>?(B -;; 0xc0 (5@ABCDEFGHIJKLMNO(B -;; 0xd0 (5PQRSTUVWXYZ[\]^_(B -;; 0xe0 (5`abcdefghijklmno(B -;; 0xf0 (5pqrstuvwxyz{|}~(B// - -;; Note - In IS 13194, several symbols are obtained by special -;; combination of several characters and Nukta sign. -;; -;; Sanskrit Vowel R -> (5*(B + (5i(B -;; Sanskrit Vowel L -> (5&(B + (5i(B -;; Sanskrit Vowel LL -> (5'(B + (5i(B -;; Sanskrit Avagrah -> (5j(B + (5i(B -;; OM -> (5!(B + (5i(B -;; -;; Note - IS 13194 defines ATR(0xEF) and EXT(0xF0), but they are -;; not used in Emacs. -;; -;; Note - the above characters DO NOT represent any script. For -;; example, if you want to obtain Devanagari character, you must do -;; something like the following. -;; -;; (char-to-string (indian-to-devanagari ?(5$(B)) -;; "$(5!$(B" - -(let ((deflist - '(;; chars syntax category - ("(5!"#(B" "w" ?7) ; vowel-modifying diacritical mark - ; chandrabindu, anuswar, visarga - ("(5$(B-(52(B" "w" ?5) ; independent vowel - ("(53(B-(5X(B" "w" ?0) ; consonant - ("(5Z(B-(5g(B" "w" ?8) ; matra - ("(5q(B-(5z(B" "w" ?6) ; digit - )) - elm chars len syntax category to ch i) - (while deflist - (setq elm (car deflist)) - (setq chars (car elm) - len (length chars) - syntax (nth 1 elm) - category (nth 2 elm) - i 0) - (while (< i len) - (if (= (aref chars i) ?-) - (setq i (1+ i) - to (sref chars i)) - (setq ch (sref chars i) - to ch)) - (while (<= ch to) - (modify-syntax-entry ch syntax) - (modify-category-entry ch category) - (setq ch (1+ ch))) - (setq i (+ i (char-bytes to)))) - (setq deflist (cdr deflist)))) - - -;;; ITRANS -;; -;; ITRANS is one of the most popular method to exchange indian scripts -;; electronically. Here is the table to convert between ITRANS code and -;; IS 13194 code. - -(defvar indian-itrans-consonant-alist - '( - ("k" . "(53(B") - ("kh" . "(54(B") - ("g" . "(55(B") - ("gh" . "(56(B") - ("N^" . "(57(B") - ("ch" . "(58(B") - ("chh" . "(59(B") - ("j" . "(5:(B") - ("jh" . "(5;(B") - ("JN" . "(5<(B") - ("T" . "(5=(B") - ("Th" . "(5>(B") - ("D" . "(5?(B") - ("Dh" . "(5@(B") - ("N" . "(5A(B") - ("t" . "(5B(B") - ("th" . "(5C(B") - ("d" . "(5D(B") - ("dh" . "(5E(B") - ("n" . "(5F(B") - ("nh" . "(5G(B") ; For transcription of non-Devanagari Languages. - ("p" . "(5H(B") - ("ph" . "(5I(B") - ("b" . "(5J(B") - ("bh" . "(5K(B") - ("m" . "(5L(B") - ("y" . "(5M(B") - ("yh" . "(5N(B") ; For transcription of non-Devanagari Languages. - ("r" . "(5O(B") - ("rh" . "(5P(B") ; For transcription of non-Devanagari Languages. - ("l" . "(5Q(B") - ("v" . "(5T(B") - ("sh" . "(5U(B") - ("shh" . "(5V(B") - ("s" . "(5W(B") - ("h" . "(5X(B") - ("ld" . "(5R(B") - ("L" . "(5R(B") - ("ksh" . "$(5!3!h!V(B") - ("GY" . "***GY***") ; Must check out later. - ;; special consonants - ("q" . "(53i(B") - ("K" . "(54i(B") - ("G" . "(55i(B") - ("z" . "(5:i(B") - ("f" . "(5Ii(B") - (".D" . "(5?i(B") - (".Dh" . "(5@i(B") - )) - -(defvar indian-itrans-vowel-sign-alist - '( - ;; Special treatment unique to IS 13194 Transliteration - ("" . "(5h(B") - ("a" . "") - ;; Matra (Vowel Sign) - ("aa" . "(5Z(B") - ("A" . "(5Z(B") - ("i" . "(5[(B") - ("ii" . "(5\(B") - ("I" . "(5\(B") - ("u" . "(5](B") - ("uu" . "(5^(B") - ("U" . "(5^(B") - ("R^i" . "(5_(B") ; These must be checked out later. - ("R^I" . "(5_i(B") - ("L^i" . "(5[i(B") - ("L^I" . "(5\i(B") - ("E" . "(5`(B") ; For transcription of non-Devanangri Languages. - ("e" . "(5a(B") - ("ai" . "(5b(B") - ;; ("e.c" . "(5c(B") ; Tentatively suppressed. - ("O" . "(5d(B") ; For transcription of non-Devanagari Languages. - ("o" . "(5e(B") - ("au" . "(5f(B") - ;; ("o.c" . "(5g(B") ; Tentatively suppressed. - )) - -;; -;; Independent vowels and other signs. -;; - -(defvar indian-itrans-other-letters-alist - '( - ("a" . "(5$(B") - ("aa" . "(5%(B") - ("A" . "(5%(B") - ("i" . "(5&(B") - ("ii" . "(5'(B") - ("I" . "(5'(B") - ("u" . "(5((B") - ("uu" . "(5)(B") - ("U" . "(5)(B") - ("R^i" . "(5*(B") - ("R^I" . "(5*i(B") - ("L^i" . "(5&i(B") - ("L^I" . "(5'i(B") - ("E" . "(5+(B") ; For transcription of non-Devanagari Languages. - ("e" . "(5,(B") - ("ai" . "(5-(B") - ;; ("e.c" . "(5.(B") ; Candra E - ("O" . "(5/(B") ; For transcription of non-Devanagari Languages. - ("o" . "(50(B") - ("au" . "(51(B") - ;; ("o.c" . "(52(B") ; Candra O - ("M" . "(5$(B") - ("H" . "(5#(B") - ("AUM" . "(5!i(B") - ("OM" . "(5!i(B") - (".r" . "(5Oh(B") - (".n" . "(5"(B") - (".N" . "(5!(B") - (".h" . "(5h(B") ; Halant - (".." . "(5j(B") - (".a" . "(5ji(B") ; Avagrah - ("0" . "(5q(B") - ("1" . "(5r(B") - ("2" . "(5s(B") - ("3" . "(5t(B") - ("4" . "(5u(B") - ("5" . "(5v(B") - ("6" . "(5w(B") - ("7" . "(5x(B") - ("8" . "(5y(B") - ("9" . "(5z(B") - )) - -;; Regular expression matching single Indian character represented -;; by ITRANS. - -(defvar indian-itrans-regexp - (let ((consonant "\\([cs]hh?\\)\\|[kgjTDnpbyr]h?\\|\\(N\\^?\\)\\|\\(jN\\)\\|[mvqKGzfs]\\|\\(ld?\\)\\|\\(ksh\\)\\|\\(GY\\)\\|\\(\\.Dh?\\)") - (vowel "\\(a[aiu]\\)\\|\\(ii\\)\\|\\(uu\\)\\|\\([RL]\\^[iI]\\)\\|[AIEOeoaiu]") - (misc "[MH0-9]\\|\\(AUM\\)\\|\\(OM\\)\\|\\(\\.[rnNh\\.a]\\)") - (lpre "\\(") (rpre "\\)") (orre "\\|")) - (concat lpre misc rpre orre - lpre lpre consonant rpre "?" lpre vowel rpre rpre orre - lpre consonant rpre ))) - -;; -;; Regular expression matching single ITRANS unit for IS 13194 characters. -;; - -(defvar itrans-indian-regexp - (let ((vowel "[(5$(B-(52(B]") - (consonant "[(53(B-(5X(B]") - (matra "[(5Z(B-(5g(B]") - (misc "[(5q(B-(5z(B]") - (lpre "\\(") (rpre "\\)") (orre "\\|")) - (concat misc orre - lpre consonant matra "?" rpre orre - vowel))) - -;; -;; IS13194 - ITRANS conversion table for string matching above regexp. -;; - -(defvar indian-itrans-alist - (let ((cl indian-itrans-consonant-alist) - (ml indian-itrans-other-letters-alist) rules) - (while cl - (let ((vl indian-itrans-vowel-sign-alist)) - (while vl - (setq rules - (cons (cons (concat (car (car cl)) (car (car vl))) - (concat (cdr (car cl)) (cdr (car vl)))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (cons (car (car ml)) - (cdr (car ml))) - rules)) - (setq ml (cdr ml))) - rules)) - -;; -;; Utility program to convert from ITRANS to IS 13194 in specified region. -;; - -(defun indian-decode-itrans-region (from to) - "Convert `ITRANS' mnemonics of the current region to Indian characters. -When called from a program, expects two arguments, -positions (integers or markers) specifying the stretch of the region." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward indian-itrans-regexp nil t) - (let* ((itrans (buffer-substring (match-beginning 0) (match-end 0))) - (ch (cdr (assoc itrans indian-itrans-alist)))) - (if ch - (progn - (delete-region (match-beginning 0) (match-end 0)) - (insert ch))))) - (goto-char (point-min)) - (while (re-search-forward "\\((5h(B\\)[^\\c0]" nil t) - (delete-region (match-beginning 1) (match-end 1))))) - -;; -;; Utility program to convert from IS 13194 to ITRANS in specified region. -;; - -(defun indian-encode-itrans-region (from to) - "Convert indian region to ITRANS mnemonics." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward itrans-indian-regexp nil t) - (let* ((indian (buffer-substring (match-beginning 0) (match-end 0))) - (ch (car (rassoc indian indian-itrans-alist)))) - (if ch - (progn - (delete-region (match-beginning 0) (match-end 0)) - (insert ch))))) - (goto-char (point-min)))) - -;;; indian.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/japan-util.el --- a/lisp/language/japan-util.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/japan-util.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,29 +1,69 @@ ;;; japan-util.el --- utilities for Japanese -;; Copyright (C) 1995 Free Software Foundation, Inc. ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. +;; Copyright (C) 1997 MORIOKA Tomohiko ;; Keywords: mule, multilingual, Japanese -;; This file is part of GNU Emacs. +;; This file is part of XEmacs. -;; 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 +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; 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. +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. ;;; Code: +;;;###autoload +(defun setup-japanese-environment () + "Setup multilingual environment (MULE) for Japanese." + (interactive) + (setup-english-environment) + + ;; (setq coding-category-iso-8-2 'japanese-iso-8bit) + (set-coding-category-system 'iso-8-2 'euc-jp) + ;; (setq coding-category-iso-8-else 'japanese-iso-8bit) + + ;; (set-coding-priority + ;; '(coding-category-iso-7 + ;; coding-category-iso-8-2 + ;; coding-category-sjis + ;; coding-category-iso-8-1 + ;; coding-category-iso-7-else + ;; coding-category-iso-8-else + ;; coding-category-emacs-mule)) + (set-coding-priority-list + '(iso-7 + iso-8-2 + shift-jis + iso-8-1 + iso-lock-shift + iso-8-designate + no-conversion + big5)) + + (set-default-coding-systems + (if (eq system-type 'ms-dos) + 'japanese-shift-jis + 'iso-2022-jp)) + + ;; (when (eq 'x (device-type (selected-device))) + ;; (x-use-halfwidth-roman-font 'japanese-jisx0208 "jisx0201")) + + ;; (setq default-input-method "japanese") + ) + (defconst japanese-kana-table '((?$B$"(B ?$B%"(B ?(I1(B) (?$B$$(B ?$B%$(B ?(I2(B) (?$B$&(B ?$B%&(B ?(I3(B) (?$B$((B ?$B%((B ?(I4(B) (?$B$*(B ?$B%*(B ?(I5(B) (?$B$+(B ?$B%+(B ?(I6(B) (?$B$-(B ?$B%-(B ?(I7(B) (?$B$/(B ?$B%/(B ?(I8(B) (?$B$1(B ?$B%1(B ?(I9(B) (?$B$3(B ?$B%3(B ?(I:(B) @@ -261,13 +301,9 @@ (defun read-hiragana-string (prompt &optional initial-input) "Read a Hiragana string from the minibuffer, prompting with string PROMPT. If non-nil, second arg INITIAL-INPUT is a string to insert before reading." - (read-multilingual-string prompt initial-input - "Japanese" "quail-ja-hiragana")) + (read-multilingual-string prompt initial-input "japanese-hiragana")) ;; -(provide 'language/japan-util) +(provide 'japan-util) -;;; Local Variables: -;;; generated-autoload-file: "../loaddefs.el" -;;; End: ;;; japan-util.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/japanese.el --- a/lisp/language/japanese.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/japanese.el Mon Aug 13 10:03:52 2007 +0200 @@ -227,42 +227,4 @@ (sample-text . "Japanese ($BF|K\8l(B) $B$3$s$K$A$O(B, (I:]FAJ(B") (documentation . t))) -;; for XEmacs (will be obsoleted) - -(define-language-environment 'japanese - "Japanese (includes JIS and EUC)" - (lambda () - (set-coding-category-system 'iso-7 'iso-2022-jp) - (set-coding-category-system 'iso-8-2 'euc-jp) - (set-coding-priority-list '(iso-7 iso-8-2 shift-jis no-conversion)) - ;;'(iso-8-2 iso-8-designate iso-8-1 shift-jis big5) - - ;; Added by mrb, who doesn't speak japanese - so be sceptical... - ;; (when (string-match "solaris\\|sunos" system-configuration) - ;;(set-native-coding-system 'euc-japan) ; someday - (set-pathname-coding-system 'euc-jp) - (add-hook 'comint-exec-hook - (lambda () - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-input-coding-system proc 'euc-jp) - (set-process-output-coding-system proc 'euc-jp)))) - ;;(set-buffer-file-coding-system-for-read 'automatic-conversion) - (set-default-buffer-file-coding-system 'euc-jp) - (setq keyboard-coding-system 'euc-jp) - (setq terminal-coding-system 'euc-jp) - (when (eq 'x (device-type (selected-device))) - (x-use-halfwidth-roman-font 'japanese-jisx0208 "jisx0201")) - - (when (eq system-type 'ms-dos) - ;; Shift-JIS is the standard coding system under Japanese MS-DOS - ;; This isn't really code - just a hint to future implementors - (setq keyboard-coding-system 'shift_jis-dos) - (setq terminal-coding-system 'shift_jis-dos) - (set-default-buffer-file-coding-system 'shift_jis-dos) - ;;(set-default-process-coding-system 'shift_jis-dos 'shift_jis-dos) - ) - )) - -(set-coding-category-system 'shift-jis 'shift_jis) - ;;; japanese.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/korean.el --- a/lisp/language/korean.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/korean.el Mon Aug 13 10:03:52 2007 +0200 @@ -105,15 +105,37 @@ "Setup multilingual environment (MULE) for Korean." (interactive) (setup-english-environment) - (setq coding-category-iso-8-2 'euc-kr) + ;; (setq coding-category-iso-8-2 'euc-kr) + (set-coding-category-system 'iso-8-2 'euc-kr) - (set-coding-priority - '(coding-category-iso-7 - coding-category-iso-8-2 - coding-category-iso-8-1)) + ;; (set-coding-priority + ;; '(coding-category-iso-7 + ;; coding-category-iso-8-2 + ;; coding-category-iso-8-1)) + (set-coding-priority-list + '(iso-8-2 + iso-7 + iso-8-1 + iso-8-designate + iso-lock-shift + no-conversion + shift-jis + big5)) (set-default-coding-systems 'euc-kr) + ;; (when (eq 'x (device-type (selected-device))) + ;; (x-use-halfwidth-roman-font 'korean-ksc5601 "ksc5636")) + + ;; EGG specific setup 97.02.05 jhod + (when (featurep 'egg) + (when (not (featurep 'egg-kor)) + (provide 'egg-kor) + (load "its/its-hangul") + (setq its:*standard-modes* + (cons (its:get-mode-map "hangul") its:*standard-modes*))) + (setq-default its:*current-map* (its:get-mode-map "hangul"))) + (setq default-input-method "korean-hangul")) (set-language-info-alist @@ -124,37 +146,4 @@ (sample-text . "Hangul ($(CGQ1[(B) $(C>H3gGO<H3gGO=J4O1n(B") (documentation . t))) -;;; for XEmacs (will be obsoleted) - -(define-language-environment 'korean - "Korean" - (lambda () - (set-coding-category-system 'iso-8-2 'euc-kr) - (set-coding-priority-list '(iso-8-2 iso-7 iso-8-designate)) - (set-pathname-coding-system 'euc-kr) - (add-hook 'comint-exec-hook - (lambda () - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-input-coding-system proc 'euc-kr) - (set-process-output-coding-system proc 'euc-kr)))) - (set-buffer-file-coding-system-for-read 'automatic-conversion) - (set-default-buffer-file-coding-system 'euc-kr) - (setq keyboard-coding-system 'euc-kr) - (setq terminal-coding-system 'euc-kr) - (when (eq 'x (device-type (selected-device))) - (x-use-halfwidth-roman-font 'korean-ksc5601 "ksc5636")) - - ;; EGG specific setup 97.02.05 jhod - (when (featurep 'egg) - (when (not (featurep 'egg-kor)) - (provide 'egg-kor) - (load "its/its-hangul") - (setq its:*standard-modes* - (cons (its:get-mode-map "hangul") its:*standard-modes*))) - (setq-default its:*current-map* (its:get-mode-map "hangul"))) - -;; ;; (setq-default quail-current-package -;; ;; (assoc "hangul" quail-package-alist)) - )) - ;;; korean.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/lao-util.el --- a/lisp/language/lao-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,140 +0,0 @@ -;;; lao-util.el --- utilities for Lao - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Lao - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;;###autoload -(defun setup-lao-environment () - "Setup multilingual environment (MULE) for Lao." - (interactive) - (setup-8-bit-environment "Lao" 'lao 'iso-2022-7bit - "lao")) - -(let ((l '((?(1!(B consonant "LETTER KOR KAI'" "CHICKEN") - (?(1"(B consonant "LETTER KHOR KHAI'" "EGG") - (?(1#(B invalid nil) - (?(1$(B consonant "LETTER QHOR QHWARGN" "BUFFALO") - (?(1%(B invalid nil) - (? invalid nil) - (?(1'(B consonant "LETTER NGOR NGUU" "SNAKE") - (?(1((B consonant "LETTER JOR JUA" "BUDDHIST NOVICE") - (?(1)(B invalid nil) - (?(1*(B consonant "LETTER XOR X\"ARNG" "ELEPHANT") - (?(1+(B invalid nil) - (?(1,(B invalid nil) - (?(1-(B consonant "LETTER YOR YUNG" "MOSQUITO") - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(14(B consonant "LETTER DOR DANG" "NOSE") - (?(15(B consonant "LETTER TOR TAR" "EYE") - (?(16(B consonant "LETTER THOR THUNG" "TO ASK,QUESTION") - (?(17(B consonant "LETTER DHOR DHARM" "FLAG") - (?(18(B invalid nil) - (?(19(B consonant "LETTER NOR NOK" "BIRD") - (?(1:(B consonant "LETTER BOR BED" "FISHHOOK") - (?(1;(B consonant "LETTER POR PAR" "FISH") - (?(1<(B consonant "LETTER HPOR HPER\"" "BEE") - (?(1=(B consonant "LETTER FHOR FHAR" "WALL") - (?(1>(B consonant "LETTER PHOR PHUU" "MOUNTAIN") - (?(1?(B consonant "LETTER FOR FAI" "FIRE") - (?(1@(B invalid nil) - (?(1A(B consonant "LETTER MOR MAR\"" "HORSE") - (?(1B(B consonant "LETTER GNOR GNAR" "MEDICINE") - (?(1C(B consonant "LETTER ROR ROD" "CAR") - (?(1D(B invalid nil) - (?(1E(B consonant "LETTER LOR LIING" "MONKEY") - (?(1F(B invalid nil) - (?(1G(B consonant "LETTER WOR WII" "HAND FAN") - (?(1H(B invalid nil) - (?(1I(B invalid nil) - (?(1J(B consonant "LETTER SOR SEA" "TIGER") - (?(1K(B consonant "LETTER HHOR HHAI" "JAR") - (?(1L(B invalid nil) - (?(1M(B consonant "LETTER OR OOW" "TAKE") - (?(1N(B consonant "LETTER HOR HEA" "BOAT") - (?(1O(B special "ELLIPSIS") - (?(1P(B vowel-base "VOWEL SIGN SARA A") - (?(1Q(B vowel-upper "VOWEL SIGN MAI KAN") - (?(1R(B vowel-base "VOWEL SIGN SARA AR") - (?(1S(B vowel-base "VOWEL SIGN SARA AM") - (?(1T(B vowel-upper "VOWEL SIGN SARA I") - (?(1U(B vowel-upper "VOWEL SIGN SARA II") - (?(1V(B vowel-upper "VOWEL SIGN SARA EU") - (?(1W(B vowel-upper "VOWEL SIGN SARA UR") - (?(1X(B vowel-lower "VOWEL SIGN SARA U") - (?(1Y(B vowel-lower "VOWEL SIGN SARA UU") - (?(1Z(B invalid nil) - (?(1[(B vowel-upper "VOWEL SIGN MAI KONG") - (?(1\(B semivowel-lower "SEMIVOWEL SIGN LO") - (?(1](B vowel-base "SEMIVOWEL SIGN SARA IA") - (?(1^(B invalid nil) - (?(1_(B invalid nil) - (?(1`(B vowel-base "VOWEL SIGN SARA EE") - (?(1a(B vowel-base "VOWEL SIGN SARA AA") - (?(1b(B vowel-base "VOWEL SIGN SARA OO") - (?(1c(B vowel-base "VOWEL SIGN SARA EI MAI MUAN\"") - (?(1d(B vowel-base "VOWEL SIGN SARA AI MAI MAY") - (?(1e(B invalid nil) - (?(1f(B special "KO LA (REPETITION)") - (?(1g(B invalid nil) - (?(1h(B tone "TONE MAI EK") - (?(1i(B tone "TONE MAI THO") - (?(1j(B tone "TONE MAI TI") - (?(1k(B tone "TONE MAI JADTAWAR") - (?(1l(B tone "CANCELLATION MARK") - (?(1m(B vowel-upper "VOWEL SIGN SARA OR") - (?(1n(B invalid nil) - (?(1o(B invalid nil) - (?(1p(B special "DIGIT ZERO") - (?(1q(B special "DIGIT ONE") - (?(1r(B special "DIGIT TWO") - (?(1s(B special "DIGIT THREE") - (?(1t(B special "DIGIT FOUR") - (?(1u(B special "DIGIT FIVE") - (?(1v(B special "DIGIT SIX") - (?(1w(B special "DIGIT SEVEN") - (?(1x(B special "DIGIT EIGHT") - (?(1y(B special "DIGIT NINE") - (?(1z(B invalid nil) - (?(1{(B invalid nil) - (?(1|(B consonant "LETTER NHOR NHUU" "MOUSE") - (?(1}(B consonant "LETTER MHOR MHAR" "DOG") - (?(1~(B invalid nil) - )) - elm) - (while l - (setq elm (car l)) - (put-char-code-property (car elm) 'phonetic-type (car (cdr elm))) - (put-char-code-property (car elm) 'name (nth 2 elm)) - (put-char-code-property (car elm) 'meaning (nth 3 elm)) - (setq l (cdr l)))) - -;; -(provide 'lao-util) - -;;; lao-util.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/lao.el --- a/lisp/language/lao.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -;;; lao.el --- Support for Lao - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Lao - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(make-coding-system - 'lao 2 ?L - "8-bit encoding for ASCII (MSB=0) and LAO (MSB=1)" - '((ascii t) (lao t) nil nil - nil ascii-eol)) - -(set-language-info-alist - "Lao" '((setup-function . setup-lao-environment) - (charset . (lao)) - (coding-system . (lao)) - (sample-text . "Lao((1>RJRERG(B) (1JP:R-04U1(B, 0(1"i1M-`0;Q190$[19ERG(B") - (documentation . t))) - -(aset use-default-ascent ?(1;(B t) -(aset use-default-ascent ?(1=(B t) -(aset use-default-ascent ?(1?(B t) -(aset use-default-ascent ?(1B(B t) -(aset ignore-relative-composition ?(1\(B t) - -;;; lao.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/thai-util.el --- a/lisp/language/thai-util.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/thai-util.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,324 +0,0 @@ -;;; thai-util.el --- utilities for Thai - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Keywords: mule, multilingual, thai - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Code: - -;; Setting information of Thai characters. - -;; (let ((l '((?,T!(B consonant "LETTER KO KAI") ; 0xA1 -;; (?,T"(B consonant "LETTER KHO KHAI") ; 0xA2 -;; (?,T#(B consonant "LETTER KHO KHUAT") ; 0xA3 -;; (?,T$(B consonant "LETTER KHO KHWAI") ; 0xA4 -;; (?,T%(B consonant "LETTER KHO KHON") ; 0xA5 -;; (?,T&(B consonant "LETTER KHO RAKHANG") ; 0xA6 -;; (?,T'(B consonant "LETTER NGO NGU") ; 0xA7 -;; (?,T((B consonant "LETTER CHO CHAN") ; 0xA8 -;; (?,T)(B consonant "LETTER CHO CHING") ; 0xA9 -;; (?,T*(B consonant "LETTER CHO CHANG") ; 0xAA -;; (?,T+(B consonant "LETTER SO SO") ; 0xAB -;; (?,T,(B consonant "LETTER CHO CHOE") ; 0xAC -;; (?,T-(B consonant "LETTER YO YING") ; 0xAD -;; (?,T.(B consonant "LETTER DO CHADA") ; 0xAE -;; (?,T/(B consonant "LETTER TO PATAK") ; 0xAF -;; (?,T0(B consonant "LETTER THO THAN") ; 0xB0 -;; (?,T1(B consonant "LETTER THO NANGMONTHO") ; 0xB1 -;; (?,T2(B consonant "LETTER THO PHUTHAO") ; 0xB2 -;; (?,T3(B consonant "LETTER NO NEN") ; 0xB3 -;; (?,T4(B consonant "LETTER DO DEK") ; 0xB4 -;; (?,T5(B consonant "LETTER TO TAO") ; 0xB5 -;; (?,T6(B consonant "LETTER THO THUNG") ; 0xB6 -;; (?,T7(B consonant "LETTER THO THAHAN") ; 0xB7 -;; (?,T8(B consonant "LETTER THO THONG") ; 0xB8 -;; (?,T9(B consonant "LETTER NO NU") ; 0xB9 -;; (?,T:(B consonant "LETTER BO BAIMAI") ; 0xBA -;; (?,T;(B consonant "LETTER PO PLA") ; 0xBB -;; (?,T<(B consonant "LETTER PHO PHUNG") ; 0xBC -;; (?,T=(B consonant "LETTER FO FA") ; 0xBD -;; (?,T>(B consonant "LETTER PHO PHAN") ; 0xBE -;; (?,T?(B consonant "LETTER FO FAN") ; 0xBF -;; (?,T@(B consonant "LETTER PHO SAMPHAO") ; 0xC0 -;; (?,TA(B consonant "LETTER MO MA") ; 0xC1 -;; (?,TB(B consonant "LETTER YO YAK") ; 0xC2 -;; (?,TC(B consonant "LETTER RO RUA") ; 0xC3 -;; (?,TD(B vowel-base "LETTER RU (Pali vowel letter)") ; 0xC4 -;; (?,TE(B consonant "LETTER LO LING") ; 0xC5 -;; (?,TF(B vowel-base "LETTER LU (Pali vowel letter)") ; 0xC6 -;; (?,TG(B consonant "LETTER WO WAEN") ; 0xC7 -;; (?,TH(B consonant "LETTER SO SALA") ; 0xC8 -;; (?,TI(B consonant "LETTER SO RUSI") ; 0xC9 -;; (?,TJ(B consonant "LETTER SO SUA") ; 0xCA -;; (?,TK(B consonant "LETTER HO HIP") ; 0xCB -;; (?,TL(B consonant "LETTER LO CHULA") ; 0xCC -;; (?,TM(B consonant "LETTER O ANG") ; 0xCD -;; (?,TN(B consonant "LETTER HO NOK HUK") ; 0xCE -;; (?,TO(B special "PAI YAN NOI (abbreviation)") ; 0xCF -;; (?,TP(B vowel-base "VOWEL SIGN SARA A") ; 0xD0 -;; (?,TQ(B vowel-upper "VOWEL SIGN MAI HAN-AKAT N/S-T") ; 0xD1 -;; (?,TR(B vowel-base "VOWEL SIGN SARA AA") ; 0xD2 -;; (?,TS(B vowel-base "VOWEL SIGN SARA AM") ; 0xD3 -;; (?,TT(B vowel-upper "VOWEL SIGN SARA I N/S-T") ; 0xD4 -;; (?,TU(B vowel-upper "VOWEL SIGN SARA II N/S-T") ; 0xD5 -;; (?,TV(B vowel-upper "VOWEL SIGN SARA UE N/S-T") ; 0xD6 -;; (?,TW(B vowel-upper "VOWEL SIGN SARA UEE N/S-T") ; 0xD7 -;; (?,TX(B vowel-lower "VOWEL SIGN SARA U N/S-B") ; 0xD8 -;; (?,TY(B vowel-lower "VOWEL SIGN SARA UU N/S-B") ; 0xD9 -;; (?,TZ(B vowel-lower "VOWEL SIGN PHINTHU N/S-B (Pali virama)") ; 0xDA -;; (?,T[(B invalid nil) ; 0xDA -;; (?,T\(B invalid nil) ; 0xDC -;; (?,T](B invalid nil) ; 0xDC -;; (?,T^(B invalid nil) ; 0xDC -;; (?,T_(B special "BAHT SIGN (currency symbol)") ; 0xDF -;; (?,T`(B vowel-base "VOWEL SIGN SARA E") ; 0xE0 -;; (?,Ta(B vowel-base "VOWEL SIGN SARA AE") ; 0xE1 -;; (?,Tb(B vowel-base "VOWEL SIGN SARA O") ; 0xE2 -;; (?,Tc(B vowel-base "VOWEL SIGN SARA MAI MUAN") ; 0xE3 -;; (?,Td(B vowel-base "VOWEL SIGN SARA MAI MALAI") ; 0xE4 -;; (?,Te(B vowel-base "LAK KHANG YAO") ; 0xE5 -;; (?,Tf(B special "MAI YAMOK (repetion)") ; 0xE6 -;; (?,Tg(B vowel-upper "VOWEL SIGN MAI TAI KHU N/S-T") ; 0xE7 -;; (?,Th(B tone "TONE MAI EK N/S-T") ; 0xE8 -;; (?,Ti(B tone "TONE MAI THO N/S-T") ; 0xE9 -;; (?,Tj(B tone "TONE MAI TRI N/S-T") ; 0xEA -;; (?,Tk(B tone "TONE MAI CHATTAWA N/S-T") ; 0xEB -;; (?,Tl(B tone "THANTHAKHAT N/S-T (cancellation mark)") ; 0xEC -;; (?,Tm(B tone "NIKKHAHIT N/S-T (final nasal)") ; 0xED -;; (?,Tn(B vowel-upper "YAMAKKAN N/S-T") ; 0xEE -;; (?,To(B special "FONRMAN") ; 0xEF -;; (?,Tp(B special "DIGIT ZERO") ; 0xF0 -;; (?,Tq(B special "DIGIT ONE") ; 0xF1 -;; (?,Tr(B special "DIGIT TWO") ; 0xF2 -;; (?,Ts(B special "DIGIT THREE") ; 0xF3 -;; (?,Tt(B special "DIGIT FOUR") ; 0xF4 -;; (?,Tu(B special "DIGIT FIVE") ; 0xF5 -;; (?,Tv(B special "DIGIT SIX") ; 0xF6 -;; (?,Tw(B special "DIGIT SEVEN") ; 0xF7 -;; (?,Tx(B special "DIGIT EIGHT") ; 0xF8 -;; (?,Ty(B special "DIGIT NINE") ; 0xF9 -;; (?,Tz(B special "ANGKHANKHU (ellipsis)") ; 0xFA -;; (?,T{(B special "KHOMUT (beginning of religious texts)") ; 0xFB -;; (?,T|(B invalid nil) ; 0xFC -;; (?,T}(B invalid nil) ; 0xFD -;; (?,T~(B invalid nil) ; 0xFE -;; )) -;; elm) -;; (while l -;; (setq elm (car l)) -;; (put-char-code-property (car elm) 'phonetic-type (car (cdr elm))) -;; (put-char-code-property (car elm) 'name (nth 2 elm)) -;; (setq l (cdr l)))) - -(defconst thai-character-alist - '((?,T!(B . consonant) ; 0xA1: LETTER KO KAI - (?,T"(B . consonant) ; 0xA2: LETTER KHO KHAI - (?,T#(B . consonant) ; 0xA3: LETTER KHO KHUAT (obsolete) - (?,T$(B . consonant) ; 0xA4: LETTER KHO KHWAI - (?,T%(B . consonant) ; 0xA5: LETTER KHO KHON (obsolete) - (?,T&(B . consonant) ; 0xA6: LETTER KHO RAKHANG - (?,T'(B . consonant) ; 0xA7: LETTER NGO NGU - (?,T((B . consonant) ; 0xA8: LETTER CHO CHAN - (?,T)(B . consonant) ; 0xA9: LETTER CHO CHING - (?,T*(B . consonant) ; 0xAA: LETTER CHO CHANG - (?,T+(B . consonant) ; 0xAB: LETTER SO SO - (?,T,(B . consonant) ; 0xAC: LETTER CHO CHOE - (?,T-(B . consonant) ; 0xAD: LETTER YO YING - (?,T.(B . consonant) ; 0xAE: LETTER DO CHADA - (?,T/(B . consonant) ; 0xAF: LETTER TO PATAK - (?,T0(B . consonant) ; 0xB0: LETTER THO THAN - (?,T1(B . consonant) ; 0xB1: LETTER THO NANGMONTHO - (?,T2(B . consonant) ; 0xB2: LETTER THO PHUTHAO - (?,T3(B . consonant) ; 0xB3: LETTER NO NEN - (?,T4(B . consonant) ; 0xB4: LETTER DO DEK - (?,T5(B . consonant) ; 0xB5: LETTER TO TAO - (?,T6(B . consonant) ; 0xB6: LETTER THO THUNG - (?,T7(B . consonant) ; 0xB7: LETTER THO THAHAN - (?,T8(B . consonant) ; 0xB8: LETTER THO THONG - (?,T9(B . consonant) ; 0xB9: LETTER NO NU - (?,T:(B . consonant) ; 0xBA: LETTER BO BAIMAI - (?,T;(B . consonant) ; 0xBB: LETTER PO PLA - (?,T<(B . consonant) ; 0xBC: LETTER PHO PHUNG - (?,T=(B . consonant) ; 0xBD: LETTER FO FA - (?,T>(B . consonant) ; 0xBE: LETTER PHO PHAN - (?,T?(B . consonant) ; 0xBF: LETTER FO FAN - (?,T@(B . consonant) ; 0xC0: LETTER PHO SAMPHAO - (?,TA(B . consonant) ; 0xC1: LETTER MO MA - (?,TB(B . consonant) ; 0xC2: LETTER YO YAK - (?,TC(B . consonant) ; 0xC3: LETTER RO RUA - (?,TD(B . vowel-base) ; 0xC4: LETTER RU (vowel letter used to write Pali) - (?,TE(B . consonant) ; 0xC5: LETTER LO LING - (?,TF(B . vowel-base) ; 0xC6: LETTER LU (vowel letter used to write Pali) - (?,TG(B . consonant) ; 0xC7: LETTER WO WAEN - (?,TH(B . consonant) ; 0xC8: LETTER SO SALA - (?,TI(B . consonant) ; 0xC9: LETTER SO RUSI - (?,TJ(B . consonant) ; 0xCA: LETTER SO SUA - (?,TK(B . consonant) ; 0xCB: LETTER HO HIP - (?,TL(B . consonant) ; 0xCC: LETTER LO CHULA - (?,TM(B . consonant) ; 0xCD: LETTER O ANG - (?,TN(B . consonant) ; 0xCE: LETTER HO NOK HUK - (?,TO(B . special) ; 0xCF: PAI YAN NOI (abbreviation) - (?,TP(B . vowel-base) ; 0xD0: VOWEL SIGN SARA A - (?,TQ(B . vowel-upper) ; 0xD1: VOWEL SIGN MAI HAN-AKAT N/S-T - (?,TR(B . vowel-base) ; 0xD2: VOWEL SIGN SARA AA - (?,TS(B . vowel-base) ; 0xD3: VOWEL SIGN SARA AM - (?,TT(B . vowel-upper) ; 0xD4: VOWEL SIGN SARA I N/S-T - (?,TU(B . vowel-upper) ; 0xD5: VOWEL SIGN SARA II N/S-T - (?,TV(B . vowel-upper) ; 0xD6: VOWEL SIGN SARA UE N/S-T - (?,TW(B . vowel-upper) ; 0xD7: VOWEL SIGN SARA UEE N/S-T - (?,TX(B . vowel-lower) ; 0xD8: VOWEL SIGN SARA U N/S-B - (?,TY(B . vowel-lower) ; 0xD9: VOWEL SIGN SARA UU N/S-B - (?,TZ(B . vowel-lower) ; 0xDA: VOWEL SIGN PHINTHU N/S-B (Pali virama) - (?,T[(B . not-used) ; 0xDA: - (?,T\(B . not-used) ; 0xDC: - (?,T](B . not-used) ; 0xDC: - (?,T^(B . not-used) ; 0xDC: - (?,T_(B . special) ; 0xDF: BAHT SIGN (currency symbol) - (?,T`(B . vowel-base) ; 0xE0: VOWEL SIGN SARA E - (?,Ta(B . vowel-base) ; 0xE1: VOWEL SIGN SARA AE - (?,Tb(B . vowel-base) ; 0xE2: VOWEL SIGN SARA O - (?,Tc(B . vowel-base) ; 0xE3: VOWEL SIGN SARA MAI MUAN - (?,Td(B . vowel-base) ; 0xE4: VOWEL SIGN SARA MAI MALAI - (?,Te(B . vowel-base) ; 0xE5: LAK KHANG YAO - (?,Tf(B . special) ; 0xE6: MAI YAMOK (repetion) - (?,Tg(B . vowel-upper) ; 0xE7: VOWEL SIGN MAI TAI KHU N/S-T - (?,Th(B . tone) ; 0xE8: TONE MAI EK N/S-T - (?,Ti(B . tone) ; 0xE9: TONE MAI THO N/S-T - (?,Tj(B . tone) ; 0xEA: TONE MAI TRI N/S-T - (?,Tk(B . tone) ; 0xEB: TONE MAI CHATTAWA N/S-T - (?,Tl(B . tone) ; 0xEC: THANTHAKHAT N/S-T (cancellation mark) - (?,Tm(B . tone) ; 0xED: NIKKHAHIT N/S-T (final nasal) - (?,Tn(B . vowel-upper) ; 0xEE: YAMAKKAN N/S-T - (?,To(B . special) ; 0xEF: FONRMAN - (?,Tp(B . special) ; 0xF0: DIGIT ZERO - (?,Tq(B . special) ; 0xF1: DIGIT ONE - (?,Tr(B . special) ; 0xF2: DIGIT TWO - (?,Ts(B . special) ; 0xF3: DIGIT THREE - (?,Tt(B . special) ; 0xF4: DIGIT FOUR - (?,Tu(B . special) ; 0xF5: DIGIT FIVE - (?,Tv(B . special) ; 0xF6: DIGIT SIX - (?,Tw(B . special) ; 0xF7: DIGIT SEVEN - (?,Tx(B . special) ; 0xF8: DIGIT EIGHT - (?,Ty(B . special) ; 0xF9: DIGIT NINE - (?,Tz(B . special) ; 0xFA: ANGKHANKHU (ellipsis) - (?,T{(B . special) ; 0xFB: KHOMUT (beginning of religious texts) - (?,T|(B . not-used) ; 0xFC: - (?,T}(B . not-used) ; 0xFD: - (?,T~(B . not-used) ; 0xFE: - ) - "Association list of thai-character and property.") -(setq thai-character-alist - (cons (cons (string-to-char "0,TQi1(B") 'vowel-upper-tone) - thai-character-alist)) - -(defconst thai-category-table - (copy-category-table (standard-category-table)) - "Category table for Thai.") -(define-category-mnemonic ?0 "Thai consonants" - thai-category-table) -(define-category-mnemonic ?1 "Thai upper/lower vowel or tone mark." - thai-category-table) -(define-category-mnemonic ?2 "Thai base vowel or special characters." - thai-category-table) - -(let ((chars thai-character-alist) - ch prop) - (while chars - (setq ch (car (car chars)) - prop (cdr (car chars))) - (cond ((eq prop 'consonant) - (modify-category-entry ch ?0 thai-category-table)) - ((or (eq prop 'vowel-upper) - (eq prop 'vowel-lower) - (eq prop 'tone)) - (modify-category-entry ch ?1 thai-category-table)) - ((null (eq prop 'vowel-upper-tone)) - (modify-category-entry ch ?2 thai-category-table))) - (setq chars (cdr chars)))) - -;; ;;;###autoload -;; (defun thai-compose-region (beg end) -;; "Compose Thai characters in the region. -;; When called from a program, expects two arguments, -;; positions (integers or markers) specifying the region." -;; (interactive "r") -;; (save-restriction -;; (narrow-to-region beg end) -;; (decompose-region (point-min) (point-max)) -;; (goto-char (point-min)) -;; (while (re-search-forward "\\c0\\(\\c2\\|\\c3\\|\\c4\\)+" nil t) -;; (if (aref (char-category-set (char-after (match-beginning 0))) ?t) -;; (compose-region (match-beginning 0) (match-end 0)))))) - -;;;###autoload -(defun thai-compose-region (beg end) - "Compose Thai characters in the region." - (interactive "r") - (save-restriction - (narrow-to-region beg end) - (decompose-region (point-min) (point-max)) - (goto-char (point-min)) - (let ((ctbl (category-table)) - str) - (unwind-protect - (progn - (set-category-table thai-category-table) - (while (re-search-forward "\\c0\\c1+" nil t) - (compose-region (match-beginning 0) (match-end 0)))) - (set-category-table ctbl))))) - -;;;###autoload -(defun thai-compose-buffer () - "Compose Thai characters in the current buffer." - (interactive) - (thai-compose-region (point-min) (point-max))) - -;; ;;;###autoload -;; (defun thai-post-read-conversion (len) -;; (save-excursion -;; (save-restriction -;; (let ((buffer-modified-p (buffer-modified-p))) -;; (narrow-to-region (point) (+ (point) len)) -;; (thai-compose-region (point-min) (point-max)) -;; (set-buffer-modified-p buffer-modified-p) -;; (- (point-max) (point-min)))))) - -;; ;;;###autoload -;; (defun thai-pre-write-conversion (from to) -;; (let ((old-buf (current-buffer)) -;; (work-buf (get-buffer-create " *thai-work*"))) -;; (set-buffer work-buf) -;; (erase-buffer) -;; (if (stringp from) -;; (insert from) -;; (insert-buffer-substring old-buf from to)) -;; (decompose-region (point-min) (point-max)) -;; ;; Should return nil as annotations. -;; nil)) - -;; -(provide 'language/thai-util) - -;;; Local Variables: -;;; generated-autoload-file: "../loaddefs.el" -;;; End: -;;; thai-util.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/thai.el --- a/lisp/language/thai.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/thai.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,70 +0,0 @@ -;;; thai.el --- Support for Thai - -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Keywords: multilingual, Thai - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Commentary: - -;; For Thai, the character set TIS620 is supported. - -;;; Code: - -(define-language-environment 'thai - "Thai" - (lambda () - (set-coding-category-system 'iso-8-designate 'tis620) - (set-coding-priority-list '(iso-8-designate iso-8-1)) - (set-default-buffer-file-coding-system 'tis620) - ;; (setq-default quail-current-package (assoc "thai" quail-package-alist)) - )) - -;; (make-coding-system -;; 'th-tis620 2 ?T -;; "Coding-system used for ASCII(MSB=0) & TIS620(MSB=1)." -;; '((ascii t) (thai-tis620 t) nil nil -;; nil ascii-eol)) -;; (put 'th-tis620 'post-read-conversion 'thai-post-read-conversion) -;; (put 'th-tis620 'pre-write-conversion 'thai-pre-write-conversion) - -(make-coding-system - 'tis620 'iso2022 - "Coding-system used for ASCII(MSB=0) & TIS620(MSB=1)." - '(charset-g0 ascii - charset-g1 thai-tis620 - no-ascii-cntl t - mnemonic "TIS620" - post-read-conversion thai-compose-region - pre-write-conversion decompose-region - )) - -;;(define-coding-system-alias 'th-tis620 'tis620) - -(set-language-info-alist - "Thai" '((tutorial . "TUTORIAL.th") - (setup-function . setup-thai-environment) - (charset . (thai-tis620)) - (coding-system . (tis620)) - (sample-text . "Thai (,T@RIRd7B(B) ,TJ0GQ1J04U1$0CQ1:(B, ,TJ0GQ1J04U10$h1P(B") - (documentation . t))) - -;;; thai.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/tibet-util.el --- a/lisp/language/tibet-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,468 +0,0 @@ -;;; tibet-util.el --- Support for inputting Tibetan characters - -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Tibetan - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Author: Toru TOMABECHI, - -;; Created: Feb. 17. 1997 - -;; History: -;; 1997.03.13 Modification in treatment of text properties; -;; Support for some special signs and punctuations. - -;;; Code: - -;;;###autoload -(defun setup-tibetan-environment () - (interactive) - (setup-english-environment) - (setq coding-category-iso-8-2 'tibetan) - - (setq-default buffer-file-coding-system 'iso-2022-7bit) - - (setq default-input-method "tibetan-wylie")) - -;;; This function makes a transcription string for -;;; re-composing a character. - -;;;###autoload -(defun tibetan-tibetan-to-transcription (ch) - "Return a transcription string of Tibetan character CH" - (let ((char ch) - (l (append tibetan-consonant-transcription-alist - tibetan-vowel-transcription-alist - tibetan-precomposed-transcription-alist - tibetan-subjoined-transcription-alist)) - decomp-l t-char trans str result) - (if (eq (char-charset char) 'composition) - (setq decomp-l (decompose-composite-char char 'list nil)) - (setq decomp-l (cons char nil))) - (setq str "") - (while decomp-l - (setq t-char (char-to-string (car decomp-l))) - (setq trans (car (rassoc t-char l))) - (setq str (concat str trans)) - (setq decomp-l (cdr decomp-l))) - (setq result str))) - -;;; This function translates transcription string into a string of -;;; Tibetan characters. - -;;;###autoload -(defun tibetan-transcription-to-tibetan (transcription) - "Translate Roman transcription into a sequence of Tibetan components." - (let ((trans transcription) - (lp tibetan-precomposed-transcription-alist) - (l (append tibetan-consonant-transcription-alist - tibetan-vowel-transcription-alist - tibetan-subjoined-transcription-alist)) - (case-fold-search nil) - substr t-char p-str t-str result) - (setq substr "") - (setq p-str "") - (setq t-str "") - (cond ((string-match tibetan-precomposed-regexp trans) - (setq substr (substring trans (match-beginning 0) (match-end 0))) - (setq trans (substring trans (match-end 0))) - (setq t-char (cdr (assoc substr lp))) - (setq p-str t-char))) - (while (string-match tibetan-regexp trans) - (setq substr (substring trans (match-beginning 0) (match-end 0))) - (setq trans (substring trans 0 (match-beginning 0))) - (setq t-char - (cdr (assoc substr l))) - (setq t-str (concat t-char t-str))) - (setq result (concat p-str t-str)))) - - -;;; -;;; Functions for composing Tibetan character. -;;; -;;; A Tibetan syllable is typically structured as follows: -;;; -;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]] -;;; -;;; where C's are all vertically stacked, V appears below or above -;;; consonant cluster and M is always put above the C[C+]V combination. -;;; (Sanskrit visarga, though it is a vowel modifier, is considered -;;; to be a punctuation.) -;;; -;;; Here are examples of the words "bsgrubs" and "h'uM" -;;; -;;; $(7"72%q`"U1"7"G(B 2$(7"H`#A`"U0"_1(B -;;; -;;; M -;;; b s b s h -;;; g ' -;;; r u -;;; u -;;; -;;; Consonants ''', 'w', 'y', 'r' take special forms when they are used -;;; as subjoined consonant. Consonant 'r' takes another special form -;;; when used as superjoined as in "rka", and so on, while it does not -;;; change its form when conjoined with subjoined ''', 'w' or 'y' -;;; as in "rwa", "rya". -;;; -;;; -;;; As a Tibetan input method should avoid using conversion key, -;;; we use a "Tibetan glyph -> transcription -> Tibetan glyph" -;;; translation at each key input. -;;; -;;; 1st stage - Check the preceding char. -;;; If the preceding char is Tibetan and composable, then -;;; -;;; 2nd stage - Translate the preceding char into transcription -;;; -;;; 3rd stage - Concatenate the transcription of preceding char -;;; and the current input key. -;;; -;;; 4th stage - Re-translate the concatenated transcription into -;;; a sequence of Tibetan letters. -;;; -;;; 5th stage - Convert leading consonants into one single precomposed char -;;; if possible. -;;; -;;; 6th stage - Compose the consonants into one composite glyph. -;;; -;;; (If the current input is a vowel sign or a vowel modifier, -;;; then it is composed with preceding char without checking -;;; except when the preceding char is a punctuation or a digit.) -;;; -;;; - -;;; This function is used to avoid composition -;;; between Tibetan and non-Tibetan chars. - -;;;###autoload -(defun tibetan-char-examin (ch) - "Check if char CH is Tibetan character. -Returns non-nil if CH is Tibetan. Otherwise, returns nil." - (let ((chr ch)) - (if (eq (char-charset chr) 'composition) - (string-match "\\cq+" (decompose-composite-char chr)) - (string-match "\\cq" (char-to-string chr))))) - -;;; This is used to avoid composition between digits, signs, punctuations -;;; and word constituents. - -;;;###autoload -(defun tibetan-composable-examin (ch) - "Check if Tibetan char CH is composable. -Returns t if CH is a composable char \(i.e. neither punctuation nor digit)." - (let ((chr ch) - chstr) - (if (eq (char-charset chr) 'composition) - (setq chstr (decompose-composite-char chr)) - (setq chstr (char-to-string chr))) - (not (string-match "[$(7!1(B-$(7!o"f$(8!;!=!?!@!A!D"`(B]" chstr)))) - - -;;; This checks if a character to be composed contains already -;;; one or more vowels / vowel modifiers. If the character contains -;;; them, then no more consonant should be added. - -;;;###autoload -(defun tibetan-complete-char-examin (ch) - "Check if composite char CH contains one or more vowel/vowel modifiers. -Returns non-nil, if CH contains vowel/vowel modifiers." - (let ((chr ch) - chstr) - (if (eq (char-charset chr) 'composition) - (setq chstr (decompose-composite-char chr)) - (setq chstr (char-to-string chr))) - (string-match "[$(7!g!e"Q(B-$(7"^"_(B-$(7"l(B]" chstr))) - -;;; This function makes a composite character consisting of two characters -;;; vertically stacked. - -;;;###autoload -(defun tibetan-vertical-stacking (first second upward) - "Return a vertically stacked composite char consisting of FIRST and SECOND. -If UPWARD is non-nil, then SECOND is put above FIRST." - (if upward - (compose-chars first '(tc . bc) second) - (compose-chars first '(bc . tc) second))) - -;;; This function makes a composite char from a string. -;;; Note that this function returns a string, not a char. - -;;;###autoload -(defun tibetan-compose-string (str) - "Compose a sequence of Tibetan character components into a composite character. -Returns a string containing a composite character." - (let ((t-str str) - f-str s-str f-ch s-ch rest composed result) - ;;Make sure no redundant vowel sign is present. - (if (string-match - "^\\(.+\\)\\($(7"Q(B\\)\\([$(7!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)" t-str) - (setq t-str (concat - (match-string 1 t-str) - (match-string 3 t-str)))) - (if (string-match - "^\\(.+\\)\\([$(7!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)\\($(7"Q(B\\)" t-str) - (setq t-str (concat - (match-string 1 t-str) - (match-string 2 t-str)))) - ;;Start conversion. - (setq result "") - ;; Consecutive base/precomposed consonants are reduced to the last one. - (while (string-match "^\\([$(7"!(B-$(7"J$!(B-$(7%u(B]\\)\\([$(7"!(B-$(7"@"B(B-$(7"J$!(B-$(7%u(B].*\\)" t-str) - (setq result (concat result (match-string 1 t-str))) - (setq t-str (match-string 2 t-str))) - ;; Vowel/vowel modifier, subjoined consonants are added one by one - ;; to the preceding element. - (while - (string-match "^\\(.\\)\\([$(7"A#!(B-$(7#J!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)\\(.*\\)" t-str) - (setq f-str (match-string 1 t-str)) - (setq f-ch (string-to-char f-str)) - (setq s-str (match-string 2 t-str)) - ;;Special treatment for 'a chung. - ;;If 'a follows a consonant, then turned into its subjoined form. - (if (and (string-match "$(7"A(B" s-str) - (not (tibetan-complete-char-examin f-ch))) - (setq s-str "$(7#A(B")) - (setq s-ch (string-to-char s-str)) - (setq rest (match-string 3 t-str)) - (cond ((string-match "\\c2" s-str);; upper vowel sign - (setq composed - (tibetan-vertical-stacking f-ch s-ch t))) - ((string-match "\\c3" s-str);; lower vowel sign - (setq composed - (tibetan-vertical-stacking f-ch s-ch nil))) - ;;Automatic conversion of ra-mgo (superscribed r). - ;;'r' is converted if followed by a subjoined consonant - ;;other than w, ', y, r. - ((and (string-match "$(7"C(B" f-str) - (not (string-match "[$(7#>#A#B#C(B]" s-str))) - (setq f-ch ?$(7#P(B) - (setq composed - (tibetan-vertical-stacking f-ch s-ch nil))) - ((not (tibetan-complete-char-examin f-ch)) - ;;Initial base consonant is tranformed, if followed by - ;;a subjoined consonant, except when it is followed - ;;by a subscribed 'a. - (if (and (string-match "[$(7"!(B-$(7"="?"@"D(B-$(7"J(B]" f-str) - (not (string-match "$(7#A(B" s-str))) - (setq f-ch - (string-to-char - (cdr (assoc f-str tibetan-base-to-subjoined-alist))))) - (setq composed - (tibetan-vertical-stacking f-ch s-ch nil))) - (t - (setq composed s-str) - (setq result (concat result f-str)))) - (setq t-str (concat composed rest))) - (setq result (concat result t-str)))) - -;;; quail <-> conversion interface. - -;;;###autoload -(defun tibetan-composition (pc key) - "Interface to quail input method. -Takes two arguments: char PC and string KEY, where PC is the preceding -character to be composed with current input KEY. -Returns a string which is the result of composition." - (let (trans cur-ch t-str result) - ;; Make a tibetan character corresponding to current input key. - (setq cur-ch (tibetan-transcription-to-tibetan key)) - ;; Check if the preceding character is Tibetan and composable. - (cond ((and (tibetan-char-examin pc) - (tibetan-composable-examin pc)) - ;;If Tibetan char corresponding to the current input key exists, - (cond (cur-ch - ;; Then, - ;; Convert the preceding character into transcription, - ;; and concatenate it with the current input key, - (setq trans (tibetan-tibetan-to-transcription pc)) - (setq trans (concat trans key)) - ;; Concatenated transcription is converted to - ;; a sequence of Tibetan characters, - (setq t-str (tibetan-transcription-to-tibetan trans)) - ;; And it is composed into a composite character. - (setq result (tibetan-compose-string t-str))) - ;; Else, - (t - ;; Simply concatenate the preceding character and - ;; the current input key. - (setq result (char-to-string pc)) - (setq result (concat result key))))) - ;; If the preceding char is not Tibetan or not composable, - (t - ;; pc = 0 means the point is at the beginning of buffer. - (if (not (eq pc 0)) - (setq result (char-to-string pc))) - (if cur-ch - (setq result (concat result cur-ch)) - (setq result (concat result key)))) - ))) - - -;;;###autoload -(defun tibetan-decompose-region (beg end) - "Decompose Tibetan characters in the region BEG END into their components. -Components are: base and subjoined consonants, vowel signs, vowel modifiers. -One column punctuations are converted to their 2 column equivalents." - (interactive "r") - (let (ch-str ch-beg ch-end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - ;; \\cq = Tibetan character - (while (re-search-forward "\\cq" nil t) - (setq ch-str (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - ;; Save the points. Maybe, using save-match-data is preferable. - ;; But in order not to lose the trace(because the body is too long), - ;; we save the points in variables. - (setq ch-beg (match-beginning 0)) - (setq ch-end (match-end 0)) - ;; Here starts the decomposition. - (cond - ;; 1 column punctuations -> 2 column equivalent - ((string-match "[$(8!D!;!=!?!@!A"`(B]" ch-str) - (setq ch-str - (car (rassoc ch-str tibetan-precomposition-rule-alist)))) - ;; Decomposition of composite character. - ((eq (char-charset (string-to-char ch-str)) 'composition) - ;; Make a string which consists of a sequence of - ;; components. - (setq ch-str (decompose-composite-char (string-to-char ch-str))) - ;; Converts nyi zla into base elements. - (cond ((string= ch-str "$(7#R#S#S#S(B") - (setq ch-str "$(7!4!5!5(B")) - ((string= ch-str "$(7#R#S#S(B") - (setq ch-str "$(7!4!5(B")) - ((string= ch-str "$(7#R#S!I(B") - (setq ch-str "$(7!6(B")) - ((string= ch-str "$(7#R#S(B") - (setq ch-str "$(7!4(B"))))) - ;; If the sequence of components starts with a subjoined consonants, - (if (string-match "^\\([$(7#!(B-$(7#J(B]\\)\\(.*\\)$" ch-str) - ;; then the first components is converted to its base form. - (setq ch-str - (concat (car (rassoc (match-string 1 ch-str) - tibetan-base-to-subjoined-alist)) - (match-string 2 ch-str)))) - ;; If the sequence of components starts with a precomposed character, - (if (string-match "^\\([$(7$!(B-$(7%u(B]\\)\\(.*\\)$" ch-str) - ;; then it is converted into a sequence of components. - (setq ch-str - (concat (car (rassoc (match-string 1 ch-str) - tibetan-precomposition-rule-alist)) - (match-string 2 ch-str)))) - ;; Special treatment for superscribed r. - (if (string-match "^$(7#P(B\\(.*\\)$" ch-str) - (setq ch-str (concat "$(7"C(B" (match-string 1 ch-str)))) - ;; Finally, the result of decomposition is inserted, and - ;; the composite character is deleted. - (insert-and-inherit ch-str) - (delete-region ch-beg ch-end)))))) - -;;;###autoload -(defun tibetan-compose-region (beg end) - "Make composite chars from Tibetan character components in the region BEG END. -Two column punctuations are converted to their 1 column equivalents." - (interactive "r") - (let (str result) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - ;; First, sequence of components which has a precomposed equivalent - ;; is converted. - (while (re-search-forward - tibetan-precomposition-rule-regexp nil t) - (setq str (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (save-match-data - (insert-and-inherit - (cdr (assoc str tibetan-precomposition-rule-alist)))) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - ;; Then, composable elements are put into a composite character. - (while (re-search-forward - "[$(7"!(B-$(7"J$!(B-$(7%u(B]+[$(7#!(B-$(7#J!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]+" - nil t) - (setq str (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (save-match-data - (setq result (tibetan-compose-string str)) - (insert-and-inherit result)) - (delete-region (match-beginning 0) (match-end 0))))))) - -;;; -;;; This variable is used to avoid repeated decomposition. -;;; -(setq-default tibetan-decomposed nil) - -;;;###autoload -(defun tibetan-decompose-buffer () - "Decomposes Tibetan characters in the buffer into their components. -See also docstring of the function tibetan-decompose-region." - (interactive) - (make-local-variable 'tibetan-decomposed) - (cond ((not tibetan-decomposed) - (tibetan-decompose-region (point-min) (point-max)) - (setq tibetan-decomposed t)))) - -;;;###autoload -(defun tibetan-compose-buffer () - "Composes Tibetan character components in the buffer. -See also docstring of the function tibetan-compose-region." - (interactive) - (make-local-variable 'tibetan-decomposed) - (tibetan-compose-region (point-min) (point-max)) - (setq tibetan-decomposed nil)) - -;;;###autoload -(defun tibetan-post-read-conversion (len) - (save-excursion - (save-restriction - (let ((buffer-modified-p (buffer-modified-p))) - (narrow-to-region (point) (+ (point) len)) - (tibetan-compose-region (point-min) (point-max)) - (set-buffer-modified-p buffer-modified-p) - (point-max)))) - (make-local-variable 'tibetan-decomposed) - (setq tibetan-decomposed nil)) - - -;;;###autoload -(defun tibetan-pre-write-conversion (from to) - (setq tibetan-decomposed-temp tibetan-decomposed) - (let ((old-buf (current-buffer)) - (work-buf (get-buffer-create " *tibetan-work*"))) - (set-buffer work-buf) - (erase-buffer) - (if (stringp from) - (insert from) - (insert-buffer-substring old-buf from to)) - (if (not tibetan-decomposed-temp) - (tibetan-decompose-region (point-min) (point-max))) - ;; Should return nil as annotations. - nil)) - -(provide 'tibet-util) - -;;; language/tibet-util.el ends here. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/tibetan.el --- a/lisp/language/tibetan.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,555 +0,0 @@ -;;; tibetan.el --- Support for Tibetan language - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Tibetan - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Author: Toru TOMABECHI, - -;; Created: Feb. 17. 1997 - -;; History: -;; 1997.03.13 Modification for special signs and punctuations. - -;;; Code: - -;;; Tibetan Character set. -;;; \x2130 -- \x234a is a subset of Unicode v.2 \x0f00 - \x0fb9 -;;; with a slight modification. And there are some subjoined -;;; consonants which are not specified in Unicode. -;;; I hope I can add missing characters later. -;;; -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2120 // $(7!!(B $(7!"(B $(7!#(B $(7!$(B $(7!%(B $(7!&(B $(7!'(B $(7!((B $(7!)(B $(7!*(B $(7!+(B $(7!,(B $(7!-(B $(7!.(B $(7!/(B ; -;;;2130 $(7!0(B $(7!1(B $(7!2(B $(7!3(B $(7!4(B $(7!5(B $(7!6(B $(7!7(B $(7!8(B $(7!9(B $(7!:(B $(7!;(B $(7!<(B $(7!=(B $(7!>(B $(7!?(B ; Punctuations, -;;;2140 $(7!@(B $(7!A(B $(7!B(B $(7!C(B $(7!D(B $(7!E(B $(7!F(B $(7!G(B $(7!H(B $(7!I(B $(7!J(B $(7!K(B $(7!L(B $(7!M(B $(7!N(B $(7!O(B ; Digits and -;;;2150 $(7!P(B $(7!Q(B $(7!R(B $(7!S(B $(7!T(B $(7!U(B $(7!V(B $(7!W(B $(7!X(B $(7!Y(B $(7!Z(B $(7![(B $(7!\(B $(7!](B $(7!^(B $(7!_(B ; Special signs. -;;;2160 $(7!`(B $(7!a(B $(7!b(B $(7!c(B $(7!d(B $(7!e(B $(7!f(B $(7!g(B $(7!h(B $(7!i(B $(7!j(B $(7!k(B $(7!l(B $(7!m(B $(7!n(B $(7!o(B ; -;;;2170 $(7!p(B $(7!q(B $(7!r(B $(7!s(B $(7!t(B $(7!u(B $(7!v(B $(7!w(B $(7!x(B $(7!y(B $(7!z(B $(7!{(B $(7!|(B $(7!}(B $(7!~(B // ; -;;; -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2220 // $(7"!(B $(7""(B $(7"#(B $(7"$(B $(7"%(B $(7"&(B $(7"'(B $(7"((B $(7")(B $(7"*(B $(7"+(B $(7",(B $(7"-(B $(7".(B $(7"/(B ; Base consonants -;;;2230 $(7"0(B $(7"1(B $(7"2(B $(7"3(B $(7"4(B $(7"5(B $(7"6(B $(7"7(B $(7"8(B $(7"9(B $(7":(B $(7";(B $(7"<(B $(7"=(B $(7">(B $(7"?(B ; and -;;;2240 $(7"@(B $(7"A(B $(7"B(B $(7"C(B $(7"D(B $(7"E(B $(7"F(B $(7"G(B $(7"H(B $(7"I(B $(7"J(B $(7"K(B $(7"L(B $(7"M(B $(7"N(B $(7"O(B ; Vowel signs. -;;;2250 $(7"P(B $(7"Q(B $(7"R(B $(7"S(B $(7"T(B $(7"U(B $(7"V(B $(7"W(B $(7"X(B $(7"Y(B $(7"Z(B $(7"[(B $(7"\(B $(7"](B $(7"^(B $(7"_(B ; (\x2251 = vowel a) -;;;2260 $(7"`(B $(7"a(B $(7"b(B $(7"c(B $(7"d(B $(7"e(B $(7"f(B $(7"g(B $(7"h(B $(7"i(B $(7"j(B $(7"k(B $(7"l(B $(7"m(B $(7"n(B $(7"o(B ; Long vowels and -;;;2270 $(7"p(B $(7"q(B $(7"r(B $(7"s(B $(7"t(B $(7"u(B $(7"v(B $(7"w(B $(7"x(B $(7"y(B $(7"z(B $(7"{(B $(7"|(B $(7"}(B $(7"~(B // ; vocalic r, l are -;;; ; not atomically -;;; ; encoded. -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2320 // $(7#!(B $(7#"(B $(7##(B $(7#$(B $(7#%(B $(7#&(B $(7#'(B $(7#((B $(7#)(B $(7#*(B $(7#+(B $(7#,(B $(7#-(B $(7#.(B $(7#/(B ; Subjoined consonants -;;;2330 $(7#0(B $(7#1(B $(7#2(B $(7#3(B $(7#4(B $(7#5(B $(7#6(B $(7#7(B $(7#8(B $(7#9(B $(7#:(B $(7#;(B $(7#<(B $(7#=(B $(7#>(B $(7#?(B ; -;;;2340 $(7#@(B $(7#A(B $(7#B(B $(7#C(B $(7#D(B $(7#E(B $(7#F(B $(7#G(B $(7#H(B $(7#I(B $(7#J(B $(7#K(B $(7#L(B $(7#M(B $(7#N(B $(7#O(B ; 'a chung (\x2341)is -;;; ; here, -;;; ; while in Unicode -;;; ; it is classified -;;; ; as a vowel sign -;;; ; (\x0f71). -;;; -;;;2350 $(7#P(B $(7#Q(B $(7#R(B $(7#S(B $(7#T(B $(7#U(B $(7#V(B $(7#W(B $(7#X(B $(7#Y(B $(7#Z(B $(7#[(B $(7#\(B $(7#](B $(7#^(B $(7#_(B ; Hereafter, the chars -;;;2360 $(7#`(B $(7#a(B $(7#b(B $(7#c(B $(7#d(B $(7#e(B $(7#f(B $(7#g(B $(7#h(B $(7#i(B $(7#j(B $(7#k(B $(7#l(B $(7#m(B $(7#n(B $(7#o(B ; are not specified -;;;2370 $(7#p(B $(7#q(B $(7#r(B $(7#s(B $(7#t(B $(7#u(B $(7#v(B $(7#w(B $(7#x(B $(7#y(B $(7#z(B $(7#{(B $(7#|(B $(7#}(B $(7#~(B // ; in Unicode. -;;; ; The character \x2351 -;;; ; is not used in our -;;; ; implementation. -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2420 // $(7$!(B $(7$"(B $(7$#(B $(7$$(B $(7$%(B $(7$&(B $(7$'(B $(7$((B $(7$)(B $(7$*(B $(7$+(B $(7$,(B $(7$-(B $(7$.(B $(7$/(B ; Precomposed -;;;2430 $(7$0(B $(7$1(B $(7$2(B $(7$3(B $(7$4(B $(7$5(B $(7$6(B $(7$7(B $(7$8(B $(7$9(B $(7$:(B $(7$;(B $(7$<(B $(7$=(B $(7$>(B $(7$?(B ; consonants for -;;;2440 $(7$@(B $(7$A(B $(7$B(B $(7$C(B $(7$D(B $(7$E(B $(7$F(B $(7$G(B $(7$H(B $(7$I(B $(7$J(B $(7$K(B $(7$L(B $(7$M(B $(7$N(B $(7$O(B ; ordinary Tibetan. -;;;2450 $(7$P(B $(7$Q(B $(7$R(B $(7$S(B $(7$T(B $(7$U(B $(7$V(B $(7$W(B $(7$X(B $(7$Y(B $(7$Z(B $(7$[(B $(7$\(B $(7$](B $(7$^(B $(7$_(B ; They are decomposed -;;;2460 $(7$`(B $(7$a(B $(7$b(B $(7$c(B $(7$d(B $(7$e(B $(7$f(B $(7$g(B $(7$h(B $(7$i(B $(7$j(B $(7$k(B $(7$l(B $(7$m(B $(7$n(B $(7$o(B ; into base and -;;;2470 $(7$p(B $(7$q(B $(7$r(B $(7$s(B $(7$t(B $(7$u(B $(7$v(B $(7$w(B $(7$x(B $(7$y(B $(7$z(B $(7${(B $(7$|(B $(7$}(B $(7$~(B // ; subjoined consonants -;;; ; when written on a -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ; file in Tibetan -;;;2520 // $(7%!(B $(7%"(B $(7%#(B $(7%$(B $(7%%(B $(7%&(B $(7%'(B $(7%((B $(7%)(B $(7%*(B $(7%+(B $(7%,(B $(7%-(B $(7%.(B $(7%/(B ; coding system. -;;;2530 $(7%0(B $(7%1(B $(7%2(B $(7%3(B $(7%4(B $(7%5(B $(7%6(B $(7%7(B $(7%8(B $(7%9(B $(7%:(B $(7%;(B $(7%<(B $(7%=(B $(7%>(B $(7%?(B ; -;;;2540 $(7%@(B $(7%A(B $(7%B(B $(7%C(B $(7%D(B $(7%E(B $(7%F(B $(7%G(B $(7%H(B $(7%I(B $(7%J(B $(7%K(B $(7%L(B $(7%M(B $(7%N(B $(7%O(B ; -;;;2550 $(7%P(B $(7%Q(B $(7%R(B $(7%S(B $(7%T(B $(7%U(B $(7%V(B $(7%W(B $(7%X(B $(7%Y(B $(7%Z(B $(7%[(B $(7%\(B $(7%](B $(7%^(B $(7%_(B ; -;;;2560 $(7%`(B $(7%a(B $(7%b(B $(7%c(B $(7%d(B $(7%e(B $(7%f(B $(7%g(B $(7%h(B $(7%i(B $(7%j(B $(7%k(B $(7%l(B $(7%m(B $(7%n(B $(7%o(B ; -;;;2570 $(7%p(B $(7%q(B $(7%r(B $(7%s(B $(7%t(B $(7%u(B $(7%v(B $(7%w(B $(7%x(B $(7%y(B $(7%z(B $(7%{(B $(7%|(B $(7%}(B $(7%~(B // ; -;;; - - -(make-coding-system - 'tibetan 2 ?Q - "8-bit encoding for ASCII (MSB=0) and TIBETAN (MSB=1)" - '((ascii t) (tibetan t) nil nil - nil ascii-eol)) - -(put 'tibetan 'post-read-conversion 'tibetan-post-read-conversion) -(put 'tibetan 'pre-write-conversion 'tibetan-pre-write-conversion) - -(set-language-info-alist - "Tibetan" '((setup-function . setup-tibetan-environment) - (charset . (tibetan tibetan-1-column)) - (coding-system . (tibetan)) - (documentation . t) - (sample-text . -"Tibetan (2$(7"70"]1"2$(8!;2$(7%P`"Q1"2$(8!;(B) 2$(7#RP#SP#S1!>"72$P`"Q1$(8!;2$(7"E0"S1"G$(8!;$(7"72"20"[1$(8!;2$(7"D0"[1"#"G!>2"I0"]0"_1$(8!;2$(7"9`"Q1$(8!;2$(7"/0"S1$(8!;2$(7"5`"Q12#2`#90"[1$(8!;2$(7"H`#A`"U0"c1!>(B"))) - - -;;; -;;; Definitions of conversion data. -;;; - - -;;; alists for tibetan char <-> transcription conversion -;;; longer transcription should come first -(defconst tibetan-consonant-transcription-alist - '(("tsh" . "$(7";(B") - ("dzh" . "$(7"=(B") - ("kSH" . "$(7"J(B") - ("kh" . "$(7""(B") - ("gh" . "$(7"$(B") - ("ng" . "$(7"%(B") - ("ch" . "$(7"'(B") - ("ny" . "$(7"*(B") - ("TH" . "$(7",(B") - ("DH" . "$(7".(B") - ("th" . "$(7"1(B") - ("dh" . "$(7"3(B") - ("ph" . "$(7"6(B") - ("bh" . "$(7"8(B") - ("ts" . "$(7":(B") - ("dz" . "$(7"<(B") - ("zh" . "$(7"?(B") - ("sh" . "$(7"E(B") - ("SH" . "$(7"F(B") - ("k" . "$(7"!(B") - ("g" . "$(7"#(B") - ("c" . "$(7"&(B") - ("j" . "$(7"((B") - ("T" . "$(7"+(B") - ("D" . "$(7"-(B") - ("N" . "$(7"/(B") - ("t" . "$(7"0(B") - ("d" . "$(7"2(B") - ("n" . "$(7"4(B") - ("p" . "$(7"5(B") - ("b" . "$(7"7(B") - ("m" . "$(7"9(B") - ("w" . "$(7">(B") - ("z" . "$(7"@(B") - ("'" . "$(7"A(B") - ("y" . "$(7"B(B") - ("r" . "$(7"C(B") - ("l" . "$(7"D(B") - ("s" . "$(7"G(B") - ("h" . "$(7"H(B") - ("H" . "$(7"H(B") - ("A" . "$(7"I(B"))) - - -(defconst tibetan-vowel-transcription-alist - '(("ai" . "$(7"\(B") - ("au" . "$(7"^(B") - ("ee" . "$(7"\(B") - ("oo" . "$(7"^(B") - ("a" . "$(7"Q(B") ; invisible vowel sign (\x2251) - ("i" . "$(7"S(B") - ("u" . "$(7"U(B") - ("e" . "$(7"[(B") - ("o" . "$(7"](B") - ("E" . "$(7"\(B") - ("O" . "$(7"^(B") - ("I" . "$(7"a(B") - ("M" . "$(7"_(B") - ("~" . "$(7"c(B") ; not specified in Ext.wylie - ("`" . "$(7"d(B") ; idem. - ("," . "$(7"e(B") ; idem. - ("v" . "$(7"g(B") ; idem. - ("V" . "$(7"h(B") ; idem. - ("x" . "$(7"i(B") ; idem. - ("X" . "$(7"j(B") ; idem. - ("q" . "$(7"k(B") ; idem. - ("Q" . "$(7"l(B") ; idem. - ("_o" . "$(7!g(B") ; idem. - ("_O" . "$(7!e(B") ; idem. - ("_/" . "$(7!I(B") ; idem. - )) - -(defconst tibetan-precomposed-transcription-alist - '(("phyw" . "$(7$G(B") - ("tshw" . "$(7$)(B") - ("rtsw" . "$(7%.(B") - ("khw" . "$(7$"(B") - ("nyw" . "$(7$%(B") - ("tsw" . "$(7$((B") - ("zhw" . "$(7$*(B") - ("shw" . "$(7$.(B") - ("khy" . "$(7$A(B") - ("phy" . "$(7$D(B") - ("khr" . "$(7$Q(B") - ("thr" . "$(7$T(B") - ("phr" . "$(7$W(B") - ("shr" . "$(7$Z(B") - ("dzr" . "$(7$^(B") - ("grw" . "$(7$_(B") - ("rng" . "$(7%#(B") - ("rny" . "$(7%%(B") - ("rts" . "$(7%+(B") - ("rdz" . "$(7%,(B") - ("rgw" . "$(7%-(B") - ("rky" . "$(7%0(B") - ("rgy" . "$(7%1(B") - ("rmy" . "$(7%2(B") - ("lng" . "$(7%B(B") - ("sng" . "$(7%R(B") - ("sny" . "$(7%S(B") - ("sts" . "$(7%Z(B") - ("sky" . "$(7%`(B") - ("sgy" . "$(7%a(B") - ("spy" . "$(7%b(B") - ("sby" . "$(7%c(B") - ("smy" . "$(7%d(B") - ("skr" . "$(7%p(B") - ("sgr" . "$(7%q(B") - ("snr" . "$(7%r(B") - ("spr" . "$(7%s(B") - ("sbr" . "$(7%t(B") - ("smr" . "$(7%u(B") - ("kw" . "$(7$!(B") - ("gw" . "$(7$#(B") - ("cw" . "$(7$$(B") - ("tw" . "$(7$&(B") - ("dw" . "$(7$'(B") - ("zw" . "$(7$+(B") - ("rw" . "$(7$,(B") - ("lw" . "$(7$-(B") - ("sw" . "$(7$/(B") - ("hw" . "$(7$0(B") - ("ky" . "$(7$@(B") - ("gy" . "$(7$B(B") - ("py" . "$(7$C(B") - ("by" . "$(7$E(B") - ("my" . "$(7$F(B") - ("kr" . "$(7$P(B") - ("gr" . "$(7$R(B") - ("tr" . "$(7$S(B") - ("dr" . "$(7$U(B") - ("pr" . "$(7$V(B") - ("brk" . "$(7"7%!(B") - ("brg" . "$(7"7%"(B") - ("brng" . "$(7"7%#(B") - ("brj" . "$(7"7%$(B") - ("brny" . "$(7"7%%(B") - ("brt" . "$(7"7%&(B") - ("brd" . "$(7"7%'(B") - ("brn" . "$(7"7%((B") - ("brts" . "$(7"7%+(B") - ("brdz" . "$(7"7%,(B") - ("brl" . "$(7"7$d(B") - ("br" . "$(7$X(B") - ("mr" . "$(7$Y(B") - ("sr" . "$(7$[(B") - ("hr" . "$(7$\(B") - ("jr" . "$(7$](B") - ("kl" . "$(7$`(B") - ("gl" . "$(7$a(B") - ("blt" . "$(7"7%E(B") - ("bld" . "$(7"7%F(B") - ("bl" . "$(7$b(B") - ("zl" . "$(7$c(B") - ("rl" . "$(7$d(B") - ("sl" . "$(7$e(B") - ("rk" . "$(7%!(B") - ("rg" . "$(7%"(B") - ("rj" . "$(7%$(B") - ("rt" . "$(7%&(B") - ("rd" . "$(7%'(B") - ("rn" . "$(7%((B") - ("rb" . "$(7%)(B") - ("rm" . "$(7%*(B") - ("lk" . "$(7%@(B") - ("lg" . "$(7%A(B") - ("lc" . "$(7%C(B") - ("lj" . "$(7%D(B") - ("lt" . "$(7%E(B") - ("ld" . "$(7%F(B") - ("ln" . "$(7!!(B") ; dummy \x2121 - ("lp" . "$(7%G(B") - ("lb" . "$(7%H(B") - ("lh" . "$(7%I(B") - ("sk" . "$(7%P(B") - ("sg" . "$(7%Q(B") - ("st" . "$(7%T(B") - ("sd" . "$(7%U(B") - ("sn" . "$(7%V(B") - ("sp" . "$(7%W(B") - ("sb" . "$(7%X(B") - ("sm" . "$(7%Y(B"))) - -(defconst tibetan-subjoined-transcription-alist - '(("+k" . "$(7#!(B") - ("+kh" . "$(7#"(B") - ("+g" . "$(7##(B") - ("+gh" . "$(7#$(B") - ("+ng" . "$(7#%(B") - ("+c" . "$(7#&(B") - ("+ch" . "$(7#'(B") - ("+j" . "$(7#((B") - ("+ny" . "$(7#*(B") - ("+T" . "$(7#+(B") - ("+TH" . "$(7#,(B") - ("+D" . "$(7#-(B") - ("+DH" . "$(7#.(B") - ("+N" . "$(7#/(B") - ("+t" . "$(7#0(B") - ("+th" . "$(7#1(B") - ("+d" . "$(7#2(B") - ("+dh" . "$(7#3(B") - ("+n" . "$(7#4(B") - ("+p" . "$(7#5(B") - ("+ph" . "$(7#6(B") - ("+b" . "$(7#7(B") - ("+bh" . "$(7#8(B") - ("+m" . "$(7#9(B") - ("+ts" . "$(7#:(B") - ("+tsh" . "$(7#;(B") - ("+dz" . "$(7#<(B") - ("+dzh" . "$(7#=(B") - ("+w" . "$(7#>(B") - ("+zh" . "$(7#?(B") - ("+z" . "$(7#@(B") - ("+'" . "$(7#A(B") - ("+y" . "$(7#B(B") - ("+r" . "$(7#C(B") - ("+l" . "$(7#D(B") - ("+sh" . "$(7#E(B") - ("+SH" . "$(7#F(B") - ("+s" . "$(7#G(B") - ("+h" . "$(7#H(B") - ("+A" . "$(7#I(B") - ("+kSH" . "$(7#J(B") - ("R" . "$(7#P(B"))) - -;;; -;;; alist for Tibetan base consonant <-> subjoined consonant conversion. -;;; -(defconst tibetan-base-to-subjoined-alist - '(("$(7"!(B" . "$(7#!(B") - ("$(7""(B" . "$(7#"(B") - ("$(7"#(B" . "$(7##(B") - ("$(7"$(B" . "$(7#$(B") - ("$(7"%(B" . "$(7#%(B") - ("$(7"&(B" . "$(7#&(B") - ("$(7"'(B" . "$(7#'(B") - ("$(7"((B" . "$(7#((B") - ("$(7"*(B" . "$(7#*(B") - ("$(7"+(B" . "$(7#+(B") - ("$(7",(B" . "$(7#,(B") - ("$(7"-(B" . "$(7#-(B") - ("$(7".(B" . "$(7#.(B") - ("$(7"/(B" . "$(7#/(B") - ("$(7"0(B" . "$(7#0(B") - ("$(7"1(B" . "$(7#1(B") - ("$(7"2(B" . "$(7#2(B") - ("$(7"3(B" . "$(7#3(B") - ("$(7"4(B" . "$(7#4(B") - ("$(7"5(B" . "$(7#5(B") - ("$(7"6(B" . "$(7#6(B") - ("$(7"7(B" . "$(7#7(B") - ("$(7"8(B" . "$(7#8(B") - ("$(7"9(B" . "$(7#9(B") - ("$(7":(B" . "$(7#:(B") - ("$(7";(B" . "$(7#;(B") - ("$(7"<(B" . "$(7#<(B") - ("$(7"=(B" . "$(7#=(B") - ("$(7">(B" . "$(7#>(B") - ("$(7"?(B" . "$(7#?(B") - ("$(7"@(B" . "$(7#@(B") - ("$(7"A(B" . "$(7#A(B") - ("$(7"B(B" . "$(7#B(B") - ("$(7"C(B" . "$(7#C(B") - ("$(7"D(B" . "$(7#D(B") - ("$(7"E(B" . "$(7#E(B") - ("$(7"F(B" . "$(7#F(B") - ("$(7"G(B" . "$(7#G(B") - ("$(7"H(B" . "$(7#H(B") - ("$(7"I(B" . "$(7#I(B") - ("$(7"J(B" . "$(7#J(B"))) - -;;; -;;; alist for Tibetan consonantic components <-> precomposed glyph conversion. -;;; (includes some punctuation conversion rules) -;;; -(defconst tibetan-precomposition-rule-alist - '(("$(7"6#B#>(B" . "$(7$G(B") - ("$(7"##C#>(B" . "$(7$_(B") - ("$(7";#>(B" . "$(7$)(B") - ("$(7"C#:#>(B" . "$(7%.(B") - ("$(7"C###>(B" . "$(7%-(B") - ("$(7"C#!#B(B" . "$(7%0(B") - ("$(7"C###B(B" . "$(7%1(B") - ("$(7"C#9#B(B" . "$(7%2(B") - ("$(7"G#!#B(B" . "$(7%`(B") - ("$(7"G###B(B" . "$(7%a(B") - ("$(7"G#5#B(B" . "$(7%b(B") - ("$(7"G#7#B(B" . "$(7%c(B") - ("$(7"G#9#B(B" . "$(7%d(B") - ("$(7"G#!#C(B" . "$(7%p(B") - ("$(7"G###C(B" . "$(7%q(B") - ("$(7"G#4#C(B" . "$(7%r(B") - ("$(7"G#5#C(B" . "$(7%s(B") - ("$(7"G#7#C(B" . "$(7%t(B") - ("$(7"G#9#C(B" . "$(7%u(B") - ("$(7""#>(B" . "$(7$"(B") - ("$(7"*#>(B" . "$(7$%(B") - ("$(7":#>(B" . "$(7$((B") - ("$(7"?#>(B" . "$(7$*(B") - ("$(7"E#>(B" . "$(7$.(B") - ("$(7""#B(B" . "$(7$A(B") - ("$(7"6#B(B" . "$(7$D(B") - ("$(7""#C(B" . "$(7$Q(B") - ("$(7"1#C(B" . "$(7$T(B") - ("$(7"6#C(B" . "$(7$W(B") - ("$(7"E#C(B" . "$(7$Z(B") - ("$(7"<#C(B" . "$(7$^(B") - ("$(7"C#%(B" . "$(7%#(B") - ("$(7"C#*(B" . "$(7%%(B") - ("$(7"C#:(B" . "$(7%+(B") - ("$(7"C#<(B" . "$(7%,(B") - ("$(7"D#%(B" . "$(7%B(B") - ("$(7"G#%(B" . "$(7%R(B") - ("$(7"G#*(B" . "$(7%S(B") - ("$(7"G#:(B" . "$(7%Z(B") - ("$(7"!#>(B" . "$(7$!(B") - ("$(7"##>(B" . "$(7$#(B") - ("$(7"&#>(B" . "$(7$$(B") - ("$(7"0#>(B" . "$(7$&(B") - ("$(7"2#>(B" . "$(7$'(B") - ("$(7"@#>(B" . "$(7$+(B") - ("$(7"C#>(B" . "$(7$,(B") - ("$(7"D#>(B" . "$(7$-(B") - ("$(7"G#>(B" . "$(7$/(B") - ("$(7"H#>(B" . "$(7$0(B") - ("$(7"!#B(B" . "$(7$@(B") - ("$(7"##B(B" . "$(7$B(B") - ("$(7"5#B(B" . "$(7$C(B") - ("$(7"7#B(B" . "$(7$E(B") - ("$(7"9#B(B" . "$(7$F(B") - ("$(7"!#C(B" . "$(7$P(B") - ("$(7"##C(B" . "$(7$R(B") - ("$(7"0#C(B" . "$(7$S(B") - ("$(7"2#C(B" . "$(7$U(B") - ("$(7"5#C(B" . "$(7$V(B") - ("$(7"7#C(B" . "$(7$X(B") - ("$(7"9#C(B" . "$(7$Y(B") - ("$(7"G#C(B" . "$(7$[(B") - ("$(7"H#C(B" . "$(7$\(B") - ("$(7"(#C(B" . "$(7$](B") - ("$(7"!#D(B" . "$(7$`(B") - ("$(7"##D(B" . "$(7$a(B") - ("$(7"7#D(B" . "$(7$b(B") - ("$(7"@#D(B" . "$(7$c(B") - ("$(7"C#D(B" . "$(7$d(B") - ("$(7"G#D(B" . "$(7$e(B") - ("$(7"C#!(B" . "$(7%!(B") - ("$(7"C##(B" . "$(7%"(B") - ("$(7"C#((B" . "$(7%$(B") - ("$(7"C#0(B" . "$(7%&(B") - ("$(7"C#2(B" . "$(7%'(B") - ("$(7"C#4(B" . "$(7%((B") - ("$(7"C#7(B" . "$(7%)(B") - ("$(7"C#9(B" . "$(7%*(B") - ("$(7"D#!(B" . "$(7%@(B") - ("$(7"D##(B" . "$(7%A(B") - ("$(7"D#&(B" . "$(7%C(B") - ("$(7"D#((B" . "$(7%D(B") - ("$(7"D#0(B" . "$(7%E(B") - ("$(7"D#2(B" . "$(7%F(B") - ("$(7"D#5(B" . "$(7%G(B") - ("$(7"D#7(B" . "$(7%H(B") - ("$(7"D#H(B" . "$(7%I(B") - ("$(7"G#!(B" . "$(7%P(B") - ("$(7"G##(B" . "$(7%Q(B") - ("$(7"G#0(B" . "$(7%T(B") - ("$(7"G#2(B" . "$(7%U(B") - ("$(7"G#4(B" . "$(7%V(B") - ("$(7"G#5(B" . "$(7%W(B") - ("$(7"G#7(B" . "$(7%X(B") - ("$(7"G#9(B" . "$(7%Y(B") - ("$(7!=(B" . "$(8!=(B") ; 2 col <-> 1 col - ("$(7!?(B" . "$(8!?(B") - ("$(7!@(B" . "$(8!@(B") - ("$(7!A(B" . "$(8!A(B") - ("$(7"`(B" . "$(8"`(B") - ("$(7!;(B" . "$(8!;(B") - ("$(7!D(B" . "$(8!D(B") - ("$(7!>(B $(7!>(B" . "2$(7!>P(B P$(7!>1(B") ; Yes this is dirty. But ... - ("$(7!4!5!5(B" . "2$(7#RP#SP#SP#S1(B") - ("$(7!4!5(B" . "2$(7#RP#SP#S1(B") - ("$(7!6(B" . "2$(7#RP#S_!I1(B") - ("$(7!4(B" . "2$(7#RP#S1(B"))) - -(defvar tibetan-regexp - (let ((l (append tibetan-consonant-transcription-alist - tibetan-vowel-transcription-alist - tibetan-subjoined-transcription-alist)) - temp) - (setq temp "\\(") - (setq temp (concat temp (car (car l)))) - (setq l (cdr l)) - (while l - (setq temp (concat temp "\\|" (car (car l)))) - (setq l (cdr l))) - (concat temp "\\)$")) - "Regexp string to match a romanized Tibetan character component, i.e., -base and subjoined consonant, vowel and vowel modifier. The result of matching -is to be used for indexing alists at conversion from a roman transcription to -the corresponding Tibetan character.") - -(defvar tibetan-precomposed-regexp - (let ((l tibetan-precomposed-transcription-alist) - temp) - (setq temp "^\\(") - (setq temp - (concat temp (car (car l)))) - (setq l (cdr l)) - (while l - (setq temp - (concat temp "\\|" (car (car l)))) - (setq l (cdr l))) - (concat temp "\\)")) - "Regexp string to match a romanized Tibetan complex consonant. -The result of matching is to be used for indexing alists when the input key -from an input method is converted to the corresponding precomposed glyph.") - -(defvar tibetan-precomposition-rule-regexp - (let ((l tibetan-precomposition-rule-alist) - temp) - (setq temp "\\(") - (setq temp (concat temp (car (car l)))) - (setq l (cdr l)) - (while l - (setq temp (concat temp "\\|" (car (car l)))) - (setq l (cdr l))) - (concat temp "\\)")) - "Regexp string to match a sequence of Tibetan consonantic components, i.e., -one base consonant and one or more subjoined consonants. -The result of matching is to be used for indexing alist when the component -sequence is converted to the corresponding precomposed glyph. -This also matches some punctuation characters which need conversion.") - -(defvar tibetan-decomposed nil) -(defvar tibetan-decomposed-temp nil) - -;;; language/tibetan.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/viet-chars.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/language/viet-chars.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,57 @@ +;;; vietnamese-chars.el --- pre-loaded support for Vietnamese, part 1. + +;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. +;; Copyright (C) 1995 Amdahl Corporation. +;; Copyright (C) 1995 Sun Microsystems. + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Mule 2.3. + +;; We have to split up the Vietnamese stuff into two files because +;; we are registering new charsets and then immediately using characters +;; from those sets. We cannot reliably expect this to work if they +;; are in the same file because of the buffering that happens while +;; reading -- the place where we use the newly-defined sets may be +;; read in before the code that creates those sets is evaluated. + +;; Vietnamese VISCII with two tables. +(make-charset 'vietnamese-viscii-lower "VISCII lower (Vietnamese)" + '(registry "VISCII1.1" + dimension 1 + chars 96 + final ?1 + graphic 1 + )) + +(make-charset 'vietnamese-viscii-upper "VISCII upper (Vietnamese)" + '(registry "VISCII1.1" + dimension 1 + chars 96 + final ?2 + graphic 1 + )) + +(modify-syntax-entry 'vietnamese-viscii-lower "w") +(modify-syntax-entry 'vietnamese-viscii-upper "w") + +(define-category ?v "Vietnamese character.") +(modify-category-entry 'vietnamese-viscii-lower ?v) +(modify-category-entry 'vietnamese-viscii-upper ?v) + +;;; vietnamese-chars.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/viet-util.el --- a/lisp/language/viet-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,296 +0,0 @@ -;;; viet-util.el --- utilities for Vietnamese - -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: mule, multilingual, Vietnamese - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Vietnamese uses ASCII characters and additional 134 unique -;; characters (these are Latin alphabets with various diacritical and -;; tone marks). As far as I know, Vietnamese now has 4 different ways -;; for representing these characters: VISCII, VSCII, VIQR, and -;; Unicode. VISCII and VSCII are simple 1-byte code which assigns 134 -;; unique characters in control-code area (0x00..0x1F) and right half -;; area (0x80..0xFF). VIQR is a menmonic encoding specification -;; representing diacritical marks by following ASCII characters. - -;;; Code: - -;;;###autoload -(defun setup-vietnamese-environment () - "Setup multilingual environment (MULE) for Vietnamese VISCII users." - (interactive) - (setup-8-bit-environment "Vietnamese" nil 'vietnamese-viscii - "vietnamese-viqr") - (setq coding-category-raw-text 'vietnamese-viscii)) - -;; VIQR is a menmonic encoding specification for Vietnamese. -;; It represents diacritical marks by ASCII characters as follows: -;; ------------+----------+-------- -;; mark | mnemonic | example -;; ------------+----------+--------- -;; breve | ( | a( -> ,1e(B -;; circumflex | ^ | a^ -> ,1b(B -;; horn | + | o+ -> ,1=(B -;; ------------+----------+--------- -;; acute | ' | a' -> ,1a(B -;; grave | ` | a` -> ,1`(B -;; hook above | ? | a? -> ,1d(B -;; tilde | ~ | a~ -> ,1c(B -;; dot below | . | a. -> ,1U(B -;; ------------+----------+--------- -;; d bar | dd | dd -> ,1p(B -;; ------------+----------+--------- - -(defvar viet-viqr-alist - '(;; lowercase - (?,1!(B . "a('") ; 161 - (?,1"(B . "a(`") ; 162 - (?,1#(B . "a(.") ; 163 - (?,1$(B . "a^'") ; 164 - (?,1%(B . "a^`") ; 165 - (?,1&(B . "a^?") ; 166 - (?,1'(B . "a^.") ; 167 - (?,1((B . "e~") ; 168 - (?,1)(B . "e.") ; 169 - (?,1*(B . "e^'") ; 170 - (?,1+(B . "e^`") ; 171 - (?,1,(B . "e^?") ; 172 - (?,1-(B . "e^~") ; 173 - (?,1.(B . "e^.") ; 174 - (?,1/(B . "o^'") ; 175 - (?,10(B . "o^`") ; 176 - (?,11(B . "o^?") ; 177 - (?,12(B . "o^~") ; 178 - (?,15(B . "o^.") ; 181 - (?,16(B . "o+`") ; 182 - (?,17(B . "o+?") ; 183 - (?,18(B . "i.") ; 184 - (?,1=(B . "o+") ; 189 - (?,1>(B . "o+'") ; 190 - (?,1F(B . "a(?") ; 198 - (?,1G(B . "a(~") ; 199 - (?,1O(B . "y`") ; 207 - (?,1Q(B . "u+'") ; 209 - (?,1U(B . "a.") ; 213 - (?,1V(B . "y?") ; 214 - (?,1W(B . "u+`") ; 215 - (?,1X(B . "u+?") ; 216 - (?,1[(B . "y~") ; 219 - (?,1\(B . "y.") ; 220 - (?,1^(B . "o+~") ; 222 - (?,1_(B . "u+") ; 223 - (?,1`(B . "a`") ; 224 - (?,1a(B . "a'") ; 225 - (?,1b(B . "a^") ; 226 - (?,1c(B . "a~") ; 227 - (?,1d(B . "a?") ; 228 - (?,1e(B . "a(") ; 229 - (?,1f(B . "u+~") ; 230 - (?,1g(B . "a^~") ; 231 - (?,1h(B . "e`") ; 232 - (?,1i(B . "e'") ; 233 - (?,1j(B . "e^") ; 234 - (?,1k(B . "e?") ; 235 - (?,1l(B . "i`") ; 236 - (?,1m(B . "i'") ; 237 - (?,1n(B . "i~") ; 238 - (?,1o(B . "i?") ; 239 - (?,1p(B . "dd") ; 240 - (?,1q(B . "u+.") ; 241 - (?,1r(B . "o`") ; 242 - (?,1s(B . "o'") ; 243 - (?,1t(B . "o^") ; 244 - (?,1u(B . "o~") ; 245 - (?,1v(B . "o?") ; 246 - (?,1w(B . "o.") ; 247 - (?,1x(B . "u.") ; 248 - (?,1y(B . "u`") ; 249 - (?,1z(B . "u'") ; 250 - (?,1{(B . "u~") ; 251 - (?,1|(B . "u?") ; 252 - (?,1}(B . "y'") ; 253 - (?,1~(B . "o+.") ; 254 - - ;; upper case - (?,2!(B . "A('") ; 161 - (?,2"(B . "A(`") ; 162 - (?,2#(B . "A(.") ; 163 - (?,2$(B . "A^'") ; 164 - (?,2%(B . "A^`") ; 165 - (?,2&(B . "A^?") ; 166 - (?,2'(B . "A^.") ; 167 - (?,2((B . "E~") ; 168 - (?,2)(B . "E.") ; 169 - (?,2*(B . "E^'") ; 170 - (?,2+(B . "E^`") ; 171 - (?,2,(B . "E^?") ; 172 - (?,2-(B . "E^~") ; 173 - (?,2.(B . "E^.") ; 174 - (?,2/(B . "O^'") ; 175 - (?,20(B . "O^`") ; 176 - (?,21(B . "O^?") ; 177 - (?,22(B . "O^~") ; 178 - (?,25(B . "O^.") ; 181 - (?,26(B . "O+`") ; 182 - (?,27(B . "O+?") ; 183 - (?,28(B . "I.") ; 184 - (?,2=(B . "O+") ; 189 - (?,2>(B . "O+'") ; 190 - (?,2F(B . "A(?") ; 198 - (?,2G(B . "A(~") ; 199 - (?,2O(B . "Y`") ; 207 - (?,2Q(B . "U+'") ; 209 - (?,2U(B . "A.") ; 213 - (?,2V(B . "Y?") ; 214 - (?,2W(B . "U+`") ; 215 - (?,2X(B . "U+?") ; 216 - (?,2[(B . "Y~") ; 219 - (?,2\(B . "Y.") ; 220 - (?,2^(B . "O+~") ; 222 - (?,2_(B . "U+") ; 223 - (?,2`(B . "A`") ; 224 - (?,2a(B . "A'") ; 225 - (?,2b(B . "A^") ; 226 - (?,2c(B . "A~") ; 227 - (?,2d(B . "A?") ; 228 - (?,2e(B . "A(") ; 229 - (?,2f(B . "U+~") ; 230 - (?,2g(B . "A^~") ; 231 - (?,2h(B . "E`") ; 232 - (?,2i(B . "E'") ; 233 - (?,2j(B . "E^") ; 234 - (?,2k(B . "E?") ; 235 - (?,2l(B . "I`") ; 236 - (?,2m(B . "I'") ; 237 - (?,2n(B . "I~") ; 238 - (?,2o(B . "I?") ; 239 - (?,2p(B . "DD") ; 240 - (?,2p(B . "dD") ; 240 - (?,2p(B . "Dd") ; 240 - (?,2q(B . "U+.") ; 241 - (?,2r(B . "O`") ; 242 - (?,2s(B . "O'") ; 243 - (?,2t(B . "O^") ; 244 - (?,2u(B . "O~") ; 245 - (?,2v(B . "O?") ; 246 - (?,2w(B . "O.") ; 247 - (?,2x(B . "U.") ; 248 - (?,2y(B . "U`") ; 249 - (?,2z(B . "U'") ; 250 - (?,2{(B . "U~") ; 251 - (?,2|(B . "U?") ; 252 - (?,2}(B . "Y'") ; 253 - (?,2~(B . "O+.") ; 254 - - ;; escape from composition - (?\( . "\\(") ; breve (left parenthesis) - (?^ . "\\^") ; circumflex (caret) - (?+ . "\\+") ; horn (plus sign) - (?' . "\\'") ; acute (apostrophe) - (?` . "\\`") ; grave (backquote) - (?? . "\\?") ; hook above (question mark) - (?~ . "\\~") ; tilde (tilde) - (?. . "\\.") ; dot below (period) - (?d . "\\d") ; d-bar (d) - (?\\ . "\\\\") ; literal backslash - ) - "Alist of Vietnamese characters vs corresponding `VIQR' string.") - -;; Regular expression matching single Vietnamese character represented -;; by VIQR. -(defconst viqr-regexp - "[aeiouyAEIOUY]\\([(^+]?['`?~.]\\|[(^+]\\)\\|[Dd][Dd]") - -;;;###autoload -(defun viet-decode-viqr-region (from to) - "Convert `VIQR' mnemonics of the current region to Vietnamese characaters. -When called from a program, expects two arguments, -positions (integers or markers) specifying the stretch of the region." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward viqr-regexp nil t) - (let* ((viqr (buffer-substring (match-beginning 0) (match-end 0))) - (ch (car (rassoc viqr viet-viqr-alist)))) - (if ch - (progn - (delete-region (match-beginning 0) (match-end 0)) - (insert ch))))))) - -;;;###autoload -(defun viet-decode-viqr-buffer () - "Convert `VIQR' mnemonics of the current buffer to Vietnamese characaters." - (interactive) - (viet-decode-viqr-region (point-min) (point-max))) - -;;;###autoload -(defun viet-encode-viqr-region (from to) - "Convert Vietnamese characaters of the current region to `VIQR' mnemonics. -When called from a program, expects two arguments, -positions (integers or markers) specifying the stretch of the region." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward "\\cv" nil t) - (let* ((ch (preceding-char)) - (viqr (cdr (assq ch viet-viqr-alist)))) - (if viqr - (progn - (delete-char -1) - (insert viqr))))))) - -;;;###autoload -(defun viet-encode-viqr-buffer () - "Convert Vietnamese characaters of the current buffer to `VIQR' mnemonics." - (interactive) - (viet-encode-viqr-region (point-min) (point-max))) - -;;;###autoload -(defun viqr-post-read-conversion (len) - (save-excursion - (save-restriction - (narrow-to-region (point) (+ (point) len)) - (let ((buffer-modified-p (buffer-modified-p))) - (viet-decode-viqr-region (point-min) (point-max)) - (set-buffer-modified-p buffer-modified-p) - (- (point-max) (point-min)))))) - -;;;###autoload -(defun viqr-pre-write-conversion (from to) - (let ((old-buf (current-buffer)) - (work-buf (get-buffer-create " *viet-work*"))) - (set-buffer work-buf) - (erase-buffer) - (if (stringp from) - (insert from) - (insert-buffer-substring old-buf from to)) - (viet-encode-viqr-region (point-min) (point-max)) - ;; Should return nil as annotations. - nil)) - -;;; -(provide 'viet-util) - -;;; viet-util.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/vietnamese.el --- a/lisp/language/vietnamese.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/vietnamese.el Mon Aug 13 10:03:52 2007 +0200 @@ -2,25 +2,26 @@ ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. ;; Licensed to the Free Software Foundation. +;; Copyright (C) 1997 MORIOKA Tomohiko ;; Keywords: multilingual, Vietnamese -;; This file is part of GNU Emacs. +;; This file is part of XEmacs. -;; 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 +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; 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. +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. ;;; Commentary: @@ -106,135 +107,268 @@ ) -(define-ccl-program ccl-decode-viscii - `(3 - ((read r0) +(define-ccl-program ccl-read-viscii + `(((read r0) (loop - (write-read-repeat r0 ,viet-viscii-decode-table)) + (write-read-repeat r0 ,viet-viscii-decode-table)) )) - "CCL program to decode VISCII 1.1") + "CCL program to read VISCII 1.1") + +;; (define-ccl-program ccl-decode-viscii +;; `(3 +;; ((read r0) +;; (loop +;; (write-read-repeat r0 ,viet-viscii-decode-table)) +;; )) +;; "CCL program to decode VISCII 1.1") ;; Multibyte form of a Vietnamese character is as follows (3-byte): ;; LEADING-CODE-PRIVATE-11 LEADING-CODE-EXTENDED-11 POSITION-CODE ;; where LEADING-CODE-EXTENDED-11 for Vietnamese is ;; `vietnamese-viscii-lower' or `vietnamese-viscii-upper'. -(define-ccl-program ccl-encode-viscii - `(1 - ((read r0) - (loop +(define-ccl-program ccl-write-viscii + `(((read r0) + (loop (if (r0 < 128) - ;; ASCII (write-read-repeat r0) - ;; not ASCII - (if (r0 != ,leading-code-private-11) - ;; not Vietnamese + (if (r0 != 154) (write-read-repeat r0) - ((read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (;; Vietnamese lower - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(car viet-viscii-encode-table))) - (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) - (;; Vietnamese upper - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) - ;; not Vietnamese - (write-read-repeat r0))))))))) - "CCL program to encode VISCII 1.1") + ((read-if (r0 == 163) + ((read r0) + (r0 -= 160) + (write-read-repeat r0 ,(car viet-viscii-encode-table)) + (if (r0 == 164) + ((read r0) + (r0 -= 160) + (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) + (write-read-repeat r0)))))))))) + "CCL program to write VISCII 1.1") + +;; (define-ccl-program ccl-encode-viscii +;; `(1 +;; ((read r0) +;; (loop +;; (if (r0 < 128) +;; ;; ASCII +;; (write-read-repeat r0) +;; ;; not ASCII +;; (if (r0 != ,leading-code-private-11) +;; ;; not Vietnamese +;; (write-read-repeat r0) +;; ((read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (;; Vietnamese lower +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(car viet-viscii-encode-table))) +;; (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) +;; (;; Vietnamese upper +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) +;; ;; not Vietnamese +;; (write-read-repeat r0))))))))) +;; "CCL program to encode VISCII 1.1") -(define-ccl-program ccl-encode-viscii-font - `(0 - ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper - ;; R1:position code - ;; Out: R1:font code point - (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (r1 = r1 ,(car viet-viscii-encode-table)) - (r1 = r1 ,(cdr viet-viscii-encode-table))) - ) - "CCL program to encode Vietnamese chars to VISCII 1.1 font") +(define-ccl-program ccl-vietnamese-lower-to-viscii + `(((r1 = r1 + ,(car viet-viscii-encode-table)))) + "CCL program to convert chars of 'vietnamese-lower to VISCII 1.1 font") + +(define-ccl-program ccl-vietnamese-upper-to-viscii + `(((r1 = r1 + ,(cdr viet-viscii-encode-table)))) + "CCL program to convert chars of 'vietnamese-upper to VISCII 1.1 font") -(define-ccl-program ccl-decode-vscii - `(3 - ((read r0) +;; (define-ccl-program ccl-encode-viscii-font +;; `(0 +;; ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper +;; ;; R1:position code +;; ;; Out: R1:font code point +;; (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (r1 = r1 ,(car viet-viscii-encode-table)) +;; (r1 = r1 ,(cdr viet-viscii-encode-table))) +;; ) +;; "CCL program to encode Vietnamese chars to VISCII 1.1 font") + +(define-ccl-program ccl-read-vscii + `(((read r0) + (loop + (write-read-repeat r0 ,viet-vscii-decode-table)) + )) + "CCL program to read VSCII-1.") + +;; (define-ccl-program ccl-decode-vscii +;; `(3 +;; ((read r0) +;; (loop +;; (write-read-repeat r0 ,viet-vscii-decode-table)) +;; )) +;; "CCL program to decode VSCII-1.") + +(define-ccl-program ccl-write-vscii + `(((read r0) (loop - (write-read-repeat r0 ,viet-vscii-decode-table)) - )) - "CCL program to decode VSCII-1.") + (if (r0 < 128) + (write-read-repeat r0) + (if (r0 != 154) + (write-read-repeat r0) + (read-if (r0 == 163) + ((read r0) + (r0 -= 160) + (write-read-repeat r0 ,(car viet-vscii-encode-table))) + (if (r0 == 164) + ((read r0) + (r0 -= 160) + (write-read-repeat + r0 ,(cdr viet-viscii-encode-table))) + (write-read-repeat r0)))))))) + "CCL program to write VSCII-1.") + +;; (define-ccl-program ccl-encode-vscii +;; `(1 +;; ((read r0) +;; (loop +;; (if (r0 < 128) +;; ;; ASCII +;; (write-read-repeat r0) +;; ;; not ASCII +;; (if (r0 != ,leading-code-private-11) +;; ;; not Vietnamese +;; (write-read-repeat r0) +;; (read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (;; Vietnamese lower +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(car viet-vscii-encode-table))) +;; (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) +;; (;; Vietnamese upper +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) +;; ;; not Vietnamese +;; (write-read-repeat r0)))))))) +;; "CCL program to encode VSCII-1.") -(define-ccl-program ccl-encode-vscii - `(1 - ((read r0) - (loop - (if (r0 < 128) - ;; ASCII - (write-read-repeat r0) - ;; not ASCII - (if (r0 != ,leading-code-private-11) - ;; not Vietnamese - (write-read-repeat r0) - (read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (;; Vietnamese lower - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(car viet-vscii-encode-table))) - (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) - (;; Vietnamese upper - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) - ;; not Vietnamese - (write-read-repeat r0)))))))) - "CCL program to encode VSCII-1.") +(define-ccl-program ccl-vietnamese-lower-to-vscii + '(((r1 = r1 + [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 190 187 198 202 199 200 203 207 209 213 210 211 212 214 232 + 229 230 231 0 0 233 234 235 222 0 0 0 0 0 237 0 + 0 0 0 0 0 0 188 189 0 0 0 0 0 0 0 250 + 0 248 0 0 0 185 251 245 246 0 0 252 254 0 236 0 + 181 184 169 183 182 168 247 201 204 208 170 206 215 221 220 216 + 174 249 223 227 171 226 225 228 244 239 243 242 241 253 238 0 + ]))) + "CCL program to convert chars of 'vietnamese-lower to VSCII-1 font.") -(define-ccl-program ccl-encode-vscii-font - `(0 - ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper - ;; R1:position code - ;; Out: R1:font code point - (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (r1 = r1 ,(car viet-vscii-encode-table)) - (r1 = r1 ,(cdr viet-vscii-encode-table))) - ) - "CCL program to encode Vietnamese chars to VSCII-1 font.") +(define-ccl-program ccl-vietnamese-upper-to-vscii + '(((r1 = r1 + [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 192 175 133 0 196 194 134 137 139 218 197 205 217 140 255 + 219 224 240 0 0 151 152 153 145 0 0 0 0 165 155 0 + 0 0 0 0 0 0 186 191 0 0 0 0 0 0 0 19 + 0 17 0 0 0 132 20 4 5 0 0 21 23 0 154 166 + 128 131 162 130 129 161 6 195 135 138 163 136 141 144 143 142 + 167 0 146 149 164 148 147 150 2 157 1 159 158 22 156 0 + ]))) + "CCL program to convert chars of 'vietnamese-upper to VSCII-1 font.") + +;; (define-ccl-program ccl-encode-vscii-font +;; `(0 +;; ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper +;; ;; R1:position code +;; ;; Out: R1:font code point +;; (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (r1 = r1 ,(car viet-vscii-encode-table)) +;; (r1 = r1 ,(cdr viet-vscii-encode-table))) +;; ) +;; "CCL program to encode Vietnamese chars to VSCII-1 font.") (make-coding-system - 'vietnamese-viscii 4 ?V - "8-bit encoding for Vietnamese VISCII 1.1 (MIME:VISCII)" - (cons ccl-decode-viscii ccl-encode-viscii)) + 'viscii 'ccl + "Coding-system used for VISCII 1.1." + `(mnemonic "VISCII" + decode ,ccl-read-viscii + encode ,ccl-write-viscii)) -(define-coding-system-alias 'viscii 'vietnamese-viscii) +;; (make-coding-system +;; 'vietnamese-viscii 4 ?V +;; "8-bit encoding for Vietnamese VISCII 1.1 (MIME:VISCII)" +;; (cons ccl-decode-viscii ccl-encode-viscii)) + +;; (define-coding-system-alias 'viscii 'vietnamese-viscii) (make-coding-system - 'vietnamese-vscii 4 ?v - "8-bit encoding for Vietnamese VSCII-1" - (cons ccl-decode-vscii ccl-encode-vscii)) + 'vscii 'ccl + "Coding-system used for VSCII 1.1." + `(mnemonic "VSCII" + decode ,ccl-read-vscii + encode ,ccl-write-vscii)) -(define-coding-system-alias 'vscii 'vietnamese-vscii) +;; (make-coding-system +;; 'vietnamese-vscii 4 ?v +;; "8-bit encoding for Vietnamese VSCII-1" +;; (cons ccl-decode-vscii ccl-encode-vscii)) + +;; (define-coding-system-alias 'vscii 'vietnamese-vscii) (make-coding-system - 'vietnamese-viqr 0 ?q - "Vietnamese latin transcription (VIQR)" - nil) -(put 'vietnamese-viqr 'post-read-conversion 'viqr-post-read-conversion) -(put 'vietnamese-viqr 'pre-write-conversion 'viqr-pre-write-conversion) + 'viqr 'no-conversion + "Coding-system used for VIQR." + '(mnemonic "VIQR" + eol-type lf + post-read-conversion viqr-post-read-conversion + pre-write-conversion viqr-pre-write-conversion)) + +;; (make-coding-system +;; 'vietnamese-viqr 0 ?q +;; "Vietnamese latin transcription (VIQR)" +;; nil) +;; (put 'vietnamese-viqr 'post-read-conversion 'viqr-post-read-conversion) +;; (put 'vietnamese-viqr 'pre-write-conversion 'viqr-pre-write-conversion) -(define-coding-system-alias 'viqr 'vietnamese-viqr) +;; (define-coding-system-alias 'viqr 'vietnamese-viqr) -(setq font-ccl-encoder-alist - (cons (cons "viscii" ccl-encode-viscii-font) font-ccl-encoder-alist)) +;; For VISCII users +(set-charset-ccl-program 'vietnamese-viscii-lower + ccl-vietnamese-lower-to-viscii) +(set-charset-ccl-program 'vietnamese-viscii-upper + ccl-vietnamese-upper-to-viscii) +;; For VSCII users +;; (set-charset-ccl-program 'vietnamese-lower ccl-vietnamese-lower-to-vscii) +;; (set-charset-ccl-program 'vietnamese-upper ccl-vietnamese-upper-to-vscii) -(setq font-ccl-encoder-alist - (cons (cons "vscii" ccl-encode-vscii-font) font-ccl-encoder-alist)) +;; (setq font-ccl-encoder-alist +;; (cons (cons "viscii" ccl-encode-viscii-font) font-ccl-encoder-alist)) + +;; (setq font-ccl-encoder-alist +;; (cons (cons "vscii" ccl-encode-vscii-font) font-ccl-encoder-alist)) (set-language-info-alist "Vietnamese" '((setup-function . setup-vietnamese-environment) (charset . (vietnamese-viscii-lower vietnamese-viscii-upper)) - (coding-system . (vietnamese-viscii vietnamese-vscii - vietnamese-viqr)) + (coding-system . (viscii vscii viqr)) (sample-text . "Vietnamese (Ti,1*(Bng Vi,1.(Bt) Ch,1`(Bo b,1U(Bn") (documentation . "\ For Vietnamese, Emacs uses special charasets internally. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/language/visual-mode.el --- a/lisp/language/visual-mode.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1176 +0,0 @@ -;; visual.el -- cursor motion, insertion, deletion, etc. in visual order -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; 94.5.15 created for Mule Ver.1.1 by Takahashi N. - -;;;###autoload -(defvar visual-mode nil "non-nil if in visual-mode.") - -(make-variable-buffer-local 'visual-mode) - -(defvar visual-use-lr-commands nil - "If non-nil, use visual-left-* and visual-right-* commands instead of -visual-forward-* and visual-backward-* commands.") - -(defvar visual-mode-map - (let ((map (make-keymap))) - (substitute-key-definition 'self-insert-command - 'visual-self-insert-command - map global-map) - ; visual basic commands - (define-key map [(control d)] 'visual-delete-char) - (define-key map [(control k)] 'visual-kill-line) - (define-key map [(control m)] 'visual-newline) - (define-key map [(control o)] 'visual-open-line) - (define-key map [(control p)] 'visual-previous-line) - (define-key map [(control w)] 'visual-kill-region) - (define-key map [(control y)] 'visual-yank) - (define-key map [delete] 'visual-backward-delete-char) - (define-key map [(meta <)] 'visual-beginning-of-buffer) - (define-key map [(meta >)] 'visual-end-of-buffer) - (define-key map [(meta d)] 'visual-kill-word) - (define-key map [(meta w)] 'visual-kill-ring-save) - (define-key map [(meta y)] 'visual-yank-pop) - (define-key map [(meta delete)] 'visual-backward-kill-word) - (define-key map [up] 'visual-previous-line) - (define-key map [down] 'visual-next-line) - (define-key map [home] 'visual-beginning-of-buffer) - (define-key map [end] 'visual-end-of-buffer) - (define-key map [left] 'visual-move-to-left-char) - (define-key map [right] 'visual-move-to-right-char) - (define-key map [(meta left)] 'visual-move-to-left-word) - (define-key map [(meta right)] 'visual-move-to-right-word) - (define-key map [(control c) (control c)] 'exit-visual-mode) - (define-key map [(control c) <] 'l2r-mode) - (define-key map [(control c) >] 'r2l-mode) - ; LR commands - (if visual-use-lr-commands - (progn - (define-key map [(control a)] 'visual-left-end-of-line) - (define-key map [(control b)] 'visual-move-to-left-char) - (define-key map [(control e)] 'visual-right-end-of-line) - (define-key map [(control f)] 'visual-move-to-right-char) - (define-key map [(meta b)] 'visual-move-to-left-word) - (define-key map [(meta f)] 'visual-move-to-right-word)) - (define-key map [(control a)] 'visual-beginning-of-line) - (define-key map [(control b)] 'visual-backward-char) - (define-key map [(control e)] 'visual-end-of-line) - (define-key map [(control f)] 'visual-forward-char) - (define-key map [(meta b)] 'visual-backward-word) - (define-key map [(meta f)] 'visual-forward-word)) - map) - "minor-mode-keymap for visual-mode.") - -(if (not (assq 'visual-mode minor-mode-map-alist)) - (setq minor-mode-map-alist - (cons (cons 'visual-mode visual-mode-map) - minor-mode-map-alist))) - -(defvar visual-mode-indicator nil - "string displayed in mode line. \" l2r\" or \" r2l\".") -(make-variable-buffer-local 'visual-mode-indicator) - -(if (not (assq 'visual-mode minor-mode-alist)) - (setq minor-mode-alist - (cons '(visual-mode visual-mode-indicator) - minor-mode-alist))) - -(setq auto-mode-alist - (append '(("\\.l2r$" . l2r-mode) ("\\.r2l$" . r2l-mode)) - auto-mode-alist)) - -(defvar visual-mode-hooks nil) - -;;;###autoload -(defun visual-mode (&optional arg) - "Toggle visual-mode. With ARG, turn visual-mode on iff ARG is positive." - (interactive "P") - (if (null arg) - (if visual-mode (exit-visual-mode) (enter-visual-mode)) - (if (> (prefix-numeric-value arg) 0) - (enter-visual-mode) - (exit-visual-mode)))) - -(defun enter-visual-mode nil - "Enter visual-mode. Cursor moves in visual order." - (interactive) - (if (not visual-mode) - (progn - (setq visual-mode t - visual-mode-indicator (if display-direction " r2l" " l2r")) - (redraw-display) - (run-hooks 'visual-mode-hooks)))) - -(defun exit-visual-mode nil - "Exit visual-mode. Cursor moves in logical order." - (interactive) - (if visual-mode - (progn - (setq visual-mode nil) - (redraw-modeline t)))) - -(defun l2r-mode nil - "Set display-direction left to right." - (interactive) - (if (not visual-mode) - (enter-visual-mode)) - (setq display-direction nil) - (setq visual-mode-indicator " l2r") - (redraw-display)) - -(defun r2l-mode nil - "Set display-direction right to left." - (interactive) - (if (not visual-mode) - (enter-visual-mode)) - (setq display-direction t) - (setq visual-mode-indicator " r2l") - (redraw-display)) - - -;; cursor motion - -(defun visual-forward-char (arg) - "Move the cursor visually forward by ARG (integer) characters. -if ARG is negative, move backward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-backward-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-forward-1-char) - (setq arg (1- arg))))) - -(defun visual-forward-1-char nil - "Move the cursor visually forward by 1 character." - (let ((r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point))) - - ; symbols used in the following comments - ; ^ : point in here - ; ~ : point will be there - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (cond - ((null a-dir) - ; ... nil - ; ^ - (error "end of buffer")) - - ((eq a-dir r-dir) - (if (eq b-dir r-dir) - - ; ... r r ... - ; ~ ^ - (backward-char 1) - - ; ... !r r r* ... - ; ^ ~ - (skip-direction-forward r-dir))) - - ((eq aa-dir r-dir) - ; ... d r* r ... - ; ^ ~ - (forward-char 1) - (skip-direction-forward r-dir) - (backward-char 1)) - - (t - ; ... d !r ... - ; ^ ~ - (forward-char 1))))) - -(defun visual-backward-char (arg) - "Move the cursor visually backward by ARG (integer) characters. -if ARG is negative, move forward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-forward-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-backward-1-char) - (setq arg (1- arg))))) - -(defun visual-backward-1-char nil - "Move the cursor visually backward by 1 character." - (let ((r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point))) - - ; symbols used in the following comments - ; ^ : point in here - ; ~ : point will be there - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (cond - ((eq a-dir r-dir) - (if (eq aa-dir r-dir) - ; ... r r ... - ; ^ ~ - (forward-char 1) - - ; ... !r r* !r ... - ; ~ ^ - (skip-direction-backward r-dir) - (if (visual-char-direction-before-point) - (backward-char 1) - (skip-direction-forward r-dir) - (backward-char 1) - (error "beginning of buffer")))) - - ((null b-dir) - ; nil !r ... - ; ^ - (error "beginning of buffer")) - - ((eq b-dir r-dir) - ; ... r* r !r - ; ~ ^ - (skip-direction-backward r-dir)) - - (t - ; ... d !r ... - ; ~ ^ - (backward-char 1))))) - -(defun visual-char-direction (ch) - "Return the direction of CH (character). -Newline's direction will be same as display-direction." - (cond - ((null ch) nil) - ((= ch ?\n) (if display-direction 1 0)) - (t (char-direction ch)))) - -(defun visual-char-direction-after-point nil - "Return the direction of after-point-character. -0: left-to-right, 1: right-to-left" - (visual-char-direction (char-after (point)))) - -(defun visual-char-direction-after-after-point nil - "Return the direction of after-after-point-character. -0: left-to-right, 1: right-to-left" - (if (= (point) (point-max)) - nil - (save-excursion - (forward-char 1) - (visual-char-direction (char-after (point)))))) - -(defun visual-char-direction-before-point nil - "Return the direction of before-point-character. -0: left-to-right, 1: right-to-left" - (visual-char-direction (char-before (point)))) - -(defun skip-direction-forward (dir) - "Move point forward as long as DIR-direction characters continue." - (while (eq (visual-char-direction-after-point) dir) - (forward-char 1))) - -(defun skip-direction-backward (dir) - "Move point backward as long as DIR-direction characters continue." - (while (eq (visual-char-direction-before-point) dir) - (backward-char 1))) - -(defvar *visual-punctuations* - '(? ?. ?, ?: ?; ?? ?! ?- ?_ ?' ?\" ?/ ?( ?) ?[ ?] ?{ ?} ?\n ?\t ; ASCII - ? ?. ?, ?: ?; ?? ?! ?- ?_ ?' ?" ?( ?) ?[ ?] ; Hebrew - ?[2](3![0](B ?[2](3&[0](B ?[2](3%[0](B ?[2](3)[0](B ?[2](3"[0](B ?[2](3'[0](B ?[2](3([0](B ?[2](3#[0](B ?[2](3$[0](B ?[2](3*[0](B ?[2](3+[0](B )) ; Arabic - -(defun visual-forward-word (arg) - "Move the cursor visually forward by ARG (integer) words. -If ARG is negative, move the cursor backward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-backward-1-word) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-forward-1-word) - (setq arg (1- arg))))) - -(defun visual-backward-word (arg) - "Move the cursor visually backward by ARG (integer) words. -If ARG is negative, move the cursor forward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-forward-1-word) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-backward-1-word) - (setq arg (1- arg))))) - -(defun visual-forward-1-word nil - "Move the cursor visually forward by one word." - (while (memq (visual-char-after) *visual-punctuations*) - (visual-forward-1-char)) - (while (not (memq (visual-char-after) *visual-punctuations*)) - (visual-forward-1-char))) - -(defun visual-backward-1-word nil - "Move the cursor visually backward by one word." - (while (memq (visual-char-before) *visual-punctuations*) - (visual-backward-1-char)) - (while (not (memq (visual-char-before) *visual-punctuations*)) - (visual-backward-1-char))) - -(defun visual-char-before nil - "Return the character visually before the cursor. -If such position is out of range, returns nil." - ; almost same as visual-backward-1-char - (save-excursion - (let ((r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point))) - (cond - ((eq a-dir r-dir) - (if (eq aa-dir r-dir) - (progn - (forward-char 1) - (char-after (point))) - (skip-direction-backward r-dir) - (if (visual-char-direction-before-point) - (progn - (backward-char 1) - (char-after (point))) - nil))) - ((null b-dir) - nil) - ((eq b-dir r-dir) - (skip-direction-backward r-dir) - (char-after (point))) - (t - (backward-char 1) - (char-after (point))))))) - -(defun visual-char-after nil - "Return the character under the cursor. -If such position is out of range, returns nil." - (char-after (point))) - -(defun visual-beginning-of-line (&optional arg) - "Move the cursor to the visual beginning of line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (beginning-of-line arg) - (let ((a-dir (visual-char-direction-after-point)) - (d-dir (if display-direction 1 0))) - (if (and a-dir (/= a-dir d-dir)) - (progn (skip-direction-forward a-dir) - (backward-char 1))))) - -(fset 'visual-end-of-line 'end-of-line) - -(defun visual-beginning-of-buffer nil - "Move the cursor to the visual beginning of current buffer." - (interactive) - (beginning-of-buffer) - (visual-beginning-of-line)) - -(fset 'visual-end-of-buffer 'end-of-buffer) - -(defvar visual-temporary-goal-column 0 - "temporary-goal-column command for visual-mode.") - -(defun visual-next-line (arg) - "next-line command for visual-mode." - (interactive "p") - (if (and (not (eq last-command 'visual-next-line)) - (not (eq last-command 'visual-previous-line))) - (setq visual-temporary-goal-column (visual-current-column))) - (next-line arg) - (visual-goto-column visual-temporary-goal-column)) - -(defun visual-previous-line (arg) - "previous-line command for visual-mode." - (interactive "p") - (if (and (not (eq last-command 'visual-next-line)) - (not (eq last-command 'visual-previous-line))) - (setq visual-temporary-goal-column (visual-current-column))) - (previous-line arg) - (visual-goto-column visual-temporary-goal-column)) - -(defun visual-current-column nil - "Return the current column counted in visual order." - (let ((c 0) (p (point))) - (visual-beginning-of-line) - (while (/= (point) p) - (setq c (+ c (char-width (visual-char-after)))) - (visual-forward-1-char)) - c)) - -(defun visual-goto-column (col) - "Move the cursor to visual column N (integer) in the current line. -If it is impossible to go to column N, the cursor is put on the nearest column -M (M < N). Returns N - M." - (if (< col 0) - (error "argument must be positive.")) - (let ((c 0)) - (visual-beginning-of-line) - (while (and (< c col) (not (eolp))) - (setq c (+ c (char-width (visual-char-after)))) - (visual-forward-1-char)) - (if (> c col) - (progn - (visual-backward-1-char) - (setq c (- c (char-width (visual-char-after)))))) - (- col c))) - - -;; insertion - -(defun visual-insert-char (ch arg) - "Insert character CH visually before the cursor. -With ARG (integer) insert that many characters." - (if (< arg 0) - (error "arg must be >= 0.")) - (while (> arg 0) - (visual-insert-1-char ch) - (setq arg (1- arg)))) - -(defun visual-insert-1-char (ch) - "Insert character CH visually before the cursor. -The cursor moves visually forward." - (let ((c-dir (visual-char-direction ch)) - (r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (tmp)) - - ; symbols used in the following comments - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; ^d : point is here and the character to be inserted is d - ; ^r : point is here and the character to be inserted is d - - (if (eq c-dir r-dir) - (if (eq a-dir r-dir) - - ; ... r ... - ; ^r - (progn - (forward-char 1) - (insert ch) - (backward-char 2)) - - ; ... !r ... - ; ^r - (skip-direction-backward c-dir) - (insert ch) - (skip-direction-forward c-dir)) - - (if (or (eq a-dir nil) - (eq a-dir c-dir)) - - ; ... !r ... - ; ^d - (insert ch) - - ; ... r ... - ; ^d - (forward-char 1) - (setq tmp (delete-direction-backward r-dir)) - (skip-direction-forward r-dir) - (insert ch tmp) - (backward-char 1))))) - -(defun delete-direction-forward (dir) - "From current point, delete DIR-direction characters forward. -Returns the deleted string." - (let ((p (point))) - (skip-direction-forward dir) - (prog1 - (buffer-substring (point) p) - (delete-region (point) p)))) - -(defun delete-direction-backward (dir) - "From current point, delete DIR-direction characters backward. -Return the deleted string." - (let ((p (point))) - (skip-direction-backward dir) - (prog1 - (buffer-substring (point) p) - (delete-region (point) p)))) - -(defun visual-self-insert-command (arg) - "Insert this character (32 <= CH < 127). -With ARG (integer), insert that many characters. -If display-direction is non-nil, the cursor stays at the same position." - (interactive "*p") - (visual-insert-char last-command-char arg) - (if display-direction - (visual-backward-char arg))) - -;; wire us into pending-delete -(put 'visual-self-insert-command 'pending-delete t) - -(defun visual-newline (arg) - "newline command for visual-mode. -With ARG (integer), insert that many newlines." - (interactive "*p") - (visual-insert-char ?\n arg)) - -(defun visual-open-line (arg) - "open-line command for visual-mode. -With arg (integer), insert that many newlines." - (interactive "*p") - (visual-insert-char ?\n arg) - (visual-backward-char arg)) - - -;; deletion - -(defun visual-delete-char (arg) - "Delete ARG (integer) characters visually forward. -If ARG is negative, delete backward." - (interactive "*p") - (if (< arg 0) - (while (< arg 0) - (visual-backward-delete-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-delete-1-char) - (setq arg (1- arg))))) - -(defun visual-backward-delete-char (arg) - "Delete ARG (integer) characters visually backward. -If arg is negative, delete forward." - (interactive "*p") - (if (< arg 0) - (while (< arg 0) - (visual-delete-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-backward-delete-1-char) - (setq arg (1- arg))))) - -(fset 'visual-delete-backward-char 'visual-backward-delete-char) - -(defun visual-backward-delete-1-char nil - "Delete a character visually before the cursor. -Ther cursor moves visually backward." - (let ((d-dir (if display-direction 1 0)) - (r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point)) - (tmp)) - - ; symbols used in the following comments - ; ^ : point in here - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (if (eq a-dir r-dir) - (cond - ((eq aa-dir r-dir) - ; ... r r ... - ; ^ - (forward-char 1) - (delete-char 1) - (backward-char 1)) - - ((save-excursion - (skip-direction-backward r-dir) - (backward-char 1) - (and (eq (visual-char-direction-after-point) d-dir) - (eq (visual-char-direction-before-point) r-dir))) - ; ... r d r* r !r ... - ; ^ - (forward-char 1) - (setq tmp (delete-direction-backward r-dir)) - (delete-backward-char 1) - (skip-direction-backward r-dir) - (insert tmp) - (backward-char 1)) - - (t - ; .....!r d r* r !r ... - ; ^ - (skip-direction-backward r-dir) - (delete-backward-char 1) - (skip-direction-forward r-dir) - (backward-char 1))) - - (cond - ((null b-dir) - ; nil !r ... - ; ^ - (error "beginning of buffer")) - - ((eq b-dir r-dir) - ; ... r !r ... - ; ^ - (skip-direction-backward r-dir) - (delete-char 1) - (skip-direction-forward r-dir)) - - (t - ; ... !r !r ... - ; ^ - (delete-backward-char 1)))))) - -(fset 'visual-delete-backward-1-char 'visual-backward-delete-1-char) - -(defun visual-delete-1-char nil - "Delete a character under the cursor. -Visually, the cursor stays at the same position." - (let ((d-dir (if display-direction 1 0)) - (r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point)) - (tmp)) - - ; symbols used in the following comments - ; ^ : point in here - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (cond - ((null a-dir) - ; ... nil - ; ^ - (error "end of buffer")) - - ((eq a-dir r-dir) - (if (eq b-dir r-dir) - - ; ... r r ... - ; ^ - (progn (delete-char 1) - (backward-char 1)) - - ; ... !r r ... - ; ^ - (delete-char 1) - (skip-direction-forward r-dir))) - - ((not (eq aa-dir r-dir)) - ; ... d !r ... - ; ^ - (delete-char 1)) - - ((eq b-dir r-dir) - ; ... r d r ... - ; ^ - (delete-char 1) - (setq tmp (delete-direction-forward r-dir)) - (skip-direction-backward r-dir) - (insert tmp) - (backward-char 1)) - - (t - ; ...!r d r ... - ; ^ - (delete-char 1) - (skip-direction-forward r-dir) - (backward-char 1))))) - -(defun visual-delete-region (beg end) - "delete-region command for visual-mode." - (interactive "*r") - (let ((begl) (begc) (endl) (endc) (l)) - - ; swap beg & end if necessary - (goto-char beg) - (setq begl (current-line) - begc (visual-current-column)) - (goto-char end) - (setq endl (current-line) - endc (visual-current-column)) - (if (or (> begl endl) - (and (= begl endl) - (> begc endc))) - (progn - (setq beg (prog1 end (setq end beg)) - begl (prog1 endl (setq endl begl)) - begc (prog1 endc (setq endc begc))) - (goto-char end))) - - ; insert a newline visually at END - (visual-insert-1-char ?\n) - (visual-backward-1-char) - (setq l (current-line)) - - ; insert a newline visually at BEG - (goto-line begl) - (visual-goto-column begc) - (visual-insert-1-char ?\n) - (beginning-of-line) - - (delete-region - (point) - (progn - (goto-line (1+ l)) - (end-of-line) - (point))) - (backward-char 1) - (visual-delete-char 2))) - -(defun current-line nil - "Return the current line number (in the buffer) of point." - (interactive) - (save-excursion - (beginning-of-line) - (1+ (count-lines 1 (point))))) - - -;; kill - -(defun visual-kill-region (beg end) - "kill-region command for visual-mode." - (interactive "r") - (let ((begl) (begc) (endl) (endc) (l)) - - ; swap beg & end if necessary - (goto-char beg) - (setq begl (current-line) - begc (visual-current-column)) - (goto-char end) - (setq endl (current-line) - endc (visual-current-column)) - (if (or (> begl endl) - (and (= begl endl) (> begc endc))) - (progn - (setq beg (prog1 end (setq end beg)) - begl (prog1 endl (setq endl begl)) - begc (prog1 endc (setq endc begc))) - (goto-char end))) - - (if (or (and buffer-read-only (not inhibit-read-only)) - (text-property-not-all beg end 'read-only nil)) - (progn - (visual-copy-region-as-kill beg end) - (if kill-read-only-ok - (message "Read only text copied to kill ring") - (barf-if-buffer-read-only))) - - ; insert a newline visually at END - (visual-insert-1-char ?\n) - (visual-backward-1-char) - (setq l (current-line)) - - ; insert a newline visually at BEG - (goto-line begl) - (visual-goto-column begc) - (visual-insert-1-char ?\n) - (beginning-of-line) - - (kill-region - (point) - (progn - (goto-line (1+ l)) - (end-of-line) - (point))) - (backward-char 1) - (visual-delete-char 2))) - - (setq this-command 'kill-region)) - -(defun visual-kill-word (arg) - "Kill ARG (integer) words visually forward. -If ARG is negative, kill backward." - (interactive "*p") - (visual-kill-region - (point) - (progn - (visual-forward-word arg) - (point)))) - -(defun visual-backward-kill-word (arg) - "Kill ARG (integer) words visually backward. -If ARG is negative, kill forward." - (interactive "*p") - (visual-kill-region - (point) - (progn - (visual-backward-word arg) - (point)))) - -(defun visual-kill-line (&optional arg) - "kill-line command for visual-mode." - (interactive "*P") - (visual-kill-region - (point) - (progn - (if arg - (progn - (forward-line (prefix-numeric-value arg)) - (visual-beginning-of-line)) - (if (eobp) - (signal 'end-of-buffer nil)) - (if (not (eolp)) - (visual-end-of-line) - (forward-line 1) - (visual-beginning-of-line))) - (point)))) - -(defun visual-copy-region-as-kill (beg end) - "copy-region-as-kill command for visual-mode." - (interactive "r") - (let ((buffer-read-only nil) - (auto-save-mode 0) - (p (point))) - (visual-kill-region beg end) - (visual-yank 1) - (if (/= (point) p) - (exchange-point-and-mark))) - nil) - -(defun visual-kill-ring-save (beg end) - "kill-ring-save command for visual-mode." - (interactive "r") - (visual-copy-region-as-kill beg end) - (if (interactive-p) - (let ((other-end (if (= (point) beg) end beg)) - (opoint (point)) - (inhibit-quit t)) - (if (pos-visible-in-window-p other-end (selected-window)) - (progn - (set-marker (mark-marker) (point) (current-buffer)) - (goto-char other-end) - (sit-for 1) - (set-marker (mark-marker) other-end (current-buffer)) - (goto-char opoint) - (and quit-flag mark-active - (deactivate-mark))) - (let* ((killed-text (current-kill 0)) - (message-len (min (length killed-text) 40))) - (if (= (point) beg) - (message "Saved text until \"%s\"" - (substring killed-text (- message-len))) - (message "Saved text from \"%s\"" - (substring killed-text 0 message-len)))))))) - - -;; yank - -(defun visual-yank (&optional arg) - "yank command for visual-mode." - (interactive "*P") - (setq this-command t) - - (let ((l1 (current-line)) (c1 (visual-current-column)) l2 c2) - - ;; Insert a newline both before and after current point. - (visual-insert-char ?\n 2) - (visual-backward-1-char) - - ;; Reinsert killed string between the two newlines. - (insert (current-kill (cond - ((listp arg) 0) - ((eq arg '-) -1) - (t (1- arg))))) - - ;; Delete the latter newline visually. - (visual-delete-1-char) - (setq l2 (current-line) - c2 (visual-current-column)) - - ;; Delete the former newline visually. - (goto-line l1) - (end-of-line) - (visual-delete-1-char) - (push-mark (point)) - - ;; Go back to the end of yanked string. - (if (= (- l2 l1) 1) - (visual-goto-column (+ c1 c2)) - (goto-line (1- l2)) - (visual-goto-column c2)) - - ;; Exchange point and mark if necessary. - (if (consp arg) - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) (current-buffer)))))) - - (setq this-command 'yank) - nil) - -(defun visual-yank-pop (arg) - "yank-pop command for visual-mode." - (interactive "*p") - (if (not (eq last-command 'yank)) - (error "Previous command was not a yank")) - (setq this-command 'yank) - (let (l1 c1 l2 c2 before) - - (save-excursion - (setq l2 (current-line) - c2 (visual-current-column)) - (goto-char (mark t)) - (setq l1 (current-line) - c1 (visual-current-column)) - (if (or (> l1 l2) - (and (= l1 l2) (> c1 c2))) - (setq before t))) - - (visual-delete-region (point) (mark t)) - (setq l1 (current-line) - c1 (visual-current-column)) - - ;; Insert a newline both before and after current point. - (visual-insert-char ?\n 2) - (visual-backward-1-char) - - ;; Reinsert killed string between the two newlines. - (insert (current-kill arg)) - - ;; Delete the latter newline visually. - (visual-delete-1-char) - (setq l2 (current-line) - c2 (visual-current-column)) - - ;; Delete the former newline visually. - (goto-line l1) - (end-of-line) - (visual-delete-1-char) - (set-marker (mark-marker) (point) (current-buffer)) - - ;; Go back to the end of yanked string. - (if (= (- l2 l1) 1) - (visual-goto-column (+ c1 c2)) - (goto-line (1- l2)) - (visual-goto-column c2)) - - ;; Exchange point and mark if necessary. - (if before - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) (current-buffer)))))) - - nil) - - -;; misc - -(defun visual-reverse-direction-word nil - "Reverse the char order of the word before point." - (interactive "*") - (goto-char - (prog1 - (point) - (reverse-region - (point) - (progn (skip-direction-backward (visual-char-direction-before-point)) - (point)))))) - -(defun visual-reverse-region (begin end) - "Reverse the order of chars between BEGIN and END." - (interactive "*r") - (apply 'insert - (nreverse - (string-to-char-list - (prog1 (buffer-substring begin end) (delete-region begin end)))))) - - -;; LR commands - -(defun visual-char-left nil - "Return the character on the left of visual point." - (if display-direction - (visual-char-after) - (visual-char-before))) - -(defun visual-char-right nil - "Return the character on the right of visual point." - (if display-direction - (visual-char-before) - (visual-char-after))) - -(defun visual-move-to-left-char (arg) - "Move the cursor visually left by ARG (integer) characters. -If ARG is negative, move the cursor right." - (interactive "p") - (if display-direction - (visual-forward-char arg) - (visual-backward-char arg))) - -(defun visual-move-to-left-1-char nil - "Move the cursor visually left by 1 character." - (interactive "p") - (if display-direction - (visual-forward-1-char) - (visual-backward-1-char))) - -(defun visual-move-to-right-char (arg) - "Move the cursor visually right by ARG (integer) characters. -If ARG is negative, move the cursor left." - (interactive "p") - (if display-direction - (visual-backward-char arg) - (visual-forward-char arg))) - -(defun visual-move-to-right-1-char nil - "Move the cursor visually right by 1 character." - (interactive "p") - (if display-direction - (visual-backward-1-char) - (visual-forward-1-char))) - -(defun visual-move-to-left-word (arg) - "Move the cursor visually left by ARG (integer) words. -If ARG is negative, move the cursor right." - (interactive "p") - (if display-direction - (visual-forward-word arg) - (visual-backward-word arg))) - -(defun visual-move-to-right-word (arg) - "Move the cursor visually right by ARG (integer) words. -If ARG is negative, move the cursor left." - (interactive "p") - (if display-direction - (visual-backward-word arg) - (visual-forward-word arg))) - -(defun visual-left-end-of-line (arg) - "Move the line cursor to the left-end of line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (if display-direction - (visual-end-of-line arg) - (visual-beginning-of-line arg))) - -(defun visual-right-end-of-line (arg) - "Move the line cursor to the right-end of line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (if display-direction - (visual-beginning-of-line arg) - (visual-end-of-line arg))) - -(defun visual-insert-char-left (ch arg) - "Insert CH (character) on the left of visual point as many as -ARG (integer)." - (if (< arg 0) - (error "ARG must be >= 0.")) - (visual-insert-char ch arg) - (and display-direction - (visual-backward-char arg))) - -(defun visual-insert-left-1-char (ch) - "Insert CH (character) on the left of visual point." - (visual-insert-1-char ch) - (and display-direction - (visual-backward-1-char))) - -(defun visual-insert-char-right (ch arg) - "Insert CH (character) on the right of visual point as many as -ARG (integer)." - (if (< arg 0) - (error "ARG must be >= 0.")) - (visual-insert-char ch arg) - (or display-direction - (visual-backward-char arg))) - -(defun visual-insert-right-1-char (ch) - "Insert CH (character) on the right of visual point." - (visual-insert-1-char ch) - (or display-direction - (visual-backward-1-char))) - -(defun visual-delete-left-char (arg) - "Delete ARG (integer) characters on the left of visual point. -If ARG is negative, on the right." - (interactive "*p") - (if display-direction - (visual-delete-char arg) - (visual-backward-delete-char arg))) - -(defun visual-delete-left-1-char nil - "Delete 1 character on the left of visual point." - (interactive "*p") - (if display-direction - (visual-delete-1-char) - (visual-backward-delete-1-char))) - -(defun visual-delete-right-char (arg) - "Delete ARG (integer) characters on the right of visual point. -If ARG is negative, on the left." - (interactive "*p") - (if display-direction - (visual-backward-delete-char arg) - (visual-delete-char arg))) - -(defun visual-delete-right-1-char nil - "Delete 1 character on the right of visual point." - (interactive "*p") - (if display-direction - (visual-backward-delete-1-char) - (visual-delete-1-char))) - -(defmacro visual-replace-left-1-char (ch) - (list - 'progn - '(visual-delete-left-1-char) - (list 'visual-insert-left-1-char ch))) - -(defmacro visual-replace-right-1-char (ch) - (list - 'progn - '(visual-delete-right-1-char) - (list 'visual-insert-right-1-char ch))) - -(defun visual-kill-left-word (arg) - "Kill ARG (integer) words on the left of visual pointer. -If ARG is negative, kill on the right." - (interactive "*p") - (if display-direction - (visual-kill-word arg) - (visual-backward-kill-word arg))) - -(defun visual-kill-right-word (arg) - "Kill ARG (integer) words on the right of visual point. -If ARG is negative, kill on the left." - (interactive "*p") - (if display-direction - (visual-backward-kill-word arg) - (visual-kill-word arg))) - -;;; -(provide 'visual-mode) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/custom-load.el --- a/lisp/leim/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sun Sep 28 14:03:16 1997 - -;;; Code: - - -;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/leim-list.el --- a/lisp/leim/leim-list.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/leim/leim-list.el Mon Aug 13 10:03:52 2007 +0200 @@ -15,241 +15,85 @@ ;; loads this file at startup time. (register-input-method - "chinese-4corner" "Chinese-BIG5" 'quail-use-package - "$(0(?-F(B" "$(0(?-FHAP#(B:: " - "quail/4Corner") -(register-input-method - "chinese-array30" "Chinese-BIG5" 'quail-use-package - "$(0#R#O(B" "$(0&d'G!J*h)E#R#O!K(B " - "quail/ARRAY30") -(register-input-method - "chinese-ccdospy" "Chinese-GB" 'quail-use-package - "$AKuF4(B" "$A::WVJdHk!KKuP4F4Rt!K(B# " - "quail/CCDOSPY") + "vietnamese-viqr" "Vietnamese" 'quail-use-package + "VQ" "Vietnamese input method with VIQR mnemonic system" + "quail/viqr") (register-input-method - "chinese-ctlau" "Chinese-GB" 'quail-use-package - "$AAuTA(B" "$A::WVJdHk!KAuN}OiJ=TARt!K(B" - "quail/CTLau") -(register-input-method - "chinese-ctlaub" "Chinese-BIG5" 'quail-use-package - "$(0N,Gn(B" "$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B" - "quail/CTLauB") -(register-input-method - "chinese-ecdict" "Chinese-BIG5" 'quail-use-package - "$(05CKH(B" "$(0&d'GTT&,!J5CKH[0.)!K(B" - "quail/ECDICT") -(register-input-method - "chinese-etzy" "Chinese-BIG5" 'quail-use-package - "$(06/0D(B" "$(0&d'GTT&,!J6/'30D5x!K(B" - "quail/ETZY") + "chinese-cns-tsangchi" "Chinese-CNS" 'quail-use-package + "$(GT?(BC" "$(GDcEFrSD+!JT?on!K(BCNS" + "quail/tsang-cns") (register-input-method - "chinese-py-b5" "Chinese-BIG5" 'quail-use-package - "$(03<(BB" "$(0&d'GTT&,!J3<5x!K(B" - "quail/PY-b5") -(register-input-method - "chinese-py" "Chinese-GB" 'quail-use-package - "$AF4(BG" "$A::WVJdHk!KF4Rt!K(B# " - "quail/PY") -(register-input-method - "chinese-punct-b5" "Chinese-BIG5" 'quail-use-package - "$(0O:(BB" "$(0&d'GTT&,!JO:X5>KHA!K(B" - "quail/Punct-b5") + "chinese-b5-tsangchi" "Chinese-BIG5" 'quail-use-package + "$(06A(BB" "$(0&d'GTT&,!J6AQo!K(BBIG5" + "quail/tsang-b5") (register-input-method - "chinese-punct" "Chinese-GB" 'quail-use-package - "$A1j(BG" "$A::WVJdHk!K1j5c7{:E!K(B# " - "quail/Punct") -(register-input-method - "chinese-qj-b5" "Chinese-BIG5" 'quail-use-package - "$(0)A(BB" "$(0&d'GTT&,!J)A,1!K(B" - "quail/QJ-b5") + "thai-kesmanee" "Thai" 'quail-use-package + ",T!!(B>" "Thai Kesmanee input method with TIS620 keyboard layout" + "quail/thai") (register-input-method - "chinese-qj" "Chinese-GB" 'quail-use-package - "$AH+(BG" "$A::WVJdHk!KH+=G!K(B# " - "quail/QJ") -(register-input-method - "chinese-sw" "Chinese-GB" 'quail-use-package - "$AJWN2(B" "$A::WVJdHk!KJWN2!K(B# " - "quail/SW") + "thai-pattachote" "Thai" 'quail-use-package + ",T!;(B>" "Thai Pattachote input method with TIS620 keyboard layout" + "quail/thai") (register-input-method - "chinese-tonepy" "Chinese-GB" 'quail-use-package - "$A5wF4(B" "$A::WVJdHk!K4x5wF4Rt!K(B# " - "quail/TONEPY") -(register-input-method - "chinese-ziranma" "Chinese-GB" 'quail-use-package - "$AK+F4(B" "$A::WVJdHk!KWTH;K+F4!K(B " - "quail/ZIRANMA") -(register-input-method - "chinese-zozy" "Chinese-BIG5" 'quail-use-package - "$(0I\0D(B" "$(0&d'GTT&,!JI\@c0D5x!K(B" - "quail/ZOZY") + "korean-symbol" "Korean" 'quail-use-package + "$(CGQ1[=I9z@T7BG%(B" "$(CGQ1[=I9z@T7BG%(B:" + "quail/symbol-ksc") (register-input-method - "cyrillic-jis-russian" "Cyrillic" 'quail-use-package - "$B'('+(B" "$B'+'8'5','&'/(B keyboard layout same as JCUKEN (JIS X0208.1983 encoding)" - "quail/cyril-jis") -(register-input-method - "cyrillic-jcuken" "Cyrillic" 'quail-use-package - ",L69(B" ",L9FC:5=(B keyboard layout widely used in Russia (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-macedonian" "Cyrillic" 'quail-use-package - ",L6(BM" ",L)*5@B7(B-,L#,(B keyboard layout based on JUS.I.K1.004 (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-serbian" "Cyrillic" 'quail-use-package - ",L6(BS" ",L)*5@B7(B-,L"+(B keyboard layout based on JUS.I.K1.005 (ISO 8859-5 encoding)" - "quail/cyrillic") + "chinese-cns-quick" "Chinese-CNS" 'quail-use-package + "$(Gv|(BC" "$(GDcEFrSD+!Jv|Mx!K(BCNS" + "quail/quick-cns") (register-input-method - "cyrillic-beylorussian" "Cyrillic" 'quail-use-package - ",L6(BB" ",L)*5@B7(B-,L&.(B BEYLORUSSIAN (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-ukrainian" "Cyrillic" 'quail-use-package - ",L6(BU" ",L$'5@B7(B-,L&.(B UKRAINIAN (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-yawerty" "Cyrillic" 'quail-use-package - ",L6O(B" ",LO25@BK(B Roman transcription (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-translit" "Cyrillic" 'quail-use-package - ",L6(Bt" "Intuitively transliterated keyboard layout." - "quail/cyrillic") + "chinese-b5-quick" "Chinese-BIG5" 'quail-use-package + "$(0X|(BB" "$(0&d'GTT&,!JX|/y!K(BBIG5" + "quail/quick-b5") (register-input-method - "cyrillic-translit-bulgarian" "Cyrillic" 'quail-use-package - ",L6(Btb" "Intuitively transliterated keyboard layout optimized for Bulgarian." - "quail/cyrillic") -(register-input-method - "devanagari-keyboard-a" "Devanagari" 'quail-use-package - "DevK" "Devanagari input method with ISCII format" - "quail/devanagari") + "chinese-py-punct-b5" "Chinese-BIG5" 'quail-use-package + "$AF47{(B" "$(0&d'GTT&,!J3<5x!K(B and `v' for $(0O:X5>KHATT&,(B" + "quail/pypunct-b5") (register-input-method - "ethiopic" "Ethiopic" 'quail-use-package - (quote ("$(3$O#U!.(B " (ethio-prefer-ascii-space "_" "$(3$h(B") (ethio-prefer-ascii-punctuation "." "$(3$i(B"))) " QUAIL PACKAGE FOR ETHIOPIC (TIGRIGNA AND AMHARIC)" - "quail/ethiopic") -(register-input-method - "greek-jis" "Greek" 'quail-use-package - "$B&8(B" "$B&%&K&K&G&M&I&J&A(B: Greek keyboard layout (JIS X0208.1983)" - "quail/greek") + "chinese-py-punct" "Chinese-GB" 'quail-use-package + "$AF47{(B" "$A::WVJdHk(B $AF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B" + "quail/py-punct") (register-input-method - "greek" "Greek" 'quail-use-package - ",FY(B" ",FEkkgmij\(B: Greek keyboard layout (ISO 8859-7)" - "quail/greek") -(register-input-method - "korean-hangul" "Korean" 'quail-use-package - "$(CGQ(B2" "$(CGQ1[(B 2$(C9z=D(B: Hangul input method with Hangul keyboard layout (KSC5601)" - "quail/hangul") -(register-input-method - "korean-hangul3" "Korean" 'quail-use-package - "$(CGQ(B3" "$(CGQ1[(B 3$(C9z=D(B: Hangul input method" - "quail/hangul3") + "latin-1-prefix" "Latin-1" 'quail-use-package + "1>" "Latin-1 characters input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "korean-hanja-jis" "Korean" 'quail-use-package - "$(C9z$B4A(B" "2$(C9z=D(BJIS$B4A;z(B: $B3:aD$(CGO4B(B $B4A;z$(C@G(B $B1$$(C@;(B $(CGQ1[(B2$(C9z$B<0$(C@87N(B $B8F=P$(CGO?)(B $BA*Z$(B" - "quail/hanja-jis") -(register-input-method - "korean-hanja" "Korean" 'quail-use-package - "$(C9zyS(B" "2$(C9z=D(BKSC$(CySm.(B: $(Cz1SWGO4B(B $(CySm.@G(B $(Cj$@;(B $(CGQ1[(B2$(C9zcR@87N(B $(C{ Hiragana -> Kanji&Kana" - "quail/japanese") + "catalan-prefix" "Latin-1" 'quail-use-package + "CA>" "Catalan and Spanish input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "japanese-ascii" "Japanese" 'quail-use-package - "Aa" "Temporary ASCII input mode while using Quail package `japanese'" - "quail/japanese") -(register-input-method - "japanese-zenkaku" "Japanese" 'quail-use-package - "$B#A(B" "Japanese zenkaku alpha numeric character input method" - "quail/japanese") -(register-input-method - "japanese-hankaku-kana" "Japanese" 'quail-use-package - "(I1(B" "Japanese hankaku katakana input method by Roman transliteration" - "quail/japanese") -(register-input-method - "japanese-hiragana" "Japanese" 'quail-use-package - "$B$"(B" "Japanese hiragana input method by Roman transliteration" - "quail/japanese") + "esperanto-prefix" "Latin-1" 'quail-use-package + "EO>" "Esperanto input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "japanese-katakana" "Japanese" 'quail-use-package - "$B%"(B" "Japanese katakana input method by Roman transliteration" - "quail/japanese") -(register-input-method - "lao" "Lao" 'quail-use-package - "(1E(B" "Lao input method simulating Lao keyboard layout based on Thai TIS620" - "quail/lao") + "french-prefix" "Latin-1" 'quail-use-package + "FR>" "French (Fran,Ag(Bais) input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "latin-1-alt-postfix" "Latin-1" 'quail-use-package - "1<" "Latin-1 character input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "latin-2-alt-postfix" "Latin-2" 'quail-use-package - "2<" "Latin-2 character input method with postfix modifiers" - "quail/latin-alt") + "german-prefix" "Latin-1" 'quail-use-package + "DE>" "German (Deutsch) input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "latin-3-alt-postfix" "Latin-3" 'quail-use-package - "3<" "Latin-3 character input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "latin-4-alt-postfix" "Latin-4" 'quail-use-package - "4<" "Latin-4 characters input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "latin-5-alt-postfix" "Latin-5" 'quail-use-package - "5<" "Latin-5 characters input method with postfix modifiers" - "quail/latin-alt") + "irish-prefix" "Latin-1" 'quail-use-package + "GA>" "Irish input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "danish-alt-postfix" "Latin-1" 'quail-use-package - "DA<" "Danish input method (rule: AE -> ,AF(B, OE -> ,AX(B, AA -> ,AE(B, E' -> ,AI(B)" - "quail/latin-alt") -(register-input-method - "esperanto-alt-postfix" "Latin-3" 'quail-use-package - "EO<" "Esperanto input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "finnish-alt-postfix" "Latin-1" 'quail-use-package - "FI<" "Finnish (Suomi) input method" - "quail/latin-alt") -(register-input-method - "french-alt-postfix" "Latin-1" 'quail-use-package - "FR<" "French (Fran,Ag(Bais) input method with postfix modifiers" - "quail/latin-alt") + "portuguese-prefix" "Latin-1" 'quail-use-package + "PT>" "Portuguese input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "german-alt-postfix" "Latin-1" 'quail-use-package - "DE<" "German (Deutsch) input method" - "quail/latin-alt") -(register-input-method - "icelandic-alt-postfix" "Latin-1" 'quail-use-package - "IS<" "Icelandic (,AM(Bslenska) input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "italian-alt-postfix" "Latin-1" 'quail-use-package - "IT<" "Italian (Italiano) input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "norwegian-alt-postfix" "Latin-1" 'quail-use-package - "NO<" "Norwegian (Norsk) input method (rule: AE->,AF(B, OE->,AX(B, AA->,AE(B, E'->,AI(B)" - "quail/latin-alt") + "spanish-prefix" "Latin-1" 'quail-use-package + "ES>" "Spanish (Espa,Aq(Bol) input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "scandinavian-alt-postfix" "Latin-1" 'quail-use-package - "SC<" "Scandinavian input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "spanish-alt-postfix" "Latin-1" 'quail-use-package - "ES<" "Spanish (Espa,Aq(Bol) input method with postfix modifiers" - "quail/latin-alt") + "latin-2-prefix" "Latin-2" 'quail-use-package + "2>" "Latin-2 characters input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "swedish-alt-postfix" "Latin-1" 'quail-use-package - "SV<" "Swedish (Svenska) input method (rule: AA -> ,AE(B, AE -> ,AD(B, OE -> ,AV(B, E' -> ,AI(B)" - "quail/latin-alt") -(register-input-method - "turkish-alt-postfix" "Latin-3" 'quail-use-package - "TR<" "Turkish (T,C|(Brk,Cg(Be) input method with postfix modifiers" - "quail/latin-alt") + "latin-3-prefix" "Latin-3" 'quail-use-package + "3>" "Latin-3 characters input method with prefix modifiers" + "quail/latin-pre") (register-input-method "latin-1-postfix" "Latin-1" 'quail-use-package "1<" "Latin-1 character input method with postfix modifiers" @@ -367,86 +211,202 @@ "DV@" "English (ASCII) input method simulating Dvorak keyboard" "quail/latin-post") (register-input-method - "latin-1-prefix" "Latin-1" 'quail-use-package - "1>" "Latin-1 characters input method with prefix modifiers" - "quail/latin-pre") + "latin-1-alt-postfix" "Latin-1" 'quail-use-package + "1<" "Latin-1 character input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "latin-2-alt-postfix" "Latin-2" 'quail-use-package + "2<" "Latin-2 character input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "latin-3-alt-postfix" "Latin-3" 'quail-use-package + "3<" "Latin-3 character input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "catalan-prefix" "Latin-1" 'quail-use-package - "CA>" "Catalan and Spanish input method with prefix modifiers" - "quail/latin-pre") + "latin-4-alt-postfix" "Latin-4" 'quail-use-package + "4<" "Latin-4 characters input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "latin-5-alt-postfix" "Latin-5" 'quail-use-package + "5<" "Latin-5 characters input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "danish-alt-postfix" "Latin-1" 'quail-use-package + "DA<" "Danish input method (rule: AE -> ,AF(B, OE -> ,AX(B, AA -> ,AE(B, E' -> ,AI(B)" + "quail/latin-alt") (register-input-method - "esperanto-prefix" "Latin-1" 'quail-use-package - "EO>" "Esperanto input method with prefix modifiers" - "quail/latin-pre") + "esperanto-alt-postfix" "Latin-3" 'quail-use-package + "EO<" "Esperanto input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "finnish-alt-postfix" "Latin-1" 'quail-use-package + "FI<" "Finnish (Suomi) input method" + "quail/latin-alt") +(register-input-method + "french-alt-postfix" "Latin-1" 'quail-use-package + "FR<" "French (Fran,Ag(Bais) input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "french-prefix" "Latin-1" 'quail-use-package - "FR>" "French (Fran,Ag(Bais) input method with prefix modifiers" - "quail/latin-pre") + "german-alt-postfix" "Latin-1" 'quail-use-package + "DE<" "German (Deutsch) input method" + "quail/latin-alt") (register-input-method - "german-prefix" "Latin-1" 'quail-use-package - "DE>" "German (Deutsch) input method with prefix modifiers" - "quail/latin-pre") + "icelandic-alt-postfix" "Latin-1" 'quail-use-package + "IS<" "Icelandic (,AM(Bslenska) input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "italian-alt-postfix" "Latin-1" 'quail-use-package + "IT<" "Italian (Italiano) input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "irish-prefix" "Latin-1" 'quail-use-package - "GA>" "Irish input method with prefix modifiers" - "quail/latin-pre") + "norwegian-alt-postfix" "Latin-1" 'quail-use-package + "NO<" "Norwegian (Norsk) input method (rule: AE->,AF(B, OE->,AX(B, AA->,AE(B, E'->,AI(B)" + "quail/latin-alt") +(register-input-method + "scandinavian-alt-postfix" "Latin-1" 'quail-use-package + "SC<" "Scandinavian input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "spanish-alt-postfix" "Latin-1" 'quail-use-package + "ES<" "Spanish (Espa,Aq(Bol) input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "portuguese-prefix" "Latin-1" 'quail-use-package - "PT>" "Portuguese input method with prefix modifiers" - "quail/latin-pre") + "swedish-alt-postfix" "Latin-1" 'quail-use-package + "SV<" "Swedish (Svenska) input method (rule: AA -> ,AE(B, AE -> ,AD(B, OE -> ,AV(B, E' -> ,AI(B)" + "quail/latin-alt") +(register-input-method + "turkish-alt-postfix" "Latin-3" 'quail-use-package + "TR<" "Turkish (T,C|(Brk,Cg(Be) input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "ipa" "IPA" 'quail-use-package + "IPA" "International Phonetic Alphabet for English, French, German and Italian" + "quail/ipa") (register-input-method - "spanish-prefix" "Latin-1" 'quail-use-package - "ES>" "Spanish (Espa,Aq(Bol) input method with prefix modifiers" - "quail/latin-pre") + "korean-hanja" "Korean" 'quail-use-package + "$(C9zyS(B" "2$(C9z=D(BKSC$(CySm.(B: $(Cz1SWGO4B(B $(CySm.@G(B $(Cj$@;(B $(CGQ1[(B2$(C9zcR@87N(B $(C{" "Latin-2 characters input method with prefix modifiers" - "quail/latin-pre") + "korean-hangul" "Korean" 'quail-use-package + "$(CGQ(B2" "$(CGQ1[(B 2$(C9z=D(B: Hangul input method with Hangul keyboard layout (KSC5601)" + "quail/hangul") +(register-input-method + "greek-jis" "Greek" 'quail-use-package + "$B&8(B" "$B&%&K&K&G&M&I&J&A(B: Greek keyboard layout (JIS X0208.1983)" + "quail/greek") (register-input-method - "latin-3-prefix" "Latin-3" 'quail-use-package - "3>" "Latin-3 characters input method with prefix modifiers" - "quail/latin-pre") + "greek" "Greek" 'quail-use-package + ",FY(B" ",FEkkgmij\(B: Greek keyboard layout (ISO 8859-7)" + "quail/greek") +(register-input-method + "cyrillic-jcuken" "Cyrillic" 'quail-use-package + ",L69(B" ",L9FC:5=(B keyboard layout widely used in Russia (ISO 8859-5 encoding)" + "quail/cyrillic") (register-input-method - "lao-lrt" "Lao" 'quail-use-package - "(1E(BR" "Lao input method using LRT (Lao Roman Transcription)." - "quail/lrt") + "cyrillic-macedonian" "Cyrillic" 'quail-use-package + ",L6(BM" ",L)*5@B7(B-,L#,(B keyboard layout based on JUS.I.K1.004 (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-serbian" "Cyrillic" 'quail-use-package + ",L6(BS" ",L)*5@B7(B-,L"+(B keyboard layout based on JUS.I.K1.005 (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-beylorussian" "Cyrillic" 'quail-use-package + ",L6(BB" ",L)*5@B7(B-,L&.(B BEYLORUSSIAN (ISO 8859-5 encoding)" + "quail/cyrillic") (register-input-method - "chinese-py-punct" "Chinese-GB" 'quail-use-package - "$AF47{(B" "$A::WVJdHk(B $AF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B" - "quail/py-punct") + "cyrillic-ukrainian" "Cyrillic" 'quail-use-package + ",L6(BU" ",L$'5@B7(B-,L&.(B UKRAINIAN (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-yawerty" "Cyrillic" 'quail-use-package + ",L6O(B" ",LO25@BK(B Roman transcription (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-translit" "Cyrillic" 'quail-use-package + ",L6(Bt" "Intuitively transliterated keyboard layout." + "quail/cyrillic") (register-input-method - "chinese-py-punct-b5" "Chinese-BIG5" 'quail-use-package - "$AF47{(B" "$(0&d'GTT&,!J3<5x!K(B and `v' for $(0O:X5>KHATT&,(B" - "quail/pypunct-b5") + "cyrillic-translit-bulgarian" "Cyrillic" 'quail-use-package + ",L6(Btb" "Intuitively transliterated keyboard layout optimized for Bulgarian." + "quail/cyrillic") +(register-input-method + "cyrillic-jis-russian" "Cyrillic" 'quail-use-package + "$B'('+(B" "$B'+'8'5','&'/(B keyboard layout same as JCUKEN (JIS X0208.1983 encoding)" + "quail/cyril-jis") +(register-input-method + "chinese-zozy" "Chinese-BIG5" 'quail-use-package + "$(0I\0D(B" "$(0&d'GTT&,!JI\@c0D5x!K(B" + "quail/ZOZY") (register-input-method - "chinese-b5-quick" "Chinese-BIG5" 'quail-use-package - "$(0X|(BB" "$(0&d'GTT&,!JX|/y!K(BBIG5" - "quail/quick-b5") + "chinese-ziranma" "Chinese-GB" 'quail-use-package + "$AK+F4(B" "$A::WVJdHk!KWTH;K+F4!K(B " + "quail/ZIRANMA") (register-input-method - "chinese-cns-quick" "Chinese-CNS" 'quail-use-package - "$(Gv|(BC" "$(GDcEFrSD+!Jv|Mx!K(BCNS" - "quail/quick-cns") + "chinese-tonepy" "Chinese-GB" 'quail-use-package + "$A5wF4(B" "$A::WVJdHk!K4x5wF4Rt!K# (B" + "quail/TONEPY") +(register-input-method + "chinese-sw" "Chinese-GB" 'quail-use-package + "$AJWN2(B" "$A::WVJdHk!KJWN2!K# (B" + "quail/SW") (register-input-method - "korean-symbol" "Korean" 'quail-use-package - "$(CGQ1[=I9z@T7BG%(B" "$(CGQ1[=I9z@T7BG%(B:" - "quail/symbol-ksc") + "chinese-qj" "Chinese-GB" 'quail-use-package + "$AH+(BG" "$A::WVJdHk!KH+=G!K# (B" + "quail/QJ") +(register-input-method + "chinese-qj-b5" "Chinese-BIG5" 'quail-use-package + "$(0)A(BB" "$(0&d'GTT&,!J)A,1!K(B" + "quail/QJ-b5") +(register-input-method + "chinese-punct" "Chinese-GB" 'quail-use-package + "$A1j(BG" "$A::WVJdHk!K1j5c7{:E!K# (B" + "quail/Punct") (register-input-method - "thai-kesmanee" "Thai" 'quail-use-package - ",T!!(B>" "Thai Kesmanee input method with TIS620 keyboard layout" - "quail/thai") + "chinese-punct-b5" "Chinese-BIG5" 'quail-use-package + "$(0O:(BB" "$(0&d'GTT&,!JO:X5>KHA!K(B" + "quail/Punct-b5") (register-input-method - "thai-pattachote" "Thai" 'quail-use-package - ",T!;(B>" "Thai Pattachote input method with TIS620 keyboard layout" - "quail/thai") + "chinese-py" "Chinese-GB" 'quail-use-package + "$AF4(BG" "$A::WVJdHk!KF4Rt!K# (B" + "quail/PY") +(register-input-method + "chinese-py-b5" "Chinese-BIG5" 'quail-use-package + "$(03<(BB" "$(0&d'GTT&,!J3<5x!K(B" + "quail/PY-b5") (register-input-method - "chinese-b5-tsangchi" "Chinese-BIG5" 'quail-use-package - "$(06A(BB" "$(0&d'GTT&,!J6AQo!K(BBIG5" - "quail/tsang-b5") + "chinese-etzy" "Chinese-BIG5" 'quail-use-package + "$(06/0D(B" "$(0&d'GTT&,!J6/'30D5x!K(B" + "quail/ETZY") +(register-input-method + "chinese-ecdict" "Chinese-BIG5" 'quail-use-package + "$(05CKH(B" "$(0&d'GTT&,!J5CKH[0.)!K(B" + "quail/ECDICT") +(register-input-method + "chinese-ctlaub" "Chinese-BIG5" 'quail-use-package + "$(0N,Gn(B" "$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B" + "quail/CTLauB") (register-input-method - "chinese-cns-tsangchi" "Chinese-CNS" 'quail-use-package - "$(GT?(BC" "$(GDcEFrSD+!JT?on!K(BCNS" - "quail/tsang-cns") + "chinese-ctlau" "Chinese-GB" 'quail-use-package + "$AAuTA(B" "$A::WVJdHk!KAuN}OiJ=TARt!K(B" + "quail/CTLau") +(register-input-method + "chinese-ccdospy" "Chinese-GB" 'quail-use-package + "$AKuF4(B" "$A::WVJdHk!KKuP4F4Rt!K# (B" + "quail/CCDOSPY") (register-input-method - "vietnamese-viqr" "Vietnamese" 'quail-use-package - "VQ" "Vietnamese input method with VIQR mnemonic system" - "quail/viqr") + "chinese-array30" "Chinese-BIG5" 'quail-use-package + "$(0#R#O(B" "$(0&d'G!J*h)E#R#O!K(B " + "quail/ARRAY30") +(register-input-method + "chinese-4corner" "Chinese-BIG5" 'quail-use-package + "$(0(?-F(B" "$(0(?-FHAP#(B:: " + "quail/4Corner") diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/quail/cyrillic.el --- a/lisp/leim/quail/cyrillic.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/leim/quail/cyrillic.el Mon Aug 13 10:03:52 2007 +0200 @@ -741,7 +741,7 @@ Also included are Ukrainian ,Lt(B (YE) = \"/e\" and ,Lw(B (YI) = \"yi\", Belorussian ,L~(B (SHORT U) = \"u'\", -Serbo-Croatian ,Lr(B (DJE) = \"/d\", ,L{(B (CHJE)= \"/ch\", +Serbian ,Lr(B (DJE) = \"/d\", ,L{(B (CHJE)= \"/ch\", Macedonian ,Ls(B (GJE) = \"/g\", ,Lu(B (DZE) = \"/s\", ,L|(B (KJE) = \"/k\", cyrillic ,Lv(B (I DECIMAL) = \"/i\", ,Lx(B (JE) = \"/j\", ,Ly(B (LJE) = \"/l\", ,Lz(B (NJE) = \"/n\" and ,L(B (DZE) =\"/z\"." diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/quail/devanagari.el --- a/lisp/leim/quail/devanagari.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,675 +0,0 @@ -;; quail/devanagari.el -- Quail packages for inputting Devanagari - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: KAWABATA, Taichi - -;; Keywords: multilingual, input method, Indian, Devanagari - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; History: -;; 1996.10.10 written by KAWABATA, Taichi -;; 1997.03.21 fixed by KAWABATA, Taichi - -;; I'm not sure if this keyboard layout is REALLY an ISCII keyboard layout. -;; Please let me know if it is not. - -;;; Code: - -(require 'quail) -(require 'devan-util) - -;; This function does nothing for now. For future use. -(defun quail-devanagari-update-translation (control-flag) - (cond ((eq control-flag t) ; terminate translation with the whole key. - (insert quail-current-str) - (quail-terminate-translation)) - ((null control-flag) ; proceed translation with more keys. - (insert (or quail-current-str quail-current-key))) - (t ; control-flag is the number of keys to be translated. - (insert (aref quail-current-key 0)) - (setq unread-command-events - (list (aref quail-current-key control-flag)))))) - -(defun quail-devanagari-compose-characters () - (interactive) - (if (quail-point-in-conversion-region) - (let* ((from (overlay-start quail-conv-overlay)) - (to (overlay-end quail-conv-overlay)) - (dstr (buffer-substring from to))) - (delete-overlay quail-overlay) - (delete-overlay quail-conv-overlay) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (delete-region (point-min) (point-max)) - (insert (devanagari-compose-string dstr 'sanskrit)) - (goto-char (point-max))) - (setq overriding-terminal-local-map nil))) - (setq unread-command-events (list last-command-event))) - -(quail-define-package - "devanagari-keyboard-a" "Devanagari" "DevK" t - "Devanagari input method with ISCII format - - `$(5!\(B !$(5!.(B @$(5!c(B #x $x %x ^x &$(5")(B *$(5"((B ( ) _$(5!#(B +$(5!*(B - ~$(5!/(B 1$(5!r(B 2$(5!s(B 3$(5!t(B 4$(5!u(B 5$(5!v(B 6$(5!w(B 7$(5!x(B 8$(5!y(B 9$(5!z(B 0$(5!q(B - =$(5!_(B - - Q$(5!f(B W$(5!-(B E$(5!%(B R$(5!'(B T$(5!)(B Y$(5!K(B U$(5!7(B I$(5!E(B O$(5!C(B P$(5!;(B {$(5!@(B }$(5!<(B |$(5!2(B - q$(5!f(B w$(5!b(B e$(5!Z(B r$(5!\(B t$(5!^(B y$(5!J(B u$(5!X(B i$(5!5(B o$(5!D(B p$(5!:(B [$(5!?(B ]$(5!i(B \\$(5!g(B - - A$(5!0(B S$(5!,(B D$(5!$(B F$(5!&(B G$(5!((B H$(5!I(B J$(5!P(B K$(5!4(B l$(5!C(B :$(5!8(B \"$(5!>(B - a$(5!e(B s$(5!a(B d$(5!h(B f$(5![(B g$(5!](B h$(5!H(B j$(5!O(B k$(5!3(B l$(5!B(B ;$(5!9(B '$(5!=(B - - Z$(5!+(B X$(5!!(B C$(5!A(B V$(5!G(B B$(5!S(B N$(5!R(B M$(5!U(B <$(5!V(B >$(5!j(B ?$(5!N(B - z$(5!`(B x$(5!"(B c$(5!L(B v$(5!F(B b$(5!T(B n$(5!Q(B m$(5!W(B , . /$(5!M(B -" - nil t t nil nil nil nil nil - ;;'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-compose-characters) - ("-" . quail-devanagari-compose-characters) - ("," . quail-devanagari-compose-characters) - ("\C-m" . quail-devanagari-compose-characters) - ([return] . quail-devanagari-compose-characters)) - ) - -;; ..... (not prepared yet) -;; I forgot where I got this keymap from. -;; Please let me know if you know what this keymap is. - -(quail-define-rules - ("`" ?$(5!\(B) - ("~" ?$(5!/(B) - ("1" ?$(5!r(B) - ("!" ?$(5!.(B) - ("2" ?$(5!s(B) - ("@" ?$(5!c(B) - ("3" ?$(5!t(B) - ("#" ?# ) ; following "r" in keymap... - ("4" ?$(5!u(B) - ("$" ?$ ) ; preceding "r" in keymap... - ("5" ?$(5!v(B) - ("%" ?x ) ; ?? - ("6" ?$(5!w(B) - ("^" ?x ) ; %tra - ("7" ?$(5!x(B) - ("&" ?$(5")(B) ; % special - ("8" ?$(5!y(B) - ("*" ?$(5"((B) ; % special - ("9" ?$(5!z(B) - ("(" ?\() - ("0" ?$(5!q(B) - (")" ?\)) - ("-" ?-) - ("_" ?$(5!#(B) - ("=" ?$(5!_(B) - ("+" ?$(5!*(B) - ("q" ?$(5!f(B) - ("Q" ?$(5!1(B) - ("w" ?$(5!b(B) - ("W" ?$(5!-(B) - ("e" ?$(5!Z(B) - ("E" ?$(5!%(B) - ("r" ?$(5!\(B) - ("R" ?$(5!'(B) - ("t" ?$(5!^(B) - ("T" ?$(5!)(B) - ("y" ?$(5!J(B) - ("Y" ?$(5!K(B) - ("u" ?$(5!X(B) - ("U" ?$(5!7(B) - ("i" ?$(5!5(B) - ("I" ?$(5!E(B) - ("o" ?$(5!D(B) - ("O" ?$(5!C(B) - ("p" ?$(5!:(B) - ("P" ?$(5!;(B) - ("[" ?$(5!?(B) - ("{" ?$(5!@(B) - ("]" ?$(5!i(B) - ("}" ?$(5!<(B) - ("\\" ?$(5!g(B) - ("|" ?$(5!2(B) - ("a" ?$(5!e(B) - ("A" ?$(5!0(B) - ("s" ?$(5!a(B) - ("S" ?$(5!,(B) - ("d" ?$(5!h(B) - ("D" ?$(5!$(B) - ("f" ?$(5![(B) - ("F" ?$(5!&(B) - ("g" ?$(5!](B) - ("G" ?$(5!((B) - ("h" ?$(5!H(B) - ("H" ?$(5!I(B) - ("j" ?$(5!O(B) - ("J" ?$(5!P(B) - ("k" ?$(5!3(B) - ("K" ?$(5!4(B) - ("l" ?$(5!B(B) - ("L" ?$(5!C(B) - (";" ?$(5!8(B) - (":" ?$(5!9(B) - ("'" ?$(5!=(B) - ("\"" ?$(5!>(B) - ("z" ?$(5!`(B) - ("Z" ?$(5!+(B) - ("x" ?$(5!"(B) - ("X" ?$(5!!(B) - ("c" ?$(5!L(B) - ("C" ?$(5!A(B) - ("v" ?$(5!F(B) - ("V" ?$(5!G(B) - ("b" ?$(5!T(B) - ("B" ?$(5!S(B) - ("n" ?$(5!Q(B) - ("N" ?$(5!R(B) - ("m" ?$(5!W(B) - ("M" ?$(5!U(B) - ;; ("," ?,) - ("<" ?$(5!V(B) - ;; ("." ?.) - (">" ?$(5!j(B) - ("/" ?$(5!M(B) - ("?" ?$(5!N(B) - ) - - -;; -;; Quail Devanagari Input By Transliteration -;; - -(eval-when-compile - -(defvar devanagari-consonant-transliteration-alist - '( - ; GUTTURALS - ("k" . "$(5!3(B") - ("k." . "$(5!3!i(B") - ("kh" . "$(5!4(B") - ("kh." . "$(5!4!i(B") - ("g" . "$(5!5(B") - ("g." . "$(5!5!i(B") - ("gh" . "$(5!6(B") - ("G" . "$(5!7(B") - ; PALATALS - ("c" . "$(5!8(B") - ("ch" . "$(5!9(B") - ("j" . "$(5!:(B") - ("j." . "$(5!:!i(B") - ("Z" . "$(5!:!i(B") - ("jh" . "$(5!;(B") - ("J" . "$(5!<(B") - ; CEREBRALS - ("T" . "$(5!=(B") - ("Th" . "$(5!>(B") - ("D" . "$(5!?(B") - ("D." . "$(5!?!i(B") - ("Dh" . "$(5!@(B") - ("Dh." . "$(5!@!i(B") - ("N" . "$(5!A(B") - ; DENTALS - ("t" . "$(5!B(B") - ("th" . "$(5!C(B") - ("d" . "$(5!D(B") - ("dh" . "$(5!E(B") - ("n" . "$(5!F(B") - ("N." . "$(5!G(B") - ; LABIALS - ("p" . "$(5!H(B") - ("ph" . "$(5!I(B") - ("ph." . "$(5!I!i(B") - ("f" . "$(5!I(B") - ("f." . "$(5!I!i(B") - ("b" . "$(5!J(B") - ("bh" . "$(5!K(B") - ("m" . "$(5!L(B") - ; SEMIVOWELS - ("y" . "$(5!M(B") - ("y." . "$(5!N(B") - ("Y" . "$(5!N(B") - ("r" . "$(5!O(B") - ("r." . "$(5!P(B") - ("l" . "$(5!Q(B") - ("W" . "$(5!R(B") - ("W." . "$(5!S(B") - ("v" . "$(5!T(B") - ("w" . "$(5!T(B") - ; SIBILANTS - ("z" . "$(5!U(B") - ("S" . "$(5!V(B") - ("s" . "$(5!W(B") - ("h" . "$(5!X(B") - )) - -(defvar devanagari-vowel-transliteration-alist - '( - ;; Special treatment unique to IS 13194 Transliteration - ("" . "$(5!h(B") - ("a" . "") - ; Matra (Vowel Sign) - ("A" . "$(5!Z(B") - ("i" . "$(5![(B") - ("I" . "$(5!\(B") - ("u" . "$(5!](B") - ("U" . "$(5!^(B") - ("R" . "$(5!_(B") - ;; ("RR" . "x") ; not specified in ordinary IS 13194.(but in Unicode??) - ("q" . "$(5#K(B") ; "$(5#K(B" = "$(5!_!i(B" in IS 13194. - ("L" . "$(5#L(B") ; "$(5#L(B" = "$(5![!i(B" in IS 13194. - ("E" . "$(5#M(B") ; "$(5#M(B" = "$(5!\!i(B" in IS 13194. - ("E" . "$(5!`(B") ; only for transcription of other scripts. - ("e" . "$(5!a(B") - ("ai" . "$(5!b(B") - ("ae" . "$(5!b(B") ; variation of transliteration. - ("EE" . "$(5!c(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!d(B") ; only for transcription of other scripts. - ("o" . "$(5!e(B") - ("au" . "$(5!f(B") - ("ao" . "$(5!f(B") ; variation of transliteration. - ("OO" . "$(5!g(B") ; only for transcription of other scripts. (Candra O) - )) - -;; -;; Independent vowels and other signs. -;; - -(defvar devanagari-other-letters-alist - '( - ("a" . "$(5!$(B") - ("A" . "$(5!%(B") - ("i" . "$(5!&(B") - ("I" . "$(5!'(B") - ("u" . "$(5!((B") - ("U" . "$(5!)(B") - ("R" . "$(5!*(B") - ;; ("RR" . "x") ; not specified in IS 13194. (but in Unicode??) - ("q" . "$(5#*(B") ; "$(5#*(B" = "$(5!*!i(B" in IS 13194. - ("L" . "$(5#&(B") ; "$(5#&(B" = "$(5!&!i(B" in IS 13194. - ("E" . "$(5#'(B") ; "$(5#'(B" = "$(5!'!i(B" in IS 13194. - ("Ex" . "$(5!+(B") ; only for transcription of other scripts. - ("e" . "$(5!,(B") - ("ai" . "$(5!-(B") - ("EE" . "$(5!.(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!/(B") ; only for transcription of other scripts. - ("o" . "$(5!0(B") - ("au" . "$(5!1(B") - ("ao" . "$(5!1(B") ; variation of transliteration. - ("OO" . "$(5!2(B") ; only for transcription of other scripts. (Candra O) - ("'" . "$(5#J(B") ; avagraha - ("@" . "$(5#!(B") ; OM - ("/" . "$(5!j(B") - ("M" . "$(5!"(B") - ("&" . "$(5!!(B") - ("H" . "$(5!#(B") - ("." . "$(5!i(B") ; Nukta - ("0" . "$(5!q(B") - ("1" . "$(5!r(B") - ("2" . "$(5!s(B") - ("3" . "$(5!t(B") - ("4" . "$(5!u(B") - ("5" . "$(5!v(B") - ("6" . "$(5!w(B") - ("7" . "$(5!x(B") - ("8" . "$(5!y(B") - ("9" . "$(5!z(B") - )) -) - -(defmacro devanagari-transliteration-quail-define-rules () - (cons 'quail-define-rules - (let ((cl devanagari-consonant-transliteration-alist) - (ml devanagari-other-letters-alist) rules) - (while cl - (let ((vl devanagari-vowel-transliteration-alist)) - (while vl - (setq rules - (cons (list (concat (car (car cl)) (car (car vl))) - (make-vector 1 - (concat (cdr (car cl)) (cdr (car vl))))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (list (car (car ml)) - (make-vector 1 (cdr (car ml)))) - rules)) - (setq ml (cdr ml))) - rules))) - -(quail-define-package - "devanagari-transliteration" "Devanagari" "DEVt" t - "Devanagari input method by transliteration -VOWELS : a $(5!$(B A $(5!%(B i $(5!&(B I $(5!'(B u $(5!((B U $(5!)(B - R $(5!*(B q $(5#*(B L $(5#&(B E $(5#'(B Ex $(5!+(B e $(5!,(B - ai $(5!-(B EE $(5!.(B O $(5!/(B o $(5!0(B au $(5!1(B OO $(5!2(B -GRUTTALS : k $(5!3(B kh $(5!4(B g $(5!5(B gh $(5!6(B G $(5!7(B -PALATALS : c $(5!8(B ch $(5!9(B j $(5!:(B jh $(5!;(B J $(5!<(B (Z $(5!:!i(B) -CEREBRALS : T $(5!=(B Th $(5!>(B D $(5!?(B Dh $(5!@(B N $(5!A(B -DENTALS : t $(5!B(B th $(5!C(B d $(5!D(B dh $(5!E(B n $(5!F(B (Nq $(5!G(B) -LABIALS : p $(5!H(B ph $(5!I(B b $(5!J(B bh $(5!K(B m $(5!L(B (f $(5!I(B) -SEMIVOWELS : y $(5!M(B Y $(5!N(B r $(5!O(B Rq $(5!P(B - l $(5!Q(B W $(5!R(B W. $(5!S(B v $(5!T(B w $(5!T(B -SIBILANTS : z $(5!U(B S $(5!V(B s $(5!W(B h $(5!X(B - -Specials : Anuswar M $(5!"(B Visarg H $(5!#(B - Chandrabindu & $(5!!(B Nukta . $(5!i(B - Danda / $(5!j(B Avagrah ' $(5#J(B - OM @ $(5#!(B -" - nil t t nil nil nil nil nil - ;; 'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-compose-characters) - ("-" . quail-devanagari-compose-characters) - ("," . quail-devanagari-compose-characters) - ("\C-m" . quail-devanagari-compose-characters) - ([return] . quail-devanagari-compose-characters)) - ) - -(devanagari-transliteration-quail-define-rules) - -;; -;; ITRANS - Indian Script Translation -;; - -(eval-and-compile - -(defun rule-indian-to-devanagari (alist) - (if (null alist) nil - (cons (cons (car (car alist)) - (indian-to-devanagari-string (cdr (car alist)))) - (rule-indian-to-devanagari (cdr alist))))) -) - -(eval-when-compile - -(defvar devanagari-consonant-itrans-alist - (rule-indian-to-devanagari indian-itrans-consonant-alist)) - -(defvar devanagari-vowel-itrans-alist - (rule-indian-to-devanagari indian-itrans-vowel-sign-alist)) - -(defvar devanagari-other-letters-itrans-alist - (rule-indian-to-devanagari indian-itrans-other-letters-alist)) - -) - -(defmacro devanagari-itrans-quail-define-rules () - (cons 'quail-define-rules - (let ((cl devanagari-consonant-itrans-alist) - (ml devanagari-other-letters-itrans-alist) rules) - (while cl - (let ((vl devanagari-vowel-itrans-alist)) - (while vl - (setq rules - (cons (list (concat (car (car cl)) (car (car vl))) - (make-vector 1 - (concat (cdr (car cl)) (cdr (car vl))))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (list (car (car ml)) - (make-vector 1 (cdr (car ml)))) - rules)) - (setq ml (cdr ml))) - rules))) - -(quail-define-package - "devanagari-itrans" "Devanagari" "DEVi" t - "Devanagari input method by ITRANS -Special Keys : Anuswar n' - Chandrabindu nn' - Visarg nh - Nukta type capital letter for first character. - $(5!7(B(ng) $(5!<(B(ny) $(5!A(B(nn) $(5!F(B(n) $(5!G(B(nnn) -" - nil t t nil nil nil nil nil - ;; 'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-compose-characters) - ("-" . quail-devanagari-compose-characters) - ("," . quail-devanagari-compose-characters) - ("\C-m" . quail-devanagari-compose-characters) - ([return] . quail-devanagari-compose-characters)) - ) - -(devanagari-itrans-quail-define-rules) - - -;; -;; Quail Hindi Input By Transliteration -;; - -(defun quail-devanagari-hindi-compose-characters () - (interactive) - (if (quail-point-in-conversion-region) - (let* ((from (overlay-start quail-conv-overlay)) - (to (overlay-end quail-conv-overlay)) - (dstr (buffer-substring from to))) - (delete-overlay quail-overlay) - (delete-overlay quail-conv-overlay) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (delete-region (point-min) (point-max)) - (insert (devanagari-compose-string dstr)) - (goto-char (point-max))) - (setq overriding-terminal-local-map nil))) - (setq unread-command-events (list last-command-event))) - -(eval-when-compile - -(defvar devanagari-hindi-consonant-transliteration-alist - '( - ; GUTTURALS - ("k" . "$(5!3(B") - ("ks" . "$(5$.(B") - ("k." . "$(5!3!i(B") - ("kh" . "$(5!4(B") - ("kh." . "$(5!4!i(B") - ("g" . "$(5!5(B") - ("g." . "$(5!5!i(B") - ("gh" . "$(5!6(B") - ("G" . "$(5!7(B") - ; PALATALS - ("ch" . "$(5!8(B") - ("chh" . "$(5!9(B") - ("j" . "$(5!:(B") - ("j." . "$(5!:!i(B") - ("z" . "$(5!:!i(B") - ("jh" . "$(5!;(B") - ("J" . "$(5!<(B") - ; CEREBRALS - ("T" . "$(5!=(B") - ("Th" . "$(5!>(B") - ("D" . "$(5!?(B") - ("D." . "$(5!?!i(B") - ("Dh" . "$(5!@(B") - ("Dh." . "$(5!@!i(B") - ("N" . "$(5!A(B") - ; DENTALS - ("t" . "$(5!B(B") - ("th" . "$(5!C(B") - ("d" . "$(5!D(B") - ("dh" . "$(5!E(B") - ("n" . "$(5!F(B") - ("N." . "$(5!G(B") - ; LABIALS - ("p" . "$(5!H(B") - ("ph" . "$(5!I(B") - ("ph." . "$(5!I!i(B") - ("f" . "$(5!I(B") - ("f." . "$(5!I!i(B") - ("b" . "$(5!J(B") - ("bh" . "$(5!K(B") - ("m" . "$(5!L(B") - ; SEMIVOWELS - ("y" . "$(5!M(B") - ("y." . "$(5!N(B") - ("Y" . "$(5!N(B") - ("r" . "$(5!O(B") - ("r." . "$(5!P(B") - ("l" . "$(5!Q(B") - ("W" . "$(5!R(B") - ("W." . "$(5!S(B") - ("v" . "$(5!T(B") - ("w" . "$(5!T(B") - ; SIBILANTS - ("sh" . "$(5!U(B") - ("S" . "$(5!V(B") - ("s" . "$(5!W(B") - ("h" . "$(5!X(B") - ; Special for Hindi - ("ks" . "$(5$.(B") - ("tr" . "$(5"%(B") - ("xn" . "$(5$E(B") - )) - -(defvar devanagari-hindi-vowel-transliteration-alist - '( - ; In hindi, halant sign is rarely used so should explicity typed in. - ("" . "") - ("~" . "$(5!h(B") - ; Matra (Vowel Sign) - ("a" . "$(5!Z(B") - ("i" . "$(5![(B") - ("I" . "$(5!\(B") - ("u" . "$(5!](B") - ("U" . "$(5!^(B") - ("R" . "$(5!_(B") - ;; ("RR" . "x") ; not specified in ordinary IS 13194.(but in Unicode??) - ("q" . "$(5#K(B") ; "$(5#K(B" = "$(5!_!i(B" in IS 13194. - ("L" . "$(5#L(B") ; "$(5#L(B" = "$(5![!i(B" in IS 13194. - ("E" . "$(5#M(B") ; "$(5#M(B" = "$(5!\!i(B" in IS 13194. - ("E" . "$(5!`(B") ; only for transcription of other scripts. - ("e" . "$(5!a(B") - ("ai" . "$(5!b(B") - ("ae" . "$(5!b(B") ; variation of transliteration. - ("EE" . "$(5!c(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!d(B") ; only for transcription of other scripts. - ("o" . "$(5!e(B") - ("au" . "$(5!f(B") - ("ao" . "$(5!f(B") ; variation of transliteration. - ("OO" . "$(5!g(B") ; only for transcription of other scripts. (Candra O) - )) - -;; -;; Independent vowels and other signs. -;; - -(defvar devanagari-hindi-other-letters-alist - '( - ("a" . "$(5!$(B") - ("A" . "$(5!%(B") - ("i" . "$(5!&(B") - ("I" . "$(5!'(B") - ("u" . "$(5!((B") - ("U" . "$(5!)(B") - ("R" . "$(5!*(B") - ;; ("RR" . "x") ; not specified in IS 13194. (but in Unicode??) - ("q" . "$(5#*(B") ; "$(5#*(B" = "$(5!*!i(B" in IS 13194. - ("L" . "$(5#&(B") ; "$(5#&(B" = "$(5!&!i(B" in IS 13194. - ("E" . "$(5#'(B") ; "$(5#'(B" = "$(5!'!i(B" in IS 13194. - ("Ex" . "$(5!+(B") ; only for transcription of other scripts. - ("e" . "$(5!,(B") - ("ai" . "$(5!-(B") - ("EE" . "$(5!.(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!/(B") ; only for transcription of other scripts. - ("o" . "$(5!0(B") - ("au" . "$(5!1(B") - ("ao" . "$(5!1(B") ; variation of transliteration. - ("OO" . "$(5!2(B") ; only for transcription of other scripts. (Candra O) - ("'" . "$(5#J(B") ; avagraha - ("@" . "$(5#!(B") ; OM - ("/" . "$(5!j(B") - ("M" . "$(5!"(B") - ("&" . "$(5!!(B") - ("H" . "$(5!#(B") - ("." . "$(5!i(B") ; Nukta - ("0" . "$(5!q(B") - ("1" . "$(5!r(B") - ("2" . "$(5!s(B") - ("3" . "$(5!t(B") - ("4" . "$(5!u(B") - ("5" . "$(5!v(B") - ("6" . "$(5!w(B") - ("7" . "$(5!x(B") - ("8" . "$(5!y(B") - ("9" . "$(5!z(B") - )) -) - -(defmacro devanagari-hindi-transliteration-quail-define-rules () - (cons 'quail-define-rules - (let ((cl devanagari-hindi-consonant-transliteration-alist) - (ml devanagari-hindi-other-letters-alist) rules) - (while cl - (let ((vl devanagari-hindi-vowel-transliteration-alist)) - (while vl - (setq rules - (cons (list (concat (car (car cl)) (car (car vl))) - (make-vector 1 - (concat (cdr (car cl)) (cdr (car vl))))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (list (car (car ml)) - (make-vector 1 (cdr (car ml)))) - rules)) - (setq ml (cdr ml))) - rules))) - -(quail-define-package - "devanagari-hindi-transliteration" "Hindi" "HINt" t - "Devanagari-Hindi input method by transliteration -VOWELS : a $(5!$(B A $(5!%(B i $(5!&(B I $(5!'(B u $(5!((B U $(5!)(B - R $(5!*(B q $(5#*(B L $(5#&(B E $(5#'(B Ex $(5!+(B e $(5!,(B - ai $(5!-(B EE $(5!.(B O $(5!/(B o $(5!0(B au $(5!1(B OO $(5!2(B -GRUTTALS : k $(5!3(B kh $(5!4(B g $(5!5(B gh $(5!6(B G $(5!7(B -PALATALS : c $(5!8(B ch $(5!9(B j $(5!:(B jh $(5!;(B J $(5!<(B z $(5!:!i(B -CEREBRALS : T $(5!=(B Th $(5!>(B D $(5!?(B Dh $(5!@(B N $(5!A(B -DENTALS : t $(5!B(B th $(5!C(B d $(5!D(B dh $(5!E(B n $(5!F(B (Nq $(5!G(B) -LABIALS : p $(5!H(B ph $(5!I(B b $(5!J(B bh $(5!K(B m $(5!L(B (f $(5!I(B) -SEMIVOWELS : y $(5!M(B Y $(5!N(B r $(5!O(B Rq $(5!P(B - l $(5!Q(B W $(5!R(B W. $(5!S(B v $(5!T(B w $(5!T(B -SIBILANTS : sh $(5!U(B S $(5!V(B s $(5!W(B h $(5!X(B -OTHERS : ks $(5$.(B tr $(5"%(B xn $(5$E(B - -Specials : Anuswar M $(5!"(B Visarg H $(5!#(B - Chandrabindu & $(5!!(B Nukta . $(5!i(B - Danda / $(5!j(B Avagrah ' $(5#J(B - OM @ $(5#!(B Halant ~ $(5!h(B -" - nil t t nil nil nil nil nil - ;; 'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-hindi-compose-characters) - ("-" . quail-devanagari-hindi-compose-characters) - ("," . quail-devanagari-hindi-compose-characters) - ("\C-m" . quail-devanagari-hindi-compose-characters) - ([return] . quail-devanagari-hindi-compose-characters)) - ) - -(devanagari-hindi-transliteration-quail-define-rules) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/quail/ethiopic.el --- a/lisp/leim/quail/ethiopic.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1041 +0,0 @@ -;; quail/ethiopic.el --- Quail package for inputting Ethiopic characters - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, ethiopic - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Author: TAKAHASHI Naoto - -;;; Code: - -(require 'quail) -(require 'ethio-util) - -;; -;; The package "ethiopic" -;; - -(quail-define-package - "ethiopic" "Ethiopic" - '("$(3$O#U!.(B " - (ethio-prefer-ascii-space "_" "$(3$h(B") - (ethio-prefer-ascii-punctuation "." "$(3$i(B")) - t " QUAIL PACKAGE FOR ETHIOPIC (TIGRIGNA AND AMHARIC) - -When you activate this package, Ethio minor mode is also turned on. - - KEYS AND FUNCTIONS - -F2 or `M-x ethio-toggle-space' - Toggles space characters for keyboard input. The current mode is - indicated in mode-line, whether by `_' (ASCII space) or `$(3$h(B' - (Ethiopic colon-like word separator). Even in the `$(3$h(B' mode, an - ASCII space is inserted if the point is preceded by `an Ethiopic - punctuation followed by zero or more ASCII spaces'. - -F3 or `M-x ethio-toggle-punctuation' - Toggles ASCII punctuations and Ethiopic punctuations for keyboard input. - The current mode is indicated by `.' (ASCII) or `$(3$i(B' (Ethiopic). - -S-SPC or `M-x ethio-insert-ethio-space' - Always insert an Ethiopic word separator `$(3$h(B'. With a prefix number, - insert that many word separators. - -C-' or `M-x ethio-gemination' - Compose the character before the point with the Ethiopic gemination mark. - If the characater is already composed, decompose it and remove the - gemination mark." - - ;; The following keys should work as defined in lisp/language/ethio-util, - ;; even during the translation. - '(([f2] . quail-execute-non-quail-command) - ([f3] . quail-execute-non-quail-command) - (" " . quail-execute-non-quail-command) - ([?\S- ] . quail-execute-non-quail-command) - ([?\C-'] . quail-execute-non-quail-command)) - t t) - -(quail-define-rules - ("he" ?$(3!!(B) - ("hu" ?$(3!"(B) - ("hi" ?$(3!#(B) - ("ha" ?$(3!$(B) - ("hE" ?$(3!%(B) - ("h" ?$(3!&(B) - ("ho" ?$(3!'(B) - ("hW" ?$(3"N(B) - ("hWa" ?$(3"N(B) - ("hWe" ?$(3"K(B) - ("hWu" ?$(3"P(B) - ("hWi" ?$(3"M(B) - ("hWE" ?$(3"O(B) - ("hW'" ?$(3"P(B) - - ("le" ?$(3!)(B) - ("lu" ?$(3!*(B) - ("li" ?$(3!+(B) - ("la" ?$(3!,(B) - ("lE" ?$(3!-(B) - ("l" ?$(3!.(B) - ("lo" ?$(3!/(B) - ("lW" ?$(3!0(B) - ("lWa" ?$(3!0(B) - ("lWe" ["$(3!.%n(B"]) - ("lWu" ["$(3!.%r(B"]) - ("lWi" ["$(3!.%o(B"]) - ("lWE" ["$(3!.%q(B"]) - ("lW'" ["$(3!.%r(B"]) - - ("Le" ?$(3!)(B) - ("Lu" ?$(3!*(B) - ("Li" ?$(3!+(B) - ("La" ?$(3!,(B) - ("LE" ?$(3!-(B) - ("L" ?$(3!.(B) - ("Lo" ?$(3!/(B) - ("LW" ?$(3!0(B) - ("LWa" ?$(3!0(B) - ("LWe" ["$(3!.%n(B"]) - ("LWu" ["$(3!.%r(B"]) - ("LWi" ["$(3!.%o(B"]) - ("LWE" ["$(3!.%q(B"]) - ("LW'" ["$(3!.%r(B"]) - - ("He" ?$(3!1(B) - ("Hu" ?$(3!2(B) - ("Hi" ?$(3!3(B) - ("Ha" ?$(3!4(B) - ("HE" ?$(3!5(B) - ("H" ?$(3!6(B) - ("Ho" ?$(3!7(B) - ("HW" ?$(3!8(B) - ("HWa" ?$(3!8(B) - ("HWe" ["$(3!6%n(B"]) - ("HWu" ["$(3!6%r(B"]) - ("HWi" ["$(3!6%o(B"]) - ("HWE" ["$(3!6%q(B"]) - ("HW'" ["$(3!6%r(B"]) - - ("me" ?$(3!9(B) - ("mu" ?$(3!:(B) - ("mi" ?$(3!;(B) - ("ma" ?$(3!<(B) - ("mE" ?$(3!=(B) - ("m" ?$(3!>(B) - ("mo" ?$(3!?(B) - ("mWe" ?$(3%1(B) - ("mWu" ?$(3%a(B) - ("mWi" ?$(3%A(B) - ("mW" ?$(3!@(B) - ("mWa" ?$(3!@(B) - ("mWE" ?$(3%Q(B) - ("mW'" ?$(3%a(B) - ("mY" ?$(3$_(B) - ("mYa" ?$(3$_(B) - - ("Me" ?$(3!9(B) - ("Mu" ?$(3!:(B) - ("Mi" ?$(3!;(B) - ("Ma" ?$(3!<(B) - ("ME" ?$(3!=(B) - ("M" ?$(3!>(B) - ("Mo" ?$(3!?(B) - ("MWe" ?$(3%1(B) - ("MWu" ?$(3%a(B) - ("MWi" ?$(3%A(B) - ("MW" ?$(3!@(B) - ("MWa" ?$(3!@(B) - ("MWE" ?$(3%Q(B) - ("MW'" ?$(3%a(B) - ("MY" ?$(3$_(B) - ("MYa" ?$(3$_(B) - - ("`se" ?$(3!A(B) - ("`su" ?$(3!B(B) - ("`si" ?$(3!C(B) - ("`sa" ?$(3!D(B) - ("`sE" ?$(3!E(B) - ("`s" ?$(3!F(B) - ("`so" ?$(3!G(B) - ("`sW" ?$(3!H(B) - ("`sWa" ?$(3!H(B) - ("`sWe" ["$(3!F%n(B"]) - ("`sWu" ["$(3!F%r(B"]) - ("`sWi" ["$(3!F%o(B"]) - ("`sWE" ["$(3!F%q(B"]) - ("`sW'" ["$(3!F%r(B"]) - - ("s2e" ?$(3!A(B) - ("s2u" ?$(3!B(B) - ("s2i" ?$(3!C(B) - ("s2a" ?$(3!D(B) - ("s2E" ?$(3!E(B) - ("s2" ?$(3!F(B) - ("s2o" ?$(3!G(B) - ("s2W" ?$(3!H(B) - ("s2Wa" ?$(3!H(B) - ("s2We" ["$(3!F%n(B"]) - ("s2Wu" ["$(3!F%r(B"]) - ("s2Wi" ["$(3!F%o(B"]) - ("s2WE" ["$(3!F%q(B"]) - ("s2W'" ["$(3!F%r(B"]) - - ("sse" ?$(3!A(B) - ("ssu" ?$(3!B(B) - ("ssi" ?$(3!C(B) - ("ssa" ?$(3!D(B) - ("ssE" ?$(3!E(B) - ("ss" ?$(3!F(B) - ("sso" ?$(3!G(B) - ("ssW" ?$(3!H(B) - ("ssWa" ?$(3!H(B) - ("ssWe" ["$(3!F%n(B"]) - ("ssWu" ["$(3!F%r(B"]) - ("ssWi" ["$(3!F%o(B"]) - ("ssWE" ["$(3!F%q(B"]) - ("ssW'" ["$(3!F%r(B"]) - - ("re" ?$(3!I(B) - ("ru" ?$(3!J(B) - ("ri" ?$(3!K(B) - ("ra" ?$(3!L(B) - ("rE" ?$(3!M(B) - ("r" ?$(3!N(B) - ("ro" ?$(3!O(B) - ("rW" ?$(3!P(B) - ("rWa" ?$(3!P(B) - ("rY" ?$(3$`(B) - ("rYa" ?$(3$`(B) - ("rWe" ["$(3!N%n(B"]) - ("rWu" ["$(3!N%r(B"]) - ("rWi" ["$(3!N%o(B"]) - ("rWE" ["$(3!N%q(B"]) - ("rW'" ["$(3!N%r(B"]) - - ("Re" ?$(3!I(B) - ("Ru" ?$(3!J(B) - ("Ri" ?$(3!K(B) - ("Ra" ?$(3!L(B) - ("RE" ?$(3!M(B) - ("R" ?$(3!N(B) - ("Ro" ?$(3!O(B) - ("RW" ?$(3!P(B) - ("RWa" ?$(3!P(B) - ("RYa" ?$(3$`(B) - ("RWe" ["$(3!N%n(B"]) - ("RWu" ["$(3!N%r(B"]) - ("RWi" ["$(3!N%o(B"]) - ("RWE" ["$(3!N%q(B"]) - ("RW'" ["$(3!N%r(B"]) - - ("se" ?$(3!Q(B) - ("su" ?$(3!R(B) - ("si" ?$(3!S(B) - ("sa" ?$(3!T(B) - ("sE" ?$(3!U(B) - ("s" ?$(3!V(B) - ("so" ?$(3!W(B) - ("sW" ?$(3!X(B) - ("sWa" ?$(3!X(B) - ("sWe" ["$(3!V%n(B"]) - ("sWu" ["$(3!V%r(B"]) - ("sWi" ["$(3!V%o(B"]) - ("sWE" ["$(3!V%q(B"]) - ("sW'" ["$(3!V%r(B"]) - - ("xe" ?$(3!Y(B) - ("xu" ?$(3!Z(B) - ("xi" ?$(3![(B) - ("xa" ?$(3!\(B) - ("xE" ?$(3!](B) - ("x" ?$(3!^(B) - ("xo" ?$(3!_(B) - ("xW" ?$(3!`(B) - ("xWa" ?$(3!`(B) - ("xWe" ["$(3!^%n(B"]) - ("xWu" ["$(3!^%r(B"]) - ("xWi" ["$(3!^%o(B"]) - ("xWE" ["$(3!^%q(B"]) - ("xW'" ["$(3!^%r(B"]) - - ("qe" ?$(3!a(B) - ("qu" ?$(3!b(B) - ("qi" ?$(3!c(B) - ("qa" ?$(3!d(B) - ("qE" ?$(3!e(B) - ("q" ?$(3!f(B) - ("qo" ?$(3!g(B) - ("qWe" ?$(3!i(B) - ("qWu" ?$(3!n(B) - ("qWi" ?$(3!k(B) - ("qW" ?$(3!l(B) - ("qWa" ?$(3!l(B) - ("qWE" ?$(3!m(B) - ("qW'" ?$(3!n(B) - - ("`qe" ?$(3%)(B) - ("`qu" ?$(3%*(B) - ("`qi" ?$(3%+(B) - ("`qa" ?$(3%,(B) - ("`qE" ?$(3%-(B) - ("`q" ?$(3%.(B) - ("`qo" ?$(3%/(B) - - ("q2e" ?$(3%)(B) - ("q2u" ?$(3%*(B) - ("q2i" ?$(3%+(B) - ("q2a" ?$(3%,(B) - ("q2E" ?$(3%-(B) - ("q2" ?$(3%.(B) - ("q2o" ?$(3%/(B) - - ("qqe" ?$(3%)(B) - ("qqu" ?$(3%*(B) - ("qqi" ?$(3%+(B) - ("qqa" ?$(3%,(B) - ("qqE" ?$(3%-(B) - ("qq" ?$(3%.(B) - ("qqo" ?$(3%/(B) - - ("Qe" ?$(3!q(B) - ("Qu" ?$(3!r(B) - ("Qi" ?$(3!s(B) - ("Qa" ?$(3!t(B) - ("QE" ?$(3!u(B) - ("Q" ?$(3!v(B) - ("Qo" ?$(3!w(B) - ("QWe" ?$(3!y(B) - ("QWu" ?$(3!~(B) - ("QWi" ?$(3!{(B) - ("QW" ?$(3!|(B) - ("QWa" ?$(3!|(B) - ("QWE" ?$(3!}(B) - ("QW'" ?$(3!~(B) - - ("be" ?$(3"#(B) - ("bu" ?$(3"$(B) - ("bi" ?$(3"%(B) - ("ba" ?$(3"&(B) - ("bE" ?$(3"'(B) - ("b" ?$(3"((B) - ("bo" ?$(3")(B) - ("bWe" ?$(3%2(B) - ("bWu" ?$(3%b(B) - ("bWi" ?$(3%B(B) - ("bW" ?$(3"*(B) - ("bWa" ?$(3"*(B) - ("bWE" ?$(3%R(B) - ("bW'" ?$(3%b(B) - - ("Be" ?$(3"#(B) - ("Bu" ?$(3"$(B) - ("Bi" ?$(3"%(B) - ("Ba" ?$(3"&(B) - ("BE" ?$(3"'(B) - ("B" ?$(3"((B) - ("Bo" ?$(3")(B) - ("BWe" ?$(3%2(B) - ("BWu" ?$(3%b(B) - ("BWi" ?$(3%B(B) - ("BW" ?$(3"*(B) - ("BWa" ?$(3"*(B) - ("BWE" ?$(3%R(B) - ("BW'" ?$(3%b(B) - - ("ve" ?$(3"+(B) - ("vu" ?$(3",(B) - ("vi" ?$(3"-(B) - ("va" ?$(3".(B) - ("vE" ?$(3"/(B) - ("v" ?$(3"0(B) - ("vo" ?$(3"1(B) - ("vW" ?$(3"2(B) - ("vWa" ?$(3"2(B) - ("vWe" ["$(3"0%n(B"]) - ("vWu" ["$(3"0%r(B"]) - ("vWi" ["$(3"0%o(B"]) - ("vWE" ["$(3"0%q(B"]) - ("vW'" ["$(3"0%r(B"]) - - ("Ve" ?$(3"+(B) - ("Vu" ?$(3",(B) - ("Vi" ?$(3"-(B) - ("Va" ?$(3".(B) - ("VE" ?$(3"/(B) - ("V" ?$(3"0(B) - ("Vo" ?$(3"1(B) - ("VW" ?$(3"2(B) - ("VWa" ?$(3"2(B) - ("VWe" ["$(3"0%n(B"]) - ("VWu" ["$(3"0%r(B"]) - ("VWi" ["$(3"0%o(B"]) - ("VWE" ["$(3"0%q(B"]) - ("VW'" ["$(3"0%r(B"]) - - ("te" ?$(3"3(B) - ("tu" ?$(3"4(B) - ("ti" ?$(3"5(B) - ("ta" ?$(3"6(B) - ("tE" ?$(3"7(B) - ("t" ?$(3"8(B) - ("to" ?$(3"9(B) - ("tW" ?$(3":(B) - ("tWa" ?$(3":(B) - ("tWe" ["$(3"8%n(B"]) - ("tWu" ["$(3"8%r(B"]) - ("tWi" ["$(3"8%o(B"]) - ("tWE" ["$(3"8%q(B"]) - ("tW'" ["$(3"8%r(B"]) - - ("ce" ?$(3";(B) - ("cu" ?$(3"<(B) - ("ci" ?$(3"=(B) - ("ca" ?$(3">(B) - ("cE" ?$(3"?(B) - ("c" ?$(3"@(B) - ("co" ?$(3"A(B) - ("cW" ?$(3"B(B) - ("cWa" ?$(3"B(B) - ("cWe" ["$(3"@%n(B"]) - ("cWu" ["$(3"@%r(B"]) - ("cWi" ["$(3"@%o(B"]) - ("cWE" ["$(3"@%q(B"]) - ("cW'" ["$(3"@%r(B"]) - - ("`he" ?$(3"C(B) - ("`hu" ?$(3"D(B) - ("`hi" ?$(3"E(B) - ("`ha" ?$(3"F(B) - ("`hE" ?$(3"G(B) - ("`h" ?$(3"H(B) - ("`ho" ?$(3"I(B) - ("`hWe" ?$(3"K(B) - ("`hWu" ?$(3"P(B) - ("`hWi" ?$(3"M(B) - ("`hW" ?$(3"N(B) - ("`hWa" ?$(3"N(B) - ("`hWE" ?$(3"O(B) - ("`hW'" ?$(3"P(B) - - ("h2e" ?$(3"C(B) - ("h2u" ?$(3"D(B) - ("h2i" ?$(3"E(B) - ("h2a" ?$(3"F(B) - ("h2E" ?$(3"G(B) - ("h2" ?$(3"H(B) - ("h2o" ?$(3"I(B) - ("h2We" ?$(3"K(B) - ("h2Wu" ?$(3"P(B) - ("h2Wi" ?$(3"M(B) - ("h2W" ?$(3"N(B) - ("h2Wa" ?$(3"N(B) - ("h2WE" ?$(3"O(B) - ("h2W'" ?$(3"P(B) - - ("hhe" ?$(3"C(B) - ("hhu" ?$(3"D(B) - ("hhi" ?$(3"E(B) - ("hha" ?$(3"F(B) - ("hhE" ?$(3"G(B) - ("hh" ?$(3"H(B) - ("hho" ?$(3"I(B) - ("hhWe" ?$(3"K(B) - ("hhWu" ?$(3"P(B) - ("hhWi" ?$(3"M(B) - ("hhW" ?$(3"N(B) - ("hhWa" ?$(3"N(B) - ("hhWE" ?$(3"O(B) - ("hhW'" ?$(3"P(B) - - ("ne" ?$(3"S(B) - ("nu" ?$(3"T(B) - ("ni" ?$(3"U(B) - ("na" ?$(3"V(B) - ("nE" ?$(3"W(B) - ("n" ?$(3"X(B) - ("no" ?$(3"Y(B) - ("nW" ?$(3"Z(B) - ("nWa" ?$(3"Z(B) - ("nWe" ["$(3"X%n(B"]) - ("nWu" ["$(3"X%r(B"]) - ("nWi" ["$(3"X%o(B"]) - ("nWE" ["$(3"X%q(B"]) - ("nW'" ["$(3"X%r(B"]) - - ("Ne" ?$(3"[(B) - ("Nu" ?$(3"\(B) - ("Ni" ?$(3"](B) - ("Na" ?$(3"^(B) - ("NE" ?$(3"_(B) - ("N" ?$(3"`(B) - ("No" ?$(3"a(B) - ("NW" ?$(3"b(B) - ("NWa" ?$(3"b(B) - ("NWe" ["$(3"`%n(B"]) - ("NWu" ["$(3"`%r(B"]) - ("NWi" ["$(3"`%o(B"]) - ("NWE" ["$(3"`%q(B"]) - ("NW'" ["$(3"`%r(B"]) - - ("e" ?$(3"c(B) - ("u" ?$(3"d(B) - ("U" ?$(3"d(B) - ("i" ?$(3"e(B) - ("a" ?$(3"f(B) - ("A" ?$(3"f(B) - ("E" ?$(3"g(B) - ("I" ?$(3"h(B) - ("o" ?$(3"i(B) - ("O" ?$(3"i(B) - ("ea" ?$(3"j(B) - ("eee" ?$(3"j(B) - - ("ke" ?$(3"k(B) - ("ku" ?$(3"l(B) - ("ki" ?$(3"m(B) - ("ka" ?$(3"n(B) - ("kE" ?$(3"o(B) - ("k" ?$(3"p(B) - ("ko" ?$(3"q(B) - ("kWe" ?$(3"s(B) - ("kWu" ?$(3"x(B) - ("kWi" ?$(3"u(B) - ("kW" ?$(3"v(B) - ("kWa" ?$(3"v(B) - ("kWE" ?$(3"w(B) - ("kW'" ?$(3"x(B) - - ("`ke" ?$(3%9(B) - ("`ku" ?$(3%:(B) - ("`ki" ?$(3%;(B) - ("`ka" ?$(3%<(B) - ("`kE" ?$(3%=(B) - ("`k" ?$(3%>(B) - ("`ko" ?$(3%?(B) - - ("k2e" ?$(3%9(B) - ("k2u" ?$(3%:(B) - ("k2i" ?$(3%;(B) - ("k2a" ?$(3%<(B) - ("k2E" ?$(3%=(B) - ("k2" ?$(3%>(B) - ("k2o" ?$(3%?(B) - - ("kke" ?$(3%9(B) - ("kku" ?$(3%:(B) - ("kki" ?$(3%;(B) - ("kka" ?$(3%<(B) - ("kkE" ?$(3%=(B) - ("kk" ?$(3%>(B) - ("kko" ?$(3%?(B) - - ("Ke" ?$(3"{(B) - ("Ku" ?$(3"|(B) - ("Ki" ?$(3"}(B) - ("Ka" ?$(3"~(B) - ("KE" ?$(3#!(B) - ("K" ?$(3#"(B) - ("Ko" ?$(3##(B) - ("KWe" ?$(3#%(B) - ("KWu" ?$(3#*(B) - ("KWi" ?$(3#'(B) - ("KW" ?$(3#((B) - ("KWa" ?$(3#((B) - ("KWE" ?$(3#)(B) - ("KW'" ?$(3#*(B) - - ("Xe" ?$(3%I(B) - ("Xu" ?$(3%J(B) - ("Xi" ?$(3%K(B) - ("Xa" ?$(3%L(B) - ("XE" ?$(3%M(B) - ("X" ?$(3%N(B) - ("Xo" ?$(3%O(B) - - ("we" ?$(3#-(B) - ("wu" ?$(3#.(B) - ("wi" ?$(3#/(B) - ("wa" ?$(3#0(B) - ("wE" ?$(3#1(B) - ("w" ?$(3#2(B) - ("wo" ?$(3#3(B) - - ("`e" ?$(3#5(B) - ("`u" ?$(3#6(B) - ("`U" ?$(3#6(B) - ("`i" ?$(3#7(B) - ("`a" ?$(3#8(B) - ("`A" ?$(3#8(B) - ("`E" ?$(3#9(B) - ("`I" ?$(3#:(B) - ("`o" ?$(3#;(B) - ("`O" ?$(3#;(B) - - ("e2" ?$(3#5(B) - ("u2" ?$(3#6(B) - ("U2" ?$(3#6(B) - ("i2" ?$(3#7(B) - ("a2" ?$(3#8(B) - ("A2" ?$(3#8(B) - ("E2" ?$(3#9(B) - ("I2" ?$(3#:(B) - ("o2" ?$(3#;(B) - ("O2" ?$(3#;(B) - - ("ee" ?$(3#5(B) - ("uu" ?$(3#6(B) - ("UU" ?$(3#6(B) - ("ii" ?$(3#7(B) - ("aa" ?$(3#8(B) - ("AA" ?$(3#8(B) - ("EE" ?$(3#9(B) - ("II" ?$(3#:(B) - ("oo" ?$(3#;(B) - ("OO" ?$(3#;(B) - - ("ze" ?$(3#=(B) - ("zu" ?$(3#>(B) - ("zi" ?$(3#?(B) - ("za" ?$(3#@(B) - ("zE" ?$(3#A(B) - ("z" ?$(3#B(B) - ("zo" ?$(3#C(B) - ("zW" ?$(3#D(B) - ("zWa" ?$(3#D(B) - ("zWe" ["$(3#B%n(B"]) - ("zWu" ["$(3#B%r(B"]) - ("zWi" ["$(3#B%o(B"]) - ("zWE" ["$(3#B%q(B"]) - ("zW'" ["$(3#B%r(B"]) - - ("Ze" ?$(3#E(B) - ("Zu" ?$(3#F(B) - ("Zi" ?$(3#G(B) - ("Za" ?$(3#H(B) - ("ZE" ?$(3#I(B) - ("Z" ?$(3#J(B) - ("Zo" ?$(3#K(B) - ("ZW" ?$(3#L(B) - ("ZWa" ?$(3#L(B) - ("ZWe" ["$(3#J%n(B"]) - ("ZWu" ["$(3#J%r(B"]) - ("ZWi" ["$(3#J%o(B"]) - ("ZWE" ["$(3#J%q(B"]) - ("ZW'" ["$(3#J%r(B"]) - - ("ye" ?$(3#M(B) - ("yu" ?$(3#N(B) - ("yi" ?$(3#O(B) - ("ya" ?$(3#P(B) - ("yE" ?$(3#Q(B) - ("y" ?$(3#R(B) - ("yo" ?$(3#S(B) - ("yW" ?$(3#T(B) - ("yWa" ?$(3#T(B) - ("yWe" ["$(3#R%n(B"]) - ("yWu" ["$(3#R%r(B"]) - ("yWi" ["$(3#R%o(B"]) - ("yWE" ["$(3#R%q(B"]) - ("yW'" ["$(3#R%r(B"]) - - ("Ye" ?$(3#M(B) - ("Yu" ?$(3#N(B) - ("Yi" ?$(3#O(B) - ("Ya" ?$(3#P(B) - ("YE" ?$(3#Q(B) - ("Y" ?$(3#R(B) - ("Yo" ?$(3#S(B) - ("YW" ?$(3#T(B) - ("YWa" ?$(3#T(B) - ("YWe" ["$(3#R%n(B"]) - ("YWu" ["$(3#R%r(B"]) - ("YWi" ["$(3#R%o(B"]) - ("YWE" ["$(3#R%q(B"]) - ("YW'" ["$(3#R%r(B"]) - - ("de" ?$(3#U(B) - ("du" ?$(3#V(B) - ("di" ?$(3#W(B) - ("da" ?$(3#X(B) - ("dE" ?$(3#Y(B) - ("d" ?$(3#Z(B) - ("do" ?$(3#[(B) - ("dW" ?$(3#\(B) - ("dWa" ?$(3#\(B) - ("dWe" ["$(3#Z%n(B"]) - ("dWu" ["$(3#Z%r(B"]) - ("dWi" ["$(3#Z%o(B"]) - ("dWE" ["$(3#Z%q(B"]) - ("dW'" ["$(3#Z%r(B"]) - - ("De" ?$(3#](B) - ("Du" ?$(3#^(B) - ("Di" ?$(3#_(B) - ("Da" ?$(3#`(B) - ("DE" ?$(3#a(B) - ("D" ?$(3#b(B) - ("Do" ?$(3#c(B) - ("DW" ?$(3#d(B) - ("DWa" ?$(3#d(B) - ("DWe" ["$(3#b%n(B"]) - ("DWu" ["$(3#b%r(B"]) - ("DWi" ["$(3#b%o(B"]) - ("DWE" ["$(3#b%q(B"]) - ("DW'" ["$(3#b%r(B"]) - - ("je" ?$(3#e(B) - ("ju" ?$(3#f(B) - ("ji" ?$(3#g(B) - ("ja" ?$(3#h(B) - ("jE" ?$(3#i(B) - ("j" ?$(3#j(B) - ("jo" ?$(3#k(B) - ("jW" ?$(3#l(B) - ("jWa" ?$(3#l(B) - ("jWe" ["$(3#j%n(B"]) - ("jWu" ["$(3#j%r(B"]) - ("jWi" ["$(3#j%o(B"]) - ("jWE" ["$(3#j%q(B"]) - ("jW'" ["$(3#j%r(B"]) - - ("Je" ?$(3#e(B) - ("Ju" ?$(3#f(B) - ("Ji" ?$(3#g(B) - ("Ja" ?$(3#h(B) - ("JE" ?$(3#i(B) - ("J" ?$(3#j(B) - ("Jo" ?$(3#k(B) - ("JW" ?$(3#l(B) - ("JWa" ?$(3#l(B) - ("JWe" ["$(3#j%n(B"]) - ("JWu" ["$(3#j%r(B"]) - ("JWi" ["$(3#j%o(B"]) - ("JWE" ["$(3#j%q(B"]) - ("JW'" ["$(3#j%r(B"]) - - ("ge" ?$(3#m(B) - ("gu" ?$(3#n(B) - ("gi" ?$(3#o(B) - ("ga" ?$(3#p(B) - ("gE" ?$(3#q(B) - ("g" ?$(3#r(B) - ("go" ?$(3#s(B) - ("gWe" ?$(3#u(B) - ("gWu" ?$(3#z(B) - ("gWi" ?$(3#w(B) - ("gW" ?$(3#x(B) - ("gWa" ?$(3#x(B) - ("gWE" ?$(3#y(B) - ("gW'" ?$(3#z(B) - - ("`ge" ?$(3%Y(B) - ("`gu" ?$(3%Z(B) - ("`gi" ?$(3%[(B) - ("`ga" ?$(3%\(B) - ("`gE" ?$(3%](B) - ("`g" ?$(3%^(B) - ("`go" ?$(3%_(B) - - ("g2e" ?$(3%Y(B) - ("g2u" ?$(3%Z(B) - ("g2i" ?$(3%[(B) - ("g2a" ?$(3%\(B) - ("g2E" ?$(3%](B) - ("g2" ?$(3%^(B) - ("g2o" ?$(3%_(B) - - ("gge" ?$(3%Y(B) - ("ggu" ?$(3%Z(B) - ("ggi" ?$(3%[(B) - ("gga" ?$(3%\(B) - ("ggE" ?$(3%](B) - ("gg" ?$(3%^(B) - ("ggo" ?$(3%_(B) - - ("Ge" ?$(3#}(B) - ("Gu" ?$(3#~(B) - ("Gi" ?$(3$!(B) - ("Ga" ?$(3$"(B) - ("GE" ?$(3$#(B) - ("G" ?$(3$$(B) - ("Go" ?$(3$%(B) - ("GWe" ?$(3%3(B) - ("GWu" ?$(3%c(B) - ("GWi" ?$(3%C(B) - ("GW" ?$(3$&(B) - ("GWa" ?$(3$&(B) - ("GWE" ?$(3%S(B) - ("GW'" ?$(3%c(B) - - ("te" ?$(3$'(B) - ("tu" ?$(3$((B) - ("ti" ?$(3$)(B) - ("ta" ?$(3$*(B) - ("tE" ?$(3$+(B) - ("t" ?$(3$,(B) - ("to" ?$(3$-(B) - ("tW" ?$(3$.(B) - ("tWa" ?$(3$.(B) - ("tWe" ["$(3$,%n(B"]) - ("tWu" ["$(3$,%r(B"]) - ("tWi" ["$(3$,%o(B"]) - ("tWE" ["$(3$,%q(B"]) - ("tW'" ["$(3$,%r(B"]) - - ("Ce" ?$(3$/(B) - ("Cu" ?$(3$0(B) - ("Ci" ?$(3$1(B) - ("Ca" ?$(3$2(B) - ("CE" ?$(3$3(B) - ("C" ?$(3$4(B) - ("Co" ?$(3$5(B) - ("CW" ?$(3$6(B) - ("CWa" ?$(3$6(B) - ("CWe" ["$(3$4%n(B"]) - ("CWu" ["$(3$4%r(B"]) - ("CWi" ["$(3$4%o(B"]) - ("CWE" ["$(3$4%q(B"]) - ("CW'" ["$(3$4%r(B"]) - - ("Pe" ?$(3$7(B) - ("Pu" ?$(3$8(B) - ("Pi" ?$(3$9(B) - ("Pa" ?$(3$:(B) - ("PE" ?$(3$;(B) - ("P" ?$(3$<(B) - ("Po" ?$(3$=(B) - ("PW" ?$(3$>(B) - ("PWa" ?$(3$>(B) - ("PWe" ["$(3$<%n(B"]) - ("PWu" ["$(3$<%r(B"]) - ("PWi" ["$(3$<%o(B"]) - ("PWE" ["$(3$<%q(B"]) - ("PW'" ["$(3$<%r(B"]) - - ("Se" ?$(3$?(B) - ("Su" ?$(3$@(B) - ("Si" ?$(3$A(B) - ("Sa" ?$(3$B(B) - ("SE" ?$(3$C(B) - ("S" ?$(3$D(B) - ("So" ?$(3$E(B) - ("SW" ?$(3$F(B) - ("SWa" ?$(3$F(B) - ("SWe" ["$(3$D%n(B"]) - ("SWu" ["$(3$D%r(B"]) - ("SWi" ["$(3$D%o(B"]) - ("SWE" ["$(3$D%q(B"]) - ("SW'" ["$(3$D%r(B"]) - - ("`Se" ?$(3$G(B) - ("`Su" ?$(3$H(B) - ("`Si" ?$(3$I(B) - ("`Sa" ?$(3$J(B) - ("`SE" ?$(3$K(B) - ("`S" ?$(3$L(B) - ("`So" ?$(3$M(B) - ("`SW" ?$(3$F(B) - ("`SWa" ?$(3$F(B) - ("`SWe" ["$(3$L%n(B"]) - ("`SWu" ["$(3$L%r(B"]) - ("`SWi" ["$(3$L%o(B"]) - ("`SWE" ["$(3$L%q(B"]) - ("`SW'" ["$(3$L%r(B"]) - - ("S2e" ?$(3$G(B) - ("S2u" ?$(3$H(B) - ("S2i" ?$(3$I(B) - ("S2a" ?$(3$J(B) - ("S2E" ?$(3$K(B) - ("S2" ?$(3$L(B) - ("S2o" ?$(3$M(B) - ("S2W" ?$(3$F(B) - ("S2Wa" ?$(3$F(B) - ("S2We" ["$(3$L%n(B"]) - ("S2Wu" ["$(3$L%r(B"]) - ("S2Wi" ["$(3$L%o(B"]) - ("S2WE" ["$(3$L%q(B"]) - ("S2W'" ["$(3$L%r(B"]) - - ("SSe" ?$(3$G(B) - ("SSu" ?$(3$H(B) - ("SSi" ?$(3$I(B) - ("SSa" ?$(3$J(B) - ("SSE" ?$(3$K(B) - ("SS" ?$(3$L(B) - ("SSo" ?$(3$M(B) - ("SSW" ?$(3$F(B) - ("SSWa" ?$(3$F(B) - ("SSWe" ["$(3$L%n(B"]) - ("SSWu" ["$(3$L%r(B"]) - ("SSWi" ["$(3$L%o(B"]) - ("SSWE" ["$(3$L%q(B"]) - ("SW'" ["$(3$L%r(B"]) - - ("fe" ?$(3$O(B) - ("fu" ?$(3$P(B) - ("fi" ?$(3$Q(B) - ("fa" ?$(3$R(B) - ("fE" ?$(3$S(B) - ("f" ?$(3$T(B) - ("fo" ?$(3$U(B) - ("fWe" ?$(3%4(B) - ("fWu" ?$(3%d(B) - ("fWi" ?$(3%D(B) - ("fW" ?$(3$V(B) - ("fWa" ?$(3$V(B) - ("fWE" ?$(3%T(B) - ("fW'" ?$(3%d(B) - ("fY" ?$(3$a(B) - ("fYa" ?$(3$a(B) - - ("Fe" ?$(3$O(B) - ("Fu" ?$(3$P(B) - ("Fi" ?$(3$Q(B) - ("Fa" ?$(3$R(B) - ("FE" ?$(3$S(B) - ("F" ?$(3$T(B) - ("Fo" ?$(3$U(B) - ("FWe" ?$(3%4(B) - ("FWu" ?$(3%d(B) - ("FWi" ?$(3%D(B) - ("FW" ?$(3$V(B) - ("FWa" ?$(3$V(B) - ("FWE" ?$(3%T(B) - ("FW'" ?$(3%d(B) - ("FY" ?$(3$a(B) - ("FYa" ?$(3$a(B) - - ("pe" ?$(3$W(B) - ("pu" ?$(3$X(B) - ("pi" ?$(3$Y(B) - ("pa" ?$(3$Z(B) - ("pE" ?$(3$[(B) - ("p" ?$(3$\(B) - ("po" ?$(3$](B) - ("pWe" ?$(3%5(B) - ("pWu" ?$(3%e(B) - ("pWi" ?$(3%E(B) - ("pW" ?$(3$^(B) - ("pWa" ?$(3$^(B) - ("pWE" ?$(3%U(B) - ("pW'" ?$(3%e(B) - - ("'" [""]) - ("''" ?') - (":" ?$(3$h(B) - ("::" ?$(3$i(B) - (":::" ?:) - ("." ?$(3$i(B) - (".." ?$(3%u(B) - ("..." ?.) - ("," ?$(3$j(B) - (",," ?,) - (";" ?$(3$k(B) - (";;" ?\;) - ("-:" ?$(3$l(B) - (":-" ?$(3$m(B) - ("*" ?*) - ("**" ?$(3$o(B) - (":|:" ?$(3$o(B) - ("?" ?$(3%x(B) - ("??" ?$(3$n(B) - ("`?" ?$(3$n(B) - ("???" ??) - ("<<" ?$(3%v(B) - (">>" ?$(3%w(B) - ("`!" ?$(3%t(B) - ("wWe" ?$(3%n(B) - ("wWu" ?$(3%r(B) - ("wWi" ?$(3%o(B) - ("wW" ?$(3%p(B) - ("wWa" ?$(3%p(B) - ("wWE" ?$(3%q(B) - ("wW'" ?$(3%r(B) - ("We" ?$(3%n(B) - ("Wu" ?$(3%r(B) - ("Wi" ?$(3%o(B) - ("W" ?$(3%p(B) - ("Wa" ?$(3%p(B) - ("WE" ?$(3%q(B) - ("W'" ?$(3%r(B) - ("`1" ?$(3$p(B) - ("`2" ?$(3$q(B) - ("`3" ?$(3$r(B) - ("`4" ?$(3$s(B) - ("`5" ?$(3$t(B) - ("`6" ?$(3$u(B) - ("`7" ?$(3$v(B) - ("`8" ?$(3$w(B) - ("`9" ?$(3$x(B) - ("`10" ?$(3$y(B) - ("`20" ?$(3$z(B) - ("`30" ?$(3${(B) - ("`40" ?$(3$|(B) - ("`50" ?$(3$}(B) - ("`60" ?$(3$~(B) - ("`70" ?$(3%!(B) - ("`80" ?$(3%"(B) - ("`90" ?$(3%#(B) - ("`100" ?$(3%$(B) - ("`1000" ["$(3$y%$(B"]) - ("`2000" ["$(3$z%$(B"]) - ("`3000" ["$(3${%$(B"]) - ("`4000" ["$(3$|%$(B"]) - ("`5000" ["$(3$}%$(B"]) - ("`6000" ["$(3$~%$(B"]) - ("`7000" ["$(3%!%$(B"]) - ("`8000" ["$(3%"%$(B"]) - ("`9000" ["$(3%#%$(B"]) - ("`10000" ?$(3%%(B) - ("`20000" ["$(3$q%%(B"]) - ("`30000" ["$(3$r%%(B"]) - ("`40000" ["$(3$s%%(B"]) - ("`50000" ["$(3$t%%(B"]) - ("`60000" ["$(3$u%%(B"]) - ("`70000" ["$(3$v%%(B"]) - ("`80000" ["$(3$w%%(B"]) - ("`90000" ["$(3$x%%(B"]) - ("`100000" ["$(3$y%%(B"]) - ("`200000" ["$(3$z%%(B"]) - ("`300000" ["$(3${%%(B"]) - ("`400000" ["$(3$|%%(B"]) - ("`500000" ["$(3$}%%(B"]) - ("`600000" ["$(3$~%%(B"]) - ("`700000" ["$(3%!%%(B"]) - ("`800000" ["$(3%"%%(B"]) - ("`900000" ["$(3%#%%(B"]) - ("`1000000" ["$(3%$%%(B"]) -) - -(add-hook 'quail-mode-hook - (lambda nil - (if (not (string= (quail-name) "ethiopic")) - nil - ;; Also turn on the Ethio minor mode. - (ethio-mode 1) - ;; The translation of `a' depends on the language - ;; (either Tigrigna or Amharic). - (quail-defrule "a" - (if (ethio-prefer-amharic-p) ?$(3"c(B ?$(3"f(B) - "ethiopic")))) - -;;; quail/ethiopic.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/quail/japanese.el --- a/lisp/leim/quail/japanese.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,381 +0,0 @@ -;;; quail/japanese.el --- Quail package for inputting Japanese - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, Japanese - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'quail) -(require 'kkc) - -;; Update Quail translation region while considering Japanese bizarre -;; translation rules. -(defun quail-japanese-update-translation (control-flag) - (cond ((eq control-flag t) - (insert quail-current-str) - (quail-terminate-translation)) - ((null control-flag) - (if (/= (aref quail-current-key 0) ?q) - (insert (or quail-current-str quail-current-key)))) - (t ; i.e. (numberp control-flag) - (cond ((= (aref quail-current-key 0) ?n) - (insert ?$B$s(B)) - ((= (aref quail-current-key 0) (aref quail-current-key 1)) - (insert ?$B$C(B)) - (t - (insert (aref quail-current-key 0)))) - (setq unread-command-events - (list (aref quail-current-key control-flag))) - (quail-terminate-translation)))) - -;; Flag to control the behavior of `quail-japanese-toggle-kana'. -(defvar quail-japanese-kana-state nil) -(make-variable-buffer-local 'quail-japanese-kana-state) - -;; Convert Hiragana <-> Katakana in the current translation region. -(defun quail-japanese-toggle-kana () - (interactive) - (let ((start (overlay-start quail-conv-overlay)) - (end (overlay-end quail-conv-overlay))) - (setq quail-japanese-kana-state - (if (eq last-command this-command) - (not quail-japanese-kana-state))) - (if quail-japanese-kana-state - (japanese-hiragana-region start end) - (japanese-katakana-region start end)) - (goto-char (overlay-end quail-conv-overlay)))) - -;; Convert Hiragana in the current translation region to Kanji by KKC -;; (Kana Kanji Converter) utility. -(defun quail-japanese-kanji-kkc () - (interactive) - (let ((from (overlay-start quail-conv-overlay)) - (to (overlay-end quail-conv-overlay)) - newfrom) - (quail-delete-overlays) - (setq overriding-terminal-local-map nil) - (kkc-region from to 'quail-japanese-kkc-mode-exit))) - -;; Function to call on exiting KKC mode. ARG is nil if KKC mode is -;; exited normally, else ARG is a cons (FROM . TO) where FROM and TO -;; specify a region not yet processed. -(defun quail-japanese-kkc-mode-exit (arg) - (if arg - (progn - (setq overriding-terminal-local-map (quail-conversion-keymap)) - (move-overlay quail-conv-overlay (car arg) (cdr arg))) - (run-hooks 'input-method-after-insert-chunk-hook))) - -(defun quail-japanese-self-insert-and-switch-to-alpha (key idx) - (quail-delete-region) - (setq unread-command-events (list (aref key (1- idx)))) - (quail-japanese-switch-package "q" 1)) - -(defvar quail-japanese-switch-table - '((?z . "japanese-zenkaku") - (?k . "japanese-hankaku-kana") - (?h . "japanese") - (?q . ("japanese-ascii")))) - -(defvar quail-japanese-package-saved nil) -(make-variable-buffer-local 'quail-japanese-package-saved) -(put 'quail-japanese-package-saved 'permanent-local t) - -(defun quail-japanese-switch-package (key idx) - (let ((pkg (cdr (assq (aref key (1- idx)) quail-japanese-switch-table)))) - (if (null pkg) - (error "No package to be switched") - (setq overriding-terminal-local-map nil) - (quail-delete-region) - (if (stringp pkg) - (activate-input-method pkg) - (if (string= (car pkg) current-input-method) - (if quail-japanese-package-saved - (activate-input-method quail-japanese-package-saved)) - (setq quail-japanese-package-saved current-input-method) - (activate-input-method (car pkg)))))) - (throw 'quail-tag nil)) - -(quail-define-package - "japanese" "Japanese" "A$B$"(B" - nil - "Romaji -> Hiragana -> Kanji&Kana ----- Special key bindings ---- -qq: toggle between input methods `japanese' and `japanese-ascii' -qz: use `japanese-zenkaku' package, \"qh\" puts you back to `japanese' -K: toggle converting region between Katakana and Hiragana -SPC: convert to Kanji&Kana -z: insert one Japanese symbol according to a key which follows -" - nil t t nil nil nil nil nil - 'quail-japanese-update-translation - '(("K" . quail-japanese-toggle-kana) - (" " . quail-japanese-kanji-kkc) - ("\C-m" . quail-no-conversion) - ([return] . quail-no-conversion)) - ) - -(quail-define-rules - -( "a" "$B$"(B") ( "i" "$B$$(B") ( "u" "$B$&(B") ( "e" "$B$((B") ( "o" "$B$*(B") -("ka" "$B$+(B") ("ki" "$B$-(B") ("ku" "$B$/(B") ("ke" "$B$1(B") ("ko" "$B$3(B") -("sa" "$B$5(B") ("si" "$B$7(B") ("su" "$B$9(B") ("se" "$B$;(B") ("so" "$B$=(B") -("ta" "$B$?(B") ("ti" "$B$A(B") ("tu" "$B$D(B") ("te" "$B$F(B") ("to" "$B$H(B") -("na" "$B$J(B") ("ni" "$B$K(B") ("nu" "$B$L(B") ("ne" "$B$M(B") ("no" "$B$N(B") -("ha" "$B$O(B") ("hi" "$B$R(B") ("hu" "$B$U(B") ("he" "$B$X(B") ("ho" "$B$[(B") -("ma" "$B$^(B") ("mi" "$B$_(B") ("mu" "$B$`(B") ("me" "$B$a(B") ("mo" "$B$b(B") -("ya" "$B$d(B") ("yu" "$B$f(B") ("yo" "$B$h(B") -("ra" "$B$i(B") ("ri" "$B$j(B") ("ru" "$B$k(B") ("re" "$B$l(B") ("ro" "$B$m(B") -("la" "$B$i(B") ("li" "$B$j(B") ("lu" "$B$k(B") ("le" "$B$l(B") ("lo" "$B$m(B") -("wa" "$B$o(B") ("wi" "$B$p(B") ("wu" "$B$&(B") ("we" "$B$q(B") ("wo" "$B$r(B") -("n'" "$B$s(B") -("ga" "$B$,(B") ("gi" "$B$.(B") ("gu" "$B$0(B") ("ge" "$B$2(B") ("go" "$B$4(B") -("za" "$B$6(B") ("zi" "$B$8(B") ("zu" "$B$:(B") ("ze" "$B$<(B") ("zo" "$B$>(B") -("da" "$B$@(B") ("di" "$B$B(B") ("du" "$B$E(B") ("de" "$B$G(B") ("do" "$B$I(B") -("ba" "$B$P(B") ("bi" "$B$S(B") ("bu" "$B$V(B") ("be" "$B$Y(B") ("bo" "$B$\(B") -("pa" "$B$Q(B") ("pi" "$B$T(B") ("pu" "$B$W(B") ("pe" "$B$Z(B") ("po" "$B$](B") - -("kya" ["$B$-$c(B"]) ("kyu" ["$B$-$e(B"]) ("kye" ["$B$-$'(B"]) ("kyo" ["$B$-$g(B"]) -("sya" ["$B$7$c(B"]) ("syu" ["$B$7$e(B"]) ("sye" ["$B$7$'(B"]) ("syo" ["$B$7$g(B"]) -("sha" ["$B$7$c(B"]) ("shu" ["$B$7$e(B"]) ("she" ["$B$7$'(B"]) ("sho" ["$B$7$g(B"]) -("cha" ["$B$A$c(B"]) ("chu" ["$B$A$e(B"]) ("che" ["$B$A$'(B"]) ("cho" ["$B$A$g(B"]) -("tya" ["$B$A$c(B"]) ("tyu" ["$B$A$e(B"]) ("tye" ["$B$A$'(B"]) ("tyo" ["$B$A$g(B"]) -("nya" ["$B$K$c(B"]) ("nyu" ["$B$K$e(B"]) ("nye" ["$B$K$'(B"]) ("nyo" ["$B$K$g(B"]) -("hya" ["$B$R$c(B"]) ("hyu" ["$B$R$e(B"]) ("hye" ["$B$R$'(B"]) ("hyo" ["$B$R$g(B"]) -("mya" ["$B$_$c(B"]) ("myu" ["$B$_$e(B"]) ("mye" ["$B$_$'(B"]) ("myo" ["$B$_$g(B"]) -("rya" ["$B$j$c(B"]) ("ryu" ["$B$j$e(B"]) ("rye" ["$B$j$'(B"]) ("ryo" ["$B$j$g(B"]) -("lya" ["$B$j$c(B"]) ("lyu" ["$B$j$e(B"]) ("lye" ["$B$j$'(B"]) ("lyo" ["$B$j$g(B"]) -("gya" ["$B$.$c(B"]) ("gyu" ["$B$.$e(B"]) ("gye" ["$B$.$'(B"]) ("gyo" ["$B$.$g(B"]) -("zya" ["$B$8$c(B"]) ("zyu" ["$B$8$e(B"]) ("zye" ["$B$8$'(B"]) ("zyo" ["$B$8$g(B"]) -("jya" ["$B$8$c(B"]) ("jyu" ["$B$8$e(B"]) ("jye" ["$B$8$'(B"]) ("jyo" ["$B$8$g(B"]) -( "ja" ["$B$8$c(B"]) ( "ju" ["$B$8$e(B"]) ( "je" ["$B$8$'(B"]) ( "jo" ["$B$8$g(B"]) -("bya" ["$B$S$c(B"]) ("byu" ["$B$S$e(B"]) ("bye" ["$B$S$'(B"]) ("byo" ["$B$S$g(B"]) -("pya" ["$B$T$c(B"]) ("pyu" ["$B$T$e(B"]) ("pye" ["$B$T$'(B"]) ("pyo" ["$B$T$g(B"]) - -("kwa" ["$B$/$n(B"]) ("kwi" ["$B$/$#(B"]) ("kwe" ["$B$/$'(B"]) ("kwo" ["$B$/$)(B"]) -("tsa" ["$B$D$!(B"]) ("tsi" ["$B$D$#(B"]) ("tse" ["$B$D$'(B"]) ("tso" ["$B$D$)(B"]) -( "fa" ["$B$U$!(B"]) ( "fi" ["$B$U$#(B"]) ( "fe" ["$B$U$'(B"]) ( "fo" ["$B$U$)(B"]) -("gwa" ["$B$0$n(B"]) ("gwi" ["$B$0$#(B"]) ("gwe" ["$B$0$'(B"]) ("gwo" ["$B$0$)(B"]) - -("dyi" ["$B$G$#(B"]) ("dyu" ["$B$I$%(B"]) ("dye" ["$B$G$'(B"]) ("dyo" ["$B$I$)(B"]) -("xwi" ["$B$&$#(B"]) ("xwe" ["$B$&$'(B"]) ("xwo" ["$B$&$)(B"]) - -("shi" "$B$7(B") ("tyi" ["$B$F$#(B"]) ("chi" "$B$A(B") ("tsu" "$B$D(B") ("ji" "$B$8(B") -("fu" "$B$U(B") -("ye" ["$B$$$'(B"]) - -("va" ["$B%t$!(B"]) ("vi" ["$B%t$#(B"]) ("vu" "$B%t(B") ("ve" ["$B%t$'(B"]) ("vo" ["$B%t$)(B"]) - -("xa" "$B$!(B") ("xi" "$B$#(B") ("xu" "$B$%(B") ("xe" "$B$'(B") ("xo" "$B$)(B") -("xtu" "$B$C(B") ("xya" "$B$c(B") ("xyu" "$B$e(B") ("xyo" "$B$g(B") ("xwa" "$B$n(B") -("xka" "$B%u(B") ("xke" "$B%v(B") - -("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B") ("4" "$B#4(B") ("5" "$B#5(B") -("6" "$B#6(B") ("7" "$B#7(B") ("8" "$B#8(B") ("9" "$B#9(B") ("0" "$B#0(B") - -("!" "$B!*(B") ("@" "$B!w(B") ("#" "$B!t(B") ("$" "$B!p(B") ("%" "$B!s(B") -("^" "$B!0(B") ("&" "$B!u(B") ("*" "$B!v(B") ("(" "$B!J(B") (")" "$B!K(B") -("-" "$B!<(B") ("=" "$B!a(B") ("`" "$B!.(B") ("\\" "$B!o(B") ("|" "$B!C(B") -("_" "$B!2(B") ("+" "$B!\(B") ("~" "$B!1(B") ("[" "$B!V(B") ("]" "$B!W(B") -("{" "$B!P(B") ("}" "$B!Q(B") (":" "$B!'(B") (";" "$B!((B") ("\"" "$B!I(B") -("'" "$B!G(B") ("." "$B!#(B") ("," "$B!"(B") ("<" "$B!c(B") (">" "$B!d(B") -("?" "$B!)(B") ("/" "$B!?(B") - -("z1" "$B!{(B") ("z!" "$B!|(B") -("z2" "$B"&(B") ("z@" "$B"'(B") -("z3" "$B"$(B") ("z#" "$B"%(B") -("z4" "$B""(B") ("z$" "$B"#(B") -("z5" "$B!~(B") ("z%" "$B"!(B") -("z6" "$B!y(B") ("z^" "$B!z(B") -("z7" "$B!}(B") ("z&" "$B!r(B") -("z8" "$B!q(B") ("z*" "$B!_(B") -("z9" "$B!i(B") ("z(" "$B!Z(B") -("z0" "$B!j(B") ("z)" "$B![(B") -("z-" "$B!A(B") ("z_" "$B!h(B") -("z=" "$B!b(B") ("z+" "$B!^(B") -("z\\" "$B!@(B") ("z|" "$B!B(B") -("z`" "$B!-(B") ("z~" "$B!/(B") - -("zq" "$B!T(B") ("zQ" "$B!R(B") -("zw" "$B!U(B") ("zW" "$B!S(B") -("zr" "$B!9(B") ("zR" "$B!8(B") -("zt" "$B!:(B") ("zT" "$B!x(B") -("zp" "$B")(B") ("zP" "$B",(B") -("z[" "$B!X(B") ("z{" "$B!L(B") -("z]" "$B!Y(B") ("z}" "$B!M(B") - -("zs" "$B!3(B") ("zS" "$B!4(B") -("zd" "$B!5(B") ("zD" "$B!6(B") -("zf" "$B!7(B") ("zF" "$B"*(B") -("zg" "$B!>(B") ("zG" "$B!=(B") -("zh" "$B"+(B") -("zj" "$B"-(B") -("zk" "$B",(B") -("zl" "$B"*(B") -("z;" "$B!+(B") ("z:" "$B!,(B") -("z\'" "$B!F(B") ("z\"" "$B!H(B") - -("zx" ":-") ("zX" ":-)") -("zc" "$B!;(B") ("zC" "$B!n(B") -("zv" "$B"((B") ("zV" "$B!`(B") -("zb" "$B!k(B") ("zB" "$B"+(B") -("zn" "$B!l(B") ("zN" "$B"-(B") -("zm" "$B!m(B") ("zM" "$B".(B") -("z," "$B!E(B") ("z<" "$B!e(B") -("z." "$B!D(B") ("z>" "$B!f(B") -("z/" "$B!&(B") ("z?" "$B!g(B") - -("\\\\" quail-japanese-self-insert-and-switch-to-alpha) -("{{" quail-japanese-self-insert-and-switch-to-alpha) -("}}" quail-japanese-self-insert-and-switch-to-alpha) - -("qq" quail-japanese-switch-package) -("qz" quail-japanese-switch-package) - -) - -(quail-define-package - "japanese-ascii" "Japanese" "Aa" - nil - "Temporary ASCII input mode while using Quail package `japanese' -Type \"qq\" to go back to previous package." - nil t t) - -(quail-define-rules ("qq" quail-japanese-switch-package)) - -(quail-define-package - "japanese-zenkaku" "Japanese" "$B#A(B" - nil - "Japanese zenkaku alpha numeric character input method ----- Special key bindings ---- -qq: toggle between `japanese-zenkaku' and `japanese-ascii' -qh: use `japanese' package, \"qz\" puts you back to `japanese-zenkaku' -" - nil t t) - -(quail-define-rules - -(" " "$B!!(B") ("!" "$B!*(B") ("\"" "$B!m(B") ("#" "$B!t(B") -("$" "$B!p(B") ("%" "$B!s(B") ("&" "$B!u(B") ("'" "$B!l(B") -("(" "$B!J(B") (")" "$B!K(B") ("*" "$B!v(B") ("+" "$B!\(B") -("," "$B!$(B") ("-" "$B!](B") ("." "$B!%(B") ("/" "$B!?(B") -("0" "$B#0(B") ("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B") -("4" "$B#4(B") ("5" "$B#5(B") ("6" "$B#6(B") ("7" "$B#7(B") -("8" "$B#8(B") ("9" "$B#9(B") (":" "$B!'(B") (";" "$B!((B") -("<" "$B!c(B") ("=" "$B!a(B") (">" "$B!d(B") ("?" "$B!)(B") -("@" "$B!w(B") ("A" "$B#A(B") ("B" "$B#B(B") ("C" "$B#C(B") -("D" "$B#D(B") ("E" "$B#E(B") ("F" "$B#F(B") ("G" "$B#G(B") -("H" "$B#H(B") ("I" "$B#I(B") ("J" "$B#J(B") ("K" "$B#K(B") -("L" "$B#L(B") ("M" "$B#M(B") ("N" "$B#N(B") ("O" "$B#O(B") -("P" "$B#P(B") ("Q" "$B#Q(B") ("R" "$B#R(B") ("S" "$B#S(B") -("T" "$B#T(B") ("U" "$B#U(B") ("V" "$B#V(B") ("W" "$B#W(B") -("X" "$B#X(B") ("Y" "$B#Y(B") ("Z" "$B#Z(B") ("[" "$B!N(B") -("\\" "$B!o(B") ("]" "$B!O(B") ("^" "$B!0(B") ("_" "$B!2(B") -("`" "$B!F(B") ("a" "$B#a(B") ("b" "$B#b(B") ("c" "$B#c(B") -("d" "$B#d(B") ("e" "$B#e(B") ("f" "$B#f(B") ("g" "$B#g(B") -("h" "$B#h(B") ("i" "$B#i(B") ("j" "$B#j(B") ("k" "$B#k(B") -("l" "$B#l(B") ("m" "$B#m(B") ("n" "$B#n(B") ("o" "$B#o(B") -("p" "$B#p(B") ("q" "$B#q(B") ("r" "$B#r(B") ("s" "$B#s(B") -("t" "$B#t(B") ("u" "$B#u(B") ("v" "$B#v(B") ("w" "$B#w(B") -("x" "$B#x(B") ("y" "$B#y(B") ("z" "$B#z(B") ("{" "$B!P(B") -("|" "$B!C(B") ("}" "$B!Q(B") ("~" "$B!A(B") - -("qq" quail-japanese-switch-package) -("qh" quail-japanese-switch-package) -) - -(defun quail-japanese-hankaku-update-translation (control-flag) - (cond ((eq control-flag t) - (insert (japanese-hankaku quail-current-str)) - (quail-terminate-translation)) - ((null control-flag) - (insert (if quail-current-str - (japanese-hankaku quail-current-str) - quail-current-key))) - (t ; i.e. (numberp control-flag) - (cond ((= (aref quail-current-key 0) ?n) - (insert ?(I](B)) - ((= (aref quail-current-key 0) (aref quail-current-key 1)) - (insert ?(I/(B)) - (t - (insert (aref quail-current-key 0)))) - (setq unread-command-events - (list (aref quail-current-key control-flag))) - (quail-terminate-translation)))) - - -(quail-define-package - "japanese-hankaku-kana" - "Japanese" "(I1(B" - nil - "Japanese hankaku katakana input method by Roman transliteration ----- Special key bindings ---- -qq: toggle between `japanese-hankaku-kana' and `japanese-ascii' -" - nil t t nil nil nil nil nil - 'quail-japanese-hankaku-update-translation) - -;; Use the same map as that of `japanese'. -(setcar (cdr (cdr quail-current-package)) - (nth 2 (assoc "japanese" quail-package-alist))) - -(quail-define-package - "japanese-hiragana" "Japanese" "$B$"(B" - nil - "Japanese hiragana input method by Roman transliteration" - nil t t nil nil nil nil nil - 'quail-japanese-update-translation) - -;; Use the same map as that of `japanese'. -(setcar (cdr (cdr quail-current-package)) - (nth 2 (assoc "japanese" quail-package-alist))) - -;; Update Quail translation region while converting Hiragana to Katakana. -(defun quail-japanese-katakana-update-translation (control-flag) - (cond ((eq control-flag t) - (insert (japanese-katakana quail-current-str)) - (quail-terminate-translation)) - ((null control-flag) - (insert (if quail-current-str - (japanese-katakana quail-current-str) - quail-current-key))) - (t ; i.e. (numberp control-flag) - (cond ((= (aref quail-current-key 0) ?n) - (insert ?$B%s(B)) - ((= (aref quail-current-key 0) (aref quail-current-key 1)) - (insert ?$B%C(B)) - (t - (insert (aref quail-current-key 0)))) - (setq unread-command-events - (list (aref quail-current-key control-flag))) - (quail-terminate-translation)))) - -(quail-define-package - "japanese-katakana" "Japanese" "$B%"(B" - nil - "Japanese katakana input method by Roman transliteration" - nil t t nil nil nil nil nil - 'quail-japanese-katakana-update-translation) - -;; Use the same map as that of `japanese'. -(setcar (cdr (cdr quail-current-package)) - (nth 2 (assoc "japanese" quail-package-alist))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/quail/lao.el --- a/lisp/leim/quail/lao.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,266 +0,0 @@ -;;; quail/lao.el --- Quail package for inputting Lao characters - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, Lao - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'quail) -(require 'lao-util) - -(eval-and-compile - -(defconst lao-keyboard-mapping - [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ; control codes - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ; control codes - 0 "1" "=" "3" "4" "(1l(B" "5" "(1'(B" ; SPC .. ' - "7" "8" "6" "(1mh(B" "(1A(B" "(1*(B" "(1c(B" "(1=(B" ; ( .. / - "(1"(B" "(1B(B" "(1?(B" "(1b(B" "(16(B" "(1X(B" "(1Y(B" "(1$(B" ; 0 .. 7 - "(15(B" "(1((B" "%" "(1G(B" "(1}(B" "(1m(B" "$" "\)" ; 8 .. ? - "2" "(1Qi(B" "(1Vi(B" "(1O(B" "." "(1Si(B" "," ":" ; @ .. G - "(1j(B" "(1N(B" "(1k(B" "!" "?" "(1f(B" "(1Wi(B" "(1|(B" ; H .. O - "(1](B" "(1[i(B" "_" ";" "+" "(1Ui(B" "x" "0" ; P .. W - "\(" "(1Ti(B" "\"" "(1:(B" 0 "(1E(B" "(1\(B" "9" ; X .. _ - "(1'(B" "(1Q(B" "(1V(B" "(1a(B" "(1!(B" "(1S(B" "(14(B" "(1`(B" ; ` .. g - "(1i(B" "(1C(B" "(1h(B" "(1R(B" "(1J(B" "(17(B" "(1W(B" "(19(B" ; h .. o - "(1-(B" "(1[(B" "(1>(B" "(1K(B" "(1P(B" "(1U(B" "(1M(B" "(1d(B" ; p .. w - "(1;(B" "(1T(B" "(1<(B" "-" "(1K\(B" "/" "~" 0] ; x .. DEL - "A table which maps ASCII key codes to corresponding Lao characters." - ) - -) - -;; Template of a cdr part of a Quail map when a consonant is entered. -(defvar lao-consonant-alist nil) -;; Template of a cdr part of a Quail map when a vowel upper is entered. -(defvar lao-vowel-upper-alist nil) -;; Template of a cdr part of a Quail map when a vowel lower is entered. -(defvar lao-vowel-lower-alist nil) -;; Template of a cdr part of a Quail map when a semivowel lower is entered. -(defvar lao-semivowel-lower-alist nil) - -;; Return a Quail map corresponding to KEY of length LEN. -;; The car part of the map is a translation generated automatically. -;; The cdr part of the map is a copy of ALIST. -(defun lao-generate-quail-map (key len alist) - (let ((str "") - (idx 0)) - (while (< idx len) - (setq str (concat str (aref lao-keyboard-mapping (aref key idx))) - idx (1+ idx))) - (cons (string-to-char (compose-string str)) (copy-alist alist)))) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; tone mark is entered. -(defun lao-tone-input (key len) - (lao-generate-quail-map key len nil)) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; vowel upper is entered. -(defun lao-vowel-upper-input (key len) - (lao-generate-quail-map key len lao-vowel-upper-alist)) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; vowel lower is entered. -(defun lao-vowel-lower-input (key len) - (lao-generate-quail-map key len lao-vowel-lower-alist)) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; semivowel lower is entered. -(defun lao-semivowel-lower-input (key len) - (lao-generate-quail-map key len lao-semivowel-lower-alist)) - -;; Return an alist which can be a cdr part of a Quail map -;; corresponding to the current key when Lao consonant is entered. -(defun lao-consonant-input (key len) - (copy-alist lao-consonant-alist)) - -(quail-define-package - "lao" "Lao" "(1E(B" t - "Lao input method simulating Lao keyboard layout based on Thai TIS620" - nil t t t t nil nil nil nil nil t) - -(defmacro lao-quail-define-rules (&rest rules) - (let ((l rules) - consonant-alist - vowel-upper-alist - vowel-lower-alist - semivowel-lower-alist - rule trans ch c-set) - (while l - (setq rule (car l)) - (setq trans (nth 1 rule)) - (if (consp trans) - (setq trans (car trans))) - (setq c-set (char-category-set (string-to-char trans))) - (cond ((aref c-set ?2) ; vowel upper - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-vowel-upper-input) - consonant-alist))) - ((aref c-set ?3) ; vowel lower - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-vowel-lower-input) - consonant-alist) - semivowel-lower-alist - (cons (cons (string-to-char (car rule)) - 'lao-vowel-lower-input) - semivowel-lower-alist))) - ((aref c-set ?4) ; tone - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-tone-input) - consonant-alist) - vowel-upper-alist - (cons (cons (string-to-char (car rule)) - 'lao-tone-input) - vowel-upper-alist) - vowel-lower-alist - (cons (cons (string-to-char (car rule)) - 'lao-tone-input) - vowel-lower-alist))) - ((aref c-set ?9) ; semivowel lower - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-semivowel-lower-input) - consonant-alist) - vowel-upper-alist - (cons (cons (string-to-char (car rule)) - 'lao-semivowel-lower-input) - vowel-upper-alist)))) - (setq l (cdr l))) - (list 'progn - (cons 'quail-define-rules rules) - `(setq lao-consonant-alist ',consonant-alist - lao-vowel-upper-alist ',vowel-upper-alist - lao-vowel-lower-alist ',vowel-lower-alist - lao-semivowel-lower-alist ',semivowel-lower-alist)))) - -(lao-quail-define-rules - ("!" "1") - ("\"" "=") - ("#" "3") - ("$" "4") - ("&" "5") - ("%" "(1l(B") - ("'" ("(1'(B" . lao-consonant-input)) - ("(" "7") - (")" "8") - ("*" "6") - ("+" "0(1mh1(B") - ("," ("(1A(B" . lao-consonant-input)) - ("-" ("(1*(B" . lao-consonant-input)) - ("." "(1c(B") - ("/" ("(1=(B" . lao-consonant-input)) - ("0" ("(1"(B" . lao-consonant-input)) - ("1" ("(1B(B" . lao-consonant-input)) - ("2" ("(1?(B" . lao-consonant-input)) - ("3" "(1b(B") - ("4" ("(16(B" . lao-consonant-input)) - ("5" "(1X(B") - ("6" "(1Y(B") - ("7" ("(1$(B" . lao-consonant-input)) - ("8" ("(15(B" . lao-consonant-input)) - ("9" ("(1((B" . lao-consonant-input)) - (":" "%") - (";" ("(1G(B" . lao-consonant-input)) - ("<" ("(1}(B" . lao-consonant-input)) - ("=" "(1m(B") - (">" "$") - ("?" ")") - ("@" "2") - ("A" "0(1Qi1(B") - ("B" "0(1Vi1(B") - ("C" "(1O(B") - ("D" ".") - ("E" "0(1Si1(B") - ("F" ",") - ("G" ":") - ("H" "(1j(B") - ("I" ("(1N(B" . lao-consonant-input)) - ("J" "(1k(B") - ("K" "!") - ("L" "?") - ("M" "(1f(B") - ("N" "0(1Wi1(B") - ("O" ("(1|(B" . lao-consonant-input)) - ("P" "(1](B") - ("Q" "0(1[i1(B") - ("R" "_") - ("S" ";") - ("T" "+") - ("U" "0(1Ui1(B") - ("V" "x") - ("W" "0") - ("X" "(") - ("Y" "0(1Ti1(B") - ("Z" "\"") - ("[" ("(1:(B" . lao-consonant-input)) - ("]" ("(1E(B" . lao-consonant-input)) - ("^" "(1\(B") - ("_" "9") - ("`" ("(1'(B" . lao-consonant-input)) - ("a" "(1Q(B") - ("b" "(1V(B") - ("c" "(1a(B") - ("d" ("(1!(B" . lao-consonant-input)) - ("e" "(1S(B") - ("f" ("(14(B" . lao-consonant-input)) - ("g" "(1`(B") - ("h" "(1i(B") - ("i" ("(1C(B" . lao-consonant-input)) - ("j" "(1h(B") - ("k" "(1R(B") - ("l" ("(1J(B" . lao-consonant-input)) - ("m" ("(17(B" . lao-consonant-input)) - ("n" "(1W(B") - ("o" ("(19(B" . lao-consonant-input)) - ("p" ("(1-(B" . lao-consonant-input)) - ("q" "(1[(B") - ("r" ("(1>(B" . lao-consonant-input)) - ("s" ("(1K(B" . lao-consonant-input)) - ("t" "(1P(B") - ("u" "(1U(B") - ("v" ("(1M(B" . lao-consonant-input)) - ("w" "(1d(B") - ("x" ("(1;(B" . lao-consonant-input)) - ("y" "(1T(B") - ("z" ("(1<(B" . lao-consonant-input)) - ("{" "-") - ("|" ("0(1K\1(B" . lao-consonant-input)) - ("}" "/") - ("~" "(1l(B") - ("\\0" "(1p(B") - ("\\1" "(1q(B") - ("\\2" "(1r(B") - ("\\3" "(1s(B") - ("\\4" "(1t(B") - ("\\5" "(1u(B") - ("\\6" "(1v(B") - ("\\7" "(1w(B") - ("\\8" "(1x(B") - ("\\9" "(1y(B") - ) - - -;;; quail/lao.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/quail/lrt.el --- a/lisp/leim/quail/lrt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,423 +0,0 @@ -;;; quail/lrt.el --- Quail package for inputting Lao characters by LRT method - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, Lao, LRT. - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'quail) -(require 'lao-util) - -;; LRT (Lao Roman Transcription) input method accepts the following -;; key sequence: -;; consonant [+ semi-vowel-sign-lo ] + vowel [+ maa-sakod ] [+ tone-mark ] - -(eval-and-compile - -;; Upper vowels and tone-marks are put on the letter. -;; Semi-vowel-sign-lo and lower vowels are put under the letter. -(defconst lrt-single-consonant-table - `(("k" . ?(1!(B) - ("kh" . ?(1"(B) - ("qh" . ?(1$(B) - ("ng" . ?(1'(B) - ("j" . ?(1((B) - ("s" . ?(1J(B) - ("x" . ?(1*(B) - ("y" . ?(1-(B) - ("d" . ?(14(B) - ("t" . ?(15(B) - ("th" . ?(16(B) - ("dh" . ?(17(B) - ("n" . ?(19(B) - ("b" . ?(1:(B) - ("p" . ?(1;(B) - ("hp" . ?(1<(B) - ("fh" . ?(1=(B) - ("ph" . ?(1>(B) - ("f" . ?(1?(B) - ("m" . ?(1A(B) - ("gn" . ?(1B(B) - ("l" . ?(1E(B) - ("r" . ?(1C(B) - ("v" . ?(1G(B) - ("w" . ?(1G(B) - ("hh" . ?(1K(B) - ("O" . ?(1M(B) - ("h" . ?(1N(B) - ("nh" . ?(1|(B) - ("mh" . ?(1}(B) - ("lh" . "0(1K\1(B") - )) - -;; Semi-vowel-sign-lo is put under the first letter. -;; Lower vowels are put under the last letter. -;; Upper vowels and tone-marks are put on the last letter. -(defconst lrt-double-consonant-table - '(("ngh" . "(1K'(B") - ("yh" . "(1K](B") - ("wh" . "(1KG(B") - ("hl" . "(1KE(B") - ("hy" . "(1K-(B") - ("hn" . "(1K9(B") - ("hm" . "(1KA(B") - )) - -(defconst lrt-semi-vowel-sign-lo - '("r" . ?(1\(B)) - -(defconst lrt-vowel-table - '(("a" "(1P(B" (0 ?(1P(B) (0 ?(1Q(B)) - ("ar" "(1R(B" (0 ?(1R(B)) - ("i" "(1T(B" (0 ?(1T(B)) - ("ii" "(1U(B" (0 ?(1U(B)) - ("eu" "(1V(B" (0 ?(1V(B)) - ("ur" "(1W(B" (0 ?(1W(B)) - ("u" "(1X(B" (0 ?(1X(B)) - ("uu" "(1Y(B" (0 ?(1Y(B)) - ("e" "(1`(B (1P(B" (?(1`(B 0 ?(1P(B) (?(1`(B 0 ?(1Q(B)) - ("ee" "(1`(B" (?(1`(B 0)) - ("ae" "(1a(B (1P(B" (?(1a(B 0 ?(1P(B) (?(1a(B 0 ?(1Q(B)) - ("aa" "(1a(B" (?(1a(B 0)) - ("o" "(1b(B (1P(B" (?(1b(B 0 ?(1P(B) (0 ?(1[(B) (?(1-(B ?(1b(B 0 ?(1Q(B) (?(1G(B ?(1b(B 0 ?(1Q(B)) - ("oo" "(1b(B" (?(1b(B 0)) - ("oe" "(1`(B (1RP(B" (?(1`(B 0 ?(1R(B ?(1P(B) (0 ?(1Q(B ?(1M(B)) - ("or" "(1m(B" (0 ?(1m(B) (0 ?(1M(B)) - ("er" "(1`(B (1T(B" (?(1`(B 0 ?(1T(B)) - ("ir" "(1`(B (1U(B" (?(1`(B 0 ?(1U(B)) - ("ua" "(1[GP(B" (0 ?(1[(B ?(1G(B ?(1P(B) (0 ?(1Q(B ?(1G(B)) - ("uaa" "(1[G(B" (0 ?(1[(B ?(1G(B) (0 ?(1G(B)) - ("ie" "(1`Q]P(B" (?(1`(B 0 ?(1Q(B ?(1](B ?(1P(B) (0 ?(1Q(B ?(1](B)) - ("ia" "(1`Q](B" (?(1`(B 0 ?(1Q(B ?(1](B) (0 ?(1](B)) - ("ea" "(1`VM(B" (?(1`(B 0 ?(1V(B ?(1M(B)) - ("eaa" "(1`WM(B" (?(1`(B 0 ?(1W(B ?(1M(B)) - ("ai" "(1d(B" (?(1d(B 0)) - ("ei" "(1c(B" (?(1c(B 0)) - ("ao" "(1`[R(B" (?(1`(B 0 ?(1[(B ?(1R(B)) - ("aM" "(1S(B" (0 ?(1S(B)))) - -;; Maa-sakod is put at the tail. -(defconst lrt-maa-sakod-table - '((?k . ?(1!(B) - (?g . ?(1'(B) - (?y . ?(1-(B) - (?d . ?(14(B) - (?n . ?(19(B) - (?b . ?(1:(B) - (?m . ?(1A(B) - (?v . ?(1G(B) - (?w . ?(1G(B) - )) - -(defconst lrt-tone-mark-table - '(("'" . ?(1h(B) - ("\"" . ?(1i(B) - ("^" . ?(1j(B) - ("+" . ?(1k(B) - ("~" . ?(1l(B))) - -;; Return list of composing patterns for normal (without maa-sakod) -;; key sequence and with-maa-sakod key sequence starting with single -;; consonant C and optional SEMI-VOWEL. -(defun lrt-composing-pattern-single-c (c semi-vowel vowel-pattern) - (let* ((patterns (copy-sequence vowel-pattern)) - (tail patterns) - place) - ;; Embed C and SEMI-VOWEL (if any) at the place of 0. - (while tail - ;; At first, make a copy. - (setcar tail (copy-sequence (car tail))) - ;; Then, do embedding. - (setq place (memq 0 (car tail))) - (setcar place c) - (if semi-vowel - (setcdr place (cons semi-vowel (cdr place)))) - (setq tail (cdr tail))) - patterns)) - -;; Return list of composing patterns for normal (without maa-sakod) -;; key sequence and with-maa-sakod key sequence starting with double -;; consonant STR and optional SEMI-VOWEL. -(defun lrt-composing-pattern-double-c (str semi-vowel vowel-pattern) - (let* ((patterns (copy-sequence vowel-pattern)) - (tail patterns) - (chars (string-to-list - (if (= (chars-in-string str) 1) - (decompose-string str) - str))) - place) - ;; Embed C and SEMI-VOWEL (if any) at the place of 0. - (while tail - ;; At first, make a copy. - (setcar tail (copy-sequence (car tail))) - ;; Then, do embedding. - (setq place (memq 0 (car tail))) - (setcar place (car chars)) - (setcdr place (cons (nth 1 chars) (cdr place))) - (if semi-vowel - ;; Embed SEMI-VOWEL in between CHARS. - (setcdr place (cons semi-vowel (cdr place)))) - (setq tail (cdr tail))) - patterns)) - -;; Return a string made of characters in CHAR-LIST while composing -;; such characters as vowel-upper, vowel-lower, semi-vowel(lower), -;; and tone-mark with the preceding base character. -(defun lrt-compose-string (char-list) - ;; Make a copy because the following work alters it. - (setq char-list (copy-sequence char-list)) - (let ((i -1) - (l char-list)) - (while l - (if (memq (get-char-code-property (car l) 'phonetic-type) - '(vowel-upper vowel-lower semivowel-lower tone)) - (let (composed-char) - (if (< i 0) - ;; No preceding base character. - (error "Invalid CHAR-LIST: %s" char-list)) - (setq composed-char - (string-to-char (compose-chars (nth i char-list) (car l)))) - (setcar (nthcdr i char-list) composed-char) - (setq l (cdr l)) - (setcdr (nthcdr i char-list) l)) - (setq l (cdr l)) - (setq i (1+ i)))) - (concat (apply 'vector char-list)))) - -(defun lrt-compose-c-s-v (consonant semi-vowel vowel-pattern) - (let ((pattern-list - (if (integerp consonant) - (lrt-composing-pattern-single-c - consonant semi-vowel vowel-pattern) - (lrt-composing-pattern-double-c - consonant semi-vowel vowel-pattern)))) - (cons (vector (lrt-compose-string (car pattern-list))) - (cons t pattern-list)))) - -) - -(defun lrt-handle-maa-sakod () - (interactive) - (if (or (= (length quail-current-key) 0) - (not quail-current-data)) - (quail-self-insert-command) - (if (not (car quail-current-data)) - (progn - (setq quail-current-data nil) - (setq unread-command-events - (cons last-command-event unread-command-events)) - (quail-terminate-translation)) - (if (not (integerp last-command-event)) - (error "Bogus calling sequence")) - (let* ((maa-sakod (cdr (assq last-command-event lrt-maa-sakod-table))) - (maa-sakod-pattern (append - (or (cdr (assq maa-sakod - (nthcdr 3 quail-current-data))) - (nth 2 quail-current-data) - (nth 1 quail-current-data)) - (list maa-sakod)))) - (quail-delete-region) - (setq quail-current-str (lrt-compose-string maa-sakod-pattern)) - (insert quail-current-str) - (quail-show-translations) - (setq quail-current-data (list nil maa-sakod-pattern)))))) - -(defun lrt-handle-tone-mark () - (interactive) - (if (= (length quail-current-key) 0) - (quail-self-insert-command) - (if (not quail-current-data) - (progn - (setq unread-command-events - (cons last-command-event unread-command-events)) - (quail-terminate-translation)) - (if (not (integerp last-command-event)) - (error "Bogus calling sequence")) - (let* ((tone-mark (cdr (assoc (char-to-string last-command-event) - lrt-tone-mark-table))) - (tone-mark-pattern - (if (car quail-current-data) - (copy-sequence (nth 1 quail-current-data)) - ;; No need of copy because lrt-handle-maa-sakod should - ;; have already done it. - (nth 1 quail-current-data))) - (tail tone-mark-pattern) - (double-consonant-keys lrt-double-consonant-table) - (double-consonant-flag nil) - place) - - ;; Set DOUBLE-CONSONANT-FLAG to t if a user entered a double - ;; consonant. - (while (and double-consonant-keys (not double-consonant-flag)) - (setq double-consonant-flag - (eq (string-match (car (car double-consonant-keys)) - quail-current-key) - 0) - double-consonant-keys (cdr double-consonant-keys))) - - ;; Find a place to embed TONE-MARK. It should be after a - ;; single or double consonant and following upper or lower vowels. - (while (and tail (not place)) - (if (and - (eq (get-char-code-property (car tail) 'phonetic-type) - 'consonant) - ;; Skip `(1K(B' if it is the first letter of double consonant. - (or (not double-consonant-flag) - (/= (car tail) ?(1K(B))) - (progn - (setq place tail) - (setq tail (cdr tail)) - (while (and tail - (memq (get-char-code-property (car tail) - 'phonetic-type) - '(vowel-upper vowel-lower semivowel-lower))) - (setq place tail tail (cdr tail)))) - (setq tail (cdr tail)))) - ;; Embed TONE-MARK. - (setcdr place (cons tone-mark (cdr place))) - (quail-delete-region) - (insert (lrt-compose-string tone-mark-pattern)) - (setq quail-current-data nil) - (quail-terminate-translation))))) - -(defmacro lrt-generate-quail-map () - `(quail-install-map - ',(let ((map (list nil)) - (semi-vowel-key (car lrt-semi-vowel-sign-lo)) - (semi-vowel-char (cdr lrt-semi-vowel-sign-lo)) - l1 e1 l2 e2 pattern key) - ;; Single consonants. - (setq l1 lrt-single-consonant-table) - (while l1 - (setq e1 (car l1)) - (quail-defrule-internal (car e1) (vector (cdr e1)) map) - (quail-defrule-internal - (concat (car e1) semi-vowel-key) - (if (stringp (cdr e1)) - (compose-string (format "%s%c" (cdr e1) semi-vowel-char)) - (compose-string (format "%c%c" (cdr e1) semi-vowel-char))) - map) - (setq l2 lrt-vowel-table) - (while l2 - (setq e2 (car l2)) - (setq key (concat (car e1) (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) nil (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq key (concat (car e1) semi-vowel-key (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) semi-vowel-char - (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq l2 (cdr l2))) - (setq l1 (cdr l1))) - - ;; Double consonants. - (setq l1 lrt-double-consonant-table) - (while l1 - (setq e1 (car l1)) - (quail-defrule-internal (car e1) (vector (cdr e1)) map) - (quail-defrule-internal - (concat (car e1) semi-vowel-key) - (vector (concat (compose-string - (format "%c%c" (sref (cdr e1) 0) semi-vowel-char)) - (substring (cdr e1) (charset-bytes 'lao)))) - map) - (setq l2 lrt-vowel-table) - (while l2 - (setq e2 (car l2)) - (setq key (concat (car e1) (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) nil (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq key (concat (car e1) semi-vowel-key (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) semi-vowel-char - (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq l2 (cdr l2))) - (setq l1 (cdr l1))) - - ;; Vowels. - (setq l1 lrt-vowel-table) - (while l1 - (setq e1 (car l1) l1 (cdr l1)) - (quail-defrule-internal (car e1) (vector (nth 1 e1)) map)) - - ;; Tone-marks. - (setq l1 lrt-tone-mark-table) - (while l1 - (setq e1 (car l1) l1 (cdr l1)) - (quail-defrule-internal (car e1) (cdr e1) map)) - - map))) - -(quail-define-package - "lao-lrt" "Lao" "(1E(BR" t - "Lao input method using LRT (Lao Roman Transcription). -`\\' (backslash) + number-key => (1p(B,(1q(B,(1r(B,... LAO DIGIT ZERO, ONE, TWO, ... -`\\' (backslash) + `\\' => (1f(B LAO KO LA (REPETITION) -`\\' (backslash) + `$' => (1O(B LAO ELLIPSIS -" - '(("k" . lrt-handle-maa-sakod) - ("g" . lrt-handle-maa-sakod) - ("y" . lrt-handle-maa-sakod) - ("d" . lrt-handle-maa-sakod) - ("n" . lrt-handle-maa-sakod) - ("b" . lrt-handle-maa-sakod) - ("m" . lrt-handle-maa-sakod) - ("v" . lrt-handle-maa-sakod) - ("w" . lrt-handle-maa-sakod) - ("'" . lrt-handle-tone-mark) - ("\"" . lrt-handle-tone-mark) - ("^" . lrt-handle-tone-mark) - ("+" . lrt-handle-tone-mark) - ("~" . lrt-handle-tone-mark)) - 'forget-last-selection 'deterministic 'kbd-translate 'show-layout - nil nil nil nil nil t) - -(lrt-generate-quail-map) - -;; Additional key definitions for Lao digits. - -(quail-defrule "\\0" ?(1p(B) -(quail-defrule "\\1" ?(1q(B) -(quail-defrule "\\2" ?(1r(B) -(quail-defrule "\\3" ?(1s(B) -(quail-defrule "\\4" ?(1t(B) -(quail-defrule "\\5" ?(1u(B) -(quail-defrule "\\6" ?(1v(B) -(quail-defrule "\\7" ?(1w(B) -(quail-defrule "\\8" ?(1x(B) -(quail-defrule "\\9" ?(1y(B) -(quail-defrule "\\\\" ?(1f(B) -(quail-defrule "\\$" ?(1O(B) - -;;; quail/lrt.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/leim/quail/tibetan.el --- a/lisp/leim/quail/tibetan.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,519 +0,0 @@ -;;; quail/tibetan.el -- Quail package for inputting Tibetan characters - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. - -;; Keywords: multilingual, input method, Tibetan - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;; Author: Toru TOMABECHI, - -;; Created: Feb. 17. 1997 - -;; History: -;; 1997.03.13 Support for inputting special signs and punctuations added. -;; (Only Ext. Wylie input) - -;;; Code: - -(require 'quail) - -;;; -;;; Functions for making some composite punctuations. -;;; - -(defun tibetan-quail-bzhi-shad (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7!>(B '(mr . ml) ?\x20 '(mr . ml) ?$(7!>(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla-phur-shad (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B '(bc . tl) ?$(7!I(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla-double (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B '(mr . ml) ?$(7#S(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla-triple (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B '(mr . ml) ?$(7#S(B '(mr . ml) ?$(7#S(B)) - (throw 'quail-tag nil)) - -;;; -;;; Setting-ups for Extended Wylie input. -;;; - -(defun quail-tibetan-input-wylie (key &rest ignore) - (let (pc) - (quail-delete-region) - (quail-delete-overlays) - (setq pc (preceding-char)) - (if (not (eq (point) (point-min))) - (delete-backward-char 1 nil)) - (insert (tibetan-composition pc key)) - (throw 'quail-tag nil))) - - -(quail-define-package "tibetan-wylie" "Tibetan" "TIBw" t -"Tibetan character input by Extended Wylie key assignment. - - +-------------------------------------+ - |2$(7"!`#T1$(8!;(B k |2$(7""`#T1$(8!;(B kh |2$(7"#`#T1$(8!;(B g |2$(7"$`#T1$(8!;(B gh |2$(7"%`#T1$(8!;(B ng| $(7"S(B i $(8!=(B / - |2$(7"&`#T1$(8!;(B c |2$(7"'`#T1$(8!;(B ch |2$(7"(`#T1$(8!;(B j | |$(7"*$(8!;(B ny| $(7"U(B u $(7!>(B // - |$(7"+$(8!;(B T |$(7",$(8!;(B TH |$(7"-$(8!;(B D |$(7".$(8!;(B DH |$(7"/$(8!;(B N | $(7"[(B e 2$(7!>P(B P$(7!>1(B //// - |$(7"0$(8!;(B t |$(7"1$(8!;(B th |$(7"2$(8!;(B d |$(7"3$(8!;(B dh |$(7"4$(8!;(B n | $(7"](B o $(7!A(B ; - |$(7"5$(8!;(B p |$(7"6$(8!;(B ph |$(7"7$(8!;(B b |$(7"8$(8!;(B bh |$(7"9$(8!;(B m | $(7"\(B ai (ee, E) $(8!?(B $ - |$(7":$(8!;(B ts|$(7";$(8!;(B tsh|$(7"<$(8!;(B dz |$(7"=$(8!;(B dzh|$(7">$(8!;(B w | $(7"^(B au (oo, O) $(8!@(B & - |$(7"?$(8!;(B zh|$(7"@$(8!;(B z |$(7"A$(8!;(B ' | |$(7"B$(8!;(B y | $(7"a(B I 2$(7#RP#SP#S1(B * - |$(7"C$(8!;(B r |$(7"D$(8!;(B l |$(7"E$(8!;(B sh |$(7"F$(8!;(B SH |$(7"G$(8!;(B s | $(7"`(B : 2$(7#RP#SP#SP#S1(B # - |$(7"H$(8!;(B h |$(7"I$(8!;(B A |$(7"J$(8!;(B kSH| | | $(7"_(B M $(7!l(B $(7!m(B < > - +-------------------------------------+ $(8!D(B % - (The consonant $(7"I$(8!;(B must be typed explicitly.) - - NOT SPECIFIED IN EXT. WYLIE: - +--------------------------------------------------------+ - |$(7"c(B = ~ |$(7"d(B = ` |$(7"e(B = , |$(7"f(B = @ |$(7!g(B = _o|$(7!e(B = _O|2$(7#RP#S_!I1(B = ^| - +--------------------------------------------------------+ - |$(7"i(B = x |$(7"j(B = X |$(7"g(B = v |$(7"h(B = V |$(7"k(B = q |$(7"l(B = Q | - +-----------------------------------------------+ - - SPECIAL KEYS - + : Consonant Stacking - \(Consonant stacking for ordinary Tibetan is done automatically) - - : No Consonant Stacking - \(To suppress automatic stacking for \"g-y\", - and to get da-drag in -r-d, -l-d .) - | : Special signs. - - Tsheg is assigned to SPC. Space is assigned to period '.'. -" - nil nil nil) - -(quail-define-rules - ("." ?\x20) - ("k" quail-tibetan-input-wylie) - ("g" quail-tibetan-input-wylie) - ("c" quail-tibetan-input-wylie) - ("j" quail-tibetan-input-wylie) - ("T" quail-tibetan-input-wylie) - ("D" quail-tibetan-input-wylie) - ("N" quail-tibetan-input-wylie) - ("t" quail-tibetan-input-wylie) - ("d" quail-tibetan-input-wylie) - ("n" quail-tibetan-input-wylie) - ("p" quail-tibetan-input-wylie) - ("b" quail-tibetan-input-wylie) - ("m" quail-tibetan-input-wylie) - ("w" quail-tibetan-input-wylie) - ("z" quail-tibetan-input-wylie) - ("'" quail-tibetan-input-wylie) - ("y" quail-tibetan-input-wylie) - ("r" quail-tibetan-input-wylie) - ("l" quail-tibetan-input-wylie) - ("SH" quail-tibetan-input-wylie) - ("s" quail-tibetan-input-wylie) - ("h" quail-tibetan-input-wylie) - ("H" quail-tibetan-input-wylie) - ("A" quail-tibetan-input-wylie) - ("+k" quail-tibetan-input-wylie) - ("+g" quail-tibetan-input-wylie) - ("+c" quail-tibetan-input-wylie) - ("+j" quail-tibetan-input-wylie) - ("+T" quail-tibetan-input-wylie) - ("+D" quail-tibetan-input-wylie) - ("+N" quail-tibetan-input-wylie) - ("+t" quail-tibetan-input-wylie) - ("+d" quail-tibetan-input-wylie) - ("+n" quail-tibetan-input-wylie) - ("+p" quail-tibetan-input-wylie) - ("+b" quail-tibetan-input-wylie) - ("+m" quail-tibetan-input-wylie) - ("+w" quail-tibetan-input-wylie) - ("+z" quail-tibetan-input-wylie) - ("+'" quail-tibetan-input-wylie) - ("+y" quail-tibetan-input-wylie) - ("+r" quail-tibetan-input-wylie) - ("+l" quail-tibetan-input-wylie) - ("+SH" quail-tibetan-input-wylie) - ("+s" quail-tibetan-input-wylie) - ("+h" quail-tibetan-input-wylie) - ("+H" quail-tibetan-input-wylie) - ("+A" quail-tibetan-input-wylie) - ("-d" ?$(7"2(B) ; To avoid default stacking - ("-y" ?$(7"B(B) ; Idem. - ("a" quail-tibetan-input-wylie) ; invisible vowel sign - ("i" quail-tibetan-input-wylie) - ("u" quail-tibetan-input-wylie) - ("e" quail-tibetan-input-wylie) - ("o" quail-tibetan-input-wylie) - ("I" quail-tibetan-input-wylie) - ("E" quail-tibetan-input-wylie) - ("O" quail-tibetan-input-wylie) - ("M" quail-tibetan-input-wylie) - ("~" quail-tibetan-input-wylie) - ("`" quail-tibetan-input-wylie) - ("," quail-tibetan-input-wylie) - ("x" quail-tibetan-input-wylie) - ("X" quail-tibetan-input-wylie) - ("v" quail-tibetan-input-wylie) - ("V" quail-tibetan-input-wylie) - ("q" quail-tibetan-input-wylie) - ("Q" quail-tibetan-input-wylie) - ("_o" quail-tibetan-input-wylie) - ("_O" quail-tibetan-input-wylie) -;;; ("_/" quail-tibetan-input-wylie) - (":" ?$(8"`(B) - (" " ?$(8!;(B) - ("/" ?$(8!=(B) - ("//" ?$(7!>(B) - ("////" tibetan-quail-bzhi-shad) - ("$" ?$(8!?(B) - ("/\"" ?$(8!@(B) ; Not defined in Ext. Wylie. - ("&" ?$(8!@(B) - (";" ?$(8!A(B) - ("%" ?$(8!D(B) - ("!" ?$(7!8(B) - ("<" ?$(7!l(B) - (">" ?$(7!m(B) - ("@" ?$(7"f(B) - ("*" tibetan-quail-nyi-zla-double) - ("#" tibetan-quail-nyi-zla-triple) - ("^" tibetan-quail-nyi-zla-phur-shad) - ("0" ?$(7!P(B) - ("1" ?$(7!Q(B) - ("2" ?$(7!R(B) - ("3" ?$(7!S(B) - ("4" ?$(7!T(B) - ("5" ?$(7!U(B) - ("6" ?$(7!V(B) - ("7" ?$(7!W(B) - ("8" ?$(7!X(B) - ("9" ?$(7!Y(B) - ("-0" ?$(7!c(B) - ("-1" ?$(7!Z(B) - ("-2" ?$(7![(B) - ("-3" ?$(7!\(B) - ("-4" ?$(7!](B) - ("-5" ?$(7!^(B) - ("-6" ?$(7!_(B) - ("-7" ?$(7!`(B) - ("-8" ?$(7!a(B) - ("-9" ?$(7!b(B) - ("|" "$(7!1!2!3!9!:!B!C!E!F!G!H!I!J!K!L!M!N!O!d!f!h!j!k!n!o(B") - ) - -;;; -;;; Setting-ups for TibKey input -;;; - -(defconst tibetan-tibkey-to-transcription-alist - '( - ("`" . "`") ; sna ldan - ("~" . "~") ; sna ldan + nada - ("q" . "k") ; ka - ("Q" ."kSH") ; kSHa - ("w" . "kh") ; kha - ("e" . "g") ; ga - ("r" . "ng") ; nga - ("t" . "c") ; ca - ("T" . "I") ; gi gu log - ("y" . "ch") ; cha - ("u" . "j") ; ja - ("i" . "ny") ; nya - ("o" . "t") ; ta - ("O" . "T") ; Ta - ("p" . "th") ; tha - ("P" . "TH") ; THa - ("[" . "d") ; da - ("{" . "D") ; Da - ("]" . "n") ; na - ("}" . "N") ; Na - ("a" . "p") ; pa - ("A" . "a") ; Vowel a (not used in original TibKey) - ("s" . "ph") ; pha - ("d" . "b") ; ba - ("f" . "m") ; ma - ("F" . "M") ; anusvara - ("g" . "u") ; zhabs kyu - ("G" . "i") ; gi gu - ("H" . ",") ; viraama - ("j" . "o") ; naro - ("J" . "e") ; 'greng bu - ("k" . "ts") ; tsa - ("l" . "tsh") ; tsha - (";" . "dz") ; dza - ("'" . "w") ; wa - ("\"" . "+w") ; wa zur - ("z" . "zh") ; zha - ("x" . "z") ; za - ("c" . "'") ; 'a - ("C" . "+'") ; 'a chung - ("v" . "y") ; ya - ("V" . "+y") ; ya btags - ("b" . "r") ; ra - ("B" . "+r") ; ra btags - ("n" . "l") ; la - ("N" . "+l") ; la btags - ("m" . "sh") ; sha - ("M" . "SH") ; SHa - ("," . "s") ; sa - ("." . "h") ; ha - ("/" . "A") ; Aa - ;;subjoined - ("hq" . "+k") ; ka - ("hQ" ."+kSH") ; kSHa - ("hw" . "+kh") ; kha - ("he" . "+g") ; ga - ("hr" . "+ng") ; nga - ("ht" . "+c") ; ca - ("hy" . "+ch") ; cha - ("hu" . "+j") ; ja - ("hi" . "+ny") ; nya - ("ho" . "+t") ; ta - ("hO" . "+T") ; Ta - ("hp" . "+th") ; tha - ("hP" . "+TH") ; THa - ("h[" . "+d") ; da - ("h{" . "+D") ; Da - ("h]" . "+n") ; na - ("h}" . "+N") ; Na - ("ha" . "+p") ; pa - ("hs" . "+ph") ; pha - ("hd" . "+b") ; ba - ("hf" . "+m") ; ma - ("hk" . "+ts") ; tsa - ("hl" . "+tsh") ; tsha - ("h;" . "+dz") ; dza - ("h'" . "+w") ; wa - ("hz" . "+zh") ; zha - ("hx" . "+z") ; za - ("hc" . "+'") ; 'a - ("hv" . "+y") ; ya - ("hb" . "+r") ; ra - ("hn" . "+l") ; la - ("hm" . "+sh") ; sha - ("hM" . "+SH") ; SHa - ("h," . "+s") ; sa - ("h." . "+h") ; ha - ("h/" . "+A") ; Aa - )) - -(defun quail-tibetan-input-tibkey (key &rest ignore) - (let (trans pc) - (setq trans (cdr (assoc key tibetan-tibkey-to-transcription-alist))) - (quail-delete-region) - (quail-delete-overlays) - (setq pc (preceding-char)) - (if (not (eq (point) (point-min))) - (delete-backward-char 1 nil)) - (insert (tibetan-composition pc trans)) - (throw 'quail-tag nil))) - - - -(quail-define-package "tibetan-tibkey" "Tibetan" "TIBt" t -"Tibetan character input by TibKey key assignment. - -(This implementation is still incomplete. - Therefore, the following key assignment is a provisional one.) - - [NOT SHIFTED] - - +-------------------------------------------------------+ - |`$(7"d(B|1$(7!Q(B|2$(7!R(B|3$(7!S(B|4$(7!T(B|5$(7!U(B|6$(7!V(B|7$(7!W(B|8$(7!X(B|9$(7!Y(B|0$(7!P(B|- |= |\\$(7!8(B| - +-------------------------------------------------------+ - |q$(7"!(B|w$(7""(B|e$(7"#(B|r$(7"%(B|t$(7"&(B|y$(7"'(B|u$(7"((B|i$(7"*(B|o$(7"0(B|p$(7"1(B|[$(7"2(B|]$(7"4(B| - +-----------------------------------------------+ - |a$(7"5(B| s$(7"6(B| d$(7"7(B|f$(7"9(B|g$(7"U(B|h |j$(7"](B|k$(7":(B|l$(7";(B|;$(7"<(B|'$(7">(B| - +---------------------------------------------+ - |z$(7"?(B|x$(7"@(B|c$(7"A(B|v$(7"B(B|b$(7"C(B|n$(7"D(B|m$(7"E(B|,$(7"G(B|.$(7"H(B|/$(7"I(B| - +---------------------------------------+ - The key 'h' is used for consonant stacking. - - [SHIFTED] - - +----------------------------------------------------------+ - |~$(7"c(B|!2$(7#RP#S1(B|@$(7#S(B|# |$ |%$(8!D(B |^$(7!1(B|& |* |($(7!l(B|)$(7!m(B|_ |+$(7!A(B| |$(7!8(B| - +----------------------------------------------------------+ - |Q$(7"J(B|W$(7#T(B|E |R |T$(7"a(B|Y |U |I$(7"f(B|O$(7"+(B|P$(7",(B|{$(7"-(B|}$(7"/(B| - +-----------------------------------------------+ - |A |S |D |F$(7"_(B|G$(7"S(B|H$(7"e(B|J$(7"[(B|K |L |:$(7"`(B|\"$(7#>(B| - +-------------------------------------------+ - |Z |X |C$(7#A(B|V$(7#B(B|B$(7#C(B|N$(7#D(B|M$(7"F(B|< |> |?$(8!=(B | - +---------------------------------------+ - - DIFFERENCE FROM THE ORIGINAL TIBKEY: - - 1. Vowel 'a' should be typed explicitly by the key 'A'. - This is really inconvenient. But to make the coding - scheme clear, it is desirable to have an explicite - vowel sign for 'a'. - 2. Tsheg is assigned to SPC key. You can input a space - by typing '>'. - 4. To avoid the default stacking $(7$B(B and to obtain $(7"#"B(B, - type 'E' instead of 'v' (=$(7"B(B). - 3. There are many characters that are not supported in the - current implementation (especially special signs). I hope - I'll complete in a future revision. -" - nil t) - -(quail-define-rules - ("`" quail-tibetan-input-tibkey) ; sna ldan, not supported yet - ("~" quail-tibetan-input-tibkey) ; sna ldan + nada - ("1" ?$(7!Q(B) - ("!" tibetan-quail-nyi-zla) ; nyi zla long - ("2" ?$(7!R(B) - ("@" ?$(7#S(B) ; nyi zla simple - ("3" ?$(7!S(B) -;;; ("#" ) - ("4" ?$(7!T(B) -;;; ("$" ) - ("5" ?$(7!U(B) - ("%" ?$(8!D(B) - ("6" ?$(7!V(B) - ("^" ?$(7!1(B) - ("7" ?$(7!W(B) - ("8" ?$(7!X(B) -;;; ("*" ) ; avagraha, not supported yet - ("9" ?$(7!Y(B) - ("(" ?$(7!l(B) - ("0" ?$(7!P(B) - (")" ?$(7!m(B) -;;; ("-" ) ; enphatic, not yet supported -;;; ("_" ) ; id. -;;; ("=" ) ; special sign, not yet supported - ("+" ?$(8!A(B) - ("\\" ?$(8!?(B) - ("|" ?$(7!8(B) - ("q" quail-tibetan-input-tibkey) ; ka - ("Q" quail-tibetan-input-tibkey) ; kSHa - ("w" quail-tibetan-input-tibkey) ; kha - ("e" quail-tibetan-input-tibkey) ; ga - ("E" ?$(7"B(B) - ("r" quail-tibetan-input-tibkey) ; nga - ("t" quail-tibetan-input-tibkey) ; ca - ("T" quail-tibetan-input-tibkey) ; gi gu log - ("y" quail-tibetan-input-tibkey) ; cha - ("u" quail-tibetan-input-tibkey) ; ja - ("i" quail-tibetan-input-tibkey) ; nya - ("I" ?$(7"f(B) ; avagraha - ("o" quail-tibetan-input-tibkey) ; ta - ("O" quail-tibetan-input-tibkey) ; Ta - ("p" quail-tibetan-input-tibkey) ; tha - ("P" quail-tibetan-input-tibkey) ; THa - ("[" quail-tibetan-input-tibkey) ; da - ("{" quail-tibetan-input-tibkey) ; Da - ("]" quail-tibetan-input-tibkey) ; na - ("}" quail-tibetan-input-tibkey) ; Na - ("a" quail-tibetan-input-tibkey) ; pa - ("A" quail-tibetan-input-tibkey) ; Vowel sign a - ("s" quail-tibetan-input-tibkey) ; pha - ("d" quail-tibetan-input-tibkey) ; ba -;;; ("D" ) ; special sign, not supported yet - ("f" quail-tibetan-input-tibkey) ; ma - ("F" quail-tibetan-input-tibkey) ; anusvara - ("g" quail-tibetan-input-tibkey) ; zhabs kyu - ("G" quail-tibetan-input-tibkey) ; gi gu - ("H" quail-tibetan-input-tibkey) ; viraama - ("j" quail-tibetan-input-tibkey) ; naro - ("J" quail-tibetan-input-tibkey) ; 'greng bu - ("k" quail-tibetan-input-tibkey);;tsa -;;; ("K" ) ; tsadru, not supported yet - ("l" quail-tibetan-input-tibkey) ; tsha - (";" quail-tibetan-input-tibkey) ; dza - (":" ?$(8"`(B) - ("'" quail-tibetan-input-tibkey) ; wa - ("\"" quail-tibetan-input-tibkey) ; wa zur - ("z" quail-tibetan-input-tibkey) ; zha - ("x" quail-tibetan-input-tibkey) ; za - ("c" quail-tibetan-input-tibkey) ; 'a - ("C" quail-tibetan-input-tibkey) ; 'a chung - ("v" quail-tibetan-input-tibkey) ; ya - ("V" quail-tibetan-input-tibkey) ; ya btags - ("b" quail-tibetan-input-tibkey) ; ra - ("B" quail-tibetan-input-tibkey) ; ra btags - ("n" quail-tibetan-input-tibkey) ; la - ("N" quail-tibetan-input-tibkey) ; la btags - ("m" quail-tibetan-input-tibkey) ; sha - ("M" quail-tibetan-input-tibkey) ; SHa - ("," quail-tibetan-input-tibkey) ; sa - ("." quail-tibetan-input-tibkey) ; ha -;;; (">" ?$(8!;(B) ; to be assigned to SPC - (">" ?\x20) - ("/" quail-tibetan-input-tibkey) ; Aa - ("?" ?$(8!=(B) - ("??" ?$(7!>(B) - ("????" tibetan-quail-bzhi-shad) - (" " ?$(8!;(B) - ;;subjoined - ("hq" quail-tibetan-input-tibkey) ; ka - ("hQ" quail-tibetan-input-tibkey) ; kSHa - ("hw" quail-tibetan-input-tibkey) ; kha - ("he" quail-tibetan-input-tibkey) ; ga - ("hr" quail-tibetan-input-tibkey) ; nga - ("ht" quail-tibetan-input-tibkey) ; ca - ("hy" quail-tibetan-input-tibkey) ; cha - ("hu" quail-tibetan-input-tibkey) ; ja - ("hi" quail-tibetan-input-tibkey) ; nya - ("ho" quail-tibetan-input-tibkey) ; ta - ("hO" quail-tibetan-input-tibkey) ; Ta - ("hp" quail-tibetan-input-tibkey) ; tha - ("hP" quail-tibetan-input-tibkey) ; THa - ("h[" quail-tibetan-input-tibkey) ; da - ("h{" quail-tibetan-input-tibkey) ; Da - ("h]" quail-tibetan-input-tibkey) ; na - ("h}" quail-tibetan-input-tibkey) ; Na - ("ha" quail-tibetan-input-tibkey) ; pa - ("hs" quail-tibetan-input-tibkey) ; pha - ("hd" quail-tibetan-input-tibkey) ; ba - ("hf" quail-tibetan-input-tibkey) ; ma - ("hk" quail-tibetan-input-tibkey) ; tsa - ("hl" quail-tibetan-input-tibkey) ; tsha - ("h;" quail-tibetan-input-tibkey) ; dza - ("h'" quail-tibetan-input-tibkey) ; wa - ("hz" quail-tibetan-input-tibkey) ; zha - ("hx" quail-tibetan-input-tibkey) ; za - ("hc" quail-tibetan-input-tibkey) ; 'a - ("hv" quail-tibetan-input-tibkey) ; ya - ("hb" quail-tibetan-input-tibkey) ; ra - ("hn" quail-tibetan-input-tibkey) ; la - ("hm" quail-tibetan-input-tibkey) ; sha - ("hM" quail-tibetan-input-tibkey) ; SHa - ("h," quail-tibetan-input-tibkey) ; sa - ("h." quail-tibetan-input-tibkey) ; ha - ("h/" quail-tibetan-input-tibkey) ; Aa - ) - -;;; quail/tibetan.el ends here. - - - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/ANNOUNCE --- a/lisp/mailcrypt/ANNOUNCE Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -Mailcrypt version 3.4 is now available. - -Mailcrypt is an Emacs Lisp package which provides a simple interface -to message encryption with PGP. (You do use Emacs to handle your mail -and news, right?) - -Features: Encryption, decryption, signing, adding keys, extracting -keys, passphrase caching with timeout, multiple secret key (identity) -support, a simple but flexible interface to Cypherpunk remailers -(including chaining, response blocks, pseudonyms, and Mixmaster -support), and an automatic keyserver interface via HTTP. - -*We* think it's the best interface to these functions anywhere, but -then again, we're biased. - -The NEWS file is appended to this message. - -Obtain it from the Mailcrypt home page at - - http://cag-www.lcs.mit.edu/mailcrypt/ - -or via FTP to - - ftp://cag.lcs.mit.edu/pub/patl/ - -Enjoy! - - - Patrick J. LoPresti (patl@lcs.mit.edu) - - Jin S. Choi (jin@atype.com) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/ChangeLog --- a/lisp/mailcrypt/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,394 +0,0 @@ -Wed Apr 24 17:59:45 1996 Steven L Baur - - * mailcrypt.el (mc-modes-alist): September Gnus has message-mode - for editing mail and news messages. - -Tue Oct 10 15:53:01 1995 Patrick J. LoPresti - - * Version 3.4 released. - -Wed Oct 4 18:25:02 1995 Patrick J. LoPresti - - * INSTALL: Document setting mc-pgp-comment to nil if using - obsolete version of PGP. - - * mc-remail.el (mc-parse-levien-buffer): Allow remailers with - "mix" property, even if "pgp" and "cpunk" properties are lacking. - (mc-generic-pre-encrypt-function): Don't try to - expand-mail-aliases if 'mail-abbrevs is provided. - - * mc-pgp.el (mc-pgp-always-fetch): New variable. Use to regulate - key fetching. - -Fri Sep 29 14:39:17 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-deactivate-passwd): Don't give feedback unless - called interactively. - (mc-get-fields): Use `buffer-substring-no-properties' to get the - body of the field as well as the name. Egad. - -Fri Sep 22 15:34:47 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-gnus-verify-signature): Renamed from - `mc-gnus-summary-verify-signature'. - (mc-gnus-snarf-keys): Renamed from `mc-gnus-summary-snarf-keys'. - (mc-gnus-decrypt-message): Renamed from - `mc-gnus-summary-decrypt-message'. - - * mailcrypt.el (mc-modes-alist): Add `gnus-article-mode'. - Reflect name changes to Gnus support functions. - -Wed Sep 20 09:30:53 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Bind - `case-fold-search' to nil when matching "Gnus". - - * mailcrypt.el (mc-xemacs-p): "XEmacs", not "Xemacs". - -Sat Sep 16 09:51:03 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-encrypt-region): If no recipients, just armor - file. - (mc-pgp-msg-end-line): Match optional newline at end. - (mc-pgp-encrypt-region): Don't honor mc-encrypt-for-me if only - armoring. - Output "Armoring..." if only armoring. - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Don't - bother trapping error on decrypt. - Require Gnus version 5.0.4 or higher. - Use new `gnus-group-read-only-p' predicate. - Pass t to `gnus-summary-edit-article'. - (mc-encrypt-message): Punt check for no recipients. - -Sun Sep 10 16:36:37 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-decrypt-parser): Deal with armor-only files. - - * mc-remail.el (mc-eliminate-continuation-lines): New function. - (mc-generic-pre-encrypt-function): Eliminate continuation lines in - preserved headers. - (mc-rewrite-for-mixmaster): Ditto. - -Mon Sep 4 17:57:47 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-process-region): Make sure we are in the source - buffer when starting process, in case `process-environment' is - buffer-local. - - * mc-remail.el (mc-rewrite-for-mixmaster): Signal error if - attempting to post through a Mixmaster. - -Sun Sep 3 18:09:58 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-decrypt-region): Add strategic - `save-excursion' calls to avoid changing buffers inside `let'. - -Fri Sep 1 15:05:56 1995 Patrick J. LoPresti - - * mc-remail.el (mc-remailer-remove-property): New function. - (mc-remailer-canonicalize-chain): Make second arg CHAINS-ALIST - optional; default to `(mc-remailer-make-chains-alist)'. - (mc-demix): New function. - - * mailcrypt.el (mc-process-region): Fix regexp to match "Process - *PGP* killed" et al. - -Thu Aug 31 12:52:44 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-encrypt-message): Clean up. Use - `mc-get-fields' and `mc-strip-addresses'. - - * mailcrypt.el (mc-strip-addresses): New function. Use everywhere. - - * mc-remail.el (mc-remailer-choose-first): New function. - (mc-remailer-choose-chain): New function. - (mc-parse-levien-buffer): Add support for returning a "ranking" of - remailers. - (mc-remailer-canonicalize-elmt): Add support for using an integer - N in a remailer-list to represent the top N remailers, shuffled - randomly. - (mc-strip-address): New function. Use everywhere. - - * mc-toplev.el (mc-vm-decrypt-message): Bind `this-command' to - `vm-edit-message-end' to trick VM into doing the right thing when - redisplaying. - -Sun Aug 27 13:12:22 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-sign-generic): Only run hooks if signing was - successful. - -Sat Aug 26 09:18:51 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-vm-decrypt-message): Bind `vm-frame-per-edit' - to nil. - -Fri Aug 25 17:41:28 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-sign-generic): Return result of signing - message, instead of always returning nil. - -Mon Aug 21 11:58:07 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-modes-alist): Add support for - `vm-virutal-mode'. - -Sun Aug 20 15:19:52 1995 Patrick J. LoPresti - - * Makefile.in (install): Use a loop for installing .elc files, - since install-sh can't copy multiple files at once. - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Back out 8/4 - change; call `gnus-summary-edit-article-postpone' instead. - Call `gnus-version' function instead of reading variable. - -Fri Aug 4 11:51:37 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Run - `gnus-article-display-hook' after decrypting. - -Wed Aug 2 10:05:06 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-split): Use \\' instead of $ to match end of - string. - -Tue Aug 1 15:55:47 1995 Patrick J. LoPresti - - * Version 3.3 released. - -Mon Jul 31 11:22:23 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-rmail-decrypt-message): Use abstractions for - keymaps to work with XEmacs. - (mc-gnus-summary-decrypt-message): Clean up. - (mc-gnus-summary-verify-signature): Don't display all headers. - (mc-gnus-summary-snarf-keys): Ditto. - -Sat Jul 29 11:47:51 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-decrypt-region): Call `undo-boundary'. - -Thu Jul 27 20:56:41 1995 Patrick J. LoPresti - - * load-path.hack: Give a friendly warning if a version of Emacs - other than 19 is used to byte-compile. - -Thu Jul 27 16:05:13 1995 Patrick J. LoPresti - - * configure.in: Use `EMACS19' instead of `EMACS' for autoconf - substitution variable, lest "configure" get confused when run - under an Emacs shell. - - * Makefile.in: Ditto. - -Thu Jul 27 10:24:47 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-keyserver-address): Use "pgp.ai.mit.edu" - instead of "www-swiss.ai.mit.edu". - - * ANNOUNCE: Update version and date in preparation for 3.3 - release. - - * INSTALL: Updated to reflect new installation directory and - absolute requirement of `easymenu'. - - * mailcrypt.el (mc-process-region): Fix parenthesization error. - Again. - -Wed Jul 26 12:48:50 1995 Patrick J. LoPresti - - * mc-remail.el (mc-rewrite-for-remailer): Use `mc-encrypt-for-me' - instead of `mc-encrypt-to-me', since there the latter does not - exist. - -Sun Jul 23 13:01:47 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-decrypt-region): Clean up case where key is - missing and we offer to fetch it. - -Thu Jul 20 11:51:06 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-newkey-re): Incorporate fix from Mike Long to - only recognize key additions. - -Wed Jul 19 10:50:55 1995 Patrick J. LoPresti - - * mailcrypt.el: Deal with unbound buffer-substring-no-properties - to work with Emacs 19.28 after all. - - * mc-pgp.el (mc-pgp-verify-region): Return nil if signature fails - to verify. - - * mc-toplev.el (mc-sign-generic): Make sure start and end are - markers before calling mc-pre-signature-hook. - (mc-encrypt-generic): Ditto, mc-pre-encryption-hook. - - * mc-remail.el (mc-remailer-insert-response-block): Fix - parenthesization error. - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Incorporate Fran - Litterio's changes for (ding) GNUS. - Clean up MH-E stuff a bit. Should really redo it entirely at some - point. - - * texi2html.ext: New file. - -Tue Jul 18 14:26:00 1995 Patrick J. LoPresti - - * Fix stuff all over to silence byte compilation warnings under - XEmacs. - - * mailcrypt.el: (require 'easymenu) outright. Starting now we - demand at least FSF Emacs 19.28 or XEmacs 19.13. - -Mon Jul 17 16:30:43 1995 Patrick J. LoPresti - - * Makefile.in: Minor tweaks. Use `.../share/emacs/site-lisp'. - -Sun Jul 16 13:48:06 1995 Patrick J. LoPresti - - * mc-pgp.el: Use "buffer-substring-no-properties" everywhere. Feh. - mc-remail.el: Ditto. - -Sat Jul 15 01:41:18 1995 Patrick J. LoPresti - - * mc-pgp.el: Add "+language=en" to PGP command lines so that we - are sure to parse the output correctly. - -Wed Jul 12 16:37:37 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-vm-verify-signature): Call vm-widen-page in - case vm-honor-page-delimiters is set. - (mc-vm-snarf-keys): Ditto. - ('mail-utils): Required for mail-fetch-field on some Emacsen. - -Fri Jun 30 10:20:52 1995 Patrick J. LoPresti - - * mc-remail.el (mc-rewrite-news-to-mail): Nuke "Newsgroups" field. - -Fri Jun 23 11:04:54 1995 Patrick J. LoPresti - - * Version 3.2 released. - - * mc-pgp.el (mc-pgp-fetch-key): Add "+batchmode" to PGP arglist. - (mc-pgp-key-begin-line): Allow match only when delimiter string - is the entire line. - (mc-pgp-key-end-line): Likewise. - - * configure.in: New file. - configure: New file. - Makefile.in: New file. Brought into conformance with GNU - standards. - INSTALL: Revised to reflect `autoconf'-generated configuration - scheme. - - * mailcrypt.el (mc-deactivate-passwd, mc-activate-passwd): Do the - right thing if both `timer' and `itimer' are present. - -Thu Jun 22 16:57:49 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-generic-parser): Include '\n' from final - delimiter line. - -Wed Jun 21 18:13:10 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-fetch-key): Give a diagnostic if the key was - not found. - -Tue Jun 20 00:53:51 1995 Patrick J. LoPresti - - * mc-toplev.el (mc-rmail-view-quit): Mark buffer unmodified when - quitting. - - * mailcrypt.el (mc-process-region): Don't rely on - accept-process-output returning immediately if process is dead - (for XEmacs' sake). - - * README: Revised (i.e., truncated) to reflect INSTALL file, - Texinfo docs, and Web pages. - - * INSTALL: New file. - - * Makefile: New file. - -Mon Jun 19 16:55:39 1995 Patrick J. LoPresti - - * NEWS: New file. - - * mailcrypt.texi: New file. Spent last few days getting this - written and the Web pages up. - -Fri Jun 16 17:55:14 1995 Patrick J. LoPresti - - * mc-pgp.el (mc-pgp-comment): New variable. - -Thu Jun 15 00:33:44 1995 Patrick J. LoPresti - - * mc-pgp.el: New file. - - * mc-toplev.el: New file. - -Wed Jun 14 16:51:00 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-pgp-fetch-from-keyrings): New function. - (mc-pgp-fetch-keyring-list): New variable. - Forgot to document most of the changes in the past week, oh well. - (mc-scheme-pgp): New function to replace variable of same name in - preparation for putting PGP support into its own file. - -Thu Jun 8 13:16:50 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-pgp-fetch-finger): New function. - (mc-pgp-fetch-http): New function. - (mc-pgp-fetch-key): New function. - -Thu Jun 1 20:09:21 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-encrypt-generic): Only use Email addresses in - default-recipients. - (mc-pgp-generic-parser): Fix parenthesis error causing non-nil - return on bad passphrase. Fix regular expression for bad - passphrase. - -Thu May 11 19:32:19 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-pgp-display-snarf-output): New variable, - defaults to nil. If t, pop up a window to display the output of - key snarfing. - - * mc-remail.el (mc-nuke-field): Do not clobber markers. (This is - the wrong place to do it anyway.) - (mc-rewrite-for-remailer): Eliminate "Comment" and "From" headers - after encryption. - -Tue May 9 15:58:53 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-modes-alist): Fix typos for mh-folder-mode and - gnus-summary-mode. - (mc-sign-message): Fix parenthesization error in let. - -Mon May 8 22:27:20 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-encrypt-region): New interactive function. - Encrypts the current region by calling the appropriate function as - determined by mc-modes-alist. - (mc-encrypt-generic): New function; bottom level of - scheme-independent encryption routines. - (mc-encrypt-message): Rewritten to call mc-encrypt-generic. - (mc-encrypt): Rewritten to just call mc-encrypt-region. - Upshot of all this is to allow encryption in arbitrary buffers, - not just message buffers. - (mc-sign-region): New interactive function. - (mc-sign-generic): New function; bottom level of - scheme-independent signing routines. - (mc-sign-message): Rewritten to call mc-sign-generic. - (mc-sign): Rewritten to just call mc-sign-region. - Upshot of all this is to allow signing in arbitrary buffers, not - just message buffers. - -Mon May 8 16:02:45 1995 Patrick J. LoPresti - - * mailcrypt.el (mc-always-replace): Add 'never option. - (mc-message): Remove "is-err" argument. - Only deactivate passphrase on "Bad passphrase" error. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/NEWS --- a/lisp/mailcrypt/NEWS Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -Noteworthy changes in Mailcrypt version 3.4: - -Several bug fixes, mostly in the remailer functions. - -`C-c / d' can now decode armor-only messages. - -`C-c / e' with an empty recipient list now generates an armor-only -message. - -Better support for Gnus 5 (formerly "(ding) Gnus"), including -decryption of messages in read-only groups. Requires Gnus 5.0.4 or -higher. - -Better support for recent versions (5.95+) of VM. - -New option for remailer list entries: Positive integer N represents a -random permutation of the N "best" remailers as ordered in -`~/.remailers'. - -New configuration variable `mc-pgp-always-fetch' to control attempts -to fetch PGP keys. Legal values are t, 'never, and nil (the default). - - -Noteworthy changes in Mailcrypt version 3.3: - -Numerous minor bugs have been fixed. - -Mailcrypt now requires at least FSF Emacs version 19.28 or XEmacs -version 19.12. Sorry, but anything else is too annoying. - -Support has been added for reading mail under (ding) Gnus. - - -Noteworthy changes in Mailcrypt version 3.2: - -Mailcrypt now uses "start-process" instead of "call-process-region" to -run PGP; this uses a pipe instead of a temp file for various inputs, -including your passphrase. Ahem. - -All Mailcrypt commands now start with the prefix `C-c /' to bring -Mailcrypt into line with documented GNU standards. - -`mc-insert-public-key' is now bound to `C-c / x' (an in "extract") -instead of `C-c a'. - -`mc-deactivate-passwd' is bound to `C-c / f' (as in "forget"). - -`mc-read-mode' and `mc-write-mode' are now full-blown minor modes. So -you can do, for example, `M-x mc-install-write-mode' from a Text mode -buffer and have the normal encryption and signing commands available. -The keymaps for the modes are configurable variables. - -Interactive commands `mc-encrypt-region', `mc-sign-region', etc. are -now defined. - -If you use RMAIL and you say no to "Replace encrypted message with -decrypted?", you will be dropped into RMAIL mode for viewing. - -RMAIL summary mode is now supported. - -Documentation in the form of a Texinfo file is now part of the -distribution. - -Mailcrypt can now fetch a needed key from finger, HTTP, or any of a -list of locally stored keyrings. `C-c / k' initiates a fetch -manually; Mailcrypt will offer to initiate one automatically as -appropriate during encryption or signature verification. - -The remailer functions now support Mixmaster. - -`C-c / d' can handle conventionally encrypted messages. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/ONEWS --- a/lisp/mailcrypt/ONEWS Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;;{{{ Change Log -;;{{{ Changes from 3.0: -;; * Generate a warning if some public keys are found while others -;; are not during encryption. -;; * Rewrite calls like (message msg) to (message "%s" msg), in case -;; msg includes a "%". -;; * Handle case in mc-pgp-decrypt-region when signature verifies, but -;; key has not been certified. -;; * Put save-excursion around each top-level function. -;; * Handle case in mc-pgp-decrypt-region when signature fails to verify -;; because you don't have the necessary public key. -;; * Locally bind mc-encrypt-for-me to nil before encrypting in -;; mc-remail. -;; * Include "+encrypttoself=off" in PGP command line flags. -;; * Include "+verbose=1" in PGP command line flags (finally). -;; * Hacked mc-rmail-verify-signature to make sure rmailkwd is loaded -;; before message is verified. -;; * (require 'gnus) when compiling. Thanks to Peter Arius -;; -;;}}} -;;{{{ Changes from 2.0: -;; * C-u to mc-encrypt-message now prompts for an ID to use -;; for signing. C-u C-u also prompts for scheme to use. -;; * Signing now uses the From line (pseudonym) to choose key. -;; * Support for multiple secret keys added. Many internal interfaces -;; changed. -;; * autoload remailer support for mc-remail.el and set default keybindings. -;; * mc-pgp-always-sign now has a 'never option. -;; * mc-pgp-encrypt-region returns t on success. -;; * Added mc-vm-snarf-keys, from Joe Reinhardt -;; . -;; * Changed mc-snarf-keys to actually snarf all keys in the buffer instead -;; of just the first one. -;; * In VM, not replacing a message puts the message into its own VM buffer -;; so you can reply to it, forward it, etc. Thanks to Pat Lopresti -;; for the suggestion. -;; * Abort edit mode in VM and RMAIL decrypt functions if no encrypted -;; message was found. -;; * Added version string. -;; * Applied some new patches from stig adding autoloads and minor additions. -;; * Made check for window-system generic, and only for emacs versions > 19. -;; * Added option to mc-sign-message to disable clearsig when signing messages. -;; From Stig . -;; * Fixed extra comma bug when offering default recipients to encrypt for. -;;}}} -;;{{{ Changes from 1.6: -;; * Decrypting a signed message in RMAIL adds a verified tag to the message. -;; * mc-sign-message takes an optional argument specifying which key to use, -;; for people who have multiple private keys. -;; * Added mc-{pre,post}-{de,en}cryption-hooks. -;; * Additions to docstrings of the major functions and `mailcrypt-*' aliases -;; for the same. -;; * Added cleanup for possible temp files left over if a process was -;; interrupted. -;; * Easier installation instructions. -;; * Lots of little bug fixes from all over. Too many to list -;; individual credits, but I've tried to include all of them. Thanks -;; to all who sent them in, especially to John T Kohl who fixed an -;; especially trying problem. -;; * Another optional argument to mc-insert-public-key that allows the -;; user to specify which public key to insert when called with a -;; prefix argument. -;; * Tons of changes from Paul Furnanz : -;; 1) Use the itimer package instead of the timer package if it exists. -;; This makes the password deactivation code work for Lemacs as well -;; as emacs 19. -;; 2) Fractured the code, so that there is a single function to use -;; when calling the encryption program. The new function is -;; mc-process-region. The function copies all data to a temporary -;; buffer, and does the work there. This way if you do an undo after -;; an encryption or signing, your password is not visible on the -;; screen. -;; 3) All process output goes to the *MailCrypt* buffer. No longer use -;; a separate buffer for decryption, encryption, verification, ... -;; This allows the user to always look at the *MailCrypt* buffer to -;; see what pgp or ripem said. -;; 4) No longer call mc-temp-display. Use display-buffer if there is a -;; reason to show the buffer (like an error occured). -;; 5) Try to print more useful messages. -;; 6) If an error occurs on encryption, the message is left unchanged. -;; No reason to undo. -;;}}} -;;{{{ Changes from 1.5: -;; * Changed mc-temp-display to just dump into a temp buffer, without -;; any fancy display stuff. Pick up show-temp.el if you liked the -;; display stuff (or uncomment the old mc-temp-buffer and remove the -;; new version). -;; * Provided a generic read mode function to call in hooks, like the -;; generic write mode function that was already there. -;; * Fixed bug in regexp that prevented compilation under recent -;; versions of FSF emacs. -;; * Narrow to headers when extracting default recipients for encryption -;; to avoid pulling in recipients of included messages. -;; * Use `fillarray' to overwrite passwords with nulls before deactivation -;; for increased security. -;; * Load mail-extr.el to get mail-extract-address-components defined. -;; Thanks to Kevin Rodgers for the following -;; improvements. -;; * Quoted an unquoted lambda expression that prevented optimized -;; compilation under emacs 18. -;; * Used `nconc' instead of `append' in various places to save on -;; garbage collection. -;; * Modified mc-split to run more efficiently. -;;}}} -;;{{{ Changes from 1.4: -;; * Call mail-extract-address-components on the recipients if we guessed -;; them from the header fields. -;; * If you don't replace a message with its decrypted version, it will now -;; pop you into a view buffer with the contents of the message. -;; * Added support for mh-e, contributed by Fritz Knabe -;; * Fixed bug in snarfing keys from menubar under GNUS. -;; * Fixed RIPEM verification problem, thanks to Sergey Gleizer -;; . -;;}}} -;;{{{ Changes from 1.3: -;; * Temp display function does not barf on F-keys or mouse events. -;; Thanks to Jonathan Stigelman -;; * Lucid emacs menu support provided by William Perry -;; * Cited signed messages would interfere with signature -;; verification; fixed. -;;}}} -;;{{{ Changes from 1.2: -;; * Added menu bar support for emacs 19. -;; * Added GNUS support thanks to Samuel Druker . -;;}}} -;;{{{ Changes from 1.1: -;; * Added recipients field to mc-encrypt-message. -;;}}} -;;{{{ Changes from 1.0: -;; * Fixed batchmode bug in decryption, where unsigned messages would return -;; with exit code of 1. -;;}}} -;;{{{ Changes from 0.3b: -;; * Only set PGPPASSFD when needed, so PGP won't break when used -;; in shell mode. -;; * Use call-process-region instead of shell-command-on-region in order -;; to detect exit codes. -;; * Changed mc-temp-display to not use the kill ring. -;; * Bug fixes. -;;}}} -;;{{{ Changes from 0.2b: -;; * Prompts for replacement in mc-rmail-decrypt-message. -;; * Bug fixes. -;;}}} -;;{{{ Changes from 0.1b: -;; * Several bug fixes. -;; Contributed by Jason Merrill : -;; * VM mailreader support -;; * Support for addresses with spaces and <>'s in them -;; * Support for using an explicit path for the pgp executable -;; * Key management functions -;; * The ability to avoid some of the prompts when encrypting -;; * Assumes mc-default-scheme unless prefixed -;;}}} - -;;}}} diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/README --- a/lisp/mailcrypt/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -Mailcrypt is an Emacs lisp package which provides a simple interface -to cryptographic functions with PGP. It was written by Patrick -LoPresti (patl@lcs.mit.edu) and Jin Choi (jin@atype.com). - -The latest version of Mailcrypt is always (?) available through the -Mailcrypt home page at `http://cag-www.lcs.mit.edu/mailcrypt/'. An -FTP mirror is at `ftp://cag.lcs.mit.edu/pub/patl/'. - -To install the Mailcrypt package on your system, follow the directions -in the file `INSTALL'. - -To hook Mailcrypt into your mail and news browsers, follow the -directions in the "Installation" section of the Mailcrypt manual. If -you don't know how to use the Emacs Info browser, you should learn; -type `C-h i' and poke around. You can read the Info version of the -Mailcrypt manual by doing `C-u C-h i' on the file `mailcrypt.info'. - -Or read the HTML version of the manual which is directly accessible -from the Mailcrypt home page. - -To automatically be informed of improvements to Mailcrypt, add -yourself to the (very low volume) Mailcrypt announcement list. Send -Email to mc-announce-request@cag.lcs.mit.edu with a request to be -added. - -Send all bug reports and comments to the authors. And most of all, -enjoy! - - - Patrick LoPresti (patl@lcs.mit.edu) and Jin Choi (jin@atype.com) - Thu Jun 22 19:58:35 1995 diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/auto-autoloads.el --- a/lisp/mailcrypt/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,157 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'mailcrypt-autoloads) (error "Already loaded")) - -;;;### (autoloads (mc-deactivate-passwd mc-install-write-mode mc-install-read-mode) "mailcrypt" "mailcrypt/mailcrypt.el") - -(autoload 'mc-install-read-mode "mailcrypt" nil t nil) - -(autoload 'mc-install-write-mode "mailcrypt" nil t nil) - -(autoload 'mc-deactivate-passwd "mailcrypt" "\ -*Deactivate the passphrase cache." t nil) - -;;;*** - -;;;### (autoloads (mc-pgp-fetch-key mc-scheme-pgp) "mc-pgp" "mailcrypt/mc-pgp.el") - -(autoload 'mc-scheme-pgp "mc-pgp" nil nil nil) - -(autoload 'mc-pgp-fetch-key "mc-pgp" "\ -Attempt to fetch a key for addition to PGP keyring. Interactively, -prompt for string matching key to fetch. - -Non-interactively, ID must be a pair. The CAR must be a bare Email -address and the CDR a keyID (with \"0x\" prefix). Either, but not -both, may be nil. - -Return t if we think we were successful; nil otherwise. Note that nil -is not necessarily an error, since we may have merely fired off an Email -request for the key." t nil) - -;;;*** - -;;;### (autoloads (mc-remailer-insert-response-block mc-remailer-encrypt-for-chain mc-remailer-insert-pseudonym) "mc-remail" "mailcrypt/mc-remail.el") - -(autoload 'mc-remailer-insert-pseudonym "mc-remail" "\ -Insert pseudonym as a From field in the hash-mark header. - -See the documentation for the variable `mc-remailer-pseudonyms' for -more information." t nil) - -(autoload 'mc-remailer-encrypt-for-chain "mc-remail" "\ -Encrypt message for a remailer chain, prompting for chain to use. - -With \\[universal-argument], pause before each encryption." t nil) - -(autoload 'mc-remailer-insert-response-block "mc-remail" "\ -Insert response block at point, prompting for chain to use. - -With \\[universal-argument], enter a recursive edit of the innermost -layer of the block before encrypting it." t nil) - -;;;*** - -;;;### (autoloads (mc-mh-snarf-keys mc-mh-verify-signature mc-mh-decrypt-message mc-gnus-decrypt-message mc-gnus-snarf-keys mc-gnus-verify-signature mc-vm-snarf-keys mc-vm-decrypt-message mc-vm-verify-signature mc-rmail-decrypt-message mc-rmail-verify-signature mc-rmail-summary-snarf-keys mc-rmail-summary-decrypt-message mc-rmail-summary-verify-signature mc-snarf-keys mc-snarf mc-insert-public-key mc-verify-signature mc-verify mc-sign-message mc-sign mc-decrypt-message mc-decrypt mc-encrypt-message mc-encrypt mc-cleanup-recipient-headers) "mc-toplev" "mailcrypt/mc-toplev.el") - -(autoload 'mc-cleanup-recipient-headers "mc-toplev" nil nil nil) - -(autoload 'mc-encrypt "mc-toplev" "\ -*Encrypt the current buffer. - -Exact behavior depends on current major mode. - -With \\[universal-argument], prompt for User ID to sign as. - -With \\[universal-argument] \\[universal-argument], prompt for encryption scheme to use." t nil) - -(autoload 'mc-encrypt-message "mc-toplev" "\ -*Encrypt a message for RECIPIENTS using the given encryption SCHEME. -RECIPIENTS is a comma separated string. If SCHEME is nil, use the value -of `mc-default-scheme'. Returns t on success, nil otherwise." nil nil) - -(autoload 'mc-decrypt "mc-toplev" "\ -*Decrypt a message in the current buffer. - -Exact behavior depends on current major mode." t nil) - -(autoload 'mc-decrypt-message "mc-toplev" "\ -Decrypt whatever message is in the current buffer. -Returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if the encryption -succeeded and VERIFIED is t if it had a valid signature." nil nil) - -(autoload 'mc-sign "mc-toplev" "\ -*Sign a message in the current buffer. - -Exact behavior depends on current major mode. - -With one prefix arg, prompts for private key to use, with two prefix args, -also prompts for encryption scheme to use. With negative prefix arg, -inhibits clearsigning (pgp)." t nil) - -(autoload 'mc-sign-message "mc-toplev" "\ -Clear sign the message." nil nil) - -(autoload 'mc-verify "mc-toplev" "\ -*Verify a message in the current buffer. - -Exact behavior depends on current major mode." t nil) - -(autoload 'mc-verify-signature "mc-toplev" "\ -*Verify the signature of the signed message in the current buffer. -Show the result as a message in the minibuffer. Returns t if the signature -is verified." nil nil) - -(autoload 'mc-insert-public-key "mc-toplev" "\ -*Insert your public key at point. -With one prefix arg, prompts for user id to use. With two prefix -args, prompts for encryption scheme." t nil) - -(autoload 'mc-snarf "mc-toplev" "\ -*Add all public keys in the buffer to your keyring. - -Exact behavior depends on current major mode." t nil) - -(autoload 'mc-snarf-keys "mc-toplev" "\ -*Add all public keys in the buffer to your keyring." t nil) - -(autoload 'mc-rmail-summary-verify-signature "mc-toplev" "\ -*Verify the signature in the current message." t nil) - -(autoload 'mc-rmail-summary-decrypt-message "mc-toplev" "\ -*Decrypt the contents of this message" t nil) - -(autoload 'mc-rmail-summary-snarf-keys "mc-toplev" "\ -*Adds keys from current message to public key ring" t nil) - -(autoload 'mc-rmail-verify-signature "mc-toplev" "\ -*Verify the signature in the current message." t nil) - -(autoload 'mc-rmail-decrypt-message "mc-toplev" "\ -*Decrypt the contents of this message" t nil) - -(autoload 'mc-vm-verify-signature "mc-toplev" "\ -*Verify the signature in the current VM message" t nil) - -(autoload 'mc-vm-decrypt-message "mc-toplev" "\ -*Decrypt the contents of the current VM message" t nil) - -(autoload 'mc-vm-snarf-keys "mc-toplev" "\ -*Snarf public key from the contents of the current VM message" t nil) - -(autoload 'mc-gnus-verify-signature "mc-toplev" nil t nil) - -(autoload 'mc-gnus-snarf-keys "mc-toplev" nil t nil) - -(autoload 'mc-gnus-decrypt-message "mc-toplev" nil t nil) - -(autoload 'mc-mh-decrypt-message "mc-toplev" "\ -Decrypt the contents of the current MH message in the show buffer." t nil) - -(autoload 'mc-mh-verify-signature "mc-toplev" "\ -*Verify the signature in the current MH message." t nil) - -(autoload 'mc-mh-snarf-keys "mc-toplev" nil t nil) - -;;;*** - -(provide 'mailcrypt-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/mailcrypt.el --- a/lisp/mailcrypt/mailcrypt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,537 +0,0 @@ -;; mailcrypt.el v3.4, mail encryption with PGP -;; Copyright (C) 1995 Jin Choi -;; Patrick LoPresti -;; Any comments or suggestions welcome. -;; Inspired by pgp.el, by Gray Watson . - -;;{{{ Licensing -;; This file is intended to be used with GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;}}} - -;;{{{ Load some required packages - -(eval-when-compile - ;; Quiet warnings - (autoload 'start-itimer "itimer") - (autoload 'cancel-itimer "itimer") - (autoload 'delete-itimer "itimer")) - -(require 'easymenu) -(require 'comint) - -(eval-and-compile - (condition-case nil (require 'itimer) (error nil)) - (if (not (featurep 'itimer)) - (condition-case nil (require 'timer) (error nil))) - - (if (not (fboundp 'buffer-substring-no-properties)) - (fset 'buffer-substring-no-properties 'buffer-substring))) - -(defconst mc-xemacs-p (string-match "XEmacs" emacs-version)) - -(if (not mc-xemacs-p) - (progn - (autoload 'mc-decrypt "mc-toplev" nil t) - (autoload 'mc-verify "mc-toplev" nil t) - (autoload 'mc-snarf "mc-toplev" nil t) - (autoload 'mc-pgp-fetch-key "mc-pgp" nil t) - (autoload 'mc-encrypt "mc-toplev" nil t) - (autoload 'mc-sign "mc-toplev" nil t) - (autoload 'mc-insert-public-key "mc-toplev" nil t) - (autoload 'mc-remailer-encrypt-for-chain "mc-remail" nil t) - (autoload 'mc-remailer-insert-response-block "mc-remail" nil t) - (autoload 'mc-remailer-insert-pseudonym "mc-remail" nil t))) - -;;}}} - -;;{{{ Minor mode variables and functions - -(defvar mc-read-mode nil - "Non-nil means Mailcrypt read mode key bindings are available.") - -(defvar mc-write-mode nil - "Non-nil means Mailcrypt write mode key bindings are available.") - -(make-variable-buffer-local 'mc-read-mode) -(make-variable-buffer-local 'mc-write-mode) - -(defvar mc-read-mode-string " MC-r" - "*String to put in mode line when Mailcrypt read mode is active.") - -(defvar mc-write-mode-string " MC-w" - "*String to put in mode line when Mailcrypt write mode is active.") - -(defvar mc-read-mode-map nil - "Keymap for Mailcrypt read mode bindings.") - -(defvar mc-write-mode-map nil - "Keymap for Mailcrypt write mode bindings.") - -(or mc-read-mode-map - (progn - (setq mc-read-mode-map (make-sparse-keymap)) - (define-key mc-read-mode-map "\C-c/f" 'mc-deactivate-passwd) - (define-key mc-read-mode-map "\C-c/d" 'mc-decrypt) - (define-key mc-read-mode-map "\C-c/v" 'mc-verify) - (define-key mc-read-mode-map "\C-c/a" 'mc-snarf) - (define-key mc-read-mode-map "\C-c/k" 'mc-pgp-fetch-key))) - -(or mc-write-mode-map - (progn - (setq mc-write-mode-map (make-sparse-keymap)) - (define-key mc-write-mode-map "\C-c/f" 'mc-deactivate-passwd) - (define-key mc-write-mode-map "\C-c/e" 'mc-encrypt) - (define-key mc-write-mode-map "\C-c/s" 'mc-sign) - (define-key mc-write-mode-map "\C-c/x" 'mc-insert-public-key) - (define-key mc-write-mode-map "\C-c/k" 'mc-pgp-fetch-key) - (define-key mc-write-mode-map "\C-c/r" - 'mc-remailer-encrypt-for-chain) - (define-key mc-write-mode-map "\C-c/b" - 'mc-remailer-insert-response-block) - (define-key mc-write-mode-map "\C-c/p" - 'mc-remailer-insert-pseudonym))) - -(easy-menu-define - mc-read-mode-menu (if mc-xemacs-p nil (list mc-read-mode-map)) - "Mailcrypt read mode menu." - '("Mailcrypt" - ["Decrypt Message" mc-decrypt t] - ["Verify Signature" mc-verify t] - ["Snarf Keys" mc-snarf t] - ["Fetch Key" mc-pgp-fetch-key t] - ["Forget Passphrase(s)" mc-deactivate-passwd t])) - -(easy-menu-define - mc-write-mode-menu (if mc-xemacs-p nil (list mc-write-mode-map)) - "Mailcrypt write mode menu." - '("Mailcrypt" - ["Encrypt Message" mc-encrypt t] - ["Sign Message" mc-sign t] - ["Insert Public Key" mc-insert-public-key t] - ["Fetch Key" mc-pgp-fetch-key t] - ["Encrypt for Remailer(s)" mc-remailer-encrypt-for-chain t] - ["Insert Pseudonym" mc-remailer-insert-pseudonym t] - ["Insert Response Block" mc-remailer-insert-response-block t] - ["Forget Passphrase(s)" mc-deactivate-passwd t])) - -(or (assq 'mc-read-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'mc-read-mode mc-read-mode-map) - minor-mode-map-alist))) - -(or (assq 'mc-write-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'mc-write-mode mc-write-mode-map) - minor-mode-map-alist))) - -(or (assq 'mc-read-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(mc-read-mode mc-read-mode-string) minor-mode-alist))) - -(or (assq 'mc-write-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(mc-write-mode mc-write-mode-string) minor-mode-alist))) - -(defun mc-read-mode (&optional arg) - "\nMinor mode for interfacing with cryptographic functions. -\\ -\\[mc-decrypt]\t\tDecrypt an encrypted message -\\[mc-verify]\t\tVerify signature on a clearsigned message -\\[mc-snarf]\t\tAdd public key(s) to keyring -\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP -\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n" - (interactive) - (setq mc-read-mode - (if (null arg) (not mc-read-mode) - (> (prefix-numeric-value arg) 0))) - (and mc-read-mode mc-write-mode (mc-write-mode nil)) - (if mc-read-mode - (easy-menu-add mc-read-mode-menu) - (easy-menu-remove mc-read-mode-menu))) - -(defun mc-write-mode (&optional arg) - "\nMinor mode for interfacing with cryptographic functions. -\\ -\\[mc-encrypt]\t\tEncrypt (and optionally sign) message -\\[mc-sign]\t\tClearsign message -\\[mc-insert-public-key]\t\tExtract public key from keyring and insert into message -\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP -\\[mc-remailer-encrypt-for-chain]\t\tEncrypt message for remailing -\\[mc-remailer-insert-pseudonym]\t\tInsert a pseudonym (for remailing) -\\[mc-remailer-insert-response-block]\t\tInsert a response block (for remailing) -\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n" - (interactive) - (setq mc-write-mode - (if (null arg) (not mc-write-mode) - (> (prefix-numeric-value arg) 0))) - (and mc-write-mode mc-read-mode (mc-read-mode nil)) - (if mc-write-mode - (easy-menu-add mc-write-mode-menu) - (easy-menu-remove mc-write-mode-menu))) - -;;;###autoload -(defun mc-install-read-mode () - (interactive) - (mc-read-mode 1)) - -;;;###autoload -(defun mc-install-write-mode () - (interactive) - (mc-write-mode 1)) - -;;}}} - -;;{{{ Note: -;; The funny triple braces you see are used by `folding-mode', a minor -;; mode by Jamie Lokier, available from the elisp archive. -;;}}} - -;;{{{ User variables. -(defconst mc-version "3.4") -(defvar mc-default-scheme 'mc-scheme-pgp "*Default encryption scheme to use.") -(defvar mc-passwd-timeout 60 - "*Time to deactivate password in seconds after a use. -nil or 0 means deactivate immediately. If the only timer package available -is the 'timer' package, then this can be a string in timer format.") - -(defvar mc-ripem-user-id (or (getenv "RIPEM_USER_NAME") - (user-full-name) "*Your RIPEM user ID.")) - -(defvar mc-always-replace nil - "*If t, decrypt mail messages in place without prompting. - -If 'never, always use a viewer instead of replacing.") - -(defvar mc-use-default-recipients nil "*Assume that the message should - be encoded for everyone listed in the To, Cc, and Bcc fields.") - -(defvar mc-encrypt-for-me nil "*Encrypt all outgoing messages with - user's public key.") - -(defvar mc-pre-signature-hook nil - "*List of hook functions to run immediately before signing.") -(defvar mc-post-signature-hook nil - "*List of hook functions to run immediately after signing.") -(defvar mc-pre-encryption-hook nil - "*List of hook functions to run immediately before encrypting.") -(defvar mc-post-encryption-hook nil - "*List of hook functions to run after encrypting.") -(defvar mc-pre-decryption-hook nil - "*List of hook functions to run immediately before decrypting.") -(defvar mc-post-decryption-hook nil - "*List of hook functions to run after decrypting.") - -(defconst mc-buffer-name "*MailCrypt*" - "Name of temporary buffer for mailcrypt") - -(defvar mc-modes-alist - '((rmail-mode (decrypt . mc-rmail-decrypt-message) - (verify . mc-rmail-verify-signature)) - (rmail-summary-mode (decrypt . mc-rmail-summary-decrypt-message) - (verify . mc-rmail-summary-verify-signature) - (snarf . mc-rmail-summary-snarf-keys)) - (vm-mode (decrypt . mc-vm-decrypt-message) - (verify . mc-vm-verify-signature) - (snarf . mc-vm-snarf-keys)) - (vm-virtual-mode (decrypt . mc-vm-decrypt-message) - (verify . mc-vm-verify-signature) - (snarf . mc-vm-snarf-keys)) - (vm-summary-mode (decrypt . mc-vm-decrypt-message) - (verify . mc-vm-verify-signature) - (snarf . mc-vm-snarf-keys)) - (mh-folder-mode (decrypt . mc-mh-decrypt-message) - (verify . mc-mh-verify-signature) - (snarf . mc-mh-snarf-keys)) - ;; September Gnus (5.2) has a new message editing mode - (message-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (gnus-summary-mode (decrypt . mc-gnus-decrypt-message) - (verify . mc-gnus-verify-signature) - (snarf . mc-gnus-snarf-keys)) - (gnus-article-mode (decrypt . mc-gnus-decrypt-message) - (verify . mc-gnus-verify-signature) - (snarf . mc-gnus-snarf-keys)) - (mail-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (vm-mail-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (mh-letter-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (news-reply-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message))) - - "Association list (indexed by major mode) of association lists -(indexed by operation) of functions to call for each major mode.") - -;;}}} -;;{{{ Program variables and constants. - -(defvar mc-timer nil "Timer object for password deactivation.") - -(defvar mc-passwd-cache nil "Cache for passphrases.") - -(defvar mc-schemes '(("pgp" . mc-scheme-pgp))) - -;;}}} - -;;{{{ Utility functions. - -(defun mc-message-delimiter-positions (start-re end-re &optional begin) - ;; Returns pair of integers (START . END) that delimit message marked off - ;; by the regular expressions start-re and end-re. Optional argument BEGIN - ;; determines where we should start looking from. - (setq begin (or begin (point-min))) - (let (start) - (save-excursion - (goto-char begin) - (and (re-search-forward start-re nil t) - (setq start (match-beginning 0)) - (re-search-forward end-re nil t) - (cons start (point)))))) - - -(defun mc-split (regexp str) - "Splits STR into a list of elements which were separated by REGEXP, -stripping initial and trailing whitespace." - (let ((data (match-data)) - (retval '()) - beg end) - (unwind-protect - (progn - (string-match "[ \t\n]*" str) ; Will always match at 0 - (setq beg (match-end 0)) - (setq end (string-match "[ \t\n]*\\'" str)) - (while (string-match regexp str beg) - (setq retval - (cons (substring str beg (match-beginning 0)) - retval)) - (setq beg (match-end 0))) - (if (not (= (length str) beg)) ; Not end - (setq retval (cons (substring str beg end) retval))) - (nreverse retval)) - (store-match-data data)))) - -;;; FIXME - Function never called? -;(defun mc-temp-display (beg end &optional name) -; (let (tmp) -; (if (not name) -; (setq name mc-buffer-name)) -; (if (string-match name "*ERROR*") -; (progn -; (message "mailcrypt: An error occured! See *ERROR* buffer.") -; (beep))) -; (setq tmp (buffer-substring beg end)) -; (delete-region beg end) -; (save-excursion -; (save-window-excursion -; (with-output-to-temp-buffer name -; (princ tmp)))))) - -;; In case I ever decide to do this right. -(defconst mc-field-name-regexp "^\\(.+\\)") -(defconst mc-field-body-regexp "\\(.*\\(\n[ \t].*\\)*\n\\)") - -(defun mc-get-fields (&optional matching bounds nuke) - "Get all header fields within BOUNDS. Return as an -alist ((FIELD-NAME . FIELD-BODY) (FIELD-NAME . FIELD-BODY) ...). - -Argument MATCHING, if present, is a regexp which each FIELD-NAME -must match exactly. Matching is case-insensitive. - -Optional arg NUKE, if non-nil, means eliminate all fields returned." - (save-excursion - (save-restriction - (let ((case-fold-search t) - (header-field-regexp - (concat mc-field-name-regexp ":" mc-field-body-regexp)) - ret name body field-start field-end) - ;; Ensure exact match - (if matching - (setq matching (concat "^\\(" matching "\\)$"))) - - (if bounds - (narrow-to-region (car bounds) (cdr bounds))) - - (goto-char (point-max)) - - (while (re-search-backward header-field-regexp nil 'move) - (setq field-start (match-beginning 0)) - (setq field-end (match-end 0)) - (setq name (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (setq body (buffer-substring-no-properties - (match-beginning 2) (match-end 2))) - (if (or (null matching) (string-match matching name)) - (progn - (setq ret (cons (cons name body) ret)) - (if nuke - (delete-region field-start field-end))))) - ret)))) - -(defsubst mc-strip-address (addr) - "Strip everything from ADDR except the basic Email address." - (car (cdr (mail-extract-address-components addr)))) - -(defun mc-strip-addresses (addr-list) - "Strip everything from the addresses in ADDR-LIST except the basic -Email address. ADDR-LIST may be a single string or a list of strings." - (if (not (listp addr-list)) (setq addr-list (list addr-list))) - (setq addr-list - (mapcar - (function (lambda (s) (mc-split "\\([ \t\n]*,[ \t\n]*\\)" s))) - addr-list)) - (setq addr-list (apply 'append addr-list)) - (mapconcat 'mc-strip-address addr-list ", ")) - -(defun mc-display-buffer (buffer) - "Like display-buffer, but always display top of the buffer." - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (display-buffer buffer))) - -(defun mc-message (msg &optional buffer default) - ;; returns t if we used msg, nil if we used default - (let ((retval t)) - (if buffer - (setq msg - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward msg nil t) - (buffer-substring-no-properties - (match-beginning 0) (match-end 0)) - (setq retval nil) - default)))) - (if msg (message "%s" msg)) - retval)) - -(defun mc-process-region (beg end passwd program args parser &optional buffer) - (let ((obuf (current-buffer)) - (process-connection-type nil) - mybuf result rgn proc) - (unwind-protect - (progn - (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp"))) - (set-buffer mybuf) - (erase-buffer) - (set-buffer obuf) - (buffer-disable-undo mybuf) - (setq proc - (apply 'start-process "*PGP*" mybuf program args)) - (if passwd - (progn - (process-send-string proc (concat passwd "\n")) - (or mc-passwd-timeout (mc-deactivate-passwd t)))) - (process-send-region proc beg end) - (process-send-eof proc) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - (setq result (process-exit-status proc)) - ;; Hack to force a status_notify() in Emacs 19.29 - (delete-process proc) - (set-buffer mybuf) - (goto-char (point-max)) - (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - ;; CRNL -> NL - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - ;; Hurm. FIXME; must get better result codes. - (if (stringp result) - (error "%s exited abnormally: '%s'" program result) - (setq rgn (funcall parser result)) - ;; If the parser found something, migrate it - (if (consp rgn) - (progn - (set-buffer obuf) - (delete-region beg end) - (goto-char beg) - (insert-buffer-substring mybuf (car rgn) (cdr rgn)) - (set-buffer mybuf) - (delete-region (car rgn) (cdr rgn))))) - ;; Return nil on failure and exit code on success - (if rgn result)) - ;; Cleanup even on nonlocal exit - (if (and proc (eq 'run (process-status proc))) - (interrupt-process proc)) - (set-buffer obuf) - (or buffer (null mybuf) (kill-buffer mybuf))))) - -;;}}} - -;;{{{ Passphrase management -(defun mc-activate-passwd (id &optional prompt) - "Activate the passphrase matching ID, using PROMPT for a prompt. -Return the passphrase. If PROMPT is nil, only return value if cached." - (cond ((featurep 'itimer) - (if mc-timer (delete-itimer mc-timer)) - (setq mc-timer (if mc-passwd-timeout - (start-itimer "mc-itimer" - 'mc-deactivate-passwd - mc-passwd-timeout) - nil))) - ((featurep 'timer) - (let ((string-time (if (integerp mc-passwd-timeout) - (format "%d sec" mc-passwd-timeout) - mc-passwd-timeout))) - (if mc-timer (cancel-timer mc-timer)) - (setq mc-timer (if string-time - (run-at-time string-time - nil 'mc-deactivate-passwd) - nil))))) - (let ((cell (assoc id mc-passwd-cache)) - passwd) - (setq passwd (cdr-safe cell)) - (if (and (not passwd) prompt) - (setq passwd (comint-read-noecho prompt))) - (if cell - (setcdr cell passwd) - (setq mc-passwd-cache (cons (cons id passwd) mc-passwd-cache))) - passwd)) - -;;;###autoload -(defun mc-deactivate-passwd (&optional inhibit-message) - "*Deactivate the passphrase cache." - (interactive) - (if mc-timer - (cond ((featurep 'itimer) (delete-itimer mc-timer)) - ((featurep 'timer) (cancel-timer mc-timer)))) - (mapcar - (function - (lambda (cell) - (if (stringp (cdr-safe cell)) (fillarray (cdr cell) 0)) - (setcdr cell nil))) - mc-passwd-cache) - (or inhibit-message - (not (interactive-p)) - (message "Passphrase%s deactivated" - (if (> (length mc-passwd-cache) 1) "s" "")))) - -;;}}} - -;;{{{ Define several aliases so that an apropos on `mailcrypt' will -;; return something. -(defalias 'mailcrypt-encrypt 'mc-encrypt) -(defalias 'mailcrypt-decrypt 'mc-decrypt) -(defalias 'mailcrypt-sign 'mc-sign) -(defalias 'mailcrypt-verify 'mc-verify) -(defalias 'mailcrypt-insert-public-key 'mc-insert-public-key) -(defalias 'mailcrypt-snarf 'mc-snarf) -;;}}} -(provide 'mailcrypt) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/mc-pgp.el --- a/lisp/mailcrypt/mc-pgp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,620 +0,0 @@ -;; mc-pgp.el, PGP support for Mailcrypt -;; Copyright (C) 1995 Jin Choi -;; Patrick LoPresti - -;;{{{ Licensing -;; This file is intended to be used with GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;}}} -(require 'mailcrypt) - -(defvar mc-pgp-user-id (user-login-name) - "*PGP ID of your default identity.") -(defvar mc-pgp-always-sign nil - "*If t, always sign encrypted PGP messages, or never sign if 'never.") -(defvar mc-pgp-path "pgp" "*The PGP executable.") -(defvar mc-pgp-display-snarf-output nil - "*If t, pop up the PGP output window when snarfing keys.") -(defvar mc-pgp-alternate-keyring nil - "*Public keyring to use instead of default.") -(defvar mc-pgp-comment - (format "Processed by Mailcrypt %s, an Emacs/PGP interface" mc-version) - "*Comment field to appear in ASCII armor output. If nil, let PGP -use its default.") - -(defconst mc-pgp-msg-begin-line "-----BEGIN PGP MESSAGE-----" - "Text for start of PGP message delimiter.") -(defconst mc-pgp-msg-end-line "-----END PGP MESSAGE-----\n?" - "Text for end of PGP message delimiter.") -(defconst mc-pgp-signed-begin-line "-----BEGIN PGP SIGNED MESSAGE-----" - "Text for start of PGP signed messages.") -(defconst mc-pgp-signed-end-line "-----END PGP SIGNATURE-----" - "Text for end of PGP signed messages.") -(defconst mc-pgp-key-begin-line "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" - "Text for start of PGP public key.") -(defconst mc-pgp-key-end-line "^-----END PGP PUBLIC KEY BLOCK-----\r?$" - "Text for end of PGP public key.") -(defconst mc-pgp-error-re "^\\(ERROR:\\|WARNING:\\).*" - "Regular expression matching an error from PGP") -(defconst mc-pgp-sigok-re "^.*Good signature.*" - "Regular expression matching a PGP signature validation message") -(defconst mc-pgp-newkey-re "^[ \t]*\\(No\\|[0-9]+\\) +new [ku].*" - "Regular expression matching a PGP key snarf message") -(defconst mc-pgp-nokey-re - "Cannot find the public key matching userid '\\(.+\\)'$" - "Regular expression matching a PGP missing-key message") -(defconst mc-pgp-key-expected-re - "Key matching expected Key ID \\(\\S +\\) not found") - -(defvar mc-pgp-keydir nil - "Directory in which keyrings are stored.") - -(defun mc-get-pgp-keydir () - (if (null mc-pgp-keydir) - (let ((buffer (generate-new-buffer " *mailcrypt temp*")) - (obuf (current-buffer))) - (unwind-protect - (progn - (call-process mc-pgp-path nil buffer nil "+verbose=1" - "+language=en" "-kv" "XXXXXXXXXX") - (set-buffer buffer) - (goto-char (point-min)) - (re-search-forward "^Key ring:\\s *'\\(.*\\)'") - (setq mc-pgp-keydir - (file-name-directory - (buffer-substring-no-properties - (match-beginning 1) (match-end 1))))) - (set-buffer obuf) - (kill-buffer buffer)))) - mc-pgp-keydir) - -(defvar mc-pgp-key-cache nil - "Association list mapping PGP IDs to canonical \"keys\". A \"key\" -is a pair (USER-ID . KEY-ID) which identifies the canonical IDs of the -PGP ID.") - -(defun mc-pgp-lookup-key (str) - ;; Look up the string STR in the user's secret key ring. Return a - ;; pair of strings (USER-ID . KEY-ID) which uniquely identifies the - ;; matching key, or nil if no key matches. - (if (equal str "***** CONVENTIONAL *****") nil - (let ((keyring (concat (mc-get-pgp-keydir) "secring")) - (result (cdr-safe (assoc str mc-pgp-key-cache))) - (key-regexp - "^\\(pub\\|sec\\)\\s +[^/]+/\\(\\S *\\)\\s +\\S +\\s +\\(.*\\)$") - (obuf (current-buffer)) - buffer) - (if (null result) - (unwind-protect - (progn - (setq buffer (generate-new-buffer " *mailcrypt temp")) - (call-process mc-pgp-path nil buffer nil - "+language=en" "-kv" str keyring) - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward key-regexp nil t) - (progn - (setq result - (cons (buffer-substring-no-properties - (match-beginning 3) (match-end 3)) - (concat - "0x" - (buffer-substring-no-properties - (match-beginning 2) (match-end 2))))) - (setq mc-pgp-key-cache (cons (cons str result) - mc-pgp-key-cache))))) - (if buffer (kill-buffer buffer)) - (set-buffer obuf))) - (if (null result) - (error "No PGP secret key for %s" str)) - result))) - -(defun mc-pgp-generic-parser (result) - (let (start) - (goto-char (point-min)) - (cond ((not (eq result 0)) - (prog1 - nil - (if (mc-message "^\aError: +Bad pass phrase\\.$" (current-buffer)) - (mc-deactivate-passwd t) - (mc-message mc-pgp-error-re (current-buffer) - (format "PGP exited with status %d" result))))) - ((re-search-forward mc-pgp-nokey-re nil t) - nil) - (t - (and - (goto-char (point-min)) - (re-search-forward "-----BEGIN PGP.*-----$" nil t) - (setq start (match-beginning 0)) - (goto-char (point-max)) - (re-search-backward "^-----END PGP.*-----\n" nil t) - (cons start (match-end 0))))))) - -(defun mc-pgp-encrypt-region (recipients start end &optional id sign) - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - ;; Crock. Rewrite someday. - (mc-pgp-always-sign mc-pgp-always-sign) - (obuf (current-buffer)) - action msg args key passwd result pgp-id) - (setq args (list "+encrypttoself=off +verbose=1" "+batchmode" - "+language=en" "-fat")) - (setq action (if recipients "Encrypting" "Armoring")) - (setq msg (format "%s..." action)) ; May get overridden below - (if recipients (setq args (cons "-e" args))) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args))) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (if (and (not (eq mc-pgp-always-sign 'never)) - (or mc-pgp-always-sign sign (y-or-n-p "Sign the message? "))) - (progn - (setq mc-pgp-always-sign t) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq passwd - (mc-activate-passwd - (cdr key) - (format "PGP passphrase for %s (%s): " (car key) (cdr key)))) - (setq args - (nconc args (list "-s" "-u" (cdr key)))) - (setenv "PGPPASSFD" "0") - (setq msg (format "%s+signing as %s ..." action (car key)))) - (setq mc-pgp-always-sign 'never)) - - (or key - (setq key (mc-pgp-lookup-key mc-pgp-user-id))) - - (if (and recipients mc-encrypt-for-me) - (setq recipients (cons (cdr key) recipients))) - - (setq args (append args recipients)) - - (message "%s" msg) - (setq result (mc-process-region start end passwd mc-pgp-path args - 'mc-pgp-generic-parser buffer)) - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward mc-pgp-nokey-re nil t) - (progn - (if result (error "This should never happen.")) - (setq pgp-id (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (if (and (not (eq mc-pgp-always-fetch 'never)) - (or mc-pgp-always-fetch - (y-or-n-p - (format "Key for '%s' not found; try to fetch? " - pgp-id)))) - (progn - (mc-pgp-fetch-key (cons pgp-id nil)) - (set-buffer obuf) - (mc-pgp-encrypt-region recipients start end id)) - (mc-message mc-pgp-nokey-re buffer) - nil)) - (if (not result) - nil - (message "%s Done." msg) - t))))) - -(defun mc-pgp-decrypt-parser (result) - (goto-char (point-min)) - (cond ((eq result 0) - ;; Valid signature - (re-search-forward "^Signature made.*\n") - (if (looking-at - "\a\nWARNING: Because this public key.*\n.*\n.*\n") - (goto-char (match-end 0))) - (cons (point) (point-max))) - ((eq result 1) - (re-search-forward - "\\(\\(^File is conven.*\\)?Just a moment\\.+\\)\\|\\(^\\.\\)") - (if (eq (match-beginning 2) (match-end 2)) - (if (looking-at - "\nFile has signature.*\\(\n\a.*\n\\)*\nWARNING:.*\n") - (goto-char (match-end 0))) - (if (looking-at "Pass phrase appears good\\. \\.") - (goto-char (match-end 0)))) - (cons (point) (point-max))) - (t nil))) - -(defun mc-pgp-decrypt-region (start end &optional id) - ;; returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if - ;; the decryption succeeded and verified is t if there was a valid signature - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - args key new-key passwd result pgp-id) - (undo-boundary) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq - passwd - (if key - (mc-activate-passwd (cdr key) - (and id - (format "PGP passphrase for %s (%s): " - (car key) (cdr key)))) - (mc-activate-passwd id "PGP passphrase for conventional decryption: "))) - (if passwd - (setenv "PGPPASSFD" "0")) - (setq args '("+verbose=1" "+batchmode" "+language=en" "-f")) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (message "Decrypting...") - (setq result - (mc-process-region - start end passwd mc-pgp-path args 'mc-pgp-decrypt-parser buffer)) - (cond - (result - (message "Decrypting... Done.") - ;; If verification failed due to missing key, offer to fetch it. - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward mc-pgp-key-expected-re nil t) - (setq pgp-id (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))))) - (if (and pgp-id - (not (eq mc-pgp-always-fetch 'never)) - (or mc-pgp-always-fetch - (y-or-n-p - (format "Key %s not found; attempt to fetch? " pgp-id))) - (mc-pgp-fetch-key (cons nil pgp-id))) - (progn - (undo-start) - (undo-more 1) - (mc-pgp-decrypt-region start end id)) - (mc-message mc-pgp-key-expected-re buffer) - (cons t (eq result 0)))) - ;; Decryption failed; maybe we need to use a different user-id - ((save-excursion - (and - (set-buffer buffer) - (goto-char (point-min)) - (re-search-forward - "^Key for user ID:.*\n.*Key ID \\([0-9A-F]+\\)" nil t) - (setq new-key - (mc-pgp-lookup-key - (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) - (not (and id (equal key new-key))))) - (mc-pgp-decrypt-region start end (cdr new-key))) - ;; Or maybe it is conventionally encrypted - ((save-excursion - (and - (set-buffer buffer) - (goto-char (point-min)) - (re-search-forward "^File is conventionally encrypted" nil t))) - (if (null key) (mc-deactivate-passwd t)) - (mc-pgp-decrypt-region start end "***** CONVENTIONAL *****")) - (t - (mc-display-buffer buffer) - (if (mc-message "^\aError: +Bad pass phrase\\.$" buffer) - (mc-deactivate-passwd t) - (mc-message mc-pgp-error-re buffer "Error decrypting buffer")) - (cons nil nil))))) - -(defun mc-pgp-sign-region (start end &optional id unclear) - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - passwd args key) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq passwd - (mc-activate-passwd - (cdr key) - (format "PGP passphrase for %s (%s): " (car key) (cdr key)))) - (setenv "PGPPASSFD" "0") - (setq args - (list - "-fast" "+verbose=1" "+language=en" - (format "+clearsig=%s" (if unclear "off" "on")) - "+batchmode" "-u" (cdr key))) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args))) - (message "Signing as %s ..." (car key)) - (if (mc-process-region start end passwd mc-pgp-path args - 'mc-pgp-generic-parser buffer) - (progn - (message "Signing as %s ... Done." (car key)) - t) - nil))) - -(defun mc-pgp-verify-parser (result) - (cond ((eq result 0) - (mc-message mc-pgp-sigok-re (current-buffer) "Good signature") - t) - ((eq result 1) - (mc-message mc-pgp-error-re (current-buffer) "Bad signature") - nil) - (t - (mc-message mc-pgp-error-re (current-buffer) - (format "PGP exited with status %d" result)) - nil))) - -(defun mc-pgp-verify-region (start end &optional no-fetch) - (let ((buffer (get-buffer-create mc-buffer-name)) - (obuf (current-buffer)) - args pgp-id) - (setq args '("+verbose=1" "+batchmode" "+language=en" "-f")) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (message "Verifying...") - (if (mc-process-region - start end nil mc-pgp-path args 'mc-pgp-verify-parser buffer) - t - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (and - (not no-fetch) - (re-search-forward mc-pgp-key-expected-re nil t) - (setq pgp-id - (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))) - (not (eq mc-pgp-always-fetch 'never)) - (or mc-pgp-always-fetch - (y-or-n-p - (format "Key %s not found; attempt to fetch? " pgp-id))) - (mc-pgp-fetch-key (cons nil pgp-id)) - (set-buffer obuf)) - (mc-pgp-verify-region start end t) - (mc-message mc-pgp-error-re buffer) - nil))))) - -(defun mc-pgp-insert-public-key (&optional id) - (let ((buffer (get-buffer-create mc-buffer-name)) - args) - (setq id (or id mc-pgp-user-id)) - (setq args (list "+verbose=1" "+batchmode" "+language=en" "-kxaf" id)) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args))) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - - (if (mc-process-region (point) (point) nil mc-pgp-path - args 'mc-pgp-generic-parser buffer) - (progn - (mc-message "Key for user ID: .*" buffer) - t)))) - -(defun mc-pgp-snarf-parser (result) - (eq result 0)) - -(defun mc-pgp-snarf-keys (start end) - ;; Returns number of keys found. - (let ((buffer (get-buffer-create mc-buffer-name)) tmpstr args) - (setq args '("+verbose=1" "+batchmode" "+language=en" "-kaf")) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (message "Snarfing...") - (if (mc-process-region start end nil mc-pgp-path args - 'mc-pgp-snarf-parser buffer) - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward mc-pgp-newkey-re nil t) - (progn - (if mc-pgp-display-snarf-output (mc-display-buffer buffer)) - (setq tmpstr (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))) - (if (equal tmpstr "No") - 0 - (car (read-from-string tmpstr)))))) - (mc-display-buffer buffer) - (mc-message mc-pgp-error-re buffer "Error snarfing PGP keys") - 0))) - -;;;###autoload -(defun mc-scheme-pgp () - (list - (cons 'encryption-func 'mc-pgp-encrypt-region) - (cons 'decryption-func 'mc-pgp-decrypt-region) - (cons 'signing-func 'mc-pgp-sign-region) - (cons 'verification-func 'mc-pgp-verify-region) - (cons 'key-insertion-func 'mc-pgp-insert-public-key) - (cons 'snarf-func 'mc-pgp-snarf-keys) - (cons 'msg-begin-line mc-pgp-msg-begin-line) - (cons 'msg-end-line mc-pgp-msg-end-line) - (cons 'signed-begin-line mc-pgp-signed-begin-line) - (cons 'signed-end-line mc-pgp-signed-end-line) - (cons 'key-begin-line mc-pgp-key-begin-line) - (cons 'key-end-line mc-pgp-key-end-line) - (cons 'user-id mc-pgp-user-id))) - -;;{{{ Key fetching - -(defvar mc-pgp-always-fetch nil - "*If t, always attempt to fetch missing keys, or never fetch if -'never.") - -(defvar mc-pgp-keyserver-url-template - "/htbin/pks-extract-key.pl?op=get&search=%s" - "The URL to pass to the keyserver.") - -(defvar mc-pgp-keyserver-address "pgp.ai.mit.edu" - "Host name of keyserver.") - -(defvar mc-pgp-keyserver-port 80 - "Port on which the keyserver's HTTP daemon lives.") - -(defvar mc-pgp-fetch-timeout 20 - "*Timeout, in seconds, for any particular key fetch operation.") - -(defvar mc-pgp-fetch-keyring-list nil - "*List of strings which are filenames of public keyrings to search -when fetching keys.") - -(defsubst mc-pgp-buffer-get-key (buf) - "Return the first key block in BUF as a string, or nil if none found." - (save-excursion - (let (start) - (set-buffer buf) - (goto-char (point-min)) - (and (re-search-forward mc-pgp-key-begin-line nil t) - (setq start (match-beginning 0)) - (re-search-forward mc-pgp-key-end-line nil t) - (buffer-substring-no-properties start (match-end 0)))))) - -(defun mc-pgp-fetch-from-keyrings (id) - (let ((keyring-list mc-pgp-fetch-keyring-list) - buf proc key) - (unwind-protect - (progn - (message "Fetching %s from keyrings..." (or (cdr id) (car id))) - (while (and (not key) keyring-list) - (setq buf (generate-new-buffer " *mailcrypt temp*")) - (setq proc - (start-process "*PGP*" buf mc-pgp-path "-kxaf" - "+verbose=0" "+batchmode" - (format "+pubring=%s" (car keyring-list)) - (or (cdr id) (car id)))) - ;; Because PGPPASSFD might be set - (process-send-string proc "\r\n") - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - (setq key (mc-pgp-buffer-get-key buf)) - (setq keyring-list (cdr keyring-list))) - key) - (if buf (kill-buffer buf)) - (if (and proc (eq 'run (process-status proc))) - (interrupt-process proc))))) - -(defun mc-pgp-fetch-from-http (id) - (let (buf connection) - (unwind-protect - (progn - (message "Fetching %s via HTTP to %s..." - (or (cdr id) (car id)) mc-pgp-keyserver-address) - (setq buf (generate-new-buffer " *mailcrypt temp*")) - (setq connection - (open-network-stream "*key fetch*" buf mc-pgp-keyserver-address - mc-pgp-keyserver-port)) - (process-send-string - connection - (concat "GET " (format mc-pgp-keyserver-url-template - (or (cdr id) (car id))) "\r\n")) - (while (and (eq 'open (process-status connection)) - (accept-process-output connection mc-pgp-fetch-timeout))) - (mc-pgp-buffer-get-key buf)) - (if buf (kill-buffer buf)) - (if connection (delete-process connection))))) - -(defun mc-pgp-fetch-from-finger (id) - (let (buf connection user host) - (unwind-protect - (and (car id) - (string-match "^\\(.+\\)@\\([^@]+\\)$" (car id)) - (progn - (message "Trying finger %s..." (car id)) - (setq user (substring (car id) - (match-beginning 1) (match-end 1))) - (setq host (substring (car id) - (match-beginning 2) (match-end 2))) - (setq buf (generate-new-buffer " *mailcrypt temp*")) - (condition-case nil - (progn - (setq connection - (open-network-stream "*key fetch*" buf host 79)) - (process-send-string connection - (concat "/W " user "\r\n")) - (while - (and (eq 'open (process-status connection)) - (accept-process-output connection - mc-pgp-fetch-timeout))) - (mc-pgp-buffer-get-key buf)) - (error nil)))) - (if buf (kill-buffer buf)) - (if connection (delete-process connection))))) - -(defvar mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings - mc-pgp-fetch-from-finger - mc-pgp-fetch-from-http) - "List of methods to try when attempting to fetch a key. Each -element is a function to call with an ID as argument. See the -documentation for the function mc-pgp-fetch-key for a description of -the ID.") - -;;;###autoload -(defun mc-pgp-fetch-key (&optional id) - "Attempt to fetch a key for addition to PGP keyring. Interactively, -prompt for string matching key to fetch. - -Non-interactively, ID must be a pair. The CAR must be a bare Email -address and the CDR a keyID (with \"0x\" prefix). Either, but not -both, may be nil. - -Return t if we think we were successful; nil otherwise. Note that nil -is not necessarily an error, since we may have merely fired off an Email -request for the key." - (interactive) - (let ((methods mc-pgp-fetch-methods) - (process-connection-type nil) key proc buf args) - (if (null id) - (setq id (cons (read-string "Fetch key for: ") nil))) - (while (and (not key) methods) - (setq key (funcall (car methods) id)) - (setq methods (cdr methods))) - (if (not (stringp key)) - (progn - (message "Key not found.") - nil) - ;; Maybe I'll do this right someday. - (unwind-protect - (save-window-excursion - (setq buf (generate-new-buffer " *PGP Key Info*")) - (pop-to-buffer buf) - (if (< (window-height) (/ (frame-height) 2)) - (enlarge-window (- (/ (frame-height) 2) - (window-height)))) - (setq args '("-f" "+verbose=0" "+batchmode")) - (if mc-pgp-alternate-keyring - (setq args - (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - - (setq proc (apply 'start-process "*PGP*" buf mc-pgp-path args)) - ;; Because PGPPASSFD might be set - (process-send-string proc "\r\n") - (process-send-string proc key) - (process-send-string proc "\r\n") - (process-send-eof proc) - (set-buffer buf) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5) - (goto-char (point-min))) - (if (y-or-n-p "Add this key to keyring? ") - (progn - (setq args (append args '("-ka"))) - (setq proc - (apply 'start-process "*PGP*" buf mc-pgp-path args)) - ;; Because PGPPASSFD might be set - (process-send-string proc "\r\n") - (process-send-string proc key) - (process-send-string proc "\r\n") - (process-send-eof proc) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - t))) - (if buf (kill-buffer buf)))))) - -;;}}} diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/mc-remail.el --- a/lisp/mailcrypt/mc-remail.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,862 +0,0 @@ -;; mc-remail.el --- Remailer support for Mailcrypt - -;; Copyright (C) 1995 Patrick LoPresti - -;;{{{ Licensing - -;; This file is intended to be used with GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;}}} -;;{{{ Load required packages - -(require 'mail-utils) -(require 'sendmail) -(require 'mailcrypt) - -(eval-and-compile - (if (not mc-xemacs-p) - (progn - (autoload 'mc-cleanup-recipient-headers "mc-toplev") - (autoload 'mc-encrypt-message "mc-toplev")))) - -(eval-and-compile - (condition-case nil (require 'mailalias) (error nil))) - -;;}}} -;;{{{ Functions dealing with remailer structures - -(defsubst mc-remailer-create (addr id props pre-encr post-encr) - "Create a remailer structure. - -ADDR is the remailer's Email address, a string. - -ID is the remailer's public key ID (a string) or nil if the same as -ADDR. - -PROPS is a list of properties, as strings. - -PRE-ENCR is a list of pre-encryption functions. Its elements will be -called with the remailer structure itself as argument. - -POST-ENCR is similar, but for post-encryption functions." -(list 'remailer addr id props pre-encr post-encr)) - -(defsubst mc-remailerp (remailer) - "Test whether REMAILER is a valid remailer struct." - (and (listp remailer) (eq 'remailer (car-safe remailer)))) - -(defsubst mc-remailer-address (remailer) - "Return the Email address of REMAILER." - (nth 1 remailer)) - -(defsubst mc-remailer-userid (remailer) - "Return the userid with which to look up the public key for REMAILER." - (or (nth 2 remailer) - (mc-strip-address (mc-remailer-address remailer)))) - -(defsubst mc-remailer-properties (remailer) - "Return the property list for REMAILER" - (nth 3 remailer)) - -(defsubst mc-remailer-pre-encrypt-hooks (remailer) - "Return the list of pre-encryption hooks for REMAILER." - (nth 4 remailer)) - -(defsubst mc-remailer-post-encrypt-hooks (remailer) - "Return the list of post-encryption hooks for REMAILER." - (nth 5 remailer)) - -(defun mc-remailer-remove-property (remailer prop) - (let ((props (append (mc-remailer-properties remailer) nil))) - (setq props (delete prop props)) - (mc-remailer-create - (mc-remailer-address remailer) - (mc-remailer-userid remailer) - props - (mc-remailer-pre-encrypt-hooks remailer) - (mc-remailer-post-encrypt-hooks remailer)))) - -;;}}} -;;{{{ User variables - -(defvar mc-response-block-included-headers - '("From" "To" "Newsgroups") - "List of header fields to include in response blocks. - -These will be copied into the deepest layer of the response block to -help you identify it when it is used to Email you.") - - -(defvar mc-remailer-tag "(*REMAILER*)" - "A string which marks an Email address as belonging to a remailer.") - -(defvar mc-levien-file-name "~/.remailers" - "The file containing a Levien format list of remailers. - -The file is read by `mc-read-levien-file' and `mc-reread-levien-file'. - -The file should include lines of the following form (other lines -are ignored): - -$remailer{\"NAME\"} = \" PROPERTIES\"; - -PROPERTIES is a space-separated set of strings. - -This format is named after Raphael Levien, who maintains a list of -active remailers. Do \"finger remailer-list@kiwi.cs.berkeley.edu\" -for the latest copy of his list.") - -(defvar mc-remailer-user-chains nil - "An alist of remailer chains defined by the user. - -Format is - -((NAME . REMAILER-LIST) - (NAME . REMAILER-LIST) - ...) - -NAME must be a string. - -REMAILER-LIST may be an arbitrary sequence, not just a list. Its -elements may be any of the following: - -1) A remailer structure created by `mc-remailer-create'. This is - the base case. - -2) A string naming another remailer chain to be spliced in - at this point. - -3) A positive integer N representing a chain to be spliced in at this - point and consisting of a random permutation of the top N remailers - as ordered in the file `mc-levien-file-name'. - -4) An arbitrary Lisp form to be evaluated, which should - return another REMAILER-LIST to be recursively processed and - spliced in at this point. - -The complete alist of chains is given by the union of the two lists -`mc-remailer-internal-chains' and `mc-remailer-user-chains'.") - -(defvar mc-remailer-internal-chains nil - "List of \"internal\" remailer chains. - -This variable is normally generated automatically from a human-readable -list of remailers; see, for example, the function `mc-reread-levien-file'. - -To define your own chains, you probably want to use the variable -`mc-remailer-user-chains'. See that variable's documentation for -format information.") - -(defvar mc-remailer-internal-ranking nil - "Ordered list of remailers, most reliable first. - -This variable is normally generated automatically from a human-readable -list of remailers; see, for example, the function `mc-reread-levien-file'.") - -(defvar mc-remailer-user-response-block - (function - (lambda (addr lines block) - (concat - ";;;\n" - (format - "To reply to this message, take the following %d-line block, remove\n" - lines) - "leading \"- \" constructs (if any), and place it at the top of a\n" - (format "message to %s :\n" addr) - block))) - "A function called to generate response block text. - -Value should be a function taking three arguments (ADDR LINES BLOCK). -ADDR is the address to which the response should be sent. -LINES is the number of lines in the encrypted response block. -BLOCK is the response block itself. -Function should return a string to be inserted into the buffer -by mc-remailer-insert-response-block.") - -(defvar mc-remailer-pseudonyms nil - "*A list of your pseudonyms. - -This is a list of strings. Completion against it will be available -when you are prompted for your pseudonym.") - -(defvar mc-remailer-preserved-headers - '("References" "Followup-to" "In-reply-to") - "*Header fields which are preserved as hashmark headers when rewriting. - -This is a list of strings naming the preserved headers. Note that -\"Subject\", \"Newsgroups\", and \"To\" are handled specially and -should not be included in this list.") - -;;}}} -;;{{{ Handling Levien format remailer lists - -(defun mc-parse-levien-buffer () - ;; Parse a buffer in Levien format. - (goto-char (point-min)) - (let (chains remailer remailer-name ranking) - (while - (re-search-forward - "^\\$remailer{\"\\(.+\\)\"}[ \t]*=[ \t]*\"\\(.*\\)\";" - nil t) - (let ((name (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - property-list address - (value-start (match-beginning 2)) - (value-end (match-end 2))) - (goto-char value-start) - (while (re-search-forward "[^ \t]+" value-end 'no-error) - (setq property-list - (append - property-list - (list (buffer-substring-no-properties - (match-beginning 0) (match-end 0)))))) - (setq address (car property-list) - property-list (cdr property-list) - remailer-name name) - (if (not - (or (member "mix" property-list) - (and (or (member "pgp" property-list) - (member "pgp." property-list)) - (or (member "cpunk" property-list) - (member "eric" property-list))))) - (setq remailer nil) - (setq remailer - (mc-remailer-create - address ; Address - (if (member "pgp." property-list) - name) ; User ID - property-list - '(mc-generic-pre-encrypt-function) ; Pre-encrypt hooks - '(mc-generic-post-encrypt-function) ; Post-encrypt hooks - )))) - (if (not (null remailer)) - (setq chains (cons (list remailer-name remailer) chains)))) - (goto-char (point-min)) - (if (re-search-forward "----------" nil t) - (while (re-search-forward "^\\([a-zA-Z0-9\\-]+\\) " nil t) - (setq remailer-name (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (if (assoc remailer-name chains) - (setq ranking (append ranking (list remailer-name)))))) - (cons chains ranking))) - -(defun mc-read-levien-file () - "Read the Levien format file specified in `mc-levien-file-name'. -Return an alist of length-1 chains, one for each remailer, named -after the remailer. Only include remailers supporting PGP -encryption." - (save-excursion - (if (file-readable-p mc-levien-file-name) - (prog2 - (find-file-read-only mc-levien-file-name) - (mc-parse-levien-buffer) - (bury-buffer))))) - -(defun mc-reread-levien-file () - "Read the Levien format file specified in `mc-levien-file-name'. - -Place result in `mc-remailer-internal-chains' and `mc-remailer-internal-ranking'. - -See the documentation for the variable `mc-levien-file-name' for -a description of Levien file format." - (interactive) - (let ((parsed-levien-file (mc-read-levien-file))) - (setq mc-remailer-internal-chains (car parsed-levien-file) - mc-remailer-internal-ranking (cdr parsed-levien-file)))) - -;;}}} -;;{{{ Arbitrary chain choice - -(defun mc-remailer-choose-first (n &optional l) - (cond - ((= n 0) nil) - ((null l) (mc-remailer-choose-first n mc-remailer-internal-ranking)) - (t (cons (car l) (mc-remailer-choose-first (1- n) (cdr l)))))) - -(defun mc-remailer-choose-chain (n) - (if (null mc-remailer-internal-ranking) - (error "No ranking information, cannot choose the %d best remailer%s" - n (if (> n 1) "s" ""))) - (append (shuffle-vector (vconcat (mc-remailer-choose-first n))) - nil)) - -;;}}} -;;{{{ Canonicalization function - -(defun mc-remailer-canonicalize-elmt (elmt chains-alist) - (cond - ((mc-remailerp elmt) (list elmt)) - ((stringp elmt) - (mc-remailer-canonicalize-chain (cdr (assoc elmt chains-alist)) - chains-alist)) - ((integerp elmt) - (mc-remailer-canonicalize-chain (mc-remailer-choose-chain elmt) - chains-alist)) - (t (mc-remailer-canonicalize-chain (eval elmt) chains-alist)))) - -(defun mc-remailer-canonicalize-chain (chain &optional chains-alist) - ;; Canonicalize a remailer chain with respect to CHAINS-ALIST. - ;; That is, use CHAINS-ALIST to resolve strings. - ;; Here is where we implement the functionality described in - ;; the documentation for the variable `mc-remailer-user-chains'. - (if (null chains-alist) - (setq chains-alist (mc-remailer-make-chains-alist))) - (cond - ((null chain) nil) - ;; Handle case where chain is actually a string or a single - ;; remailer. - ((or (stringp chain) (mc-remailerp chain) (integerp chain)) - (mc-remailer-canonicalize-elmt chain chains-alist)) - (t - (let ((first (elt chain 0)) - (rest (cdr (append chain nil)))) - (append - (mc-remailer-canonicalize-elmt first chains-alist) - (mc-remailer-canonicalize-chain rest chains-alist)))))) - -;;}}} -;;{{{ Auxiliaries for mail header munging - -(defsubst mc-nuke-field (field &optional bounds) - ;; Delete all fields exactly matching regexp FIELD from header, - ;; bounded by BOUNDS. Default is entire visible region of buffer. - (mc-get-fields field bounds t)) - -(defun mc-replace-field (field-name replacement header) - (save-excursion - (save-restriction - (if (not (string-match "^[ \t]" replacement)) - (setq replacement (concat " " replacement))) - (if (not (string-match "\n$" replacement)) - (setq replacement (concat replacement "\n"))) - (let ((case-fold-search t) - (field-regexp (regexp-quote field-name))) - (narrow-to-region (car header) (cdr header)) - (goto-char (point-min)) - (re-search-forward - (concat "^" field-regexp ":" mc-field-body-regexp) - nil t) - (mc-nuke-field field-regexp header) - (insert field-name ":" replacement))))) - -(defun mc-find-main-header (&optional ignored) - ;; Find the main header of the mail message; return as a pair of - ;; markers (START . END). - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (forward-line -1) - (cons (copy-marker (point-min)) (copy-marker (point))))) - -(defun mc-find-colon-header (&optional insert) - ;; Find the header with a "::" immediately after the - ;; mail-header-separator. Return region enclosing header. Optional - ;; arg INSERT means insert the header if it does not exist already. - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (if (or (and (looking-at "::\n") (forward-line 1)) - (and insert - (progn - (insert-before-markers "::\n\n") - (forward-line -1)))) - (let ((start (point))) - (re-search-forward "^$" nil 'move) - (cons (copy-marker start) (copy-marker (point))))))) - -(defun mc-find-hash-header (&optional insert) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (if (or (and (looking-at "##\n") (forward-line 1)) - (and (looking-at "::\n") - (re-search-forward "^\n" nil 'move) - (looking-at "##\n") - (forward-line 1)) - (and insert - (progn - (insert-before-markers "##\n\n") - (forward-line -1)))) - (let ((start (point))) - (re-search-forward "^$" nil 'move) - (cons (copy-marker start) (copy-marker (point))))))) - - -(defsubst mc-replace-main-field (field replacement) - (mc-replace-field field replacement (mc-find-main-header t))) - -(defsubst mc-replace-hash-field (field replacement) - (mc-replace-field field replacement (mc-find-hash-header t))) - -(defsubst mc-replace-colon-field (field replacement) - (mc-replace-field field replacement (mc-find-colon-header t))) - -(defun mc-recipient-is-remailerp () - (let ((to (mc-get-fields "To" (mc-find-main-header)))) - (and to - (string-match (regexp-quote mc-remailer-tag) (cdr (car to)))))) - -;;}}} -;;{{{ Pre-encryption and post-encryption hook defaults - -(defun mc-generic-post-encrypt-function (remailer) - (let ((main-header (mc-find-main-header)) - (colon-header (mc-find-colon-header t))) - (mc-replace-field "Encrypted" "PGP" colon-header) - (mc-replace-field - "To" - (concat (mc-remailer-address remailer) " " mc-remailer-tag) - main-header))) - -(defun mc-generic-pre-encrypt-function (remailer) - (let ((addr (mc-remailer-address remailer)) - (props (mc-remailer-properties remailer)) - (main-header (mc-find-main-header)) - (colon-header (mc-find-colon-header t)) - to to-field preserved-regexp preserved) - - (setq preserved-regexp - (mc-disjunction-regexp mc-remailer-preserved-headers)) - (setq preserved (mc-get-fields preserved-regexp main-header t)) - (if preserved (goto-char (cdr (mc-find-hash-header t)))) - (mapcar (function - (lambda (c) - (insert (car c) ":" - (mc-eliminate-continuation-lines (cdr c))))) - preserved) - - (if (and (mc-find-hash-header) (not (member "hash" props))) - (error "Remailer %s does not support hashmarks" addr)) - - (if (mc-get-fields "Newsgroups" main-header) - (cond ((not (member "post" props)) - (error "Remailer %s does not support posting" addr)) - ((not (member "hash" props)) - (error "Remailer %s does not support hashmarks" addr)) - (t (mc-rewrite-news-to-mail remailer))) - (and (featurep 'mailalias) - (not (featurep 'mail-abbrevs)) - mail-aliases - (expand-mail-aliases (car main-header) (cdr main-header))) - (setq to (mc-strip-addresses - (mapcar 'cdr (mc-get-fields "To" main-header)))) - (if (string-match "," to) - (error "Remailer %s does not support multiple recipients." addr)) - (setq to-field - (if (mc-get-fields "From" colon-header) - "Send-To" - (cond - ((member "eric" props) "Anon-Send-To") - ((member "cpunk" props) "Request-Remailing-To") - (t (error "Remailer %s is not type-1" addr))))) - (mc-replace-field to-field to colon-header) - (mc-nuke-field "Reply-to" main-header)))) - -;;}}} -;;{{{ Misc. random - -(defun mc-disjunction-regexp (regexps) - ;; Take a list of regular expressions and return a single - ;; regular expression which matches anything that any of the - ;; original regexps match. - (concat "\\(" - (mapconcat 'identity regexps "\\)\\|\\(") - "\\)")) - -(defun mc-user-mail-address () - "Figure out the user's Email address as best we can." - (mc-strip-address - (cond ((and (boundp 'gnus-user-from-line) - (stringp gnus-user-from-line)) - gnus-user-from-line) - ((stringp mail-default-reply-to) mail-default-reply-to) - ((boundp 'user-mail-address) user-mail-address) - (t (concat (user-login-name) "@" (system-name)))))) - -(defun mc-eliminate-continuation-lines (string) - (while (string-match "\n[\t ]+" string) - (setq string (replace-match " " t nil string))) - string) - -(defun mc-remailer-make-chains-alist () - (if (null mc-remailer-internal-chains) - (mc-reread-levien-file)) - (append mc-remailer-internal-chains mc-remailer-user-chains)) - -;;;###autoload -(defun mc-remailer-insert-pseudonym () - "Insert pseudonym as a From field in the hash-mark header. - -See the documentation for the variable `mc-remailer-pseudonyms' for -more information." - (interactive) - (let ((completion-ignore-case t) - pseudonym) - (setq pseudonym - (cond ((null mc-remailer-pseudonyms) - (read-from-minibuffer "Pseudonym: ")) - (t - (completing-read "Pseudonym: " - (mapcar 'list mc-remailer-pseudonyms))))) - (if (not (string-match "\\S +@\\S +" pseudonym)) - (setq pseudonym (concat pseudonym " "))) - (mc-replace-colon-field "From" pseudonym))) - -;;}}} -;;{{{ Mixmaster support -(defvar mc-mixmaster-path nil - "*Path to the Mixmaster binary. If defined, Mixmaster chains will -be passed to this program for rewriting.") - -(defvar mc-mixmaster-list-path nil - "*Path to the Mixmaster type2.list file.") - -(defun mc-demix (&rest chain) - "Use arguments as a remailer-list and return a new list with the -\"mix\" property removed from all the elements." - (mapcar (function (lambda (r) (mc-remailer-remove-property r "mix"))) - (mc-remailer-canonicalize-chain chain))) - -(defun mc-mixmaster-process (beg end recipients preserved mix-chain) - ;; Run a region through Mixmaster. - (let (ret) - (if (not (markerp end)) - (setq end (copy-marker end))) - (goto-char beg) - (mapcar (function (lambda (x) (insert x ?\n))) recipients) - (insert ?\n) - (mapcar (function (lambda (x) (insert x))) preserved) - (insert ?\n) - (setq mix-chain (mapcar (function (lambda (x) (format "%d" x))) mix-chain)) - ;; Handle case of empty message - (if (< end (point)) (setq end (point))) - (setq ret - (apply 'call-process-region beg end mc-mixmaster-path t t nil - "-f" "-o" "stdout" "-l" mix-chain)) - (if (not (eq ret 0)) (error "Mixmaster barfed.")) - (goto-char beg) - (re-search-forward "^::$") - (delete-region beg (match-beginning 0)))) - -(defun mc-mixmaster-build-alist (&optional n) - ;; Construct an alist mapping Mixmaster Email addresses to integers. - ;; FIXME; this is terrible - (let (buf) - (save-excursion - (unwind-protect - (progn - (setq n (or n 1)) - (setq buf (find-file-noselect mc-mixmaster-list-path)) - (set-buffer buf) - (if (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)" nil t) - (cons (cons (buffer-substring-no-properties - (match-beginning 1) (match-end 1)) - n) - (mc-mixmaster-build-alist (+ n 1))))) - (if buf (kill-buffer buf)))))) - -(defvar mc-mixmaster-alist nil) - -(defsubst mc-mixmaster-alist () - (or mc-mixmaster-alist - (setq mc-mixmaster-alist (mc-mixmaster-build-alist)))) - -(defun mc-mixmaster-translate-chain (chain) - ;; Take a chain of Mixmaster remailers and convert it to the list - ;; of integers which represents them. - (if (or (null chain) - (not (member "mix" (mc-remailer-properties (car chain))))) - nil - (cons (cdr (assoc (mc-strip-address (mc-remailer-address (car chain))) - (mc-mixmaster-alist))) - (mc-mixmaster-translate-chain (cdr chain))))) - -(defun mc-mixmaster-skip (chain) - ;; Return the largest possible suffix of CHAIN whose first element - ;; is not a Mixmaster. - (cond ((null chain) nil) - ((not (member "mix" (mc-remailer-properties (car chain)))) - chain) - (t (mc-mixmaster-skip (cdr chain))))) - -(defun mc-rewrite-for-mixmaster (chain &optional pause) - ;; Rewrite the current mail buffer for a chain of Mixmasters. - (let ((mix-chain (mc-mixmaster-translate-chain chain)) - (main-header (mc-find-main-header)) - (colon-header (mc-find-colon-header)) - (hash-header (mc-find-hash-header)) - recipients preserved newsgroups first last rest preserved-regexp) - - ;; Figure out FIRST and LAST. FIRST is the first Mixmaster in the - ;; chain. LAST is the last. - (setq first (car chain) - rest chain) - (while (and rest (member "mix" (mc-remailer-properties (car rest)))) - (setq last (car rest) - rest (cdr rest))) - - ;; If recipient is not a remailer, deal with hashmark and colon - ;; headers and get rid of them. - (if (mc-recipient-is-remailerp) - nil - (if hash-header - (progn - (setq preserved (mc-get-fields nil hash-header)) - (goto-char (car hash-header)) - (forward-line -1) - (delete-region (point) (+ (cdr hash-header) 1)))) - ;; Preserve pseduonym line... - (if colon-header - (progn - (setq preserved - (append (mc-get-fields "From" colon-header) preserved)) - (goto-char (car colon-header)) - (forward-line -1) - (delete-region (point) (+ (cdr colon-header) 1))))) - - ;; Expand aliases and get recipients. - (and (featurep 'mailalias) - (not (featurep 'mail-abbrevs)) - mail-aliases - (expand-mail-aliases (car main-header) (cdr main-header))) - (setq recipients - (mc-cleanup-recipient-headers - (mapconcat 'cdr (mc-get-fields "To" main-header t) ", "))) - (setq newsgroups (mc-get-fields "Newsgroups" nil t)) - ;; Mixmaster does not support posting... -;;; (if (and newsgroups -;;; (not (member "post" (mc-remailer-properties last)))) - (if newsgroups - (error "Remailer %s does not support posting" - (mc-remailer-address last))) - (setq - recipients - (append (mapcar - (function (lambda (c) (concat "Post:" (cdr c)))) newsgroups) - recipients)) - - (setq - preserved-regexp - (mc-disjunction-regexp (cons "Subject" mc-remailer-preserved-headers))) - - (setq preserved - (append (mc-get-fields preserved-regexp main-header t) preserved)) - - ;; Convert preserved header alist to simple list of strings - (setq preserved - (mapcar - (function - (lambda (c) - (concat (car c) ":" - (mc-eliminate-continuation-lines (cdr c))))) - preserved)) - - ;; Do the conversion - (goto-char (cdr main-header)) - (forward-line 1) - (mc-mixmaster-process (point) (point-max) recipients preserved - mix-chain) - - (mc-replace-field "To" - (concat - (mc-remailer-address first) " " mc-remailer-tag) - main-header))) - -;;}}} -;;{{{ High level message rewriting - -(defun mc-rewrite-news-to-mail (remailer) - (let ((main-header (mc-find-main-header)) - newsgroups) - (setq newsgroups (mc-get-fields "Newsgroups" main-header t)) - (mc-replace-colon-field "Post-To" (cdr (car newsgroups))) - (mail-mode))) - -(defun mc-rewrite-for-remailer (remailer &optional pause) - ;; Rewrite the current mail buffer for a single remailer. This - ;; includes running the pre-encryption hooks, modifying the To: - ;; field, encrypting with the remailer's public key, and running the - ;; post-encryption hooks. - (let ((addr (mc-remailer-address remailer)) - (main-header (mc-find-main-header))) - ;; If recipient is already a remailer, make sure the "::" and "##" - ;; headers get to it - (if (mc-recipient-is-remailerp) - (progn - (goto-char (cdr main-header)) - (forward-line 1) - (insert "::\n\n"))) - - (mapcar - (function (lambda (hook) (funcall hook remailer))) - (mc-remailer-pre-encrypt-hooks remailer)) - - ;; Move "Subject" lines down. - (goto-char (car (mc-find-colon-header t))) - (mapcar - (function (lambda (f) (insert (car f) ":" (cdr f)))) - (mc-get-fields "Subject" main-header t)) - - (if pause - (let ((cursor-in-echo-area t)) - (message "SPC to encrypt for %s : " addr) - (read-char-exclusive))) - (setq main-header (mc-find-main-header)) - (goto-char (cdr main-header)) - (forward-line 1) - (if (let ((mc-pgp-always-sign 'never) - (mc-encrypt-for-me nil)) - (mc-encrypt-message (mc-remailer-userid remailer) nil (point))) - (progn - (mapcar - (function (lambda (hook) (funcall hook remailer))) - (mc-remailer-post-encrypt-hooks remailer)) - (mc-nuke-field "Comment") - (mc-nuke-field "From")) - (error "Unable to encrypt message to %s" - (mc-remailer-userid remailer))))) - -(defun mc-rewrite-for-chain (chain &optional pause) - ;; Rewrite the current buffer for a chain of remailers. - ;; CHAIN must be in canonical form. - (let (rest) - (if mc-mixmaster-path - (setq rest (mc-mixmaster-skip chain)) - (setq rest chain)) - (if (null chain) nil - (mc-rewrite-for-chain - (if (eq rest chain) (cdr rest) rest) pause) - (if (eq rest chain) - (mc-rewrite-for-remailer (car chain) pause) - (mc-rewrite-for-mixmaster chain pause))))) - -(defun mc-unparse-chain (chain) - ;; Unparse CHAIN into a string suitable for printing. - (if (null chain) - nil - (concat (mc-remailer-address (car chain)) "\n" - (mc-unparse-chain (cdr chain))))) - -(defun mc-disallow-field (field &optional header) - (let ((case-fold-search t)) - (if (null header) - (setq header (mc-find-main-header))) - (goto-char (car header)) - (if (re-search-forward (concat "^" (regexp-quote field) ":") - (cdr header) t) - - (progn - (goto-char (match-beginning 0)) - (error "Cannot use a %s field." field))))) - -;;;###autoload -(defun mc-remailer-encrypt-for-chain (&optional pause) - "Encrypt message for a remailer chain, prompting for chain to use. - -With \\[universal-argument], pause before each encryption." - (interactive "P") - (let ((chains (mc-remailer-make-chains-alist)) - (buffer (get-buffer-create mc-buffer-name)) - chain-name chain) - (mc-disallow-field "CC") - (mc-disallow-field "FCC") - (mc-disallow-field "BCC") - (setq chain-name - (completing-read - "Choose a remailer or chain: " chains nil 'strict-match)) - (setq chain - (mc-remailer-canonicalize-chain - (cdr (assoc chain-name chains)) - chains)) - (mc-rewrite-for-chain chain pause) - (if chain - (save-excursion - (set-buffer buffer) - (erase-buffer) - (insert "Rewritten for chain `" chain-name "':\n\n" - (mc-unparse-chain chain)) - (message "Done. See %s buffer for details." mc-buffer-name))))) - -;;}}} -;;{{{ Response block generation - -;;;###autoload -(defun mc-remailer-insert-response-block (&optional arg) - "Insert response block at point, prompting for chain to use. - -With \\[universal-argument], enter a recursive edit of the innermost -layer of the block before encrypting it." - (interactive "p") - (let (buf main-header to addr block lines) - (save-excursion - (setq buf - (mc-remailer-make-response-block (if (> arg 1) t))) - (set-buffer buf) - (setq main-header (mc-find-main-header)) - (setq to (cdr (car (mc-get-fields "To" main-header)))) - (setq addr (concat "<" (mc-strip-address to) ">")) - (goto-char (cdr main-header)) - (forward-line 1) - (setq block (buffer-substring-no-properties - (point) (point-max)) - lines (count-lines (point) (point-max))) - (kill-buffer buf)) - (let ((opoint (point))) - (insert (funcall mc-remailer-user-response-block - addr lines block)) - (goto-char opoint)) - (mc-nuke-field "Reply-to" (mc-find-main-header)) - (mc-replace-hash-field "Reply-to" addr))) - -(defun mc-remailer-make-response-block (&optional recurse) - ;; Return a buffer which contains a response block - ;; for the user, and a To: header for the remailer to use. - (let ((buf (generate-new-buffer " *Remailer Response Block*")) - (original-buf (current-buffer)) - (mc-mixmaster-path nil) - all-headers included-regexp included) - (setq all-headers (mc-find-main-header)) - (setcdr all-headers - (max - (cdr all-headers) - (or (cdr-safe (mc-find-colon-header)) 0) - (or (cdr-safe (mc-find-hash-header)) 0))) - (save-excursion - (setq - included-regexp - (mc-disjunction-regexp mc-response-block-included-headers)) - (setq included (mc-get-fields included-regexp all-headers)) - (set-buffer buf) - (insert "To: " (mc-user-mail-address) "\n" mail-header-separator "\n") - (insert ";; Response block created " (current-time-string) "\n") - (mapcar (function (lambda (c) (insert "; " (car c) ":" (cdr c)))) - included) - (if recurse - (progn - (switch-to-buffer buf) - (message "Editing response block ; %s when done." - (substitute-command-keys "\\[exit-recursive-edit]")) - (recursive-edit))) - (set-buffer buf) - (mc-remailer-encrypt-for-chain) - (switch-to-buffer original-buf)) - buf)) - -;;}}} diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mailcrypt/mc-toplev.el --- a/lisp/mailcrypt/mc-toplev.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,655 +0,0 @@ -;; mc-toplev.el, entry point functions for Mailcrypt -;; Copyright (C) 1995 Jin Choi -;; Patrick LoPresti - -;;{{{ Licensing -;; This file is intended to be used with GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;}}} -;;{{{ Load some required packages -(require 'mailcrypt) -(require 'mail-utils) - -(eval-when-compile - ;; RMAIL - (condition-case nil (require 'rmail) (error nil)) - (autoload 'rmail-abort-edit "rmailedit") - (autoload 'rmail-cease-edit "rmailedit") - ;; Is this a good idea? - (defvar rmail-buffer nil) - - ;; VM - (condition-case nil (require 'vm) (error nil)) - - ;; GNUS - (condition-case nil (require 'gnus) (error nil)) - - ;; MH-E - (condition-case nil (require 'mh-e) (error nil))) - -(eval-and-compile - (condition-case nil (require 'mailalias) (error nil))) - -(if (not mc-xemacs-p) - (autoload 'mc-scheme-pgp "mc-pgp" nil t)) - -;;}}} - -;;{{{ Encryption - -;;;###autoload -(defun mc-cleanup-recipient-headers (str) - ;; Takes a comma separated string of recipients to encrypt for and, - ;; assuming they were possibly extracted from the headers of a reply, - ;; returns a list of the address components. - (mapcar 'mc-strip-address - (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" str))) - -(defun mc-find-headers-end () - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (if (looking-at "^::\n") - (re-search-forward "^\n" nil t)) - (if (looking-at "^##\n") - (re-search-forward "^\n" nil t)) - (point-marker))) - -;;;###autoload -(defun mc-encrypt (arg) - "*Encrypt the current buffer. - -Exact behavior depends on current major mode. - -With \\[universal-argument], prompt for User ID to sign as. - -With \\[universal-argument] \\[universal-argument], prompt for encryption scheme to use." - (interactive "p") - (mc-encrypt-region arg nil nil)) - -(defun mc-encrypt-region (arg start end) - "*Encrypt the current region." - (interactive "p\nr") - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'encrypt mode-alist)) - 'mc-encrypt-generic)) - sign scheme from) - (if (>= arg 4) - (setq from (read-string "User ID: ") - sign t)) - (if (>= arg 16) - (setq scheme - (cdr (assoc - (completing-read "Encryption Scheme: " mc-schemes) - mc-schemes)))) - (funcall func nil scheme start end from sign))) - -(defun mc-encrypt-generic (&optional recipients scheme start end from sign) - "*Generic function to encrypt a region of data." - (save-excursion - (or start (setq start (point-min-marker))) - (or (markerp start) (setq start (copy-marker start))) - (or end (setq end (point-max-marker))) - (or (markerp end) (setq end (copy-marker end))) - (run-hooks 'mc-pre-encryption-hook) - (cond ((stringp recipients) - (setq recipients - (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients))) - ((null recipients) - (setq recipients - (mc-cleanup-recipient-headers (read-string "Recipients: ")))) - (t (error "mc-encrypt-generic: recipients not string or nil"))) - (or scheme (setq scheme mc-default-scheme)) - (if (funcall (cdr (assoc 'encryption-func (funcall scheme))) - recipients start end from sign) - (progn - (run-hooks 'mc-post-encryption-hook) - t)))) - -;;;###autoload -(defun mc-encrypt-message (&optional recipients scheme start end from sign) - "*Encrypt a message for RECIPIENTS using the given encryption SCHEME. -RECIPIENTS is a comma separated string. If SCHEME is nil, use the value -of `mc-default-scheme'. Returns t on success, nil otherwise." - (save-excursion - (let ((headers-end (mc-find-headers-end)) - default-recipients) - - (setq default-recipients - (save-restriction - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$")) - (narrow-to-region (point-min) (point)) - (and (featurep 'mailalias) - (not (featurep 'mail-abbrevs)) - mail-aliases - (expand-mail-aliases (point-min) (point-max))) - (mc-strip-addresses - (mapcar 'cdr - (mc-get-fields "to\\|cc\\|bcc"))))) - - (if (not from) - (save-restriction - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (narrow-to-region (point) headers-end) - (setq from (mail-fetch-field "From")))) - - (if (not recipients) - (setq recipients - (if mc-use-default-recipients - default-recipients - (read-from-minibuffer "Recipients: " default-recipients)))) - - (or start (setq start headers-end)) - (or end (setq end (point-max-marker))) - - (mc-encrypt-generic recipients scheme start end from sign)))) - - -;;}}} -;;{{{ Decryption - -;;;###autoload -(defun mc-decrypt () - "*Decrypt a message in the current buffer. - -Exact behavior depends on current major mode." - (interactive) - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'decrypt mode-alist)) - 'mc-decrypt-message))) - (funcall func))) - -;;;###autoload -(defun mc-decrypt-message () - "Decrypt whatever message is in the current buffer. -Returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if the encryption -succeeded and VERIFIED is t if it had a valid signature." - (save-excursion - (let ((schemes mc-schemes) - limits scheme) - (while (and schemes - (setq scheme (cdr (car schemes))) - (not (setq - limits - (mc-message-delimiter-positions - (cdr (assoc 'msg-begin-line (funcall scheme))) - (cdr (assoc 'msg-end-line (funcall scheme))))))) - (setq schemes (cdr schemes))) - - (if (null limits) - (error "Found no encrypted message in this buffer.") - (run-hooks 'mc-pre-decryption-hook) - (let ((resultval (funcall (cdr (assoc 'decryption-func - (funcall scheme))) - (car limits) (cdr limits)))) - (goto-char (point-min)) - (if (car resultval) ; decryption succeeded - (run-hooks 'mc-post-decryption-hook)) - resultval))))) -;;}}} -;;{{{ Signing -;;;###autoload -(defun mc-sign (arg) - "*Sign a message in the current buffer. - -Exact behavior depends on current major mode. - -With one prefix arg, prompts for private key to use, with two prefix args, -also prompts for encryption scheme to use. With negative prefix arg, -inhibits clearsigning (pgp)." - (interactive "p") - (mc-sign-region arg nil nil)) - -(defun mc-sign-region (arg start end) - "*Sign the current region." - (interactive "p\nr") - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'sign mode-alist)) - 'mc-sign-generic)) - from scheme) - (if (>= arg 16) - (setq scheme - (cdr (assoc - (completing-read "Encryption Scheme: " mc-schemes) - mc-schemes)))) - (if (>= arg 4) - (setq from (read-string "User ID: "))) - - (funcall func from scheme start end (< arg 0)))) - -(defun mc-sign-generic (withkey scheme start end unclearsig) - (or scheme (setq scheme mc-default-scheme)) - (or start (setq start (point-min-marker))) - (or (markerp start) (setq start (copy-marker start))) - (or end (setq end (point-max-marker))) - (or (markerp end) (setq end (copy-marker end))) - (run-hooks 'mc-pre-signature-hook) - (if (funcall (cdr (assoc 'signing-func (funcall scheme))) - start end withkey unclearsig) - (progn - (run-hooks 'mc-post-signature-hook) - t))) - -;;;###autoload -(defun mc-sign-message (&optional withkey scheme start end unclearsig) - "Clear sign the message." - (save-excursion - (let ((headers-end (mc-find-headers-end))) - (or withkey - (progn - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (save-restriction - (narrow-to-region (point) headers-end) - (setq withkey (mail-fetch-field "From"))))) - (or start (setq start headers-end)) - (or end (setq end (point-max-marker))) - (mc-sign-generic withkey scheme start end unclearsig)))) - -;;}}} -;;{{{ Signature verification - -;;;###autoload -(defun mc-verify () - "*Verify a message in the current buffer. - -Exact behavior depends on current major mode." - (interactive) - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'verify mode-alist)) - 'mc-verify-signature))) - (funcall func))) - -;;;###autoload -(defun mc-verify-signature () - "*Verify the signature of the signed message in the current buffer. -Show the result as a message in the minibuffer. Returns t if the signature -is verified." - (save-excursion - (let ((schemes mc-schemes) - limits scheme) - (while (and schemes - (setq scheme (cdr (car schemes))) - (not - (setq - limits - (mc-message-delimiter-positions - (cdr (assoc 'signed-begin-line (funcall scheme))) - (cdr (assoc 'signed-end-line (funcall scheme))))))) - (setq schemes (cdr schemes))) - - (if (null limits) - (error "Found no signed message in this buffer.") - (funcall (cdr (assoc 'verification-func (funcall scheme))) - (car limits) (cdr limits)))))) - - -;;}}} -;;{{{ Key management - -;;{{{ mc-insert-public-key - -;;;###autoload -(defun mc-insert-public-key (&optional userid scheme) - "*Insert your public key at point. -With one prefix arg, prompts for user id to use. With two prefix -args, prompts for encryption scheme." - (interactive - (let (arglist) - (if (not (and (listp current-prefix-arg) - (numberp (car current-prefix-arg)))) - nil - (if (>= (car current-prefix-arg) 16) - (setq arglist - (cons (cdr (assoc (completing-read "Encryption Scheme: " - mc-schemes) - mc-schemes)) - arglist))) - (if (>= (car current-prefix-arg) 4) - (setq arglist (cons (read-string "User ID: ") arglist)))) - arglist)) - -; (if (< (point) (mc-find-headers-end)) -; (error "Can't insert key inside message header")) - (or scheme (setq scheme mc-default-scheme)) - (or userid (setq userid (cdr (assoc 'user-id (funcall scheme))))) - - ;; (goto-char (point-max)) - (if (not (bolp)) - (insert "\n")) - (funcall (cdr (assoc 'key-insertion-func (funcall scheme))) userid)) - -;;}}} -;;{{{ mc-snarf-keys - -;;;###autoload -(defun mc-snarf () - "*Add all public keys in the buffer to your keyring. - -Exact behavior depends on current major mode." - (interactive) - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'snarf mode-alist)) - 'mc-snarf-keys))) - (funcall func))) - -;;;###autoload -(defun mc-snarf-keys () - "*Add all public keys in the buffer to your keyring." - (interactive) - (let ((schemes mc-schemes) - (start (point-min)) - (found 0) - limits scheme) - (save-excursion - (catch 'done - (while t - (while (and schemes - (setq scheme (cdr (car schemes))) - (not - (setq - limits - (mc-message-delimiter-positions - (cdr (assoc 'key-begin-line (funcall scheme))) - (cdr (assoc 'key-end-line (funcall scheme))) - start)))) - (setq schemes (cdr schemes))) - (if (null limits) - (throw 'done found) - (setq start (cdr limits)) - (setq found (+ found (funcall (cdr (assoc 'snarf-func - (funcall scheme))) - (car limits) (cdr limits))))))) - (message (format "%d new key%s found" found - (if (eq 1 found) "" "s")))))) -;;}}} -;;}}} -;;{{{ Mode specific functions - -;;{{{ RMAIL -;;;###autoload -(defun mc-rmail-summary-verify-signature () - "*Verify the signature in the current message." - (interactive) - (if (not (eq major-mode 'rmail-summary-mode)) - (error - "mc-rmail-summary-verify-signature called in inappropriate buffer")) - (save-excursion - (set-buffer rmail-buffer) - (mc-verify))) - -;;;###autoload -(defun mc-rmail-summary-decrypt-message () - "*Decrypt the contents of this message" - (interactive) - (if (not (eq major-mode 'rmail-summary-mode)) - (error - "mc-rmail-summary-decrypt-message called in inappropriate buffer")) - (save-excursion - (set-buffer rmail-buffer) - (mc-decrypt))) - -;;;###autoload -(defun mc-rmail-summary-snarf-keys () - "*Adds keys from current message to public key ring" - (interactive) - (if (not (eq major-mode 'rmail-summary-mode)) - (error - "mc-rmail-summary-snarf-keys called in inappropriate buffer")) - (save-excursion - (set-buffer rmail-buffer) - (mc-snarf))) - -;;;###autoload -(defun mc-rmail-verify-signature () - "*Verify the signature in the current message." - (interactive) - (if (not (equal mode-name "RMAIL")) - (error "mc-rmail-verify-signature called in a non-RMAIL buffer")) - ;; Hack to load rmailkwd before verifying sig - (rmail-add-label "verified") - (rmail-kill-label "verified") - (if (mc-verify-signature) - (rmail-add-label "verified"))) - -;;;###autoload -(defun mc-rmail-decrypt-message () - "*Decrypt the contents of this message" - (interactive) - (let (decryption-result) - (if (not (equal mode-name "RMAIL")) - (error "mc-rmail-decrypt-message called in a non-RMAIL buffer")) - (unwind-protect - (progn - (rmail-edit-current-message) - (setq decryption-result (mc-decrypt-message)) - (cond ((not (car decryption-result)) - (rmail-abort-edit)) - ((and (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p - "Replace encrypted message with decrypted? "))) - (rmail-cease-edit) - (rmail-kill-label "edited") - (rmail-add-label "decrypted") - (if (cdr decryption-result) - (rmail-add-label "verified"))) - (t - (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*"))) - (copy-to-buffer tmp (point-min) (point-max)) - (rmail-abort-edit) - (switch-to-buffer tmp t) - (goto-char (point-min)) - (insert "From Mailcrypt-" mc-version " " - (current-time-string) "\n") - (rmail-convert-file) - (rmail-mode) - (use-local-map (copy-keymap (current-local-map))) - (local-set-key "q" 'mc-rmail-view-quit) - (set-buffer-modified-p nil))))) - (if (eq major-mode 'rmail-edit-mode) - (rmail-abort-edit))))) - -(defun mc-rmail-view-quit () - (interactive) - (let ((buf (current-buffer))) - (set-buffer-modified-p nil) - (rmail-quit) - (kill-buffer buf))) - -;;}}} -;;{{{ VM -;;;###autoload -(defun mc-vm-verify-signature () - "*Verify the signature in the current VM message" - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (save-restriction - (vm-widen-page) - (mc-verify-signature))) - -;;;###autoload -(defun mc-vm-decrypt-message () - "*Decrypt the contents of the current VM message" - (interactive) - (let ((vm-frame-per-edit nil) - from-line) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - - ;; store away a valid "From " line for possible later use. - (setq from-line (vm-leading-message-separator)) - (vm-edit-message) - (cond ((not (condition-case condition-data - (car (mc-decrypt-message)) - (error - (vm-edit-message-abort) - (error (message "Decryption failed: %s" - (car (cdr condition-data))))))) - (vm-edit-message-abort) - (error "Decryption failed.")) - ((and (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p "Replace encrypted message with decrypted? "))) - (let ((this-command 'vm-edit-message-end)) - (vm-edit-message-end))) - (t - (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*"))) - (copy-to-buffer tmp (point-min) (point-max)) - (vm-edit-message-abort) - (switch-to-buffer tmp t) - (goto-char (point-min)) - (insert from-line) - (set-buffer-modified-p nil) - (vm-mode t)))))) - -;;;###autoload -(defun mc-vm-snarf-keys () - "*Snarf public key from the contents of the current VM message" - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (save-restriction - (vm-widen-page) - (mc-snarf-keys))) - -;;}}} -;;{{{ GNUS - -;;;###autoload -(defun mc-gnus-verify-signature () - (interactive) - (gnus-summary-select-article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (save-restriction (widen) (mc-verify-signature)))) - -;;;###autoload -(defun mc-gnus-snarf-keys () - (interactive) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction (widen) (mc-snarf-keys)))) - -;;;###autoload -(defun mc-gnus-decrypt-message () - (interactive) - (gnus-summary-select-article) - ;; Gnus 5 has the string "Gnus" instead of "GNUS" in gnus-version. - (if (not (let ((case-fold-search nil)) - (string-match "Gnus" gnus-version))) - (gnus-eval-in-buffer-window - gnus-article-buffer - (save-restriction (widen) (mc-decrypt-message))) - ;; Gnus 5 allows editing of articles. (Actually, it makes a great - ;; mail reader.) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-summary-edit-article t) - (save-restriction - (widen) - (cond ((not (car (mc-decrypt-message))) - (gnus-summary-edit-article-postpone)) - ((and (not (gnus-group-read-only-p)) - (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p - "Replace encrypted message on disk? "))) - (gnus-summary-edit-article-done)) - (t - (gnus-summary-edit-article-postpone))))))) - -;;}}} -;;{{{ MH - -;;;###autoload -(defun mc-mh-decrypt-message () - "Decrypt the contents of the current MH message in the show buffer." - (interactive "P") - (let* ((msg (mh-get-msg-num t)) - (msg-filename (mh-msg-filename msg)) - (show-buffer (get-buffer mh-show-buffer)) - decrypt-okay decrypt-on-disk) - (setq - decrypt-on-disk - (and (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p "Replace encrypted message on disk? ")))) - (if decrypt-on-disk - (progn - (save-excursion - (set-buffer (create-file-buffer msg-filename)) - (insert-file-contents msg-filename t) - (if (setq decrypt-okay (car (mc-decrypt-message))) - (save-buffer) - (message "Decryption failed.") - (set-buffer-modified-p nil)) - (kill-buffer nil)) - (if decrypt-okay - (if (and show-buffer - (equal msg-filename (buffer-file-name show-buffer))) - (save-excursion - (save-window-excursion - (mh-invalidate-show-buffer))))) - (mh-show msg)) - (mh-show msg) - (save-excursion - (set-buffer mh-show-buffer) - (if (setq decrypt-okay (car (mc-decrypt-message))) - (progn - (goto-char (point-min)) - (set-buffer-modified-p nil)) - (message "Decryption failed."))) - (if (not decrypt-okay) - (progn - (mh-invalidate-show-buffer) - (mh-show msg)))))) - -;;;###autoload -(defun mc-mh-verify-signature () - "*Verify the signature in the current MH message." - (interactive) - (mh-show) - (mh-in-show-buffer (mh-show-buffer) - (mc-verify-signature))) - - -;;;###autoload -(defun mc-mh-snarf-keys () - (interactive) - (mh-show) - (mh-in-show-buffer (mh-show-buffer) - (mc-snarf-keys))) - -;;}}} - -;;}}} diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mel/ChangeLog --- a/lisp/mel/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,530 +0,0 @@ -1997-07-25 MORIOKA Tomohiko - - * MEL: Version 6.10.1 was released. - -1997-07-14 MORIOKA Tomohiko - - * mel-u.el (uuencode-external-decode-region): Use - `inhibit-read-only' instead of `(setq buffer-read-only nil)'. - -1997-07-09 Steven L Baur - - * mel-u.el (uuencode-external-decode-region): Force - buffer-read-only nil because it gets changed magically to t during - the call to `insert-file-contents'. - - -1997-07-14 MORIOKA Tomohiko - - * MEL: Version 6.10 was released. - -1997-07-14 MORIOKA Tomohiko - - * mel.el: Add autoload comments for command `mime-encode-region', - `mime-decode-region' and `mime-insert-encoded-file'. - -1997-07-13 MORIOKA Tomohiko - - * mel-q.el (quoted-printable-internal-encoding-limit): Change - initial value; 0 for XEmacs/mule; 1000 if mmencode is found; - otherwise nil; Don't use `quoted-printable-internal-encode-region' - for XEmacs/mule. - - * mel-q.el: Use `start' instead of `beg' for argument. - - * mel-q.el (quoted-printable-internal-encode-region): New - implementation. - - * mel-q.el (quoted-printable-quote-char): Change to `defsubst'; - use `aref'. - - * mel-q.el: Abolish unused function `byte-to-hex-string'. - -1997-07-01 Steven L Baur - - * mel/mel-q.el (q-encoding-encode-string): Fix Ebola-ified - comparison. (cf. [xemacs-beta:10342][tm-en:1367]) - - -1997-05-15 MORIOKA Tomohiko - - * MEL: Version 6.9.1 was released. - -Thu May 15 05:43:48 1997 MORIOKA Tomohiko - - * README.en (make install): Add LISPDIR. - -Tue May 13 14:59:52 1997 MORIOKA Tomohiko - - * Makefile (LISPDIR): New variable. - - * MEL-MK (config-mel): set LISPDIR. - - * MEL-CFG: Setting for load-path is modified. - - -1997-04-30 MORIOKA Tomohiko - - * MEL: Version 6.9 was released. - -Wed Apr 30 17:29:02 1997 MORIOKA Tomohiko - - * README.en (q-encoding-encode-string, q-encoding-decode-string): - Modify documentation. - -Wed Apr 30 17:24:32 1997 MORIOKA Tomohiko - - * mel.el, mel-q.el (q-encoding-encode-string, - q-encoding-decode-string): Add DOC-string. - -Wed Apr 30 17:14:46 1997 MORIOKA Tomohiko - - * mel.el (base64-insert-encoded-file, - quoted-printable-insert-encoded-file): Modify DOC-string. - - * mel-q.el (quoted-printable-insert-encoded-file): Add DOC-string. - -Wed Apr 30 17:09:57 1997 MORIOKA Tomohiko - - * mel-q.el (quoted-printable-encode-region, - quoted-printable-decode-region): Add DOC-string. - - * mel.el: Add autoload for `quoted-printable-encode-string' and - `quoted-printable-decode-string'. - - * mel-q.el (quoted-printable-encode-string, - quoted-printable-decode-string): Add DOC-string. - -Wed Apr 30 13:23:00 1997 MORIOKA Tomohiko - - * mel.el (base64-insert-encoded-file): DOC-string was modified. - - * mel-b.el (base64-insert-encoded-file): Add DOC-string. - -Wed Apr 30 13:15:12 1997 MORIOKA Tomohiko - - * mel-b.el (base64-encode-region, base64-decode-region): Add - DOC-string. - -Wed Apr 30 13:01:16 1997 MORIOKA Tomohiko - - * mel.el (base64-encode-string, base64-decode-string): Add - DOC-string. - - * mel-b.el (base64-encode-string, base64-decode-string): Add - DOC-string. - - * mel.el: autoload for `q-encoding-encode-string-for-text', - `q-encoding-encode-string-for-comment' and - `q-encoding-encode-string-for-phrase' were abolished. - -Tue Apr 29 11:47:35 1997 MORIOKA Tomohiko - - * README.en: New file. - - -1997-03-14 MORIOKA Tomohiko - - * MEL: Version 6.3 was released. - -Fri Mar 14 07:40:13 1997 MORIOKA Tomohiko - - * MEL-MK (config-mel): New function; load "MEL-CFG". - - * MEL-CFG: New file. - -Wed Mar 12 06:31:16 1997 MORIOKA Tomohiko - - * MEL-MK: mk-mel was renamed to MEL-MK. - -Mon Mar 10 15:15:09 1997 MORIOKA Tomohiko - - * mel-u.el: Variable `mime/tmp-dir' was abolished. - - Require mel. - - (uuencode-external-decoder): Use variable `mime-temp-directory' - instead of `mime/tmp-dir'. - - (uuencode-external-decode-region): Use variable - `mime-temp-directory' instead of `mime/tmp-dir'. - - * mel.el (mime-temp-directory): New variable. - - * mel-u.el (uuencode-external-decode-region): Use - `as-binary-input-file'. - - -1997-03-10 MORIOKA Tomohiko - - * MEL: Version 6.2.3 was released. - - * mel-g.el (gzip64-external-encoder, gzip64-external-decoder): Use - `exec-installed-p' instead of `file-installed-p' to search - mmencode. - - -1997-03-03 MORIOKA Tomohiko - - * MEL: Version 6.2.2 was released. - - * mel-g.el (gzip64-external-encoder, gzip64-external-decoder): - Search mmencode from `exec-path'. (cf. [xemacs-beta:3730]) - - -Wed Jan 1 11:01:44 1997 MORIOKA Tomohiko - - * MEL: Version 6.2.1 was released. - -Wed Dec 28 13:57:22 1996 Martin Buchholz - - * mk-mel: Use variable `default-directory' instead of `(getenv - "PWD")'. (cf. [tm-en:1084]) - - * Makefile: A makefile command like `cd some-dir; do-something' is - generally better written as: `cd some-dir && do-something' since - if the cd fails (usually because of a coding or file-system error) - the do-something is not executed in the wrong - directory. (cf. [tm-en:1084]) - - -Wed Dec 25 06:30:59 1996 MORIOKA Tomohiko - - * MEL: Version 6.2 was released. - - * mel.el (mime-encoding-method-alist, mime-decoding-method-alist, - mime-file-encoding-method-alist): Add DOC-string. - -Wed Dec 25 01:08:47 1996 Steven L Baur - - * mel.el: to decode `x-uuencode'. (cf. [tm-en:1062]) - - -Thu Oct 31 16:05:41 1996 MORIOKA Tomohiko - - * MEL: Version 6.0.1 was released. - -Mon Oct 28 12:53:09 1996 MORIOKA Tomohiko - - * mel-q.el (quoted-printable-insert-encoded-file): New constant. - (q-encoding-encode-string): New implementation; Function - `q-encoding-encode-string-for-text', - `q-encoding-encode-string-for-comment' and - `q-encoding-encode-string-for-phrase' were abolished. - - -Mon Sep 23 16:53:19 1996 MORIOKA Tomohiko - - * MEL: Version 6.0 was released. - - * mel.el (mime-file-encoding-method-alist): Use function - `insert-binary-file-contents-literally'. - - -Fri Aug 23 07:31:32 1996 MORIOKA Tomohiko - - * MEL: Version 5.6.1 was released. - -Thu Aug 22 14:49:14 1996 MORIOKA Tomohiko - - * MEL-ELS: Variable `mel-el-files' and `mel-elc-files' were - abolished. - -Thu Aug 22 14:47:45 1996 MORIOKA Tomohiko - - * mk-mel: Variable `el-file-mode' was abolished. - Function `install-el', `install-el-files', `install-elc' and - `install-elc-files' were abolished. - (install-mel): Use function `install-elisp-modules'. - -Mon Aug 19 16:55:27 1996 MORIOKA Tomohiko - - * mk-mel (compile-mel): Use function `compile-elisp-modules'. - -Mon Aug 19 16:53:14 1996 MORIOKA Tomohiko - - * MEL-ELS (mel-modules): changed to list of symbols. - - * mk-mel: mel-els was renamed to MEL-ELS. - - -Thu Jun 27 22:28:57 1996 MORIOKA Tomohiko - - * MEL: Version 5.6 was released. - -Wed Jun 26 16:25:13 1996 MORIOKA Tomohiko - - * mel-g.el (gzip64-external-encode-region): regularize line break - code (for OS/2). - -Wed Jun 26 16:23:39 1996 MORIOKA Tomohiko - - * mel-g.el (gzip64-external-encode-region): Use macro - `as-binary-process'. - (gzip64-external-decode-region): Use macro `as-binary-process'. - -Wed Jun 26 16:21:11 1996 MORIOKA Tomohiko - - * mel-u.el (uuencode-external-encode-region): regularize line - break code (for OS/2). - -Wed Jun 26 16:18:39 1996 MORIOKA Tomohiko - - * mel-u.el (uuencode-external-encode-region): Use macro - `as-binary-process'. - (uuencode-external-decode-region): Use macro `as-binary-process'. - -Wed Jun 26 16:13:39 1996 MORIOKA Tomohiko - - * mel-q.el (quoted-printable-external-encode-region): Use macro - `as-binary-process'. - (quoted-printable-external-decode-region): Use macro - `as-binary-process'. - - * mel-b.el (base64-external-encode-region): Use macro - `as-binary-process'. - (base64-external-decode-region): Use macro `as-binary-process'. - -Wed Jun 12 05:30:23 1996 MORIOKA Tomohiko - - * MEL: Version 5.5 was released. - -Mon Jun 10 05:06:27 1996 MORIOKA Tomohiko - - * mel-q.el (q-encoding-printable-char-p): New function. - - (q-encoding-encoded-length): Use function - `q-encoding-printable-char-p'. - - -Sun Jun 9 04:10:08 1996 MORIOKA Tomohiko - - * MEL: Version 5.4 was released. - -Fri Jun 7 14:06:59 1996 MORIOKA Tomohiko - - * mel-g.el (gzip64-external-encode-region): fixed. - (gzip64-external-decode-region): fixed. - -Fri Jun 7 14:04:09 1996 MORIOKA Tomohiko - - * mel-q.el (quoted-printable-external-encode-region): fixed. - (quoted-printable-external-decode-region): fixed. - -Fri Jun 7 12:12:47 1996 MORIOKA Tomohiko - - * mel-u.el (uuencode-external-encode-region): fixed. - (uuencode-external-decode-region): fixed. - -Thu Jun 6 08:46:55 1996 MORIOKA Tomohiko - - * mel.el (mime-file-encoding-method-alist): New variable. - (mime-insert-encoded-file): New function. - - * mel-g.el (gzip64-external-encode-region): fixed - `default-process-coding-system'. - - (gzip64-external-decode-region): fixed - `default-process-coding-system'. - -Thu Jun 6 07:51:30 1996 MORIOKA Tomohiko - - * mel-u.el (uuencode-external-encode-region): fixed - `default-process-coding-system'. - - (uuencode-external-decode-region): fixed - `default-process-coding-system'. - -Thu Jun 6 07:48:44 1996 MORIOKA Tomohiko - - * mel-q.el (quoted-printable-external-encode-region): fixed - `default-process-coding-system'. - - (quoted-printable-external-decode-region): fixed - `default-process-coding-system'. - -Thu Jun 6 07:09:23 1996 MORIOKA Tomohiko - - * mel-b.el (base64-external-encode-region): fixed - `default-process-coding-system'. - - (base64-external-decode-region): fixed - `default-process-coding-system'. - - -Mon Jun 3 14:43:47 1996 MORIOKA Tomohiko - - * MEL: Version 5.2 was released. - -Wed May 29 12:54:45 1996 MORIOKA Tomohiko - - * mel-g.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (gzip64-external-encode-region): set for process code. - (gzip64-external-decode-region): set for process code. - -Wed May 29 12:49:41 1996 MORIOKA Tomohiko - - * mel-u.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (uuencode-external-encode-region): set for process code. - (uuencode-external-decode-region): set for process code. - -Wed May 29 12:40:12 1996 MORIOKA Tomohiko - - * mel-q.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (quoted-printable-external-encode-region): set for process code. - (quoted-printable-external-decode-region): set for process code. - -Wed May 29 10:54:01 1996 MORIOKA Tomohiko - - * mel-b.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (base64-external-encode-region): set for process code. - (base64-external-decode-region): set for process code. - -Wed May 29 08:10:15 1996 MORIOKA Tomohiko - - * mel-g.el (gzip64-insert-encoded-file): New function. - -Wed May 29 08:00:01 1996 MORIOKA Tomohiko - - * mel-g.el: Shuhei KOBAYASHI's address was changed. - - * mel-u.el (uuencode-insert-encoded-file): New function. - -Wed May 29 07:30:48 1996 MORIOKA Tomohiko - - * mel-q.el (quoted-printable-insert-encoded-file): New function. - - * mel-b.el (base64-insert-encoded-file): New function. - - -Tue May 28 03:31:13 1996 MORIOKA Tomohiko - - * MEL: Version 5.0 was released. - - * mel.el: Function `mime/encode-region' and `mime/decode-region' - were abolished. - - -Thu May 23 01:32:04 1996 MORIOKA Tomohiko - - * MEL: Version 4.7.1 was released. - -Wed May 22 02:20:35 1996 MORIOKA Tomohiko - - * mel.el (mime-encode-region): New function; Order of arguments - was changed. - (mime-decode-region): New function; Order of arguments was - changed. - (mime/encode-region): New implementation. - (mime/decode-region): New implementation. - - -Wed May 15 21:19:12 1996 MORIOKA Tomohiko - - * MEL: Version 4.7 was released. - - * mel-b.el (base64-internal-decode-region): fixed about last line - which does not have line break. - - -Tue May 14 02:43:41 1996 MORIOKA Tomohiko - - * MEL: Version 4.6 was released. - -Sun May 12 17:43:04 1996 MORIOKA Tomohiko - - * mel-b.el (base64-decode-1): New spec; Argument was changed; - Return string instead of list of characters. - (base64-decode-string): modified for new spec of function - `base64-decode-1'. - (base64-internal-decode-region): fixed. - -Sun May 12 17:05:17 1996 MORIOKA Tomohiko - - * mel-b.el (base64-encode-1): New spec; Argument was changed; - Return string instead of list of characters. - (base64-encode-string): modified for new spec of function - `base64-encode-1'. - (base64-internal-decode-region): fixed. - -Sun May 12 16:17:11 1996 MORIOKA Tomohiko - - * mel-b.el: Function `base64-encode-chars' was abolished. - (base64-encode-1): New spec; use function `base64-num-to-char. - (base64-encode-string): Use function `base64-encode-1' instead of - `base64-encode-chars'. - -Sun May 12 15:50:26 1996 MORIOKA Tomohiko - - * mel-b.el: Function `base64-decode-chars' was abolished. - (base64-decode-1): New spec; use function `base64-char-to-num'. - (base64-decode-string): Use function `base64-decode-1' instead of - `base64-decode-chars'. - - -Sat May 11 08:12:23 1996 MORIOKA Tomohiko - - * MEL: Version 4.2 was released. - - * mel-b.el (base64-encode-1): don't use function `base64-mask'. - Function `base64-mask' was abolished. - -Sat May 11 07:52:05 1996 MORIOKA Tomohiko - - * mel-b.el (base64-decode-1): don't use function `base64-mask'. - -Sat May 11 06:35:20 1996 MORIOKA Tomohiko - - * mel-b.el (base64-internal-decode-region): New implementation. - - -Wed Mar 13 16:40:46 1996 MORIOKA Tomohiko - - * MEL: Version 3.5 was released. - -Mon Mar 11 14:29:31 1996 MORIOKA Tomohiko - - * mel-q.el (byte-to-hex-string): New function. - -Tue Mar 12 11:19:02 1996 Shuhei KOBAYASHI - - * mel-els (mel-modules): "mel-g" was added. (cf.[tm-ja:1661]) - - * mel.el: gzip64 support was added. (cf.[tm-ja:1661]) - - * mel-g.el: New file. - gzip64 encoder/decoder. `gzip64' is an experimental encoding. - (cf.[tm-ja:1661]) - - -Mon Mar 4 09:13:20 1996 Morioka Tomohiko - - * MEL: Version 3.3.1 was released. - - * mel-els: New module - - * mk-mel: use mel-els file. - -Thu Jan 18 10:26:38 1996 Morioka Tomohiko - - * Makefile: Yoshiyuki Yamagami 's patch - was applied to specify `-no-site-file' option. (cf. [tm-ja:1474]) - -Thu Jan 18 01:55:25 1996 Yoshiyuki Yamagami - - * Makefile: specify `-no-site-file' option (cf. [tm-ja:1474]) - - -Wed Jan 9 19:09:44 1996 Morioka Tomohiko - - * MEL: version 3.3 was released. - -Tue Jan 9 18:25:22 1996 Morioka Tomohiko - - * mel-u.el (uuencode-external-decode-region): - don't display uuencode output. - (cf. [tm-en:253]) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mel/auto-autoloads.el --- a/lisp/mel/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'mel-autoloads) (error "Already loaded")) - -;;;### (autoloads (mime-insert-encoded-file mime-decode-region mime-encode-region) "mel" "mel/mel.el") - -(autoload 'mime-encode-region "mel" "\ -Encode region START to END of current buffer using ENCODING." t nil) - -(autoload 'mime-decode-region "mel" "\ -Decode region START to END of current buffer using ENCODING." t nil) - -(autoload 'mime-insert-encoded-file "mel" "\ -Insert file FILENAME encoded by ENCODING format." t nil) - -;;;*** - -(provide 'mel-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mel/mel-b.el --- a/lisp/mel/mel-b.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,309 +0,0 @@ -;;; mel-b.el: Base64 encoder/decoder for GNU Emacs - -;; Copyright (C) 1992,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: ENAMI Tsugutomo -;; MORIOKA Tomohiko -;; Maintainer: MORIOKA Tomohiko -;; Created: 1995/6/24 -;; Version: $Id: mel-b.el,v 1.3 1997/06/06 00:57:14 steve Exp $ -;; Keywords: MIME, Base64 - -;; This file is part of MEL (MIME Encoding Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) - - -;;; @ variables -;;; - -(defvar base64-external-encoder '("mmencode") - "*list of base64 encoder program name and its arguments.") - -(defvar base64-external-decoder '("mmencode" "-u") - "*list of base64 decoder program name and its arguments.") - -(defvar base64-internal-encoding-limit 1000 - "*limit size to use internal base64 encoder. -If size of input to encode is larger than this limit, -external encoder is called.") - -(defvar base64-internal-decoding-limit 1000 - "*limit size to use internal base64 decoder. -If size of input to decode is larger than this limit, -external decoder is called.") - - -;;; @ internal base64 decoder/encoder -;;; based on base64 decoder by Enami Tsugutomo - -;;; @@ convert from/to base64 char -;;; - -(defun base64-num-to-char (n) - (cond ((eq n nil) ?=) - ((< n 26) (+ ?A n)) - ((< n 52) (+ ?a (- n 26))) - ((< n 62) (+ ?0 (- n 52))) - ((= n 62) ?+) - ((= n 63) ?/) - (t (error "not a base64 integer %d" n)))) - -(defun base64-char-to-num (c) - (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A)) - ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26)) - ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52)) - ((= c ?+) 62) - ((= c ?/) 63) - ((= c ?=) nil) - (t (error "not a base64 character %c" c)))) - - -;;; @@ encode/decode one base64 unit -;;; - -(defun base64-encode-1 (pack) - (let ((a (car pack)) - (b (nth 1 pack)) - (c (nth 2 pack))) - (concat - (char-to-string (base64-num-to-char (ash a -2))) - (if b - (concat - (char-to-string - (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4)))) - (if c - (concat - (char-to-string - (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6)))) - (char-to-string (base64-num-to-char (logand c 63))) - ) - (concat (char-to-string - (base64-num-to-char (ash (logand b 15) 2))) "=") - )) - (concat (char-to-string - (base64-num-to-char (ash (logand a 3) 4))) "==") - )))) - -(defun base64-decode-1 (pack) - (let ((a (base64-char-to-num (car pack))) - (b (base64-char-to-num (nth 1 pack))) - (c (nth 2 pack)) - (d (nth 3 pack))) - (concat (char-to-string (logior (ash a 2) (ash b -4))) - (if (and c (setq c (base64-char-to-num c))) - (concat (char-to-string - (logior (ash (logand b 15) 4) (ash c -2))) - (if (and d (setq d (base64-char-to-num d))) - (char-to-string (logior (ash (logand c 3) 6) d)) - )))))) - - -;;; @@ base64 encoder/decoder for string -;;; - -(defun base64-encode-string (string) - "Encode STRING to base64, and return the result." - (let ((len (length string)) - (b 0)(e 57) - dest) - (while (< e len) - (setq dest - (concat dest - (mapconcat - (function base64-encode-1) - (pack-sequence (substring string b e) 3) - "") - "\n")) - (setq b e - e (+ e 57) - ) - ) - (let* ((es (mapconcat - (function base64-encode-1) - (pack-sequence (substring string b) 3) - "")) - (m (mod (length es) 4)) - ) - (concat dest es (cond ((= m 3) "=") - ((= m 2) "==") - )) - ))) - -(defun base64-decode-string (string) - "Decode STRING which is encoded in base64, and return the result." - (mapconcat (function base64-decode-1) - (pack-sequence string 4) - "")) - - -;;; @ base64 encoder/decoder for region -;;; - -(defun base64-internal-encode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let ((str (buffer-substring beg end))) - (delete-region beg end) - (insert (base64-encode-string str)) - ) - (or (bolp) - (insert "\n") - ) - ))) - -(defun base64-internal-decode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (looking-at ".*\n") - (condition-case err - (replace-match - (base64-decode-string - (buffer-substring (match-beginning 0) (1- (match-end 0)))) - t t) - (error - (prog1 - (message (nth 1 err)) - (replace-match ""))))) - (if (looking-at ".*$") - (condition-case err - (replace-match - (base64-decode-string - (buffer-substring (match-beginning 0) (match-end 0))) - t t) - (error - (prog1 - (message (nth 1 err)) - (replace-match ""))) - )) - ))) - -(defun base64-external-encode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (as-binary-process (apply (function call-process-region) - beg end (car base64-external-encoder) - t t nil (cdr base64-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - ))) - -(defun base64-external-decode-region (beg end) - (save-excursion - (as-binary-process (apply (function call-process-region) - beg end (car base64-external-decoder) - t t nil (cdr base64-external-decoder)) - ))) - -(defun base64-encode-region (start end) - "Encode current region by base64. -START and END are buffer positions. -This function calls internal base64 encoder if size of region is -smaller than `base64-internal-encoding-limit', otherwise it calls -external base64 encoder specified by `base64-external-encoder'. In -this case, you must install the program (maybe mmencode included in -metamail or XEmacs package)." - (interactive "r") - (if (and base64-internal-encoding-limit - (> (- end start) base64-internal-encoding-limit)) - (base64-external-encode-region start end) - (base64-internal-encode-region start end) - )) - -(defun base64-decode-region (start end) - "Decode current region by base64. -START and END are buffer positions. -This function calls internal base64 decoder if size of region is -smaller than `base64-internal-decoding-limit', otherwise it calls -external base64 decoder specified by `base64-external-decoder'. In -this case, you must install the program (maybe mmencode included in -metamail or XEmacs package)." - (interactive "r") - (if (and base64-internal-decoding-limit - (> (- end start) base64-internal-decoding-limit)) - (base64-external-decode-region start end) - (base64-internal-decode-region start end) - )) - - -;;; @ base64 encoder/decoder for file -;;; - -(defun base64-insert-encoded-file (filename) - "Encode contents of file FILENAME to base64, and insert the result. -It calls external base64 encoder specified by -`base64-external-encoder'. So you must install the program (maybe -mmencode included in metamail or XEmacs package)." - (interactive (list (read-file-name "Insert encoded file: "))) - (apply (function call-process) (car base64-external-encoder) - filename t nil (cdr base64-external-encoder)) - ) - - -;;; @ etc -;;; - -(defun base64-encoded-length (string) - (let ((len (length string))) - (* (+ (/ len 3) - (if (= (mod len 3) 0) 0 1) - ) 4) - )) - -(defun pack-sequence (seq size) - "Split sequence SEQ into SIZE elements packs, -and return list of packs. [mel-b; tl-seq function]" - (let ((len (length seq)) (p 0) obj - unit (i 0) - dest) - (while (< p len) - (setq obj (elt seq p)) - (setq unit (cons obj unit)) - (setq i (1+ i)) - (if (= i size) - (progn - (setq dest (cons (reverse unit) dest)) - (setq unit nil) - (setq i 0) - )) - (setq p (1+ p)) - ) - (if unit - (setq dest (cons (reverse unit) dest)) - ) - (reverse dest) - )) - - -;;; @ end -;;; - -(provide 'mel-b) - -;;; mel-b.el ends here. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mel/mel-g.el --- a/lisp/mel/mel-g.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,101 +0,0 @@ -;;; mel-g.el: Gzip64 encoder/decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko -;; Copyright (C) 1996 Shuhei KOBAYASHI - -;; Author: Shuhei KOBAYASHI -;; modified by MORIOKA Tomohiko -;; Maintainer: Shuhei KOBAYASHI -;; Created: 1995/10/25 -;; Version: $Id: mel-g.el,v 1.5 1997/03/16 03:05:14 steve Exp $ -;; Keywords: Gzip64, base64, gzip, MIME - -;; This file is not part of MEL (MIME Encoding Library) yet. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'file-detect) - - -;;; @ variables -;;; - -(defvar gzip64-external-encoder - (let ((file (exec-installed-p "mmencode"))) - (and file - (` ("sh" "-c" (, (concat "gzip -c | " file)))) - )) - "*list of gzip64 encoder program name and its arguments.") - -(defvar gzip64-external-decoder - (let ((file (exec-installed-p "mmencode"))) - (and file - (` ("sh" "-c" (, (concat file " -u | gzip -dc")))) - )) - "*list of gzip64 decoder program name and its arguments.") - - -;;; @ encoder/decoder for region -;;; - -(defun gzip64-external-encode-region (beg end) - (interactive "*r") - (save-excursion - (as-binary-process (apply (function call-process-region) - beg end (car gzip64-external-encoder) - t t nil (cdr gzip64-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - )) - -(defun gzip64-external-decode-region (beg end) - (interactive "*r") - (save-excursion - (as-binary-process (apply (function call-process-region) - beg end (car gzip64-external-decoder) - t t nil (cdr gzip64-external-decoder)) - ) - )) - -(defalias 'gzip64-encode-region 'gzip64-external-encode-region) -(defalias 'gzip64-decode-region 'gzip64-external-decode-region) - - -;;; @ encoder/decoder for file -;;; - -(defun gzip64-insert-encoded-file (filename) - (interactive (list (read-file-name "Insert encoded file: "))) - (apply (function call-process) (car gzip64-external-encoder) - filename t nil - (cdr gzip64-external-encoder)) - ) - - -;;; @ end -;;; - -(provide 'mel-g) - -;;; mel-g.el ends here. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mel/mel-q.el --- a/lisp/mel/mel-q.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,335 +0,0 @@ -;;; mel-q.el: Quoted-Printable and Q-encoding encoder/decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1995/6/25 -;; Version: $Id: mel-q.el,v 1.5 1997/07/26 22:09:47 steve Exp $ -;; Keywords: MIME, Quoted-Printable, Q-encoding - -;; This file is part of MEL (MIME Encoding Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) - - -;;; @ Quoted-Printable encoder -;;; - -(defconst quoted-printable-hex-chars "0123456789ABCDEF") - -(defsubst quoted-printable-quote-char (character) - (concat - "=" - (char-to-string (aref quoted-printable-hex-chars (ash character -4))) - (char-to-string (aref quoted-printable-hex-chars (logand character 15))) - )) - -(defun quoted-printable-internal-encode-region (start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (let ((col 0) - enable-multibyte-characters) - (while (< (point)(point-max)) - (cond ((>= col 75) - (insert "=\n") - (setq col 0) - ) - ((looking-at "^From ") - (replace-match "=46rom ") - (backward-char 1) - (setq col (+ col 6)) - ) - ((looking-at "[ \t]\n") - (forward-char 1) - (insert "=\n") - (forward-char 1) - (setq col 0) - ) - (t - (let ((chr (char-after (point)))) - (cond ((= chr ?\n) - (forward-char 1) - (setq col 0) - ) - ((or (= chr ?\t) - (and (<= 32 chr)(/= chr ?=)(< chr 127)) - ) - (forward-char 1) - (setq col (1+ col)) - ) - ((>= col 73) - (insert "=\n") - (setq col 0) - ) - (t - (delete-char 1) - (insert (quoted-printable-quote-char chr)) - (setq col (+ col 3)) - )) - ))) - ))))) - -(defvar quoted-printable-external-encoder '("mmencode" "-q") - "*list of quoted-printable encoder program name and its arguments.") - -(defun quoted-printable-external-encode-region (start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (as-binary-process - (apply (function call-process-region) - start end (car quoted-printable-external-encoder) - t t nil (cdr quoted-printable-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - ))) - -(defvar quoted-printable-internal-encoding-limit - (if (and (featurep 'xemacs)(featurep 'mule)) - 0 - (require 'file-detect) - (if (exec-installed-p "mmencode") - 1000 - (message "Don't found external encoder for Quoted-Printable!") - nil)) - "*limit size to use internal quoted-printable encoder. -If size of input to encode is larger than this limit, -external encoder is called.") - -(defun quoted-printable-encode-region (start end) - "Encode current region by quoted-printable. -START and END are buffer positions. -This function calls internal quoted-printable encoder if size of -region is smaller than `quoted-printable-internal-encoding-limit', -otherwise it calls external quoted-printable encoder specified by -`quoted-printable-external-encoder'. In this case, you must install -the program (maybe mmencode included in metamail or XEmacs package)." - (interactive "r") - (if (and quoted-printable-internal-encoding-limit - (> (- end start) quoted-printable-internal-encoding-limit)) - (quoted-printable-external-encode-region start end) - (quoted-printable-internal-encode-region start end) - )) - -(defun quoted-printable-encode-string (string) - "Encode STRING to quoted-printable, and return the result." - (with-temp-buffer - (insert string) - (quoted-printable-encode-region (point-min)(point-max)) - (buffer-string) - )) - -(defun quoted-printable-insert-encoded-file (filename) - "Encode contents of file FILENAME to quoted-printable, and insert the result. -It calls external quoted-printable encoder specified by -`quoted-printable-external-encoder'. So you must install the program -\(maybe mmencode included in metamail or XEmacs package)." - (interactive (list (read-file-name "Insert encoded file: "))) - (apply (function call-process) (car quoted-printable-external-encoder) - filename t nil (cdr quoted-printable-external-encoder)) - ) - - -;;; @ Quoted-Printable decoder -;;; - -(defun quoted-printable-decode-string (string) - "Decode STRING which is encoded in quoted-printable, and return the result." - (let (q h l) - (mapconcat (function - (lambda (chr) - (cond ((eq chr ?=) - (setq q t) - "") - (q (setq h - (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (setq q nil) - "") - (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (prog1 - (char-to-string (logior (ash h 4) l)) - (setq h nil) - ) - ) - (t (char-to-string chr)) - ))) - string ""))) - -(defconst quoted-printable-octet-regexp - (concat "=[" quoted-printable-hex-chars - "][" quoted-printable-hex-chars "]")) - -(defun quoted-printable-internal-decode-region (start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (re-search-forward "=\n" nil t) - (replace-match "") - ) - (goto-char (point-min)) - (let (b e str) - (while (re-search-forward quoted-printable-octet-regexp nil t) - (setq b (match-beginning 0)) - (setq e (match-end 0)) - (setq str (buffer-substring b e)) - (delete-region b e) - (insert (quoted-printable-decode-string str)) - )) - ))) - -(defvar quoted-printable-external-decoder '("mmencode" "-q" "-u") - "*list of quoted-printable decoder program name and its arguments.") - -(defun quoted-printable-external-decode-region (start end) - (save-excursion - (as-binary-process - (apply (function call-process-region) - start end (car quoted-printable-external-decoder) - t t nil (cdr quoted-printable-external-decoder)) - ))) - -(defvar quoted-printable-internal-decoding-limit nil - "*limit size to use internal quoted-printable decoder. -If size of input to decode is larger than this limit, -external decoder is called.") - -(defun quoted-printable-decode-region (start end) - "Decode current region by quoted-printable. -START and END are buffer positions. -This function calls internal quoted-printable decoder if size of -region is smaller than `quoted-printable-internal-decoding-limit', -otherwise it calls external quoted-printable decoder specified by -`quoted-printable-external-decoder'. In this case, you must install -the program (maybe mmencode included in metamail or XEmacs package)." - (interactive "r") - (if (and quoted-printable-internal-decoding-limit - (> (- end start) quoted-printable-internal-decoding-limit)) - (quoted-printable-external-decode-region start end) - (quoted-printable-internal-decode-region start end) - )) - - -;;; @ Q-encoding encode/decode string -;;; - -(defconst q-encoding-special-chars-alist - '((text ?= ?? ?_) - (comment ?= ?? ?_ ?\( ?\) ?\\) - (phrase ?= ?? ?_ ?\( ?\) ?\\ ?\" ?# ?$ ?% ?& ?' ?, ?. ?/ - ?: ?\; ?< ?> ?@ ?\[ ?\] ?^ ?` ?{ ?| ?} ?~) - )) - -(defun q-encoding-encode-string (string &optional mode) - "Encode STRING to Q-encoding of encoded-word, and return the result. -MODE allows `text', `comment', `phrase' or nil. Default value is -`phrase'." - (let ((specials (cdr (or (assq mode q-encoding-special-chars-alist) - (assq 'phrase q-encoding-special-chars-alist) - )))) - (mapconcat (function - (lambda (chr) - (cond ((eq chr ? ) "_") - ((or (< chr 32) (< 126 chr) - (memq chr specials) - ) - (quoted-printable-quote-char chr) - ) - (t - (char-to-string chr) - )) - )) - string "") - )) - -(defun q-encoding-decode-string (string) - "Decode STRING which is encoded in Q-encoding and return the result." - (let (q h l) - (mapconcat (function - (lambda (chr) - (cond ((eq chr ?_) " ") - ((eq chr ?=) - (setq q t) - "") - (q (setq h (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (setq q nil) - "") - (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (prog1 - (char-to-string (logior (ash h 4) l)) - (setq h nil) - ) - ) - (t (char-to-string chr)) - ))) - string ""))) - - -;;; @@ etc -;;; - -(defun q-encoding-printable-char-p (chr mode) - (and (not (memq chr '(?= ?? ?_))) - (<= ?\ chr)(<= chr ?~) - (cond ((eq mode 'text) t) - ((eq mode 'comment) - (not (memq chr '(?\( ?\) ?\\))) - ) - (t - (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr)) - )))) - -(defun q-encoding-encoded-length (string &optional mode) - (let ((l 0)(i 0)(len (length string)) chr) - (while (< i len) - (setq chr (elt string i)) - (if (q-encoding-printable-char-p chr mode) - (setq l (+ l 1)) - (setq l (+ l 3)) - ) - (setq i (+ i 1)) ) - l)) - - -;;; @ end -;;; - -(provide 'mel-q) - -;;; mel-q.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mel/mel-u.el --- a/lisp/mel/mel-u.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -;;; mel-u.el: uuencode encoder/decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1995/10/25 -;; Version: $Id: mel-u.el,v 1.5 1997/07/26 22:09:47 steve Exp $ -;; Keywords: uuencode - -;; This file is part of MEL (MIME Encoding Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'mel) - - -;;; @ variables -;;; - -(defvar uuencode-external-encoder '("uuencode" "-") - "*list of uuencode encoder program name and its arguments.") - -(defvar uuencode-external-decoder - (list "sh" "-c" (format "(cd %s; uudecode)" mime-temp-directory)) - "*list of uuencode decoder program name and its arguments.") - - -;;; @ uuencode encoder/decoder for region -;;; - -(defun uuencode-external-encode-region (start end) - "Encode current region by unofficial uuencode format. -This function uses external uuencode encoder which is specified by -variable `uuencode-external-encoder'." - (interactive "*r") - (save-excursion - (as-binary-process (apply (function call-process-region) - start end (car uuencode-external-encoder) - t t nil (cdr uuencode-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - )) - -(defun uuencode-external-decode-region (start end) - "Decode current region by unofficial uuencode format. -This function uses external uuencode decoder which is specified by -variable `uuencode-external-decoder'." - (interactive "*r") - (save-excursion - (let ((filename (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (if (re-search-forward "^begin [0-9]+ " nil t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0) - (match-end 0)) - )))))) - (if filename - (as-binary-process - (apply (function call-process-region) - start end (car uuencode-external-decoder) - t nil nil (cdr uuencode-external-decoder)) - (setq filename (expand-file-name filename mime-temp-directory)) - (as-binary-input-file (insert-file-contents filename)) - ;; The previous line causes the buffer to be made read-only, I - ;; do not pretend to understand the control flow leading to this - ;; but suspect it has something to do with image-mode. -slb - ;; Use `inhibit-read-only' to avoid to force - ;; buffer-read-only nil. - tomo. - (let ((inhibit-read-only t)) - (delete-file filename) - ) - )) - ))) - -(defalias 'uuencode-encode-region 'uuencode-external-encode-region) -(defalias 'uuencode-decode-region 'uuencode-external-decode-region) - - -;;; @ uuencode encoder/decoder for file -;;; - -(defun uuencode-insert-encoded-file (filename) - "Insert file encoded by unofficial uuencode format. -This function uses external uuencode encoder which is specified by -variable `uuencode-external-encoder'." - (interactive (list (read-file-name "Insert encoded file: "))) - (call-process (car uuencode-external-encoder) filename t nil - (file-name-nondirectory filename)) - ) - - -;;; @ end -;;; - -(provide 'mel-u) - -;;; mel-u.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mel/mel.el --- a/lisp/mel/mel.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ -;;; mel.el : a MIME encoding/decoding library - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; modified by Shuhei KOBAYASHI -;; Created: 1995/6/25 -;; Version: $Id: mel.el,v 1.5 1997/07/26 22:09:47 steve Exp $ -;; Keywords: MIME, Base64, Quoted-Printable, uuencode, gzip64 - -;; This file is part of MEL (MIME Encoding Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; @ variable -;;; - -(defvar mime-temp-directory (or (getenv "MIME_TMP_DIR") - (getenv "TM_TMP_DIR") - "/tmp/") - "*Directory for temporary files.") - - -;;; @ region -;;; - -(autoload 'base64-encode-region - "mel-b" "Encode current region by base64." t) -(autoload 'quoted-printable-encode-region - "mel-q" "Encode current region by Quoted-Printable." t) -(autoload 'uuencode-encode-region - "mel-u" "Encode current region by unofficial uuencode format." t) -(autoload 'gzip64-encode-region - "mel-g" "Encode current region by unofficial x-gzip64 format." t) - -(defvar mime-encoding-method-alist - '(("base64" . base64-encode-region) - ("quoted-printable" . quoted-printable-encode-region) - ("x-uue" . uuencode-encode-region) - ("x-gzip64" . gzip64-encode-region) - ("7bit") - ("8bit") - ("binary") - ) - "Alist of encoding vs. corresponding method to encode region. -Each element looks like (STRING . FUNCTION) or (STRING . nil). -STRING is content-transfer-encoding. -FUNCTION is region encoder and nil means not to encode.") - - -(autoload 'base64-decode-region - "mel-b" "Decode current region by base64." t) -(autoload 'quoted-printable-decode-region - "mel-q" "Decode current region by Quoted-Printable." t) -(autoload 'uuencode-decode-region - "mel-u" "Decode current region by unofficial uuencode format." t) -(autoload 'gzip64-decode-region - "mel-g" "Decode current region by unofficial x-gzip64 format." t) - -(defvar mime-decoding-method-alist - '(("base64" . base64-decode-region) - ("quoted-printable" . quoted-printable-decode-region) - ("x-uue" . uuencode-decode-region) - ("x-uuencode" . uuencode-decode-region) - ("x-gzip64" . gzip64-decode-region) - ) - "Alist of encoding vs. corresponding method to decode region. -Each element looks like (STRING . FUNCTION). -STRING is content-transfer-encoding. -FUNCTION is region decoder.") - - -;;;###autoload -(defun mime-encode-region (start end encoding) - "Encode region START to END of current buffer using ENCODING." - (interactive - (list (region-beginning) (region-end) - (completing-read "encoding: " - mime-encoding-method-alist - nil t "base64")) - ) - (let ((f (cdr (assoc encoding mime-encoding-method-alist)))) - (if f - (funcall f start end) - ))) - -;;;###autoload -(defun mime-decode-region (start end encoding) - "Decode region START to END of current buffer using ENCODING." - (interactive - (list (region-beginning) (region-end) - (completing-read "encoding: " - mime-decoding-method-alist - nil t "base64")) - ) - (let ((f (cdr (assoc encoding mime-decoding-method-alist)))) - (if f - (funcall f start end) - ))) - - -;;; @ file -;;; - -(autoload 'base64-insert-encoded-file "mel-b" - "Encode contents of file to base64, and insert the result." t) -(autoload 'quoted-printable-insert-encoded-file "mel-q" - "Encode contents of file to quoted-printable, and insert the result." t) -(autoload 'uuencode-insert-encoded-file - "mel-u" "Insert file encoded by unofficial uuencode format." t) -(autoload 'gzip64-insert-encoded-file - "mel-g" "Insert file encoded by unofficial gzip64 format." t) - -(defvar mime-file-encoding-method-alist - '(("base64" . base64-insert-encoded-file) - ("quoted-printable" . quoted-printable-insert-encoded-file) - ("x-uue" . uuencode-insert-encoded-file) - ("x-gzip64" . gzip64-insert-encoded-file) - ("7bit" . insert-binary-file-contents-literally) - ("8bit" . insert-binary-file-contents-literally) - ("binary" . insert-binary-file-contents-literally) - ) - "Alist of encoding vs. corresponding method to insert encoded file. -Each element looks like (STRING . FUNCTION). -STRING is content-transfer-encoding. -FUNCTION is function to insert encoded file.") - -;;;###autoload -(defun mime-insert-encoded-file (filename encoding) - "Insert file FILENAME encoded by ENCODING format." - (interactive - (list (read-file-name "Insert encoded file: ") - (completing-read "encoding: " - mime-encoding-method-alist - nil t "base64")) - ) - (let ((f (cdr (assoc encoding mime-file-encoding-method-alist)))) - (if f - (funcall f filename) - ))) - - -;;; @ string -;;; - -(autoload 'base64-encode-string "mel-b" - "Encode STRING to base64, and return the result.") -(autoload 'base64-decode-string "mel-b" - "Decode STRING which is encoded in base64, and return the result.") -(autoload 'quoted-printable-encode-string "mel-q" - "Encode STRING to quoted-printable, and return the result.") -(autoload 'quoted-printable-decode-string "mel-q" - "Decode STRING which is encoded in quoted-printable, and return the result.") - -(autoload 'q-encoding-encode-string "mel-q" - "Encode STRING to Q-encoding of encoded-word, and return the result.") -(autoload 'q-encoding-decode-string "mel-q" - "Decode STRING which is encoded in Q-encoding and return the result.") - -(autoload 'base64-encoded-length "mel-b") -(autoload 'q-encoding-encoded-length "mel-q") - - -;;; @ end -;;; - -(provide 'mel) - -;;; mel.el ends here. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/modes/auto-autoloads.el --- a/lisp/modes/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -228,6 +228,42 @@ ;;;*** +;;;### (autoloads (c-comment-edit) "c-comment" "modes/c-comment.el") + +(autoload 'c-comment-edit "c-comment" "\ +Edit multi-line C comments. +This command allows the easy editing of a multi-line C comment like this: + /* + * ... + * ... + */ +The comment may be indented or flush with the left margin. + +If point is within a comment, that comment is used. Otherwise the +comment to be edited is found by searching forward from point. + +With one \\[universal-argument] searching starts after moving back one + paragraph. +With two \\[universal-argument]'s searching starts at the beginning of the + current or proceeding C function. +With three \\[universal-argument]'s searching starts at the beginning of the + current page. +With four \\[universal-argument]'s searching starts at the beginning of the + current buffer (clipping restrictions apply). + +Once located, the comment is copied into a temporary buffer, the comment +leaders and delimiters are stripped away and the resulting buffer is +selected for editing. The major mode of this buffer is controlled by +the variable `c-comment-edit-mode'.\\ + +Use \\[c-comment-edit-end] when you have finished editing the comment. The +comment will be inserted into the original buffer with the appropriate +delimiters and indention, replacing the old version of the comment. If +you don't want your edited version of the comment to replace the +original, use \\[c-comment-edit-abort]." t nil) + +;;;*** + ;;;### (autoloads (common-lisp-indent-function) "cl-indent" "modes/cl-indent.el") (autoload 'common-lisp-indent-function "cl-indent" nil nil nil) @@ -707,7 +743,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.12 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.13 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -1286,7 +1322,7 @@ ;;;*** -;;;### (autoloads (reftex-add-to-label-alist reftex-mode turn-on-reftex) "reftex" "modes/reftex.el") +;;;### (autoloads (reftex-mode turn-on-reftex) "reftex" "modes/reftex.el") (autoload 'turn-on-reftex "reftex" "\ Turn on RefTeX minor mode." nil nil) @@ -1299,7 +1335,7 @@ context of the label definition. The selected label is inserted as a \\ref macro. -Citations can be made with `\\[reftex-citation]' which will use a regular expression +Citations can be made with `\\[reftex-citation]' which will use a regular expression to pull out a *formatted* list of articles from your BibTeX database. The selected citation is inserted as a \\cite macro. @@ -1309,24 +1345,15 @@ Most command have help available on the fly. This help is accessed by pressing `?' to any prompt mentioning this feature. -Extensive documentation about reftex is in the file header of `reftex.el'. +Extensive documentation about RefTeX is in the file header of `reftex.el'. +You can view this information with `\\[reftex-show-commentary]'. \\{reftex-mode-map} -Under X, these functions will also be available in a menu on the menu bar. +Under X, these and other functions will also be available as `Ref' menu +on the menu bar. ------------------------------------------------------------------------------" t nil) -(autoload 'reftex-add-to-label-alist "reftex" "\ -Add label environment descriptions to `reftex-label-alist-external-add-ons'. -The format of ENTRY-LIST is exactly like `reftex-label-alist'. See there -for details. -This function makes it possible to support RefTeX from AUCTeX style files. -The entries in ENTRY-LIST will be processed after the user settings in -`reftex-label-alist', and before the defaults (specified in -`reftex-default-label-alist-entries'). Any changes made to -`reftex-label-alist-external-add-ons' will raise a flag to the effect that a -mode reset is done on the next occasion." nil nil) - ;;;*** ;;;### (autoloads (rexx-mode) "rexx-mode" "modes/rexx-mode.el") @@ -2019,7 +2046,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.12 $ +vhdl-mode $Revision: 1.13 $ To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a vhdl-mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the diff -r d3e9274cbc4e -r e45d5e7c476e lisp/modes/c-comment.el --- a/lisp/modes/c-comment.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/c-comment.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,20 +1,47 @@ ;;; c-comment.el --- edit C comments -;; Keywords: c +;; Copyright (C) 1987, 1988, 1989 Kyle E. Jones +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Kyle Jones +;; Maintainer: XEmacs Development Team +;; Keywords: languages + +;; This file is part of XEmacs. -;;; Copyright (C) 1987, 1988, 1989 Kyle E. Jones -;;; -;;; Verbatim copies of this file may be freely redistributed. -;;; -;;; Modified versions of this file may be redistributed provided that this -;;; notice remains unchanged, the file contains prominent notice of -;;; author and time of modifications, and redistribution of the file -;;; is not further restricted in any way. -;;; -;;; This file is distributed `as is', without warranties of any kind. +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. +;;; Commentary: + +;; +;; Verbatim copies of this file may be freely redistributed. +;; +;; Modified versions of this file may be redistributed provided that this +;; notice remains unchanged, the file contains prominent notice of +;; author and time of modifications, and redistribution of the file +;; is not further restricted in any way. +;; +;; This file is distributed `as is', without warranties of any kind. + +;; sb [23-Oct-1997] Put into standard format, fixed an autoload cookie. + +;;; Code: + (provide 'c-comment-edit) (defvar c-comment-leader " *" @@ -56,8 +83,15 @@ (defmacro marker (pos &optional buffer) (list 'set-marker '(make-marker) pos buffer)) +(defvar c-comment-edit-map nil "Key map for c-comment-edit buffers") +(if c-comment-edit-map + nil + (setq c-comment-edit-map (make-sparse-keymap)) + (define-key c-comment-edit-map [(meta control c)] 'c-comment-edit-end) + (define-key c-comment-edit-map [(control c) (control c)] 'c-comment-edit-end) + (define-key c-comment-edit-map [(control c) (control ?\])] 'c-comment-edit-abort)) -;;;### autoload +;;;###autoload (defun c-comment-edit (search-prefix) "Edit multi-line C comments. This command allows the easy editing of a multi-line C comment like this: @@ -82,7 +116,7 @@ Once located, the comment is copied into a temporary buffer, the comment leaders and delimiters are stripped away and the resulting buffer is selected for editing. The major mode of this buffer is controlled by -the variable `c-comment-edit-mode'. +the variable `c-comment-edit-mode'.\\ Use \\[c-comment-edit-end] when you have finished editing the comment. The comment will be inserted into the original buffer with the appropriate @@ -157,7 +191,8 @@ (delete-char 1)) ;; restore cursor if possible (goto-char (or marker (point-min))) - (set-buffer-modified-p nil)) + (set-buffer-modified-p nil) + (use-local-map c-comment-edit-map c-comment-buffer)) ;; run user hook, if present. (if c-comment-edit-hook (funcall c-comment-edit-hook)) @@ -293,9 +328,5 @@ (if (eq (car (car list)) buffer) (throw 'return-value (car list)) (setq list (cdr list))))))) - -;; keys; -(define-key mode-specific-map "\e" 'c-comment-edit-end) -(define-key mode-specific-map "\C-]" 'c-comment-edit-abort) - +;;; c-comment.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/modes/cperl-mode.el --- a/lisp/modes/cperl-mode.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/cperl-mode.el Mon Aug 13 10:03:52 2007 +0200 @@ -37,7 +37,7 @@ ;;; Karl M. Hegbloom ;; Original Vendor Version Number: (mostly based on...) -;; $Id: cperl-mode.el,v 1.14 1997/10/12 01:39:40 steve Exp $ +;; $Id: cperl-mode.el,v 1.15 1997/10/31 14:52:54 steve Exp $ ;; Increment the final digit once per XEmacs-only revision, the other ;; for merges. (sound ok?) @@ -632,7 +632,9 @@ :group 'cperl-faces) (defface cperl-here-face - '(( ((class color)) (:foreground "green") )) + '((((type x) (class color) (background light)) + (:foreground "green4" :background "grey85")) + (t (:foreground "green"))) "*The result of evaluation of this expression is used for here-docs highlighting." :group 'cperl-faces) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/modes/custom-load.el --- a/lisp/modes/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,73 +1,72 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:16 1997 ;;; Code: -(custom-put 'extensions 'custom-loads '("auto-show" "strokes")) -(custom-put 'message 'custom-loads '("sendmail")) -(custom-put 'prolog 'custom-loads '("prolog")) -(custom-put 'auto-show 'custom-loads '("auto-show")) -(custom-put 'mouse 'custom-loads '("outl-mouse" "strokes")) -(custom-put 'mail-abbrevs 'custom-loads '("mail-abbrevs")) -(custom-put 'pascal 'custom-loads '("pascal")) -(custom-put 'tex 'custom-loads '("reftex" "texinfo")) -(custom-put 'tcl 'custom-loads '("tcl")) -(custom-put 'icon 'custom-loads '("icon")) -(custom-put 'texinfo 'custom-loads '("texinfo")) -(custom-put 'xrdb 'custom-loads '("xrdb-mode")) -(custom-put 'mail 'custom-loads '("mail-abbrevs")) -(custom-put 'fortran-indent 'custom-loads '("fortran")) -(custom-put 'docs 'custom-loads '("texinfo")) -(custom-put 'lisp-indent 'custom-loads '("cl-indent")) -(custom-put 'tools 'custom-loads '("hideshow" "lazy-shot" "make-mode")) -(custom-put 'lisp 'custom-loads '("lisp-mode" "cl-indent" "strokes")) -(custom-put 'reftex 'custom-loads '("reftex")) -(custom-put 'outlines 'custom-loads '("hideshow" "outl-mouse" "whitespace-mode")) -(custom-put 'f90 'custom-loads '("f90")) -(custom-put 'perl 'custom-loads '("cperl-mode")) -(custom-put 'asm 'custom-loads '("asm-mode")) -(custom-put 'ada 'custom-loads '("ada-mode")) -(custom-put 'reftex-label-support 'custom-loads '("reftex")) -(custom-put 'data 'custom-loads '("arc-mode" "xrdb-mode")) -(custom-put 'fortran-comment 'custom-loads '("fortran")) -(custom-put 'outl-mouse 'custom-loads '("outl-mouse")) -(custom-put 'frames 'custom-loads '("rsz-minibuf")) -(custom-put 'cperl-electric 'custom-loads '("cperl-mode")) -(custom-put 'verilog 'custom-loads '("verilog-mode")) -(custom-put 'abbrev 'custom-loads '("abbrev")) -(custom-put 'f90-indent 'custom-loads '("f90")) -(custom-put 'strokes 'custom-loads '("strokes")) -(custom-put 'lazy-shot 'custom-loads '("lazy-shot")) -(custom-put 'archive-lzh 'custom-loads '("arc-mode")) -(custom-put 'scribe 'custom-loads '("scribe")) -(custom-put 'archive 'custom-loads '("arc-mode")) -(custom-put 'c-macro 'custom-loads '("cmacexp")) -(custom-put 'vrml 'custom-loads '("vrml-mode")) -(custom-put 'simula 'custom-loads '("simula")) -(custom-put 'archive-arc 'custom-loads '("arc-mode")) -(custom-put 'fortran 'custom-loads '("f90" "fortran")) -(custom-put 'cperl-faces 'custom-loads '("cperl-mode")) -(custom-put 'resize-minibuffer 'custom-loads '("rsz-minibuf")) -(custom-put 'languages 'custom-loads '("ada-mode" "asm-mode" "cperl-mode" "fortran" "icon" "pascal" "prolog" "rexx-mode" "sh-script" "simula" "tcl" "verilog-mode" "vhdl-mode" "vrml-mode" "winmgr-mode" "xrdb-mode")) -(custom-put 'cperl-indent 'custom-loads '("cperl-mode")) -(custom-put 'archive-zoo 'custom-loads '("arc-mode")) -(custom-put 'archive-zip 'custom-loads '("arc-mode")) -(custom-put 'display 'custom-loads '("auto-show")) -(custom-put 'faces 'custom-loads '("cperl-mode")) -(custom-put 'hideshow 'custom-loads '("hideshow")) -(custom-put 'vhdl 'custom-loads '("vhdl-mode")) -(custom-put 'enriched 'custom-loads '("enriched")) -(custom-put 'processes 'custom-loads '("executable")) -(custom-put 'rexx 'custom-loads '("rexx-mode")) -(custom-put 'executable 'custom-loads '("executable")) -(custom-put 'wp 'custom-loads '("enriched" "scribe" "texinfo")) -(custom-put 'sh 'custom-loads '("sh-script")) -(custom-put 'makefile-mode 'custom-loads '("make-mode")) -(custom-put 'whitespace 'custom-loads '("whitespace-mode")) -(custom-put 'matching 'custom-loads '("whitespace-mode")) -(custom-put 'winmgr 'custom-loads '("winmgr-mode")) -(custom-put 'unix 'custom-loads '("sh-script")) -(custom-put 'c 'custom-loads '("cmacexp")) +(custom-add-loads 'extensions '("auto-show" "strokes")) +(custom-add-loads 'message '("sendmail")) +(custom-add-loads 'prolog '("prolog")) +(custom-add-loads 'auto-show '("auto-show")) +(custom-add-loads 'mouse '("outl-mouse" "strokes")) +(custom-add-loads 'mail-abbrevs '("mail-abbrevs")) +(custom-add-loads 'pascal '("pascal")) +(custom-add-loads 'tex '("reftex" "texinfo")) +(custom-add-loads 'tcl '("tcl")) +(custom-add-loads 'icon '("icon")) +(custom-add-loads 'texinfo '("texinfo")) +(custom-add-loads 'xrdb '("xrdb-mode")) +(custom-add-loads 'mail '("mail-abbrevs")) +(custom-add-loads 'fortran-indent '("fortran")) +(custom-add-loads 'docs '("texinfo")) +(custom-add-loads 'lisp-indent '("cl-indent")) +(custom-add-loads 'tools '("hideshow" "lazy-shot" "make-mode")) +(custom-add-loads 'lisp '("lisp-mode" "cl-indent" "strokes")) +(custom-add-loads 'reftex '("reftex")) +(custom-add-loads 'outlines '("hideshow" "outl-mouse" "whitespace-mode")) +(custom-add-loads 'f90 '("f90")) +(custom-add-loads 'perl '("cperl-mode")) +(custom-add-loads 'asm '("asm-mode")) +(custom-add-loads 'ada '("ada-mode")) +(custom-add-loads 'reftex-label-support '("reftex")) +(custom-add-loads 'data '("arc-mode" "xrdb-mode")) +(custom-add-loads 'fortran-comment '("fortran")) +(custom-add-loads 'outl-mouse '("outl-mouse")) +(custom-add-loads 'frames '("rsz-minibuf")) +(custom-add-loads 'cperl-electric '("cperl-mode")) +(custom-add-loads 'verilog '("verilog-mode")) +(custom-add-loads 'abbrev '("abbrev")) +(custom-add-loads 'f90-indent '("f90")) +(custom-add-loads 'strokes '("strokes")) +(custom-add-loads 'lazy-shot '("lazy-shot")) +(custom-add-loads 'archive-lzh '("arc-mode")) +(custom-add-loads 'scribe '("scribe")) +(custom-add-loads 'archive '("arc-mode")) +(custom-add-loads 'c-macro '("cmacexp")) +(custom-add-loads 'vrml '("vrml-mode")) +(custom-add-loads 'simula '("simula")) +(custom-add-loads 'archive-arc '("arc-mode")) +(custom-add-loads 'fortran '("f90" "fortran")) +(custom-add-loads 'cperl-faces '("cperl-mode")) +(custom-add-loads 'resize-minibuffer '("rsz-minibuf")) +(custom-add-loads 'languages '("ada-mode" "asm-mode" "cperl-mode" "fortran" "icon" "pascal" "prolog" "rexx-mode" "sh-script" "simula" "tcl" "verilog-mode" "vhdl-mode" "vrml-mode" "winmgr-mode" "xrdb-mode")) +(custom-add-loads 'cperl-indent '("cperl-mode")) +(custom-add-loads 'archive-zoo '("arc-mode")) +(custom-add-loads 'archive-zip '("arc-mode")) +(custom-add-loads 'display '("auto-show")) +(custom-add-loads 'faces '("cperl-mode" "lazy-shot")) +(custom-add-loads 'hideshow '("hideshow")) +(custom-add-loads 'vhdl '("vhdl-mode")) +(custom-add-loads 'enriched '("enriched")) +(custom-add-loads 'processes '("executable")) +(custom-add-loads 'rexx '("rexx-mode")) +(custom-add-loads 'executable '("executable")) +(custom-add-loads 'wp '("enriched" "scribe" "texinfo")) +(custom-add-loads 'sh '("sh-script")) +(custom-add-loads 'makefile-mode '("make-mode")) +(custom-add-loads 'whitespace '("whitespace-mode")) +(custom-add-loads 'matching '("whitespace-mode")) +(custom-add-loads 'winmgr '("winmgr-mode")) +(custom-add-loads 'unix '("sh-script")) +(custom-add-loads 'c '("cmacexp")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/modes/enriched.el --- a/lisp/modes/enriched.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/enriched.el Mon Aug 13 10:03:52 2007 +0200 @@ -417,10 +417,10 @@ (t (let* ((fg (and (not (eq (face-foreground face) (face-foreground 'default))) - (color-instance-name (face-foreground face)))) + (color-name (face-foreground face)))) (bg (and (not (eq (face-background face) (face-background 'default))) - (color-instance-name (face-background face)))) + (color-name (face-background face)))) (ans '())) (if fg (setq ans (cons (list "x-color" fg) ans))) (if bg (setq ans (cons (list "x-bg-color" bg) ans))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/modes/lazy-shot.el --- a/lisp/modes/lazy-shot.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/lazy-shot.el Mon Aug 13 10:03:52 2007 +0200 @@ -22,27 +22,32 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Synched up with: Not synched. +;;; Synched up with: Not in FSF (mostly equivalent to lazy-lock 2.06 +;;; in FSF 19.34). ;;; Commentary: -;; This versions has basic demand lock functionality. Somebody please -;; sync further with lazy-lock v2 from FSF, customize etc. -;; -;; -;; Idea for the stealth lock function: -;; -;; -;; On an Idle itimer -;; Loop over all buffers with lazy-lock set -;; mapcar-extent in the region (point) point-max for -;; one-shot-function property -;; If not found do the same for [point-min,point] -;; font-lock the found region and delete the extent +;;; This is an experimental demand based font-lock implemenation. It +;;; is almost equal in functionality and interface to lazy-lock 2.06 +;;; Does somebody really need defer-locking? +;;; +;;; To use: put +;;; (add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) +;;; in .emacs (.xemacs/init.el). Do not use in combination with +;;; lazy-lock. + +;;; It is exprimental in the sense that it relies on C support from +;;; the redisplay engine, that is experimental. The code in this file +;;; is more or less finished. The C code support experimental because +;;; the current design is rumoured to be ugly. Secondly because +;;; XEmacs does actually display the "un-font-locked" parts of the +;;; buffer first, the user notices flashing as the buffer is repainted +;;; with color/fonts. ;;; Code: (require 'font-lock) +(require 'itimer) (defvar lazy-shot-mode nil) @@ -50,13 +55,62 @@ (defgroup lazy-shot nil "Lazy-shot customizations" :group 'tools + :group 'faces :prefix "lazy-shot-") +(defcustom lazy-shot-minimum-size 0 + "*Minimum size of a buffer for demand-driven fontification. +On-demand fontification occurs if the buffer size is greater than this value. +If nil, means demand-driven fontification is never performed." + :type '(choice (const :tag "Off" nil) + (integer :tag "Size")) + :group 'lazy-shot) + + (defcustom lazy-shot-step-size 1024 ; Please test diffent sizes "Minimum size of each fontification shot." :type 'integer :group 'lazy-shot) +(defcustom lazy-shot-stealth-time 30 + "*Time in seconds to delay before beginning stealth fontification. +Stealth fontification occurs if there is no input within this time. +If nil, means stealth fontification is never performed. + +The value of this variable is used when Lazy Shot mode is turned on." + :type '(choice (const :tag "Off" nil) + (number :tag "Time")) + :group 'lazy-shot) + +(defcustom lazy-shot-stealth-lines (if font-lock-maximum-decoration 100 250) + "*Maximum size of a chunk of stealth fontification. +Each iteration of stealth fontification can fontify this number of lines. +To speed up input response during stealth fontification, at the cost of stealth +taking longer to fontify, you could reduce the value of this variable." + :type 'integer + :group 'lazy-shot) + +(defcustom lazy-shot-stealth-nice + (/ (float 1) (float 8)) + "*Time in seconds to pause between chunks of stealth fontification. +Each iteration of stealth fontification is separated by this amount of time. +To reduce machine load during stealth fontification, at the cost of stealth +taking longer to fontify, you could increase the value of this variable." + :type 'number + :group 'lazy-shot) + +(defcustom lazy-shot-verbose (not (null font-lock-verbose)) + "*If non-nil, means demand fontification should show status messages." + :type 'boolean + :group 'lazy-shot) + +(defcustom lazy-shot-stealth-verbose (not (null lazy-shot-verbose)) + "*If non-nil, means stealth fontification should show status messages." + :type 'boolean + :group 'lazy-shot) + + + ;;;###autoload (defun lazy-shot-mode (&optional arg) "Toggle Lazy Lock mode. @@ -75,72 +129,123 @@ ;; Turn ourselves off. (lazy-shot-unstall)))) +(custom-add-option 'font-lock-mode-hook 'turn-on-lazy-lock) + ;;;###autoload (defun turn-on-lazy-shot () "Unconditionally turn on Lazy Lock mode." (lazy-shot-mode t)) + ;; Can we do something intelligent here? + ;; I would want to set-extent-end-position start on extents that + ;; only partially overlap! +(defun lazy-shot-clean-up-extents (start end) + "Make sure there are no lazy-shot-extens betweeen START and END. +This improves efficiency and C-g behavior." + ;; Be carefull this function is typically called with inhibit-quit! + (map-extents (lambda (e b) (delete-extent e)) + nil start end nil 'start-and-end-in-region 'initial-redisplay-function + 'lazy-shot-redisplay-function)) + +(defun lazy-shot-redisplay-function (extent) + "Lazy lock the EXTENT when it has become visisble." + (lazy-shot-lock-extent extent nil)) -(defun lazy-shot-shot-function (extent) - "Lazy lock the extent when it has become visisble" - (let ((start (extent-start-position extent)) - (end (extent-end-position extent)) - (buffer (extent-object extent))) - (delete-extent extent) - (with-current-buffer buffer - (save-excursion - ;; This magic should really go into font-lock-fonity-region - (goto-char start) - (unless (bolp) - (beginning-of-line) - (setq start (point))) - (goto-char end) - (unless (bolp) - (forward-line) - (setq end (point))) - (display-message 'progress - (format "Lazy-shot fontifying from %s to %s in %s" - start end buffer)) - (save-match-data - (font-lock-fontify-region start end)))))) +(defun lazy-shot-lock-extent (extent stealth) + "Font-lock the EXTENT. Called from redisplay-trigger functions and +stealth locking functions" + (when (extent-live-p extent) + (let ((start (extent-start-position extent)) + (end (extent-end-position extent)) + (buffer (extent-object extent))) + (delete-extent extent) + (save-excursion + ;; Should inhibit quit here + (set-buffer buffer) ;; with-current-buffer is silly here + ;; This magic should really go into font-lock-fonity-region + (goto-char start) + (setq start (point-at-bol)) + (goto-char end) + (setq end (point-at-bol 2)) + (lazy-shot-clean-up-extents start end) + (if (or lazy-shot-verbose (and stealth lazy-shot-stealth-verbose)) + (display-message 'progress + (format "Lazy-shot fontifying %sfrom %s to %s in %s" + (if stealth "stealthy " "") start end buffer))) + ;; and a allow quit here + (save-match-data + (font-lock-fontify-region start end)))))) +(defun lazy-shot-stealth-lock (buffer) + "Find an extent to lazy lock in buffer." + (if (buffer-live-p buffer) + (with-current-buffer buffer + (let ((extent t)) + (while (and extent (sit-for lazy-shot-stealth-nice)) + (setq extent + (or ;; First after point + (map-extents (lambda (e n) e) nil (point) nil nil nil + 'initial-redisplay-function + 'lazy-shot-redisplay-function) + ;; Then before it + (map-extents (lambda (e n) e) nil nil (point) nil nil + 'initial-redisplay-function + 'lazy-shot-redisplay-function))) + (if extent + (lazy-shot-lock-extent extent t) + (delete-itimer current-itimer) + (setq lazy-shot-stealth-timer nil))))) + (delete-itimer current-itimer))) + (defun lazy-shot-install-extent (spos epos &optional buffer) - "Make an extent that will lazy-shot if it is displayed" + "Make an extent that will lazy-shot if it is displayed." (let ((extent (make-extent spos epos buffer))) (when extent - (set-extent-one-shot-function extent - 'lazy-shot-shot-function)) + (set-extent-initial-redisplay-function extent + 'lazy-shot-redisplay-function)) extent)) -(defun lazy-shot-next-line (pos &optional buffer) - "Return the next end-of-line from POS in BUFFER." - (save-excursion - (goto-char pos buffer) - (forward-line 1 buffer) - (point buffer))) (defun lazy-shot-install-extents (fontifying) ;; ;; Add hook if lazy-shot.el is deferring or is fontifying on scrolling. (when fontifying - (let ((max (point-max))) - (do* ((start (point-min) end) - (end (min max (lazy-shot-next-line (+ start lazy-shot-step-size))) - (min max (lazy-shot-next-line (+ start lazy-shot-step-size))))) - ((>= start max)) - (lazy-shot-install-extent start end))))) + (let ((max (point-max)) + start) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq start (point)) + (goto-char (min max (+ start lazy-shot-step-size))) + (forward-line 1) + (lazy-shot-install-extent start (point))))))) + +(defun lazy-shot-install-timer (fontifying) + (when (and lazy-shot-stealth-time fontifying) + (make-variable-buffer-local 'lazy-shot-stealth-timer) + (setq lazy-shot-stealth-timer + (start-itimer (format "lazy shot for %s" (current-buffer)) + 'lazy-shot-stealth-lock lazy-shot-stealth-time + lazy-shot-stealth-time + t t (current-buffer))))) + (defun lazy-shot-install () (make-local-variable 'font-lock-fontified) - (setq font-lock-fontified t) - (lazy-shot-install-extents font-lock-fontified)) + (setq font-lock-fontified (and lazy-shot-minimum-size + (>= (buffer-size) lazy-shot-minimum-size))) + (lazy-shot-install-extents font-lock-fontified) + (lazy-shot-install-timer font-lock-fontified)) (defun lazy-shot-unstall () - ;; + ;; Stop the timer + (when lazy-shot-stealth-timer + (delete-itimer lazy-shot-stealth-timer) + (setq lazy-shot-stealth-timer nil)) ;; Remove the extents. (map-extents (lambda (e arg) (delete-extent e) nil) - nil nil nil nil nil 'one-shot-function 'lazy-shot-shot-function) + nil nil nil nil nil 'initial-redisplay-function 'lazy-shot-redisplay-function) ;; ;; Remove the fontification hooks. (remove-hook 'after-change-functions 'lazy-shot-defer-after-change t) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/modes/reftex.el --- a/lisp/modes/reftex.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/reftex.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,7 +1,7 @@ ;; reftex.el --- Minor mode for doing \label, \ref and \cite in LaTeX - ;; Copyright (c) 1997 Free Software Foundation, Inc. +;; Version: 3.7 ;; Author: Carsten Dominik ;; Keywords: tex @@ -30,7 +30,8 @@ ;; \cite commands in (multi-file) LaTeX documents. ;; Labels are created semi-automatically. Definition context of labels is ;; provided when creating a reference. Citations are simplified with -;; efficient database lookup. +;; efficient database lookup. A table of contents buffer provides easy +;; access to any part of a document. ;; ;; To turn RefTeX Minor Mode on and off in a particular buffer, use ;; `M-x reftex-mode'. @@ -41,239 +42,312 @@ ;; (add-hook 'LaTeX-mode-hook 'turn-on-reftex) ; with AUCTeX LaTeX mode ;; (add-hook 'latex-mode-hook 'turn-on-reftex) ; with Emacs latex mode ;; -;; For key bindings, see further down in this documentation. +;; For default key bindings, see further down in this documentation. +;; +;;--------------------------------------------------------------------------- +;; +;; CONTENTS +;; -------- +;; +;; Overview............................ All you need to know to get started. ;; +;; Configuration....................... How to configure RefTeX. +;; Configuration Examples........... Tutorial examples. +;; Hooks............................ Available hooks. +;; Configuration Variables.......... Complete listing. +;; Key Bindings........................ A list of default bindings. +;; Multifile Documents................. Documents spread over many files. +;; References to Other Documents....... RefTeX and the LaTeX package `xr'. +;; Optimizations for Large Documents... How to improve speed and memory use. +;; Related Packages.................... Other Emacs packages. +;; Known Bugs and Work-Arounds......... First aid. +;; Author.............................. Who wrote RefTeX and who helped. +;; History............................. What was new in which version. ;;--------------------------------------------------------------------------- ;; ;; OVERVIEW -;; -;; 1. USING \label AND \ref. Labels and references are one of the -;; strong points of LaTeX. But, in documents with hundreds of -;; equations, figures, tables etc. it becomes quickly impossible to -;; find good label names and to actually remember them. Then, also -;; completion of labels in not enough. One actually needs to see the -;; context of the label definition to find the right one. -;; -;; - RefTeX distinguishes labels for different environments. It -;; always knows if a certain label references a figure, table -;; etc.. You can configure RefTeX to recognize any additional -;; labeled environments you might have defined yourself. +;; ======== +;; +;; 1. USING \label AND \ref. Labels and references are one of the strong +;; points of LaTeX. But, in documents with hundreds of equations, +;; figures, tables etc. it becomes quickly impossible to find good label +;; names and to actually remember them. Then, also completion of labels +;; is not enough. One actually needs to see the context of the label +;; definition to find the right one. +;; +;; - RefTeX distinguishes labels for different environments. It always +;; knows if a certain label references a figure, table etc.. You can +;; configure RefTeX to recognize any additional labeled environments +;; you have defined yourself. ;; ;; - RefTeX defines automatically unique labels. Type `C-c (' -;; (reftex-label) to insert a label at point. RefTeX will either +;; (`reftex-label') to insert a label at point. RefTeX will either ;; - derive a label from context (default for section labels) ;; - insert a simple label consisting of a prefix and a number -;; (default for equations and enumerate items) or +;; (default for equations,enumerate items, and footnotes) or ;; - prompt for a label string (figures and tables). ;; Which labels are created how can be controlled with the variable ;; `reftex-insert-label-flags'. ;; -;; - Referencing labels is a snap and I promise you'll love it. -;; In order to make a reference, type `C-c )' (`reftex-reference'). -;; This shows an outline of the documents with all labels of a -;; certain type (figure, equation,...) and context of the label -;; definition. Selecting one of the labels inserts a \ref macro -;; into the original buffer. Online help during the selection is -;; available with `?'. -;; -;; 2. CITATIONS. After typing `C-c [' (`reftex-citation'), RefTeX will -;; let you specify a regexp to search in current BibTeX database files -;; (as specified in the \bibliography command) and pull out a formatted -;; list of matches for you to choose from. The list is *formatted* and -;; thus much easier to read than the raw database entries. It can also -;; be sorted. The text inserted into the buffer is by default just -;; `\cite{KEY}', but can also contain author names and the year in a -;; configurable way. See documentation of the variable -;; `reftex-cite-format'. -;; -;; 3. TABLE OF CONTENTS. Typing `C-c =' (`reftex-toc') will show -;; a table of contents of the document. From that buffer, you can -;; jump quickly to every part of your document. This is similar to -;; imenu, only it works for entire multifile documents and uses the -;; keyboard rather than the mouse. The initial version of this -;; function was contributed by Stephen Eglen. +;; - Referencing labels is a snap and I promise you'll love it. In +;; order to make a reference, type `C-c )' (`reftex-reference'). This +;; shows an outline of the document with all labels of a certain type +;; (figure, equation,...) and context of the label definition. +;; Selecting one of the labels inserts a \ref macro into the original +;; buffer. Online help during the selection is available with `?'. +;; +;; 2. CITATIONS. After typing `C-c [' (`reftex-citation'), RefTeX will let +;; you specify a regexp to search in current BibTeX database files (as +;; specified in the \bibliography command) and pull out a formatted list +;; of matches for you to choose from. The list is *formatted* and +;; sorted, thus much easier to read than the raw database entries. The +;; text inserted into the buffer is by default just `\cite{KEY}', but +;; can also contain author names and the year in a configurable way. +;; See documentation of the variable `reftex-cite-format'. ;; -;; 4. MULTIFILE DOCUMENTS are supported in the same way as by AUCTeX. -;; I.e. if a source file is not a full LaTeX document by itself, -;; but included by another file, you may specify the name of -;; the (top level) master file in a local variable section at the -;; end of the source file, like so: -;; -;; %%% Local Variables: -;; %%% TeX-master: my_master.tex -;; %%% End: -;; -;; This will only take effect when you load the file next time or when -;; you reset RefTeX with M-x reftex-reset-mode. +;; 3. TABLE OF CONTENTS. Typing `C-c =' (`reftex-toc') will show a table +;; of contents of the document. From that buffer, you can jump quickly +;; to every part of your document. This is similar to imenu, only it +;; works for entire multifile documents and uses the keyboard rather +;; than the mouse. The initial version of this function was contributed +;; by Stephen Eglen. ;; -;; RefTeX will also recognize the file variable tex-main-file. This -;; variable is used by the Emacs TeX modes and works just like -;; AUCTeX's TeX-master variable. See the documentation of your TeX/LaTeX -;; modes. -;; -;; RefTeX knows about all files related to a document via input and -;; include. It provides functions to run regular expression searches and -;; replaces over the entire document and to create a TAGS file. +;; 4. MULTIFILE DOCUMENTS are fully supported by RefTeX. Such documents +;; consist of a master file and many other files being included via +;; \input or \include. RefTeX will provide cross referencing +;; information from all files which are part of the document. See +;; `RefTeX and Multifile Documents' further down in the documentation +;; for more information on this topic. ;; -;; 5. DOCUMENT PARSING. RefTeX needs to parse the document in order to find -;; labels and other information. It will do it automatically once, when -;; you start working with a document. If you need to enforce reparsing -;; later, call any of the functions `reftex-citation', `reftex-label', -;; `reftex-reference', `reftex-toc' with a raw C-u prefix. -;; -;;------------------------------------------------------------------------- -;; -;; CONFIGURATION -;; -;; RefTeX contains many configurable options which change the way it works. +;; 5. DOCUMENT PARSING. RefTeX needs to parse the document in order to +;; find labels and other information. It will do it automatically once, +;; when you start working with a document. Re-parsing should not be +;; necessary too often since RefTeX updates its lists internally when +;; you make a new label with `reftex-label'. To enforce reparsing, +;; call any of the functions `reftex-citation', `reftex-label', +;; `reftex-reference', `reftex-toc' with a raw C-u prefix, or press the +;; `r' key in the label menu and table of contents buffer. +;;--------------------------------------------------------------------------- ;; -;; Most importantly, RefTeX needs to be configured if you use labels to -;; mark non-standard environments. RefTeX always understands LaTeX section -;; commands and the following environments: figure, figure*, -;; sidewaysfigure, table, table*, sidewaystable, equation, eqnarray, -;; enumerate. For everythings else, it needs to be configured. +;; CONFIGURATION +;; ============= ;; -;; A good way to configure RefTeX is with the custom.el package by Per -;; Abrahamsen, shipped with Emacs 20 and XEmacs 19.15. To do this, just -;; say `M-x reftex-customize'. This will not work with older versions -;; of custom.el. -;; -;; Here is a complete list of the RefTeX configuration variables with -;; their default settings. You could copy this list to your .emacs file -;; and change whatever is necessary. Each variable has an extensive -;; documentation string. Look it up for more information! +;; RefTeX needs to be configured if you use labels to mark environments +;; defined by yourself (e.g. with `\newenvironment') or in packages not +;; included in the standard LaTeX distribution. RefTeX's default settings +;; make it recognize practically all labeled environments and macros +;; discussed in `The LaTeX Companion' by Goossens, Mittelbach & Samarin, +;; Addison-Wesley 1994. These are: ;; -;; ;; Configuration Variables and User Options for RefTeX ------------------ -;; ;; Support for \label and \ref -------------------------------------- -;; (setq reftex-label-alist nil) -;; (setq reftex-default-label-alist-entries '(Sideways LaTeX)) -;; (setq reftex-use-text-after-label-as-context nil) -;; ;; Label insertion -;; (setq reftex-insert-label-flags '("s" "sft")) -;; (setq reftex-derive-label-parameters '(3 20 t 1 "-" -;; ("the" "on" "in" "off" "a" "for" "by" "of" "and" "is"))) -;; (setq reftex-label-illegal-re "[\000-\040\177-\377\\\\#$%&~^_{}]") -;; (setq reftex-abbrev-parameters '(4 2 "^saeiou" "aeiou")) -;; ;; Label referencing -;; (setq reftex-label-menu-flags '(t t nil nil nil nil)) -;; (setq reftex-guess-label-type t) -;; ;; BibteX citation configuration ---------------------------------------- -;; (setq reftex-bibpath-environment-variables '("BIBINPUTS" "TEXBIB")) -;; (setq reftex-bibfile-ignore-list nil) -;; (setq reftex-sort-bibtex-matches 'reverse-year) -;; (setq reftex-cite-format 'reftex-cite-format-default) -;; ;; Table of contents configuration -------------------------------------- -;; (setq reftex-toc-follow-mode nil) -;; ;; Miscellaneous configurations ----------------------------------------- -;; (setq reftex-extra-bindings nil) -;; (setq reftex-plug-into-AUCTeX nil) -;; (setq reftex-use-fonts t) -;; (setq reftex-keep-temporary-buffers t) -;; (setq reftex-auto-show-entry t) +;; - figure, figure*, table, table*, equation, eqnarray, enumerate, +;; the \footnote macro (this is the LaTeX core stuff) +;; - align, gather, multline, flalign, alignat, xalignat, xxalignat, +;; subequations (from AMS-LaTeX's amsmath.sty package) +;; - the \endnote macro (from endnotes.sty) +;; - Beqnarray (fancybox.sty) +;; - floatingfig (floatfig.sty) +;; - longtable (longtable.sty) +;; - figwindow, tabwindow (picinpar.sty) +;; - sidewaysfigure, sidewaystable (rotating.sty) +;; - subfigure, subfigure*, the \subfigure macro (subfigure.sty) +;; - supertabular (supertab.sty) +;; - wrapfigure (wrapfig.sty) ;; -;; CONFIGURATION EXAMPLES: -;; ======================= +;; If you want to use any other labeled environments or macros, you need +;; to configure RefTeX. ;; -;; Suppose you are working with AMS-LaTeX amsmath package (with its math -;; environments like `align', `multiline' etc.). Here is how you would -;; configure RefTeX to recognize these environments: +;; Per Abrahamsens custom.el package provides a simple way to do +;; configuration. To try it out, use `M-x reftex-customize'. ;; -;; (setq reftex-label-alist '(AMSTeX)) +;; CONFIGURATION EXAMPLES +;; ---------------------- ;; -;; This is very easy since RefTeX has builtin support for AMS-LaTeX. -;; Suppose, however, you are also +;; Suppose you are working with AMS-LaTeX amsmath package (with its math +;; environments like `align', `multline' etc.). RefTeX is preconfigured to +;; recognize these - so there is nothing you have to do. ;; -;; - using "\newtheorem" in LaTeX in order to define two new environments -;; "Theorem" and "Axiom" like this: +;; Suppose you are also using `\newtheorem' in LaTeX in order to define two +;; new environments `theorem' and `axiom' ;; ;; \newtheorem{axiom}{Axiom} ;; \newtheorem{theorem}{Theorem} ;; -;; - making your figures not directly with the figure environment, but with -;; a macro like +;; to be used like this: ;; -;; \newcommand{\myfig}[4][tbp]{ -;; \begin{figure}[#1] -;; \epsimp[#4]{#2} -;; \caption{#3} -;; \end{figure}} -;; -;; which would be called like -;; -;; \myfig{filename}{\label{fig:13} caption text}{1} +;; \begin{axiom} +;; \label{ax:first} +;; .... +;; \end{axiom} ;; -;; Here is how to tell RefTeX to also recognize Theorem and Axiom as -;; labeled environments, and that any labels defined inside the \myfig -;; macro are figure labels: +;; So we need to tell RefTeX that `theorem' and `axiom' are new labeled +;; environments which define their own label categories. Here is how: ;; -;; (setq reftex-label-alist -;; '(AMSTeX -;; ("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) -;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")) -;; ("\\myfig" ?f "fig:" nil t))) +;; (setq reftex-label-alist +;; '(("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) +;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")))) ;; -;; The type indicator characters ?a and ?h are used for prompts when -;; RefTeX queries for a label type. Note that "h" was chosen for "theorem" -;; since "t" is already taken by "table". Note that also "s", "f", "e", "n" -;; are taken by the standard environments. +;; The type indicator characters ?a and ?h are used for prompts when RefTeX +;; queries for a label type. Note that `h' was chosen for `theorem' since +;; `t' is already taken by `table'. Note that also `s', `f', `e', `i', `n' +;; are already used for standard environments. ;; The automatic labels for Axioms and Theorems will look like "ax:23" or ;; "thr:24". ;; The "\ref{%s}" is a format string indicating how to insert references to -;; these labels. The nil format in the \myfig entry means to use the same -;; format as other figure labels. -;; The next item indicates how to grab context of the label definition. -;; - t means to get it from a default location (from the beginning of a \macro -;; or after the \begin statement). t is *not* a good choice for eqnarray -;; and similar environments. +;; these labels. +;; The next item indicates how to grab context of the label definition. +;; - t means to get it from a default location (from the beginning of a +;; \macro or after the \begin statement). t is *not* a good choice for +;; eqnarray and similar environments. ;; - nil means to use the text right after the label definition. ;; - For more complex ways of getting context, see the docstring of ;; `reftex-label-alist'. ;; The strings at the end of each entry are used to guess the correct label ;; type from the word before point when creating a reference. E.g. if you -;; write: "as we have shown in Theorem" and then press `C-)', RefTeX will -;; know that you are looking for a Theorem label and restrict the labels in -;; the menu to only these labels without even asking. -;; See also the documentation string of the variable `reftex-label-alist'. +;; write: "As we have shown in Theorem" and then press `C-c )', RefTeX will +;; know that you are looking for a theorem label and restrict the menu to +;; only these labels without even asking. +;; +;; Depending on how you would like the label insertion and selection for +;; the new environments to work, you might want to add the letters "a" and +;; "h" to some of the flags in the following variables: +;; +;; reftex-insert-label-flags reftex-label-menu-flags +;; +;; Suppose you want to make figures not directly with the figure +;; environment, but with a macro like +;; +;; \newcommand{\myfig}[5][tbp]{% +;; \begin{figure}[#1] +;; \epsimp[#5]{#2} +;; \caption{#3} +;; \label{#4} +;; \end{figure}} ;; -;; Depending on how you would like the label insertion and selection for the -;; new environments to work, you might want to add the letters "a" and "h" -;; to some of the flags in the following variables: +;; which would be called like +;; +;; \myfig[htp]{filename}{caption text}{label}{1} +;; +;; Now we also need to tell RefTeX that the 4th argument of the \myfig +;; macro is a figure label, and where to find the context. ;; -;; reftex-insert-label-flags -;; reftex-label-menu-flags +;; (setq reftex-label-alist +;; '(("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) +;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")) +;; ("\\myfig[]{}{}{*}{}" ?f nil nil 3))) ;; -;; The individual flags in these variables can be set to t or nil to enable or -;; disable the feature for all label types. They may also contain a string of -;; label type letters in order to turn on the feature for those types only. +;; The empty pairs of brackets indicate the different arguments of the +;; \myfig macro. The `*' marks the label argument. `?f' indicates that +;; this is a figure label which will be listed together with labels from +;; normal figure environments. The nil entries for prefix and reference +;; format mean to use the defaults for figure labels. The `3' for the +;; context method means to grab the 3rd macro argument - the caption. +;; +;; As a side effect of this configuration, `reftex-label' will now insert +;; the required naked label (without the \label macro) when point is +;; directly after the opening parenthesis of a \myfig macro argument. ;; ;; ----- -;; If you are writing in a language different from english you might want to -;; add magic words for that language. Here is a German example: ;; -;; (setq reftex-label-alist +;; If you are writing in a language different from English you might want +;; to add magic words for that language. Here is a German example: +;; +;; (setq reftex-label-alist ;; '((nil ?s nil nil nil ("Kapitel" "Kap." "Abschnitt" "Teil")) ;; (nil ?e nil nil nil ("Gleichung" "Gl.")) ;; (nil ?t nil nil nil ("Tabelle")) ;; (nil ?f nil nil nil ("Figur" "Abbildung" "Abb.")) -;; (nil ?n nil nil nil ("Punkt")))) +;; (nil ?n nil nil nil ("Anmerkung" "Anm.")) +;; (nil ?i nil nil nil ("Punkt")))) ;; ;; Using nil as first item in each entry makes sure that this entry does -;; not replace the original entry for that label type. +;; not replace the original entry for that label type, but just adds magic +;; words. +;; +;; ----- +;; +;; Normally, RefTeX inserts equation references with parenthesis like +;; "~(\ref{KEY})". If you want to change this to square brackets, use +;; +;; (setq reftex-label-alist '((nil ?e nil "~[\\ref{%s}]" nil nil))) +;; +;; In order to use the AMS-LaTeX \eqref macro instead, either of the +;; following lines does the job. +;; +;; (setq reftex-label-alist '((nil ?e nil "~\\eqref{%s}" nil nil))) +;; (setq reftex-label-alist '(AMSTeX)) +;; +;; ---- +;; +;; By default, citations are inserted simply as \cite{KEY}. You can have +;; more complex citation commands with many available packages, most +;; notably the harvard and natbib packages. RefTeX can be configured to +;; support these and other styles by setting the variable +;; `reftex-cite-format'. E.g., for the natbib package you would use +;; +;; (setq reftex-cite-format 'natbib) +;; +;; This can also be done as a file variable. For the full list of builtin +;; options, try `M-x customize-variable RET reftex-cite-format RET'. ;; ;; HOOKS ;; ----- -;; Loading reftex.el runs the hook `reftex-load-hook'. -;; Turning on reftex-mode runs `reftex-mode-hook'. +;; - Loading reftex.el runs the hook `reftex-load-hook'. +;; - Turning on reftex-mode runs `reftex-mode-hook'. +;; - Files visited literally are processed with +;; `reftex-initialize-temporary-buffers' if that is a list of functions. +;; +;; CONFIGURATION VARIABLES +;; ----------------------- +;; +;; The best way to learn about all configuration variables is via the +;; browser interface of the custom library. For reference, I am giving +;; here a complete list. ;; +;; ;; Defining label environments +;; reftex-default-label-alist-entries +;; reftex-label-alist +;; reftex-section-levels +;; reftex-default-context-regexps +;; reftex-use-text-after-label-as-context +;; ;; Label insertion +;; reftex-insert-label-flags +;; reftex-derive-label-parameters +;; reftex-label-illegal-re +;; reftex-abbrev-parameters +;; ;; Label referencing +;; reftex-label-menu-flags +;; reftex-level-indent +;; reftex-refontify-context +;; reftex-guess-label-type +;; ;; BibteX citation configuration +;; reftex-bibpath-environment-variables +;; reftex-bibfile-ignore-list +;; reftex-sort-bibtex-matches +;; reftex-cite-format +;; reftex-comment-citations +;; reftex-cite-comment-format +;; reftex-cite-punctuation +;; ;; Table of contents configuration +;; reftex-toc-follow-mode +;; ;; Fine-tuning the parser +;; reftex-keep-temporary-buffers +;; reftex-initialize-temporary-buffers +;; reftex-enable-partial-scans +;; reftex-save-parse-info +;; ;; Miscellaneous configurations +;; reftex-extra-bindings +;; reftex-plug-into-AUCTeX +;; reftex-use-fonts +;; reftex-auto-show-entry +;; reftex-load-hook +;; reftex-mode-hook ;;------------------------------------------------------------------------- ;; ;; KEY BINDINGS +;; ============ ;; -;; All important functions of RefTeX can be reached from its menu which -;; is installed in the menu bar as "Ref" menu. Only the more frequently used -;; functions have key bindings. -;; -;; Here is the default set of keybindings from RefTeX. +;; All RefTeX commands can be reached from its menu, the `Ref' menu on the +;; menu bar. More frequently used commands have key bindings: ;; ;; C-c = reftex-toc ;; C-c ( reftex-label @@ -281,9 +355,9 @@ ;; C-c [ reftex-citation ;; C-c & reftex-view-crossref ;; -;; I've used these bindings in order to avoid interfering with AUCTeX's -;; settings. Personally, I also bind some functions in the C-c LETTER -;; map for easier access: +;; These keys are chosen to avoid interfering with AUCTeX's settings. +;; Personally, I also bind some functions in the C-c LETTER map for +;; easier access: ;; ;; C-c t reftex-toc ;; C-c l reftex-label @@ -294,59 +368,137 @@ ;; C-c g reftex-grep-document ;; ;; If you want to copy those as well, set in your .emacs file: -;; +;; ;; (setq reftex-extra-bindings t) ;; ;; It is possible to bind the function for viewing cross references to a -;; mouse event. Something like the following in .emacs will do the trick: +;; mouse event. Something like the following will do the trick: ;; -;; (add-hook 'reftex-load-hook +;; (add-hook 'reftex-load-hook ;; '(lambda () -;; (define-key reftex-mode-map [(alt mouse-1)] +;; (define-key reftex-mode-map [(shift mouse-2)] ;; 'reftex-mouse-view-crossref))) -;; +;;------------------------------------------------------------------------- +;; +;; REFTEX AND MULTIFILE DOCUMENTS +;; ============================== +;; +;; The following is relevant when using RefTeX for multi-file documents: +;; +;; o RefTeX has full support for multifile documents. You can edit parts +;; of several (multifile) documents at the same time without conflicts. +;; RefTeX provides functions to run `grep', `search' and `query-replace' +;; on all files which are part of a multifile document. +;; +;; o All files belonging to a multifile document should have a File +;; Variable (`TeX-master' for AUCTeX or `tex-main-file' for the standard +;; Emacs LaTeX mode) set to the name of the master file. See the +;; documentation of your (La)TeX mode and the Emacs documentation on +;; file variables: [Emacs/Customization/Variables/File Variables]. +;; +;; o The context of a label definition must be found in the same file as +;; the label itself in order to be processed correctly by RefTeX. The +;; only exception is that section labels referring to a section statement +;; outside the current file can still use that section title as context. ;;------------------------------------------------------------------------- ;; +;; REFERENCES TO OTHER DOCUMENTS +;; ============================= +;; +;; RefTeX supports the LaTeX package `xr', which makes it possible to +;; reference labels defined in another document. See the documentation on +;; `xr' for details. +;; When the document is set up to work with `xr', you can use the `x' key +;; in the reference label menu to switch to the label menu of an external +;; document and select any labels from there. In the *toc* buffer, the +;; `x' key can be used to switch to the table of contents of an external +;; document. +;; +;; For this kind of inter-document cross references, saving of parsing +;; information can mean a large speed-up. +;; +;; (setq reftex-save-parse-info t) +;; +;;------------------------------------------------------------------------- +;; +;; OPTIMIZATIONS FOR LARGE DOCUMENTS +;; ================================= +;; +;; The default settings of RefTeX ensure a safe ride for beginners and +;; casual users. However, when using RefTeX for a large project and/or on +;; a small computer, there are ways to improve speed or memory usage. +;; +;; o RefTeX will load other parts of a multifile document as well as BibTeX +;; database files for lookup purposes. These buffers are kept, so that +;; subsequent use of the same files is fast. If you can't afford keeping +;; these buffers around, and if you can live with a speed penalty, try +;; +;; (setq reftex-keep-temporary-buffers nil) +;; +;; o The `C-u' prefix on the major RefTeX commands `reftex-label', +;; `reftex-reference', `reftex-citation' and `reftex-toc' initiates +;; re-parsing of the entire document in order to update the parsing +;; information. For a large document this can be unnecessary, in +;; particular if only one file has changed. RefTeX can be configured to +;; do partial scans instead of full ones. `C-u' re-parsing then does +;; apply only to the current buffer and files included from it. +;; Likewise, the `r' key in both the label menu and the table-of-contents +;; buffer will only prompt scanning of the file in which the label or +;; section macro near the cursor was defined. Re-parsing of the entire +;; document is still available by using `C-u C-u' as a prefix, or the +;; capital `R' key in the menus. To use this feature, try +;; +;; (setq reftex-enable-partial-scans t) +;; +;; o Even with partial scans enabled, RefTeX still has to make one full +;; scan, when you start working with a document. To avoid this, parsing +;; information can stored in a file. The file `MASTER.rel' is used for +;; storing information about a document with master file `MASTER.tex'. +;; It is written each time RefTeX parses (part of) the document, and +;; restored when you begin working with a document in a new editing +;; session. To use this feature, put into .emacs: +;; +;; (setq reftex-save-parse-info t) +;;---------------------------------------------------------------------------- +;; ;; RELATED PACKAGES +;; ================ ;; ;; AUCTeX ;; ------ -;; If you are writing any TeX or LaTeX documents with Emacs, you should -;; have a look at AUCTeX, the definitive package to work with TeX and LaTeX. +;; If you are writing TeX or LaTeX documents with Emacs, you should have +;; a look at AUCTeX, the definitive package to work with TeX and LaTeX. ;; Information on AUCTeX can be found here: ;; ;; http://www.sunsite.auc.dk/auctex/ ;; -;; Instead of using the RefTeX functions described above directly, you -;; can also use them indirectly through AUCTeX (>9.7p). RefTeX provides -;; several interface functions which can be used as replacement for -;; corresponding AUCTeX functions dealing with labels and citations. -;; In this way you can work normally with AUCTeX and use RefTeX +;; Instead of using the RefTeX functions described above directly, you can +;; also use them indirectly, through AUCTeX (version 9.8a or later). +;; RefTeX provides several interface functions which can be used as +;; replacement for corresponding AUCTeX functions dealing with labels and +;; citations. In this way you can work normally with AUCTeX and use RefTeX ;; internals to create and complete labels and citation keys. ;; ;; `reftex-label' can be used as the `LaTeX-label-function' which does -;; label insertion when new environments are created with C-c C-e. +;; label insertion when new environments are created with `C-c C-e'. ;; ;; `reftex-arg-label', `reftex-arg-ref' and `reftex-arg-cite' can replace -;; the corresponding `TeX-arg-...' functions. E.g. when you insert a -;; label macro with `C-c RET label RET', RefTeX will be transparently used -;; to create the label. +;; the corresponding `TeX-arg-...' functions. E.g. when you insert a label +;; macro with `C-c RET label RET', RefTeX will be transparently used to +;; create the label. ;; -;; In order to plug all 4 functions into AUCTeX, use in .emacs: +;; In order to plug all 4 functions into AUCTeX, use: ;; ;; (setq reftex-plug-into-AUCTeX t) ;; -;; You may also choose to plug in only some of these functions. The -;; following setting will leave TeX-arg-cite as it was while replacing -;; the other 3 AUCTeX functions: -;; -;; (setq reftex-plug-into-AUCTeX '(t t t nil)) +;; You may also choose to plug in only some of these functions. See the +;; docstring of `reftex-plug-into-AUCTeX'. ;; ;; AUCTeX can support RefTeX via style files. A style file may contain ;; calls to `reftex-add-to-label-alist' which defines additions to -;; `reftex-label-alist'. The argument taken by this function must have -;; the same format as `reftex-label-alist'. The `amsmath.el' style file -;; of AUCTeX (>9.7p) for example contains the following: +;; `reftex-label-alist'. The argument taken by this function must have the +;; same format as `reftex-label-alist'. The `amsmath.el' style file of +;; AUCTeX (>9.7p) for example contains the following: ;; ;; (TeX-add-style-hook "amsmath" ;; (function @@ -362,111 +514,93 @@ ;; (lambda () ;; (if (featurep 'reftex) ;; (reftex-add-to-label-alist -;; '(("proposition" ?p "prop:" "~\\ref{%s}" t +;; '(("proposition" ?p "prop:" "~\\ref{%s}" t ;; ("Proposition" "Prop.")))))))) ;; ;; Bib-cite.el ;; ----------- -;; Once you have written a document with labels, refs and citations, -;; it can be nice to read such a file like a hypertext document. -;; RefTeX has some support for that (`reftex-view-crossref', -;; `reftex-search-document'). A more elegant interface with mouse -;; support and links into Hyperbole is provided (among other things) -;; by Peter S. Galbraith's `bib-cite.el'. There is some overlap in the -;; functionalities of Bib-cite and RefTeX. Bib-cite.el comes bundled -;; with AUCTeX. You can also get the latest version from +;; Once you have written a document with labels, refs and citations, it can +;; be nice to read such a file like a hypertext document. RefTeX has some +;; support for that (`reftex-view-crossref', `reftex-search-document'). A +;; more elegant interface with mouse support and links into Hyperbole is +;; provided (among other things) by Peter S. Galbraith's `bib-cite.el'. +;; There is some overlap in the functionalities of Bib-cite and RefTeX. +;; Bib-cite.el comes bundled with AUCTeX. You can also get the latest +;; version from ;; ;; ftp://ftp.phys.ocean.dal.ca/users/rhogee/elisp/bib-cite.el -;; -;;------------------------------------------------------------------------- -;; -;; PERFORMANCE ISSUES -;; -;; 1. RefTeX will load other parts of a multifile document as well as BibTeX -;; database files for lookup purposes. These buffers are kept, so that -;; subsequent lookup in the same files is fast. For large documents and -;; large BibTeX databases, this can use up a lot of memory. If you have -;; more time than memory, try the following option, which will remove -;; buffers created for lookup after use. -;; -;; (setq reftex-keep-temporary-buffers nil) +;;--------------------------------------------------------------------------- ;; -;; 2. Parsing the document for labels and their context can be slow. -;; Therefore, RefTeX does it just once automatically. Further parsing -;; happens only on user request -;; - with a raw C-u prefix arg to any of the functions `reftex-label', -;; `reftex-reference', `reftex-citation', `reftex-toc'. -;; - with the `r' key from the label selection menu or the *toc* buffer. +;; KNOWN BUGS AND WORK-AROUNDS +;; =========================== ;; -;; *** If you use `reftex-label' to create labels, the list will be -;; *** updated internally, so that no extra parsing is required. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; KNOWN BUGS +;; o \input, \include, \bibliography and \section (etc.) statements have +;; to be first on a line (except for white space). ;; -;; o If you change `reftex-label-alist' in an editing session, you need to -;; reset reftex with `M-x reftex-reset-mode' in order to make these -;; changes effective. Changes introduced with the function -;; `reftex-add-to-label-alist' as well as changes applied from the -;; customization buffer automatically trigger a reset. +;; o RefTeX sees also labels in regions commented out and will refuse to +;; make duplicates of such a label. This is considered to be a feature. ;; -;; o At times the short context shown by RefTeX may not be what you want. -;; In particular, eqnarray environments can be difficult to -;; parse. RefTeX's default behavior for eqnarrays is to scan backwards to -;; either a double backslash or the beginning of the environment. If this -;; gives unsatisfactory results, make it a habit to place the label -;; *before* each equation -;; -;; \begin{eqnarray} -;; \label{eq:1} -;; E = \gamma m c^2 \\ -;; \label{eq:2} -;; \gamma = \sqrt{1-v^2/c^2} -;; \end{eqnarray} -;; -;; and turn off parsing for context in equation and eqnarray environments -;; with -;; -;; (setq reftex-use-text-after-label-as-context "e"). -;; -;; o RefTeX keeps only one global copy of the configuration variables. -;; Also any additions from style files go into a global variable. +;; o When using partial scans (`reftex-enable-partial-scans'), the section +;; numbers in the table of contents may eventually become wrong. A full +;; scan will fix this. +;; +;; o RefTeX keeps only a global copy of the configuration variables. +;; Also, any additions from style files go into a global variable. ;; Practically, this should not be a problem. Theoretically, it could ;; give conflicts if two documents used environments with identical ;; names, but different associated label types. -;; -;; o Input, include, bibliography and section statements have to be first -;; on a line (except for white space) in order to be seen by reftex. -;; -;; o When the document is scanned, RefTeX creates a large buffer containing -;; the entire document instead of scanning the individual files one by -;; one. This is necessary since a file might not contain the context -;; needed by RefTeX. +;; +;; o When using packages which make the buffer representation of a file +;; different from its disk representation (e.g. x-symbol, isotex, +;; iso-cvt) you may find that RefTeX's parsing information sometimes +;; reflects the disk state of a file. This happens only in *unvisited* +;; parts of a multifile document, because RefTeX visits these files +;; literally for speed reasons. Then both short context and section +;; headings may look different from what you usually see on your screen. +;; In rare cases `reftex-toc' may have problems to jump to an affected +;; section heading. There are three possible ways to deal with this: +;; +;; - (setq reftex-keep-temporary-buffers t) +;; This implies that RefTeX will load all parts of a multifile +;; document into Emacs (i.e. there will be no temporary buffers). +;; - (setq reftex-initialize-temporary-buffers t) +;; This means full initialization of temporary buffers. It involves +;; a penalty when the same file is used for lookup often. +;; - Set `reftex-initialize-temporary-buffers' to a list of hook +;; functions doing a minimal initialization. +;; +;; You might also want to check the variable `reftex-refontify-context'. ;; -;; o If you have two identical section headings in the same file, -;; `reftex-toc' will only let you jump to the first one because it searches -;; for the section heading from the beginning of the file. You can work -;; around this by changing one of the section titles in a way LaTeX does -;; not see, e.g. with extra white space. RefTeX will distinguish -;; \section{Introduction} from \section{ Introduction}. +;; o Some nasty :-# packages use an additional argument to a \begin macro +;; to specify a label. E.g. Lamport's "pf.sty" uses both +;; +;; \step{LABEL}{CLAIM} and \begin{step+}{LABEL} +;; CLAIM +;; \end{step+} +;; +;; We need to trick RefTeX into swallowing this: ;; -;; o RefTeX sees also labels in regions commented out and will refuse to -;; make duplicates of such a label. This is considered to be a feature. -;; -;; o When RefTeX tries to show a window full of context from inside a -;; section hidden with `outline-minor-mode', it will unhide that section. -;; This change will not be reversed automatically. +;; ;; Configuration for Lamport's pf.sty +;; (setq reftex-label-alist +;; '(("\\step{*}{}" ?p "st:" "~\\stepref{%s}" 2 ("Step" "St.")) +;; ("\\begin{step+}{*}" ?p "st:" "~\\stepref{%s}" 1000))) ;; -;;--------------------------------------------------------------------------- +;; The first line is just a normal configuration for a macro. For the +;; `step+' environment we actually tell RefTeX to look for the *macro* +;; "\begin{step+}" and interprete the *first* argument (which in reality +;; is a second argument to the macro \begin) as a label of type ?p. +;; Argument count for this macro starts only after the {step+}, also +;; when specifying how to get context. ;; -;; TO DO -;; -;; I think I am pretty much done with this one... -;; +;; o In XEmacs 19.15, the overlay library has a bug. RefTeX does not +;; suffer from it, but since it loads the library, other packages like +;; GNUS will switch from extents to overlays and hit the bug. Upgrade +;; to XEmacs 20, or fix the overlay library (in line 180 of overlay.el, +;; change `(list before after)' to `(cons before after)'). ;;--------------------------------------------------------------------------- ;; ;; AUTHOR +;; ====== ;; ;; Carsten Dominik ;; @@ -480,29 +614,113 @@ ;; THANKS TO: ;; --------- ;; At least the following people have invested time to test and bug-fix -;; reftex.el. Some have send patches for fixes or new features. +;; reftex.el. Some have send patches for fixes or new features, or came +;; up with useful ideas. ;; ;; Stephen Eglen -;; F.E.Burstall +;; F.E. Burstall ;; Karl Eichwalder ;; Laurent Mugnier ;; Rory Molinari ;; Soren Dayton ;; Daniel Polani ;; Allan Strand +;; Adrian Lanz +;; Jan Vroonhof +;; Alastair Burt +;; Dieter Kraft +;; Robin S. Socha ;; -;; The view crossref feature was inspired by the similar function in +;; The view crossref feature was inspired by the similar function in ;; Peter S. Galbraith's bib-cite.el. -;; +;; ;; Finally thanks to Uwe Bolick who first ;; got me (some years ago) into supporting LaTeX labels and references ;; with an Editor (which was MicroEmacs at the time). ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; +;; HISTORY +;; ======= +;; +;; Here are the more important changes made to RefTeX since initial release. +;; Minor bug fixes are not mentioned. +;; +;; Version 1.00 +;; - released on 7 Jan 1997. +;; Version 1.04 +;; - Macros as wrappers, AMSTeX support, delayed context parsing for +;; new labels. +;; Version 1.05 +;; - XEmacs port. +;; Version 1.07 +;; - RefTeX gets its own menu. +;; Version 1.09 +;; - Support for tex-main-file, an analogue for TeX-master. +;; - MS-DOS support. +;; Version 2.00 +;; - Labels can be derived from context (default for sections). +;; - Configuration of label insertion and label referencing revised. +;; - Crossref fields in BibTeX database entries. +;; - `reftex-toc' introduced (thanks to Stephen Eglen). +;; Version 2.03 +;; - Figure*, table*, Sidewaysfigure/table added to default environments. +;; - `reftex-bibfile-ignore-list' introduced (thanks to Rory Molinari). +;; - New functions `reftex-arg-label', `reftex-arg-ref', `reftex-arg-cite'. +;; - Emacs/XEmacs compatibility reworked. XEmacs 19.15 now is required. +;; - `reftex-add-to-label-alist' (to be called from AUCTeX style files). +;; - Finding context with a hook function. +;; - Sorting BibTeX entries (new variable: `reftex-sort-bibtex-matches'). +;; Version 2.05 +;; - Support for `custom.el'. +;; - New function `reftex-grep-document' (thanks to Stephen Eglen). +;; Version 2.07 +;; - New functions `reftex-search-document', `reftex-query-replace-document' +;; Version 2.11 +;; - Submitted for inclusion to Emacs and XEmacs. +;; Version 2.14 +;; - Variable `reftex-plug-into-AUCTeX' simplifies cooperation with AUCTeX. +;; Version 2.17 +;; - Label prefix expands % escapes with current file name and other stuff. +;; - Citation format now with % escapes. This is not backward compatible! +;; - TEXINPUTS variable recognized when looking for input files. +;; - Context can be the nth argument of a macro. +;; - Searching in the select buffer is now possible (C-s and C-r). +;; - Display and derive-label can use two different context methods. +;; - AMSmath xalignat and xxalignat added. +;; - THIS IS THE VERSION DISTRIBUTED WITH EMACS 20.1 and 20.2 +;; Version 3.00 +;; - RefTeX should work better for very large projects: +;; - The new parser works without creating a master buffer. +;; - Rescanning can be limited to a part of a multifile document. +;; - Information from the parser can be stored in a file. +;; - RefTeX can deal with macros having a naked label as an argument. +;; - Macros may have white space and newlines between arguments. +;; - Multiple identical section headings no longer confuse `reftex-toc'. +;; - RefTeX should work correctly in combination with buffer-altering +;; packages like outline, folding, x-symbol, iso-cvt, isotex, etc. +;; - All labeled environments discussed in `The LaTeX Companion' by +;; Goossens, Mittelbach & Samarin, Addison-Wesley 1994) are part of +;; RefTeX's defaults. +;; Version 3.03 +;; - Support for the LaTeX package `xr', for inter-document references. +;; - A few (minor) Mule-related changes. +;; - Fixed bug which could cause HUGE .rel files. +;; - Search for input and .bib files with recursive path definitions. +;; Version 3.04 +;; - Fixed BUG in the `xr' support. +;; Version 3.05 +;; - Compatibility code now first checks for XEmacs feature. +;; Version 3.07 +;; - `Ref' menu improved. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;;;;; ;;; Code: +(eval-when-compile (require 'cl)) + ;; Stuff that needs to be there when we use defcustom ;; -------------------------------------------------- @@ -516,103 +734,322 @@ (setq reftex-tables-dirty t) (set symbol value))) +(eval-and-compile + (defmacro reftex-fp (n) + (if (fboundp 'forward-point) + (list 'forward-point n) + (list '+ '(point) n)))) + ;;; Begin of Configuration Section ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Define the two constants which are needed during compilation + +(eval-and-compile +(defconst reftex-label-alist-builtin + '( + ;; Some aliases, mostly for backward compatibility + (Sideways "Alias for -->rotating" (rotating)) + (AMSTeX "amsmath with eqref macro" + ((nil ?e nil "~\\eqref{%s}") + amsmath)) + + ;; Individual package defaults + (amsmath "AMS-LaTeX math environments" + (("align" ?e nil nil eqnarray-like) + ("gather" ?e nil nil eqnarray-like) + ("multline" ?e nil nil t) + ("flalign" ?e nil nil eqnarray-like) + ("alignat" ?e nil nil alignat-like) + ("xalignat" ?e nil nil alignat-like) + ("xxalignat" ?e nil nil alignat-like) + ("subequations" ?e nil nil t))) + + (endnotes "The \\endnote macro" + (("\\endnote[]{}" ?n nil nil 2 ("Endnote")))) + + (fancybox "The Beqnarray environment" + (("Beqnarray" ?e nil nil eqnarray-like))) + + (floatfig "The floatingfigure environment" + (("floatingfigure" ?f nil nil caption))) + + (longtable "The longtable environment" + (("longtable" ?t nil nil caption))) + + (picinpar "The figwindow and tabwindow environments" + (("figwindow" ?f nil nil 1) + ("tabwindow" ?f nil nil 1))) + + (rotating "Sidewaysfigure and table" + (("sidewaysfigure" ?f nil nil caption) + ("sidewaystable" ?t nil nil caption))) + + (subfigure "Subfigure environments/macro" + (("subfigure" ?f nil nil caption) + ("subfigure*" ?f nil nil caption) + ("\\subfigure[]{}" ?f nil nil 1))) + + (supertab "Supertabular environment" + (("supertabular" ?t nil nil "\\tablecaption{"))) + + (wrapfig "The wrapfigure environment" + (("wrapfigure" ?f nil nil caption))) + + ;; The LaTeX core stuff + (LaTeX "LaTeX default environments" + (("section" ?s "sec:" "~\\ref{%s}" (nil . t) + ("Part" "Chapter" "Chap." "Section" "Sec." "Sect." "Paragraph" "Par." + "\\S" "Teil" "Kapitel" "Kap." "Abschnitt" )) + + ("enumerate" ?i "item:" "~\\ref{%s}" item + ("Item" "Punkt")) + + ("equation" ?e "eq:" "~(\\ref{%s})" t + ("Equation" "Eq." "Eqn." "Gleichung" "Gl.")) + ("eqnarray" ?e "eq:" nil eqnarray-like) + + ("figure" ?f "fig:" "~\\ref{%s}" caption + ("Figure" "Fig." "Abbildung" "Abb.")) + ("figure*" ?f nil nil caption) + + ("table" ?t "tab:" "~\\ref{%s}" caption + ("Table" "Tab." "Tabelle")) + ("table*" ?t nil nil caption) + + ("\\footnote[]{}" ?n "note:" "~\\ref{%s}" 2 + ("Footnote" "Note")) + + ("any" ?\ " " "\\ref{%s}" nil))) + + ) + "The default label environment descriptions. +Lower-case symbols correspond to a style file of the same name in the LaTeX +distribution. Mixed-case symbols are convenience aliases.") + +(defconst reftex-cite-format-builtin + '( + (default "Default macro \\cite{%l}" + "\\cite{%l}") + (natbib "The Natbib package" + ((?\C-m . "\\cite{%l}") + (?t . "\\citet{%l}") + (?T . "\\citet*{%l}") + (?p . "\\citep{%l}") + (?P . "\\citep*{%l}") + (?e . "\\citep[e.g.][]{%l}") + (?a . "\\citeauthor{%l}") + (?y . "\\citeyear{%l}"))) + (harvard "The Harvard package" + ((?\C-m . "\\cite{%l}") + (?p . "\\cite{%l}") + (?t . "\\citeasnoun{%l}") + (?n . "\\citeasnoun{%l}") + (?s . "\\possessivecite{%l}") + (?e . "\\citeaffixed{%l}{?}") + (?y . "\\citeyear{%l}") + (?a . "\\citename{%l}"))) + (chicago "The Chicago package" + ((?\C-m . "\\cite{%l}") + (?t . "\\citeN{%l}") + (?T . "\\shortciteN{%l}") + (?p . "\\cite{%l}") + (?P . "\\shortcite{%l}") + (?a . "\\citeA{%l}") + (?A . "\\shortciteA{%l}") + (?y . "\\citeyear{key}"))) + (astron "The Astron package" + ((?\C-m . "\\cite{%l}") + (?p . "\\cite{%l}" ) + (?t . "%2a (\\cite{%l})"))) + (author-year "Do-it-yourself Author-year" + ((?\C-m . "\\cite{%l}") + (?t . "%2a (%y)\\nocite{%l}") + (?p . "(%2a %y\\nocite{%l})"))) + (locally "Full info in parenthesis" + "(%2a %y, %j %v, %P, %e: %b, %u, %s %<)") + ;; undocumented feature: `%<' kills white space and punctuation locally. + ) + "Builtin versions of for the citation format. +The following conventions are valid for all alist entries: +`?\C-m' should always point to a straight \\cite{%l} macro. +`?t' should point to a textual citation (citation as a noun). +`?p' should point to a parenthetical citation.") +) + ;; Configuration Variables and User Options for RefTeX ------------------ (defgroup reftex nil "LaTeX label and citation support." :tag "RefTeX" - :link '(url-link :tag "Home Page" "http://strw.leidenuniv.nl/~dominik/Tools/") + :link '(url-link :tag "Home Page" + "http://strw.leidenuniv.nl/~dominik/Tools/") + :link '(emacs-commentary-link :tag "Commentary in reftex.el" "reftex.el") :prefix "reftex-" :group 'tex) (defun reftex-customize () "Call the customize function with reftex as argument." (interactive) - (if (fboundp 'customize-group) - (customize-group 'reftex) - (customize 'reftex))) + ;; Depending on the customize version we can call different functions. + (cond + ((fboundp 'customize-browse) + (customize-browse 'reftex)) + ((fboundp 'customize-group) + (customize-group 'reftex)) + ((fboundp 'customize) + (customize 'reftex)) + (t (error "Custom.el not available")))) + +(defun reftex-show-commentary () + "Use the finder to view the file documentation from `reftex.el'." + (interactive) + (require 'finder) + (finder-commentary "reftex.el")) ;; Support for \label and \ref -------------------------------------- (defgroup reftex-label-support nil "Support for creation, insertion and referencing of labels in LaTeX." - :prefix "reftex-" :group 'reftex) (defgroup reftex-defining-label-environments nil "Definition of environments and macros to do with label." - :prefix "reftex-" :group 'reftex-label-support) +;; Make a constant for the customization stuff +(eval-and-compile + (defconst reftex-tmp + '((const :tag "Default position" t) + (const :tag "After label" nil) + (number :tag "Macro arg nr" 1) + (regexp :tag "Regexp" "") + (const :tag "Caption in float" caption) + (const :tag "Item in list" item) + (const :tag "Eqnarray-like" eqnarray-like) + (const :tag "Alignat-like" alignat-like) + (symbol :tag "Function" my-func)))) + +(defcustom reftex-default-label-alist-entries + '(amsmath endnotes fancybox floatfig longtable picinpar + rotating subfigure supertab wrapfig LaTeX) + "Default label alist specifications. LaTeX should be the last entry. +This list describes the default label environments RefTeX should always use. +It is probably a mistake to remove the LaTeX symbol from this list. + +The options include: +LaTeX The standard LaTeX environments. +Sideways The sidewaysfigure and sidewaystable environments. +AMSTeX The math environments in the AMS-LaTeX amsmath package. + +For the full list of options, try + +M-x customize-variable RET reftex-default-label-alist-entries RET." + :group 'reftex-defining-label-environments + :set 'reftex-set-dirty + :type `(set + :indent 4 + :inline t + :greedy t + ,@(mapcar + (function + (lambda (x) + (list 'const ':tag (concat (symbol-name (nth 0 x)) + ": " (nth 1 x)) + (nth 0 x)))) + reftex-label-alist-builtin))) (defcustom reftex-label-alist nil "Alist with information on environments for \\label-\\ref use. -See the definition of `reftex-label-alist-builtin' for examples. This variable -should define additions and changes to the default. The only things you MUST -NOT change is that `?s' is the type indicator for section labels and SPACE is -for the `any' label type. These are hard-coded at other places in the code. - -Changes to this variable after RefTeX has been loaded become only -effective when RefTeX is reset with \\[reftex-reset-mode]. - -Each list entry is a list describing an environment or macro carrying a -label. The elements of each list entry are: + +This docstring is easier to understand after reading the configuration +examples in `reftex.el'. Looking at the builtin defaults in the constant +`reftex-label-alist-builtin' may also be instructive. + +Set this variable to define additions and changes to the default. The only +things you MUST NOT change is that `?s' is the type indicator for section +labels, and SPC for the `any' label type. These are hard-coded at other +places in the code. + +Each list entry describes either an environment carrying a counter for use +with \\label and \\ref, or a LaTeX macro defining a label as (or inside) +one of its arguments. The elements of each list entry are: 0. Name of the environment (like \"table\") or macro (like \"\\\\myfig\"). + For macros, indicate the macro arguments for best results, as in + \"\\\\myfig[]{}{}{*}{}\". Use square brackets for optional arguments, + a star to mark the label argument, if any. The macro does not have to + have a label argument - you could also use \\label{..} inside one of + its arguments. Special names: `section' for section labels, `any' to define a group which contains all labels. - This may also be nil if this entry is only meant to change some settings + This may also be nil if the entry is only meant to change some settings associated with the type indicator character (see below). -1. Type indicator character, like `?t'. - The type indicator is a single character used in prompts for - label types. It must be a printable character. The same character - may occur several times in this list, to cover cases in which different - environments carry the same label type (like equation and eqnarray). +1. Type indicator character, like `?t', must be a printable ASCII character. + The type indicator is a single character which defines a label type. + Any label inside the environment or macro is assumed to belong to this + type. The same character may occur several times in this list, to cover + cases in which different environments carry the same label type (like + `equation' and `eqnarray'). 2. Label prefix string, like \"tab:\". The prefix is a short string used as the start of a label. It may be the - empty string. - -3. Format string for reference insert in buffer. Each `%s' will be replaced - by the label (several `%s' can be there to do this: - \"\\ref{%s} on page~\\pageref{%s}\"). + empty string. The prefix may contain the following `%' escapes: + %f Current file name with directory and extension stripped. + %F Current file name relative to directory of master file. + %u User login name, on systems which support this. + + Example: In a file `intro.tex', \"eq:%f:\" will become \"eq:intro:\"). + +3. Format string for reference insert in buffer. `%s' will be replaced by + the label. When the format starts with `~', whitespace before point will be removed so that the reference cannot be separated from the word before it. 4. Indication on how to find the short context. - If nil, use the text following the \\label{...} macro. - If t, use - - text following the \\begin{...} statement of environments - (not a good choice in in eqnarray or enumerate environments!) - the section heading for section labels. - - the begin of the macro for macros. + - text following the \\begin{...} statement of environments. + (not a good choice for environments like eqnarray or enumerate, + where one has several labels in a single environment). + - text after the macro name (stearting with the first arg) for macros. + - If an integer, use the nth argument of the macro. As a special case, + 1000 means to get text after the last macro argument. - If a string, use as regexp to search *backward* from the label. Context is then the text following the end of the match. E.g. putting this to - \"\\\\\\\\caption{\" will use the beginning of the caption in a figure - or table environment. + \"\\\\\\\\caption[[{]\" will use the caption in a figure or table + environment. \"\\\\\\\\begin{eqnarray}\\\\|\\\\\\\\\\\\\\\\\" works for eqnarrays. + - If any of `caption', `item', `eqnarray-like', `alignat-like', this + symbol will internally be translated into an appropriate regexp + (see also the variable `reftex-default-context-regexps'). - If a function, call this function with the name of the environment/macro as argument. On call, point will be just after the \\label macro. The function is expected to return a suitable context string. It should throw an exception (error) when failing to find context. - Consider the following example, which would return the 10 characters - following the label as context: + As an example, here is a function returning the 10 chars following + the label macro as context: (defun my-context-function (env-or-mac) (if (> (point-max) (+ 10 (point))) (buffer-substring (point) (+ 10 (point))) (error \"Buffer too small\"))) + Label context is used in two ways by RefTeX: For display in the label + menu, and to derive a label string. If you want to use a different + method for each of these, specify them as a dotted pair. + E.g. `(nil . t)' uses the text after the label (nil) for display, and + text from the default position (t) to derive a label string. This is + actually used for section labels. + Setting the variable `reftex-use-text-after-label-as-context' to t overrides the setting here. 5. List of magic words which identify a reference to be of this type. If the word before point is equal to one of these words when calling - `reftex-reference', the label list offered will be automatically restricted - to labels of the correct type. + `reftex-reference', the label list offered will be automatically + restricted to labels of the correct type. If the type indicator characters of two or more entries are the same, RefTeX will use @@ -621,77 +1058,81 @@ Any list entry may also be a symbol. If that has an association in `reftex-label-alist-builtin', the cdr of that association is spliced into the -list. See the AMSTeX configuration example in the comment section of -`reftex.el'." +list. However, builtin defaults should normally be set here but with the +variable `reftex-default-label-alist-entries." :group 'reftex-defining-label-environments :set 'reftex-set-dirty - :type '(list - :convert-widget - (lambda (widget) - (let* - ((args - (list - `(repeat - :inline t - (radio - :value ("" ?a nil nil t nil) - (choice - :tag "Builtin" - :value AMSTeX - ,@(mapcar (function (lambda (x) - (list 'const ':tag (nth 1 x) (car x)))) - reftex-label-alist-builtin)) - (list :tag "Detailed custom entry" - (choice :tag "Environment or \\macro " - (const :tag "Ignore, just use typekey" nil) - (string "")) - (character :tag "Typekey character " ?a) - (choice :tag "Label prefix string " - (const :tag "Copy from similar label type" nil) - (string :tag "Specify here" "lab:")) - (choice :tag "Label reference format" - (const :tag "Copy from similar label type" nil) - (string :tag "Specify here" "~\\ref{%s}")) - (choice :tag "Grab context method " - (const :tag "Default position" t) - (const :tag "After label" nil) - (regexp :tag "Regular expression" "") - (symbol :tag "Function" my-context-function)) - (repeat :tag "List of Magic Words" (string)))))))) - (widget-put widget :args args) - widget)))) - -(defcustom reftex-default-label-alist-entries '(Sideways LaTeX) - "Default label alist specifications. LaTeX should be the last entry. -This list describes the default label environments RefTeX should always use -in addition to the specifications in reftex-label-alist. It is probably a -mistake to remove the LaTeX symbol from this list. - -The options include: -LaTeX The standard LaTeX environments -Sideways The sidewaysfigure and sidewaystable environments -AMSTeX The math environments in the AMS_LaTeX amsmath package - -For the full list of options, see the constant `reftex-label-alist-builtin'. -Better still, try - -M-x customize-variable RET reftex-default-label-alist-entries RET." + :type + `(repeat + (choice + :value ("" ?a nil nil nil nil) + (list :tag "Detailed label alist entry" + :value ("" ?a nil nil nil nil) + (choice :tag "Environment or \\macro " + (const :tag "Ignore, just use typekey" nil) + (string "")) + (character :tag "Typekey character " ?a) + (choice :tag "Label prefix string " + (const :tag "Default" nil) + (string :tag "String" "lab:")) + (choice :tag "Label reference format" + (const :tag "Default" nil) + (string :tag "String" "~\\ref{%s}")) + (choice :tag "Context" + (choice + :tag "1 method" + ,@reftex-tmp) + (cons :tag "Split methods" + (choice + :tag " Display context " + ,@reftex-tmp) + (choice + :tag " Derive label context" + ,@reftex-tmp))) + (repeat :tag "List of Magic Words" (string))) + (choice + :tag "Package" + :value AMSTeX + ,@(mapcar + (function + (lambda (x) + (list 'const ':tag (concat (symbol-name (nth 0 x))); ": " (nth 1 x)) + (nth 0 x)))) + reftex-label-alist-builtin))))) + +;; LaTeX section commands and level numbers +(defcustom reftex-section-levels + '( + ("part" . 0) + ("chapter" . 1) + ("section" . 2) + ("subsection" . 3) + ("subsubsection" . 4) + ("paragraph" . 5) + ("subparagraph" . 6) + ("subsubparagraph" . 7) + ) + "Commands and levels used for defining sections in the document. +The car of each cons cell is the name of the section macro. The cdr is a +number indicating its level." :group 'reftex-defining-label-environments - :set 'reftex-set-dirty - :type '(list :indent 4 - :convert-widget - (lambda (widget) - (let* ((args - (list - `(checklist - :inline t - ,@(reverse - (mapcar (lambda (x) - (list 'const ':tag (nth 1 x) (car x))) - reftex-label-alist-builtin)))))) - (widget-put widget :args args) - widget)))) - + :set 'reftex-set-dirty + :type '(repeat + (cons (string :tag "sectioning macro" "") + (number :tag "level " 0)))) + +(defcustom reftex-default-context-regexps + '((caption . "\\\\\\(rot\\)?caption\\*?[[{]") + (item . "\\\\item\\(\\[[^]]*\\]\\)?") + (eqnarray-like . "\\\\begin{%s}\\|\\\\\\\\") + (alignat-like . "\\\\begin{%s}{[0-9]*}\\|\\\\\\\\")) +"Alist with default regular expressions for finding context. +The form (format regexp (regexp-quote environment)) is used to calculate +the final regular expression - so %s will be replaced with the environment +or macro." + :group 'reftex-defining-label-environments + :type '(repeat (cons (symbol) (regexp)))) + (defcustom reftex-use-text-after-label-as-context nil "*t means, grab context from directly after the \\label{..} macro. This is the fastest method for obtaining context of the label definition, but @@ -702,14 +1143,13 @@ :group 'reftex-defining-label-environments :set 'reftex-set-dirty :type '(choice - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types"))) + (const :tag "on" t) (const :tag "off" nil) + (string :tag "Selected label types"))) ;; Label insertion (defgroup reftex-making-and-inserting-labels nil "Options on how to create new labels." - :prefix "reftex-" :group 'reftex-label-support) (defcustom reftex-insert-label-flags '("s" "sft") @@ -720,6 +1160,8 @@ The conversion of the context to a legal label is governed by the specifications given in `reftex-derive-label-parameters'. If RefTeX fails to derive a label, it will prompt the user. +If DERIVE is nil, the label generated will consist of the prefix and a +unique number, like `eq:23'. If PROMPT is t, the user will be prompted for a label string. The prompt will already contain the prefix, and (if DERIVE is t) a default label derived from @@ -746,14 +1188,14 @@ :type '(list (choice :tag "Derive label from context" (const :tag "always" t) (const :tag "never" nil) - (string :tag "for selected label types" "")) + (string :tag "selected label types" "")) (choice :tag "Prompt for label string " :entry-format " %b %v" (const :tag "always" t) (const :tag "never" nil) - (string :tag "for selected label types" "")))) - -(defcustom reftex-derive-label-parameters '(3 20 t 1 "-" ; continue + (string :tag "selected label types" "")))) + +(defcustom reftex-derive-label-parameters '(3 20 t 1 "-" ("the" "on" "in" "off" "a" "for" "by" "of" "and" "is")) "Parameters for converting a string into a label. NWORDS Number of words to use. @@ -768,19 +1210,19 @@ IGNOREWORDS List of words which should not be part of labels." :group 'reftex-making-and-inserting-labels :type '(list (integer :tag "Number of words " 3) - (integer :tag "Maximum label length " 20) - (choice :tag "Illegal characters in words" - (const :tag "throw away entire word" nil) - (const :tag "throw away single chars" t)) - (choice :tag "Abbreviate words " - (const :tag "never" nil) - (const :tag "always" t) - (const :tag "when label is too long" 1)) - (string :tag "Separator between words " "-") - (repeat :tag "Ignore words" - :entry-format " %i %d %v" - (string :tag "")))) - + (integer :tag "Maximum label length " 20) + (choice :tag "Illegal characters in words" + (const :tag "throw away entire word" nil) + (const :tag "throw away single chars" t)) + (choice :tag "Abbreviate words " + (const :tag "never" nil) + (const :tag "always" t) + (const :tag "when label is too long" 1)) + (string :tag "Separator between words " "-") + (repeat :tag "Ignore words" + :entry-format " %i %d %v" + (string :tag "")))) + (defcustom reftex-label-illegal-re "[\000-\040\177-\377\\\\#$%&~^_{}]" "Regexp matching characters not legal in labels. For historic reasons, this character class comes *with* the [] brackets." @@ -795,21 +1237,25 @@ AFTER Character class after abbrev point in word." :group 'reftex-making-and-inserting-labels :type '(list - (integer :tag "Minimum chars per word" 4) - (integer :tag "Shorten by at least " 2) - (string :tag "cut before char class " "^saeiou") - (string :tag "cut after char class " "aeiou"))) - + (integer :tag "Minimum chars per word" 4) + (integer :tag "Shorten by at least " 2) + (string :tag "cut before char class " "^saeiou") + (string :tag "cut after char class " "aeiou"))) ;; Label referencing (defgroup reftex-referencing-labels nil "Options on how to reference labels." - :prefix "reftex-" :group 'reftex-label-support) -(defcustom reftex-label-menu-flags '(t t nil nil nil nil) - "*List of flags governing the label menu makeup. +(eval-and-compile + (defconst reftex-tmp + '((const :tag "on" t) + (const :tag "off" nil) + (string :tag "Selected label types")))) + +(defcustom reftex-label-menu-flags '(t t nil nil nil nil t nil) + "List of flags governing the label menu makeup. The flags are: TABLE-OF-CONTENTS Show the labels embedded in a table of context. @@ -817,8 +1263,9 @@ COUNTERS Show counters. This just numbers the labels in the menu. NO-CONTEXT Non-nil means do NOT show the short context. FOLLOW Follow full context in other window. -SHOW-COMMENTED Show labels from regions which are commented out. RefTeX - sees these labels, but does not normally show them. +SHOW-COMMENTED Show labels from regions which are commented out. +MATCH-IN-TOC Searches in label menu will also match in toc lines. +SHOW FILES Show Begin and end of included files. Each of these flags can be set to t or nil, or to a string of type letters indicating the label types for which it should be true. These strings work @@ -830,25 +1277,37 @@ decide here to not have a table of contents in the label menu, you can still get one interactively during selection from the label menu." :group 'reftex-referencing-labels - :type '(list - (choice :tag "Embed in table of contents " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Show section numbers " - (const :tag "on" t) (const :tag "off" nil)) - (choice :tag "Show individual counters " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Hide short context " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Follow context in other window" - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Show commented labels " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")))) - + :type + `(list + (choice :tag "Embed in table of contents " ,@reftex-tmp) + (choice :tag "Show section numbers " ,@reftex-tmp) + (choice :tag "Show individual counters " ,@reftex-tmp) + (choice :tag "Hide short context " ,@reftex-tmp) + (choice :tag "Follow context in other window " ,@reftex-tmp) + (choice :tag "Show commented labels " ,@reftex-tmp) + (choice :tag "Searches match in toc lines " ,@reftex-tmp) + (choice :tag "Show begin/end of included files" ,@reftex-tmp))) + +(defcustom reftex-level-indent 2 + "*Number of spaces to be used for indentation per section level." + :group 'reftex-referencing-labels + :type '(integer)) + +(defcustom reftex-refontify-context 1 + "*Non-nil means, re-fontify the context in the label menu with font-lock. +This slightly slows down the creation of the label menu. It is only necessay +when you definitely want the context fontified. + +This option may have 3 different values: +nil Never refontify. +t Always refontify. +1 Refontify when absolutly necessary, e.g. when with the x-symbol package. +The option is ignored when `reftex-use-fonts' is nil." + :group 'reftex-referencing-labels + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "When necessary" 1))) (defcustom reftex-guess-label-type t "*Non-nil means, `reftex-reference' will try to guess the label type. @@ -863,7 +1322,6 @@ (defgroup reftex-citation-support nil "Support for referencing bibliographic data with BibTeX." - :prefix "reftex-" :group 'reftex) (defcustom reftex-bibpath-environment-variables '("BIBINPUTS" "TEXBIB") @@ -873,7 +1331,7 @@ :type '(repeat (string :tag "Environment variable"))) (defcustom reftex-bibfile-ignore-list nil - "List of files in \\bibliography{..} RefTeX should *not* parse. + "*List of files in \\bibliography{..} RefTeX should *not* parse. The file names have to be in the exact same form as in the bibliography macro - i.e. without the `.bib' extension. Intended for files which contain only `@string' macro definitions and the @@ -891,85 +1349,180 @@ 'reverse-year Sort entries by decreasing year." :group 'reftex-citation-support :type '(choice (const :tag "not" nil) - (const :tag "by author" author) - (const :tag "by year" year) - (const :tag "by year, reversed" reverse-year))) - -(defcustom reftex-cite-format 'reftex-cite-format-default - "Defines the format of citations to be inserted into the buffer. -It can be a string, a list of strings, or an alist with characters as keys -and a list of strings in the car. In the simplest case, this can just -be the string \"\\cite{KEY}\", which is also the default. See the -definition of the `reftex-cite-format-XXXX' constants for more complex -examples. - If `reftex-cite-format' is a string, it will be used as the format. -In the format, AUTHOR will be replaced by the last name of the -author, YEAR will be replaced by the year and KEY by the citation -key. If AUTHOR is present several times, it will be replaced with -successive author names. -See the constant `reftex-cite-format-default' for an example. - If `reftex-cite-format' is a list of strings, the string used will -depend upon the number of authors of the article. No authors means, -the first string will be used; 1 author means, the second string will -be used etc.. The last string in the list will be used for all articles -with too many authors. See `reftex-cite-format-1-author-simple' for an -example. - If `reftex-cite-format' is a list of cons cells, the car of each cell -needs to be a character. When a selected reference is accepted by -pressing that key, the cdr of the associated list will be used as -described above. See `reftex-cite-format-2-authors' for an example. + (const :tag "by author" author) + (const :tag "by year" year) + (const :tag "by year, reversed" reverse-year))) + +(defcustom reftex-cite-format 'default + "*The format of citations to be inserted into the buffer. +It can be a string or an alist. In the simplest case this is just +the string \"\\cite{%l}\", which is also the default. See the +definition of `reftex-cite-format-builtin' for more complex examples. + +If `reftex-cite-format' is a string, it will be used as the format. +In the format, the following percent escapes will be expanded. + +%l The BibTeX label of the citation. +%a List of author names, see also `reftex-cite-punctuation. +%2a Like %a, but abbreviate more than 2 authors like Jones et al. +%A First author name only. +%e Works like %a, but on list of editor names. (%2e and %E work a well) + +It is also possible to access all other BibTeX database fields: +%b booktitle %c chapter %d edition %h howpublished +%i institution %j journal %k key %m month +%n number %o organization %p pages %P first page +%r address %s school %u publisher %t title +%v volume %y year + +Usually, only %l is needed. Try, however, (setq reftex-comment-citations t). + +If `reftex-cite-format' is an alist of characters and strings, the user +will be prompted for a character to select one of the possible format +strings. In order to configure this variable, you can either set `reftex-cite-format' directly yourself or set it to the SYMBOL of one of -the predefined constants. E.g.: -(setq reftex-cite-format 'reftex-cite-format-2-authors)" - :group 'reftex-citation-support - :type -'(choice - (choice :tag "symbolic defaults" - :value reftex-cite-format-default - (const reftex-cite-format-default) - (const reftex-cite-format-1-author-simple) - (const reftex-cite-format-2-authors)) - (string :tag "format string" "\\cite{KEY}") - (repeat :tag "list of strings" - :value ("\cite{KEY}" "AUTHOR \cite{KEY}" "AUTHOR and AUTHOR \cite{KEY}") - (string :tag "format string" "")) - (repeat :tag "key-ed lists of strings" - :value ((? . ("\cite{KEY}" "AUTHOR \cite{KEY}" "AUTHOR and AUTHOR \cite{KEY}"))) - (cons :tag "Enter a keyed list of format strings" - (character :tag "Key character " ? ) - (repeat - (string :tag "format string" "")))))) +the predefined styles (see `reftex-cite-format-builtin'). E.g.: +(setq reftex-cite-format 'harvard)" + :group 'reftex-citation-support + :type + `(choice + :format "%{%t%}: \n%[Value Menu%] %v" + (radio :tag "Symbolic Builtins" + :indent 4 + :value default + ,@(mapcar + (function + (lambda (x) + (list 'const ':tag (concat (symbol-name (nth 0 x)) + ": " (nth 1 x)) + (nth 0 x)))) + reftex-cite-format-builtin)) + (string :tag "format string" "\\cite{%l}") + (repeat :tag "key-ed format strings" + :value ((?\r . "\\cite{%l}") + (?t . "\\cite{%l}") (?p . "\\cite{%l}")) + (cons (character :tag "Key character" ?\r) + (string :tag "Format string" ""))))) + +(defcustom reftex-comment-citations nil + "*Non-nil means add a comment for each citation describing the full entry. +The comment is formatted according to `reftex-cite-comment-format'." + :group 'reftex-citation-support + :type '(boolean)) + +(defcustom reftex-cite-comment-format + "%% %2a %y, %j %v, %P, %e: %b, %u, %s %<\n" + "Citation format used for commented citations. Must NOT contain %l." + :group 'reftex-citation-support + :type '(string)) + +(defcustom reftex-cite-punctuation '(", " " \\& " " {\\it et al.}") + "Punctuation for formatting of name lists in citations. +This is a list of 3 strings. +1. normal names separator, like \", \" in Jones, Brown and Miller +2. final names separator, like \" and \" in Jones, Brown and Miller +3. The \"et al\" string, like \" {...}\" in Jones {\\it et al.}" + :group 'reftex-citation-support + :type '(list + (string :tag "Separator for names ") + (string :tag "Separator for last name in list") + (string :tag "string used as et al. "))) ;; Table of contents configuration -------------------------------------- (defgroup reftex-table-of-contents-browser nil "A multifile table of contents browser." - :prefix "reftex-" :group 'reftex) (defcustom reftex-toc-follow-mode nil - "Non-nil means, point in *toc* buffer will cause other window to follow. + "*Non-nil means, point in *toc* buffer will cause other window to follow. The other window will show the corresponding part of the document. This flag can be toggled from within the *toc* buffer with the `f' key." :group 'reftex-table-of-contents-browser :type '(boolean)) +;; Tuning the parser ---------------------------------------------------- + +(defgroup reftex-optimizations-for-large-documents nil + "Configuration of parser speed and memory usage." + :group 'reftex) + +(defcustom reftex-keep-temporary-buffers 1 + "*Non-nil means, keep buffers created for parsing and lookup. +RefTeX sometimes needs to visit files related to the current document. +We distinguish files visited for +PARSING: Parts of a multifile document loaded when (re)-parsing the document. +LOOKUP: BibTeX database files and TeX files loaded to find a reference, + to display label context, etc. +The created buffers can be kept for later use, or be thrown away immediately +after use, depending on the value of this variable: + +nil Throw away as much as possible. +t Keep everything. +1 Throw away buffers created for parsing, but keep the ones created + for lookup. + +If a buffer is to be kept, the file is visited normally (which is potentially +slow but will happen only once). +If a buffer is to be thrown away, the initialization of the buffer depends +upon the variable `reftex-initialize-temporary-buffers'." + :group 'reftex-miscellaneous-configurations + :type '(choice + (const :tag "Throw away everything" nil) + (const :tag "Keep everything" t) + (const :tag "Keep lookup buffers only" 1))) + +(defcustom reftex-initialize-temporary-buffers nil + "*Non-nil means do initializations even when visiting file temporarily. +When nil, RefTeX may turn off find-file hooks and other stuff to briefly +visit a file. +When t, the full default initializations are done (find-file-hook etc.). +Instead of t or nil, this variable may also be a list of hook functions to +do a minimal initialization." + :group 'reftex-miscellaneous-configurations + :type '(choice + (const :tag "Read files literally" nil) + (const :tag "Fully initialize buffers" t) + (repeat :tag "Hook functions" :value (nil) + (function-item)))) + +(defcustom reftex-enable-partial-scans nil + "*Non-nil means, re-parse only 1 file when asked to re-parse. +Re-parsing is normally requested with a `C-u' prefix to many RefTeX commands, +or with the `r' key in menus. When this option is t in a multifile document, +we will only parse the current buffer, or the file associated with the label +or section heading near point in a menu. Requesting re-parsing of an entire +multifile document then requires a `C-u C-u' prefix or the capital `R' key +in menus." + :group 'reftex-optimizations-for-large-documents + :type 'boolean) + +(defcustom reftex-save-parse-info nil + "*Non-nil means, save information gathered with parsing in a file. +The file MASTER.rel in the same directory as MASTER.tex is used to save the +information. When this variable is t, +- accessing the parsing information for the first time in an editing session + will read that file (if available) instead of parsing the document. +- each time (part of) the document is rescanned, a new version of the file + is written." + :group 'reftex-optimizations-for-large-documents + :type 'boolean) + ;; Miscellaneous configurations ----------------------------------------- (defgroup reftex-miscellaneous-configurations nil "Collection of further configurations." - :prefix "reftex-" :group 'reftex) (defcustom reftex-extra-bindings nil "Non-nil means, make additional key bindings on startup. These extra bindings are located in the users `C-c letter' map." :group 'reftex-miscellaneous-configurations - :type '(boolean)) + :type '(boolean)) (defcustom reftex-plug-into-AUCTeX nil - "Plug-in flags for AUCTeX interface. + "*Plug-in flags for AUCTeX interface. This variable is a list of 4 boolean flags. When a flag is non-nil, it means: @@ -989,15 +1542,15 @@ may require a restart of Emacs in order to become effective." :group 'reftex-miscellaneous-configurations :type '(choice (const :tag "No plug-ins" nil) - (const :tag "All possible plug-ins" t) - (list - :tag "Individual choice" - :value (nil nil nil nil) - (boolean :tag "Use reftex-label as LaTeX-label-function") - (boolean :tag "Use reftex-arg-label as TeX-arg-label ") - (boolean :tag "Use reftex-arg-ref as TeX-arg-ref ") - (boolean :tag "Use reftex-arg-cite as TeX-arg-cite ") - ))) + (const :tag "All possible plug-ins" t) + (list + :tag "Individual choice" + :value (nil nil nil nil) + (boolean :tag "Use reftex-label as LaTeX-label-function") + (boolean :tag "Use reftex-arg-label as TeX-arg-label ") + (boolean :tag "Use reftex-arg-ref as TeX-arg-ref ") + (boolean :tag "Use reftex-arg-cite as TeX-arg-cite ") + ))) (defcustom reftex-use-fonts t "*Non-nil means, use fonts in label menu and on-the-fly help. @@ -1005,23 +1558,28 @@ :group 'reftex-miscellaneous-configurations :type '(boolean)) -(defcustom reftex-keep-temporary-buffers t - "*Non-nil means, keep any TeX and BibTeX files loaded for lookup. -Nil means, kill it immediately after use unless it was already an existing -buffer before the lookup happened. It is faster to keep the buffers, but can -use a lot of memory, depending on the size of your database and document." +(defcustom reftex-auto-show-entry 'copy + "*Non-nil means, do something when context in other window is hidden. +Some modes like `outline-mode' or `folding-mode' hide parts of buffers. +When RefTeX is asked to show context for a label definition, and the context +is invisible, it can unhide that section permanently (value t), or copy the +context to a temporary buffer (value 'copy)." :group 'reftex-miscellaneous-configurations - :type '(boolean)) - -(defcustom reftex-auto-show-entry t - "*Non-nil means, showing context in another window may unhide a section. -This is important when using outline-minor-mode. If the context to be shown -is in a hidden section, RefTeX will issue a \"show-entry\" command in order -to show it. This is not reversed when the label is selected - so the section -remains shown after command completion." + :type '(radio :value copy + :indent 4 + (const :tag "Do nothing" nil) + (const :tag "Unhide section permanently" t) + (const :tag "Copy context to show" copy))) + +(defcustom reftex-load-hook nil + "Hook which is being run when loading reftex.el." :group 'reftex-miscellaneous-configurations - :type '(boolean)) - + :type 'hook) + +(defcustom reftex-mode-hook nil + "Hook which is being run when turning on RefTeX mode." + :group 'reftex-miscellaneous-configurations + :type 'hook) ;;; End of Configuration Section ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1030,7 +1588,7 @@ ;;; Define the formal stuff for a minor mode named RefTeX. ;;; -(defconst reftex-version "2.14 for Emacs distribution." +(defconst reftex-version "RefTeX version 3.7" "Version string for RefTeX.") (defvar reftex-mode nil @@ -1056,7 +1614,7 @@ context of the label definition. The selected label is inserted as a \\ref macro. -Citations can be made with `\\[reftex-citation]' which will use a regular expression +Citations can be made with `\\[reftex-citation]' which will use a regular expression to pull out a *formatted* list of articles from your BibTeX database. The selected citation is inserted as a \\cite macro. @@ -1066,10 +1624,12 @@ Most command have help available on the fly. This help is accessed by pressing `?' to any prompt mentioning this feature. -Extensive documentation about reftex is in the file header of `reftex.el'. +Extensive documentation about RefTeX is in the file header of `reftex.el'. +You can view this information with `\\[reftex-show-commentary]'. \\{reftex-mode-map} -Under X, these functions will also be available in a menu on the menu bar. +Under X, these and other functions will also be available as `Ref' menu +on the menu bar. ------------------------------------------------------------------------------" @@ -1080,28 +1640,16 @@ ; Add or remove the menu, and run the hook (if reftex-mode (progn - (easy-menu-add reftex-mode-menu) - (reftex-plug-into-AUCTeX) - (run-hooks 'reftex-mode-hook)) + (easy-menu-add reftex-mode-menu) + (reftex-plug-into-AUCTeX) + (run-hooks 'reftex-mode-hook)) (easy-menu-remove reftex-mode-menu))) - + (or (assoc 'reftex-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(reftex-mode " Ref") minor-mode-alist))) + (push '(reftex-mode " Ref") minor-mode-alist)) (or (assoc 'reftex-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'reftex-mode reftex-mode-map) - minor-mode-map-alist))) - - - - - - - - - + (push (cons 'reftex-mode reftex-mode-map) minor-mode-map-alist)) ;;; =========================================================================== ;;; @@ -1119,61 +1667,60 @@ ;;; AUCTeX ;;; ------ -(defun reftex-arg-label (optional &optional prompt definition) +(defun reftex-arg-label (optional &optional prompt definition) "Use `reftex-label' to create label. Insert it with `TeX-argument-insert'. This function is intended for AUCTeX macro support." (let ((label (reftex-label nil t))) - (if (and definition (not (string-equal "" label))) - (LaTeX-add-labels label)) + (if (and definition (not (string-equal "" label))) + (LaTeX-add-labels label)) (TeX-argument-insert label optional optional))) -(defun reftex-arg-ref (optional &optional prompt definition) +(defun reftex-arg-ref (optional &optional prompt definition) "Use `reftex-reference' to select label. Insert with `TeX-argument-insert'. This function is intended for AUCTeX macro support." (let ((label (reftex-reference nil t))) - (if (and definition (not (string-equal "" label))) - (LaTeX-add-labels label)) + (if (and definition (not (string-equal "" label))) + (LaTeX-add-labels label)) (TeX-argument-insert label optional optional))) -(defun reftex-arg-cite (optional &optional prompt definition) +(defun reftex-arg-cite (optional &optional prompt definition) "Use reftex-citation to select a key. Insert with `TeX-argument-insert'. This function is intended for AUCTeX macro support." - (let ((key (reftex-citation nil t))) + (let ((key (reftex-citation t))) (TeX-argument-insert (or key "") optional optional))) (defun reftex-plug-into-AUCTeX () ;; Replace AucTeX functions with RefTeX functions. ;; Which functions are replaced is controlled by the variable ;; `reftex-plug-into-AUCTeX'. - (let ((flags - (cond ((eq reftex-plug-into-AUCTeX t) '(t t t t)) - ((eq reftex-plug-into-AUCTeX nil) '(nil nil nil nil)) - (t reftex-plug-into-AUCTeX)))) + (let ((flags + (cond ((eq reftex-plug-into-AUCTeX t) '(t t t t)) + ((eq reftex-plug-into-AUCTeX nil) '(nil nil nil nil)) + (t reftex-plug-into-AUCTeX)))) (and (nth 0 flags) - (boundp 'LaTeX-label-function) - (setq LaTeX-label-function 'reftex-label)) + (boundp 'LaTeX-label-function) + (setq LaTeX-label-function 'reftex-label)) (and (nth 1 flags) - (fboundp 'TeX-arg-label) - (fset 'TeX-arg-label 'reftex-arg-label)) + (fboundp 'TeX-arg-label) + (fset 'TeX-arg-label 'reftex-arg-label)) (and (nth 2 flags) - (fboundp 'TeX-arg-ref) - (fset 'TeX-arg-ref 'reftex-arg-ref)) + (fboundp 'TeX-arg-ref) + (fset 'TeX-arg-ref 'reftex-arg-ref)) (and (nth 3 flags) - (fboundp 'TeX-arg-cite) - (fset 'TeX-arg-cite 'reftex-arg-cite)))) - + (fboundp 'TeX-arg-cite) + (fset 'TeX-arg-cite 'reftex-arg-cite)))) + (defvar reftex-label-alist-external-add-ons nil "List of label alist entries added with reftex-add-to-label-alist.") -;;;###autoload (defun reftex-add-to-label-alist (entry-list) "Add label environment descriptions to `reftex-label-alist-external-add-ons'. -The format of ENTRY-LIST is exactly like `reftex-label-alist'. See there +The format of ENTRY-LIST is exactly like `reftex-label-alist'. See there for details. This function makes it possible to support RefTeX from AUCTeX style files. The entries in ENTRY-LIST will be processed after the user settings in @@ -1185,10 +1732,9 @@ (while entry-list (setq entry (car entry-list) entry-list (cdr entry-list)) - (if (not (member entry reftex-label-alist-external-add-ons)) - (setq reftex-tables-dirty t - reftex-label-alist-external-add-ons - (cons entry reftex-label-alist-external-add-ons)))))) + (unless (member entry reftex-label-alist-external-add-ons) + (setq reftex-tables-dirty t) + (push entry reftex-label-alist-external-add-ons))))) ;;; =========================================================================== ;;; @@ -1203,8 +1749,7 @@ ;; List of variables which handle the multifile stuff. ;; This list is used to tie, untie, and reset these symbols. (defconst reftex-multifile-symbols - '(reftex-label-numbers-symbol reftex-list-of-labels-symbol - reftex-bibfile-list-symbol)) + '(reftex-docstruct-symbol)) ;; Alist connecting master file names with the corresponding lisp symbols. (defvar reftex-master-index-list nil) @@ -1212,29 +1757,13 @@ ;; Last index used for a master file. (defvar reftex-multifile-index 0) -;; Alist connecting a master file with all included files. -(defvar reftex-master-include-list nil) - -;; Variable holding the symbol with current value of label postfix. -(defvar reftex-label-numbers-symbol nil ) -(make-variable-buffer-local 'reftex-label-numbers-symbol) - ;; Variable holding the symbol with the label list of the document. -;; Each element of the label list is again a list with the following elements: -;; 0: One character label type indicator. -;; 1: Short context to put into label menu. -;; 2: The label. -;; 3: The name of the file where the label is defined. -(defvar reftex-list-of-labels-symbol nil) -(make-variable-buffer-local 'reftex-list-of-labels-symbol) - -;; Variable holding the symbol with a list of library files for this document. -(defvar reftex-bibfile-list-symbol nil) -(make-variable-buffer-local 'reftex-bibfile-list-symbol) +(defvar reftex-docstruct-symbol nil) +(make-variable-buffer-local 'reftex-docstruct-symbol) (defun reftex-next-multifile-index () ;; Return the next free index for multifile symbols. - (setq reftex-multifile-index (1+ reftex-multifile-index))) + (incf reftex-multifile-index)) (defun reftex-tie-multifile-symbols () ;; Tie the buffer-local symbols to globals connected with the master file. @@ -1252,10 +1781,8 @@ (setq index (cdr index)) ;; Get a new index and add info to the alist. (setq index (reftex-next-multifile-index) - reftex-master-index-list (cons - (cons master index) - reftex-master-index-list) - newflag t)) + newflag t) + (push (cons master index) reftex-master-index-list)) ;; Get/create symbols and tie them. (while symlist @@ -1328,146 +1855,33 @@ (error "No such master file %s" master))) (expand-file-name master))) -(defun reftex-make-master-buffer (master-file mode) - "Make a master buffer which contains the MASTER-FILE and all includes. -This is to prepare a buffer containing the entire document in correct -sequence for parsing. Therefore it will even expand includes which are -commented out. -The function returns the number of input/include files not found." - - (interactive "fmaster file: ") - (let ((not-found 0) file file-list tmp (font-lock-maximum-size 1)) - (switch-to-buffer "*reftex-master.tex*") - (erase-buffer) - (if (not (eq major-mode mode)) - (funcall mode)) - ;; First insert the master file. - (if (not (file-exists-p master-file)) - (error "No such master file: %s" master-file)) - (reftex-insert-buffer-or-file master-file) - (subst-char-in-region (point-min) (point-max) ?\r ?\n t) - (setq file-list (cons master-file file-list)) - (goto-char 1) - ;; Remember from which file these lines came. - (put-text-property (point-min) (point-max) 'file - (expand-file-name master-file)) - ;; Make the default directory that of the master file. - ;; All input and include stuff works relative to that directory. - (cd (file-name-directory (expand-file-name master-file))) - ;; Now find recursively all include/input statements and expand them. - (while (re-search-forward - "^[ \t]*\\\\\\(include\\|input\\){\\([^}\n]+\\)}" nil t) - (setq file (reftex-no-props (match-string 2))) - (if (not (and (> (length file) 4) - (string= (substring file -4) ".tex"))) - (setq file (concat file ".tex"))) - (if (file-exists-p file) - (progn - (replace-match - (format "\n%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% START OF %s FILE: %s\n%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% END OF %s FILE: %s\n" - (match-string 1) file - (match-string 1) file)) - (beginning-of-line 0) - (narrow-to-region (point) (point)) - ;; Insert the file. - (reftex-insert-buffer-or-file file) - (subst-char-in-region (point-min) (point-max) ?\r ?\n t) - (setq file-list (cons (expand-file-name file) file-list)) - ;; Remember from which file these lines came. - (put-text-property (point-min) (point-max) - 'file (expand-file-name file)) - (goto-char (point-min)) - (widen)) - (message "Input/include file %s not found. Ignored. Continuing..." - file) - (setq not-found (1+ not-found)))) - (setq file-list (nreverse file-list)) - (while (setq tmp (assoc (car file-list) reftex-master-include-list)) - (setq reftex-master-include-list (delq tmp reftex-master-include-list))) - (setq reftex-master-include-list (cons file-list reftex-master-include-list)) - not-found)) - -(defun reftex-insert-buffer-or-file (file) - "If there is a buffer associated with FILE, insert it - otherwise the FILE." - (let ((buffer (reftex-get-buffer-visiting file))) - (if buffer - (let (beg end beg1 end1) - (save-excursion - ;; Make sure we get the whole buffer. - (set-buffer buffer) - (setq beg (point-min) end (point-max)) - (widen) - (setq beg1 (point-min) end1 (point-max))) - (insert-buffer-substring buffer beg1 end1) - (save-excursion - (set-buffer buffer) - (narrow-to-region beg end))) - (insert-file-contents file)))) - - -(defun reftex-parse-document (&optional buffer) - "Rescan the document." +(defun reftex-parse-one () + "Re-parse this file." + (interactive) + (let ((reftex-enable-partial-scans t)) + (reftex-access-scan-info '(4)))) + +(defun reftex-parse-all () + "Re-parse entire document." (interactive) - (save-window-excursion - (save-excursion - (if buffer - (if (not (bufferp buffer)) - (error "No such buffer %s" (buffer-name buffer)) - (set-buffer buffer))) - (reftex-access-scan-info t)))) - -(defun reftex-access-scan-info (&optional rescan) - ;; Access the scanning info. When the multifile symbols are not yet tied, - ;; tie them. When they are have to be created, do a buffer scan to - ;; fill them. - - ;; If RESCAN is non-nil, enforce document scanning - - (catch 'exit - (let ((rescan (or (equal rescan t) (equal rescan '(4))))) - - ;; Reset the mode if we had changes from style hooks. - (and reftex-tables-dirty - (reftex-reset-mode)) - - (if (eq reftex-list-of-labels-symbol nil) - ;; Symbols are not yet tied: Tie them and see if they are set. - (reftex-tie-multifile-symbols)) - - (if (and (symbol-value reftex-list-of-labels-symbol) - (not rescan)) - ;; Lists do already exist and we don't need to rescan. - ;; Return from here. - (throw 'exit t)) - - ;; We need to rescan - ;; ================= - - (unwind-protect - (save-window-excursion - (save-excursion - - ;; Do the scanning. - - (let ((label-list-symbol reftex-list-of-labels-symbol) - (label-numbers-symbol reftex-label-numbers-symbol) - (bibfile-list-symbol reftex-bibfile-list-symbol)) - - (message "Creating master buffer...") - (reftex-make-master-buffer (reftex-TeX-master-file) major-mode) - - (message "Scanning document...") - - (reftex-scan-buffer-for-labels - label-numbers-symbol label-list-symbol) - - (reftex-scan-buffer-for-bibliography-statement - bibfile-list-symbol) - - (message "Scanning document... done")))) - - (if (get-buffer "*reftex-master.tex*") - (kill-buffer "*reftex-master.tex*")))))) + (reftex-access-scan-info '(16))) + +(defun reftex-all-document-files (&optional relative) + ;; Return a list of all files belonging to the current document. + ;; When RELATIVE is non-nil, give file names relative to directory + ;; of master file. + (let* ((all (symbol-value reftex-docstruct-symbol)) + (master-dir (file-name-directory (reftex-TeX-master-file))) + (re (concat "\\`" (regexp-quote master-dir))) + file-list tmp file) + (while (setq tmp (assoc 'bof all)) + (setq file (nth 1 tmp) + all (cdr (memq tmp all))) + (and relative + (string-match re file) + (setq file (substring file (match-end 0)))) + (push file file-list)) + (nreverse file-list))) (defun reftex-create-tags-file () "Create TAGS file by running `etags' on the current document. @@ -1475,8 +1889,8 @@ (interactive) (reftex-access-scan-info current-prefix-arg) (let* ((master (reftex-TeX-master-file)) - (files (assoc master reftex-master-include-list)) - (cmd (format "etags %s" (mapconcat 'identity files " ")))) + (files (reftex-all-document-files)) + (cmd (format "etags %s" (mapconcat 'identity files " ")))) (save-excursion (set-buffer (reftex-get-buffer-visiting master)) (message "Running etags to create TAGS file...") @@ -1495,21 +1909,13 @@ (interactive (list (read-from-minibuffer "Run grep on document (like this): " - reftex-grep-command nil nil + reftex-grep-command nil nil 'reftex-grep-history))) (reftex-access-scan-info current-prefix-arg) - (let* ((master (reftex-TeX-master-file)) - (default-directory (file-name-directory master)) - (re (format "\\`%s\\(.*\\)" (regexp-quote - (expand-file-name default-directory)))) - (files (assoc master reftex-master-include-list)) - (cmd (format - "%s %s" grep-cmd - (mapconcat (function (lambda (x) - (if (string-match re x) - (match-string 1 x) - x))) - files " ")))) + (let* ((files (reftex-all-document-files t)) + (cmd (format + "%s %s" grep-cmd + (mapconcat 'identity files " ")))) (grep cmd))) (defun reftex-search-document (&optional regexp) @@ -1519,14 +1925,13 @@ This works also without an active TAGS table." (interactive) (let ((default (reftex-this-word))) - (if (not regexp) - (setq regexp (read-string (format "Search regexp in document [%s]: " - default)))) + (unless regexp + (setq regexp (read-string (format "Search regexp in document [%s]: " + default)))) (if (string= regexp "") (setq regexp (regexp-quote default))) (reftex-access-scan-info current-prefix-arg) - (tags-search regexp (list 'assoc (reftex-TeX-master-file) - 'reftex-master-include-list)))) + (tags-search regexp (list 'reftex-all-document-files)))) (defun reftex-query-replace-document (&optional from to delimited) "Run a query-replace-regexp of FROM with TO over the entire TeX document. @@ -1536,17 +1941,15 @@ This works also without an active TAGS table." (interactive) (let ((default (reftex-this-word))) - (if (not from) - (progn - (setq from (read-string (format "Replace regexp in document [%s]: " - default))) - (if (string= from "") (setq from (regexp-quote default))))) - (if (not to) - (setq to (read-string (format "Replace regexp %s with: " from)))) + (unless from + (setq from (read-string (format "Replace regexp in document [%s]: " + default))) + (if (string= from "") (setq from (regexp-quote default)))) + (unless to + (setq to (read-string (format "Replace regexp %s with: " from)))) (reftex-access-scan-info current-prefix-arg) (tags-query-replace from to (or delimited current-prefix-arg) - (list 'assoc (reftex-TeX-master-file) - 'reftex-master-include-list)))) + (list 'reftex-all-document-files)))) (defun reftex-change-label (&optional from to) "Query replace FROM with TO in all \\label and \\ref commands. @@ -1556,25 +1959,17 @@ This works also without an active TAGS table." (interactive) (let ((default (reftex-this-word "-a-zA-Z0-9_*.:"))) - (if (not from) - (setq from (read-string (format "Replace label globally [%s]: " - default)))) + (unless from + (setq from (read-string (format "Replace label globally [%s]: " + default)))) (if (string= from "") (setq from default)) - (if (not to) - (setq to (read-string (format "Replace label %s with: " - from)))) + (unless to + (setq to (read-string (format "Replace label %s with: " + from)))) (reftex-query-replace-document (concat "\\\\\\(label\\|[a-z]*ref\\){" (regexp-quote from) "}") (format "\\\\\\1{%s}" to)))) -(defun reftex-this-word (&optional class) -;; Grab the word around point. - (setq class (or class "-a-zA-Z0-9:_/.*;|")) - (save-excursion - (buffer-substring-no-properties - (progn (skip-chars-backward class) (point)) - (progn (skip-chars-forward class) (point))))) - ;;; =========================================================================== ;;; ;;; Functions to create and reference automatic labels. @@ -1614,7 +2009,7 @@ ;; The regular expression used to abbreviate words. (defconst reftex-abbrev-regexp (concat - "^\\(" + "\\`\\(" (make-string (nth 0 reftex-abbrev-parameters) ?.) "[" (nth 2 reftex-abbrev-parameters) "]*" "\\)" @@ -1625,25 +2020,398 @@ (defvar reftex-default-context-position nil) (defvar reftex-location-start nil) (defvar reftex-call-back-to-this-buffer nil) +(defvar reftex-active-toc nil) +(defvar reftex-tex-path nil) +(defvar reftex-bib-path nil) + +;; Internal list with index numbers of labels in the selection menu +(defvar reftex-label-index-list) ;; List of buffers created temporarily for lookup, which should be killed. (defvar reftex-buffers-to-kill nil) -;; The regexp used to find section statements. -(defconst reftex-section-regexp "^[ ]*\\\\\\(part\\|chapter\\|section\\|subsection\\|subsubsection\\|paragraph\\|subparagraph\\|subsubparagraph\\)\\*?\\(\\[[^]]*\\]\\)?{") - -;; LaTeX section commands and level numbers -(defconst reftex-section-levels - '( - ("part" . 0) - ("chapter" . 1) - ("section" . 2) - ("subsection" . 3) - ("subsubsection" . 4) - ("paragraph" . 5) - ("subparagraph" . 6) - ("subsubparagraph" . 7) - )) +;; Regexp to find section statements. Computed from reftex-section-levels. +(defvar reftex-section-regexp nil) +(defvar reftex-section-or-include-regexp nil) +(defvar reftex-everything-regexp nil) +(defvar reftex-find-label-regexp-format nil) +(defvar reftex-find-label-regexp-format2 nil) + +;; The parser functions ---------------------------------- + +(defvar reftex-memory nil + "Memorizes old variable values to indicate changes in these variables.") + +(defun reftex-access-scan-info (&optional rescan file) + ;; Access the scanning info. When the multifile symbols are not yet tied, + ;; tie them. When they are empty or RESCAN is non-nil, scan the document. + + ;; Reset the mode if we had changes to important variables. + (when (or reftex-tables-dirty + (not (eq reftex-label-alist (nth 0 reftex-memory))) + (not (eq reftex-label-alist-external-add-ons + (nth 1 reftex-memory))) + (not (eq reftex-default-label-alist-entries + (nth 2 reftex-memory)))) + (reftex-reset-mode)) + + (if (eq reftex-docstruct-symbol nil) + ;; Symbols are not yet tied: Tie them. + (reftex-tie-multifile-symbols)) + + (if (and (null (symbol-value reftex-docstruct-symbol)) + reftex-save-parse-info) + ;; Try to read the stuff from a file + (reftex-access-parse-file 'read)) + + (cond + ((not (symbol-value reftex-docstruct-symbol)) + (reftex-do-parse 1 file)) + ((member rescan '(t 1 (4) (16))) + (reftex-do-parse rescan file)))) + +(defun reftex-do-parse (rescan &optional file) + ;; Access the scanning info. When the multifile symbols are not yet tied, + ;; tie them. When they are have to be created, do a buffer scan to + ;; fill them. + + ;; If RESCAN is non-nil, enforce document scanning + + ;; Normalize the rescan argument + (setq rescan (cond ((eq rescan t) t) + ((eq rescan 1) 1) + ((equal rescan '(4)) t) + ((equal rescan '(16)) 1) + (t 1))) + + ;; Partial scans only when allowed + (unless reftex-enable-partial-scans + (setq rescan 1)) + + ;; Do the scanning. + + (let* ((old-list (symbol-value reftex-docstruct-symbol)) + (master (reftex-TeX-master-file)) + (master-dir (file-name-as-directory (file-name-directory master))) + (file (or file (buffer-file-name))) + from-file + docstruct tmp) + + ;; Make sure replacement is really an option here + (when (and (eq rescan t) + (not (and (member (list 'bof file) old-list) + (member (list 'eof file) old-list)))) + (message "Scanning whole document (no file section %s)" file) + (setq rescan 1)) + (when (string= file master) + (message "Scanning whole document (%s is master)" file) + (setq rescan 1)) + + ;; From which file do we start? + (setq from-file + (cond ((eq rescan t) (or file master)) + ((eq rescan 1) master) + (t (error "horrible!!")))) + + ;; Find active toc entry and initialize section-numbers + (setq reftex-active-toc + (reftex-last-assoc-before-elt + 'toc (list 'bof from-file) old-list)) + (reftex-init-section-numbers reftex-active-toc) + + (if (eq rescan 1) + (message "Scanning entire document...") + (message "Scanning document from %s..." from-file)) + + (save-window-excursion + (save-excursion + (unwind-protect + (setq docstruct + (reftex-parse-from-file + from-file docstruct master-dir)) + (reftex-kill-temporary-buffers)))) + + (message "Scanning document... done") + + ;; Turn the list around. + (setq docstruct (nreverse docstruct)) + + ;; Set or insert + (setq docstruct (reftex-replace-label-list-segment + old-list docstruct (eq rescan 1))) + + ;; Add all missing information + (unless (assq 'label-numbers docstruct) + (push (cons 'label-numbers nil) docstruct)) + (unless (assq 'master-dir docstruct) + (push (cons 'master-dir master-dir) docstruct)) + (let* ((bof1 (memq (assq 'bof docstruct) docstruct)) + (bof2 (assq 'bof (cdr bof1))) + (is-multi (not (not (and bof1 bof2)))) + (entry (or (assq 'is-multi docstruct) + (car (push (list 'is-multi is-multi) docstruct))))) + (setcdr entry (cons is-multi nil))) + (unless (assq 'xr docstruct) + (let* ((allxr (reftex-all-assq 'xr-doc docstruct)) + (alist (mapcar + '(lambda (x) + (if (setq tmp (reftex-find-tex-file (nth 2 x) + master-dir)) + (cons (nth 1 x) tmp) + (message "Can't find external document %s" + (nth 2 x)) + nil)) + allxr)) + (alist (delete nil alist)) + (allprefix (delete nil (mapcar 'car alist))) + (regexp (concat "\\`\\(" (mapconcat 'identity allprefix "\\|") + "\\)"))) + (push (list 'xr alist regexp) docstruct))) + + (set reftex-docstruct-symbol docstruct) + + ;; Save the parsing informtion into a file? + (if reftex-save-parse-info + (reftex-access-parse-file 'write)))) + +(defun reftex-is-multi () + ;; Tell if this is a multifile document. When not sure, say yes. + (let ((entry (assq 'is-multi (symbol-value reftex-docstruct-symbol)))) + (if entry + (nth 1 entry) + t))) + +(defun reftex-parse-from-file (file docstruct master-dir) + ;; Scan the buffer for labels and save them in a list. + (let ((regexp reftex-everything-regexp) + (bound 0) + file-found tmp + (level 1) + (highest-level 100) + toc-entry next-buf) + + (catch 'exit + (setq file-found (reftex-find-tex-file file master-dir)) + (unless file-found + (push (list 'file-error file) docstruct) + (throw 'exit nil)) + + (save-excursion + + (message "Scanning file %s" file) + (set-buffer + (setq next-buf + (reftex-get-file-buffer-force + file-found + (not (eq t reftex-keep-temporary-buffers))))) + + ;; Begin of file mark + (setq file (buffer-file-name)) + (push (list 'bof file) docstruct) + + (save-excursion + (save-restriction + (widen) + (goto-char 1) + + (while (re-search-forward regexp nil t) + + (cond + + ((match-end 1) + ;; It is a label + (push (reftex-label-info (reftex-match-string 1) file bound) + docstruct)) + + ((match-end 3) + ;; It is a section + (setq bound (point)) + + ;; Insert in List + (setq toc-entry (reftex-section-info file)) + (setq level (nth 5 toc-entry)) + (setq highest-level (min highest-level level)) + (if (= level highest-level) + (message + "Scanning %s %s ..." + (car (nth level reftex-section-levels)) + (nth 6 toc-entry))) + + (push toc-entry docstruct) + (setq reftex-active-toc toc-entry)) + + ((match-end 7) + ;; It's an include or input + (setq docstruct + (reftex-parse-from-file + (reftex-match-string 7) + docstruct master-dir))) + + ((match-end 8) + ;; A macro with label + (save-excursion + (let* ((mac (reftex-match-string 8)) + (label (progn (goto-char (match-end 8)) + (save-match-data + (reftex-no-props + (reftex-nth-arg-wrapper + mac))))) + (entry (progn (goto-char (match-end 0)) + (reftex-label-info + label file bound mac)))) + (push entry docstruct)))) + (t (error "This should not happen (reftex-parse-from-file)"))) + ) + + + ;; Find bibliography statement + (when (setq tmp (reftex-locate-bibliography-files master-dir)) + (push (cons 'bib tmp) docstruct)) + + ;; Find external document specifications + (goto-char 1) + (while (re-search-forward "[\n\r][ \t]*\\\\externaldocument\\(\\[\\([^]]*\\)\\]\\)?{\\([^}]+\\)}" nil t) + (push (list 'xr-doc (reftex-match-string 2) + (reftex-match-string 3)) + docstruct)) + + ;; End of file mark + (push (list 'eof file) docstruct)))) + + ;; Kill the scanned buffer + (reftex-kill-temporary-buffers next-buf)) + + ;; Return the list + docstruct)) + +(defun reftex-locate-bibliography-files (master-dir) + ;; Scan buffer for bibliography macro and return file list. + (let (file-list) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + "\\(\\`\\|[\n\r]\\)[ \t]*\\\\bibliography{[ \t]*\\([^}]+\\)" nil t) + (setq file-list + (mapcar '(lambda (x) (concat x ".bib")) + (reftex-delete-list + reftex-bibfile-ignore-list + (split-string + (reftex-match-string 2) + "[ \t\n\r]*,[ \t\n\r]*"))))) + (delete nil + (mapcar + (function + (lambda (file) (reftex-find-bib-file file master-dir))) + file-list))))) + +(defun reftex-last-assoc-before-elt (key elt list) + ;; Find the last association of KEY in LIST before or at ELT + ;; ELT is found in LIST with equal, not eq. + ;; Returns nil when either KEY or elt are not found in LIST. + ;; On success, returns the association. + (let* ((elt (car (member elt list))) ass last-ass) + + (while (and (setq ass (assoc key list)) + (setq list (memq ass list)) + (memq elt list)) + (setq last-ass ass + list (cdr list))) + last-ass)) + +(defun reftex-replace-label-list-segment (old insert &optional entirely) + ;; Replace the segment in OLD which corresponds to INSERT. + ;; Works with side effects, directly changes old. + ;; If entirely is t, just return INSERT. + ;; This function also makes sure the old toc markers do not point anywhere. + + (cond + (entirely + (reftex-silence-toc-markers old (length old)) + insert) + (t (let* ((new old) + (file (nth 1 (car insert))) + (eof-list (member (list 'eof file) old)) + (bof-list (member (list 'bof file) old)) + n) + (if (not (and bof-list eof-list)) + (error "Cannot splice") + ;; Splice + (reftex-silence-toc-markers bof-list (- (length bof-list) + (length eof-list))) + (setq n (- (length old) (length bof-list))) + (setcdr (nthcdr n new) (cdr insert)) + (setcdr (nthcdr (1- (length new)) new) (cdr eof-list))) + new)))) + +(defun reftex-silence-toc-markers (list n) + ;; Set all markers in list to nil + (while (and list (> (decf n) -1)) + (and (eq (car (car list)) 'toc) + (markerp (nth 4 (car list))) + (set-marker (nth 4 (car list)) nil)) + (pop list))) + +(defun reftex-access-parse-file (action) + (let* ((list (symbol-value reftex-docstruct-symbol)) + (master (reftex-TeX-master-file)) + (enable-local-variables nil) + (file (if (string-match "\\.[a-zA-Z]+\\'" master) + (concat (substring master 0 (match-beginning 0)) ".rel") + (concat master ".rel")))) + (cond + ((eq action 'readable) + (file-readable-p file)) + ((eq action 'restore) + (if (eq reftex-docstruct-symbol nil) + ;; Symbols are not yet tied: Tie them. + (reftex-tie-multifile-symbols)) + (if (file-exists-p file) + ;; load the file and return t for success + (progn (load-file file) t) + ;; return nil for failure + nil)) + ((eq action 'read) + (if (file-exists-p file) + ;; load the file and return t for success + (progn (load-file file) t) + ;; return nil for failure + nil)) + (t + (save-excursion + (if (file-writable-p file) + (progn + (message "Writing parse file %s" (abbreviate-file-name file)) + (find-file file) + (erase-buffer) + (insert (format ";; RefTeX parse info file\n")) + (insert (format ";; File: %s\n" master)) + (insert (format ";; Date: %s\n" + (format-time-string "%D %T" + (current-time)))) + (insert (format ";; User: %s (%s)\n\n" + (user-login-name) (user-full-name))) + (insert "(set reftex-docstruct-symbol '(\n\n") + (let ((standard-output (current-buffer))) + (mapcar + (function + (lambda (x) + (cond ((eq (car x) 'toc) + ;; A toc entry. Do not save the marker. + ;; Save the markers position at position 8 + (print (list 'toc "toc" (nth 2 x) (nth 3 x) + nil (nth 5 x) (nth 6 x) (nth 7 x) + (or (and (markerp (nth 4 x)) + (marker-position (nth 4 x))) + (nth 8 x))))) + (t (print x))))) + list)) + (insert "))") + (save-buffer 0) + (kill-buffer (current-buffer))) + (error "Cannot write to file %s" file))) + t)))) + +;; Creating labels -------------- (defun reftex-label (&optional environment no-insert) "Insert a unique label. Return the label. @@ -1662,22 +2430,34 @@ (if (or (not environment) (not (assoc environment reftex-env-or-mac-alist))) (setq environment (reftex-label-location))) - (if (not environment) - (error "Can't figure out what kind of label should be inserted")) + (unless environment + (error "Can't figure out what kind of label should be inserted")) ;; Ok, go ahead. - (let (label num typekey prefix entry cell lab valid default force-prompt) - (setq typekey (nth 1 (assoc environment - reftex-env-or-mac-alist))) + (let* ((entry (assoc environment reftex-env-or-mac-alist)) + (typekey (nth 1 entry)) + (format (nth 3 entry)) + label prefix valid default force-prompt) + (when (and (eq (string-to-char environment) ?\\) + (nth 4 entry) + (memq (preceding-char) '(?\[ ?\{))) + (setq format "%s")) + (setq prefix (or (cdr (assoc typekey reftex-typekey-to-prefix-alist)) (concat typekey "-"))) + ;; Replace any escapes in the prefix + (setq prefix (reftex-replace-prefix-escapes prefix)) ;; Make a default label. (cond ((reftex-typekey-check typekey (nth 0 reftex-insert-label-flags)) ;; Derive a label from context. - (setq default (nth 2 (reftex-label-info " "))) + (setq reftex-active-toc (reftex-last-assoc-before-elt + 'toc (car (reftex-where-am-I)) + (symbol-value reftex-docstruct-symbol))) + (setq default (reftex-no-props + (nth 2 (reftex-label-info " " nil nil t)))) ;; Catch the cases where the is actually no context available. (if (or (string-match "NO MATCH FOR CONTEXT REGEXP" default) (string-match "ILLEGAL VALUE OF PARSE" default) @@ -1689,11 +2469,7 @@ (setq default (concat prefix (reftex-string-to-label default))) ;; Make it unique. - (setq label default) - (setq num 1) - (while (assoc label (symbol-value reftex-list-of-labels-symbol)) - (setq label (concat default "-" (setq num (1+ num))))) - (setq default label))) + (setq default (reftex-uniquify-label default nil "-")))) ((reftex-typekey-check typekey (nth 1 reftex-insert-label-flags)) ; prompt ;; Minimal default: the user will be prompted. @@ -1701,9 +2477,7 @@ (t ;; Make an automatic label. - (while (assoc - (setq default (concat prefix (reftex-next-label-number typekey))) - (symbol-value reftex-list-of-labels-symbol))))) + (setq default (reftex-uniquify-label prefix t)))) ;; Should we ask the user? (if (or (reftex-typekey-check typekey @@ -1713,7 +2487,9 @@ (while (not valid) ;; iterate until we get a legal label - (setq label (read-string "Label: " default)) + (setq label (read-string + (if (string= format "%s") "Naked Label: " "Label: ") + default)) ;; Lets make sure that this is a legal label (cond @@ -1726,7 +2502,7 @@ ;; Look it up in the label list ((setq entry (assoc label - (symbol-value reftex-list-of-labels-symbol))) + (symbol-value reftex-docstruct-symbol))) (message "Label \"%s\" exists in file %s" label (nth 3 entry)) (ding) (sit-for 2)) @@ -1736,49 +2512,24 @@ (setq valid t)))) (setq label default)) - ;; Insert the label - (if (not no-insert) - (insert "\\label{" label "}")) - ;; Insert the label into the label list - (if (symbol-value reftex-list-of-labels-symbol) - (let ((cnt 0) - (pos (point)) - (all (symbol-value reftex-list-of-labels-symbol)) - (look-for nil) - (note nil) - (text nil) - (file (buffer-file-name))) - - ;; find the previous label in order to know where to insert new label - ;; into label list - (save-excursion - (if (re-search-backward "\\\\label{\\([^}]+\\)}" nil 1 2) - (setq look-for (reftex-no-props (match-string 1)))) - (if (or (re-search-forward - "\\\\\\(include\\|input\\){[^}\n]+}" pos t) - (re-search-forward reftex-section-regexp pos t) - (null look-for)) - (setq note "POSITION UNCERTAIN. RESCAN TO FIX."))) - (if (not look-for) - (set reftex-list-of-labels-symbol - (cons (list label typekey text file note) - (symbol-value reftex-list-of-labels-symbol))) - (while all - (setq cell (car all) - all (cdr all) - cnt (1+ cnt) - lab (nth 0 cell)) - (if (string= lab look-for) - (progn - (setcdr - (nthcdr (1- cnt) - (symbol-value reftex-list-of-labels-symbol)) - (cons (list label typekey text file note) - (nthcdr - cnt (symbol-value reftex-list-of-labels-symbol)))) - ;; to end the loop, set all to nil - (setq all nil))))))) + (let* ((here-I-am-info (reftex-where-am-I)) + (here-I-am (car here-I-am-info)) + (note (if (cdr here-I-am-info) + "" + "POSITION UNCERTAIN. RESCAN TO FIX.")) + (file (buffer-file-name)) + (text nil) + (tail (memq here-I-am (symbol-value reftex-docstruct-symbol)))) + + (if tail + (setcdr tail (cons (list label typekey text file note) + (cdr tail))))) + + ;; Insert the label into the buffer + (unless no-insert + (insert (format format label))) + ;; return value of the function is the label label)) @@ -1788,24 +2539,21 @@ ;; Uses reftex-derive-label-parameters and reftex-abbrev-parameters ;; - (let* ((words0 (reftex-split "[- \t\n\r]+" - (reftex-no-props string))) + (let* ((words0 (split-string string "[- \t\n\r]+")) (ignore-words (nth 5 reftex-derive-label-parameters)) words word) ;; remove words from the ignore list or with funny characters - (while words0 - (setq word (car words0) words0 (cdr words0)) + (while (setq word (pop words0)) (cond ((member (downcase word) ignore-words)) ((string-match reftex-label-illegal-re word) - (if (nth 2 reftex-derive-label-parameters) - (progn - (while (string-match reftex-label-illegal-re word) - (setq word (replace-match "" nil nil word))) - (setq words (cons word words))))) + (when (nth 2 reftex-derive-label-parameters) + (while (string-match reftex-label-illegal-re word) + (setq word (replace-match "" nil nil word))) + (push word words))) (t - (setq words (cons word words))))) + (push word words)))) (setq words (nreverse words)) ;; restrict number of words @@ -1836,10 +2584,35 @@ string)) ;; Delete the final punctuation, if any - (if (string-match "[^a-zA-Z0-9]+$" string) + (if (string-match "[^a-zA-Z0-9]+\\'" string) (setq string (replace-match "" nil nil string))) string)) +(defun reftex-replace-prefix-escapes (prefix) + ;; Replace %escapes in a label prefix + (save-match-data + (let (letter (num 0) replace) + (while (string-match "\\%\\([a-zA-Z]\\)" prefix num) + (setq letter (match-string 1 prefix)) + (setq replace + (cond + ((equal letter "f") + (file-name-sans-extension + (file-name-nondirectory (buffer-file-name)))) + ((equal letter "F") + (let ((masterdir (file-name-directory (reftex-TeX-master-file))) + (file (file-name-sans-extension (buffer-file-name)))) + (if (string-match (concat "\\`" (regexp-quote masterdir)) + file) + (substring file (length masterdir)) + file))) + ((equal letter "u") + (or (user-login-name) "")) + (t ""))) + (setq num (1- (+ (match-beginning 1) (length replace))) + prefix (replace-match replace nil nil prefix))) + prefix))) + (defun reftex-label-location (&optional bound) ;; Return the environment or macro which determines the label type at point. ;; If optional BOUND is an integer, limit backward searches to that point. @@ -1850,46 +2623,59 @@ (p2 (or (cdr loc2) 0))) (setq reftex-location-start (max p1 p2)) - (if (> p1 p2) + (if (>= p1 p2) (progn - (setq reftex-default-context-position p1) - (car loc1)) - (setq reftex-default-context-position - (+ p2 8 (length (car loc2)))) + (setq reftex-default-context-position (+ p1 (length (car loc1)))) + (or (car loc1) "section")) + (setq reftex-default-context-position (+ p2 8 (length (car loc2)))) (or (car loc2) "section")))) - -(defun reftex-next-label-number (type) - ;; Increment value of automatic labels in current buffer. Return new value. +(defun reftex-uniquify-label (label &optional force separator) + ;; Make label unique by appending a number. + ;; Optional FORCE means, force appending a number, even if label is unique. + ;; Optional SEPARATOR is a string to stick between label and number. ;; Ensure access to scanning info (reftex-access-scan-info) - (let ((n (cdr (assoc type (symbol-value reftex-label-numbers-symbol))))) - (if (not (integerp n)) - ;; oops - type not known - make one here - (progn - (set reftex-label-numbers-symbol - (cons (cons type 0) - (symbol-value reftex-label-numbers-symbol))) - (setq n 0))) - (setq n (1+ n)) - (setcdr (assoc type (symbol-value reftex-label-numbers-symbol)) n) - n)) + (cond + ((and (not force) + (not (assoc label (symbol-value reftex-docstruct-symbol)))) + label) + (t + (let* ((label-numbers (assq 'label-numbers + (symbol-value reftex-docstruct-symbol))) + (label-numbers-alist (cdr label-numbers)) + (cell (or (assoc label label-numbers-alist) + (car (setcdr label-numbers + (cons (cons label 0) + label-numbers-alist))))) + (num (1+ (cdr cell))) + (sep (or separator ""))) + (while (assoc (concat label sep (int-to-string num)) + (symbol-value reftex-docstruct-symbol)) + (incf num)) + (setcdr cell num) + (concat label sep (int-to-string num)))))) ;; Help string for the reference label menu -(defconst reftex-reference-label-help +(defconst reftex-select-label-prompt + "Select: [n]ext [p]revious [r]escan [ ]context e[x]tern [q]uit RET [?]HELP+more") + +(defconst reftex-select-label-help " AVAILABLE KEYS IN REFERENCE LABEL MENU - ====================================== - n / p Go to next/previous label (Cursor motion works as well) - r / s Rescan document for labels / Switch label type - t / # Toggle table of contents / Toggle counter mode - c Toggle display of short context - SPACE Show full context for current label in other window - f Toggle follow mode: other window will follow context - a / q Use last referenced label / Quit without accepting label - ? / C-r Display this help message / Recursive Edit into other window - RETURN Accept current label") + -------------------------------------- + n / p Go to next/previous label (Cursor motion works as well) + C-s / C-r Search forward/backward. Use repeated C-s/C-r as in isearch. + r / s Reparse document / Switch label type + x Switch to label menu of external document (with LaTeX package `xr') + t i c # % Toggle: [i]ncl. file borders, [t]able of contents, [c]ontext + [#] label counters, [%] labels in comments + SPC Show full context for current label in other window + f Toggle follow mode: other window will follow context + l / q Reuse last referenced label / Quit without accepting label + e Recursive Edit into other window + RET Accept current label") (defun reftex-reference (&optional type no-insert) "Make a LaTeX reference. Look only for labels of a certain TYPE. @@ -1909,14 +2695,13 @@ ;; Ensure access to scanning info and rescan buffer if prefix are is '(4) (reftex-access-scan-info current-prefix-arg) - (if (not type) - ;; guess type from context - (if (and reftex-guess-label-type - (not (= 16 (prefix-numeric-value current-prefix-arg))) - (setq type (assoc (downcase (reftex-word-before-point)) - reftex-words-to-typekey-alist))) - (setq type (cdr type)) - (setq type (reftex-query-label-type)))) + (unless type + ;; guess type from context + (if (and reftex-guess-label-type + (setq type (assoc (downcase (reftex-word-before-point)) + reftex-words-to-typekey-alist))) + (setq type (cdr type)) + (setq type (reftex-query-label-type)))) (let (label pair (form (or (cdr (assoc type reftex-typekey-to-format-alist)) @@ -1941,320 +2726,343 @@ ;; return the label label)) -(defun reftex-goto-label (&optional arg) - "Go to a LaTeX label. With prefix ARG, go to label in another window." - (interactive "P") - (let (type label file pair) - (if (not type) - (setq type (reftex-query-label-type))) - - (setq pair (reftex-offer-label-menu type) - label (car pair) - file (cdr pair)) - (if (and label file (file-exists-p file)) - (progn - (if arg - (find-file-other-window file) - (find-file file)) - (goto-char (point-min)) - (if (not (search-forward (concat "\\label{" label "}") nil t)) - (error "No such label found: %s" label) - (reftex-highlight 0 (match-beginning 0) (match-end 0)) - (add-hook 'pre-command-hook 'reftex-highlight-shall-die))) - (message "Quit") - nil))) - -;; Internal list with index numbers of labels in the selection menu -(defvar reftex-label-index-list nil) - (defun reftex-offer-label-menu (typekey) ;; Offer a menu with the appropriate labels. Return (label . file). (let* ((buf (current-buffer)) - (near-label (reftex-find-nearby-label)) + (xr-data (assq 'xr (symbol-value reftex-docstruct-symbol))) + (xr-alist (cons (cons "" (buffer-file-name)) (nth 1 xr-data))) + (xr-index 0) + (here-I-am (car (reftex-where-am-I))) (toc (reftex-typekey-check typekey reftex-label-menu-flags 0)) + (files (reftex-typekey-check typekey reftex-label-menu-flags 7)) (context (not (reftex-typekey-check typekey reftex-label-menu-flags 3))) (counter (reftex-typekey-check typekey reftex-label-menu-flags 2)) (follow (reftex-typekey-check typekey reftex-label-menu-flags 4)) - offset rtn key cnt entry) - - (setq reftex-call-back-to-this-buffer buf) + (commented (nth 5 reftex-label-menu-flags)) + (match-everywhere (reftex-typekey-check + typekey reftex-label-menu-flags 6)) + (prefix "") + offset rtn key cnt last-cnt entry) + (setq entry (cons nil nil)) + ;; The following unwind-protect kills temporary buffers after use (unwind-protect (catch 'exit (while t (save-window-excursion + (setq reftex-call-back-to-this-buffer buf) (switch-to-buffer-other-window "*RefTeX Select*") (erase-buffer) (setq truncate-lines t) - (setq reftex-label-index-list (reftex-make-and-insert-label-list - typekey buf toc context counter - near-label)) - (setq near-label "_ ") ; turn off search for near label + (setq mode-line-format + (list "---- " 'mode-line-buffer-identification + " " (abbreviate-file-name + (buffer-file-name buf)) + " -%-")) + + (setq reftex-label-index-list + (reftex-make-and-insert-label-list + typekey buf toc files context counter commented + here-I-am prefix)) + (setq here-I-am nil) ; turn off determination of offset + ;; use only when searched (setq offset (or (car reftex-label-index-list) offset)) - ;; use only when searched - (setq reftex-label-index-list (cdr reftex-label-index-list)) ;; only this is the true list - (if (not reftex-label-index-list) - (error "No labels of type \"%s\"" typekey)) + (pop reftex-label-index-list) (setq rtn (reftex-select-item - nil - "Label: [n]ext [p]rev [r]escan [t]oc [ ]context [q]uit RETURN [?]HELP+more" + reftex-select-label-prompt "^>" - "\n[^.]" 2 - reftex-reference-label-help - '(?r ?g ?c ?t ?s ?# ?a) + reftex-select-label-help + '(?r ?R ?g ?c ?t ?s ?# ?i ?l ?% ?x) offset - 'reftex-select-label-callback follow)) - (setq key (car rtn) - cnt (cdr rtn) - offset (1+ cnt)) - (if (not key) (throw 'exit nil)) + 'reftex-select-label-callback follow + match-everywhere)) + (setq key (car rtn) + cnt (nth 1 rtn) + last-cnt (nth 2 rtn) + offset (1+ (or cnt last-cnt 0))) + (unless key (throw 'exit nil)) (cond - ((or (equal key ?r) - (equal key ?g)) + ((or (eq key ?r) + (eq key ?R) + (eq key ?g)) ;; rescan buffer - (reftex-parse-document buf)) - ((equal key ?c) + (reftex-parse-document buf (or cnt last-cnt) key)) + ((eq key ?c) ;; toggle context mode (setq context (not context))) - ((equal key ?s) + ((eq key ?s) ;; switch type (setq typekey (reftex-query-label-type))) - ((equal key ?t) + ((eq key ?t) ;; toggle tabel of contents display (setq toc (not toc))) - ((equal key ?#) + ((eq key ?i) + ;; toggle display of included file borders + (setq files (not files))) + ((eq key ?#) ;; toggle counter display (setq counter (not counter))) - ((equal key ?a) + ((eq key ?%) + ;; toggle display of commented labels + (setq commented (not commented))) + ((eq key ?l) ;; reuse the last referenced label again (setq entry reftex-last-used-reference) (throw 'exit t)) + ((eq key ?x) + ;; select an external document + (setq xr-index (reftex-select-external-document + xr-alist xr-index)) + (setq buf (or (reftex-get-file-buffer-force + (cdr (nth xr-index xr-alist))) + (error "Cannot switch document")) + prefix (or (car (nth xr-index xr-alist)) "") + offset nil)) (t (set-buffer buf) - (setq entry (nth (nth cnt reftex-label-index-list) - (symbol-value reftex-list-of-labels-symbol))) - (setq reftex-last-used-reference entry) + (if cnt + (progn + (setq entry (nth (nth cnt reftex-label-index-list) + (symbol-value reftex-docstruct-symbol))) + (setq reftex-last-used-reference entry)) + (setq entry nil)) (throw 'exit t)))))) (kill-buffer "*RefTeX Select*") + (and (get-buffer "*RefTeX Context Copy*") + (kill-buffer "*RefTeX Context Copy*")) (reftex-kill-temporary-buffers)) - (cons (reftex-no-props (nth 0 entry)) (nth 3 entry)))) - -;; Indentation for table of context lines in the menu -(defconst reftex-toc-indent " ") -;; Indentation for the lines containing the label -(defconst reftex-label-indent "> ") -;; Indentation for context lines -(defconst reftex-context-indent ". ") -;; Indentation per section level -(defvar reftex-level-indent 2 - "*Number of spaces to be used for indentation per section level. -With more indentation, the label menu looks nicer, but shows less context. -Changing this is only fully operational after the next buffer scan.") - -(defun reftex-make-and-insert-label-list (typekey0 buf toc context - counter near-label) + (cons (if (nth 0 entry) (concat prefix (nth 0 entry)) nil) + (nth 3 entry)))) + +(defun reftex-select-external-document (xr-alist xr-index) + ;; Return index of an external document. + (cond + ((= (length xr-alist) 1) + (message "No external douments available") + (ding) 0) + ((= (length xr-alist) 2) + (- 1 xr-index)) + (t + (save-window-excursion + (let* ((fmt " [%c] %-5s %s\n") (n (1- ?0)) key) + (with-output-to-temp-buffer "*RefTeX Select*" + (princ + (concat "Select a document by pressing a number key:\n KEY PREFIX DOCUMENT\n----------------------\n" + (mapconcat '(lambda (x) + (format fmt (incf n) (or (car x) "") + (abbreviate-file-name (cdr x)))) + xr-alist "")))) + (setq key (read-char)) + (if (< (- key ?1) (length xr-alist)) + (- key ?0) + (error "Illegal document selection [%c]" key))))))) + +(defun reftex-make-and-insert-label-list + (typekey0 buf toc files context counter show-commented here-I-am xr-prefix) ;; Insert a menu of all labels in buffer BUF into current buffer. - ;; Return the list of labels, with the index of NEAR-LABEL as extra car. - (let (ins-list index-list offset) + ;; Return the list of labels, with the index of HERE-I-AM as extra car. + (let* ((font (reftex-use-fonts)) + (refont (reftex-refontify)) + (cnt 0) + (index -1) + (toc-indent " ") + (label-indent + (concat "> " + (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) + (context-indent + (concat ". " + (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) + all cell text label typekey note comment master-dir-re + index-list offset docstruct-symbol from from1 to) + + ;; Pop to buffer buf to get the correct buffer-local variables (save-excursion (set-buffer buf) - (let* ((all nil) - (font (reftex-use-fonts)) - (cnt 0) - (file nil) - (index -1) - (toc-indent reftex-toc-indent) - (label-indent - (concat reftex-label-indent - (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) - (context-indent - (concat reftex-context-indent - (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) - cell text label typekey note comment) - - ; Ensure access to scanning info - (reftex-access-scan-info) - - (setq all (symbol-value reftex-list-of-labels-symbol)) - - (while all - - (setq index (1+ index) - cell (car all) - all (cdr all)) - - (if (null (nth 2 cell)) - ;; No context yet. Quick update - (progn - (setq cell (reftex-label-info-update cell)) - (setcar (nthcdr index - (symbol-value reftex-list-of-labels-symbol)) - cell))) - - ;; in the following setq we *copy* the label, since we will change - ;; its properties, and we cannot have any properties in the list - ;; (because of assoc searches) - (setq label (copy-sequence (nth 0 cell)) - typekey (nth 1 cell) - text (nth 2 cell) - file (nth 3 cell) - note (nth 4 cell) - comment (get-text-property 0 'in-comment text)) - - (if (string= label near-label) - (setq offset (1+ cnt))) - - (cond - ((and toc (string= typekey "toc")) - (setq ins-list - (cons (concat toc-indent text "\n") - ins-list))) - ((string= typekey "toc")) - ((and (or (string= typekey typekey0) (string= typekey0 " ")) - (or (nth 5 reftex-label-menu-flags) ; show-commented? - (null comment))) - (setq cnt (1+ cnt)) - (if comment (setq label (concat "% " label))) - (if font - (put-text-property - 0 (length label) - 'face - (if comment - 'font-lock-comment-face - 'font-lock-reference-face) - label)) - (setq index-list (cons index index-list)) - (setq ins-list - (cons (concat - label-indent - label - (if counter (format " (%d) " cnt)) - (if comment " LABEL IS COMMENTED OUT ") - (if note (concat " " note) "") - "\n" - (if context (concat context-indent text "\n"))) - ins-list)))) - ))) - - (apply 'insert (nreverse ins-list)) + + ;; Ensure access to scanning info + (reftex-access-scan-info) + + (setq docstruct-symbol reftex-docstruct-symbol + all (symbol-value reftex-docstruct-symbol) + reftex-active-toc nil + master-dir-re + (concat "\\`" (regexp-quote + (file-name-directory (reftex-TeX-master-file)))))) + + (when refont + ;; Calculate font-lock-defaults as in LaTeX mode. + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults nil) + (let ((major-mode 'latex-mode)) + (font-lock-set-defaults)) + ;; The following is only needed for XEmacs, but does not hurt Emacs. + (setq font-lock-mode nil)) + + ;; Walk the docstruct and insert the appropriate stuff + + (while (setq cell (pop all)) + + (incf index) + (setq from (point)) + + (if (eq cell here-I-am) (setq offset (1+ cnt))) + + (cond + + ((memq (car cell) '(bib label-numbers master-dir is-multi + xr xr-doc))) + ;; These are currently ignored + + ((memq (car cell) '(bof eof file-error)) + ;; Beginning or end of a file + (when files + (insert + " " (if (string-match master-dir-re (nth 1 cell)) + (substring (nth 1 cell) (match-end 0)) + (nth 1 cell)) + (cond ((eq (car cell) 'bof) " starts here\n") + ((eq (car cell) 'eof) " ends here\n") + ((eq (car cell) 'file-error) " was not found\n"))) + (when font + (put-text-property from (point) + 'face 'font-lock-function-name-face)))) + + ((eq (car cell) 'toc) + ;; a table of contents entry + (when toc + (setq reftex-active-toc cell) + (insert (concat toc-indent (nth 2 cell) "\n")))) + + ((stringp (car cell)) + ;; a label + (when (null (nth 2 cell)) + ;; No context yet. Quick update. + (setq cell (reftex-label-info-update cell)) + (setcar (nthcdr index (symbol-value docstruct-symbol)) + cell)) + + (setq label (car cell) + typekey (nth 1 cell) + text (nth 2 cell) + note (nth 4 cell) + comment (get-text-property 0 'in-comment text)) + + (when (and (or (string= typekey typekey0) (string= typekey0 " ")) + (or show-commented (null comment))) + + ;; Yes we want this one + (incf cnt) + (push index index-list) + + (setq label (concat xr-prefix label)) + (when comment (setq label (concat "% " label))) + (insert label-indent label) + (when font + (put-text-property + (- (point) (length label)) (point) + 'face (if comment + 'font-lock-comment-face + 'font-lock-reference-face))) + + (insert (if counter (format " (%d) " cnt) "") + (if comment " LABEL IS COMMENTED OUT " "") + (if note (concat " " note) "") + "\n") + (setq to (point)) + + (when context + (setq from1 to) + (insert context-indent text "\n") + (setq to (point)) + (when refont + (font-lock-fontify-region from1 to) + (goto-char to))) + (put-text-property from to 'cnt (1- cnt)) + (goto-char to))))) + + ;; Return the index list (cons offset (nreverse index-list)))) +(defun reftex-parse-document (&optional buffer cnt key) + "Rescan the document." + (interactive) + (save-window-excursion + (save-excursion + (if buffer + (if (not (bufferp buffer)) + (error "No such buffer %s" (buffer-name buffer)) + (set-buffer buffer))) + (let ((arg (if (eq key ?R) '(16) '(4))) + (file (if cnt + (nth 3 + (nth (nth cnt reftex-label-index-list) + (symbol-value reftex-docstruct-symbol)))))) + (reftex-access-scan-info arg file))))) + (defun reftex-query-label-type () ;; Ask for label type (message reftex-type-query-prompt) (let ((key (read-char))) - (if (equal key ?\?) - (progn - (save-window-excursion - (with-output-to-temp-buffer "*RefTeX Help*" - (princ reftex-type-query-help)) - (setq key (read-char)) - (kill-buffer "*RefTeX Help*")))) - (if (not (member (char-to-string key) reftex-typekey-list)) - (error "No such label type: %s" (char-to-string key))) + (when (eq key ?\?) + (save-window-excursion + (with-output-to-temp-buffer "*RefTeX Help*" + (princ reftex-type-query-help)) + (setq key (read-char)) + (kill-buffer "*RefTeX Help*"))) + (unless (member (char-to-string key) reftex-typekey-list) + (error "No such label type: %s" (char-to-string key))) (char-to-string key))) -(defun reftex-find-nearby-label () - ;; Find a nearby label. - (save-excursion - (if (or (re-search-backward "\\\\label{\\([^}]+\\)}" nil t) - (re-search-forward "\\\\label{\\([^}]+\\)}" nil t)) - (reftex-no-props (match-string 1)) - nil))) - ;; Variable holding the vector with section numbers (defvar reftex-section-numbers [0 0 0 0 0 0 0 0]) -(defun reftex-scan-buffer-for-labels (label-numbers-symbol label-list-symbol) - ;; Scan the buffer for labels and save them in a list. - (save-excursion - (let ((regexp (concat "\\\\label{\\([^}]*\\)}" "\\|" - reftex-section-regexp)) - (font (reftex-use-fonts)) - (bound 0) - (highest-level 100) - file (level 1) star text text1 label section-number macro find) - (set label-list-symbol nil) - (goto-char 0) - - ;; reset label numbers - (set label-numbers-symbol - (mapcar '(lambda(x) (cons x 0)) reftex-typekey-list)) - - ;; reset section numbers - (reftex-section-number reftex-section-numbers -1) - - (while (re-search-forward regexp nil t) - (setq file (get-text-property (match-beginning 0) 'file)) - (if (string= (buffer-substring (match-beginning 0) - (+ 7 (match-beginning 0))) "\\label{") - ;; It is a label - (progn - (setq label (reftex-no-props (match-string 1))) - (set label-list-symbol - (cons (reftex-label-info label file bound) - (symbol-value label-list-symbol)))) - - ;; It is a section - (setq bound (point)) - (setq star (= ?* (char-after (match-end 2)))) - (setq find (buffer-substring-no-properties - (1- (match-beginning 2)) (match-end 0))) - (setq macro (reftex-no-props (match-string 2))) - (setq level (cdr (assoc macro reftex-section-levels))) - - (setq section-number (reftex-section-number - reftex-section-numbers level star)) - (setq highest-level (min highest-level level)) - (if (= level highest-level) - (message - "Scanning %s %s ..." - (car (nth level reftex-section-levels)) - section-number)) - - ;; get the title - (save-match-data - (setq text1 (reftex-context-substring)) - (setq text (reftex-nicify-text text1))) - - (setq find (reftex-allow-for-ctrl-m (concat find text1))) - - ;; add section number and indentation - (setq text - (concat - (make-string (* reftex-level-indent level) ?\ ) - (if (nth 1 reftex-label-menu-flags) ; section number flag - (concat section-number " ")) - text)) - ;; fontify - (if font (put-text-property 0 (length text) - 'face 'font-lock-comment-face text)) - - ;; insert in list - (set label-list-symbol - (cons (list nil "toc" text file find) - (symbol-value label-list-symbol))))) - (set label-list-symbol - (nreverse (symbol-value label-list-symbol)))))) - +(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! + (let* ((marker (set-marker (make-marker) (1- (match-beginning 3)))) + (macro (reftex-match-string 3)) + (star (= ?* (char-after (match-end 3)))) + (level (cdr (assoc macro reftex-section-levels))) + (section-number (reftex-section-number + reftex-section-numbers level star)) + (text1 (save-match-data (save-excursion (reftex-context-substring)))) + (literal (buffer-substring-no-properties + (1- (match-beginning 3)) + (min (point-max) (+ (match-end 0) (length text1) 1)))) + ;; Literal can be too short since text1 too short. No big problem. + (text (reftex-nicify-text text1))) + + ;; Add section number and indentation + (setq text + (concat + (make-string (* reftex-level-indent level) ?\ ) + (if (nth 1 reftex-label-menu-flags) ; section number flag + (concat section-number " ")) + text)) + ;; Fontify + (if (reftex-use-fonts) + (put-text-property 0 (length text) + 'face 'font-lock-comment-face text)) + (list 'toc "toc" text file marker level section-number + literal (marker-position marker)))) (defun reftex-label-info-update (cell) ;; Update information about just one label in a different file. ;; CELL contains the old info list (let* ((label (nth 0 cell)) (typekey (nth 1 cell)) - (text (nth 2 cell)) + ;; (text (nth 2 cell)) (file (nth 3 cell)) (note (nth 4 cell)) (buf (reftex-get-file-buffer-force - file (not reftex-keep-temporary-buffers)))) + file (not (eq t reftex-keep-temporary-buffers))))) (if (not buf) (list label typekey "" file "LOST LABEL. RESCAN TO FIX.") (save-excursion @@ -2263,21 +3071,29 @@ (widen) (goto-char 1) - (if (re-search-forward (concat "\\\\label{" (regexp-quote label) "}") - nil t) - (append (reftex-label-info label file) (list note)) + (if (or (re-search-forward + (format reftex-find-label-regexp-format + (regexp-quote label)) nil t) + (re-search-forward + (format reftex-find-label-regexp-format2 + (regexp-quote label)) nil t)) + + (progn + (backward-char 1) + (append (reftex-label-info label file) (list note))) (list label typekey "" file "LOST LABEL. RESCAN TO FIX."))))))) -(defun reftex-label-info (label &optional file bound) +(defun reftex-label-info (label &optional file bound derive env-or-mac) ;; Return info list on LABEL at point. - (let* ((env-or-mac (reftex-label-location bound)) + (let* ((env-or-mac (or env-or-mac (reftex-label-location bound))) (typekey (nth 1 (assoc env-or-mac reftex-env-or-mac-alist))) (file (or file (buffer-file-name))) (parse (if (reftex-typekey-check typekey reftex-use-text-after-label-as-context) nil (nth 2 (assoc env-or-mac reftex-env-or-mac-alist)))) - (text (reftex-short-context env-or-mac parse reftex-location-start))) + (text (reftex-short-context env-or-mac parse reftex-location-start + derive))) (if (reftex-in-comment) (put-text-property 0 1 'in-comment t text)) (list label typekey text file))) @@ -2285,11 +3101,14 @@ (defun reftex-in-comment () (save-excursion (skip-chars-backward "^%\n\r") - (= (preceding-char) ?%))) - -(defun reftex-short-context (env parse &optional bound) + (eq (preceding-char) ?%))) + +(defun reftex-short-context (env parse &optional bound derive) ;; Get about one line of useful context for the label definition at point. + (if (consp parse) + (setq parse (if derive (cdr parse) (car parse)))) + (reftex-nicify-text (cond @@ -2302,13 +3121,21 @@ (if (string= env "section") ;; special treatment for section labels (save-excursion - (if (re-search-backward reftex-section-regexp (point-min) t) + (if (and (re-search-backward reftex-section-or-include-regexp + (point-min) t) + (match-end 2)) (progn (goto-char (match-end 0)) (reftex-context-substring)) - "SECTION HEADING NOT FOUND")) + (if reftex-active-toc + (progn + (string-match "{\\([^}]*\\)" (nth 7 reftex-active-toc)) + (match-string 1 (nth 7 reftex-active-toc))) + "SECTION HEADING NOT FOUND"))) (save-excursion - (goto-char reftex-default-context-position) + (goto-char reftex-default-context-position) + (unless (eq (string-to-char env) ?\\) + (reftex-move-over-touching-args)) (reftex-context-substring)))) ((stringp parse) @@ -2318,60 +3145,249 @@ (goto-char (match-end 0)) (reftex-context-substring)) "NO MATCH FOR CONTEXT REGEXP"))) + + ((integerp parse) + (or (save-excursion + (goto-char reftex-default-context-position) + (reftex-nth-arg + parse + (nth 6 (assoc env reftex-env-or-mac-alist)))) + "")) + ((fboundp parse) ;; A hook function. Call it. (save-excursion (condition-case error-var (funcall parse env) - ('error (format "HOOK ERROR: %s" (cdr error-var)))))) + (error (format "HOOK ERROR: %s" (cdr error-var)))))) (t "ILLEGAL VALUE OF PARSE")))) +(defun reftex-where-am-I () + ;; Return the docstruct entry above point. Actually returns a cons + ;; cell in which the cdr is a flag indicating if the information is + ;; exact (t) or approximate (nil). + (interactive) + + (let ((docstruct (symbol-value reftex-docstruct-symbol)) + (cnt 0) rtn + found) + (save-excursion + (while (not rtn) + (incf cnt) + (setq found (re-search-backward reftex-everything-regexp nil t)) + (setq rtn + (cond + ((not found) + ;; no match + (or + (car (member (list 'bof (buffer-file-name)) docstruct)) + (not (setq cnt 2)) + (assq 'bof docstruct) ;; for safety reasons + 'corrupted)) + ((match-end 1) + ;; Label + (assoc (reftex-match-string 1) + (symbol-value reftex-docstruct-symbol))) + ((match-end 3) + ;; Section + (goto-char (1- (match-beginning 3))) + (let* ((list (member (list 'bof (buffer-file-name)) + docstruct)) + (endelt (car (member (list 'eof (buffer-file-name)) + list))) + rtn1) + (while (and list (not (eq endelt (car list)))) + (if (and (eq (car (car list)) 'toc) + (string= (buffer-file-name) + (nth 3 (car list)))) + (cond + ((equal (point) + (or (and (markerp (nth 4 (car list))) + (marker-position (nth 4 (car list)))) + (nth 8 (car list)))) + ;; Fits with marker position or recorded position + (setq rtn1 (car list) list nil)) + ((looking-at (reftex-make-regexp-allow-for-ctrl-m + (nth 7 (car list)))) + ;; Same title + (setq rtn1 (car list) list nil cnt 2)))) + (pop list)) + rtn1)) + ((match-end 7) + ;; Input or include... + (car + (member (list 'eof (reftex-find-tex-file + (reftex-match-string 7) + (cons + (cdr (assq 'master-dir docstruct)) + reftex-tex-path))) + docstruct))) + ((match-end 8) + (save-excursion + (goto-char (match-end 8)) + (assoc (reftex-no-props + (reftex-nth-arg-wrapper + (reftex-match-string 8))) + (symbol-value reftex-docstruct-symbol)))) + (t + (error "This should not happen (reftex-where-am-I)")))))) + (cons rtn (eq cnt 1)))) + +(defun reftex-parse-args (macro) + ;; Return a list of macro name, nargs, arg-nr which is label and a list of + ;; optional argument indices. + (if (string-match "[[{]\\*?[]}]" macro) + (progn + (let ((must-match (substring macro 0 (match-beginning 0))) + (args (substring macro (match-beginning 0))) + opt-list nlabel (cnt 0)) + (while (string-match "\\`[[{]\\(\\*\\)?[]}]" args) + (incf cnt) + (when (eq ?\[ (string-to-char args)) + (push cnt opt-list)) + (when (and (match-end 1) + (not nlabel)) + (setq nlabel cnt)) + (setq args (substring args (match-end 0)))) + (list must-match cnt nlabel opt-list))) + nil)) + +(defsubst reftex-move-to-next-arg (&optional ignore) + ;; Assuming that we are at the end of a macro name or a macro argument, + ;; move forward to the opening parenthesis of the next argument. + ;; This function understands the splitting of macros over several lines + ;; in TeX. + (cond + ;; Just to be quick: + ((memq (following-char) '(?\[ ?\{))) + ;; Do a search + ((looking-at "[ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*[[{]") + (goto-char (1- (match-end 0))) + t) + (t nil))) + +(defsubst reftex-move-to-previous-arg (&optional bound) + ;; Assuming that we are in front of a macro argument, + ;; move backward to the closing parenthesis of the previous argument. + ;; This function understands the splitting of macros over several lines + ;; in TeX. + (cond + ;; Just to be quick: + ((memq (preceding-char) '(?\] ?\}))) + ;; Do a search + ((re-search-backward + "[]}][ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*\\=" bound t) + (goto-char (1+ (match-beginning 0))) + t) + (t nil))) + +(defun reftex-nth-arg-wrapper (key) + (let ((entry (assoc key reftex-env-or-mac-alist))) + (reftex-nth-arg (nth 5 entry) (nth 6 entry)))) + +(defun reftex-nth-arg (n &optional opt-args) + ;; Return the nth following {} or [] parentheses content. + ;; OPT-ARGS is a list of argument numbers which are optional. + + ;; If we are sitting at a macro start, skip to end of macro name. + (and (eq (following-char) ?\\) (skip-chars-forward "a-zA-Z*\\\\")) + + (if (= n 1000) + ;; Special case: Skip all touching arguments + (progn + (reftex-move-over-touching-args) + (reftex-context-substring)) + + ;; Do the real thing. + (let ((cnt 1)) + + (when (reftex-move-to-next-arg) + + (while (< cnt n) + (while (and (member cnt opt-args) + (eq (following-char) ?\{)) + (incf cnt)) + (when (< cnt n) + (unless (and (condition-case nil + (or (forward-list 1) t) + (error nil)) + (reftex-move-to-next-arg) + (incf cnt)) + (setq cnt 1000)))) + + (while (and (memq cnt opt-args) + (eq (following-char) ?\{)) + (incf cnt))) + (if (and (= n cnt) + (> (skip-chars-forward "{\\[") 0)) + (reftex-context-substring) + nil)))) + +(defun reftex-move-over-touching-args () + (condition-case nil + (while (memq (following-char) '(?\[ ?\{)) + (forward-list 1)) + (error nil))) + (defun reftex-context-substring () ;; Return up to 100 chars from point ;; When point is just after a { or [, limit string to matching parenthesis (cond ((or (= (preceding-char) ?\{) (= (preceding-char) ?\[)) - ;; inside a list - get only the list, with modified syntax to be perfect - (buffer-substring + ;; Inside a list - get only the list. + (buffer-substring-no-properties (point) - (min (+ 100 (point)) - (point-max) - (condition-case nil - (progn - (up-list 1) - (1- (point))) - ('error (point-max)))))) + (min (reftex-fp 150) + (point-max) + (condition-case nil + (progn + (up-list 1) + (1- (point))) + (error (point-max)))))) (t ;; no list - just grab 100 characters - (buffer-substring (point) (min (+ 100 (point)) (point-max)))))) + (buffer-substring-no-properties (point) (min (reftex-fp 150) (point-max)))))) + +(defun reftex-init-section-numbers (&optional toc-entry) + ;; Initialize the section numbers with zeros or with what is found + ;; in the toc entry. + (let* ((level (or (nth 5 toc-entry) -1)) + (numbers (nreverse (split-string (or (nth 6 toc-entry) "") "\\."))) + (depth (1- (length reftex-section-numbers))) + (i depth)) + (while (>= i 0) + (if (> i level) + (aset reftex-section-numbers i 0) + (aset reftex-section-numbers i (string-to-int (or (car numbers) "0"))) + (pop numbers)) + (decf i)))) (defun reftex-section-number (section-numbers &optional level star) ;; Return a string with the current section number. ;; When LEVEL is non-nil, increase section numbers on that level. - (let* ((depth 6) idx n (string "")) - (if level - (progn - (if (and (> level -1) (not star)) - (aset section-numbers level (1+ (aref section-numbers level)))) - (setq idx (1+ level)) - (while (<= idx depth) - (aset section-numbers idx 0) - (setq idx (1+ idx))))) + (let* ((depth (1- (length section-numbers))) idx n (string "")) + (when level + (when (and (> level -1) (not star)) + (aset section-numbers level (1+ (aref section-numbers level)))) + (setq idx (1+ level)) + (while (<= idx depth) + (aset section-numbers idx 0) + (incf idx))) (setq idx 0) (while (<= idx depth) (setq n (aref section-numbers idx)) (setq string (concat string (if (not (string= string "")) "." "") (int-to-string n))) - (setq idx (1+ idx))) + (incf idx)) (save-match-data (if (string-match "\\`\\(0\\.\\)+" string) (setq string (replace-match "" nil nil string))) (if (string-match "\\(\\.0\\)+\\'" string) (setq string (replace-match "" nil nil string)))) - (if star - (concat (make-string (1- (length string)) ?\ ) "*") + (if star + (concat (make-string (1- (length string)) ?\ ) "*") string))) ;; A variable to remember the index of the last label context shown @@ -2381,13 +3397,13 @@ ;; Callback function called from the label selection in order to ;; show context in another window (let* ((this-window (selected-window)) - index entry label file buffer) + index entry label file buffer re) ;; pop to original buffer in order to get correct variables (catch 'exit (save-excursion (set-buffer reftex-call-back-to-this-buffer) (setq index (nth (or cnt 1) reftex-label-index-list) - entry (nth index (symbol-value reftex-list-of-labels-symbol)) + entry (nth index (symbol-value reftex-docstruct-symbol)) label (nth 0 entry) file (nth 3 entry))) @@ -2404,42 +3420,49 @@ ;; search for that label - (if (not (and (integerp cnt) - (integerp reftex-last-cnt) - (if (> cnt reftex-last-cnt) - (search-forward (concat "\\label{" label "}") nil t) - (search-backward (concat "\\label{" label "}") nil t)))) - (progn - (goto-char 1) - (search-forward (concat "\\label{" label "}") nil t))) - (reftex-highlight 0 (match-beginning 0) (match-end 0)) - (reftex-show-entry) - (recenter (/ (window-height) 2)) + (setq re (format reftex-find-label-regexp-format (regexp-quote label))) + (unless (and (integerp cnt) + (integerp reftex-last-cnt) + (if (> cnt reftex-last-cnt) + (re-search-forward re nil t) + (re-search-backward re nil t))) + (goto-char (point-min)) + (unless (re-search-forward re nil t) + ;; Ooops. Must be in a macro with distributed args. + (re-search-forward (format reftex-find-label-regexp-format2 + (regexp-quote label)) nil t))) + (when (match-end 3) + (reftex-highlight 0 (match-beginning 3) (match-end 3)) + (reftex-show-entry (- (point) (match-beginning 3)) + (- (point) (match-end 3))) + (recenter (/ (window-height) 2))) (select-window this-window)))) (defun reftex-pop-to-label (label file-list &optional mark-to-kill highlight) ;; Find LABEL in any file in FILE-LIST in another window. ;; If mark-to-kill is non-nil, mark new buffer for killing. ;; If HIGHLIGHT is non-nil, highlight the label definition. - (let* ((re (concat "\\\\label{" (regexp-quote label) "}")) + (let* ((re1 (format reftex-find-label-regexp-format (regexp-quote label))) + (re2 (format reftex-find-label-regexp-format2 (regexp-quote label))) + (re-list (list re1 re2)) re + (file-list-1 file-list) file buf) (catch 'exit - (while file-list - (setq file (car file-list) - file-list (cdr file-list)) - (if (not (setq buf (reftex-get-file-buffer-force file mark-to-kill))) - (error "No such file %s" file)) - (set-buffer buf) - (widen) - (goto-char (point-min)) - (if (re-search-forward re nil t) - (progn - (switch-to-buffer-other-window buf) - (goto-char (match-beginning 0)) - (recenter (/ (window-height) 2)) - (if highlight - (reftex-highlight 0 (match-beginning 0) (match-end 0))) - (throw 'exit (selected-window))))) + (while (setq re (pop re-list)) + (setq file-list file-list-1) + (while (setq file (pop file-list)) + (unless (setq buf (reftex-get-file-buffer-force file mark-to-kill)) + (error "No such file %s" file)) + (set-buffer buf) + (widen) + (goto-char (point-min)) + (when (re-search-forward re nil t) + (switch-to-buffer-other-window buf) + (goto-char (match-beginning 0)) + (recenter (/ (window-height) 2)) + (if highlight + (reftex-highlight 0 (match-beginning 3) (match-end 3))) + (throw 'exit (selected-window))))) (error "Label %s not found" label)))) (defun reftex-find-duplicate-labels () @@ -2451,21 +3474,26 @@ (reftex-access-scan-info t) (let ((master (reftex-TeX-master-file)) - (dlist + (cnt 0) + (dlist (mapcar '(lambda(x) (let (x1) (cond - ((car x) + ((memq (car x) + '(toc bof eof bib label-numbers xr xr-doc + master-dir file-error is-multi)) + nil) + (t (setq x1 (reftex-all-assoc-string - (car x) (symbol-value reftex-list-of-labels-symbol))) + (car x) (symbol-value reftex-docstruct-symbol))) (if (< 1 (length x1)) - (append (list (reftex-no-props (car x))) + (append (list (car x)) (mapcar '(lambda(x) (abbreviate-file-name (nth 3 x))) x1)) - (list nil))) - (t nil)))) - (reftex-uniquify (symbol-value reftex-list-of-labels-symbol))))) + (list nil)))))) + (reftex-uniquify (symbol-value reftex-docstruct-symbol))))) + (setq dlist (reftex-uniquify dlist)) (if (null dlist) (error "No duplicate labels in document")) (switch-to-buffer-other-window "*Duplicate Labels*") @@ -2473,82 +3501,125 @@ (setq TeX-master master) (erase-buffer) (insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n") - (insert " Move point to label and type `M-x reftex-change-label'\n" - " This will run a query-replace on the label and its references\n") + (insert + " Move point to label and type `r' to run a query-replace on the label\n" + " and its references. Type `q' to exit this buffer.\n\n") (insert " LABEL FILE\n") (insert " -------------------------------------------------------------\n") + (use-local-map (make-sparse-keymap)) + (local-set-key [?q] '(lambda () (interactive) + (kill-buffer (current-buffer)) (delete-window))) + (local-set-key [?r] 'reftex-change-label) (while dlist - (if (and (car (car dlist)) - (cdr (car dlist))) - (progn - (insert (mapconcat '(lambda(x) x) (car dlist) "\n ") "\n"))) - (setq dlist (cdr dlist))) - (goto-char (point-min)))) + (when (and (car (car dlist)) + (cdr (car dlist))) + (incf cnt) + (insert (mapconcat '(lambda(x) x) (car dlist) "\n ") "\n")) + (pop dlist)) + (goto-char (point-min)) + (when (= cnt 0) + (kill-buffer (current-buffer)) + (delete-window) + (message "Document does not contain duplicate labels.")))) + +(defun reftex-all-assq (key list) + ;; Return a list of all associations of KEY in LIST. Comparison with string= + (let (rtn) + (while (setq list (memq (assq key list) list)) + (push (car list) rtn) + (pop list)) + (nreverse rtn))) (defun reftex-all-assoc-string (key list) ;; Return a list of all associations of KEY in LIST. Comparison with string= (let (rtn) (while list (if (string= (car (car list)) key) - (setq rtn (cons (car list) rtn))) - (setq list (cdr list))) + (push (car list) rtn)) + (pop list)) (nreverse rtn))) -(defun reftex-kill-temporary-buffers () +(defun reftex-kill-temporary-buffers (&optional buffer) ;; Kill all buffers in the list reftex-kill-temporary-buffers. - (while reftex-buffers-to-kill - (if (bufferp (car reftex-buffers-to-kill)) - (progn - (and (buffer-modified-p (car reftex-buffers-to-kill)) - (y-or-n-p (format "Save file %s? " - (buffer-file-name - (car reftex-buffers-to-kill)))) - (save-excursion - (set-buffer (car reftex-buffers-to-kill)) - (save-buffer))) - (kill-buffer (car reftex-buffers-to-kill)))) - (setq reftex-buffers-to-kill (cdr reftex-buffers-to-kill)))) - -(defun reftex-show-entry () + (cond + (buffer + (when (member buffer reftex-buffers-to-kill) + (kill-buffer buffer) + (setq reftex-buffers-to-kill + (delete buffer reftex-buffers-to-kill)))) + (t + (while (setq buffer (pop reftex-buffers-to-kill)) + (when (bufferp buffer) + (and (buffer-modified-p buffer) + (y-or-n-p (format "Save file %s? " + (buffer-file-name buffer))) + (save-excursion + (set-buffer buffer) + (save-buffer))) + (kill-buffer buffer)) + (pop reftex-buffers-to-kill))))) + +(defun reftex-show-entry (beg-hlt end-hlt) ;; Show entry if point is hidden by outline mode - (let ((pos (point))) + (let* ((pos (point)) + (n (/ (window-height) 2)) + (beg (save-excursion + (re-search-backward "[\n\r]" nil 1 n) (point))) + (end (save-excursion + (re-search-forward "[\n\r]" nil 1 n) (point)))) (if (and reftex-auto-show-entry - (boundp 'outline-minor-mode) - outline-minor-mode - (looking-at "[^\n\r]*\r")) - (progn - (outline-back-to-heading) - (show-entry) - (goto-char pos))))) - + (string-match + "\r" (buffer-substring beg end))) + (cond + ((eq t reftex-auto-show-entry) + (subst-char-in-region + (save-excursion (search-backward "\n" nil t) (point)) + (save-excursion (search-forward "\n" nil t) (point)) + ?\r ?\n t)) + ((eq reftex-auto-show-entry 'copy) + (let ((string (buffer-substring beg end))) + (switch-to-buffer "*RefTeX Context Copy*") + (setq buffer-read-only nil) + (erase-buffer) + (insert string) + (subst-char-in-region (point-min) (point-max) ?\r ?\n t) + (goto-char (- pos beg)) + (reftex-highlight 0 (1+ (- (point) beg-hlt)) + (1+ (- (point) end-hlt))) + (when (reftex-refontify) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults nil) + (let ((major-mode 'latex-mode)) + (font-lock-set-defaults) + (font-lock-fontify-buffer))) + (setq buffer-read-only t))) + )))) (defun reftex-nicify-text (text) - ;; Make TEXT nice for inclusion into label menu + ;; Make TEXT nice for inclusion as context into label menu (while (string-match "[\n\r\t]\\|[ \t][ \t]+" text) ; remove extra whitespace (setq text (replace-match " " nil t text))) (if (string-match "\\\\end{.*" text) ; nothing beyond \end{ (setq text (replace-match "" nil t text))) (if (string-match "\\\\label{[^}]*}" text) ; kill the label (setq text (replace-match "" nil t text))) - (if (string-match "^ +" text) ; leading whitespace + (if (string-match "\\`[ }]+" text) ; leading whitespace, `}' (setq text (replace-match "" nil t text))) (cond - ((> (length text) 100) ; not to long - (setq text (substring text 0 100))) - ((= (length text) 0) ; not empty - (setq text " "))) - text) + ((> (length text) 100) (substring text 0 100)) + ((= (length text) 0) " ") + (t text))) (defun reftex-typekey-check (typekey conf-variable &optional n) ;; Check if CONF-VARIABLE is true or contains TYPEKEY (and n (setq conf-variable (nth n conf-variable))) - (or (equal conf-variable t) + (or (eq conf-variable t) (and (stringp conf-variable) (string-match (concat "[" conf-variable "]") typekey)))) ;;; =========================================================================== ;;; -;;; Table of contents (contributed from Stephen Eglen, changed by C. Dominik) +;;; Table of contents ;; We keep at most one *toc* buffer - it is easy to make them @@ -2558,68 +3629,73 @@ (defvar reftex-last-toc-file nil "Stores the file name from which `reftex-toc' was called. For redo command.") +(defvar reftex-last-window-height nil) + (defvar reftex-toc-return-marker (make-marker) "Marker which makes it possible to return from toc to old position.") +(defconst reftex-toc-help +" AVAILABLE KEYS IN TOC BUFFER + ============================ +SPC Show the corresponding section of the LaTeX document. +TAB Goto the section. +RET Goto the section and hide the *toc* buffer (also on mouse-2). +q / Q Hide/Kill *toc* buffer, return to position of last reftex-toc command. +f Toggle follow mode on and off. +r / g Reparse the LaTeX document. +x Switch to TOC of external document (with LaTeX package `xr').") + (defun reftex-toc () "Show the table of contents for the current document. -To see the corresponding part of the LaTeX document, use within the -*toc* buffer: - -SPC Show the corresponding section of the LaTeX document. -RET Goto the section and hide the *toc* buffer. -q Hide the *toc* window and return to position of last reftex-toc command. -Q Kill the *toc* buffer and return to position of last reftex-toc command. -f Toggle follow mode on and off. -r Reparse the LaTeX document. -g Revert buffer (like `r'). - When called with a raw C-u prefix, rescan the document first." (interactive) - (and (not (string= reftex-last-toc-master (reftex-TeX-master-file))) - (get-buffer "*toc*") - (kill-buffer "*toc*")) + (if (or (not (string= reftex-last-toc-master (reftex-TeX-master-file))) + current-prefix-arg) + (reftex-empty-toc-buffer)) (setq reftex-last-toc-file (buffer-file-name)) (setq reftex-last-toc-master (reftex-TeX-master-file)) (set-marker reftex-toc-return-marker (point)) - ;; if follow mode is active, arrange to delay it one command + ;; If follow mode is active, arrange to delay it one command (if reftex-toc-follow-mode (setq reftex-toc-follow-mode 1)) - (if (and current-prefix-arg - (get-buffer "*toc*")) - (kill-buffer "*toc*")) - ;; Ensure access to scanning info and rescan buffer if prefix are is '(4) (reftex-access-scan-info current-prefix-arg) - (let* ((all (symbol-value reftex-list-of-labels-symbol)) + (let* ((all (symbol-value reftex-docstruct-symbol)) + (xr-data (assq 'xr all)) + (xr-alist (cons (cons "" (buffer-file-name)) (nth 1 xr-data))) (where (reftex-nearest-section)) - toc toc1 cell label file find startpos) - - (if (and (get-buffer "*toc*") - (get-buffer-window (get-buffer "*toc*"))) - (select-window (get-buffer-window (get-buffer "*toc*"))) - (delete-other-windows) - (switch-to-buffer-other-window (current-buffer)) - (switch-to-buffer-other-window (get-buffer-create "*toc*"))) + toc1 cell startpos) + + (if (get-buffer-window "*toc*") + (select-window (get-buffer-window "*toc*")) + (setq reftex-last-window-height (window-height)) ; remember + (split-window-vertically) + (switch-to-buffer (get-buffer-create "*toc*"))) (cond ;; buffer is empty - fill it with the table of contents ((= (buffer-size) 0) - (local-set-key " " 'reftex-toc-view-line) - (local-set-key "\C-m" 'reftex-toc-goto-line-and-hide) - (local-set-key "r" 'reftex-toc-redo) - (local-set-key "g" 'revert-buffer) - (local-set-key "q" 'reftex-toc-quit) - (local-set-key "Q" 'reftex-toc-quit-and-kill) - (local-set-key "f" 'reftex-toc-toggle-follow) + (local-set-key "?" 'reftex-toc-show-help) + (local-set-key " " 'reftex-toc-view-line) + (local-set-key "\C-m" 'reftex-toc-goto-line-and-hide) + (local-set-key "\C-i" 'reftex-toc-goto-line) + (local-set-key "r" 'reftex-toc-redo) + (local-set-key "R" 'reftex-toc-Redo) + (local-set-key "g" 'revert-buffer) + (local-set-key "q" 'reftex-toc-quit) + (local-set-key "Q" 'reftex-toc-quit-and-kill) + (local-set-key "f" 'reftex-toc-toggle-follow) + (local-set-key "x" 'reftex-toc-external) + (local-set-key [(mouse-2)] 'reftex-toc-mouse-goto-line-and-hide); Emacs + (local-set-key [(button2)] 'reftex-toc-mouse-goto-line-and-hide); XEmacs (make-local-variable 'revert-buffer-function) (setq revert-buffer-function 'reftex-toc-redo) (setq truncate-lines t) @@ -2630,7 +3706,7 @@ (insert (format "TABLE-OF-CONTENTS on %s -MENU: SPC=view RET=goto [q]uit [Q]uit+kill [r]escan [f]ollow-mode +SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [f]ollow-mode e[x]tern [?]Help ------------------------------------------------------------------------------- " (abbreviate-file-name reftex-last-toc-master))) (setq startpos (point)) @@ -2638,23 +3714,15 @@ (if (reftex-use-fonts) (put-text-property 1 (point) 'face 'font-lock-keyword-face)) (put-text-property 1 (point) 'intangible t) + (put-text-property 1 2 'xr-alist xr-alist) (while all (setq cell (car all) all (cdr all)) - (setq label (nth 0 cell) - toc (nth 2 cell) - file (nth 3 cell) - find (nth 4 cell)) - (if (not label) - (progn - (setq toc1 (concat toc "\n")) - (put-text-property 0 (length toc1) - 'file file toc1) - (put-text-property 0 (length toc1) - 'find find toc1) - (insert toc1) - ))) + (when (eq (car cell) 'toc) + (setq toc1 (concat (nth 2 cell) "\n")) + (put-text-property 0 (length toc1) 'toc cell toc1) + (insert toc1))) (backward-delete-char 1) @@ -2668,37 +3736,14 @@ (goto-char (point-max)) (beginning-of-line) (while (and (> (point) startpos) - (or (not (string= (get-text-property (point) 'file) - (car where))) - (not (string= (get-text-property (point) 'find) - (cdr where))))) + (not (eq (get-text-property (point) 'toc) where))) (beginning-of-line 0)))) (defun reftex-nearest-section () ;; Return (file . find) of nearest section command - (let (cell label rest) - (save-excursion - (cond - ;; Try to find a section heading - ((or (re-search-backward reftex-section-regexp nil t) - (re-search-forward reftex-section-regexp nil t)) - (goto-char (match-end 0)) - (cons (buffer-file-name) - (reftex-allow-for-ctrl-m - (concat (buffer-substring-no-properties - (1- (match-beginning 1)) (match-end 0)) - (reftex-context-substring))))) - ;; Try to find a label - ((and (or (re-search-backward "\\\\label{\\([^}]+\\)}" nil t) - (re-search-forward "\\\\label{\\([^}]+\\)}" nil t)) - (setq label (reftex-no-props (match-string 1))) - (setq cell (assoc label (symbol-value - reftex-list-of-labels-symbol))) - (setq rest (memq cell (symbol-value reftex-list-of-labels-symbol))) - (setq cell (car (memq (assoc nil rest) rest))) - (null (car cell))) - (cons (nth 3 cell) (nth 4 cell))) - (t nil))))) + (let* ((here-I-am (car (reftex-where-am-I)))) + (reftex-last-assoc-before-elt + 'toc here-I-am (symbol-value reftex-docstruct-symbol)))) (defun reftex-toc-pre-command-hook () ;; used as pre command hook in *toc* buffer @@ -2709,9 +3754,9 @@ ;; used in the post-command-hook for the *toc* buffer (and (> (point) 1) (save-excursion - (reftex-highlight 1 - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))))) + (reftex-highlight 1 + (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))))) (cond ((integerp reftex-toc-follow-mode) ;; remove delayed action @@ -2720,7 +3765,27 @@ ;; show context in other window (condition-case nil (reftex-toc-visit-line) - ('error t))))) + (error (ding) t))))) + +(defun reftex-empty-toc-buffer () + (if (get-buffer "*toc*") + (save-excursion + (set-buffer "*toc*") + (setq buffer-read-only nil) + (erase-buffer)))) + +(defun reftex-re-enlarge () + (enlarge-window + (max 0 (- (or reftex-last-window-height (window-height)) + (window-height))))) + +(defun reftex-toc-show-help () + (interactive) + (with-output-to-temp-buffer "*RefTeX Help*" + (princ reftex-toc-help)) + ;; If follow mode is active, arrange to delay it one command + (if reftex-toc-follow-mode + (setq reftex-toc-follow-mode 1))) (defun reftex-toc-toggle-follow () "Toggle toc-follow mode. @@ -2735,70 +3800,132 @@ "Go to document location in other window. Hide the *toc* window." (interactive) (reftex-toc-visit-line 'hide)) +(defun reftex-toc-goto-line () + "Go to document location in other window. Hide the *toc* window." + (interactive) + (reftex-toc-visit-line t)) +(defun reftex-toc-mouse-goto-line-and-hide (ev) + "Go to document location in other window. Hide the *toc* window." + (interactive "e") + (mouse-set-point ev) + (reftex-toc-visit-line 'hide)) (defun reftex-toc-quit () "Hide the *toc* window and do not move point." (interactive) - (delete-window) + (or (one-window-p) (delete-window)) (switch-to-buffer (marker-buffer reftex-toc-return-marker)) - (goto-char (marker-position reftex-toc-return-marker))) + (reftex-re-enlarge) + (goto-char (or (marker-position reftex-toc-return-marker) (point)))) (defun reftex-toc-quit-and-kill () "Kill the *toc* buffer." (interactive) (kill-buffer "*toc*") - (delete-window) + (or (one-window-p) (delete-window)) (switch-to-buffer (marker-buffer reftex-toc-return-marker)) + (reftex-re-enlarge) (goto-char (marker-position reftex-toc-return-marker))) (defun reftex-toc-redo (&rest ignore) - "Regenerate the *toc* buffer. Call only from within the *toc* buffer" + "Regenerate the *toc* buffer by reparsing file of last reftex-toc command." + (interactive) + (if reftex-enable-partial-scans + (let ((file (nth 3 (get-text-property (point) 'toc)))) + (if (not file) + (error "Don't know which file to rescan. Try `R'.") + (switch-to-buffer-other-window + (reftex-get-file-buffer-force file)) + (setq current-prefix-arg '(4)) + (reftex-toc))) + (reftex-toc-Redo)) + (reftex-kill-temporary-buffers)) +(defun reftex-toc-Redo (&rest ignore) + "Regenerate the *toc* buffer by reparsing the entire document." (interactive) - (switch-to-buffer (reftex-get-file-buffer-force reftex-last-toc-file)) - (delete-other-windows) - (setq current-prefix-arg '(4)) + (switch-to-buffer-other-window + (reftex-get-file-buffer-force reftex-last-toc-file)) + (setq current-prefix-arg '(16)) (reftex-toc)) +(defun reftex-toc-external (&rest ignore) + "Switch to table of contents of an external document." + (interactive) + (let* ((xr-alist (get-text-property 1 'xr-alist)) + (xr-index (reftex-select-external-document + xr-alist 0))) + (switch-to-buffer-other-window (or (reftex-get-file-buffer-force + (cdr (nth xr-index xr-alist))) + (error "Cannot switch document"))) + (reftex-toc))) (defun reftex-toc-visit-line (&optional final) ;; Visit the tex file corresponding to the toc entry on the current line. ;; If FINAL is t, stay there ;; If FINAL is 'hide, hide the *toc* window. - ;; Otherwise, move cursor back into *toc* window - - (let (file find beg end (toc-window (selected-window)) show-window) - (save-excursion - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq end (point))) - - ;; get the file and the search string - (setq file (get-text-property (point) 'file)) - (setq find (get-text-property (point) 'find)) - (if (or (not file) (not find)) - (error "Cannot visit line")) - - (switch-to-buffer-other-window (reftex-get-file-buffer-force file)) - (setq show-window (selected-window)) - (goto-char (point-min)) - - (if (not (re-search-forward find nil t)) - (error "Cannot visit line")) - - (setq beg (match-beginning 0) - end (match-end 0)) - - (goto-char beg) + ;; Otherwise, move cursor back into *toc* window. + ;; This function is pretty clever about finding back a section heading, + ;; even if the buffer is not live, or things like outline, x-symbol etc. + ;; have been active. + + (let* ((toc (get-text-property (point) 'toc)) + (file (nth 3 toc)) + (marker (nth 4 toc)) + (level (nth 5 toc)) + (literal (nth 7 toc)) + (emergency-point (nth 8 toc)) + (toc-window (selected-window)) + show-window show-buffer match) + + (unless toc (error "Don't know which toc line to visit")) + + (setq match + (cond + ((and (markerp marker) (marker-buffer marker)) + ;; Buffer is still live and we have the marker. Should be easy. + (switch-to-buffer-other-window (marker-buffer marker)) + (goto-char (marker-position marker)) + (or (looking-at (regexp-quote literal)) + (looking-at (reftex-make-regexp-allow-for-ctrl-m literal)) + (looking-at (reftex-make-desparate-section-regexp literal)) + (looking-at (concat "\\\\" + (regexp-quote + (car (rassq level reftex-section-levels))) + "[[{]")))) + (t + ;; Marker is lost. Use the backup method. + (switch-to-buffer-other-window + (reftex-get-file-buffer-force file nil)) + (goto-char (or emergency-point (point-min))) + (or (looking-at (regexp-quote literal)) + (let ((pos (point))) + (re-search-backward "\\`\\|[\r\n][ \t]*[\r\n]" nil t) + (or (reftex-nearest-match (regexp-quote literal) pos) + (reftex-nearest-match + (reftex-make-regexp-allow-for-ctrl-m literal) pos) + (reftex-nearest-match + (reftex-make-desparate-section-regexp literal) pos))))) + )) + + (setq show-window (selected-window) + show-buffer (current-buffer)) + + (unless match + (select-window toc-window) + (error "Cannot find line")) + + (goto-char (match-beginning 0)) (recenter 1) - (reftex-highlight 0 beg end (current-buffer)) + (reftex-highlight 0 (match-beginning 0) (match-end 0) (current-buffer)) (select-window toc-window) ;; use the `final' parameter to decide what to do next (cond - ((equal final t) + ((eq final t) (reftex-unhighlight 0) (select-window show-window)) ((eq final 'hide) (reftex-unhighlight 0) - (delete-window)) + (or (one-window-p) (delete-window)) + (switch-to-buffer show-buffer) + (reftex-re-enlarge)) (t nil)))) ;;; =========================================================================== @@ -2809,131 +3936,87 @@ ;; Define variable to silence compiler warnings (defvar reftex-found-list) - -;; Internal variable, but used from different functions -(defvar reftex-cite-format1 nil) +(defvar reftex-cite-format-builtin) ;; The history list of regular expressions used for citations (defvar reftex-cite-regexp-hist nil) -;; Help string for citation selection +;; Prompt and help string for citation selection +(defconst reftex-citation-prompt + "Select: [n]ext [p]revious [r]estrict [ ]full_entry [q]uit RET [?]Help+more") + (defconst reftex-citation-help "AVAILABLE KEYS IN MAKE CITATION MENU --------------------------------------- - n / p Go to next/previous entry (Cursor motion works as well). - r Restrict selection with another regexp. - SPACE Show full database entry in other window. - f Toggle follow mode: Other window will follow with full db entry. - q Quit without inserting \\cite macro into buffer. - ? Display this help message. - C-r Recursive edit into other window. - RETURN ... Accept current entry and insert in format according to - `reftex-cite-format'") - -(defconst reftex-cite-format-default "\\cite{KEY}" - "The default value for reftex-cite-format. -Uses the string version of `reftex-cite-format'.") - -(defconst reftex-cite-format-1-author-simple - '( "\\cite{KEY}" "AUTHOR \\cite{KEY}" "AUTHOR {\it et al.} \\cite{KEY}") - "Value for reftex-cite format establishing a simple citation with name -of the first author. -Uses the list version of `reftex-cite-format'.") - -(defconst reftex-cite-format-2-authors - '((?\C-m - . ( "\\cite{KEY}" "AUTHOR \\cite{KEY}" - "AUTHOR \\& AUTHOR \\cite{KEY}" "AUTHOR \\etal{} \\cite{KEY}")) - (?\, - . ("\\cite{KEY}" "AUTHOR, \\cite{KEY}" - "AUTHOR \\& AUTHOR, \\cite{KEY}" "AUTHOR \\etal{}, \\cite{KEY}")) - (?\; - . ("\\cite{KEY}" "AUTHOR; \\cite{KEY}" - "AUTHOR \\& AUTHOR; \\cite{KEY}" "AUTHOR \\etal{}; \\cite{KEY}")) - (?\: - . ("\\cite{KEY}" "AUTHOR: \\cite{KEY}" - "AUTHOR \\& AUTHOR: \\cite{KEY}" "AUTHOR \\etal{}: \\cite{KEY}")) - (?\( - . ("(\\cite{KEY})" "AUTHOR (\\cite{KEY})" - "AUTHOR \\& AUTHOR (\\cite{KEY})" "AUTHOR \\etal{} (\\cite{KEY})")) - (?\[ - . ("[\\cite{KEY}]" "AUTHOR [\\cite{KEY}]" - "AUTHOR \\& AUTHOR [\\cite{KEY}]" "AUTHOR \\etal{} [\\cite{KEY}]"))) - "Value for `reftex-cite-format' that estabishes an Author/Year citation -where the year is supplied from BibTeX. Depending on which character -is used during selection to accept the label, an extra ,;: or pair of -parenthesis will be inserted. -Uses the list-of-cons-cells version of `reftex-cite-format'.") + n / p Go to next/previous entry (Cursor motion works as well). + C-s / C-r Search forward/backward. Use repeated C-s/C-r as in isearch. + g / r Start over with new regexp / Restrict with additional regexp. + SPC Show full database entry in other window. + f Toggle follow mode: Other window will follow with full db entry. + q Quit without inserting \\cite macro into buffer. + e Recursive edit into other window. + RET / a Accept current entry / Accept all entries.") ;; Find bibtex files (defun reftex-get-bibfile-list () - ;; Return list of bibfiles for current document + ;; Return list of bibfiles for current document. + ;; When using the chapterbib or bibunits package you should either + ;; use the same database files everywhere, or separate parts using + ;; different databases into different files (included into the mater file). + ;; Then this function will return the applicable database files. ;; Ensure access to scanning info (reftex-access-scan-info) - - (or (symbol-value reftex-bibfile-list-symbol) - (error "No BibTeX files to parse. Add \\bibliography statment to document and reparse."))) - -(defun reftex-scan-buffer-for-bibliography-statement (bib-list-symbol) - ;; Scan buffer for bibliography macro and store file list in bib-list-symbol. - (let (file-list dir-list) - (setq dir-list - (reftex-split - (concat path-separator "+") - (mapconcat '(lambda(x) - (if (getenv x) (getenv x) "")) - reftex-bibpath-environment-variables - path-separator))) - (goto-char (point-min)) - (if (re-search-forward "^[ \t]*\\\\bibliography{[ \t]*\\([^}]+\\)" nil t) - (progn - (setq dir-list - (cons (file-name-directory - (get-text-property (match-beginning 0) 'file)) - dir-list)) - (setq file-list - (mapcar '(lambda (x) (concat x ".bib")) - (reftex-delete-list - reftex-bibfile-ignore-list - (reftex-split - "[ \t\n]*,[ \t\n]*" - (reftex-no-props (match-string 1))))))) - (message "No \\bibliography command in document.")) - (set bib-list-symbol - (if file-list - (reftex-find-files-on-path file-list dir-list - "While parsing \\bibliography:") - nil)))) - -(defun reftex-find-files-on-path (file-list path-list &optional error-string) - ;; Search for all files in FILE-LIST on the PATH-LIST. Return absolute names. - ;; A missing file throws an exception with the error message ERROR-STRING. - (let (found-list found file) - (while file-list - (setq file (car file-list) - file-list (cdr file-list) - found nil) - (if (file-name-absolute-p file) - (setq found (expand-file-name file)) - (let ((dirs path-list)) - (while (and dirs (not found)) - (if (and (not (string= (car dirs) "")) - (file-exists-p (expand-file-name file (car dirs)))) - (setq found (expand-file-name file (car dirs)))) - (setq dirs (cdr dirs))))) - (if (and found - (file-exists-p found)) - (add-to-list 'found-list (expand-file-name found)) - (error "%s No such file %s." - (or error-string "") file))) - (nreverse found-list))) + (or + ;; Try inside this file (and its includes) + (cdr (reftex-last-assoc-before-elt + 'bib (list 'eof (buffer-file-name)) + (member (list 'bof (buffer-file-name)) + (symbol-value reftex-docstruct-symbol)))) + ;; Try after the beginning of this file + (cdr (assq 'bib (member (list 'bof (buffer-file-name)) + (symbol-value reftex-docstruct-symbol)))) + ;; Anywhere in the entire document + (cdr (assq 'bib (symbol-value reftex-docstruct-symbol))) + (error "\\bibliography statment missing or .bib files not found."))) + +(defun reftex-find-tex-file (file master-dir &optional die) + ;; Find FILE in MASTER-DIR or on reftex-tex-path. + ;; FILE may be given without the .tex extension. + (reftex-access-search-path "tex") + (let* ((path (cons master-dir reftex-tex-path)) + file1) + (setq file1 + (or (reftex-find-file-on-path (concat file ".tex") path) + (reftex-find-file-on-path file path))) + (unless file1 + (reftex-access-search-path "tex" t file) + (setq path (cons master-dir reftex-tex-path)) + (setq file1 + (or (reftex-find-file-on-path (concat file ".tex") path) + (reftex-find-file-on-path file path)))) + (cond (file1 file1) + (die (error "No such file: %s" file) nil) + (t (message "No such file: %s (ignored)" file) nil)))) + +(defun reftex-find-bib-file (file master-dir &optional die) + ;; Find FILE in MASTER-DIR or on reftex-bib-path + (reftex-access-search-path "bib") + (let ((file1 (reftex-find-file-on-path + file (cons master-dir reftex-bib-path)))) + (unless file1 + (reftex-access-search-path "bib" t file) + (setq file1 (reftex-find-file-on-path + file (cons master-dir reftex-bib-path)))) + (cond (file1 file1) + (die (error "No such file: %s" file) nil) + (t (message "No such file: %s (ignored)" file) nil)))) ;; Find a certain reference in any of the BibTeX files. (defun reftex-pop-to-bibtex-entry (key file-list - &optional mark-to-kill highlight) + &optional mark-to-kill highlight) ;; Find BibTeX KEY in any file in FILE-LIST in another window. ;; If mark-to-kill is non-nil, mark new buffer to kill." @@ -2945,18 +4028,17 @@ (while file-list (setq file (car file-list) file-list (cdr file-list)) - (if (not (setq buf (reftex-get-file-buffer-force file mark-to-kill))) - (error "No such file %s" file)) + (unless (setq buf (reftex-get-file-buffer-force file mark-to-kill)) + (error "No such file %s" file)) (switch-to-buffer buf) (widen) - (goto-char 0) - (if (re-search-forward re nil t) - (progn - (goto-char (match-beginning 0)) - (recenter 0) - (if highlight - (reftex-highlight 0 (match-beginning 0) (match-end 0))) - (throw 'exit (selected-window))))) + (goto-char (point-min)) + (when (re-search-forward re nil t) + (goto-char (match-beginning 0)) + (recenter 0) + (if highlight + (reftex-highlight 0 (match-beginning 0) (match-end 0))) + (throw 'exit (selected-window)))) (set-window-configuration window-conf) (beep) (message "No BibTeX entry with citation key %s" key)))) @@ -2968,15 +4050,14 @@ ;; BUFFERS is a list of buffers or file names. ;; Return list with entries." (let* (re-list first-re rest-re - ;; avoid fontification of lookup buffers - (lazy-lock-minimum-size 1) (buffer-list (if (listp buffers) buffers (list buffers))) found-list entry buffer1 buffer alist key-point start-point end-point) - (setq re-list (reftex-split "[ \t]*&&[ \t]*" - (read-string "RegExp [ && RegExp...]: " - nil 'reftex-cite-regexp-hist))) + (setq re-list (split-string + (read-string "RegExp [ && RegExp...]: " + nil 'reftex-cite-regexp-hist) + "[ \t]*&&[ \t]*")) (setq first-re (car re-list) ; We'll use the first re to find things, rest-re (cdr re-list)) ; the other to narrow down. @@ -2986,7 +4067,7 @@ (save-excursion (save-window-excursion - ;; walk through all bibtex files + ;; Walk through all bibtex files (while buffer-list (setq buffer (car buffer-list) buffer-list (cdr buffer-list)) @@ -3000,68 +4081,64 @@ (message "Scanning bibliography database %s" buffer1)) (set-buffer buffer1) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward first-re nil t) - (catch 'search-again - (setq key-point (point)) - (if (not (re-search-backward - "^[ \t]*@\\([a-zA-Z]+\\)[ \t\n\r]*[{(]" nil t)) - (throw 'search-again nil)) - (setq start-point (point)) - (goto-char (match-end 0)) - (condition-case nil - (up-list 1) - ('error (goto-char key-point) - (throw 'search-again nil))) - (setq end-point (point)) - - ;; Ignore @string, @comment and @c entries or things - ;; outside entries - (if (or (string= (downcase (match-string 1)) "string") - (string= (downcase (match-string 1)) "comment") - (string= (downcase (match-string 1)) "c") - (< (point) key-point)) ; this means match not in {} - (progn - (goto-char key-point) - (throw 'search-again nil))) - - ;; Well, we have got a match - (setq entry (concat - (buffer-substring start-point (point)) "\n")) - - ;; Check if other regexp match as well - (setq re-list rest-re) - (while re-list - (if (not (string-match (car re-list) entry)) - ;; nope - move on - (throw 'search-again nil)) - (setq re-list (cdr re-list))) - - (setq alist (reftex-parse-bibtex-entry - nil start-point end-point)) - (setq alist (cons (cons "&entry" entry) alist)) - - ;; check for crossref entries - (if (assoc "crossref" alist) - (setq alist - (append - alist (reftex-get-crossref-alist alist)))) - - ;; format the entry - (setq alist - (cons - (cons "&formatted" - (reftex-format-bib-entry alist)) - alist)) - - ;; add it to the list - (setq found-list (cons alist found-list))))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward first-re nil t) + (catch 'search-again + (setq key-point (point)) + (unless (re-search-backward + "\\(\\`\\|[\n\r]\\)[ \t]*@\\([a-zA-Z]+\\)[ \t\n\r]*[{(]" nil t) + (throw 'search-again nil)) + (setq start-point (point)) + (goto-char (match-end 0)) + (condition-case nil + (up-list 1) + (error (goto-char key-point) + (throw 'search-again nil))) + (setq end-point (point)) + + ;; Ignore @string, @comment and @c entries or things + ;; outside entries + (when (or (string= (downcase (match-string 2)) "string") + (string= (downcase (match-string 2)) "comment") + (string= (downcase (match-string 2)) "c") + (< (point) key-point)) ; this means match not in {} + (goto-char key-point) + (throw 'search-again nil)) + + ;; Well, we have got a match + (setq entry (concat + (buffer-substring start-point (point)) "\n")) + + ;; Check if other regexp match as well + (setq re-list rest-re) + (while re-list + (unless (string-match (car re-list) entry) + ;; nope - move on + (throw 'search-again nil)) + (pop re-list)) + + (setq alist (reftex-parse-bibtex-entry + nil start-point end-point)) + (push (cons "&entry" entry) alist) + + ;; check for crossref entries + (if (assoc "crossref" alist) + (setq alist + (append + alist (reftex-get-crossref-alist alist)))) + + ;; format the entry + (push (cons "&formatted" (reftex-format-bib-entry alist)) + alist) + + ;; add it to the list + (push alist found-list)))) (reftex-kill-temporary-buffers)))) (setq found-list (nreverse found-list)) - + ;; Sorting - (cond + (cond ((eq 'author reftex-sort-bibtex-matches) (sort found-list 'reftex-bib-sort-author)) ((eq 'year reftex-sort-bibtex-matches) @@ -3071,13 +4148,14 @@ (t found-list)))) (defun reftex-bib-sort-author (e1 e2) - (let ((al1 (reftex-get-bib-authors e1)) (al2 (reftex-get-bib-authors e2))) + (let ((al1 (reftex-get-bib-names "author" e1)) + (al2 (reftex-get-bib-names "author" e2))) (while (and al1 al2 (string= (car al1) (car al2))) - (setq al1 (cdr al1) - al2 (cdr al2))) + (pop al1) + (pop al2)) (if (and (stringp (car al1)) - (stringp (car al2))) - (string< (car al1) (car al2)) + (stringp (car al2))) + (string< (car al1) (car al2)) (not (stringp (car al1)))))) (defun reftex-bib-sort-year (e1 e2) @@ -3096,32 +4174,32 @@ (save-restriction (widen) (if (re-search-forward - (concat "@\\w+[{(][ \t\n\r]*" (regexp-quote crkey) "[ \t\n\r]*,") nil t) + (concat "@\\w+[{(][ \t\n\r]*" (regexp-quote crkey) + "[ \t\n\r]*,") nil t) (progn (setq start (match-beginning 0)) (condition-case nil (up-list 1) - ('error nil)) + (error nil)) (reftex-parse-bibtex-entry nil start (point))) nil))))) ;; Parse and format individual entries -(defun reftex-get-bib-authors (entry) - ;; Return a list with the author names in ENTRY - (let (authors) - (setq authors (reftex-get-bib-field "author" entry)) - (if (equal "" authors) - (setq authors (reftex-get-bib-field "editor" entry))) - (while (string-match "\\band\\b[ \t]*" authors) - (setq authors (replace-match "\n" nil t authors))) - (while (string-match "[\\.a-zA-Z\\-]+\\.[ \t]*\\|,.*\\|[{}]+" authors) - (setq authors (replace-match "" nil t authors))) - (while (string-match "^[ \t]+\\|[ \t]+$" authors) - (setq authors (replace-match "" nil t authors))) - (while (string-match "[ \t][ \t]+" authors) - (setq authors (replace-match " " nil t authors))) - (reftex-split "\n" authors))) +(defun reftex-get-bib-names (field entry) + ;; Return a list with the author or editor anmes in ENTRY + (let ((names (reftex-get-bib-field field entry))) + (if (equal "" names) + (setq names (reftex-get-bib-field "editor" entry))) + (while (string-match "\\band\\b[ \t]*" names) + (setq names (replace-match "\n" nil t names))) + (while (string-match "[\\.a-zA-Z\\-]+\\.[ \t]*\\|,.*\\|[{}]+" names) + (setq names (replace-match "" nil t names))) + (while (string-match "^[ \t]+\\|[ \t]+$" names) + (setq names (replace-match "" nil t names))) + (while (string-match "[ \t][ \t]+" names) + (setq names (replace-match " " nil t names))) + (split-string names "\n"))) (defun reftex-parse-bibtex-entry (entry &optional from to) (let (alist key start field) @@ -3137,21 +4215,21 @@ (narrow-to-region from to)) (goto-char (point-min)) - (if (re-search-forward + (if (re-search-forward "@\\(\\w+\\)[ \t\n\r]*[{(][ \t\n\r]*\\([^ \t\n\r,]+\\)" nil t) (setq alist (list - (cons "&type" (downcase (reftex-no-props (match-string 1)))) - (cons "&key" (reftex-no-props (match-string 2)))))) + (cons "&type" (downcase (reftex-match-string 1))) + (cons "&key" (reftex-match-string 2))))) (while (re-search-forward "\\(\\w+\\)[ \t\n\r]*=[ \t\n\r]*" nil t) - (setq key (reftex-no-props (downcase (match-string 1)))) + (setq key (downcase (reftex-match-string 1))) (cond ((= (following-char) ?{) (forward-char 1) (setq start (point)) (condition-case nil (up-list 1) - ('error nil))) + (error nil))) ((= (following-char) ?\") (forward-char 1) (setq start (point)) @@ -3170,8 +4248,8 @@ ;; remove trailing garbage (if (string-match "[ \t}]+$" field) (setq field (replace-match "" nil t field))) - (setq alist (cons (cons key field) alist))) - alist)))) + (push (cons key field) alist)))) + alist)) (defun reftex-get-bib-field (fieldname entry) ;; Extract the field FIELDNAME from an ENTRY @@ -3181,8 +4259,7 @@ (defun reftex-format-bib-entry (entry) ;; Format a BibTeX ENTRY so that it is nice to look at (let* - ((rtn nil) - (auth-list (reftex-get-bib-authors entry)) + ((auth-list (reftex-get-bib-names "author" entry)) (authors (mapconcat '(lambda (x) x) auth-list ", ")) (year (reftex-get-bib-field "year" entry)) (title (reftex-get-bib-field "title" entry)) @@ -3208,33 +4285,19 @@ (equal type "inproceedings")) (concat "in: " (reftex-get-bib-field "booktitle" entry))) (t "")))) - (setq authors - (if (> (length authors) 30) - (concat (substring authors 0 27) "...") - (format "%-30s" authors)) - title - (if (> (length title) 70) - (concat (substring title 0 67) "...") - (format "%-70s" title)) - extra - (if (> (length extra) 40) - (concat (substring extra 0 37) "...") - (format "%-40s" extra))) - (if (reftex-use-fonts) - (progn - (put-text-property 0 (length authors) 'face 'font-lock-keyword-face - authors) - (put-text-property 0 (length title) 'face 'font-lock-comment-face - title) - (put-text-property 0 (length extra) 'face 'font-lock-reference-face - extra))) - (setq rtn (concat key "\n " authors " " year " " extra - "\n " title "\n\n")) - rtn)) + (setq authors (reftex-truncate authors 30 t t)) + (when (reftex-use-fonts) + (put-text-property 0 (length authors) 'face 'font-lock-keyword-face + authors) + (put-text-property 0 (length title) 'face 'font-lock-comment-face + title) + (put-text-property 0 (length extra) 'face 'font-lock-reference-face + extra)) + (concat key "\n " authors " " year " " extra "\n " title "\n\n"))) ;; Make a citation -(defun reftex-citation (&optional arg no-insert) +(defun reftex-citation (&optional no-insert) "Make a citation using BibTeX database files. After asking for a Regular Expression, it scans the buffers with bibtex entries (taken from the \\bibliography command) and offers the @@ -3250,196 +4313,272 @@ When called with just C-u as prefix, enforces rescan of buffer for bibliography statement (e.g. if it was changed)." - (interactive "P") + (interactive) ;; check for recursive edit (reftex-check-recursive-edit) ;; if there is just 1 C-u prefix arg, force to rescan buffer - (if (and current-prefix-arg - (listp current-prefix-arg) - (= 4 (prefix-numeric-value arg))) - (reftex-reset-scanning-information)) - - ;; check if there is already a cite command at point and change cite format + (reftex-access-scan-info current-prefix-arg) + + ;; Call reftex-do-citation, but protected + (unwind-protect + (reftex-do-citation current-prefix-arg no-insert) + (reftex-kill-temporary-buffers))) + +(defun reftex-do-citation (&optional arg no-insert) + ;; This really does the work of reftex-citation. + + ;; Check if there is already a cite command at point and change cite format ;; in order to only add another reference in the same cite command. - (let ((pos (point))) - (search-backward "\\" (point-min) 1) - (if (and (looking-at "\\\\[a-zA-Z]*cite\\*?\\(\\[[^]]*\\]\\)*{\\([^}]*\\)") - (>= (match-end 0) pos) - (>= pos (match-beginning 2))) + (let (key format (macro (car (car (reftex-what-macro t))))) + (if (and (stringp macro) + (string-match "\\`\\\\cite\\|cite\\'" macro)) (progn - (goto-char pos) (cond ((or (not arg) (not (listp arg))) - (setq reftex-cite-format1 + (setq format (concat (if (not (or (= (preceding-char) ?{) (= (preceding-char) ?,))) "," "") - "KEY" + "%l" (if (not (or (= (following-char) ?}) (= (following-char) ?,))) "," "")))) (t - (setq reftex-cite-format1 "KEY")))) - (setq reftex-cite-format1 - (if (symbolp reftex-cite-format) - (symbol-value reftex-cite-format) - reftex-cite-format)) - (goto-char pos))) - - (let* (key entry cnt rtn ins-string re-list re - ;; scan bibtex files - (lazy-lock-minimum-size 1) - (reftex-found-list (reftex-extract-bib-entries - (reftex-get-bibfile-list))) - (found-list-r nil) - (accept-keys - (if (and (listp reftex-cite-format1) - (listp (car reftex-cite-format1))) - (mapcar 'car reftex-cite-format1) - '(?\C-m)))) - (if (not reftex-found-list) + (setq format "%l")))) + ;; else: figure out the correct format + (setq format + (cond + ((stringp reftex-cite-format) reftex-cite-format) + ((and (symbolp reftex-cite-format) + (assq reftex-cite-format reftex-cite-format-builtin)) + (nth 2 (assq reftex-cite-format reftex-cite-format-builtin))) + (t reftex-cite-format))) + (if (listp format) + (save-window-excursion + (with-output-to-temp-buffer "*RefTeX Select*" + (princ "SELECT A CITATION FORMAT\n\n") + (princ + (mapconcat + (function (lambda (x) + (format "[%c] %s %s" (car x) + (if (> (car x) 31) " " "") + (cdr x)))) + format "\n"))) + (setq key (read-char)) + (if (assq key format) + (setq format (cdr (assq key format))) + (error "No citation format associated with key `%c'" key))))) + + (let* (entry cnt rtn ins-string re-list re + ;; scan bibtex files + (reftex-found-list (reftex-extract-bib-entries + (reftex-get-bibfile-list))) + (found-list-r nil)) + (unless reftex-found-list (error "Sorry, no matches found")) - ;; remember where we came from - (setq reftex-call-back-to-this-buffer (current-buffer)) - - ;; offer selection - (save-window-excursion - (switch-to-buffer-other-window "*RefTeX Select*") - (erase-buffer) - (mapcar '(lambda (x) (insert (cdr (assoc "&formatted" x)))) - reftex-found-list) - (if (= 0 (buffer-size)) - (error "Sorry, no matches found")) - (setq truncate-lines t) - (goto-char 1) - (if (catch 'exit - (while t - (setq rtn - (reftex-select-item - nil - (concat - "Select: [n]ext [p]rev [r]estrict [q]uit [?]Help ||" - " RETURN " - (condition-case nil - (mapconcat 'char-to-string accept-keys " ") - (error (error "Illegal reftex-cite-format")))) - "^[^ \t\n]" - "\n\n" - 4 - reftex-citation-help - (cons ?r accept-keys) - nil - 'reftex-bibtex-selection-callback nil)) - (setq key (car rtn) - cnt (cdr rtn)) - (if (not key) (throw 'exit nil)) + ;; remember where we came from + (setq reftex-call-back-to-this-buffer (current-buffer)) + + ;; offer selection + (save-window-excursion + (switch-to-buffer-other-window "*RefTeX Select*") + (erase-buffer) + (reftex-insert-bib-matches reftex-found-list) + (if (= 0 (buffer-size)) + (error "Sorry, no matches found")) + (setq truncate-lines t) + (goto-char 1) + (if (catch 'exit + (while t + (setq rtn + (reftex-select-item + reftex-citation-prompt + "^[^ \t\n\r]" + 4 + reftex-citation-help + '(?r ?a ?g ?\C-m) + nil + 'reftex-bibtex-selection-callback nil)) + (setq key (car rtn) + cnt (nth 1 rtn)) + (unless key (throw 'exit nil)) + (cond + ((eq key ?g) + (setq reftex-found-list + (save-excursion + (set-buffer reftex-call-back-to-this-buffer) + (reftex-extract-bib-entries + (reftex-get-bibfile-list)))) + (erase-buffer) + (reftex-insert-bib-matches reftex-found-list) + (if (= 0 (buffer-size)) + (error "Sorry, no matches found")) + (goto-char 1)) + + ((eq key ?r) + ;; restrict with new regular expression + (setq re-list + (split-string (read-string + "RegExp [ && RegExp...]: " + nil 'reftex-cite-regexp-hist) + "[ \t]*&&[ \t]*")) + (while re-list + (setq re (car re-list) + re-list (cdr re-list)) + (setq found-list-r + (delete "" + (mapcar + '(lambda (x) + (if (string-match + re (cdr (assoc "&entry" x))) + x + "")) + reftex-found-list)))) + (if found-list-r + (setq reftex-found-list found-list-r) + (ding)) + (erase-buffer) + (reftex-insert-bib-matches reftex-found-list) + (goto-char 1)) + ((eq key ?a) + (setq entry 'all) + (throw 'exit t)) + ((or (eq key ?\C-m) + (eq key 'return)) + (if cnt + (setq entry (nth cnt reftex-found-list)) + (setq entry nil)) + (throw 'exit t)) + (t + (ding))))) + (progn + ;; format the entry + (if (eq entry 'all) + (setq ins-string + (mapconcat + '(lambda (entry) + (reftex-format-citation entry format)) + reftex-found-list "\n")) + (setq ins-string (reftex-format-citation entry format)))) + (setq ins-string "") + (message "Quit"))) + (kill-buffer "*RefTeX Select*") + + (unless no-insert + (insert ins-string) + (when (string-match "\\?" ins-string) + (search-backward "?") + (delete-char 1))) + (message "") + + ;; Check if the prefix arg was numeric, and call recursively + (when (and (integerp arg) + (> arg 1) + (re-search-backward + "\\\\\\([a-zA-Z]*cite\\|cite[a-zA-Z]*\\)\\**\\(\\[[^]]*\\]\\)*{\\([^}]*\\)" nil t)) + (goto-char (match-end 0)) + (decf arg) + (reftex-do-citation arg)) + + ;; Return the citation key + (or (eq entry 'all) + (reftex-get-bib-field "&key" entry))))) + +(defun reftex-insert-bib-matches (list) + ;; Insert the bib matches and number them correctly + (let ((cnt -1) tmp) + (mapcar '(lambda (x) + (setq tmp (cdr (assoc "&formatted" x))) + (incf cnt) + (put-text-property 0 (length tmp) 'cnt cnt tmp) + (insert tmp)) + list))) + +(defun reftex-format-names (namelist n) + (interactive) + (let (last (len (length namelist))) + (cond + ((= 1 len) (car namelist)) + ((> len n) (concat (car namelist) (nth 2 reftex-cite-punctuation))) + (t + (setq n (min len n) + last (nth (1- n) namelist)) + (setcdr (nthcdr (- n 2) namelist) nil) + (concat + (mapconcat 'identity namelist (nth 0 reftex-cite-punctuation)) + (nth 1 reftex-cite-punctuation) + last))))) + +(defun reftex-format-citation (entry format) + ;; Format a citation from the info in the BibTeX ENTRY + + (unless (stringp format) (setq format "\\cite{%l}")) + + (if (and reftex-comment-citations + (string-match "%l" reftex-cite-comment-format)) + (error "reftex-cite-comment-format contains illeagal %%l")) + + (while (string-match + "\\(\\`\\|[^%]\\)\\(\\(%\\([0-9]*\\)\\([a-zA-Z]\\)\\)[.,;: ]*\\)" + format) + (let ((n (string-to-int (match-string 4 format))) + (l (string-to-char (match-string 5 format))) + rpl b e) + (save-match-data + (setq rpl (cond - ((equal key ?r) - ;; restrict with new regular expression - (setq re-list - (reftex-split "[ \t]*&&[ \t]*" - (read-string "RegExp [ && RegExp...]: " - nil 'reftex-cite-regexp-hist))) - (while re-list - (setq re (car re-list) - re-list (cdr re-list)) - (setq found-list-r - (delete "" - (mapcar - '(lambda (x) - (if (string-match re - (cdr (assoc "&entry" x))) - x - "")) - reftex-found-list)))) - (if found-list-r - (setq reftex-found-list found-list-r) - (ding)) - (erase-buffer) - (mapcar '(lambda (x) (insert (cdr (assoc "&formatted" x)))) - reftex-found-list) - (goto-char 1)) - ((or (member key accept-keys) - (equal key ?\C-m) - (equal key 'return)) - (setq entry (nth cnt reftex-found-list)) - (throw 'exit t)) - (t - (ding))))) - (progn - ;; format the entry - (if (not (integerp key)) (setq key ?\C-m)) - (setq ins-string (reftex-format-citation entry key))) - (setq ins-string "") - (message "Quit"))) - (kill-buffer "*RefTeX Select*") - - (if (not no-insert) - (insert ins-string)) - (message "") - - ;; Check if the prefix arg was numeric, and call reftex-citation recursively - (if (and (integerp arg) - (> arg 1) - (re-search-backward - "\\\\[a-zA-Z]*cite\\*?\\(\\[[^]]*\\]\\)*{\\([^}]*\\)" nil t)) - (progn - (goto-char (match-end 0)) - (setq arg (1- arg)) - (reftex-citation arg)) - (reftex-kill-temporary-buffers)) - ;; Return the citation key - (reftex-get-bib-field "&key" entry))) - -(defun reftex-format-citation (entry key) - ;; Format a citation from the info in the BibTeX ENTRY - (let* ((cite-key (reftex-get-bib-field "&key" entry)) - (year (reftex-get-bib-field "year" entry)) - (auth-list (reftex-get-bib-authors entry)) - (nauthors (length auth-list)) - format) - - (save-excursion - ;; Find the correct format - (if (and (listp reftex-cite-format1) - (listp (car reftex-cite-format1))) - (if (integerp (car (car reftex-cite-format1))) - (if (assoc key reftex-cite-format1) - (setq format (cdr (assoc key reftex-cite-format1))) - (if (or (equal key ?\C-m) - (equal key 'return)) - (setq format (cdr (car reftex-cite-format1))) - (error "Error in reftex-cite-format"))) - (error "Error in reftex-cite-format")) - (setq format reftex-cite-format1)) - - (if (listp format) - (let ((nn (min nauthors (1- (length format))))) - (while (and (> nn 0) (string= "" (nth nn format))) - (setq nn (1- nn))) - (setq format (nth nn format)))) - (if (stringp format) - (setq format format) - (setq format "\\cite{KEY}")) - - ;; Insert the author names - (while (string-match "\\bAUTHOR\\b" format) - (setq format (replace-match (car auth-list) t t format)) - (setq auth-list (cdr auth-list))) - (while (string-match "\\bKEY\\b" format) - (setq format (replace-match cite-key t t format))) - (while (string-match "\\bYEAR\\b" format) - (setq format (replace-match year t t format))) - format))) - -;; this is slow and not recommended for follow mode + ((= l ?l) (concat + (reftex-get-bib-field "&key" entry) + (if reftex-comment-citations + reftex-cite-comment-format + ""))) + ((= l ?a) (reftex-format-names + (reftex-get-bib-names "author" entry) + (or n 2))) + ((= l ?A) (car (reftex-get-bib-names "author" entry))) + ((= l ?b) (reftex-get-bib-field "booktitle" entry)) + ((= l ?c) (reftex-get-bib-field "chapter" entry)) + ((= l ?d) (reftex-get-bib-field "edition" entry)) + ((= l ?e) (reftex-format-names + (reftex-get-bib-names "editor" entry) + (or n 2))) + ((= l ?E) (car (reftex-get-bib-names "editor" entry))) + ((= l ?h) (reftex-get-bib-field "howpublished" entry)) + ((= l ?i) (reftex-get-bib-field "institution" entry)) + ((= l ?j) (reftex-get-bib-field "journal" entry)) + ((= l ?k) (reftex-get-bib-field "key" entry)) + ((= l ?m) (reftex-get-bib-field "month" entry)) + ((= l ?n) (reftex-get-bib-field "number" entry)) + ((= l ?o) (reftex-get-bib-field "organization" entry)) + ((= l ?p) (reftex-get-bib-field "pages" entry)) + ((= l ?P) (car (split-string + (reftex-get-bib-field "pages" entry) + "[- .]+"))) + ((= l ?s) (reftex-get-bib-field "school" entry)) + ((= l ?u) (reftex-get-bib-field "publisher" entry)) + ((= l ?r) (reftex-get-bib-field "address" entry)) + ((= l ?t) (reftex-get-bib-field "title" entry)) + ((= l ?v) (reftex-get-bib-field "volume" entry)) + ((= l ?y) (reftex-get-bib-field "year" entry))))) + + (if (string= rpl "") + (setq b (match-beginning 2) e (match-end 2)) + (setq b (match-beginning 3) e (match-end 3))) + (setq format (concat (substring format 0 b) rpl (substring format e))))) + (while (string-match "%%" format) + (setq format (replace-match "%" t t format))) + (while (string-match "[ ,.;:]*%<" format) + (setq format (replace-match "" t t format))) + format) + +;; This is slow and not recommended for follow mode (defun reftex-bibtex-selection-callback (cnt) ;; Callback function to be called from the BibTeX selection, in ;; order to display context. This function is relatively slow and not @@ -3468,124 +4607,175 @@ (substitute-command-keys "In unfinished recursive edit. Finish (\\[exit-recursive-edit]) or abort (\\[abort-recursive-edit]).")))) -(defun reftex-select-item (buffer prompt next-re end-re size help-string +(defun reftex-select-item (prompt next-re size help-string event-list &optional offset - call-back cb-flag) -;; Select an item from the buffer BUFFER. Show PROMPT to user, find -;; next item with NEXT-RE regular expression, return on any of the -;; events listed in EVENT-LIST. The function returns the event along -;; with an integer indicating which item was selected. When OFFSET is -;; specified, starts at that item in the list. When CALL-BACK is -;; given, it is a function which is called with the match of the -;; NEXT-RE match and the index of the element. - (let* (key key-sq b e ev cnt cmd - (offset1 (or offset 1))) + call-back cb-flag match-everywhere) +;; Select an item. Show PROMPT to user, find next item with NEXT-RE +;; regular expression, return on any of the events listed in +;; EVENT-LIST. The function returns the event along with an integer +;; indicating which item was selected. When OFFSET is specified, +;; starts at that item in the list. When CALL-BACK is given, it is a +;; function which is called with the index of the element. + + (let* (key key-sq b e ev cnt last-cnt cmd skip-callback + (search-str "") tmp search-start matched forward mini-map last-key + (offset1 (or offset 1)) win1 win2) + + ;; Set up a minibuffer keymap for the search stuff + (setq mini-map (copy-keymap minibuffer-local-map)) + (define-key mini-map "\C-s" + '(lambda () (interactive) (setq forward t) (exit-minibuffer))) + (define-key mini-map "\C-r" + '(lambda () (interactive) (setq forward nil) (exit-minibuffer))) + (define-key mini-map "\C-m" 'exit-minibuffer) + (setq ev (catch 'exit (save-window-excursion - (if buffer - (switch-to-buffer-other-window buffer)) - (if (= 0 (buffer-size)) - (throw 'exit nil)) (setq truncate-lines t) (goto-char 1) - (if (not (re-search-forward next-re nil t offset1)) - (progn ; in case the offset is illegal - (setq offset1 1) - (if (not (re-search-forward next-re nil t offset1)) - (throw 'exit nil)))) + (unless (re-search-forward next-re nil t offset1) + ;; in case the offset is illegal + (setq offset1 1) + (re-search-forward next-re nil t offset1)) (beginning-of-line 1) - (setq cnt (if offset1 (1- offset1) 0)) (while t - (if (and cb-flag call-back) + (setq last-cnt (or cnt last-cnt)) + (setq cnt (get-text-property (point) 'cnt)) + (if (and cnt cb-flag call-back (not skip-callback)) (funcall call-back cnt)) - (setq b (point) - e (save-excursion - (save-match-data - (re-search-forward end-re nil 1)) - (point))) + (setq skip-callback nil) + (if cnt + (setq b (or (previous-single-property-change + (1+ (point)) 'cnt) + (point-min)) + e (or (next-single-property-change + (point) 'cnt) + (point-max))) + (setq b (point) e (point))) (reftex-highlight 1 b e) (if (or (not (pos-visible-in-window-p b)) (not (pos-visible-in-window-p e))) (recenter (/ (window-height) 2))) (setq key-sq (read-key-sequence prompt)) + (setq last-key key) (setq key (car (cond + ((fboundp 'event-to-character) ; XEmacs + (mapcar 'event-to-character key-sq)) ((fboundp 'listify-key-sequence) ; Emacs (listify-key-sequence key-sq)) - ((fboundp 'event-to-character) ; XEmacs - (mapcar 'event-to-character key-sq)) (t (error "Please report this problem to dominik@strw.leidenuniv.nl"))))) (setq cmd (key-binding key-sq)) + (reftex-unhighlight 2) (reftex-unhighlight 0) (cond - ((or (equal key ?n) - (equal key ?\C-i) - (equal cmd 'next-line)) - (if (re-search-forward next-re nil t 2) - (setq cnt (1+ cnt))) + ;; Single line motions + ((or (eq key ?n) + (eq key ?\C-i) + (eq cmd 'next-line)) + (or (eobp) (forward-char 1)) + (re-search-forward next-re nil t 1) (beginning-of-line 1)) - - ((equal cmd 'scroll-up) - (setq cnt (1- cnt)) + ((or (eq key ?p) + (eq cmd 'previous-line)) + (re-search-backward next-re nil t)) + + ;; Page motions + ((eq cmd 'scroll-up) (while (and (pos-visible-in-window-p) - (re-search-forward next-re nil t)) - (setq cnt (1+ cnt))) + (re-search-forward next-re nil t))) (beginning-of-line 1) (recenter 1)) - - ((or (equal key ?p) - (equal cmd 'previous-line)) - (if (re-search-backward next-re nil t) - (setq cnt (1- cnt)))) - - ((equal cmd 'scroll-down) + ((eq cmd 'scroll-down) (while (and (pos-visible-in-window-p) - (re-search-backward next-re nil t)) - (setq cnt (1- cnt))) + (re-search-backward next-re nil t))) (recenter (- (window-height) size 2))) - ((equal key ?q) + ;; Begin and end of buffer + ((eq cmd 'beginning-of-buffer) + (goto-char (point-min)) + (re-search-forward next-re nil t) + (beginning-of-line 1)) + ((eq cmd 'end-of-buffer) + (goto-char (point-max)) + (re-search-backward next-re nil t)) + + ;; Exit + ((eq key ?q) (throw 'exit nil)) - - ((equal key ?\C-g) - (bury-buffer) - (error "Abort")) - - ((or (equal key ?\C-m) - (equal key 'return) - (equal cmd 'newline)) + ((eq key ?\C-g) + (if (or (eq last-key ?\C-s) (eq last-key ?\C-r)) + (ding) + (bury-buffer) + (error "Abort"))) + ((or (eq key ?\C-m) + (eq key 'return) + (eq cmd 'newline)) (throw 'exit 'return)) - - ((or (equal key ?C) ; backward compatibility - (equal key ?f)) + ((memq key event-list) + (throw 'exit key)) + + ;; Callback + ((or (eq key ?C) ; backward compatibility + (eq key ?f)) (setq cb-flag (not cb-flag))) - - ((equal key ?\ ) - (funcall call-back cnt)) - - ((equal key ?\?) - (save-window-excursion - (with-output-to-temp-buffer "*RefTeX Help*" - (princ help-string)) - (setq unread-command-events - (cons - (cond - ((fboundp 'read-event) ; Emacs - (read-event)) - ((fboundp 'next-command-event) ; XEmacs - (next-command-event)) - (t (error "Please report this problem to dominik@strw.leidenuniv.nl"))) - nil))) - (kill-buffer "*RefTeX Help*")) - - ((equal key ?\C-r) - ;; sje - code copied from ispell.el for - ;; performing recursive edit + ((eq key ?\ ) + (if cnt (funcall call-back cnt) (ding))) + + ;; Help + ((eq key ?\?) + (with-output-to-temp-buffer "*RefTeX Help*" + (princ help-string)) + (setq win1 (selected-window) + win2 (get-buffer-window "*RefTeX Help*" t)) + (select-window win2) + (unless (and (pos-visible-in-window-p 1) + (pos-visible-in-window-p (point-max))) + (enlarge-window (1+ (- (count-lines 1 (point-max)) + (window-height))))) + (select-window win1) + (setq skip-callback t)) + + ;; Searching + ((or (setq forward (eq key ?\C-s)) (eq key ?\C-r)) + (if (or (and (not (eq last-key ?\C-s)) + (not (eq last-key ?\C-r))) + (string= search-str "")) + (setq tmp ; get a new string + (read-from-minibuffer + (if (string= search-str "") + "Search: " + (format "Search [%s]:" search-str)) + nil mini-map) + search-str (if (string= tmp "") + search-str tmp))) + (setq search-start (point)) + (and (not (string= search-str "")) + (progn + (while + (and (setq matched + (if forward + (search-forward search-str nil 1) + (search-backward search-str nil 1))) + (or (>= (save-excursion + (goto-char (match-beginning 0)) + (current-column)) + (window-width)) + (not (or (get-text-property (point) 'cnt) + match-everywhere))))) + (if matched + (reftex-highlight 2 (match-beginning 0) + (match-end 0)) + (ding) + (goto-char search-start))))) + + ;; Recursive edit + ((eq key ?e) (set-marker reftex-recursive-edit-marker (point)) (unwind-protect (progn @@ -3596,20 +4786,18 @@ (substitute-command-keys "Recursive edit. Return to selection with \\[exit-recursive-edit]")) (recursive-edit))) - (if (not (equal (marker-buffer - reftex-recursive-edit-marker) - (current-buffer))) - (error - "Cannot continue RefTeX from this buffer.")) + (unless (equal (marker-buffer + reftex-recursive-edit-marker) + (current-buffer)) + (error "Cannot continue RefTeX from this buffer.")) (goto-char reftex-recursive-edit-marker)) (set-marker reftex-recursive-edit-marker nil))) - ((member key event-list) - (throw 'exit key)) (t (ding))))))) + (and (get-buffer "*RefTeX Help*") (kill-buffer "*RefTeX Help*")) (message "") - (cons ev cnt))) + (list ev cnt last-cnt))) ;;; =========================================================================== ;;; @@ -3622,56 +4810,89 @@ If there is no such macro at point, search forward to find one. When you call this function several times in direct successtion, point will move to view subsequent cross references further down in the buffer. +To cope with the plethora of variations in packages, this function +assumes any macro either starting with ending in `ref' or `cite' to contain +cross references. With argument, actually select the window showing the cross reference." (interactive "P") ;; See where we are. - (let* ((pos (point)) - (re "\\\\[a-z]*\\(cite\\|ref\\)\\(\\[[^{}]*\\]\\)?{\\([^}]+\\)}") - (my-window (get-buffer-window (current-buffer))) - pop-window cmd args macro label key-start point) - - (if (save-excursion - (forward-char 1) - (and (search-backward "\\" nil t) - (looking-at re) - (< pos (match-end 0)))) - (setq macro (match-string 1) - key-start (match-beginning 3))) + (let* ((re "\\\\\\([a-z]*\\(cite\\|ref\\)\\|\\(cite\\|ref\\)[a-z]*\\)\\**\\(\\[[^{}]*\\]\\)?{") + (macro (car (car (reftex-what-macro t)))) + (this-word (reftex-this-word "*a-zA-Z\\\\")) + (my-window (selected-window)) + pop-window cmd args point) + + (if (and macro + (string-match "\\`\\\\cite\\|\\`\\\\ref\\|cite\\'\\|ref\\'" + macro)) + (and (setq macro (match-string 0 macro)) + (string-match "\\`\\\\" macro) + (setq macro (substring macro 1))) + (setq macro nil)) (if (and macro (eq last-command this-command)) - (if (and (string= macro "cite") - (skip-chars-forward "^}, \t\n\r") - (= (following-char) ?,)) - (setq key-start (1+ (point))) - (setq macro nil))) - - (if (not macro) - (if (re-search-forward re nil t) - (setq macro (match-string 1) - key-start (match-beginning 3)) - (error "No further cross references in buffer"))) - - (goto-char key-start) + (if (string= macro "cite") + (progn + (skip-chars-forward "^},%") + (while (and (eq (following-char) ?%) + (or (beginning-of-line 2) t) + (skip-chars-forward " \t\n\r"))) + (skip-chars-forward ",") + (if (eq (following-char) ?}) + (setq macro nil))) + (setq macro nil))) + + (if (and (not macro) + (or (not (string-match "\\`\\\\" this-word)) + (eq (following-char) ?\\) + (search-backward "\\" nil t) + t)) + (if (interactive-p) + ;; Only move far if this function was called directly + (and (re-search-forward re nil t) + (setq macro (or (match-string 2) (match-string 3)))) + ;; The macro needs to be at point + (and (looking-at re) + (setq macro (or (match-string 2) (match-string 3))) + (goto-char (match-end 0))))) + + + (unless macro + (error "No cross reference to display")) ;; Ensure access to scanning info (reftex-access-scan-info) - (cond + (cond ((string= macro "cite") (setq cmd 'reftex-pop-to-bibtex-entry - args (list - (reftex-no-props (reftex-this-word "^{},")) - (reftex-get-bibfile-list) nil t))) + args (list + (reftex-this-word "^{},%\n\r") + (reftex-get-bibfile-list) nil t))) ((string= macro "ref") - (let ((label (reftex-no-props (reftex-this-word "^{}"))) - (entry (assoc label (symbol-value reftex-list-of-labels-symbol)))) + (let* ((label (reftex-this-word "^{}%\n\r")) + (xr-data (assoc 'xr (symbol-value reftex-docstruct-symbol))) + (xr-re (nth 2 xr-data)) + (entry (assoc label (symbol-value reftex-docstruct-symbol)))) + (if (and (not entry) (string-match xr-re label)) + ;; Label is defined in external document + (save-excursion + (save-match-data + (set-buffer + (or (reftex-get-file-buffer-force + (cdr (assoc (match-string 1 label) (nth 1 xr-data)))) + (error "Problem with external label %s" label)))) + (setq label (substring label (match-end 1))) + (reftex-access-scan-info) + (setq entry + (assoc label (symbol-value reftex-docstruct-symbol))))) (if entry (setq cmd 'reftex-pop-to-label - args (list label (list (nth 3 entry)) nil t)) - (error "Label %s not known - reparse document might help" label)))) - (t (error "This should not happen"))) + args (list label (list (nth 3 entry)) nil t)) + (error "Label %s not known - reparse document might help" label)))) + (t (error "This should not happen (reftex-view-crossref)"))) (setq point (point)) (apply cmd args) (setq pop-window (selected-window)) @@ -3688,6 +4909,7 @@ With argument, actually select the window showing the cross reference." (interactive "e") (mouse-set-point ev) + (setq last-command 'self-insert-command) ;; make sure we do not move! (reftex-view-crossref current-prefix-arg)) ;;; =========================================================================== @@ -3716,7 +4938,7 @@ (let ((bound (or bound (save-excursion (re-search-backward reftex-section-regexp nil 1) (point)))) - pos cmd-list cmd) + pos cmd-list cmd cnt cnt-opt entry) (save-restriction (save-excursion (narrow-to-region (max 1 bound) (point-max)) @@ -3724,22 +4946,32 @@ (while (condition-case nil (progn (up-list -1) t) (error nil)) + (setq cnt 1 cnt-opt 0) ;; move back over any touching sexps - (while (or (= (preceding-char) ?\]) - (= (preceding-char) ?\})) - (backward-sexp)) + (while (and (reftex-move-to-previous-arg bound) + (condition-case nil + (progn (backward-sexp) t) + (error nil))) + (if (eq (following-char) ?\[) (incf cnt-opt)) + (incf cnt)) (setq pos (point)) - (if (and (or (= (following-char) ?\[) - (= (following-char) ?\{)) - (and (re-search-backward "\\(\\\\[a-zA-Z]+\\)" nil t) - (= (match-end 0) pos))) - (progn - (setq cmd (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (if (eq t which) - (setq cmd-list (cons (cons cmd (point)) cmd-list)) - (if (member cmd which) - (throw 'exit (cons cmd (point))))))) + (when (and (or (= (following-char) ?\[) + (= (following-char) ?\{)) + (re-search-backward "\\\\[*a-zA-Z]+\\=" nil t)) + (setq cmd (reftex-match-string 0)) + (when (looking-at "\\\\begin{[^}]*}") + (setq cmd (reftex-match-string 0) + cnt (1- cnt))) + ;; This does ignore optional arguments. Very hard to fix. + (when (setq entry (assoc cmd reftex-env-or-mac-alist)) + (if (> cnt (or (nth 4 entry) 100)) + (setq cmd nil))) + (cond + ((null cmd)) + ((eq t which) + (push (cons cmd (point)) cmd-list)) + ((member cmd which) + (throw 'exit (cons cmd (point)))))) (goto-char pos))) (nreverse cmd-list))))) @@ -3774,7 +5006,7 @@ ((member env end-list) (setq end-list (delete env end-list))) ((eq t which) - (setq env-list (cons (cons env (point)) env-list))) + (push (cons env (point)) env-list)) ((member env which) (throw 'exit (cons env (point)))))) (nreverse env-list))))) @@ -3785,7 +5017,7 @@ (let ((pos (point))) (save-excursion (re-search-backward "[^ \t\n\r]" (point-min) 1) - (setq pos (1+ (point))) + (setq pos (min (1+ (point)) (point-max))) (if (re-search-backward "[^a-zA-Z0-9\\\.:]" (point-min) 1) (forward-char 1)) (buffer-substring-no-properties (point) pos)))) @@ -3800,22 +5032,169 @@ (set-text-properties 0 (length string) nil string)) string) -(defun reftex-split (regexp string) - ;; Split like perl - (let ((start 0) list) - (while (string-match regexp string start) - (setq list (cons (substring string start (match-beginning 0)) list)) - (setq start (match-end 0))) - (setq list (nreverse (cons (substring string start) list))))) - -(defun reftex-allow-for-ctrl-m (string) - ;; convert STRING into a regexp, allowing ^M for \n +(defun reftex-match-string (n) + ;; Match string without properties + (when (match-beginning n) + (buffer-substring-no-properties (match-beginning n) (match-end n)))) + +(defun reftex-this-word (&optional class) + ;; Grab the word around point. + (setq class (or class "-a-zA-Z0-9:_/.*;|")) + (save-excursion + (buffer-substring-no-properties + (progn (skip-chars-backward class) (point)) + (progn (skip-chars-forward class) (point))))) + +(defvar enable-multibyte-characters) +(defun reftex-truncate (string ncols &optional ellipses padding) + ;; Truncate a string to NCHAR characters. + ;; Works fast with ASCII and correctly with Mule characters. + ;; When ELLIPSES is non-nil, put three dots at the end of the string. + (setq string + (cond + ((and (boundp 'enable-multibyte-characters) + enable-multibyte-characters) + (if (<= (string-width string) ncols) + string + (if ellipses + (concat (truncate-string-to-width string (- ncols 3)) "...") + (truncate-string-to-width string ncols)))) + (t + (if (<= (length string) ncols) + string + (if ellipses + (concat (substring string 0 (- ncols 3)) "...") + (substring string 0 ncols)))))) + (if padding + (format (format "%%-%ds" ncols) string) + string)) + +(defun reftex-nearest-match (regexp &optional pos) + ;; Find the nearest match of REGEXP. Set the match data. + ;; If POS is given, calculate distances relative to it. + ;; Return nil if there is no match. + (let ((start (point)) (pos (or pos (point))) match1 match2 match) + (goto-char start) + (when (re-search-backward regexp nil t) + (setq match1 (match-data))) + (goto-char start) + (when (re-search-forward regexp nil t) + (setq match2 (match-data))) + (goto-char start) + (setq match + (cond + ((not match1) match2) + ((not match2) match1) + ((< (abs (- pos (car match1))) (abs (- pos (car match2)))) match1) + (t match2))) + (if match (progn (store-match-data match) t) nil))) + +(defun reftex-auto-mode-alist () + ;; Return an `auto-mode-alist' with only the .gz (etc) thingies. + ;; Stolen from gnus nnheader. + (let ((alist auto-mode-alist) + out) + (while alist + (when (listp (cdr (car alist))) + (push (car alist) out)) + (pop alist)) + (nreverse out))) + +(defun reftex-access-search-path (which &optional recurse file) + ;; Access path from environment variables. WHICH is either "tex" or "bib". + ;; When RECURSE is t, expand recursive paths, ending in double slash + ;; FILE is just for the message. + (let* ((pathvar (intern (concat "reftex-" which "-path"))) + (status (get pathvar 'status))) + (cond + ((eq status 'recursed)) + ((and status (null recurse))) + ((null status) + (let ((env-vars (if (equal which "tex") (list "TEXINPUTS") + reftex-bibpath-environment-variables))) + (set pathvar (reftex-parse-colon-path + (mapconcat '(lambda(x) (or (getenv x) "")) + env-vars path-separator)))) + (put pathvar 'status 'split)) + ((and (eq 'split status) recurse) + (message "Expanding search path to find %s file: %s ..." which file) + (set pathvar (reftex-expand-path (symbol-value pathvar))) + (put pathvar 'status 'recursed))))) + +(defun reftex-find-file-on-path (file path) + ;; Find FILE along the directory list PATH. + (catch 'exit + (when (file-name-absolute-p file) + (if (file-exists-p file) + (throw 'exit file) + (throw 'exit nil))) + (let* ((thepath path) file1 dir + (doubleslash (concat "/" "/"))) + (while (setq dir (pop thepath)) + (when (string= (substring dir -2) doubleslash) + (setq dir (substring dir 0 -1))) + (setq file1 (expand-file-name file dir)) + (if (file-exists-p file1) + (throw 'exit file1))) + ;; No such file + nil))) + +(defun reftex-parse-colon-path (path) + ;; Like parse-colon-parse, but // or /~ have no effects. + (mapcar 'file-name-as-directory + (delete "" (split-string path (concat path-separator "+"))))) + +(defun reftex-expand-path (path) + ;; Expand parts of path ending in a double slash + (let (path1 dir dirs (doubleslash (concat "/" "/"))) + (while (setq dir (pop path)) + (if (string= (substring dir -2) doubleslash) + (progn + (setq dir (substring dir 0 -1)) + (setq dirs (reftex-recursive-directory-list dir)) + (setq path1 (append dirs path1))) + (push dir path1))) + (nreverse path1))) + +(defun reftex-recursive-directory-list (dir) + (let ((path (list dir)) dirs path1) + (while (setq dir (pop path)) + (setq dirs + (delete nil + (mapcar (function + (lambda (x) + (if (and (file-directory-p x) + (not (string-match "/\\.+\\'" x))) + (file-name-as-directory x) + nil))) + (directory-files dir t)))) + (setq path (append dirs path)) + (push dir path1)) + path1)) + +(defun reftex-make-regexp-allow-for-ctrl-m (string) + ;; convert STRING into a regexp, allowing ^M for \n and vice versa (let ((start -2)) (setq string (regexp-quote string)) (while (setq start (string-match "[\n\r]" string (+ 3 start))) (setq string (replace-match "[\n\r]" nil t string))) string)) +(defun reftex-make-desparate-section-regexp (old) + ;; Return a regexp which will still match a section statement even if + ;; x-symbol or isotex or the like have been at work in the mean time. + (let* ((n (1+ (string-match "[[{]" old))) + (new (regexp-quote (substring old 0 (1+ (string-match "[[{]" old))))) + (old (substring old n))) + (while (string-match + "\\([\r\n]\\)\\|\\(\\`\\|[ \t\n\r]\\)\\([a-zA-Z0-9]+\\)\\([ \t\n\r]\\|}\\'\\)" + old) + (if (match-beginning 1) + (setq new (concat new "[^\n\r]*[\n\r]")) + (setq new (concat new "[^\n\r]*" (match-string 3 old)))) + (setq old (substring old (match-end 0)))) + new)) + (defun reftex-delete-list (elt-list list) ;; like delete, but with a list of things to delete ;; (original code from Rory Molinari) @@ -3827,44 +5206,76 @@ (defun reftex-get-buffer-visiting (file) ;; return a buffer visiting FILE (cond - ((fboundp 'find-buffer-visiting) ; Emacs - (find-buffer-visiting file)) ((boundp 'find-file-compare-truenames) ; XEmacs (let ((find-file-compare-truenames t)) (get-file-buffer file))) + ((fboundp 'find-buffer-visiting) ; Emacs + (find-buffer-visiting file)) (t (error "Please report this problem to dominik@strw.leidenuniv.nl")))) (defun reftex-get-file-buffer-force (file &optional mark-to-kill) ;; Return a buffer visiting file. Make one, if necessary. - ;; If neither such a buffer no the file exist, return nil. - ;; If MARK-TO-KILL in non-nil, put any new buffers into the kill list." + ;; If neither such a buffer nor the file exist, return nil. + ;; If MARK-TO-KILL is t and there is no live buffer, load the file with + ;; initializations according to `reftex-initialize-temporary-buffers', + ;; and mark the buffer to be killed after use. (let ((buf (reftex-get-buffer-visiting file))) - (cond - (buf buf) - ((file-exists-p file) - (setq buf (find-file-noselect file)) - (if mark-to-kill - (add-to-list 'reftex-buffers-to-kill buf)) - buf) - (t nil)))) + + (cond (buf + ;; We have it already as a buffer - just return it + buf) + + ((file-readable-p file) + ;; At least there is such a file and we can read it. + + (if (or (not mark-to-kill) + (eq t reftex-initialize-temporary-buffers)) + + ;; Visit the file with full magic + (setq buf (find-file-noselect file)) + + ;; Else: Visit the file just briefly, without or + ;; with limited Magic + + ;; The magic goes away + (let ((format-alist nil) + (auto-mode-alist (reftex-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (after-insert-file-functions nil)) + (setq buf (find-file-noselect file))) + + ;; Is there a hook to run? + (when (listp reftex-initialize-temporary-buffers) + (save-excursion + (set-buffer buf) + (run-hooks 'reftex-initialize-temporary-buffers)))) + + ;; Lets see if we got a license to kill :-| + (and mark-to-kill + (add-to-list 'reftex-buffers-to-kill buf)) + + ;; Return the new buffer + buf) + + ;; If no such file exists, return nil + (t nil)))) (defun reftex-splice-symbols-into-list (list alist) ;; Splice the association in ALIST of any symbols in LIST into the list. ;; Return new list. (let (rtn tmp) (while list - (while (and (not (null (car list))) - (symbolp (car list))) + (while (and (not (null (car list))) ;; keep list elements nil + (symbolp (car list))) (setq tmp (car list)) (cond ((assoc tmp alist) - (setq list (append (cdr (cdr (assoc tmp alist))) (cdr list)))) + (setq list (append (nth 2 (assoc tmp alist)) (cdr list)))) (t (error "Cannot treat symbol %s in reftex-label-alist" (symbol-name tmp))))) - (setq rtn (cons (car list) rtn) - list (cdr list))) + (push (pop list) rtn)) (nreverse rtn))) (defun reftex-uniquify (alist &optional keep-list) @@ -3872,36 +5283,44 @@ ;; Elements of KEEP-LIST are not removed even if duplicate. (let (new elm) (while alist - (setq elm (car alist) - alist (cdr alist)) + (setq elm (pop alist)) (if (or (member (car elm) keep-list) - (not (assoc (car elm) new))) - (setq new (cons elm new)))) - (setq new (nreverse new)) - new)) + (not (assoc (car elm) new))) + (push elm new))) + (nreverse new))) (defun reftex-use-fonts () ;; Return t if we can and want to use fonts. (and window-system reftex-use-fonts - (boundp 'font-lock-keyword-face))) + (featurep 'font-lock))) + +(defun reftex-refontify () + ;; Return t if we need to refontify context + (and (reftex-use-fonts) + (or (eq t reftex-refontify-context) + (and (eq 1 reftex-refontify-context) + (or (featurep 'x-symbol)))))) ;; Highlighting uses overlays. If this is for XEmacs, we need to load ;; the overlay library, available in version 19.15 (and (not (fboundp 'make-overlay)) (condition-case nil (require 'overlay) - ('error + (error (error "RefTeX needs overlay emulation (available in XEmacs 19.15)")))) ;; We keep a vector with several different overlays to do our highlighting. -(defvar reftex-highlight-overlays [nil nil]) +(defvar reftex-highlight-overlays [nil nil nil]) ;; Initialize the overlays (aset reftex-highlight-overlays 0 (make-overlay 1 1)) (overlay-put (aref reftex-highlight-overlays 0) 'face 'highlight) (aset reftex-highlight-overlays 1 (make-overlay 1 1)) (overlay-put (aref reftex-highlight-overlays 1) 'face 'highlight) +(aset reftex-highlight-overlays 2 (make-overlay 1 1)) +(overlay-put (aref reftex-highlight-overlays 2) 'face + (if (string-match "XEmacs" emacs-version) 'zmacs-region 'region)) ;; Two functions for activating and deactivation highlight overlays (defun reftex-highlight (index begin end &optional buffer) @@ -3919,137 +5338,49 @@ ;;; --------------------------------------------------------------------------- ;;; -;;; Cursor position after insertion of forms - -(defun reftex-position-cursor () - ;; Search back to question mark, delete it, leave point there - (if (search-backward "\?" (- (point) 100) t) - (delete-char 1))) - -(defun reftex-item () - "Insert an \\item and provide a label if the environments supports that." - (interactive) - (let ((env (car - (reftex-what-environment '("itemize" "enumerate" "eqnarray"))))) - - (if (and env (not (bolp))) (newline)) - - (cond - - ((string= env "eqnarray") - (if (not (bolp)) - (newline)) - (reftex-label env) - (insert "\n & & ") - (beginning-of-line 1)) - - ((string= env "itemize") - (newline) - (insert "\\item ")) - - ((string= env "enumerate") - (newline) - (insert "\\item") - (reftex-label env) - (insert " ")) - (t - (error "\\item command does not make sense here..."))))) - -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- -;;; -;;; Data Section: Definition of large constants - - -(defconst reftex-label-alist-builtin - '( - (LaTeX - "LaTeX default environments" - ("section" ?s "sec:" "~\\ref{%s}" t - ("Part" "Chapter" "Chap." "Section" "Sec." "Sect." "Paragraph" "Par." - "\\S" "Teil" "Kapitel" "Kap." "Abschnitt" )) - - ("enumerate" ?n "item:" "~\\ref{%s}" "\\\\item\\(\\[[^]]*\\]\\)?" - ("Item" "Punkt")) - - ("equation" ?e "eq:" "~(\\ref{%s})" t - ("Equation" "Eq." "Eqn." "Gleichung" "Gl.")) - ("eqnarray" ?e "eq:" nil "\\\\begin{eqnarray}\\|\\\\\\\\") - - ("figure" ?f "fig:" "~\\ref{%s}" "\\\\caption\\(\\[[^]]*\\]\\)?{" - ("Figure" "Fig." "Abbildung" "Abb.")) - ("figure*" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - - ("table" ?t "tab:" "~\\ref{%s}" "\\\\caption\\(\\[[^]]*\\]\\)?{" - ("Table" "Tab." "Tabelle")) - ("table*" ?t nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - - ("any" ?\ " " "\\ref{%s}" nil)) - - (Sideways - "Sidewaysfigure and sidewaystable" - ("sidewaysfigure" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - ("sidewaystable" ?t nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{")) - - (Subfigure - "Subfigure environments and macro" - ("subfigure" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - ("subfigure*" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - ("\\subfigure" ?f nil nil "\\\\subfigure[[{]")) - - (AMSTeX - "AMS-LaTeX: amsmath package environents" - ("align" ?e "eq:" "~\\eqref{%s}" "\\\\begin{align}\\|\\\\\\\\") - ("gather" ?e "eq:" nil "\\\\begin{gather}\\|\\\\\\\\") - ("multline" ?e "eq:" nil t) - ("flalign" ?e "eq:" nil "\\\\begin{flalign}\\|\\\\\\\\") - ("alignat" ?e "eq:" nil "\\\\begin{alignat}{[0-9]*}\\|\\\\\\\\")) - - (AASTeX - "AAS deluxetable environment" - ("deluxetable" ?t "tab:" nil "\\\\caption{"))) - "The default label environment descriptions.") - -;;; --------------------------------------------------------------------------- -;;; ;;; Functions to compile the tables, reset the mode etc. (defun reftex-reset-mode () "Reset RefTeX Mode. Required to implement changes to some list variables. This function will compile the information in `reftex-label-alist' and similar variables. It is called when RefTeX is first used, and after changes to -these variables via `reftex-add-to-label-alist'." +these variables." (interactive) ;; Record that we have done this (setq reftex-tables-dirty nil) + (setq reftex-memory + (list reftex-label-alist reftex-label-alist-external-add-ons + reftex-default-label-alist-entries)) + + ;; Reset the file search path variables + (put 'reftex-tex-path 'status nil) + (put 'reftex-bib-path 'status nil) ;; Kill temporary buffers associated with RefTeX - just in case they ;; were not cleaned up properly - (let ((buffer-list '("*reftex-master.tex*" "*RefTeX Help*" "*RefTeX Select*" - "*Duplicate Labels*" "*toc*" "*RefTeX-scratch*"))) - (while buffer-list - (if (get-buffer (car buffer-list)) - (kill-buffer (car buffer-list))) - (setq buffer-list (cdr buffer-list)))) - - ;; Plug functions into AUCTeX if the user option says so + (let ((buffer-list '("*RefTeX Master*" "*RefTeX Help*" "*RefTeX Select*" + "*Duplicate Labels*" "*toc*" "*RefTeX-scratch*")) + buf) + (while (setq buf (pop buffer-list)) + (if (get-buffer buf) + (kill-buffer buf)))) + + ;; Make sure the current document will be rescanned soon. + (reftex-reset-scanning-information) + + ;; Plug functions into AUCTeX if the user option says so. (reftex-plug-into-AUCTeX) - ;; To update buffer-local variables - (hack-local-variables) (message "updating internal tables...") (reftex-compute-ref-cite-tables) - (message "updating internal tables... done") - (reftex-reset-scanning-information)) + (message "updating internal tables... done")) (defun reftex-reset-scanning-information () "Reset the symbols containing information from buffer scanning. This enforces rescanning the buffer on next use." - (if (and (string= reftex-last-toc-master (reftex-TeX-master-file)) - (get-buffer "*toc*")) - (kill-buffer "*toc*")) + (if (string= reftex-last-toc-master (reftex-TeX-master-file)) + (reftex-empty-toc-buffer)) (let ((symlist reftex-multifile-symbols) symbol) (while symlist @@ -4066,14 +5397,15 @@ ;; Compile information in reftex-label-alist (let ((tmp (reftex-uniquify (reftex-splice-symbols-into-list - (append - reftex-label-alist - reftex-label-alist-external-add-ons - reftex-default-label-alist-entries) - reftex-label-alist-builtin) - '(nil))) - entry env-or-mac typekeychar typekey prefix regexp - fmt wordlist cmd qh-list) + (append + reftex-label-alist + reftex-label-alist-external-add-ons + reftex-default-label-alist-entries) + reftex-label-alist-builtin) + '(nil))) + entry env-or-mac typekeychar typekey prefix context word + fmt reffmt labelfmt wordlist qh-list macros-with-labels + nargs nlabel opt-args cell sum) (setq reftex-words-to-typekey-alist nil reftex-typekey-list nil @@ -4084,65 +5416,86 @@ reftex-label-mac-list nil) (while tmp (catch 'next-entry - (setq entry (car tmp) - env-or-mac (car entry) - entry (cdr entry) - tmp (cdr tmp)) - (if (null env-or-mac) - (setq env-or-mac "")) - (if (stringp (car entry)) - ;; This is before version 2.00 - convert entry to new format - ;; This is just to keep old users happy - (setq entry (cons (string-to-char (car entry)) - (cons (concat (car entry) ":") - (cdr entry))))) - (setq typekeychar (nth 0 entry) - typekey (char-to-string typekeychar) - prefix (nth 1 entry) - fmt (nth 2 entry) - regexp (nth 3 entry) - wordlist (nth 4 entry)) - (if (stringp wordlist) - ;; This is before version 2.04 - convert to new format - (setq wordlist (nthcdr 4 entry))) - (if typekey - (add-to-list 'reftex-typekey-list typekey)) - (if (and typekey prefix) - (add-to-list 'reftex-typekey-to-prefix-alist (cons typekey prefix))) - (cond - ((string-match "\\`\\\\" env-or-mac) - ;; It's a macro - (add-to-list 'reftex-label-mac-list env-or-mac)) - (t - (or (string= env-or-mac "any") - (string= env-or-mac "") - (add-to-list 'reftex-label-env-list env-or-mac)))) - (and fmt - (not (assoc typekey reftex-typekey-to-format-alist)) - (setq reftex-typekey-to-format-alist - (cons (cons typekey fmt) - reftex-typekey-to-format-alist))) - (and (not (string= env-or-mac "any")) - (not (string= env-or-mac "")) - (not (assoc env-or-mac reftex-env-or-mac-alist)) - (setq reftex-env-or-mac-alist - (cons (list env-or-mac typekey regexp) - reftex-env-or-mac-alist))) - (while (and wordlist (stringp (car wordlist))) - (or (assoc (car wordlist) reftex-words-to-typekey-alist) - (setq reftex-words-to-typekey-alist - (cons (cons (downcase (car wordlist)) typekey) - reftex-words-to-typekey-alist))) - (setq wordlist (cdr wordlist))) - (cond - ((string= "" env-or-mac) nil) - ((assoc typekey qh-list) - (setcdr (assoc typekey qh-list) - (concat (cdr (assoc typekey qh-list)) " " env-or-mac))) - (t - (setq qh-list (cons (cons typekey env-or-mac) qh-list)))))) - - (setq qh-list (nreverse qh-list)) + (setq entry (car tmp) + env-or-mac (car entry) + entry (cdr entry) + tmp (cdr tmp)) + (if (null env-or-mac) + (setq env-or-mac "")) + (if (stringp (car entry)) + ;; This is before version 2.00 - convert entry to new format + ;; This is just to keep old users happy + (setq entry (cons (string-to-char (car entry)) + (cons (concat (car entry) ":") + (cdr entry))))) + (setq typekeychar (nth 0 entry) + typekey (char-to-string typekeychar) + prefix (nth 1 entry) + fmt (nth 2 entry) + context (nth 3 entry) + wordlist (nth 4 entry)) + (if (stringp wordlist) + ;; This is before version 2.04 - convert to new format + (setq wordlist (nthcdr 4 entry))) + + (if (and (stringp fmt) + (string-match "@" fmt)) + ;; special syntax for specifying a label format + (setq fmt (split-string fmt "@+")) + (setq fmt (list "\\label{%s}" fmt))) + (setq labelfmt (car fmt) + reffmt (nth 1 fmt)) + (if typekey + (add-to-list 'reftex-typekey-list typekey)) + (if (and typekey prefix + (not (assoc typekey reftex-typekey-to-prefix-alist))) + (add-to-list 'reftex-typekey-to-prefix-alist + (cons typekey prefix))) + (cond + ((string-match "\\`\\\\" env-or-mac) + ;; It's a macro + (let ((result (reftex-parse-args env-or-mac))) + (setq env-or-mac (or (first result) env-or-mac) + nargs (second result) + nlabel (third result) + opt-args (fourth result)) + (if nlabel (add-to-list 'macros-with-labels env-or-mac))) + (add-to-list 'reftex-label-mac-list env-or-mac)) + (t + (setq nargs nil nlabel nil opt-args nil) + (cond ((string= env-or-mac "any")) + ((string= env-or-mac "")) + ((string= env-or-mac "section")) + (t + (add-to-list 'reftex-label-env-list env-or-mac) + ;; Translate some special context cases + (when (assq context reftex-default-context-regexps) + (setq context + (format + (cdr (assq context reftex-default-context-regexps)) + (regexp-quote env-or-mac)))))))) + (and reffmt + (not (assoc typekey reftex-typekey-to-format-alist)) + (push (cons typekey reffmt) reftex-typekey-to-format-alist)) + (and (not (string= env-or-mac "any")) + (not (string= env-or-mac "")) + (not (assoc env-or-mac reftex-env-or-mac-alist)) + (push (list env-or-mac typekey context labelfmt + nargs nlabel opt-args) + reftex-env-or-mac-alist)) + (while (and (setq word (pop wordlist)) + (stringp word)) + (setq word (downcase word)) + (or (assoc word reftex-words-to-typekey-alist) + (push (cons word typekey) reftex-words-to-typekey-alist))) + (cond + ((string= "" env-or-mac) nil) + ((setq cell (assoc typekey qh-list)) + (push env-or-mac (cdr cell))) + (t + (push (list typekey env-or-mac) qh-list))))) + + (setq qh-list (sort qh-list '(lambda (x1 x2) (string< (car x1) (car x2))))) (setq reftex-typekey-to-prefix-alist (nreverse reftex-typekey-to-prefix-alist)) (setq reftex-type-query-prompt @@ -4153,14 +5506,51 @@ " (?=Help)")) (setq reftex-type-query-help (concat "SELECT A LABEL TYPE:\n--------------------\n" - (mapconcat '(lambda(x) - (format " [%s] %s" - (car x) (cdr x))) - qh-list "\n"))))) + (mapconcat + '(lambda(x) + (setq sum 0) + (format " [%s] %s" + (car x) + (mapconcat + '(lambda(x) + (setq sum (+ sum (length x))) + (if (< sum 60) + x + (setq sum 0) + (concat "\n " x))) + (cdr x) " "))) + qh-list "\n"))) + + ;; Calculate the regular expressions + (let ((label-re "\\\\label{\\([^}]*\\)}") + (include-re "\\(\\`\\|[\n\r]\\)[ \t]*\\\\\\(include\\|input\\)[{ \t]+\\([^} \t\n\r]+\\)") + (section-re + (concat "\\(\\`\\|[\n\r]\\)[ \t]*\\\\\\(" + (mapconcat 'car reftex-section-levels "\\|") + "\\)\\*?\\(\\[[^]]*\\]\\)?{")) + (macro-re + (if macros-with-labels + (concat "\\(" + (mapconcat 'regexp-quote macros-with-labels "\\|") + "\\)[[{]") + "")) + (find-label-re-format + (concat "\\(" + (mapconcat 'regexp-quote (append '("\\label") + macros-with-labels) "\\|") + "\\)\\([[{][^]}]*[]}]\\)*[[{]\\(%s\\)[]}]"))) + (setq reftex-section-regexp section-re + reftex-section-or-include-regexp + (concat section-re "\\|" include-re) + reftex-everything-regexp + (concat label-re "\\|" section-re "\\|" include-re + (if macros-with-labels "\\|" "") macro-re) + reftex-find-label-regexp-format find-label-re-format + reftex-find-label-regexp-format2 + "\\([]} \t\n\r]\\)\\([[{]\\)\\(%s\\)[]}]")))) ;;; Keybindings -------------------------------------------------------------- -(define-key reftex-mode-map "\C-c-" 'reftex-item) (define-key reftex-mode-map "\C-c=" 'reftex-toc) (define-key reftex-mode-map "\C-c(" 'reftex-label) (define-key reftex-mode-map "\C-c)" 'reftex-reference) @@ -4184,30 +5574,72 @@ (require 'easymenu) -(easy-menu-define +(easy-menu-define reftex-mode-menu reftex-mode-map "Menu used in RefTeX mode" - '("Ref" - ["Table of Contents" reftex-toc t] + `("Ref" + ["Table of Contents" reftex-toc t] "----" - ["\\label" reftex-label t] - ["\\ref" reftex-reference t] - ["\\cite" reftex-citation t] - ["View crossref" reftex-view-crossref t] + ["\\label" reftex-label t] + ["\\ref" reftex-reference t] + ["\\cite" reftex-citation t] + ["View Crossref" reftex-view-crossref t] "----" - ("Search and Replace" - ["Search whole document" reftex-search-document t] - ["Replace in document" reftex-query-replace-document t] - ["Grep on document" reftex-grep-document t] + ("Parse Document" + ["Only this File" reftex-parse-one t] + ["Entire Document" reftex-parse-all (reftex-is-multi)] + ["Save to File" (reftex-access-parse-file 'write) + (> (length (symbol-value reftex-docstruct-symbol)) 0)] + ["Restore from File" (reftex-access-parse-file 'restore) + (reftex-access-parse-file 'readable)] + "----" + ["Enable Partial Scans" + (setq reftex-enable-partial-scans (not reftex-enable-partial-scans)) + :style toggle :selected reftex-enable-partial-scans] + ["Auto-Save Parse Info" + (setq reftex-save-parse-info (not reftex-save-parse-info)) + :style toggle :selected reftex-save-parse-info] + "---" + ["Reset RefTeX Mode" reftex-reset-mode t]) + ("Multifile" + ["Search Whole Document" reftex-search-document t] + ["Replace in Document" reftex-query-replace-document t] + ["Grep on Document" reftex-grep-document t] + "----" + ["Create TAGS File" reftex-create-tags-file t] "----" - ["Find duplicate labels" reftex-find-duplicate-labels t] - ["Change label and refs" reftex-change-label t] + ["Find Duplicate Labels" reftex-find-duplicate-labels t] + ["Change Label and Refs" reftex-change-label t]) + ("Citation Options" + "Citation Style" + ,@(mapcar + (function + (lambda (x) + (vector + (symbol-name (car x)) + (list 'setq 'reftex-cite-format (list 'quote (car x))) + :style 'radio :selected + (list 'eq 'reftex-cite-format (list 'quote (car x)))))) + reftex-cite-format-builtin) "----" - ["Create TAGS file" reftex-create-tags-file t]) + "Bibinfo in Comments" + ["Attach Comments" + (setq reftex-comment-citations (not reftex-comment-citations)) + :style toggle :selected reftex-comment-citations] + "---" + "Sort Database Matches" + ["by Author" (setq reftex-sort-bibtex-matches 'author) + :style radio :selected (eq reftex-sort-bibtex-matches 'author)] + ["by Year" (setq reftex-sort-bibtex-matches 'year) + :style radio :selected (eq reftex-sort-bibtex-matches 'year)] + ["by Year, reversed" (setq reftex-sort-bibtex-matches 'reverse-year) + :style radio :selected (eq reftex-sort-bibtex-matches 'reverse-year)] + ["Not" (setq reftex-sort-bibtex-matches nil) + :style radio :selected (eq reftex-sort-bibtex-matches nil)]) "----" - ["Parse document" reftex-parse-document t] - ["Reset RefTeX Mode" reftex-reset-mode t] - ["Customize RefTeX" reftex-customize t])) + ["Customize RefTeX" reftex-customize t] + "----" + ["Show Documentation" reftex-show-commentary t])) ;;; Run Hook ------------------------------------------------------------------ @@ -4215,14 +5647,15 @@ ;;; That's it! ---------------------------------------------------------------- +(provide 'reftex) + ; Make sure tabels are compiled (message "updating internal tables...") (reftex-compute-ref-cite-tables) (message "updating internal tables...done") (setq reftex-tables-dirty nil) -(provide 'reftex) - ;;;============================================================================ -;;; reftex.el end here +;;; reftex.el ends here + diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mu/latex-math-symbol.el --- a/lisp/mu/latex-math-symbol.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -;;; latex-math-symbol.el --- LaTeX math symbol decoder - -;; Copyright (C) 1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Created: 1996/7/1 -;; Version: -;; $Id: latex-math-symbol.el,v 1.3 1997/01/30 02:22:35 steve Exp $ -;; Keywords: LaTeX, math, mule - -;; This file is part of MU (Message Utilities). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to install -;; bytecompile this file and copy it to the apropriate directory. -;; - How to use -;; If you use tm, please put following to your ~/.emacs: -;; (autoload 'latex-math-decode-buffer "latex-math-symbol" nil t) -;; (add-hook 'mime-viewer/plain-text-preview-hook -;; 'latex-math-decode-buffer) -;; Of course, it may be available for other hooks to filter messages. - -;;; Code: - -(defvar latex-math-symbol-table-alist - '(("\\alpha" . ",Fa(B") - ("\\beta" . ",Fb(B") - ("\\gamma" . ",Fc(B")("\\Gamma" . "$B&#(B") - ("\\delta" . ",Fd(B")("\\Delta" . "$B&$(B") - ("\\epsilon" . ",Fe(B")("\\varepsilon" . "$B&E(B") - ("\\zeta" . ",Ff(B") - ("\\eta" . ",Fg(B") - ("\\theta" . ",Fh(B")("\\Theta" . "$B&((B") - ("\\iota" . ",Fi(B") - ("\\kappa" . ",Fj(B") - ("\\lambda" . ",Fk(B")("\\Lambda" . "$B&+(B") - ("\\mu" . ",Fl(B") - ("\\nu" . ",Fm(B") - ("\\xi" . ",Fn(B")("\\Xi" . "$B&.(B") - ("\\pi" . ",Fp(B")("\\Pi" . "$B&0(B") - ("\\rho" . ",Fq(B") - ("\\sigma" . ",Fs(B")("\\Sigma" . "$B&2(B") - ("\\varsigma" . ",Fr(B") - ("\\tau" . ",Ft(B") - ("\\upsilon" . ",Fu(B")("\\Upsilon" . "$B&4(B") - ("\\phi" . "$B&U(B")("\\Phi" . "$B&5(B") - ("\\varphi" . ",Fv(B") - ("\\chi" . ",Fw(B") - ("\\psi" . ",Fx(B")("\\Psi" . "$B&7(B") - ("\\omega" . ",Fy(B")("\\Omega" . "$B&8(B") - - ("\\{" . "$B!P(B")("\\}" . "$B!Q(B") - ("\\langle\\!\\langle" . "$B!T(B")("\\rangle\\!\\rangle" . "$B!U(B") - ("\\langle" . "$B!R(B")("\\rangle" . "$B!S(B") - - ("\\cdots" . "$B!D(B") - - ("\\ln" . "$(G"L(B") - ("\\log" . "$(G"K(B") - - ("\\pm" . "$B!^(B") - ("\\cdot" . "$B!&(B") - ("\\times" . "$B!_(B")("\\ast" . "$B!v(B") - ("\\star" . "$B!z(B") - ("\\bullet" . "$B!&(B") - ("\\div" . "$B!`(B") - ("\\cap" . "$B"A(B")("\\cup" . "$B"@(B") - ("\\lhd" . "$(C"7(B")("\\rhd" . "$(C"9(B") - ("\\bigcirc" . "$B"~(B") - ("\\vee" . "$B"K(B")("\\lor" . "$B"K(B") - ("\\wedge" . "$B"J(B")("\\land" . "$B"J(B") - ("\\oplus" . "$(G"S(B") - ("\\odot" . "$(G"T(B") - ("\\dagger" . "$B"w(B")("\\ddagger" . "$B"x(B") - - ("\\leq" . "$(C!B(B")("\\geq" . "$(C!C(B") - ("\\le" . "$(C!B(B")("\\ge" . "$(C!C(B") - ("\\ll" . "$B"c(B")("\\gg" . "$B"d(B") - ("\\subseteq" . "$B"<(B")("\\supseteq" . "$B"=(B") - ("\\subset" . "$B">(B")("\\supset" . "$B"?(B") - ("\\in" . "$B":(B") - ("\\ni" . "$B";(B")("\\owns" . "$B";(B") - ("\\frown" . "$B"^(B") - ("\\mid" . "$B!C(B")("\\parallel" . "$B!B(B") - ("\\sim" . "$B!A(B") - ("\\equiv" . "$B"a(B") - ("\\approx" . "$A!V(B") - ("\\not=" . "$B!b(B") - ("\\neq" . "$B!b(B")("\\ne" . "$B!b(B") - ("\\perp" . "$B"](B") - - ("\\triangleup" . "$B"$(B") - ("\\forall" . "$B"O(B") - - ("\\hbar" . ",C1(B")("\\imath" . ",C9(B") - ("\\ell" . "$(C'$(B") - ("\\partial" . "$B"_(B") - ("\\infty" . "$B!g(B") - ("\\smallint" . "$B"i(B") - ("\\P" . "$B"y(B") - ("\\prime" . "$B!l(B") - ("\\nabla" . "$B"`(B") - ("\\top" . "$(D0#(B")("\\bot" . "$(D0"(B") - ("\\vert" . "$B!C(B")("\\Vert" . "$B!B(B") - ("\\angle" . "$B"\(B") - ("\\triangle" . "$B"$(B") - ("\\backslash" . "$B!@(B") - ("\\S" . "$B!x(B") - ("\\forall" . "$B"O(B") - ("\\exists" . "$B"P(B") - ("\\neg" . "$B"L(B")("\\lnot" . "$B"L(B") - ("\\flat" . "$B"u(B")("\\sharp" . "$B"t(B") - ("\\clubsuit" . "$(C"@(B") - ("\\diamondsuit" . "$B!~(B") - ("\\heartsuit" . "$(C"=(B") - ("\\spadesuit" . "$(C"<(B") - - ("\\leftarrow" . "$B"+(B")("\\rightarrow" . "$B"*(B") - ("\\gets" . "$B"+(B")("\\to" . "$B"*(B") - - ("^1" . ",A9(B")("^{1}" . ",A9(B") - ("^2" . ",A2(B")("^{2}" . ",A2(B") - ("^3" . ",A3(B")("^{3}" . ",A3(B") - ("^4" . "$(C)y(B")("^{4}" . "$(C)y(B") - ("^n" . "$(C)z(B")("^{n}" . "$(C)z(B") - ("_1" . "$(C){(B")("_{1}" . "$(C){(B") - ("_2" . "$(C)|(B")("_{2}" . "$(C)|(B") - ("_3" . "$(C)}(B")("_{3}" . "$(C)}(B") - ("_4" . "$(C)~(B")("_{4}" . "$(C)~(B") - )) - -(defun latex-math-decode-region (beg end) - (interactive "r") - (save-restriction - (narrow-to-region beg end) - (let ((rest latex-math-symbol-table-alist) - (case-fold-search nil) - cell) - (while rest - (setq cell (car rest)) - (goto-char beg) - (while (re-search-forward - (concat "\\(" - (regexp-quote (car cell)) - "\\)\\([^a-zA-Z]\\|$\\)") - nil t) - (delete-region (match-beginning 1)(match-end 1)) - (goto-char (match-beginning 0)) - (insert (cdr cell)) - ) - (setq rest (cdr rest)) - )))) - -(defun latex-math-decode-buffer () - (interactive) - (latex-math-decode-region (point-min)(point-max)) - ) - - -;;; @ end -;;; - -(provide 'latex-math-symbol) - -;;; latex-math-symbol.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mu/mu-bbdb.el --- a/lisp/mu/mu-bbdb.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -;;; mu-bbdb.el --- `attribution' function for mu-cite with BBDB. - -;; Copyright (C) 1996 Shuhei KOBAYASHI - -;; Author: Shuhei KOBAYASHI -;; Version: $Id: mu-bbdb.el,v 1.1.1.2 1996/12/21 20:50:53 steve Exp $ - -;; This file is part of tl (Tiny Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to use -;; 1. bytecompile this file and copy it to the apropriate directory. -;; 2. put the following lines to your ~/.emacs: -;; (require 'tl-misc) -;; (call-after-loaded 'mu-cite -;; (function -;; (lambda () -;; (require 'mu-bbdb) -;; ))) - - -;;; Code: - -(require 'mu-cite) -(if (module-installed-p 'bbdb) - (require 'bbdb)) - -(defvar mu-bbdb-load-hook nil - "*List of functions called after mu-bbdb is loaded.") - -;;; @@ prefix and registration using BBDB -;;; - -(defun mu-cite/get-bbdb-prefix-method () - (or (mu-cite/get-bbdb-attr (mu-cite/get-value 'address)) - ">") - ) - -(defun mu-cite/get-bbdb-attr (addr) - "Extract attribute information from BBDB." - (let ((record (bbdb-search-simple nil addr))) - (and record - (bbdb-record-getprop record 'attribution)) - )) - -(defun mu-cite/set-bbdb-attr (attr addr) - "Add attribute information to BBDB." - (let* ((bbdb-notice-hook nil) - (record (bbdb-annotate-message-sender - addr t - (bbdb-invoke-hook-for-value - bbdb/mail-auto-create-p) - t))) - (if record - (progn - (bbdb-record-putprop record 'attribution attr) - (bbdb-change-record record nil)) - ))) - -(defun mu-cite/get-bbdb-prefix-register-method () - (let ((addr (mu-cite/get-value 'address))) - (or (mu-cite/get-bbdb-attr addr) - (let ((return - (read-string "Citation name? " - (or (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history) - )) - (if (and (not (string-equal return "")) - (y-or-n-p (format "Register \"%s\"? " return))) - (mu-cite/set-bbdb-attr return addr) - ) - return)))) - -(defun mu-cite/get-bbdb-prefix-register-verbose-method () - (let* ((addr (mu-cite/get-value 'address)) - (attr (mu-cite/get-bbdb-attr addr)) - (return (read-string "Citation name? " - (or attr - (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history)) - ) - (if (and (not (string-equal return "")) - (not (string-equal return attr)) - (y-or-n-p (format "Register \"%s\"? " return)) - ) - (mu-cite/set-bbdb-attr return addr) - ) - return)) - -(or (assoc 'bbdb-prefix mu-cite/default-methods-alist) - (setq mu-cite/default-methods-alist - (append mu-cite/default-methods-alist - (list - (cons 'bbdb-prefix - (function mu-cite/get-bbdb-prefix-method)) - (cons 'bbdb-prefix-register - (function mu-cite/get-bbdb-prefix-register-method)) - (cons 'bbdb-prefix-register-verbose - (function - mu-cite/get-bbdb-prefix-register-verbose-method)) - )))) - - -;;; @ end -;;; - -(provide 'mu-bbdb) - -(run-hooks 'mu-bbdb-load-hook) - -;;; mu-bbdb.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mu/mu-cite.el --- a/lisp/mu/mu-cite.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,536 +0,0 @@ -;;; mu-cite.el --- yet another citation tool for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; MINOURA Makoto -;; Shuhei KOBAYASHI -;; Maintainer: Shuhei KOBAYASHI -;; Version: $Revision: 1.6 $ -;; Keywords: mail, news, citation - -;; This file is part of MU (Message Utilities). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to use -;; 1. bytecompile this file and copy it to the apropriate directory. -;; 2. put the following lines to your ~/.emacs: -;; for EMACS 19 or later and XEmacs -;; (autoload 'mu-cite/cite-original "mu-cite" nil t) -;; ;; for all but message-mode -;; (add-hook 'mail-citation-hook 'mu-cite/cite-original) -;; ;; for message-mode only -;; (setq message-cite-function (function mu-cite/cite-original)) -;; for EMACS 18 -;; ;; for all but mh-e -;; (add-hook 'mail-yank-hooks (function mu-cite/cite-original)) -;; ;; for mh-e only -;; (add-hook 'mh-yank-hooks (function mu-cite/cite-original)) - -;;; Code: - -(require 'std11) -(require 'tl-str) -(require 'tl-list) - - -;;; @ version -;;; - -(defconst mu-cite/RCS-ID - "$Id: mu-cite.el,v 1.6 1997/03/22 06:02:28 steve Exp $") -(defconst mu-cite/version (get-version-string mu-cite/RCS-ID)) - - -;;; @ formats -;;; - -(defvar mu-cite/cited-prefix-regexp "\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)" - "*Regexp to match the citation prefix. -If match, mu-cite doesn't insert citation prefix.") - -(defvar mu-cite/prefix-format '(prefix-register-verbose "> ") - "*List to represent citation prefix. -Each elements must be string or method name.") - -(defvar mu-cite/top-format '(in-id - ">>>>> " from " wrote:\n") - "*List to represent top string of citation. -Each elements must be string or method name.") - - -;;; @ hooks -;;; - -(defvar mu-cite-load-hook nil - "*List of functions called after mu-cite is loaded. -Use this hook to add your own methods to `mu-cite/default-methods-alist'.") - -(defvar mu-cite/instantiation-hook nil - "*List of functions called just before narrowing to the message.") - -(defvar mu-cite/pre-cite-hook nil - "*List of functions called before citing a region of text.") - -(defvar mu-cite/post-cite-hook nil - "*List of functions called after citing a region of text.") - - -;;; @ field -;;; - -(defvar mu-cite/get-field-value-method-alist nil - "Alist major-mode vs. function to get field-body of header.") - -(defun mu-cite/get-field-value (name) - (or (std11-field-body name) - (let ((method (assq major-mode mu-cite/get-field-value-method-alist))) - (if method - (funcall (cdr method) name) - )))) - - -;;; @ prefix registration -;;; - -(defvar mu-cite/registration-file (expand-file-name "~/.mu-cite.el") - "*The name of the user environment file for mu-cite.") - -(defvar mu-cite/allow-null-string-registration nil - "*If non-nil, null-string citation-name is registered.") - -(defvar mu-cite/registration-symbol 'mu-cite/citation-name-alist) - -(defvar mu-cite/citation-name-alist nil) -(or (eq 'mu-cite/citation-name-alist mu-cite/registration-symbol) - (setq mu-cite/citation-name-alist - (symbol-value mu-cite/registration-symbol)) - ) -(defvar mu-cite/minibuffer-history nil) - -;; get citation-name from the database -(defun mu-cite/get-citation-name (from) - (assoc-value from mu-cite/citation-name-alist) - ) - -;; register citation-name to the database -(defun mu-cite/add-citation-name (name from) - (setq mu-cite/citation-name-alist - (put-alist from name mu-cite/citation-name-alist)) - (mu-cite/save-registration-file) - ) - -;; load/save registration file -(defun mu-cite/load-registration-file () - (let* ((file mu-cite/registration-file) - (buffer (get-buffer-create " *mu-register*"))) - (if (file-readable-p file) - (unwind-protect - (save-excursion - (set-buffer buffer) - (erase-buffer) - (insert-file-contents file) - ;; (eval-buffer) - (eval-current-buffer)) - (kill-buffer buffer)) - ))) -(add-hook 'mu-cite-load-hook (function mu-cite/load-registration-file)) - -(defun mu-cite/save-registration-file () - (let* ((file mu-cite/registration-file) - (buffer (get-buffer-create " *mu-register*"))) - (unwind-protect - (save-excursion - (set-buffer buffer) - (setq buffer-file-name file) - (erase-buffer) - (insert ";;; " (file-name-nondirectory file) "\n") - (insert ";;; This file is generated automatically by mu-cite " - mu-cite/version "\n\n") - (insert "(setq " - (symbol-name mu-cite/registration-symbol) - "\n '(") - (insert (mapconcat - (function prin1-to-string) - mu-cite/citation-name-alist "\n ")) - (insert "\n ))\n\n") - (insert ";;; " - (file-name-nondirectory file) - " ends here.\n") - (save-buffer)) - (kill-buffer buffer)))) - - -;;; @ item methods -;;; - -;;; @@ ML count -;;; - -(defvar mu-cite/ml-count-field-list - '("X-Ml-Count" "X-Mail-Count" "X-Seqno" "X-Sequence" "Mailinglist-Id") - "*List of header fields which contain sequence number of mailing list.") - -(defun mu-cite/get-ml-count-method () - (let ((field-list mu-cite/ml-count-field-list)) - (catch 'tag - (while field-list - (let* ((field (car field-list)) - (ml-count (mu-cite/get-field-value field))) - (if (and ml-count (string-match "[0-9]+" ml-count)) - (throw 'tag - (substring ml-count - (match-beginning 0)(match-end 0)) - )) - (setq field-list (cdr field-list)) - ))))) - - -;;; @@ prefix and registration -;;; - -(defun mu-cite/get-prefix-method () - (or (mu-cite/get-citation-name (mu-cite/get-value 'address)) - ">") - ) - -(defun mu-cite/get-prefix-register-method () - (let ((addr (mu-cite/get-value 'address))) - (or (mu-cite/get-citation-name addr) - (let ((return - (read-string "Citation name? " - (or (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history) - )) - (if (and (or mu-cite/allow-null-string-registration - (not (string-equal return ""))) - (y-or-n-p (format "Register \"%s\"? " return))) - (mu-cite/add-citation-name return addr) - ) - return)))) - -(defun mu-cite/get-prefix-register-verbose-method () - (let* ((addr (mu-cite/get-value 'address)) - (return1 (mu-cite/get-citation-name addr)) - (return (read-string "Citation name? " - (or return1 - (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history)) - ) - (if (and (or mu-cite/allow-null-string-registration - (not (string-equal return ""))) - (not (string-equal return return1)) - (y-or-n-p (format "Register \"%s\"? " return)) - ) - (mu-cite/add-citation-name return addr) - ) - return)) - - -;;; @@ set up -;;; - -(defvar mu-cite/default-methods-alist - (list (cons 'from - (function - (lambda () - (mu-cite/get-field-value "From") - ))) - (cons 'date - (function - (lambda () - (mu-cite/get-field-value "Date") - ))) - (cons 'message-id - (function - (lambda () - (mu-cite/get-field-value "Message-Id") - ))) - (cons 'subject - (function - (lambda () - (mu-cite/get-field-value "Subject") - ))) - (cons 'ml-name - (function - (lambda () - (mu-cite/get-field-value "X-Ml-Name") - ))) - (cons 'ml-count (function mu-cite/get-ml-count-method)) - (cons 'address-structure - (function - (lambda () - (car - (std11-parse-address-string (mu-cite/get-value 'from)) - )))) - (cons 'full-name - (function - (lambda () - (std11-full-name-string - (mu-cite/get-value 'address-structure)) - ))) - (cons 'address - (function - (lambda () - (std11-address-string - (mu-cite/get-value 'address-structure)) - ))) - (cons 'id - (function - (lambda () - (let ((ml-name (mu-cite/get-value 'ml-name))) - (if ml-name - (concat "[" - ml-name - " : No." - (mu-cite/get-value 'ml-count) - "]") - (mu-cite/get-value 'message-id) - ))))) - (cons 'in-id - (function - (lambda () - (let ((id (mu-cite/get-value 'id))) - (if id - (format ">>>>> In %s \n" id) - ""))))) - (cons 'prefix (function mu-cite/get-prefix-method)) - (cons 'prefix-register - (function mu-cite/get-prefix-register-method)) - (cons 'prefix-register-verbose - (function mu-cite/get-prefix-register-verbose-method)) - (cons 'x-attribution - (function - (lambda () - (mu-cite/get-field-value "X-Attribution") - ))) - )) - - -;;; @ fundamentals -;;; - -(defvar mu-cite/methods-alist nil) - -(defun mu-cite/make-methods () - (setq mu-cite/methods-alist - (copy-alist mu-cite/default-methods-alist)) - (run-hooks 'mu-cite/instantiation-hook) - ) - -(defun mu-cite/get-value (item) - (let ((ret (assoc-value item mu-cite/methods-alist))) - (if (functionp ret) - (prog1 - (setq ret (funcall ret)) - (set-alist 'mu-cite/methods-alist item ret) - ) - ret))) - -(defun mu-cite/eval-format (list) - (mapconcat (function - (lambda (elt) - (cond ((stringp elt) elt) - ((symbolp elt) (mu-cite/get-value elt)) - ))) - list "") - ) - - -;;; @ main function -;;; - -(defun mu-cite/cite-original () - "Citing filter function. -This is callable from the various mail and news readers' reply -function according to the agreed upon standard." - (interactive) - (mu-cite/make-methods) - (save-restriction - (if (< (mark t) (point)) - (exchange-point-and-mark)) - (narrow-to-region (point)(point-max)) - (run-hooks 'mu-cite/pre-cite-hook) - (let ((last-point (point)) - (top (mu-cite/eval-format mu-cite/top-format)) - (prefix (mu-cite/eval-format mu-cite/prefix-format)) - ) - (if (re-search-forward "^-*$" nil nil) - (forward-line 1) - ) - (widen) - (delete-region last-point (point)) - (insert top) - (setq last-point (point)) - (while (< (point)(mark t)) - (or (looking-at mu-cite/cited-prefix-regexp) - (insert prefix)) - (forward-line 1)) - (goto-char last-point) - ) - (run-hooks 'mu-cite/post-cite-hook) - )) - - -;;; @ message editing utilities -;;; - -(defvar citation-mark-chars ">}|" - "*String of characters for citation delimiter. [mu-cite.el]") - -(defvar citation-disable-chars "<{" - "*String of characters not allowed as citation-prefix.") - -(defun detect-paragraph-cited-prefix () - (save-excursion - (goto-char (point-min)) - (let ((i 0) - (prefix - (buffer-substring - (progn (beginning-of-line)(point)) - (progn (end-of-line)(point)) - )) - str ret) - (while (and (= (forward-line) 0) - (setq str (buffer-substring - (progn (beginning-of-line)(point)) - (progn (end-of-line)(point)))) - (setq ret (string-compare-from-top prefix str)) - ) - (setq prefix - (if (stringp ret) - ret - (second ret))) - (setq i (1+ i)) - ) - (cond ((> i 1) prefix) - ((> i 0) - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point) - (+ (point)(length prefix))) - (goto-char (point-max)) - (if (re-search-backward - (concat "[" citation-mark-chars "]") nil t) - (progn - (goto-char (match-end 0)) - (if (looking-at "[ \t]+") - (goto-char (match-end 0)) - ) - (buffer-substring (point-min)(point)) - ) - prefix))) - ((progn - (goto-char (point-max)) - (re-search-backward - (concat "[" citation-disable-chars "]") nil t) - (re-search-backward - (concat "[" citation-mark-chars "]") nil t) - ) - (goto-char (match-end 0)) - (if (looking-at "[ \t]+") - (goto-char (match-end 0)) - ) - (buffer-substring (point-min)(point)) - ) - (t "")) - ))) - -(defun fill-cited-region (beg end) - (interactive "*r") - (save-excursion - (save-restriction - (goto-char end) - (and (search-backward "\n" nil t) - (setq end (match-end 0)) - ) - (narrow-to-region beg end) - (let* ((fill-prefix (detect-paragraph-cited-prefix)) - (pat (concat fill-prefix "\n")) - ) - (goto-char (point-min)) - (while (search-forward pat nil t) - (let ((b (match-beginning 0)) - (e (match-end 0)) - ) - (delete-region b e) - (if (and (> b (point-min)) - (let ((cat (char-category - (char-before b)))) - (or (string-match "a" cat) - (string-match "l" cat) - )) - ) - (insert " ") - )) - ) - (goto-char (point-min)) - (fill-region (point-min) (point-max)) - )))) - -(defun compress-cited-prefix () - (interactive) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") nil t) - (while (re-search-forward - (concat "^\\([ \t]*[^ \t\n" citation-mark-chars "]*[" - citation-mark-chars "]\\)+") nil t) - (let* ((b (match-beginning 0)) - (e (match-end 0)) - (prefix (buffer-substring b e)) - ps pe (s 0) - (nest (let ((i 0)) - (if (string-match "<[^<>]+>" prefix) - (setq prefix (substring prefix 0 (match-beginning 0))) - ) - (while (string-match - (concat "\\([" citation-mark-chars "]+\\)[ \t]*") - prefix s) - (setq i (+ i (- (match-end 1)(match-beginning 1))) - ps s - pe (match-beginning 1) - s (match-end 0) - )) - i))) - (if (and ps (< ps pe)) - (progn - (delete-region b e) - (insert (concat (substring prefix ps pe) (make-string nest ?>))) - )))))) - -(defun replace-top-string (old new) - (interactive "*sOld string: \nsNew string: ") - (while (re-search-forward - (concat "^" (regexp-quote old)) nil t) - (replace-match new) - )) - - -;;; @ end -;;; - -(provide 'mu-cite) - -(run-hooks 'mu-cite-load-hook) - -;;; mu-cite.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/auto-autoloads.el --- a/lisp/mule/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -37,14 +37,11 @@ ;;;*** -;;;### (autoloads (dump-coding-systems dump-charsets mule-diag list-fontset describe-fontset list-font describe-font list-coding-system list-coding-system-briefly describe-coding-system list-charsets) "mule-debug" "mule/mule-debug.el") +;;;### (autoloads (dump-coding-systems dump-charsets mule-diag list-fontset describe-fontset list-font describe-font list-coding-system list-coding-system-briefly list-charsets) "mule-debug" "mule/mule-debug.el") (autoload 'list-charsets "mule-debug" "\ Display a list of existing character sets." t nil) -(autoload 'describe-coding-system "mule-debug" "\ -Display documentation of the coding-system CS." t nil) - (autoload 'list-coding-system-briefly "mule-debug" "\ Display coding-systems currently used with a brief format in mini-buffer." t nil) @@ -74,6 +71,105 @@ ;;;*** +;;;### (autoloads (dump-codings dump-charsets mule-diag list-input-methods list-fontsets describe-fontset describe-font list-coding-systems describe-current-coding-system describe-current-coding-system-briefly describe-coding-system list-character-sets) "mule-diag" "mule/mule-diag.el") + +(autoload 'list-character-sets "mule-diag" "\ +Display a list of all character sets. + +The ID column contains a charset identification number for internal use. +The B column contains a number of bytes occupied in a buffer. +The W column contains a number of columns occupied in a screen. + +With prefix arg, the output format gets more cryptic +but contains full information about each character sets." t nil) + +(autoload 'describe-coding-system "mule-diag" "\ +Display information of CODING-SYSTEM." t nil) + +(autoload 'describe-current-coding-system-briefly "mule-diag" "\ +Display coding systems currently used in a brief format in echo area. + +The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\", +where mnemonics of the following coding systems come in this order +at the place of `..': + buffer-file-coding-system (of the current buffer) + eol-type of buffer-file-coding-system (of the current buffer) + (keyboard-coding-system) + eol-type of (keyboard-coding-system) + (terminal-coding-system) + eol-type of (terminal-coding-system) + process-coding-system for read (of the current buffer, if any) + eol-type of process-coding-system for read (of the current buffer, if any) + process-coding-system for write (of the current buffer, if any) + eol-type of process-coding-system for write (of the current buffer, if any) + default-buffer-file-coding-system + eol-type of default-buffer-file-coding-system + default-process-coding-system for read + eol-type of default-process-coding-system for read + default-process-coding-system for write + eol-type of default-process-coding-system" t nil) + +(autoload 'describe-current-coding-system "mule-diag" "\ +Display coding systems currently used in a detailed format." t nil) + +(autoload 'list-coding-systems "mule-diag" "\ +Display a list of all coding systems. +It prints mnemonic letter, name, and description of each coding systems. + +With prefix arg, the output format gets more cryptic, +but contains full information about each coding systems." t nil) + +(autoload 'describe-font "mule-diag" "\ +Display information about fonts which partially match FONTNAME." t nil) + +(autoload 'describe-fontset "mule-diag" "\ +Display information of FONTSET. + +It prints name, size, and style of FONTSET, and lists up fonts +contained in FONTSET. + +The column WDxHT contains width and height (pixels) of each fontset +\(i.e. those of ASCII font in the fontset). The letter `-' in this +column means that the corresponding fontset is not yet used in any +frame. + +The O column of each font contains one of the following letters. + o -- font already opened + - -- font not yet opened + x -- font can't be opened + ? -- no font specified + +The Charset column of each font contains a name of character set +displayed by the font." t nil) + +(autoload 'list-fontsets "mule-diag" "\ +Display a list of all fontsets. + +It prints name, size, and style of each fontset. +With prefix arg, it also lists up fonts contained in each fontset. +See the function `describe-fontset' for the format of the list." t nil) + +(autoload 'list-input-methods "mule-diag" "\ +Print information of all input methods." t nil) + +(autoload 'mule-diag "mule-diag" "\ +Display diagnosis of the multilingual environment (MULE). + +It prints various information related to the current multilingual +environment, including lists of input methods, coding systems, +character sets, and fontsets (if Emacs running under some window +system)." t nil) + +(autoload 'dump-charsets "mule-diag" "\ +Dump information of all charsets into the file \"CHARSETS\". +The file is saved in the directory `data-directory'." nil nil) + +(autoload 'dump-codings "mule-diag" "\ +Dump information of all coding systems into the file \"CODINGS\". +The file is saved in the directory `data-directory'." nil nil) + +;;;*** + ;;;### (autoloads (set-keyboard-coding-system) "mule-keyboard" "mule/mule-keyboard.el") (defvar keyboard-allow-latin-input nil "\ @@ -212,21 +308,5 @@ even if WITH-COMPOSITION-RULE is t." nil nil) ;;;*** - -;;;### (autoloads (vn-decompose-viqr-buffer vn-decompose-viqr vn-compose-viqr-buffer vn-compose-viqr) "mule-vietnamese" "mule/mule-vietnamese.el") - -(autoload 'vn-compose-viqr "mule-vietnamese" "\ -Convert 'VIQR' mnemonics of the current region to -pre-composed Vietnamese characaters." t nil) - -(autoload 'vn-compose-viqr-buffer "mule-vietnamese" nil t nil) - -(autoload 'vn-decompose-viqr "mule-vietnamese" "\ -Convert pre-composed Vietnamese characaters of the current region to -'VIQR' mnemonics." t nil) - -(autoload 'vn-decompose-viqr-buffer "mule-vietnamese" nil t nil) - -;;;*** (provide 'mule-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/canna-leim.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mule/canna-leim.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,53 @@ +;;; canna-leim.el --- Canna-related code for LEIM +;; Copyright (C) 1997 Stephen Turnbull +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Shamelessly ripped off from +;; +;; skk-leim.el --- SKK related code for LEIM +;; Copyright (C) 1997 +;; Murata Shuuichirou +;; +;; Author: Stephen Turnbull +;; Version: canna-leim.el,v 1.2 1997/10/27 10:08:49 steve Exp +;; Keywords: japanese, input method, LEIM +;; Last Modified: 1997/10/27 10:08:49 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either versions 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs, see the file COPYING. If not, write to the Free +;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + +;;; TODO +;; +;; Add pointers to Canna documentation in LEIM format + +(defun canna-activate (&optional name) + (if (featurep 'CANNA) + (require 'canna) + (error "Canna is not built into this XEmacs")) + (setq inactivate-current-input-method-function 'canna-inactivate) + (canna) + (canna-toggle-japanese-mode)) + +(defun canna-inactivate () + (cond (canna:*japanese-mode* (canna-toggle-japanese-mode))) ) + +(register-input-method + 'japanese-canna "Japanese" + 'canna-activate nil + "Canna - a kana to kanji conversion program" ) + +(provide 'canna-leim) + +;;; canna-leim.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/canna.el --- a/lisp/mule/canna.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/canna.el Mon Aug 13 10:03:52 2007 +0200 @@ -5,7 +5,7 @@ ;; Author: Akira Kon ;; MORIOKA Tomohiko -;; Version: $Revision: 1.7 $ +;; Version: $Revision: 1.8 $ ;; Keywords: Canna, Japanese, input method, mule, multilingual ;; This file is not a part of Emacs yet. @@ -50,7 +50,7 @@ ;; end (defconst canna-rcs-version - "$Id: canna.el,v 1.7 1997/06/21 20:02:46 steve Exp $") + "$Id: canna.el,v 1.8 1997/10/31 14:52:58 steve Exp $") (defun canna-version () "Display version of canna.el in mini-buffer." @@ -1057,7 +1057,14 @@ (define-key global-map (make-string 1 ch) 'canna-self-insert-command) (setq ch (1+ ch)) )) - (cond ((let ((keys (car init-val)) (ok nil)) + (cond + ;; #### I'm just guessing that this should come before the + ;; init-val setting + ;; if registered with LEIM, no-op + ((featurep 'canna-leim) t) + ;; check to see if an X resource or the like is available in + ;; init-val + ((let ((keys (car init-val)) (ok nil)) (while keys (cond ((< (car keys) 128) (global-set-key @@ -1066,9 +1073,13 @@ (setq ok t) )) (setq keys (cdr keys)) ) ok)) - (t ; $B%G%U%)%k%H$N@_Dj(B - (global-set-key "\C-o" 'canna-toggle-japanese-mode) )) + ;; $B%G%U%)%k%H$N@_Dj(B + ;; Since XEmacs provides canna-leim.el, we should leave this + ;; as is. + (t (global-set-key "\C-o" 'canna-toggle-japanese-mode)) ) + ;; #### should these global bindings be conditional on LEIM? + ;; LEIM doesn't use kanji key yet AFAIK, so leave them. (if (not (keymapp (global-key-binding "\e["))) (global-unset-key "\e[") ) (global-set-key "\e[210z" 'canna-toggle-japanese-mode) ; XFER diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/custom-load.el --- a/lisp/mule/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,9 +1,8 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:17 1997 ;;; Code: -(custom-put 'mule 'custom-loads '("mule-cmds")) +(custom-add-loads 'mule '("mule-cmds")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/hebrew-hooks.el --- a/lisp/mule/hebrew-hooks.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/hebrew-hooks.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,68 +0,0 @@ -;;; hebrew-hooks.el --- pre-loaded support for Hebrew. - -;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. -;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1995 Sun Microsystems. - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Mule 2.3. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; HEBREW -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Syntax of Hebrew characters -(loop for c from 96 to 122 - do (modify-syntax-entry (make-char 'hebrew-iso8859-8 c) "w")) -(modify-syntax-entry (make-char 'hebrew-iso8859-8 32) "w") ; no-break space - -(make-coding-system - 'iso-8859-8 'iso2022 - "MIME ISO-8859-8" - '(charset-g0 ascii - charset-g1 hebrew-iso8859-8 - charset-g2 t - charset-g3 t - no-iso6429 t - mnemonic "MIME/Hbrw" -)) - -(make-coding-system - 'ctext-hebrew 'iso2022 - "Coding-system of Hebrew." - '(charset-g0 ascii - charset-g1 hebrew-iso8859-8 - charset-g2 t - charset-g3 t - mnemonic "CText/Hbrw" -)) - -(add-hook 'quail-package-alist '("hebrew" "quail-hebrew")) - -(define-language-environment 'hebrew - "Hebrew" - (lambda () - (set-coding-category-system 'iso-8-designate 'iso-8859-8) - (set-coding-priority-list '(iso-8-designate iso-8-1)) - (set-default-buffer-file-coding-system 'iso-8859-8) - (setq terminal-coding-system 'iso-8859-8) - (setq keyboard-coding-system 'iso-8859-8) - (setq-default quail-current-package - (assoc "hebrew" quail-package-alist)) - )) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-cmds.el --- a/lisp/mule/mule-cmds.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-cmds.el Mon Aug 13 10:03:52 2007 +0200 @@ -29,19 +29,18 @@ (defvar mule-keymap (make-sparse-keymap "MULE") "Keymap for MULE (Multilingual environment) specific commands.") -(fset 'mule-prefix mule-keymap) ;; Keep "C-x C-m ..." for mule specific commands. -(define-key ctl-x-map "\C-m" 'mule-prefix) +(define-key ctl-x-map "\C-m" mule-keymap) (define-key mule-keymap "f" 'set-buffer-file-coding-system) (define-key mule-keymap "F" 'set-default-buffer-file-coding-system) ; XEmacs (define-key mule-keymap "t" 'set-terminal-coding-system) (define-key mule-keymap "k" 'set-keyboard-coding-system) -(define-key mule-keymap "p" 'set-current-process-coding-system) -(define-key mule-keymap "P" 'set-default-process-coding-system) ; XEmacs +(define-key mule-keymap "p" 'set-buffer-process-coding-system) (define-key mule-keymap "\C-\\" 'select-input-method) -(define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs +(define-key mule-keymap "c" 'universal-coding-system-argument) +;;(define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs (define-key mule-keymap "C" 'list-coding-system) ; XEmacs (define-key mule-keymap "r" 'toggle-display-direction) ; XEmacs (define-key mule-keymap "l" 'set-language-environment) @@ -50,7 +49,7 @@ (define-key help-map "L" 'describe-language-environment) (define-key help-map "\C-\\" 'describe-input-method) (define-key help-map "I" 'describe-input-method) -(define-key help-map "C" 'describe-current-coding-system) +(define-key help-map "C" 'describe-coding-system) (define-key help-map "h" 'view-hello-file) ;; Menu for XEmacs were moved to x11/x-menubar.el. @@ -71,13 +70,72 @@ (let ((coding-system-for-read 'iso-2022-7)) (find-file-read-only (expand-file-name "HELLO" data-directory)))) +(defun universal-coding-system-argument () + "Execute an I/O command using the specified coding system." + (interactive) + (let* ((coding-system + (read-coding-system "Coding system for following command: ")) + (keyseq (read-key-sequence + (format "Command to execute with %s:" coding-system))) + (cmd (key-binding keyseq))) + (let ((coding-system-for-read coding-system) + (coding-system-for-write coding-system)) + (message "") + (call-interactively cmd)))) + +(defun set-default-coding-systems (coding-system) + "Set default value of various coding systems to CODING-SYSTEM. +The follwing coding systems are set: + o coding system of a newly created buffer + o default coding system for terminal output + o default coding system for keyboard input + o default coding system for subprocess I/O" + (check-coding-system coding-system) + ;;(setq-default buffer-file-coding-system coding-system) + (set-default-buffer-file-coding-system coding-system) + ;;(setq default-terminal-coding-system coding-system) + (setq terminal-coding-system coding-system) + ;;(setq default-keyboard-coding-system coding-system) + (setq keyboard-coding-system coding-system) + ;;(setq default-process-coding-system (cons coding-system coding-system)) + (add-hook 'comint-exec-hook + (lambda () + (let ((proc (get-buffer-process (current-buffer)))) + (set-process-input-coding-system proc coding-system) + (set-process-output-coding-system proc coding-system) + ))) + (setq file-name-coding-system coding-system) + ) + +(defun prefer-coding-system (coding-system) + "Add CODING-SYSTEM at the front of the priority list for automatic detection. +This also sets the following coding systems to CODING-SYSTEM: + o coding system of a newly created buffer + o default coding system for terminal output + o default coding system for keyboard input + o default coding system for subprocess I/O" + (interactive "zPrefer coding system: ") + (if (not (and coding-system (coding-system-p coding-system))) + (error "Invalid coding system `%s'" coding-system)) + (let ((coding-category (coding-system-category coding-system)) + (parent (coding-system-parent coding-system))) + (if (not coding-category) + ;; CODING-SYSTEM is no-conversion or undecided. + (error "Can't prefer the coding system `%s'" coding-system)) + (set coding-category (or parent coding-system)) + (if (not (eq coding-category (car coding-category-list))) + ;; We must change the order. + (setq coding-category-list + (cons coding-category + (delq coding-category coding-category-list)))) + (if (and parent (interactive-p)) + (message "Highest priority is set to %s (parent of %s)" + parent coding-system)) + (set-default-coding-systems (or parent coding-system)))) + ;;; Language support staffs. -(defvar primary-language "English" - "Name of a user's primary language. -Emacs provide various language supports based on this variable.") - (defvar language-info-alist nil "Alist of language names vs the corresponding information of various kind. Each element looks like: @@ -141,23 +199,43 @@ (setcdr lang-slot (cons key-slot (cdr lang-slot))))) ;; Setup menu. (cond ((eq key 'documentation) - ;; (define-key-after mule-describe-language-support-map + ;; (define-key-after + ;; (if (consp info) + ;; (prog1 (symbol-value (cdr info)) + ;; (setq info (car info))) + ;; describe-language-environment-map) ;; (vector (intern language-name)) - ;; (cons language-name info) + ;; (cons language-name 'describe-specified-language-support) ;; t) + (if (consp info) + (setq info (car info))) (eval-after-load "x-menubar" - `(add-menu-button '("Mule" "Describe Language Support") - (vector ,language-name ',info t))) + `(add-menu-button + '("Mule" "Describe Language Support") + (vector ,language-name + '(describe-language-environment ,language-name) + t))) ) ((eq key 'setup-function) - ;; (define-key-after mule-set-language-environment-map + ;; (define-key-after + ;; (if (consp info) + ;; (prog1 (symbol-value (cdr info)) + ;; (setq info (car info))) + ;; setup-language-environment-map) ;; (vector (intern language-name)) - ;; (cons language-name info) + ;; (cons language-name 'setup-specified-language-environment) ;; t) + (if (consp info) + (setq info (car info))) (eval-after-load "x-menubar" - `(add-menu-button '("Mule" "Set Language Environment") - (vector ,language-name ',info t))) + `(add-menu-button + '("Mule" "Set Language Environment") + (vector ,language-name + '(set-language-environment ,language-name) + t))) )) + + (setcdr key-slot info) )) (defun set-language-info-alist (language-name alist) @@ -178,7 +256,7 @@ (name (completing-read prompt language-info-alist (function (lambda (elm) (assq key elm))) - t nil nil default))) + t nil default))) (if (and (> (length name) 0) (get-language-info name key)) name))) @@ -311,11 +389,8 @@ )) (if (> (length input-method) 0) input-method - ;; If we have a default, use it, otherwise check inhibit-null - (if default - default - (if inhibit-null - (error "No valid input method is specified")))))) + (if inhibit-null + (error "No valid input method is specified"))))) (defun activate-input-method (input-method) "Turn INPUT-METHOD on. @@ -373,8 +448,6 @@ When there's no input method to turn on, turn on what read from minibuffer." (interactive "P") - (if (eq arg 1) - (setq arg nil)) (let* ((default (or (car input-method-history) default-input-method))) (if (and current-input-method (not arg)) (inactivate-input-method) @@ -428,7 +501,9 @@ (if (and input-method (symbolp input-method)) (setq input-method (symbol-name input-method))) (let ((current-input-method input-method)) - (read-string prompt initial-input nil nil t))) + ;; FSFmacs + ;; (read-string prompt initial-input nil nil t))) + (read-string prompt initial-input nil))) ;; Variables to control behavior of input methods. All input methods ;; should react to these variables. @@ -479,80 +554,109 @@ But, if this flag is non-nil, the input method is never back on.") -;;; Language specific setup functions. -;; (defun set-language-environment (language-name) -;; "Setup a user's environment for LANGUAGE-NAME. -;; -;; To setup, a fucntion returned by: -;; (get-language-info LANGUAGE-NAME 'setup-function) -;; is called." -;; (interactive (list (read-language-name 'setup-function "Language: "))) -;; (let (func) -;; (if (or (null language-name) -;; (null (setq func -;; (get-language-info language-name 'setup-function)))) -;; (error "No way to setup environment for the specified language")) -;; (funcall func))) +(defun setup-specified-language-environment () + "Set up multi-lingual environment convenient for the specified language." + (interactive) + (let (language-name) + (if (and (symbolp last-command-event) + (or (not (eq last-command-event 'Default)) + (setq last-command-event 'English)) + (setq language-name (symbol-name last-command-event))) + (set-language-environment language-name) + (error "Bogus calling sequence")))) + +(defvar current-language-environment "English" + "The last language environment specified with `set-language-environment'.") + +(defun set-language-environment (language-name) + "Set up multi-lingual environment for using LANGUAGE-NAME. +This sets the coding system priority and the default input method +and sometimes other things." + (interactive (list (read-language-name 'setup-function + "Set language environment: "))) + (if language-name + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (setq language-name "English")) + (if (null (get-language-info language-name 'setup-function)) + (error "Language environment not defined: %S" language-name)) + (funcall (get-language-info language-name 'setup-function)) + (setq current-language-environment language-name) + (force-mode-line-update t)) ;; Print all arguments with `princ', then print "\n". (defsubst princ-list (&rest args) (while args (princ (car args)) (setq args (cdr args))) (princ "\n")) -(defun describe-language-support (language-name) - "Describe how Emacs supports LANGUAGE-NAME. +;; Print a language specific information such as input methods, +;; charsets, and coding systems. This function is intended to be +;; called from the menu: +;; [menu-bar mule describe-language-environment LANGUAGE] +;; and should not run it by `M-x describe-current-input-method-function'. +(defun describe-specified-language-support () + "Describe how Emacs supports the specified language environment." + (interactive) + (let (language-name) + (if (not (and (symbolp last-command-event) + (setq language-name (symbol-name last-command-event)))) + (error "Bogus calling sequence")) + (describe-language-environment language-name))) -For that, a function returned by: - (get-language-info LANGUAGE-NAME 'describe-function) -is called." - (interactive (list (read-language-name 'documentation "Language: "))) - (let (func) - (if (or (null language-name) - (null (setq func - (get-language-info language-name 'describe-function)))) - (error "No documentation for the specified language")) - (funcall func))) - -;; Print LANGUAGE-NAME specific information such as input methods, -;; charsets, and coding systems. This function is intended to be -;; called from various describe-LANGUAGE-support functions defined in -;; lisp/language/LANGUAGE.el. -(defun describe-language-support-internal (language-name) - (with-output-to-temp-buffer "*Help*" - (let ((doc (get-language-info language-name 'documentation))) +(defun describe-language-environment (language-name) + "Describe how Emacs supports language environment LANGUAGE-NAME." + (interactive + (list (read-language-name + 'documentation + "Describe language environment (default, current choise): "))) + (if (null language-name) + (setq language-name current-language-environment)) + (if (or (null language-name) + (null (get-language-info language-name 'documentation))) + (error "No documentation for the specified language")) + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (let ((doc (get-language-info language-name 'documentation))) + (with-output-to-temp-buffer "*Help*" (if (stringp doc) - (princ-list doc))) - (princ "-----------------------------------------------------------\n") - (princ-list "List of items specific to " - language-name - " support") - (princ "-----------------------------------------------------------\n") - (let ((str (get-language-info language-name 'sample-text))) - (if (stringp str) - (progn - (princ "\n") - (princ-list " " str)))) - (princ "\n") - (let ((l (get-language-info language-name 'input-method))) - (while l - (princ-list " " (car (car l))) - (setq l (cdr l)))) - (princ "\n") - (let ((l (get-language-info language-name 'charset))) - (if (null l) - (princ-list " nothing specific to " language-name) - (while l - (princ-list " " (car l) ": " - (charset-description (car l))) - (setq l (cdr l))))) - (princ "\n") - (let ((l (get-language-info language-name 'coding-system))) - (if (null l) - (princ-list " nothing specific to " language-name) - (while l - (princ-list " " (car l) ":\n\t" - (coding-system-docstring (car l))) - (setq l (cdr l))))))) + (progn + (princ-list doc) + (terpri))) + (let ((str (get-language-info language-name 'sample-text))) + (if (stringp str) + (progn + (princ "Sample text:\n") + (princ-list " " str) + (terpri)))) + (princ "Input methods:\n") + (let ((l input-method-alist)) + (while l + (if (string= language-name (nth 1 (car l))) + (princ-list " " (car (car l)) + (format " (`%s' in mode line)" (nth 3 (car l))))) + (setq l (cdr l)))) + (terpri) + (princ "Character sets:\n") + (let ((l (get-language-info language-name 'charset))) + (if (null l) + (princ-list " nothing specific to " language-name) + (while l + (princ-list " " (car l) ": " + (charset-description (car l))) + (setq l (cdr l))))) + (terpri) + (princ "Coding systems:\n") + (let ((l (get-language-info language-name 'coding-system))) + (if (null l) + (princ-list " nothing specific to " language-name) + (while l + (princ ; (format " %s (`%c' in mode line):\n\t%s\n" + ;; In XEmacs, `coding-system-mnemonic' returns string. + (format " %s (`%s' in mode line):\n\t%s\n" + (car l) + (coding-system-mnemonic (car l)) + (coding-system-doc-string (car l)))) + (setq l (cdr l)))))))) ;;; Charset property @@ -568,29 +672,30 @@ ;; (set-charset-plist charset ;; (plist-put (charset-plist charset) propname value))) -;;; Character code property -;; (put 'char-code-property-table 'char-table-extra-slots 0) - -;; (defvar char-code-property-table -;; (make-char-table 'char-code-property-table) -;; "Char-table containing a property list of each character code. +(defvar char-code-property-table + (make-char-table 'generic) + "Char-table containing a property list of each character code. ;; -;; See also the documentation of `get-char-code-property' and -;; `put-char-code-property'") +See also the documentation of `get-char-code-property' and +`put-char-code-property'") +;; (let ((plist (aref char-code-property-table char))) +(defun get-char-code-property (char propname) + "Return the value of CHAR's PROPNAME property in `char-code-property-table'." + (let ((plist (get-char-table char char-code-property-table))) + (if (listp plist) + (car (cdr (memq propname plist)))))) -;; (defun get-char-code-property (char propname) -;; "Return the value of CHAR's PROPNAME property in `char-code-property-table'." -;; (let ((plist (aref char-code-property-table char))) -;; (if (listp plist) -;; (car (cdr (memq propname plist)))))) - -;; (defun put-char-code-property (char propname value) -;; "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. -;; It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." -;; (let ((plist (aref char-code-property-table char))) -;; (if plist -;; (let ((slot (memq propname plist))) -;; (if slot +(defun put-char-code-property (char propname value) + "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. +It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." + (let ((plist (get-char-table char char-code-property-table))) + (if plist + (let ((slot (memq propname plist))) + (if slot + (setcar (cdr slot) value) + (nconc plist (list propname value)))) + (put-char-table char (list propname value) char-code-property-table) + ))) ;; (setcar (cdr slot) value) ;; (nconc plist (list propname value)))) ;; (aset char-code-property-table char (list propname value))))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-coding.el --- a/lisp/mule/mule-coding.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-coding.el Mon Aug 13 10:03:52 2007 +0200 @@ -84,6 +84,10 @@ (cons (cons regexp coding-system) network-coding-system-alist))))))) +(defsubst keyboard-coding-system () + "Return coding-system of what is sent from terminal keyboard." + keyboard-coding-system) + (defun set-keyboard-coding-system (coding-system) "Set the coding system used for TTY keyboard input. Currently broken." (interactive "zkeyboard-coding-system: ") @@ -91,6 +95,10 @@ (setq keyboard-coding-system coding-system) (redraw-modeline t)) +(defsubst terminal-coding-system () + "Return coding-system of your terminal." + terminal-coding-system) + (defun set-terminal-coding-system (coding-system) "Set the coding system used for TTY display output. Currently broken." (interactive "zterminal-coding-system: ") @@ -156,19 +164,6 @@ "Return the 'pre-write-conversion property of CODING-SYSTEM." (coding-system-property coding-system 'pre-write-conversion)) -(defun coding-system-charset (coding-system register) - "Return the 'charset property of CODING-SYSTEM for the specified REGISTER." - (unless (integerp register) - (signal 'wrong-type-argument (list 'integerp register))) - (coding-system-property - coding-system - (case register - (0 'charset-g0) - (1 'charset-g1) - (2 'charset-g2) - (3 'charset-g3) - (t (signal 'args-out-of-range (list register 0 3)))))) - (defun coding-system-force-on-output (coding-system register) "Return the 'force-on-output property of CODING-SYSTEM for the specified REGISTER." (unless (integerp register) @@ -226,10 +221,13 @@ ;;;; Definitions of predefined coding systems (make-coding-system - 'automatic-conversion 'automatic-conversion + 'undecided 'undecided "Automatic conversion." '(mnemonic "Auto")) +;; compatibility for old XEmacsen (don't use it) +(copy-coding-system 'undecided 'automatic-conversion) + (make-coding-system 'ctext 'iso2022 "Coding-system used in X as Compound Text Encoding." diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-debug.el --- a/lisp/mule/mule-debug.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-debug.el Mon Aug 13 10:03:52 2007 +0200 @@ -73,67 +73,6 @@ ; (charset-list)) ; )) -(defun describe-designation (cs register) - (let ((charset - (coding-system-property - cs (intern (format "charset-g%d" register)))) - (force - (coding-system-property - cs (intern (format "force-g%d-on-output" register))))) - (princ - (format - " G%d: %s%s\n" - register - (cond ((null charset) "never used") - ((eq t charset) "none") - (t (charset-name charset))) - (if force " (explicit designation required)" ""))))) - -;;;###autoload -(defun describe-coding-system (cs) - "Display documentation of the coding-system CS." - (interactive "zCoding-system: ") - (setq cs (get-coding-system cs)) - (with-output-to-temp-buffer "*Help*" - (princ (format "Coding-system %s [%s]:\n" - (coding-system-name cs) - (coding-system-mnemonic cs))) - (princ (format " %s\n" (coding-system-doc-string cs))) - (let ((type (coding-system-type cs))) - (princ "Type: ") (princ type) (terpri) - (case type - ('iso2022 - (princ "\nInitial designations:\n") - (dolist (register '(0 1 2 3)) - (describe-designation cs register)) - (princ "\nOther properties: \n") - (dolist (prop '(short no-ascii-eol no-ascii-cntl seven lock-shift no-iso6429)) - (princ (format " %s: " (symbol-name prop))) - (princ (coding-system-property cs prop)) - (terpri))) - ;;(princ " short: ") (princ (coding-system-short)) - ;;(princ (if (aref flags 4) "ShortForm" "LongForm")) - ;;(if (aref flags 5) (princ ", ASCII@EOL")) - ;;(if (aref flags 6) (princ ", ASCII@CNTL")) - ;;(princ (if (coding-system-seven cs) ", 7bit" ", 8bit")) - ;;(if (aref flags 8) (princ ", UseLockingShift")) - ;;(if (aref flags 9) (princ ", UseRoman")) - ;;(if (aref flags 10) (princ ", UseOldJIS")) - ;;(if (aref flags 11) (princ ", No ISO6429")) - ;;(terpri)) - - ('big5 - ;;(princ (if flags "Big-ETen\n" "Big-HKU\n"))) - )) - (princ (format "\nEOL-Type: %s\n" - (case (coding-system-eol-type cs) - ('nil "null (= LF)") - ('lf "LF") - ('crlf "CRLF") - ('cr "CR") - (t "invalid")))) - ))) - ;;;###autoload (defun list-coding-system-briefly () "Display coding-systems currently used with a brief format in mini-buffer." diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-diag.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mule/mule-diag.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,772 @@ +;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE) + +;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. +;; Copyright (C) 1997 MORIOKA Tomohiko + +;; Keywords: multilingual, charset, coding system, fontset, diagnosis + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; General utility function + +;; Print all arguments with single space separator in one line. +(defun print-list (&rest args) + (while (cdr args) + (when (car args) + (princ (car args)) + (princ " ")) + (setq args (cdr args))) + (princ (car args)) + (princ "\n")) + +;; Re-order the elements of charset-list. +(defun sort-charset-list () + (setq charset-list + (sort charset-list + (function (lambda (x y) (< (charset-id x) (charset-id y))))))) + +;;; CHARSET + +;;;###autoload +(defun list-character-sets (&optional arg) + "Display a list of all character sets. + +The ID column contains a charset identification number for internal use. +The B column contains a number of bytes occupied in a buffer. +The W column contains a number of columns occupied in a screen. + +With prefix arg, the output format gets more cryptic +but contains full information about each character sets." + (interactive "P") + (sort-charset-list) + (with-output-to-temp-buffer "*Help*" + (save-excursion + (set-buffer standard-output) + (let ((l charset-list) + charset) + (if (null arg) + (progn + (insert "ID Name B W Description\n") + (insert "-- ---- - - -----------\n") + (while l + (setq charset (car l) l (cdr l)) + (insert (format "%03d %s" (charset-id charset) charset)) + (indent-to 28) + (insert (format "%d %d %s\n" + (charset-bytes charset) + (charset-width charset) + (charset-description charset))))) + (insert "\ +######################### +## LIST OF CHARSETS +## Each line corresponds to one charset. +## The following attributes are listed in this order +## separated by a colon `:' in one line. +## CHARSET-ID, +## CHARSET-SYMBOL-NAME, +## DIMENSION (1 or 2) +## CHARS (94 or 96) +## BYTES (of multibyte form: 1, 2, 3, or 4), +## WIDTH (occupied column numbers: 1 or 2), +## DIRECTION (0:left-to-right, 1:right-to-left), +## ISO-FINAL-CHAR (character code of ISO-2022's final character) +## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR) +## DESCRIPTION (describing string of the charset) +") + (while l + (setq charset (car l) l (cdr l)) + (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n" + (charset-id charset) + charset + (charset-dimension charset) + (charset-chars charset) + (charset-bytes charset) + (charset-width charset) + (charset-direction charset) + (charset-iso-final-char charset) + (charset-iso-graphic-plane charset) + (charset-description charset)))))) + (help-mode) + (setq truncate-lines t)))) + +;;; CODING-SYSTEM + +(defun describe-designation (cs register) + (let ((charset + (coding-system-property + cs (intern (format "charset-g%d" register)))) + (force + (coding-system-property + cs (intern (format "force-g%d-on-output" register))))) + (princ + (format + " G%d: %s%s\n" + register + (cond ((null charset) "never used") + ((eq t charset) "none") + (t (charset-name charset))) + (if force " (explicit designation required)" ""))))) + +;;;###autoload +(defun describe-coding-system (coding-system) + "Display information of CODING-SYSTEM." + (interactive "zDescribe coding system (default, current choices): ") + (if (or (null coding-system) + (string= (symbol-name coding-system) "")) + (describe-current-coding-system) + (with-output-to-temp-buffer "*Help*" + (print-coding-system-briefly coding-system 'doc-string) + (let ((type (coding-system-type coding-system))) + (princ (format "Type: %s" type)) + (when (eq type 'iso2022) + (princ " (variant of ISO-2022)\n") + (princ "Initial designations:\n") + ;;(print-designation flags) + (describe-designation coding-system 0) + (describe-designation coding-system 1) + (describe-designation coding-system 2) + (describe-designation coding-system 3) + (princ "Other Form: \n ") + (princ (if (coding-system-short coding-system) + "short-form" + "long-form")) + (if (coding-system-no-ascii-eol coding-system) + (princ ", ASCII@EOL")) + (if (coding-system-no-ascii-cntl coding-system) + (princ ", ASCII@CNTL")) + (princ (if (coding-system-seven coding-system) + ", 7-bit" + ", 8-bit")) + (if (coding-system-lock-shift coding-system) + (princ ", use-locking-shift") + (princ ", use-single-shift")) + ;;(if (aref flags 10) (princ ", use-roman")) + ;;(if (aref flags 10) (princ ", use-old-jis")) + (if (coding-system-no-iso6429 coding-system) + (princ ", no-ISO6429")) + ) + (princ "\nEOL type:") + (let ((eol-type (coding-system-eol-type coding-system))) + (cond ((null eol-type) + (princ "\n Automatic selection from\n ") + (princ (format "%s-unix, %s-dos or %s-mac.\n" + coding-system coding-system coding-system)) + ) + ((symbolp eol-type) + (princ " ") + (princ eol-type)) + (t (princ "invalid\n"))))) + (save-excursion + (set-buffer standard-output) + (help-mode))))) + +;;;###autoload +(defun describe-current-coding-system-briefly () + "Display coding systems currently used in a brief format in echo area. + +The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\", +where mnemonics of the following coding systems come in this order +at the place of `..': + buffer-file-coding-system (of the current buffer) + eol-type of buffer-file-coding-system (of the current buffer) + (keyboard-coding-system) + eol-type of (keyboard-coding-system) + (terminal-coding-system) + eol-type of (terminal-coding-system) + process-coding-system for read (of the current buffer, if any) + eol-type of process-coding-system for read (of the current buffer, if any) + process-coding-system for write (of the current buffer, if any) + eol-type of process-coding-system for write (of the current buffer, if any) + default-buffer-file-coding-system + eol-type of default-buffer-file-coding-system + default-process-coding-system for read + eol-type of default-process-coding-system for read + default-process-coding-system for write + eol-type of default-process-coding-system" + (interactive) + (let* ((proc (get-buffer-process (current-buffer))) + (process-coding-systems (if proc (process-coding-system proc)))) + (message + "F[%c%c],K[%c%c],T[%c%c],P>[%c%c],P<[%c%c], default F[%c%c],P>[%c%c],P<[%c%c]" + (coding-system-mnemonic buffer-file-coding-system) + (coding-system-eol-type-mnemonic buffer-file-coding-system) + (coding-system-mnemonic (keyboard-coding-system)) + (coding-system-eol-type-mnemonic (keyboard-coding-system)) + (coding-system-mnemonic (terminal-coding-system)) + (coding-system-eol-type-mnemonic (terminal-coding-system)) + (coding-system-mnemonic (car process-coding-systems)) + (coding-system-eol-type-mnemonic (car process-coding-systems)) + (coding-system-mnemonic (cdr process-coding-systems)) + (coding-system-eol-type-mnemonic (cdr process-coding-systems)) + (coding-system-mnemonic default-buffer-file-coding-system) + (coding-system-eol-type-mnemonic default-buffer-file-coding-system) + (coding-system-mnemonic (car default-process-coding-system)) + (coding-system-eol-type-mnemonic (car default-process-coding-system)) + (coding-system-mnemonic (cdr default-process-coding-system)) + (coding-system-eol-type-mnemonic (cdr default-process-coding-system)) + ))) + +;; Print symbol name and mnemonic letter of CODING-SYSTEM by `princ'. +(defun print-coding-system-briefly (coding-system &optional doc-string) + (if (not coding-system) + (princ "nil\n") + ;; In XEmacs, coding-system has own type. + (if (coding-system-p coding-system) + (setq coding-system (coding-system-name coding-system)) + ) + ;; In XEmacs, coding-system-mnemonic returns string. + (princ (format "%s -- %s" + (coding-system-mnemonic coding-system) + coding-system)) + ;; Current XEmacs does not have `coding-system-parent'. + ;; (let ((parent (coding-system-parent coding-system))) + ;; (if parent + ;; (princ (format " (alias of %s)" parent)))) + (let ((aliases (get coding-system 'alias-coding-systems))) + (if aliases + (princ (format " %S" (cons 'alias: aliases))))) + (princ "\n") + (if (and doc-string + (setq doc-string (coding-system-doc-string coding-system))) + (princ (format " %s\n" doc-string))))) + +;;;###autoload +(defun describe-current-coding-system () + "Display coding systems currently used in a detailed format." + (interactive) + (with-output-to-temp-buffer "*Help*" + (let* ((proc (get-buffer-process (current-buffer))) + (process-coding-systems (if proc (process-coding-system proc)))) + (princ "Coding system for saving this buffer:\n ") + ;; local-variable-p of XEmacs requires 2 arguments. + (if (local-variable-p 'buffer-file-coding-system (current-buffer)) + (print-coding-system-briefly buffer-file-coding-system) + (princ "Not set locally, use the default.\n")) + (princ "Default coding system (for new files):\n ") + (print-coding-system-briefly default-buffer-file-coding-system) + (princ "Coding system for keyboard input:\n ") + (print-coding-system-briefly (keyboard-coding-system)) + (princ "Coding system for terminal output:\n ") + (print-coding-system-briefly (terminal-coding-system)) + (when (get-buffer-process (current-buffer)) + (princ "Coding systems for process I/O:\n") + (princ " encoding input to the process: ") + (print-coding-system-briefly (cdr process-coding-systems)) + (princ " decoding output from the process: ") + (print-coding-system-briefly (car process-coding-systems))) + ;;(princ "Defaults for subprocess I/O:\n") + ;;(princ " decoding: ") + ;;(print-coding-system-briefly (car default-process-coding-system)) + ;;(princ " encoding: ") + ;;(print-coding-system-briefly (cdr default-process-coding-system)) + ) + (save-excursion + (set-buffer standard-output) + + (princ + "\nPriority order for recognizing coding systems when reading files:\n") + (let ((l (coding-category-list)) ; It is function in XEmacs. + (i 1) + (coding-list nil) + coding aliases) + (while l + (setq coding (coding-category-system (car l))) ; for XEmacs + (when (not (memq coding coding-list)) + (setq coding-list (cons coding coding-list)) + (princ (format " %d. %s" i coding)) + (when (setq aliases (get coding 'alias-coding-systems)) + (princ " ") + (princ (cons 'alias: aliases))) + (terpri) + (setq i (1+ i))) + (setq l (cdr l)))) + (princ "\n Other coding systems cannot be distinguished automatically + from these, and therefore cannot be recognized automatically + with the present coding system priorities.\n\n") + + (let ((categories '(iso-7)) ; for XEmacs + ;; '(coding-category-iso-7 coding-category-iso-7-else)) + coding-system codings) + (while categories + ;; for XEmacs + (setq coding-system (coding-category-system (car categories))) + (mapcar + (function + (lambda (x) + (if (and (not (eq x coding-system)) + (get x 'no-initial-designation) + (let ((flags (coding-system-flags x))) + (not (or (aref flags 10) (aref flags 11))))) + (setq codings (cons x codings))))) + (get (car categories) 'coding-systems)) + (if codings + (let ((max-col (frame-width)) + pos) + (princ (format " The followings are decoded correctly but recognized as %s:\n " coding-system)) + (while codings + (setq pos (point)) + (insert (format " %s" (car codings))) + (when (> (current-column) max-col) + (goto-char pos) + (insert "\n ") + (goto-char (point-max))) + (setq codings (cdr codings))) + (insert "\n\n"))) + (setq categories (cdr categories)))) + + (princ "Particular coding systems specified for certain file names:\n") + (terpri) + (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n") + (princ " ---------\t--------------\t\t----------------\n") + (let ((func (lambda (operation alist) + (princ " ") + (princ operation) + (if (not alist) + (princ "\tnothing specified\n") + (while alist + (indent-to 16) + (prin1 (car (car alist))) + (indent-to 40) + (princ (cdr (car alist))) + (princ "\n") + (setq alist (cdr alist))))))) + (funcall func "File I/O" file-coding-system-alist) + (funcall func "Process I/O" process-coding-system-alist) + (funcall func "Network I/O" network-coding-system-alist)) + (help-mode)))) + +;; Print detailed information on CODING-SYSTEM. +(defun print-coding-system (coding-system &optional aliases) + (let ((type (coding-system-type coding-system)) + (eol-type (coding-system-eol-type coding-system)) + (flags (coding-system-flags coding-system)) + (base (coding-system-base coding-system))) + (if (not (eq base coding-system)) + (princ (format "%s (alias of %s)\n" coding-system base)) + (princ coding-system) + (while aliases + (princ ",") + (princ (car aliases)) + (setq aliases (cdr aliases))) + (princ (format ":%s:%c:%d:" + type + (coding-system-mnemonic coding-system) + (if (integerp eol-type) eol-type 3))) + (cond ((eq type 2) ; ISO-2022 + (let ((idx 0) + charset) + (while (< idx 4) + (setq charset (aref flags idx)) + (cond ((null charset) + (princ -1)) + ((eq charset t) + (princ -2)) + ((charsetp charset) + (princ charset)) + ((listp charset) + (princ "(") + (princ (car charset)) + (setq charset (cdr charset)) + (while charset + (princ ",") + (princ (car charset)) + (setq charset (cdr charset))) + (princ ")"))) + (princ ",") + (setq idx (1+ idx))) + (while (< idx 12) + (princ (if (aref flags idx) 1 0)) + (princ ",") + (setq idx (1+ idx))) + (princ (if (aref flags idx) 1 0)))) + ((eq type 4) ; CCL + (let (i len) + (setq i 0 len (length (car flags))) + (while (< i len) + (princ (format " %x" (aref (car flags) i))) + (setq i (1+ i))) + (princ ",") + (setq i 0 len (length (cdr flags))) + (while (< i len) + (princ (format " %x" (aref (cdr flags) i))) + (setq i (1+ i))))) + (t (princ 0))) + (princ ":") + (princ (coding-system-doc-string coding-system)) + (princ "\n")))) + +;;;###autoload +(defun list-coding-systems (&optional arg) + "Display a list of all coding systems. +It prints mnemonic letter, name, and description of each coding systems. + +With prefix arg, the output format gets more cryptic, +but contains full information about each coding systems." + (interactive "P") + (with-output-to-temp-buffer "*Help*" + (if (null arg) + (princ "\ +############################################### +# List of coding systems in the following format: +# MNEMONIC-LETTER -- CODING-SYSTEM-NAME +# DOC-STRING +") + (princ "\ +######################### +## LIST OF CODING SYSTEMS +## Each line corresponds to one coding system +## Format of a line is: +## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION +## :PRE-WRITE-CONVERSION:DOC-STRING, +## where +## NAME = coding system name +## ALIAS = alias of the coding system +## TYPE = nil (no conversion), t (undecided or automatic detection), +## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL) +## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection) +## FLAGS = +## if TYPE = 2 then +## comma (`,') separated data of the followings: +## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN, +## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429 +## else if TYPE = 4 then +## comma (`,') separated CCL programs for read and write +## else +## 0 +## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called +## +")) + (let ((bases (coding-system-list)) + ;;(coding-system-list 'base-only)) + coding-system) + (while bases + (setq coding-system (car bases)) + (if (null arg) + (print-coding-system-briefly coding-system 'doc-string) + (print-coding-system coding-system)) + (setq bases (cdr bases)))))) + +;;;###automatic +(defun list-coding-categories () + "Display a list of all coding categories." + (with-output-to-temp-buffer "*Help*" + (princ "\ +############################ +## LIST OF CODING CATEGORIES (ordered by priority) +## CATEGORY:CODING-SYSTEM +## +") + (let ((l coding-category-list)) + (while l + (princ (format "%s:%s\n" (car l) (symbol-value (car l)))) + (setq l (cdr l)))))) + +;;; FONT + +;; Print information of a font in FONTINFO. +(defun describe-font-internal (font-info &optional verbose) + (print-list "name (opened by):" (aref font-info 0)) + (print-list " full name:" (aref font-info 1)) + (let ((charset (aref font-info 2))) + (print-list " charset:" + (format "%s (%s)" charset (charset-description charset)))) + (print-list " size:" (format "%d" (aref font-info 3))) + (print-list " height:" (format "%d" (aref font-info 4))) + (print-list " baseline-offset:" (format "%d" (aref font-info 5))) + (print-list "relative-compose:" (format "%d" (aref font-info 6)))) + +;;;###autoload +(defun describe-font (fontname) + "Display information about fonts which partially match FONTNAME." + (interactive "sFontname (default, current choise for ASCII chars): ") + (or window-system + (error "No window system being used")) + (when (or (not fontname) (= (length fontname) 0)) + (setq fontname (cdr (assq 'font (frame-parameters)))) + (if (query-fontset fontname) + (setq fontname + (nth 2 (assq 'ascii (aref (fontset-info fontname) 2)))))) + (let ((font-info (font-info fontname))) + (if (null font-info) + (message "No matching font") + (with-output-to-temp-buffer "*Help*" + (describe-font-internal font-info 'verbose))))) + +;; Print information of FONTSET. If optional arg PRINT-FONTS is +;; non-nil, print also names of all fonts in FONTSET. This function +;; actually INSERT such information in the current buffer. +(defun print-fontset (fontset &optional print-fonts) + (let* ((fontset-info (fontset-info fontset)) + (size (aref fontset-info 0)) + (height (aref fontset-info 1)) + (fonts (and print-fonts (aref fontset-info 2))) + (xlfd-fields (x-decompose-font-name fontset)) + style) + (if xlfd-fields + (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum)) + (slant (aref xlfd-fields xlfd-regexp-slant-subnum))) + (if (string-match "^bold$\\|^demibold$" weight) + (setq style (concat weight " ")) + (setq style "medium ")) + (cond ((string-match "^i$" slant) + (setq style (concat style "italic"))) + ((string-match "^o$" slant) + (setq style (concat style "slant"))) + ((string-match "^ri$" slant) + (setq style (concat style "reverse italic"))) + ((string-match "^ro$" slant) + (setq style (concat style "reverse slant"))))) + (setq style " ? ")) + (beginning-of-line) + (insert fontset) + (indent-to 58) + (insert (if (> size 0) (format "%2dx%d" size height) " -")) + (indent-to 64) + (insert style "\n") + (when print-fonts + (insert " O Charset / Fontname\n" + " - ------------------\n") + (sort-charset-list) + (let ((l charset-list) + charset font-info opened fontname) + (while l + (setq charset (car l) l (cdr l)) + (setq font-info (assq charset fonts)) + (if (null font-info) + (setq opened ?? fontname "not specified") + (if (nth 2 font-info) + (if (stringp (nth 2 font-info)) + (setq opened ?o fontname (nth 2 font-info)) + (setq opened ?- fontname (nth 1 font-info))) + (setq opened ?x fontname (nth 1 font-info)))) + (insert (format " %c %s\n %s\n" + opened charset fontname))))))) + +;;;###autoload +(defun describe-fontset (fontset) + "Display information of FONTSET. + +It prints name, size, and style of FONTSET, and lists up fonts +contained in FONTSET. + +The column WDxHT contains width and height (pixels) of each fontset +\(i.e. those of ASCII font in the fontset). The letter `-' in this +column means that the corresponding fontset is not yet used in any +frame. + +The O column of each font contains one of the following letters. + o -- font already opened + - -- font not yet opened + x -- font can't be opened + ? -- no font specified + +The Charset column of each font contains a name of character set +displayed by the font." + (interactive + (if (not window-system) + (error "No window system being used") + (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list))) + (completion-ignore-case t)) + (list (completing-read + "Fontset (default, used by the current frame): " + fontset-list nil t))))) + (if (= (length fontset) 0) + (setq fontset (cdr (assq 'font (frame-parameters))))) + (if (not (query-fontset fontset)) + (error "Current frame is using font, not fontset")) + (let ((fontset-info (fontset-info fontset))) + (with-output-to-temp-buffer "*Help*" + (save-excursion + (set-buffer standard-output) + (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n") + (insert "------------\t\t\t\t\t\t ----- -----\n") + (print-fontset fontset t))))) + +;;;###autoload +(defun list-fontsets (arg) + "Display a list of all fontsets. + +It prints name, size, and style of each fontset. +With prefix arg, it also lists up fonts contained in each fontset. +See the function `describe-fontset' for the format of the list." + (interactive "P") + (with-output-to-temp-buffer "*Help*" + (save-excursion + (set-buffer standard-output) + (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n") + (insert "------------\t\t\t\t\t\t ----- -----\n") + (let ((fontsets (fontset-list))) + (while fontsets + (print-fontset (car fontsets) arg) + (setq fontsets (cdr fontsets))))))) + +;;;###autoload +(defun list-input-methods () + "Print information of all input methods." + (interactive) + (with-output-to-temp-buffer "*Help*" + (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n") + (princ " SHORT-DESCRIPTION\n------------------------------\n") + (setq input-method-alist + (sort input-method-alist + (function (lambda (x y) (string< (nth 1 x) (nth 1 y)))))) + (let ((l input-method-alist) + language elt) + (while l + (setq elt (car l) l (cdr l)) + (when (not (equal language (nth 1 elt))) + (setq language (nth 1 elt)) + (princ language) + (terpri)) + (princ (format " %s (`%s' in mode line)\n %s\n" + (car elt) (nth 3 elt) + (let ((title (nth 4 elt))) + (string-match ".*" title) + (match-string 0 title)))))))) + +;;; DIAGNOSIS + +;; Insert a header of a section with SECTION-NUMBER and TITLE. +(defun insert-section (section-number title) + (insert "########################################\n" + "# Section " (format "%d" section-number) ". " title "\n" + "########################################\n\n")) + +;;;###autoload +(defun mule-diag () + "Display diagnosis of the multilingual environment (MULE). + +It prints various information related to the current multilingual +environment, including lists of input methods, coding systems, +character sets, and fontsets (if Emacs running under some window +system)." + (interactive) + (with-output-to-temp-buffer "*Mule-Diagnosis*" + (save-excursion + (set-buffer standard-output) + (insert "\t###############################\n" + "\t### Diagnosis of your Emacs ###\n" + "\t###############################\n\n" + "CONTENTS: Section 1. General Information\n" + " Section 2. Display\n" + " Section 3. Input methods\n" + " Section 4. Coding systems\n" + " Section 5. Character sets\n") + (if window-system + (insert " Section 6. Fontsets\n")) + (insert "\n") + + (insert-section 1 "General Information") + (insert "Version of this emacs:\n " (emacs-version) "\n\n") + + (insert-section 2 "Display") + (if window-system + (insert "Window-system: " + (symbol-name window-system) + (format "%s" window-system-version)) + (insert "Terminal: " (getenv "TERM"))) + (insert "\n\n") + + (if (eq window-system 'x) + (let ((font (cdr (assq 'font (frame-parameters))))) + (insert "The selected frame is using the " + (if (query-fontset font) "fontset" "font") + ":\n\t" font)) + (insert "Coding system of the terminal: " + (symbol-name (terminal-coding-system)))) + (insert "\n\n") + + (insert-section 3 "Input methods") + (save-excursion (list-input-methods)) + (insert-buffer-substring "*Help*") + (insert "\n") + (if default-input-method + (insert "Default input method: " default-input-method "\n") + (insert "No default input method is specified\n")) + + (insert-section 4 "Coding systems") + (save-excursion (list-coding-systems t)) + (insert-buffer-substring "*Help*") + (save-excursion (list-coding-categories)) + (insert-buffer-substring "*Help*") + (insert "\n") + + (insert-section 5 "Character sets") + (save-excursion (list-character-sets t)) + (insert-buffer-substring "*Help*") + (insert "\n") + + (when window-system + (insert-section 6 "Fontsets") + (save-excursion (list-fontsets t)) + (insert-buffer-substring "*Help*")) + (help-mode)))) + + +;;; DUMP DATA FILE + +;;;###autoload +(defun dump-charsets () + "Dump information of all charsets into the file \"CHARSETS\". +The file is saved in the directory `data-directory'." + (let ((file (expand-file-name "CHARSETS" data-directory)) + buf) + (or (file-writable-p file) + (error "Can't write to file %s" file)) + (setq buf (find-file-noselect file)) + (save-window-excursion + (save-excursion + (set-buffer buf) + (setq buffer-read-only nil) + (erase-buffer) + (list-character-sets t) + (insert-buffer-substring "*Help*") + (let (make-backup-files + coding-system-for-write) + (save-buffer)))) + (kill-buffer buf)) + (if noninteractive + (kill-emacs))) + +;;;###autoload +(defun dump-codings () + "Dump information of all coding systems into the file \"CODINGS\". +The file is saved in the directory `data-directory'." + (let ((file (expand-file-name "CODINGS" data-directory)) + buf) + (or (file-writable-p file) + (error "Can't write to file %s" file)) + (setq buf (find-file-noselect file)) + (save-window-excursion + (save-excursion + (set-buffer buf) + (setq buffer-read-only nil) + (erase-buffer) + (list-coding-systems t) + (insert-buffer-substring "*Help*") + (list-coding-categories) + (insert-buffer-substring "*Help*") + (let (make-backup-files + coding-system-for-write) + (save-buffer)))) + (kill-buffer buf)) + (if noninteractive + (kill-emacs))) + +;;; mule-diag.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-files.el --- a/lisp/mule/mule-files.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-files.el Mon Aug 13 10:03:52 2007 +0200 @@ -26,18 +26,10 @@ ;;; Derived from mule.el in the original Mule but heavily modified ;;; by Ben Wing. -;; 1997/3/11 modified by MORIOKA Tomohiko to sync with Emacs/mule API. +;; 1997/3/11 modified by MORIOKA Tomohiko to sync with Emacs 20 API. ;;; Code: -;;;; #### also think more about `binary' vs. `no-conversion' - -;; Use `no-conversion' instead of `binary', because Emacs/mule does -;; not have `binary' coding-system. - -;; also think more about `internal'. - - (setq-default buffer-file-coding-system 'iso-2022-8) (put 'buffer-file-coding-system 'permanent-local t) @@ -49,7 +41,7 @@ 'overriding-file-coding-system 'coding-system-for-read) -(defvar buffer-file-coding-system-for-read 'automatic-conversion +(defvar buffer-file-coding-system-for-read 'undecided "Coding system used when reading a file. This provides coarse-grained control; for finer-grained control, use `file-coding-system-alist'. From a Lisp program, if you wish to @@ -66,6 +58,7 @@ '(("\\.elc$" . (binary . binary)) ("loaddefs.el$" . (binary . binary)) ("\\.tar$" . (binary . binary)) + ("TUTORIAL\\.hr$" . iso-8859-2) ;; ("\\.\\(el\\|emacs\\|info\\(-[0-9]+\\)?\\|texi\\)$" . iso-2022-8) ;; ("\\(ChangeLog\\|CHANGES-beta\\)$" . iso-2022-8) ("\\.\\(gz\\|Z\\)$" . binary) @@ -194,7 +187,7 @@ (if (re-search-forward "^From" nil 'move) (beginning-of-line)) (setq end (point)) - (decode-coding-region start end 'automatic-conversion)))))) + (decode-coding-region start end 'undecided)))))) (defun find-coding-system-magic-cookie () "Look for the coding-system magic cookie in the current buffer.\n" @@ -209,15 +202,38 @@ "charsets." (save-excursion (goto-char (point-min)) - (let ((case-fold-search nil)) - (if (search-forward ";;;###coding system: " (+ (point-min) 3000) t) - (let ((start (point)) - (end (progn - (skip-chars-forward "^ \t\n\r") - (point)))) - (if (> end start) - (let ((codesys (intern (buffer-substring start end)))) - (if (find-coding-system codesys) codesys)))))))) + (or (and (looking-at "^-\\*-[^\n]*coding: \\([^ \t\n;]+\\);[^\n]*-\\*-") + (let ((codesys (intern (buffer-substring + (match-beginning 1)(match-end 1))))) + (if (find-coding-system codesys) codesys))) + ;; (save-excursion + ;; (let (start end) + ;; (and (re-search-forward "^;+[ \t]*Local Variables:" nil t) + ;; (setq start (match-end 0)) + ;; (re-search-forward "\n;+[ \t]*End:") + ;; (setq end (match-beginning 0)) + ;; (save-restriction + ;; (narrow-to-region start end) + ;; (goto-char start) + ;; (re-search-forward "^;;; coding: \\([^\n]+\\)$" nil t) + ;; ) + ;; (let ((codesys + ;; (intern (buffer-substring + ;; (match-beginning 1)(match-end 1))))) + ;; (if (find-coding-system codesys) codesys)) + ;; ))) + (let ((case-fold-search nil)) + (if (search-forward + ";;;###coding system: " (+ (point-min) 3000) t) + (let ((start (point)) + (end (progn + (skip-chars-forward "^ \t\n\r") + (point)))) + (if (> end start) + (let ((codesys (intern (buffer-substring start end)))) + (if (find-coding-system codesys) codesys))) + ))) + ))) (defun load (file &optional noerror nomessage nosuffix) "Execute a file of Lisp code named FILE. @@ -251,20 +267,24 @@ ;; use string= instead of string-match to keep match-data. (if (string= ".elc" (downcase (substring path -4))) ;; if reading a byte-compiled file and we didn't find - ;; a coding-system magic cookie, then use `no-conversion'. + ;; a coding-system magic cookie, then use `binary'. ;; We need to guarantee that we never do autodetection ;; on byte-compiled files because confusion here would ;; be a very bad thing. Pre-existing byte-compiled - ;; files are always in the `no-conversion' system. + ;; files are always in the `binary' coding system. ;; Also, byte-compiled files always use `lf' to terminate ;; a line; don't risk confusion here either. - (if (not __codesys__) - (setq __codesys__ 'no-conversion)) + (or __codesys__ + (setq __codesys__ 'binary)) ;; otherwise use `buffer-file-coding-system-for-read', as normal ;; #### need to do some looking up in ;; #### file-coding-system-alist! - (if (not __codesys__) - (setq __codesys__ buffer-file-coding-system-for-read))) + (or __codesys__ + (setq __codesys__ + (or (find-file-coding-system-for-read-from-filename + file) + buffer-file-coding-system-for-read))) + ) ;; now use the internal load to actually load the file. (load-internal file noerror nomessage nosuffix __codesys__)))))) @@ -378,9 +398,9 @@ (if (null (find-coding-system coding-system)) (progn (message - "Invalid coding-system (%s), using 'automatic-conversion" + "Invalid coding-system (%s), using 'undecided" coding-system) - (setq coding-system 'automatic-conversion))) + (setq coding-system 'undecided))) (setq return-val (insert-file-contents-internal filename visit beg end replace coding-system diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-help.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mule/mule-help.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,77 @@ +;;; mule-help.el --- Mule-ized Help functions + +;; Copyright (C) 1997 by Free Software Foundation, Inc. + +;; Author: SL Baur +;; Keywords: help, internal + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Emacs 20.1 + +;;; Commentary: + +;; + +;;; Code: + +;; TUTORIAL arg is XEmacs addition +(defun help-with-tutorial (&optional arg tutorial) + "Select the Emacs learn-by-doing tutorial. +If there is a tutorial version written in the language +of the selected language environment, that version is used. +If there's no tutorial in that language, `TUTORIAL' is selected. +With arg, you are asked to select which language." + (interactive "P") + (let (lang filename file) + (if arg + (or (setq lang (read-language-name 'tutorial "Language: ")) + (error "No tutorial file of the specified language")) + (setq lang current-language-environment)) + (setq filename (or (get-language-info lang 'tutorial) + (or tutorial "TUTORIAL"))) + (setq file (expand-file-name (concat "~/" filename))) + (delete-other-windows) + (if (get-file-buffer file) + (switch-to-buffer (get-file-buffer file)) + (switch-to-buffer (create-file-buffer file)) + (setq buffer-file-name file) + (setq default-directory (expand-file-name "~/")) + (setq buffer-auto-save-file-name nil) + (insert-file-contents (expand-file-name filename data-directory)) + (goto-char (point-min)) + (search-forward "\n<<") + (beginning-of-line) + (delete-region (point) (progn (end-of-line) (point))) + (let ((n (- (window-height (selected-window)) + (count-lines (point-min) (point)) + 6))) + (if (< n 12) + (newline n) + ;; Some people get confused by the large gap. + (newline (/ n 2)) + (insert "[Middle of page left blank for didactic purposes. " + "Text continues below]") + (newline (- n (/ n 2))))) + (goto-char (point-min)) + (set-buffer-modified-p nil)))) + + +(provide 'mule-help) + +;;; mule-help.el ends here \ No newline at end of file diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-init.el --- a/lisp/mule/mule-init.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-init.el Mon Aug 13 10:03:52 2007 +0200 @@ -42,8 +42,8 @@ (require 'cl) -(setq language-environment-list - (sort (language-environment-list) 'string-lessp)) +;; (setq language-environment-list +;; (sort (language-environment-list) 'string-lessp)) ;; MULE keymap codes were moved to mule-cmds.el. @@ -84,34 +84,36 @@ (help-with-tutorial (concat "mule/TUTORIAL" (or language "")))) (defvar auto-language-alist - '(("^ja" . japanese) - ("^zh" . chinese) - ("^ko" . korean)) + '(("^ja" . "Japanese") + ("^zh" . "Chinese") + ("^ko" . "Korean")) "Alist of LANG patterns vs. corresponding language environment. Each element looks like (REGEXP . LANGUAGE-ENVIRONMENT). It the value of the environment variable LANG matches the regexp REGEXP, then `set-language-environment' is called with LANGUAGE-ENVIRONMENT.") - + (defun init-mule () "Initialize MULE environment at startup. Don't call this." (let ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG")))) (unless (or (null lang) (string-equal "C" lang)) (let ((case-fold-search t)) - (loop for elt in auto-language-alist - if (string-match (car elt) lang) - return (set-language-environment (cdr elt)))) - + (loop for elt in auto-language-alist + if (string-match (car elt) lang) + return (progn + (setq lang (substring lang 0 (match-end 0))) + (set-language-environment (cdr elt)) + ))) ;; Load a (localizable) locale-specific init file, if it exists. (load (format "locale/%s/locale-start" lang) t t))) - - (when (current-language-environment) + + (when current-language-environment ;; Translate remaining args on command line using file-name-coding-system (loop for arg in-ref command-line-args-left do (setf arg (decode-coding-string arg file-name-coding-system))) - + ;; rman seems to be incompatible with encoded text (setq Manual-use-rosetta-man nil) - + ;; Make sure ls -l output is readable by dired and encoded using ;; file-name-coding-system (add-hook @@ -120,7 +122,7 @@ (make-local-variable 'process-environment) (setenv "LC_MESSAGES" "C") (setenv "LC_TIME" "C")))) - + ;; Register avairable input methods by loading LEIM list file. (load "leim-list.el" 'noerror 'nomessage 'nosuffix) ) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-misc.el --- a/lisp/mule/mule-misc.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-misc.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,5 +1,7 @@ ;; mule-misc.el --- Miscellaneous Mule functions. +;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. ;; Copyright (C) 1995 Amdahl Corporation. ;; Copyright (C) 1995 Sun Microsystems. @@ -190,52 +192,89 @@ because its `find-charset-string' ignores ASCII charset." (delq 'ascii (charsets-in-region start end))) +(defun split-char (char) + "Return list of charset and one or two position-codes of CHAR." + (let ((charset (char-charset char))) + (if (eq charset 'ascii) + (list charset char) + (let ((i 0) + (len (charset-dimension charset)) + (code (if (integerp char) + char + (char-int char))) + dest) + (while (< i len) + (setq dest (cons (logand code 127) dest) + code (lsh code -7) + i (1+ i))) + (cons charset dest) + )))) + + +;;; Commands + +(defun set-buffer-process-coding-system (decoding encoding) + "Set coding systems for the process associated with the current buffer. +DECODING is the coding system to be used to decode input from the process, +ENCODING is the coding system to be used to encode output to the process. + +For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]." + (interactive + "zCoding-system for process input: \nzCoding-system for process output: ") + (let ((proc (get-buffer-process (current-buffer)))) + (if (null proc) + (error "no process") + (check-coding-system decoding) + (check-coding-system encoding) + (set-process-coding-system proc decoding encoding))) + (force-mode-line-update)) + ;;; Language environments -(defvar current-language-environment nil) +;; (defvar current-language-environment nil) -(defvar language-environment-list nil) +;; (defvar language-environment-list nil) -(defun current-language-environment () - "Return the current language environment as a symbol. -Returns nil if `set-language-environment' has not been called." - current-language-environment) +;; (defun current-language-environment () +;; "Return the current language environment as a symbol. +;; Returns nil if `set-language-environment' has not been called." +;; current-language-environment) -(defun language-environment-list () - "Return a list of all currently defined language environments." - language-environment-list) +;; (defun language-environment-list () +;; "Return a list of all currently defined language environments." +;; language-environment-list) -(defun language-environment-p (sym) - "True if SYM names a defined language environment." - (memq sym (language-environment-list))) +;; (defun language-environment-p (sym) +;; "True if SYM names a defined language environment." +;; (memq sym (language-environment-list))) -(defun set-language-environment (env) - "Set the current language environment to ENV." - (interactive - (list (intern (completing-read "Language environment: " - obarray 'language-environment-p - 'require-match)))) - (when (not (string= (charset-registry 'ascii) "iso8859-1")) - (set-charset-registry 'ascii "iso8859-1")) - (let ((func (get env 'set-lang-environ))) - (if (not (null func)) - (funcall func))) - (setq current-language-environment env) - (if (featurep 'egg) - (egg-lang-switch-callback)) -;; (if (featurep 'quail) -;; (quail-lang-switch-callback)) -) +;; (defun set-language-environment (env) +;; "Set the current language environment to ENV." +;; (interactive +;; (list (intern (completing-read "Language environment: " +;; obarray 'language-environment-p +;; 'require-match)))) +;; (when (not (string= (charset-registry 'ascii) "iso8859-1")) +;; (set-charset-registry 'ascii "iso8859-1")) +;; (let ((func (get env 'set-lang-environ))) +;; (if (not (null func)) +;; (funcall func))) +;; (setq current-language-environment env) +;; (if (featurep 'egg) +;; (egg-lang-switch-callback)) +;; ;; (if (featurep 'quail) +;; ;; (quail-lang-switch-callback)) +;; ) -(defun define-language-environment (env-sym doc-string enable-function) - "Define a new language environment, named by ENV-SYM. -DOC-STRING should be a string describing the environment. -ENABLE-FUNCTION should be a function of no arguments that will be called -when the language environment is made current." - (put env-sym 'lang-environ-doc-string doc-string) - (put env-sym 'set-lang-environ enable-function) - (setq language-environment-list (cons env-sym language-environment-list))) +;; (defun define-language-environment (env-sym doc-string enable-function) +;; "Define a new language environment, named by ENV-SYM. +;; DOC-STRING should be a string describing the environment. +;; ENABLE-FUNCTION should be a function of no arguments that will be called +;; when the language environment is made current." +;; (put env-sym 'lang-environ-doc-string doc-string) +;; (put env-sym 'set-lang-environ enable-function) +;; (setq language-environment-list (cons env-sym language-environment-list))) (defun define-egg-environment (env-sym doc-string enable-function) "Define a new language environment for egg, named by ENV-SYM. @@ -245,11 +284,12 @@ (put env-sym 'egg-environ-doc-string doc-string) (put env-sym 'set-egg-environ enable-function)) -(defun define-quail-environment (env-sym doc-string enable-function) - "Define a new language environment for quail, named by ENV-SYM. -DOC-STRING should be a string describing the environment. -ENABLE-FUNCTION should be a function of no arguments that will be called -when the language environment is made current." - (put env-sym 'quail-environ-doc-string doc-string) - (put env-sym 'set-quail-environ enable-function)) +;; (defun define-quail-environment (env-sym doc-string enable-function) +;; "Define a new language environment for quail, named by ENV-SYM. +;; DOC-STRING should be a string describing the environment. +;; ENABLE-FUNCTION should be a function of no arguments that will be called +;; when the language environment is made current." +;; (put env-sym 'quail-environ-doc-string doc-string) +;; (put env-sym 'set-quail-environ enable-function)) +;;; mule-misc.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-process.el --- a/lisp/mule/mule-process.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-process.el Mon Aug 13 10:03:52 2007 +0200 @@ -72,7 +72,7 @@ (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'call-process filename)) + (setq ret (funcall ret 'call-process program)) ) (cond ((consp ret) (car ret)) ((find-coding-system ret) ret) @@ -116,7 +116,7 @@ (t (make-temp-name "/tmp/emacs"))))) (unwind-protect - (let (cs-r cd-w) + (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist process-coding-system-alist) @@ -127,7 +127,7 @@ (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'call-process-region filename))) + (setq ret (funcall ret 'call-process-region program))) (cond ((consp ret) (setq cs-r (car ret) cs-w (cdr ret))) @@ -162,7 +162,7 @@ Remaining arguments are strings to give program as arguments. INCODE and OUTCODE specify the coding-system objects used in input/output from/to the process." - (let (cs-r cd-w) + (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist process-coding-system-alist) @@ -173,7 +173,7 @@ (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'start-process filename))) + (setq ret (funcall ret 'start-process program))) (cond ((consp ret) (setq cs-r (car ret) cs-w (cdr ret))) @@ -216,18 +216,29 @@ Third arg is name of the host to connect to, or its IP address. Fourth arg SERVICE is name of the service desired, or an integer specifying a port number to connect to." - (let (cs-r cd-w) + (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist network-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search (eq system-type 'vax-vms)) + pattern) (while alist - (if (string-match (car (car alist)) program) - (throw 'found (setq ret (cdr (car alist))))) + (setq pattern (car (car alist))) + (and + (cond ((numberp pattern) + (and (numberp service) + (eq pattern service))) + ((stringp pattern) + (or (and (stringp service) + (string-match pattern service)) + (and (numberp service) + (string-match pattern + (number-to-string service)))))) + (throw 'found (setq ret (cdr (car alist))))) (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'open-network-stream filename))) + (setq ret (funcall ret 'open-network-stream service))) (cond ((consp ret) (setq cs-r (car ret) cs-w (cdr ret))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/mule-vietnamese.el --- a/lisp/mule/mule-vietnamese.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -;; Vietnamese language specific setup for Mule -;; Copyright (C) 1992 Free Software Foundation, Inc. -;; This file is part of Mule (MULtilingual Enhancement of GNU Emacs). -;; This file contains European characters. - -;; Mule is free software distributed in the form of patches to GNU Emacs. -;; You can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. - -;; Mule is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; 93.5.25 created for Mule Ver.0.9.8 by K.Handa -;;; 93.7.22 modified for Mule Ver.0.9.8 by K.Handa - -(defconst viqr-regexp - "[aeiouyAEIOUY]\\([(^+]?['`?~.]\\|[(^+]\\)\\|[Dd][Dd]") - -;;;###autoload -(defun vn-compose-viqr (from to) - "Convert 'VIQR' mnemonics of the current region to -pre-composed Vietnamese characaters." - (interactive "r") - (let (quail-current-package map key def) - (quail-use-package "viqr") - (setq map (quail-map)) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward viqr-regexp 0 t) - (setq key (buffer-substring (match-beginning 0) (match-end 0))) - (setq def (lookup-key map key)) - (if (numberp def) - (if (> def 2) - (setq key (substring key 0 (1- def)) - def (lookup-key map key)))) - (if (keymapp def) - (progn - (goto-char (match-beginning 0)) - (delete-region (point) (+ (point) (length key))) - (insert (quail-get-candidate def t)))))))) - -;;;###autoload -(defun vn-compose-viqr-buffer () - (interactive) - (vn-compose-viqr (point-min) (point-max))) - -;;;###autoload -(defun vn-decompose-viqr (from to) - "Convert pre-composed Vietnamese characaters of the current region to -'VIQR' mnemonics." - (interactive "r") - (let (quail-current-package decode-map key def) - (quail-use-package "viqr") - (setq decode-map (quail-decode-map)) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward "\\cv" 0 t) - (setq def (preceding-char)) - (if (setq key (assq def decode-map)) - (progn - (delete-char -1) - (insert (cdr key)))))))) - -;;;###autoload -(defun vn-decompose-viqr-buffer () - (interactive) - (vn-decompose-viqr (point-min) (point-max))) - -;;; -(provide 'viet) -(provide 'vietnamese) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/vietnamese-hooks-1.el --- a/lisp/mule/vietnamese-hooks-1.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -;;; vietnamese-hooks-1.el --- pre-loaded support for Vietnamese, part 1. - -;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. -;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1995 Sun Microsystems. - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Mule 2.3. - -;; We have to split up the Vietnamese stuff into two files because -;; we are registering new charsets and then immediately using characters -;; from those sets. We cannot reliably expect this to work if they -;; are in the same file because of the buffering that happens while -;; reading -- the place where we use the newly-defined sets may be -;; read in before the code that creates those sets is evaluated. - -;; Vietnamese VISCII with two tables. -(make-charset 'vietnamese-lower "VISCII lower (Vietnamese)" - '(registry "VISCII1.1" - dimension 1 - chars 96 - final ?1 - graphic 1 - )) - -(make-charset 'vietnamese-upper "VISCII upper (Vietnamese)" - '(registry "VISCII1.1" - dimension 1 - chars 96 - final ?2 - graphic 1 - )) - -(modify-syntax-entry 'vietnamese-lower "w") -(modify-syntax-entry 'vietnamese-upper "w") - -(define-category ?v "Vietnamese character.") -(modify-category-entry 'vietnamese-lower ?v) -(modify-category-entry 'vietnamese-upper ?v) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/mule/vietnamese-hooks-2.el --- a/lisp/mule/vietnamese-hooks-2.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,270 +0,0 @@ -;;; vietnamese-hooks-2.el --- pre-loaded support for Vietnamese, part 2. - -;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. -;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1995 Sun Microsystems. - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Mule 2.3. - -;; See comment in vietnamese-hooks-1.el for why we split up the Vietnamese -;; stuff into two files. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; VIETNAMESE -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-ccl-program ccl-read-viscii - '(((read r0) - (loop - (write-read-repeat - r0 - [ 0 1 ?-2Æ 3 4 ?Ç ?ç 7 8 9 10 11 12 13 14 15-A - 16 17 18 19 ?-2Ö 21 22 23 24 ?Û 26 27 28 29 ?Ü 31-A - 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 - 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 - 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 - 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 - 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 - ?-2Õ ?¡ ?¢ ?£ ?¤ ?¥ ?¦ ?§ ?¨ ?© ?ª ?« ?¬ ?­ ?® ?¯-A - ?-2° ?± ?² ?µ ?þ ?¾ ?¶ ?· ?¸ ?ö ?÷ ?ï ?ü ?û ?ø ?Ï-A - ?-2õ ?-1¡ ?¢ ?£ ?¤ ?¥ ?¦ ?§ ?¨ ?© ?ª ?« ?¬ ?­ ?® ?¯-A - ?-1° ?± ?² ?-2Þ ?½ ?-1µ ?¶ ?· ?¸ ?-2ñ ?Ñ ?× ?Ø ?-1½ ?¾ ?-2ß-A - ?-2à ?á ?â ?ã ?ä ?å ?-1Æ ?Ç ?-2è ?é ?ê ?ë ?ì ?í ?î ?-1Ï-A - ?-2ð ?-1Ñ ?-2ò ?ó ?ô ?-1Õ ?Ö ?× ?Ø ?-2ù ?ú ?-1Û ?Ü ?-2ý ?-1Þ ?ß-A - ?-1à ?á ?â ?ã ?ä ?å ?æ ?ç ?è ?é ?ê ?ë ?ì ?í ?î ?ï-A - ?-1ð ?ñ ?ò ?ó ?ô ?õ ?ö ?÷ ?ø ?ù ?ú ?û ?ü ?ý ?þ ?-2æ ]))))-A - "CCL program to read VISCII 1.1") - -(define-ccl-program ccl-write-viscii - '(((read r0) - (loop - (if (r0 < 128) - (write-read-repeat r0) - (if (r0 != 154) - (write-read-repeat r0) - ((read-if (r0 == 163) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 - 176 177 178 0 0 181 182 183 184 0 0 0 0 189 190 0 - 0 0 0 0 0 0 198 199 0 0 0 0 0 0 0 207 - 0 209 0 0 0 213 214 215 216 0 0 219 220 0 222 223 - 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 - 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 0 - ])) - (if (r0 == 164) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 129 130 131 132 165 134 135 136 137 138 139 140 141 142 143 - 144 145 146 0 0 147 150 151 152 0 0 0 0 180 149 0 - 0 0 0 0 0 0 2 5 0 0 0 0 0 0 0 159 - 0 186 0 0 0 128 20 187 188 0 0 25 30 0 179 191 - 192 193 194 195 196 197 255 6 200 201 202 203 204 205 206 155 - 208 185 210 211 212 160 153 154 158 217 218 157 156 221 148 0 - ])) - (write-read-repeat r0))))))))) - "CCL program to write VISCII 1.1") - -(make-coding-system - 'viscii 'ccl - "Coding-system used for VISCII 1.1." - `(mnemonic "VISCII" - decode ,ccl-read-viscii - encode ,ccl-write-viscii)) - -(make-coding-system - 'viqr 'no-conversion - "Coding-system used for VIQR." - '(mnemonic "VIQR" - eol-type lf - post-read-conversion vn-compose-viqr - pre-write-conversion vn-decompose-viqr)) - -(define-ccl-program ccl-read-vscii - '(((read r0) - (loop - (write-read-repeat r0 - [0 ?-2ú ?ø 3 ?× ?Ø ?æ 7 8 9 10 11 12 13 14 15-A - 16 ?-2Ñ ?ß ?Ï ?Ö ?Û ?ý ?Ü 24 25 26 27 28 29 30 31-A - 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 - 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 - 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 - 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 - 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 - ?-2à ?ä ?ã ?á ?Õ ?£ ?§ ?è ?ë ?¨ ?é ?© ?® ?ì ?ï ?î-A - ?-2í ?¸ ?ò ?ö ?õ ?ó ?÷ ?µ ?¶ ?· ?Þ ?¾ ?þ ?ù ?ü ?û-A - 160 ?-2å ?â ?ê ?ô ?½ ?ß ?ð ?-1å ?â ?ê ?ô ?¾ ?ù ?ð ?-2¢-A - 192 193 194 195 196 ?-1à ?ä ?ã ?á ?Õ ?-2Æ ?-1¢ ?Æ ?Ç ?¡ ?-2Ç-A - ?-2¡ ?¥ ?¦ ?ç ?¥ ?« ?-1£ ?¥ ?¦ ?ç ?¤ ?§ ?è ?-2¬ ?-1ë ?¨-A - ?-1é ?© ?« ?¬ ?­ ?ª ?® ?ì ?ï ?-2­ ?ª ?° ?-1î ?í ?¸ ?ò-A - ?-2± ?-1ö ?õ ?ó ?÷ ?° ?± ?² ?¯ ?µ ?¶ ?· ?Þ ?¾ ?þ ?ù-A - ?-2² ?-1ü ?û ?ú ?ø ?× ?Ø ?æ ?Ñ ?ñ ?Ï ?Ö ?Û ?ý ?Ü ?-2¯]))))-A - "CCL program to read VSCII-1.") - -(define-ccl-program ccl-write-vscii - '(((read r0) - (loop - (if (r0 < 128) - (write-read-repeat r0) - (if (r0 != 154) - (write-read-repeat r0) - (read-if (r0 == 163) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 190 187 198 202 199 200 203 207 209 213 210 211 212 214 232 - 229 230 231 0 0 233 234 235 222 0 0 0 0 0 237 0 - 0 0 0 0 0 0 188 189 0 0 0 0 0 0 0 250 - 0 248 0 0 0 185 251 245 246 0 0 252 254 0 236 0 - 181 184 169 183 182 168 247 201 204 208 170 206 215 221 220 216 - 174 249 223 227 171 226 225 228 244 239 243 242 241 253 238 0 - ])) - (if (r0 == 164) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 192 175 133 0 196 194 134 137 139 218 197 205 217 140 255 - 219 224 240 0 0 151 152 153 145 0 0 0 0 165 155 0 - 0 0 0 0 0 0 186 191 0 0 0 0 0 0 0 19 - 0 17 0 0 0 132 20 4 5 0 0 21 23 0 154 166 - 128 131 162 130 129 161 6 195 135 138 163 136 141 144 143 142 - 167 0 146 149 164 148 147 150 2 157 1 159 158 22 156 0 - ])) - (write-read-repeat r0)))))))) - "CCL program to write VSCII-1.") - -(make-coding-system - 'vscii 'ccl - "Coding-system used for VSCII 1.1." - `(mnemonic "VSCII" - decode ,ccl-read-vscii - encode ,ccl-write-vscii)) - -(define-ccl-program ccl-vietnamese-lower-to-viscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 - 176 177 178 0 0 181 182 183 184 0 0 0 0 189 190 0 - 0 0 0 0 0 0 198 199 0 0 0 0 0 0 0 207 - 0 209 0 0 0 213 214 215 216 0 0 219 220 0 222 223 - 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 - 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 0 - ]))) - "CCL program to convert chars of 'vietnamese-lower to VISCII 1.1 font") - -(define-ccl-program ccl-vietnamese-upper-to-viscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 - 144 145 146 0 0 147 150 151 152 0 0 0 0 180 149 0 - 0 0 0 0 0 0 2 5 0 0 0 0 0 0 0 159 - 0 186 0 0 0 128 20 187 188 0 0 25 30 0 179 191 - 192 193 194 195 196 197 255 6 200 201 202 203 204 205 206 155 - 208 185 210 211 212 160 153 154 158 217 218 157 156 221 148 0 - ]))) - "CCL program to convert chars of 'vietnamese-upper to VISCII 1.1 font") - -(define-ccl-program ccl-vietnamese-lower-to-vscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 190 187 198 202 199 200 203 207 209 213 210 211 212 214 232 - 229 230 231 0 0 233 234 235 222 0 0 0 0 0 237 0 - 0 0 0 0 0 0 188 189 0 0 0 0 0 0 0 250 - 0 248 0 0 0 185 251 245 246 0 0 252 254 0 236 0 - 181 184 169 183 182 168 247 201 204 208 170 206 215 221 220 216 - 174 249 223 227 171 226 225 228 244 239 243 242 241 253 238 0 - ]))) - "CCL program to convert chars of 'vietnamese-lower to VSCII-1 font.") - -(define-ccl-program ccl-vietnamese-upper-to-vscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 192 175 133 0 196 194 134 137 139 218 197 205 217 140 255 - 219 224 240 0 0 151 152 153 145 0 0 0 0 165 155 0 - 0 0 0 0 0 0 186 191 0 0 0 0 0 0 0 19 - 0 17 0 0 0 132 20 4 5 0 0 21 23 0 154 166 - 128 131 162 130 129 161 6 195 135 138 163 136 141 144 143 142 - 167 0 146 149 164 148 147 150 2 157 1 159 158 22 156 0 - ]))) - "CCL program to convert chars of 'vietnamese-upper to VSCII-1 font.") - -;; For VISCII users -(set-charset-ccl-program 'vietnamese-lower ccl-vietnamese-lower-to-viscii) -(set-charset-ccl-program 'vietnamese-upper ccl-vietnamese-upper-to-viscii) -;; For VSCII users -;; (set-charset-ccl-program 'vietnamese-lower ccl-vietnamese-lower-to-vscii) -;; (set-charset-ccl-program 'vietnamese-upper ccl-vietnamese-upper-to-vscii) - -(add-hook 'quail-package-alist '("viqr" "quail-viet")) - -(define-language-environment 'vietnamese - "Vietnamese" - (lambda () - ;; For VISCII users - (set-coding-category-system 'no-conversion 'viscii) - ;; For VSCII users - ;; (setq coding-category-system 'binary 'vscii) - (set-coding-priority-list '(no-conversion)) - (set-default-buffer-file-coding-system 'viscii) - (setq-default quail-current-package (assoc "viqr" quail-package-alist)))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/add-log.el --- a/lisp/packages/add-log.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/add-log.el Mon Aug 13 10:03:52 2007 +0200 @@ -113,7 +113,9 @@ "Keymap for Change Log major mode.") (if change-log-mode-map nil - (setq change-log-mode-map (make-sparse-keymap))) + (setq change-log-mode-map (make-sparse-keymap)) + (define-key change-log-mode-map "\C-c\C-c" 'change-log-exit) + (define-key change-log-mode-map "\C-c\C-k" 'change-log-cancel)) (defvar change-log-time-zone-rule nil "Time zone used for calculating change log time stamps. @@ -270,6 +272,8 @@ (substring buffer-file-name (match-end 0)) (file-name-nondirectory buffer-file-name)))) + (push-window-configuration) + (if (and other-window (not (equal file-name buffer-file-name))) (find-file-other-window file-name) (find-file file-name)) @@ -387,8 +391,30 @@ (set (make-local-variable 'adaptive-fill-regexp) "\\s *") ;;(set (make-local-variable 'font-lock-defaults) ;;'(change-log-font-lock-keywords t)) + (when (boundp 'filladapt-mode) + ;; Filladapt works badly with ChangeLogs. Still, we disable it + ;; before change-log-mode-hook, so the users can override this + ;; choice. + (setq filladapt-mode nil)) (run-hooks 'change-log-mode-hook)) +(defun change-log-exit () + "Save the change-log buffer, and restores the old window configuration. +Buries the buffer." + (interactive) + (save-buffer) + (let ((buf (current-buffer))) + (pop-window-configuration) + (bury-buffer buf))) + +(defun change-log-cancel () + "Cancel the changes to change-log buffer. +This kills the buffer without saving, and restores the old window + configuration." + (interactive) + (kill-buffer (current-buffer)) + (pop-window-configuration)) + ;; It might be nice to have a general feature to replace this. The idea I ;; have is a variable giving a regexp matching text which should not be ;; moved from bol by filling. change-log-mode would set this to "^\\s *\\s(". diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/auto-autoloads.el --- a/lisp/packages/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -1112,7 +1112,7 @@ ;;;### (autoloads (gnuserv-start gnuserv-running-p) "gnuserv" "packages/gnuserv.el") -(defcustom gnuserv-frame nil "*The frame to be used to display all edited files.\nIf nil, then a new frame is created for each file edited.\nIf t, then the currently selected frame will be used.\nIf a function, then this will be called with a symbol `x' or `tty' as the\nonly argument, and its return value will be interpreted as above." :tag "Gnuserv Frame" :type '(radio (const :tag "Create new frame each time" nil) (const :tag "Use selected frame" t) (function-item :tag "Use main Emacs frame" gnuserv-main-frame-function) (function-item :tag "Use visible frame, otherwise create new" gnuserv-visible-frame-function) (function-item :tag "Create special Gnuserv frame and use it" gnuserv-special-frame-function) (function :tag "Other")) :group 'gnuserv) +(defcustom gnuserv-frame nil "*The frame to be used to display all edited files.\nIf nil, then a new frame is created for each file edited.\nIf t, then the currently selected frame will be used.\nIf a function, then this will be called with a symbol `x' or `tty' as the\nonly argument, and its return value will be interpreted as above." :tag "Gnuserv Frame" :type '(radio (const :tag "Create new frame each time" nil) (const :tag "Use selected frame" t) (function-item :tag "Use main Emacs frame" gnuserv-main-frame-function) (function-item :tag "Use visible frame, otherwise create new" gnuserv-visible-frame-function) (function-item :tag "Create special Gnuserv frame and use it" gnuserv-special-frame-function) (function :tag "Other")) :group 'gnuserv :group 'frames) (autoload 'gnuserv-running-p "gnuserv" "\ Return non-nil if a gnuserv process is running from this XEmacs session." nil nil) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/backup-dir.el --- a/lisp/packages/backup-dir.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/backup-dir.el Mon Aug 13 10:03:52 2007 +0200 @@ -96,7 +96,6 @@ ;;; It does not work under ms-dos. - (byte-compiler-options (optimize t) (warnings (- free-vars)) ; Don't warn about free variables @@ -106,23 +105,42 @@ ;;; New variables affecting backup file behavior ;;; This is the only user-customizable variable for this package. ;;; -(defvar bkup-backup-directory-info nil - "Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...)) +(defcustom bkup-backup-directory-info nil + "*Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...)) If the filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t, -then BACKUP-DIR is used as the path for its backups. Directories may -begin with \"/\" to specify an absolute pathname. If BACKUP-DIR does -not exist and OPTIONS contains the symbol `ok-create', then it is created if possible. -Otherwise the usual behavior (backup in the same directory as the file) -results. If OPTIONS contains the symbol `full-path', then the full path of the file +then BACKUP-DIR is used as the path for its backups. + +Directories may begin with \"/\" to specify an absolute pathname. + +If BACKUP-DIR does not exist and OPTIONS contains the symbol `ok-create', +then it is created if possible. Otherwise the usual behavior (backup in the +same directory as the file) results. + +If OPTIONS contains the symbol `full-path', then the full path of the file being backed up is prepended to the backup file name, with each \"/\" -replaced by a \"!\". This is intended for cases where an absolute backup path -is used. If OPTIONS contains the symbol `search-upward' and the backup -directory BACKUP-DIR is a relative path, then a directory with that name is -searched for starting at the current directory and proceeding upward (.., -../.., etc) until one is found of that name or the root is reached, and if -one is found it is used as the backup directory. Finally, if no FILE-REGEXP -matches the file name being backed up, then the usual behavior results.") +replaced by a \"!\". This is intended for cases where an absolute backup +path is used. + +If OPTIONS contains the symbol `search-upward' and the backup directory +BACKUP-DIR is a relative path, then a directory with that name is searched +for starting at the current directory and proceeding upward (.., ../.., etc) +until one is found of that name, or the root is reached, and if one is found +it is used as the backup directory. + +Finally, if no FILE-REGEXP matches the file name being backed up, then the +usual behavior results. +Once you save this variable with `M-x customize-variable', +`backup-dir' will be loaded for you each time you start XEmacs." + :type '(repeat + (list (regexp :tag "File regexp") + (string :tag "Backup Dir") + (set :inline t + (const ok-create) + (const full-path) + (const search-upward)))) + :require 'backup-dir + :group 'backup) ;;; New functions ;;; diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/custom-load.el --- a/lisp/packages/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,99 +1,100 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:22 1997 ;;; Code: -(custom-put 'extensions 'custom-loads '("iswitchb" "page-ext" "time-stamp")) -(custom-put 'change-log 'custom-loads '("add-log")) -(custom-put 'filladapt 'custom-loads '("filladapt")) -(custom-put 'copyright 'custom-loads '("upd-copyr")) -(custom-put 'recent-files-menu 'custom-loads '("recent-files")) -(custom-put 'mouse 'custom-loads '("avoid")) -(custom-put 'tex 'custom-loads '("texnfo-tex")) -(custom-put 'tar 'custom-loads '("tar-mode")) -(custom-put 'etags 'custom-loads '("etags")) -(custom-put 'igrep 'custom-loads '("igrep")) -(custom-put 'menu 'custom-loads '("recent-files")) -(custom-put 'minibuffer 'custom-loads '("icomplete")) -(custom-put 'environment 'custom-loads '("gnuserv")) -(custom-put 'texinfo 'custom-loads '("texnfo-tex")) -(custom-put 'terminals 'custom-loads '("gnuserv")) -(custom-put 'auto-save 'custom-loads '("auto-save")) -(custom-put 'ispell 'custom-loads '("ispell")) -(custom-put 'mail 'custom-loads '("feedmail" "metamail" "supercite")) -(custom-put 'ps-print-face 'custom-loads '("ps-print")) -(custom-put 'crypt 'custom-loads '("crypt")) -(custom-put 'object 'custom-loads '("gopher")) -(custom-put 'man 'custom-loads '("man")) -(custom-put 'lpr 'custom-loads '("lpr")) -(custom-put 'ps-print-header 'custom-loads '("ps-print")) -(custom-put 'docs 'custom-loads '("hyper-apropos" "info" "makeinfo")) -(custom-put 'completion 'custom-loads '("completion")) -(custom-put 'tools 'custom-loads '("add-log" "autoinsert" "compile" "diff" "etags" "func-menu" "generic-sc" "hyper-apropos" "rcompile")) -(custom-put 'recent-files 'custom-loads '("recent-files")) -(custom-put 'display-time-balloon 'custom-loads '("time")) -(custom-put 'dabbrev 'custom-loads '("dabbrev")) -(custom-put 'display-time 'custom-loads '("time")) -(custom-put 'hypermedia 'custom-loads '("gopher" "metamail")) -(custom-put 'save-place 'custom-loads '("saveplace")) -(custom-put 'lisp 'custom-loads '("func-menu" "hyper-apropos")) -(custom-put 'jka-compr 'custom-loads '("jka-compr")) -(custom-put 'diff 'custom-loads '("diff")) -(custom-put 'supercite-cite 'custom-loads '("supercite")) -(custom-put 'applications 'custom-loads '("time")) -(custom-put 'paren-matching 'custom-loads '("paren")) -(custom-put 'time-stamp 'custom-loads '("time-stamp")) -(custom-put 'avoid 'custom-loads '("avoid")) -(custom-put 'help 'custom-loads '("hyper-apropos" "info" "man")) -(custom-put 'supercite 'custom-loads '("supercite")) -(custom-put 'generic-sc 'custom-loads '("generic-sc")) -(custom-put 'local 'custom-loads '("gopher")) -(custom-put 'keyboard 'custom-loads '("pending-del")) -(custom-put 'hyper-apropos-faces 'custom-loads '("hyper-apropos")) -(custom-put 'data 'custom-loads '("auto-save" "jka-compr" "saveplace" "tar-mode" "time-stamp")) -(custom-put 'ps-print 'custom-loads '("ps-print")) -(custom-put 'compression 'custom-loads '("jka-compr")) -(custom-put 'comm 'custom-loads '("gopher")) -(custom-put 'ps-print-font 'custom-loads '("ps-print")) -(custom-put 'frames 'custom-loads '("balloon-help" "desktop")) -(custom-put 'supercite-attr 'custom-loads '("supercite")) -(custom-put 'bookmarks 'custom-loads '("bookmark")) -(custom-put 'desktop 'custom-loads '("desktop")) -(custom-put 'abbrev 'custom-loads '("dabbrev")) -(custom-put 'remote-compile 'custom-loads '("rcompile")) -(custom-put 'programming 'custom-loads '("compile")) -(custom-put 'metamail 'custom-loads '("metamail")) -(custom-put 'icomplete 'custom-loads '("icomplete")) -(custom-put 'compilation 'custom-loads '("compile")) -(custom-put 'iswitchb 'custom-loads '("iswitchb")) -(custom-put 'makeinfo 'custom-loads '("makeinfo")) -(custom-put 'fume 'custom-loads '("func-menu")) -(custom-put 'auto-insert 'custom-loads '("autoinsert")) -(custom-put 'files 'custom-loads '("auto-save" "recent-files")) -(custom-put 'fast-lock 'custom-loads '("fast-lock")) -(custom-put 'gnuserv 'custom-loads '("gnuserv")) -(custom-put 'ps-print-horizontal 'custom-loads '("ps-print")) -(custom-put 'maint 'custom-loads '("add-log" "upd-copyr")) -(custom-put 'fill 'custom-loads '("filladapt")) -(custom-put 'balloon-help 'custom-loads '("balloon-help")) -(custom-put 'supercite-hooks 'custom-loads '("supercite")) -(custom-put 'texinfo-tex 'custom-loads '("texnfo-tex")) -(custom-put 'faces 'custom-loads '("fast-lock" "hyper-apropos" "ps-print")) -(custom-put 'pages 'custom-loads '("page-ext")) -(custom-put 'supercite-frames 'custom-loads '("supercite")) -(custom-put 'feedmail 'custom-loads '("feedmail")) -(custom-put 'processes 'custom-loads '("compile" "gnuserv" "igrep" "ispell" "metamail" "rcompile")) -(custom-put 'news 'custom-loads '("supercite")) -(custom-put 'hyper-apropos 'custom-loads '("hyper-apropos")) -(custom-put 'wp 'custom-loads '("lpr" "ps-print")) -(custom-put 'ps-print-vertical 'custom-loads '("ps-print")) -(custom-put 'gopher 'custom-loads '("gopher")) -(custom-put 'editing 'custom-loads '("bookmark")) -(custom-put 'matching 'custom-loads '("paren" "completion" "hyper-apropos")) -(custom-put 'ps-print-color 'custom-loads '("ps-print")) -(custom-put 'info 'custom-loads '("info")) -(custom-put 'unix 'custom-loads '("tar-mode")) -(custom-put 'c 'custom-loads '("func-menu")) +(custom-add-loads 'extensions '("iswitchb" "page-ext" "time-stamp")) +(custom-add-loads 'change-log '("add-log")) +(custom-add-loads 'filladapt '("filladapt")) +(custom-add-loads 'copyright '("upd-copyr")) +(custom-add-loads 'info-faces '("info")) +(custom-add-loads 'recent-files-menu '("recent-files")) +(custom-add-loads 'mouse '("avoid")) +(custom-add-loads 'tex '("texnfo-tex")) +(custom-add-loads 'tar '("tar-mode")) +(custom-add-loads 'etags '("etags")) +(custom-add-loads 'igrep '("igrep")) +(custom-add-loads 'menu '("recent-files")) +(custom-add-loads 'minibuffer '("icomplete")) +(custom-add-loads 'environment '("gnuserv")) +(custom-add-loads 'texinfo '("texnfo-tex")) +(custom-add-loads 'terminals '("gnuserv")) +(custom-add-loads 'auto-save '("auto-save")) +(custom-add-loads 'ispell '("ispell")) +(custom-add-loads 'mail '("feedmail" "metamail" "supercite")) +(custom-add-loads 'ps-print-face '("ps-print")) +(custom-add-loads 'crypt '("crypt")) +(custom-add-loads 'object '("gopher")) +(custom-add-loads 'man '("man")) +(custom-add-loads 'lpr '("lpr")) +(custom-add-loads 'ps-print-header '("ps-print")) +(custom-add-loads 'docs '("hyper-apropos" "info" "makeinfo")) +(custom-add-loads 'completion '("completion")) +(custom-add-loads 'tools '("add-log" "autoinsert" "compile" "diff" "etags" "func-menu" "generic-sc" "hyper-apropos" "rcompile")) +(custom-add-loads 'recent-files '("recent-files")) +(custom-add-loads 'display-time-balloon '("time")) +(custom-add-loads 'dabbrev '("dabbrev")) +(custom-add-loads 'display-time '("time")) +(custom-add-loads 'hypermedia '("gopher" "metamail")) +(custom-add-loads 'save-place '("saveplace")) +(custom-add-loads 'lisp '("func-menu" "hyper-apropos")) +(custom-add-loads 'jka-compr '("jka-compr")) +(custom-add-loads 'diff '("diff")) +(custom-add-loads 'supercite-cite '("supercite")) +(custom-add-loads 'applications '("time")) +(custom-add-loads 'paren-matching '("paren")) +(custom-add-loads 'time-stamp '("time-stamp")) +(custom-add-loads 'avoid '("avoid")) +(custom-add-loads 'help '("hyper-apropos" "info" "man")) +(custom-add-loads 'supercite '("supercite")) +(custom-add-loads 'generic-sc '("generic-sc")) +(custom-add-loads 'local '("gopher")) +(custom-add-loads 'keyboard '("pending-del")) +(custom-add-loads 'hyper-apropos-faces '("hyper-apropos")) +(custom-add-loads 'data '("auto-save" "jka-compr" "saveplace" "tar-mode" "time-stamp")) +(custom-add-loads 'ps-print '("ps-print")) +(custom-add-loads 'compression '("jka-compr")) +(custom-add-loads 'comm '("gopher")) +(custom-add-loads 'ps-print-font '("ps-print")) +(custom-add-loads 'backup '("backup-dir")) +(custom-add-loads 'frames '("gnuserv" "balloon-help" "desktop")) +(custom-add-loads 'supercite-attr '("supercite")) +(custom-add-loads 'bookmarks '("bookmark")) +(custom-add-loads 'desktop '("desktop")) +(custom-add-loads 'abbrev '("dabbrev")) +(custom-add-loads 'remote-compile '("rcompile")) +(custom-add-loads 'programming '("compile")) +(custom-add-loads 'metamail '("metamail")) +(custom-add-loads 'icomplete '("icomplete")) +(custom-add-loads 'compilation '("compile")) +(custom-add-loads 'iswitchb '("iswitchb")) +(custom-add-loads 'makeinfo '("makeinfo")) +(custom-add-loads 'fume '("func-menu")) +(custom-add-loads 'auto-insert '("autoinsert")) +(custom-add-loads 'files '("recent-files")) +(custom-add-loads 'fast-lock '("fast-lock")) +(custom-add-loads 'gnuserv '("gnuserv")) +(custom-add-loads 'ps-print-horizontal '("ps-print")) +(custom-add-loads 'maint '("add-log" "upd-copyr")) +(custom-add-loads 'fill '("filladapt")) +(custom-add-loads 'balloon-help '("balloon-help")) +(custom-add-loads 'supercite-hooks '("supercite")) +(custom-add-loads 'texinfo-tex '("texnfo-tex")) +(custom-add-loads 'faces '("fast-lock" "hyper-apropos" "info" "ps-print")) +(custom-add-loads 'pages '("page-ext")) +(custom-add-loads 'supercite-frames '("supercite")) +(custom-add-loads 'feedmail '("feedmail")) +(custom-add-loads 'processes '("compile" "gnuserv" "igrep" "ispell" "metamail" "rcompile")) +(custom-add-loads 'news '("supercite")) +(custom-add-loads 'hyper-apropos '("hyper-apropos")) +(custom-add-loads 'wp '("lpr" "ps-print")) +(custom-add-loads 'ps-print-vertical '("ps-print")) +(custom-add-loads 'gopher '("gopher")) +(custom-add-loads 'editing '("bookmark")) +(custom-add-loads 'matching '("paren" "completion" "hyper-apropos")) +(custom-add-loads 'ps-print-color '("ps-print")) +(custom-add-loads 'info '("info")) +(custom-add-loads 'unix '("tar-mode")) +(custom-add-loads 'c '("func-menu")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/etags.el --- a/lisp/packages/etags.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/etags.el Mon Aug 13 10:03:52 2007 +0200 @@ -1061,7 +1061,7 @@ (defun emacs-lisp-default-tag () "Function to return a default tag for Emacs-Lisp mode." (let ((tag (or (variable-at-point) - (function-called-at-point)))) + (function-at-point)))) (if tag (symbol-name tag)))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/gnuserv.el --- a/lisp/packages/gnuserv.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/gnuserv.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,7 +1,7 @@ ;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv ;; Copyright (C) 1989-1997 Free Software Foundation, Inc. -;; Version: 3.9 +;; Version: 3.10 ;; Author: Andy Norman (ange@hplb.hpl.hp.com), originally based on server.el ;; Hrvoje Niksic ;; Maintainer: Jan Vroonhof , @@ -58,10 +58,11 @@ ;; gnudoit and gnuserv, distributed with XEmacs. ;; gnuserv.el was originally written by Andy Norman as an improvement -;; over William Sommerfeld's server.el. Since then, a number of people -;; have worked on it, including Bob Weiner, Darell Kindred, Arup -;; Mukherjee, Ben Wing and Jan Vroonhof. It was completely rewritten -;; (labeled as version 3) by Hrvoje Niksic in May 1997. +;; over William Sommerfeld's server.el. Since then, a number of +;; people have worked on it, including Bob Weiner, Darell Kindred, +;; Arup Mukherjee, Ben Wing and Jan Vroonhof. It was completely +;; rewritten (labeled as version 3) by Hrvoje Niksic in May 1997. The +;; new code will not run on GNU Emacs. ;; Jan Vroonhof July/1996 ;; ported the server-temp-file-regexp feature from server.el @@ -131,7 +132,16 @@ (function-item :tag "Create special Gnuserv frame and use it" gnuserv-special-frame-function) (function :tag "Other")) - :group 'gnuserv) + :group 'gnuserv + :group 'frames) + +(defcustom gnuserv-frame-plist nil + "*Plist of frame properties for creating a gnuserv frame." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'gnuserv + :group 'frames) (defcustom gnuserv-done-function 'kill-buffer "*Function used to remove a buffer after editing. @@ -281,7 +291,7 @@ (defun gnuserv-special-frame-function (type) "Creates a special frame for Gnuserv and returns it on later invocations." (unless (frame-live-p gnuserv-special-frame) - (setq gnuserv-special-frame (make-frame))) + (setq gnuserv-special-frame (make-frame gnuserv-frame-plist))) gnuserv-special-frame) @@ -406,7 +416,9 @@ (dest-frame (if (functionp gnuserv-frame) (funcall gnuserv-frame (car type)) gnuserv-frame)) - ;; The gnuserv-frame dependencies are ugly. + ;; The gnuserv-frame dependencies are ugly, but it's + ;; extremely hard to make that stuff cleaner without + ;; breaking everything in sight. (device (cond ((frame-live-p dest-frame) (frame-device dest-frame)) ((null dest-frame) @@ -419,7 +431,8 @@ (frame (cond ((frame-live-p dest-frame) dest-frame) ((null dest-frame) - (setq new-frame (make-frame nil device)) + (setq new-frame (make-frame gnuserv-frame-plist + device)) new-frame) (t (selected-frame)))) (client (make-gnuclient :id gnuserv-current-client diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/hyper-apropos.el --- a/lisp/packages/hyper-apropos.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/hyper-apropos.el Mon Aug 13 10:03:52 2007 +0200 @@ -533,7 +533,7 @@ (let ((fn (hyper-apropos-this-symbol)) val) (or (fboundp fn) - (setq fn (function-called-at-point))) + (setq fn (function-at-point))) (setq val (let ((enable-recursive-minibuffers t)) (completing-read (if fn (format "%s (default %s): " prompt fn) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/info.el --- a/lisp/packages/info.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/info.el Mon Aug 13 10:03:52 2007 +0200 @@ -311,6 +311,11 @@ :group 'help :group 'docs) +(defgroup info-faces nil + "The faces used by info browser." + :group 'info + :group 'faces) + (defcustom Info-inhibit-toolbar nil "*Non-nil means don't use the specialized Info toolbar." @@ -408,6 +413,14 @@ :type 'regexp :group 'info) +(defface info-node '((t (:bold t :italic t))) + "Face used for node links in info." + :group 'info-faces) + +(defface info-xref '((t (:bold t))) + "Face used for cross-references in info." + :group 'info-faces) + ;; Is this right for NT? .zip, with -c for to stdout, right? (defvar Info-suffix-list '( ("" . nil) (".info" . nil) @@ -916,6 +929,9 @@ (while buffers (kill-buffer (car buffers)) (setq buffers (cdr buffers))) + (while lbuffers + (kill-buffer (car lbuffers)) + (setq lbuffers (cdr lbuffers))) (message "Composing main Info directory...done")) (setq Info-dir-contents (buffer-string))) (setq default-directory Info-dir-contents-directory) @@ -2429,18 +2445,7 @@ (make-local-variable 'Info-current-annotation-completions) (make-local-variable 'Info-index-alternatives) (make-local-variable 'Info-history) - (if t ;; XEmacs: remove v19 test - (progn - (or (and (fboundp 'find-face) (find-face 'info-node)) - (make-face 'info-node "used for node links in info")) - (or (and (fboundp 'find-face) (find-face 'info-xref)) - (make-face 'info-xref "used for cross-references in info")) - (or (face-differs-from-default-p 'info-node) - (if (face-differs-from-default-p 'bold-italic) - (copy-face 'bold-italic 'info-node) - (copy-face 'bold 'info-node))) - (or (face-differs-from-default-p 'info-xref) - (copy-face 'bold 'info-xref)))) + ;; Faces are now defined by `defface'... (make-local-variable 'mouse-track-click-hook) (add-hook 'mouse-track-click-hook 'Info-maybe-follow-clicked-node) (add-hook 'mouse-track-click-hook 'Info-mouse-track-double-click-hook) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/jka-compr.el --- a/lisp/packages/jka-compr.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/jka-compr.el Mon Aug 13 10:03:52 2007 +0200 @@ -139,7 +139,11 @@ ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'" "zipping" "gzip" ("-c" "-q") "unzipping" "gzip" ("-c" "-q" "-d") - t t]) + t t] + ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'" + "bzipping" "bzip2" ("-f") + "unbzipping" "bzip2" ("-d") + nil t]) "List of vectors that describe available compression techniques. Each element, which describes a compression technique, is a vector of @@ -164,8 +168,8 @@ uncompress-args is a list of args to pass to the uncompress program - append-flag is non-nil if this compression technique can be - appended + append-flag is non-nil if files compressed with this technique can + be appended to without decompressing them first. auto-mode flag non-nil means strip the regexp from file names before attempting to set the mode. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/packages/man.el --- a/lisp/packages/man.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/man.el Mon Aug 13 10:03:52 2007 +0200 @@ -202,7 +202,7 @@ (let ((bufname (concat "Man" (when apropos-mode " apropos") ": " topic - (when section (concat "(" section ")") ""))) + (when section (concat "(" section ")")))) (temp-buffer-show-function (cond ((eq 't Manual-buffer-view-mode) 'view-buffer) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/pcl-cvs/pcl-cvs-xemacs.el --- a/lisp/pcl-cvs/pcl-cvs-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/pcl-cvs/pcl-cvs-xemacs.el Mon Aug 13 10:03:52 2007 +0200 @@ -42,6 +42,7 @@ ["Diff against Repository" cvs-mode-diff-cvs t] ["Diff against Backup Version" cvs-mode-diff-backup t] "----" + ["Update sources from Repository" cvs-mode-update-no-prompt t] ["Commit Changes to Repository" cvs-mode-commit t] ["Revert File from Repository" cvs-mode-undo-local-changes t] ["Add File to Repository" cvs-mode-add t] diff -r d3e9274cbc4e -r e45d5e7c476e lisp/pcl-cvs/pcl-cvs.el --- a/lisp/pcl-cvs/pcl-cvs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/pcl-cvs/pcl-cvs.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,10 +1,10 @@ ;;; ;;;#ident "@(#)OrigId: pcl-cvs.el,v 1.93 1993/05/31 22:44:00 ceder Exp " ;;; -;;;#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-3b28 $:$Id: pcl-cvs.el,v 1.6 1997/10/12 01:39:46 steve Exp $" +;;;#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-4b2 $:$Id: pcl-cvs.el,v 1.7 1997/10/31 14:53:04 steve Exp $" ;;; ;;; pcl-cvs.el -- A Front-end to CVS 1.3 or later. -;;; Release 1.05-CVS-$Name: r20-3b28 $. +;;; Release 1.05-CVS-$Name: r20-4b2 $. ;;; Copyright (C) 1991, 1992, 1993 Per Cederqvist ;;; This program is free software; you can redistribute it and/or modify @@ -126,7 +126,7 @@ ;;; END OF THINGS TO CHECK WHEN INSTALLING ;;; -------------------------------------------------------- -(defconst pcl-cvs-version "1.05-CVS-$Name: r20-3b28 $" +(defconst pcl-cvs-version "1.05-CVS-$Name: r20-4b2 $" "A string denoting the current release version of pcl-cvs.") ;; You are NOT allowed to disable this message by default. However, you @@ -139,8 +139,8 @@ (defconst cvs-startup-message (if cvs-inhibit-copyright-message - "PCL-CVS release 1.05-CVS-$Name: r20-3b28 $" - "PCL-CVS release 1.05 from CVS release $Name: r20-3b28 $. + "PCL-CVS release 1.05-CVS-$Name: r20-4b2 $" + "PCL-CVS release 1.05 from CVS release $Name: r20-4b2 $. Copyright (C) 1992, 1993 Per Cederqvist Pcl-cvs comes with absolutely no warranty; for details consult the manual. This is free software, and you are welcome to redistribute it under certain @@ -727,7 +727,7 @@ \\[cvs-mode-undo-local-changes] Revert the last checked in version - discard your changes to the file. Entry to this mode runs cvs-mode-hook. -This description is updated for release 1.05-CVS-$Name: r20-3b28 $ of pcl-cvs. +This description is updated for release 1.05-CVS-$Name: r20-4b2 $ of pcl-cvs. All bindings: \\{cvs-mode-map}" @@ -1016,7 +1016,7 @@ (insert "Pcl-cvs Version: " "@(#)OrigId: pcl-cvs.el,v 1.93 1993/05/31 22:44:00 ceder Exp\n") (insert "CVS Version: " - "@(#)lisp/pcl-cvs:$Name: r20-3b28 $:$Id: pcl-cvs.el,v 1.6 1997/10/12 01:39:46 steve Exp $\n\n") + "@(#)lisp/pcl-cvs:$Name: r20-4b2 $:$Id: pcl-cvs.el,v 1.7 1997/10/31 14:53:04 steve Exp $\n\n") (insert (format "--- Contents of stdout buffer (%d chars) ---\n" (length stdout))) (insert stdout) @@ -1469,6 +1469,10 @@ "^$") (forward-line 1)) + ((looking-at + "^Executing ssh-askpass to query the password") + (forward-line 1)) + ;; top-level parser (cond) default clause (t diff -r d3e9274cbc4e -r e45d5e7c476e lisp/pcl-cvs/string.el --- a/lisp/pcl-cvs/string.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,160 +0,0 @@ -;;;; $Id: string.el,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $ -;;;; This file contains some miscellaneous string functions - -;; Copyright (C) 1991-1995 Free Software Foundation - -;; Author: Sebastian Kremer -;; Per Cederqvist -;; Inge Wallin -;; Maintainer: elib-maintainers@lysator.liu.se -;; Created: before 9 May 1991 -;; Keywords: extensions, lisp - -;;;; This file is part of the GNU Emacs lisp library, Elib. -;;;; -;;;; GNU Elib is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; GNU Elib 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 Elib; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;;; Boston, MA 02111-1307, USA -;;;; -;;;; Author: Sebastian Kremer -;;;; sk@thp.Uni-Koeln.DE -;;;; - - -;;; Commentary: - -;;; -;;; This file is part of the elisp library Elib. -;;; It implements simple generic string functions for use in other -;;; elisp code: replace regexps in strings, split strings on regexps. -;;; - - -;;; Code: - -(provide 'string) - - -;; This function is a near-equivalent of the elisp function replace-match -;; which work on strings instead of a buffer. The FIXEDCASE parameter -;; of replace-match is not implemented. - -(defun string-replace-match (regexp string newtext &optional literal global) - "Replace first match of REGEXP in STRING with NEWTEXT. -If no match is found, nil is returned instead of the new string. - -Optional arg LITERAL non-nil means to take NEWTEXT literally. If LITERAL is -nil, character `\\' is the start of one of the following sequences: - \\\\ will be replaced by a single \\. - \\& will be replaced by the text which matched the regexp. - \\N where N is a number and 1 <= N <= 9, will be replaced - by the Nth subexpression in REGEXP. Subexpressions are grouped - inside \\( \\). - -Optional arg GLOBAL means to replace all matches instead of only the first." - - (let ((data (match-data))) - (unwind-protect - - (if global - (let ((result "") - (start 0) - matchbeginning - matchend) - (while (string-match regexp string start) - (setq matchbeginning (match-beginning 0) - matchend (match-end 0) - result (concat result - (substring string start matchbeginning) - (if literal - newtext - (elib-string-expand-newtext))) - start matchend)) - - (if matchbeginning ; matched at least once - (concat result (substring string start)) - nil)) - - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (elib-string-expand-newtext)) - (substring string (match-end 0))))) - (store-match-data data)))) - - -(defun elib-string-expand-newtext () - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT. - ;; Uses match data and fluid vars `newtext', `string'. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) - (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - - -(defun string-split (pattern string &optional limit) - "Splitting on regexp PATTERN, turn string STRING into a list of substrings. -Optional third arg LIMIT (>= 1) is a limit to the length of the -resulting list." - - (let ((data (match-data))) - (unwind-protect - (let* ((start (string-match pattern string)) - (result (list (substring string 0 start))) - (count 1) - (end (if start (match-end 0)))) - (if end ; else nothing left - (while (and (or (not (integerp limit)) - (< count limit)) - (string-match pattern string end)) - (setq start (match-beginning 0) - count (1+ count) - result (cons (substring string end start) result) - end (match-end 0) - start end))) - (if (and (or (not (integerp limit)) - (< count limit)) - end) ; else nothing left - (setq result - (cons (substring string end) result))) - (nreverse result)) - (store-match-data data)))) - -;;; string.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/about.el --- a/lisp/prim/about.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/about.el Mon Aug 13 10:03:52 2007 +0200 @@ -69,17 +69,20 @@ (kazz "IENAGA Kazuyuki" "ienaga@jsys.co.jp") (kyle "Kyle Jones" "kyle_jones@wonderworks.com") (larsi "Lars Magne Ingebrigtsen" "larsi@gnus.org") + (marcpa "Marc Paquette" "marcpa@CAM.ORG") (mly "Richard Mlynarik" "mly@adoc.xerox.com") (morioka "MORIOKA Tomohiko" "morioka@jaist.ac.jp") (mrb "Martin Buchholz" "mrb@sun.eng.com") + (ograf "Oliver Graf" "ograf@fga.de") (pez "Peter Pezaris" "pez@dwwc.com") (piper "Andy Piper" "andy@parallax.co.uk") (rickc "Rick Campbell" "rickc@lehman.com") (rossini "Anthony Rossini" "rossini@stat.sc.edu") - (shelton "Vin Shelton" "acs@acm.org") + (vin "Vin Shelton" "acs@acm.org") (sperber "Michael Sperber" "sperber@informatik.uni-tuebingen.de") (slb "SL Baur" "steve@xemacs.org") (stig "Jonathan Stigelman" "stig@hackvan.com") + (stigb "Stig Bjorlykke" "stigb@tihlde.hist.no") (thiessel "Marcus Thiessel" "thiessel@rhrk.uni-kl.de") (vladimir "Vladimir Ivanovic" "vladimir@mri.com") (wing "Ben Wing" "wing@xemacs.org") @@ -100,8 +103,11 @@ (kazz . "http://www.imasy.or.jp/~kazz/") (kyle . "http://www.wonderworks.com/kyle/") (larsi . "http://www.ifi.uio.no/~larsi/") + (marcpa . "http://www.positron911.com/products/power.htm") + (ograf . "http://www.fga.de/~ograf/") (pez . "http://www.dwwc.com/") - (shelton . "http://www.upa.org/") + (vin . "http://www.upa.org/") + (stigb . "http://www.tihlde.hist.no/~stigb/") (wget . "ftp://gnjilux.cc.fer.hr/pub/unix/util/wget/") (xemacs . "http://www.xemacs.org/")) "Some of the more important URLs.") @@ -157,7 +163,7 @@ "Remove") (widget-create 'link :help-echo "Kill buffer" :action (lambda (&rest ignore) - (bury-buffer)) + (kill-buffer (current-buffer))) "Kill")) (widget-insert " this buffer.\n") (use-local-map (make-sparse-keymap)) @@ -512,7 +518,7 @@ '(color grayscale)) "" "m") ".xpm") - data-directory)) + (locate-data-directory "photos"))) (data nil)) (unless (file-exists-p file) ;; Maybe the file is compressed? @@ -668,6 +674,14 @@ Stig likes to perch, hang from the ceiling, and climb on the walls. Stig has a cool van. Stig would like to be able to telecommute from, say, the north rim of the Grand Canyon or the midst of Baja.\n")) + (stigb + (widget-insert "\ +Currently studying computer science in Trondheim, Norway. Full time +Linux user and proud of it. XEmacs hacker light. Maintainer of the +RPM package. + +See:\t") + (about-url-link 'stigb "Visit Stig's home page")) (baw (widget-insert "\ @@ -738,6 +752,19 @@ See ") (about-url-link 'larsi "Visit the Larsissistic pages") (widget-insert ".\n")) + (marcpa + (widget-insert "\ +I work for Positron Industries Inc., Public Safety Division. +I'm part of the team producing POWER 911, a 911 emergency response +system written in Modula3:\n") + (about-url-link 'marcpa "Visit POWER 911") + (widget-insert "\ +Previously, I worked at Softimage Inc., now a Microsoft company +(eeekkk!), as a UNIX system administrator. This is where I've been +converted to NT. + +In a previous life, I was a programmer/sysadmin at CRIM (Centre de +Recherche Informatique de Montreal) for the speech recognition group.\n")) (jens (widget-insert "\ Jens did the artwork for graphics added to XEmacs 20.2 and 19.15. @@ -799,7 +826,7 @@ installed or changing his hairstyle, he does research in modern programming languages and their implementation, and hopes that one day XEmacs will speak Scheme.\n")) - (shelton + (vin (widget-insert "\ Vin maintains the XEmacs patch pages in order to bring a more stable XEmacs. (Actually, he does it 'cause it's fun and he's been @@ -813,7 +840,7 @@ to play competitive Ultimate any more, so now I've gotten roped into serving on the board of directors of the Ultimate Players Association. See ") - (about-url-link 'shelton "Visit the UPA homepage") + (about-url-link 'vin "Visit the UPA homepage") (widget-insert ".\n")) (ajc (widget-insert "\ @@ -890,6 +917,25 @@ language/package one might want. In spare time, acts as a Ph.D. (bio)statistician for money and amusement. Current position: Assistant Professor of Statistics at the University of South Carolina.\n")) + (ograf + (widget-insert "\ +I'm a student of computer sciences at the University of Koblenz. My +major is computational linguistics (human language generation and +analysis). + +I make my living as a managing director of a small but fine company +which I started two years ago with one of my friends. We provide +business network solutions based on linux servers and various other +networking products. + +Most of my spare time I spent on the development of the XEmacs DnD +events, a enhanced version of Tk called TkStep (better looks, DnD, +and more), and various other minor hacks: ISDN-tools, cd players, +python, etc... + +To see some of these have a look at ") + (about-url-link 'ograf "one of my homepages") + (widget-insert ".\n")) )) @@ -1060,11 +1106,13 @@ Otherwise, I'm, say, 35.82% professional Jazz guitar player, which means that's not the way I earn my crust, but things may very well reverse in the future ...\n") + (about-show-linked-info 'marcpa "\ +I work for Positron Industries Inc., Public Safety Division.\n") (about-show-linked-info 'pez "\ Author of SQL Mode, edit-toolbar, mailtool-mode, and various other small packages with varying degrees of usefulness.\n") (about-show-linked-info 'rickc "\ -The hacker formerly known as Rick Busdiecker, author of ILISP.\n") +The hacker formerly known as Rick Busdiecker, maintainer of ILISP.\n") (about-show-linked-info 'rossini "\ Author of the first XEmacs FAQ, as well as minor priest in the movement to get every statistician in the world to use XEmacs for @@ -1074,7 +1122,14 @@ XLispStat; configurable for nearly any other statistical language/package one might want. In spare time, acts as a Ph.D. (bio)statistician for money and amusement. Current position: -Assistant Professor of Statistics at the University of South Carolina.") +Assistant Professor of Statistics at the University of South Carolina.\n") + (about-show-linked-info 'stigb "\ +Currently studying computer science in Trondheim, Norway. Full time +Linux user and proud of it. XEmacs hacker light. Maintainer of the +RPM package.\n") + (about-show-linked-info 'ograf "\ +Is currently working on the integration of OffiX and CDE drag-and-drop +into the event system of XEmacs.\n") (flet ((print-short (name addr &optional shortinfo) (concat (about-with-face name 'italic) (about-tabs name) @@ -1273,7 +1328,6 @@ (print-short "Achim Oppelt" "aoppelt@theorie3.physik.uni-erlangen.de") (print-short "Rebecca Ore" "rebecca.ore@op.net") (print-short "Sudeep Kumar Palat" "palat@idt.unit.no") - (print-short "Marc Paquette" "Marc.Paquette@Softimage.com") (print-short "Jens-U H Petersen" "petersen@kurims.kyoto-u.ac.jp") (print-short "Joel Peterson" "tarzan@aosi.com") (print-short "Thomas A. Peterson" "tap@src.honeywell.com") @@ -1299,9 +1353,9 @@ (print-short "Cotton Seed" "cottons@cybercom.net") (print-short "Axel Seibert" "seiberta@informatik.tu-muenchen.de") (print-short "Odd-Magne Sekkingstad" "oddms@ii.uib.no") - (print-short "Vinnie Shelton" "shelton@icd.teradyne.com") (print-short "John Shen" "zfs60@cas.org") (print-short "Murata Shuuichirou" "mrt@mickey.ai.kyutech.ac.jp") + (print-short "Matt Simmons" "simmonmt@acm.org") (print-short "Dinesh Somasekhar" "somasekh@ecn.purdue.edu") (print-short "Jeffrey Sparkes" "jsparkes@bnr.ca") (print-short "Manoj Srivastava" "srivasta@pilgrim.umass.edu") @@ -1314,6 +1368,7 @@ (print-short "Raymond L. Toy" "toy@rtp.ericsson.se") (print-short "Remek Trzaska" "remek@npac.syr.edu") (print-short "TSUTOMU Nakamura" "tsutomu@rs.kyoto.omronsoft.co.jp") + (print-short "Stephen Turnbull" "turnbull@sk.tsukuba.ac.jp") (print-short "John Turner" "turner@xdiv.lanl.gov") (print-short "UENO Fumihiro" "7m2vej@ritp.ye.IHI.CO.JP") (print-short "Juan E. Villacis" "jvillaci@cs.indiana.edu") diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -126,7 +126,7 @@ Find the definition of the function near point in the current window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -137,7 +137,7 @@ Find the definition of the function near point in the other window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -148,7 +148,7 @@ Find the definition of the function near point in the another frame. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -300,9 +300,9 @@ ;;;*** -;;;### (autoloads (profile-key-sequence profile profiling-results) "profile" "prim/profile.el") +;;;### (autoloads (profile-key-sequence profile profile-results) "profile" "prim/profile.el") -(autoload 'profiling-results "profile" "\ +(autoload 'profile-results "profile" "\ Print profiling info INFO to STREAM in a pretty format. If INFO is omitted, the current profiling info is retrieved using `get-profiling-info'. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/cmdloop.el --- a/lisp/prim/cmdloop.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/cmdloop.el Mon Aug 13 10:03:52 2007 +0200 @@ -88,10 +88,14 @@ nil) ((region-active-p) (zmacs-deactivate-region)) + ((> (recursion-depth) 0) + (exit-recursive-edit)) (buffer-quit-function (funcall buffer-quit-function)) ((not (one-window-p t)) - (delete-other-windows)))) + (delete-other-windows)) + ((string-match "^ \\*" (buffer-name (current-buffer))) + (bury-buffer)))) ;;#### This should really be a ring of last errors. (defvar last-error nil diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/custom-load.el --- a/lisp/prim/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,39 +1,38 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:25 1997 ;;; Code: -(custom-put 'mouse 'custom-loads '("mouse")) -(custom-put 'minibuffer 'custom-loads '("simple" "minibuf")) -(custom-put 'log-message 'custom-loads '("simple")) -(custom-put 'environment 'custom-loads '("frame" "minibuf" "modeline" "sound")) -(custom-put 'sound 'custom-loads '("sound")) -(custom-put 'auto-save 'custom-loads '("files")) -(custom-put 'mail 'custom-loads '("simple")) -(custom-put 'editing-basics 'custom-loads '("cmdloop" "simple" "files" "lisp")) -(custom-put 'help-appearance 'custom-loads '("help")) -(custom-put 'lisp 'custom-loads '("lisp" "find-func")) -(custom-put 'help 'custom-loads '("help")) -(custom-put 'keyboard 'custom-loads '("cmdloop")) -(custom-put 'warnings 'custom-loads '("simple")) -(custom-put 'backup 'custom-loads '("files")) -(custom-put 'frames 'custom-loads '("frame" "window-xemacs" "gui")) -(custom-put 'abbrev 'custom-loads '("files")) -(custom-put 'find-function 'custom-loads '("find-func")) -(custom-put 'dired 'custom-loads '("files")) -(custom-put 'killing 'custom-loads '("simple")) -(custom-put 'paren-blinking 'custom-loads '("simple")) -(custom-put 'find-file 'custom-loads '("files")) -(custom-put 'files 'custom-loads '("files")) -(custom-put 'fill-comments 'custom-loads '("simple")) -(custom-put 'windows 'custom-loads '("window" "window-xemacs")) -(custom-put 'fill 'custom-loads '("simple")) -(custom-put 'faces 'custom-loads '("faces")) -(custom-put 'vc 'custom-loads '("files")) -(custom-put 'isearch 'custom-loads '("isearch-mode")) -(custom-put 'modeline 'custom-loads '("modeline")) -(custom-put 'editing 'custom-loads '("simple")) -(custom-put 'matching 'custom-loads '("simple" "isearch-mode")) +(custom-add-loads 'mouse '("mouse")) +(custom-add-loads 'minibuffer '("simple" "minibuf")) +(custom-add-loads 'log-message '("simple")) +(custom-add-loads 'environment '("frame" "minibuf" "modeline" "sound")) +(custom-add-loads 'sound '("sound")) +(custom-add-loads 'auto-save '("files")) +(custom-add-loads 'mail '("simple")) +(custom-add-loads 'editing-basics '("cmdloop" "simple" "files" "lisp")) +(custom-add-loads 'help-appearance '("help")) +(custom-add-loads 'lisp '("lisp" "find-func")) +(custom-add-loads 'help '("help")) +(custom-add-loads 'keyboard '("cmdloop")) +(custom-add-loads 'warnings '("simple")) +(custom-add-loads 'backup '("files")) +(custom-add-loads 'frames '("frame" "window-xemacs" "gui")) +(custom-add-loads 'abbrev '("files")) +(custom-add-loads 'find-function '("find-func")) +(custom-add-loads 'dired '("files")) +(custom-add-loads 'killing '("simple")) +(custom-add-loads 'paren-blinking '("simple")) +(custom-add-loads 'find-file '("files")) +(custom-add-loads 'files '("files")) +(custom-add-loads 'fill-comments '("simple")) +(custom-add-loads 'windows '("window" "window-xemacs")) +(custom-add-loads 'fill '("simple")) +(custom-add-loads 'faces '("faces")) +(custom-add-loads 'vc '("files")) +(custom-add-loads 'isearch '("isearch-mode")) +(custom-add-loads 'modeline '("modeline")) +(custom-add-loads 'editing '("simple")) +(custom-add-loads 'matching '("simple" "isearch-mode")) ;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/dumped-lisp.el --- a/lisp/prim/dumped-lisp.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/dumped-lisp.el Mon Aug 13 10:03:52 2007 +0200 @@ -50,6 +50,7 @@ ; `emacs-user-extension-dir' "misc" ;; (load-gc "profile") + #-mule "help-nomule" "help" ;; (load-gc "hyper-apropos") Soon... #-mule "files-nomule" @@ -111,6 +112,7 @@ #+mule "mule-files" ;; Handle process with encoding/decoding non-ascii coding-system. #+mule "mule-process" + #+mule "mule-help" ;; Load the remaining basic files. #+mule "mule-category" #+mule "mule-ccl" @@ -139,16 +141,20 @@ #+mule "language/chinese" #+mule "language/cyrillic" #+mule "language/english" - #+mule "language/ethiopic" +;; #+mule "language/ethiopic" #+mule "language/european" #+mule "language/greek" - #+mule "hebrew-hooks" + #+mule "language/hebrew" #+mule "language/japanese" #+mule "language/korean" #+mule "language/misc-lang" - #+mule "language/thai" - #+mule "vietnamese-hooks-1" - #+mule "vietnamese-hooks-2" +;; #+mule "language/thai" + #+mule "language/viet-chars" + #+mule "language/vietnamese" + + ;; Specialized language support + #+(and mule CANNA) "canna-leim" + #+(and mule wnn) "egg-leim" ;; Set up the XEmacs environment for Mule. ;; Assumes the existence of various stuff above. @@ -178,7 +184,7 @@ #+tooltalk "tooltalk/tooltalk-util" #+tooltalk "tooltalk/tooltalk-init" ;; "vc-hooks" ; Packaged. Available in two versions. - "ediff-hook" + ;; "ediff-hook" ; Packaged. "fontl-hooks" "auto-show" ;; #+energize "energize/energize-load.el" diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/faces.el --- a/lisp/prim/faces.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/faces.el Mon Aug 13 10:03:52 2007 +0200 @@ -1127,8 +1127,9 @@ (if (< (apply '+ (color-instance-rgb-components color-instance)) 65536) 'dark 'light) - ;; We'll get an error on a TTY; TTY-s are generally - ;; dark. ### That's a good one. + ;; Here, we get an error on a TTY. As we don't have + ;; a good way of detecting whether a TTY is light or + ;; dark, we'll guess it's dark. (error 'dark)))) (set-frame-property frame 'background-mode mode) mode)) @@ -1225,16 +1226,13 @@ entries (cdr entries) req (car entry) options (cdr entry) - match (cond ((eq req 'type) - (memq type options)) - ((eq req 'class) - (memq class options)) - ((eq req 'background) - (memq background options)) - (t - (warn "Unknown req `%S' with options `%S'" - req options) - nil)))) + match (case req + (type (memq type options)) + (class (memq class options)) + (background (memq background options)) + (t (warn "Unknown req `%S' with options `%S'" + req options) + nil)))) match))) (defun relevant-custom-frames () @@ -1268,7 +1266,6 @@ (get-custom-frame-properties frame)) (initialize-custom-faces frame))) - (defun make-empty-face (name &optional doc-string temporary) "Like `make-face', but doesn't query the resource database." @@ -1365,8 +1362,9 @@ ) -;; These warnings are there for a reason. -;; Just specify your fonts correctly. Deal with it. +;; These warnings are there for a reason. Just specify your fonts +;; correctly. Deal with it. Additionally, one can use +;; `log-warning-minimum-level' instead of this. ;(defvar inhibit-font-complaints nil ; "Whether to suppress complaints about incomplete sets of fonts.") @@ -1395,6 +1393,15 @@ face )))) + +;; #### This is quite a mess. We should use the custom mechanism for +;; most of this stuff. Currently we don't do it, because Custom +;; doesn't use specifiers (yet.) FSF does it the Right Way. + +;; For instance, the definition of `bold' should be something like +;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should +;; make sure that everything works properly. + (defun init-other-random-faces (device) "Initializes the colors and fonts of the bold, italic, bold-italic, zmacs-region, list-mode-item-selected, highlight, primary-selection, @@ -1416,6 +1423,10 @@ ;; the time. For many languages, italic is an alien concept. ;; Basically, because italic is not a globally meaningful concept, ;; the use of the italic face should really be oboleted. + + ;; I disagree with above. In many languages, the concept of capital + ;; letters is just as alien, and yet we use them. Italic is here to + ;; stay. -hniksic ;; In a Solaris Japanese environment, there just aren't any italic ;; fonts - period. CDE recognizes this reality, and fonts @@ -1576,10 +1587,10 @@ (setq face (signal 'wrong-type-argument (list 'facep face)))) (while (cond ((stringp pixmap) (unless (file-readable-p pixmap) - (setq pixmap (vector 'xbm ':file pixmap))) + (setq pixmap `[xbm :file ,pixmap])) nil) ((and (consp pixmap) (= (length pixmap) 3)) - (setq pixmap (vector 'xbm ':data pixmap)) + (setq pixmap `[xbm :data ,pixmap]) nil) (t t)) (setq pixmap (signal 'wrong-type-argument @@ -1595,33 +1606,24 @@ ;; The default, modeline, left-margin, right-margin, text-cursor, ;; and pointer faces are created in C. -(make-face 'bold "bold text") -(make-face 'italic "italic text") -(make-face 'bold-italic "bold-italic text") -(make-face 'underline "underlined text") +(make-face 'bold "Bold text.") +(make-face 'italic "Italic text.") +(make-face 'bold-italic "Bold-italic text.") +(make-face 'underline "Underlined text.") (or (face-differs-from-default-p 'underline) (set-face-underline-p 'underline t 'global)) -(make-face 'zmacs-region "used on defined region between point and mark") -(make-face 'isearch "used on region matched by isearch") +(make-face 'zmacs-region "Used on highlightes region between point and mark.") +(make-face 'isearch "Used on region matched by isearch.") (make-face 'list-mode-item-selected "Face for the selected list item in list-mode.") -(make-face 'highlight "highlight face") -(make-face 'primary-selection) -(make-face 'secondary-selection) +(make-face 'highlight "Highlight face.") +(make-face 'primary-selection "Primary selection face.") +(make-face 'secondary-selection "Secondary selection face.") -;; The loop macro isn't defined until loaddefs.el is read -;;(loop for color in '("red" "green" "blue" "yellow") do -;; (make-face (intern color) (concat color " text")) -;; (set-face-foreground (intern color) color nil 'color)) -(make-face 'red "red text") -(set-face-foreground 'red "red" nil 'color) -(make-face 'green "green text") -(set-face-foreground 'green "green" nil 'color) -(make-face 'blue "blue text") -(set-face-foreground 'blue "blue" nil 'color) -(make-face 'yellow "yellow text") -(set-face-foreground 'yellow "yellow" nil 'color) - +;; Several useful color faces. +(dolist (color '(red green blue yellow)) + (make-face color (concat (symbol-name color) " text.")) + (set-face-foreground color (symbol-name color) nil 'color)) ;; Make some useful faces. This happens very early, before creating ;; the first non-stream device. We initialize the tty global values here. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/featurep.el --- a/lisp/prim/featurep.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -;;; featurep.el --- Support functions for reader conditionals - -;; Copyright 1997 Naggum Software - -;; Author: Erik Naggum -;; Keywords: internal - -;; This file is not (yet) part of GNU Emacs, but distributed under the -;; same conditions as GNU Emacs, and is useless without GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The #+ and #- reader macros require support code to work properly until -;; `featurep' is enhanced in the C code. This support code is written in -;; Lisp to make it easier to experiment with the code. - -;; XEmacs: this code has been ported to C by Steve Baur. The -;; implementations should be equivalent. - - -;;; Code: - -(eval-when-compile (require 'cl)) - -(provide (if (string-match "XEmacs" emacs-version) 'xemacs 'emacs)) - -(defvar featurep-emacs-version nil - "The version number of this Emacs, as a floating-point number.") - -(defun featurep (fexp) - "Return non-nil if feature expression FEXP is true." - (typecase fexp - (symbol (and (memq fexp features) ;original definition - t)) - (number (>= (or featurep-emacs-version - (setq featurep-emacs-version - (+ emacs-major-version - (/ emacs-minor-version 100.0)))) - fexp)) - (list (case (pop fexp) - (not (let ((negate (pop fexp))) - (if fexp - (signal 'invalid-read-syntax (list fexp)) - (not (featurep negate))))) - (and (while (and fexp (featurep (car fexp))) - (pop fexp)) - (null fexp)) - (or (while (and fexp (not (featurep (car fexp)))) - (pop fexp)) - fexp) - (t (signal 'invalid-read-syntax (list fexp))))) - (t (signal 'invalid-read-syntax (list fexp))))) - -;;; featurep.el ends here - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/files.el --- a/lisp/prim/files.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/files.el Mon Aug 13 10:03:52 2007 +0200 @@ -144,7 +144,7 @@ If the file name matches one of these regular expressions, then `revert-buffer' reverts the file without querying if the file has changed on disk and you have not edited the buffer." - :type 'boolean + :type '(repeat (regexp "")) :group 'find-file) (defvar buffer-file-number nil @@ -644,8 +644,6 @@ (frame (make-frame (if name (list (cons 'name (symbol-name name))))))) (pop-to-buffer buffer t frame) - (unless focus-follows-mouse - (select-frame frame)) (make-frame-visible frame) buffer)) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/fill.el --- a/lisp/prim/fill.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/fill.el Mon Aug 13 10:03:52 2007 +0200 @@ -554,8 +554,10 @@ (setq prefixcol (current-column)))))) ;; Justify the line just ended, if desired. (if justify - (if (eobp) - (justify-current-line justify t t) + (if (save-excursion (skip-chars-forward " \t") (eobp)) + (progn + (delete-horizontal-space) + (justify-current-line justify t t)) (forward-line -1) (justify-current-line justify nil t) (forward-line 1)))))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/find-func.el --- a/lisp/prim/find-func.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/find-func.el Mon Aug 13 10:03:52 2007 +0200 @@ -8,7 +8,7 @@ ;; Created: 97/07/25 ;; URL: -;; $Id: find-func.el,v 1.1 1997/10/10 01:39:52 steve Exp $ +;; $Id: find-func.el,v 1.2 1997/10/31 14:53:07 steve Exp $ ;; This file is part of XEmacs. @@ -96,10 +96,10 @@ The library where FUNCTION is defined is searched for in `find-function-source-path', if non `nil', otherwise in `load-path'." + (if (not function) + (error "You didn't specify a function")) (and (subrp (symbol-function function)) (error "%s is a primitive function" function)) - (if (not function) - (error "You didn't specify a function")) (let ((def (symbol-function function)) library aliases) (while (symbolp def) @@ -118,7 +118,10 @@ (nth 1 def)) ((describe-function-find-file function)) ((compiled-function-p def) - (substring (compiled-function-annotation def) 0 -4)))) + (substring (compiled-function-annotation def) 0 -4)) + ((eq 'macro (car-safe def)) + (and (compiled-function-p (cdr def)) + (substring (compiled-function-annotation (cdr def)) 0 -4))))) (if (null library) (error (format "Don't know where `%s' is defined" function))) (if (string-match "\\.el\\(c\\)\\'" library) @@ -153,9 +156,8 @@ (defun find-function-read-function () "Read and return a function, defaulting to the one near point. -The function named by `find-function-function' is used to select the -default function." - (let ((fn (funcall find-function-function)) +`function-at-point' is used to select the default function." + (let ((fn (function-at-point)) (enable-recursive-minibuffers t) val) (setq val (completing-read @@ -184,7 +186,7 @@ "Find the definition of the function near point in the current window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -198,7 +200,7 @@ "Find the definition of the function near point in the other window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -212,7 +214,7 @@ "Find the definition of the function near point in the another frame. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/frame.el --- a/lisp/prim/frame.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/frame.el Mon Aug 13 10:03:52 2007 +0200 @@ -545,7 +545,8 @@ ; this is in C in FSFmacs (defun frame-list () "Return a list of all frames on all devices/consoles." - (apply 'append (mapcar 'device-frame-list (device-list)))) + ;; Lists are copies, so nconc is safe here. + (apply 'nconc (mapcar 'device-frame-list (device-list)))) (defun frame-type (&optional frame) "Return the type of the specified frame (e.g. `x' or `tty'). @@ -613,26 +614,25 @@ (list 'frame-configuration-p configuration))) (let ((config-plist (cdr configuration)) frames-to-delete) - (mapcar (function - (lambda (frame) - (let ((properties (assq frame config-plist))) - (if properties - (progn - (set-frame-properties - frame - ;; Since we can't set a frame's minibuffer status, - ;; we might as well omit the parameter altogether. - (lax-plist-remprop (nth 1 properties) 'minibuffer)) - (set-window-configuration (nth 2 properties))) - (setq frames-to-delete (cons frame frames-to-delete)))))) - (frame-list)) + (mapc (lambda (frame) + (let ((properties (assq frame config-plist))) + (if properties + (progn + (set-frame-properties + frame + ;; Since we can't set a frame's minibuffer status, + ;; we might as well omit the parameter altogether. + (lax-plist-remprop (nth 1 properties) 'minibuffer)) + (set-window-configuration (nth 2 properties))) + (setq frames-to-delete (cons frame frames-to-delete))))) + (frame-list)) (if nodelete ;; Note: making frames invisible here was tried ;; but led to some strange behavior--each time the frame ;; was made visible again, the window manager asked afresh ;; for where to put it. - (mapcar 'iconify-frame frames-to-delete) - (mapcar 'delete-frame frames-to-delete)))) + (mapc 'iconify-frame frames-to-delete) + (mapc 'delete-frame frames-to-delete)))) ; this function is in subr.el in FSFmacs. ; that's because they don't always include frame.el, while we do. @@ -1139,7 +1139,7 @@ (defun delete-other-frames (&optional frame) "Delete all but FRAME (or the selected frame)." (interactive) - (mapcar 'delete-frame (delq (or frame (selected-frame)) (frame-list)))) + (mapc 'delete-frame (delq (or frame (selected-frame)) (frame-list)))) ;; By adding primitives to directly access the window hierarchy, ;; we can move many functions into Lisp. We do it this way diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/glyphs.el --- a/lisp/prim/glyphs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/glyphs.el Mon Aug 13 10:03:52 2007 +0200 @@ -602,12 +602,12 @@ ;; initialize default image types (if (featurep 'x) (set-console-type-image-conversion-list 'x - `(,@(if (featurep 'xpm) '(("\\.xpm$\\'" [xpm :file nil] 2))) + `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2))) ("\\.xbm\\'" [xbm :file nil] 2) ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2))) ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2))) - ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2))) - ,@(if (featurep 'gif) '(("\\`GIF8[79]" [gif :data nil] 2))) + ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2) + ("\\`GIF8[79]" [gif :data nil] 2))) ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2))) ;; all of the JFIF-format JPEG's that I've seen begin with ;; the following. I have no idea if this is standard. @@ -657,7 +657,10 @@ ;; has a built-in bitmap (if (featurep 'xpm) (set-glyph-image xemacs-logo - (concat "../etc/" "xemacs.xpm") + (concat "../etc/" + (if emacs-beta-version + "xemacs-beta.xpm" + "xemacs.xpm")) 'global 'x)) (cond ((featurep 'xpm) (set-glyph-image frame-icon-glyph diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/help-nomule.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/prim/help-nomule.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,99 @@ +;;; help-nomule.el --- Help functions when not in Mule + +;; Copyright (C) 1997 by Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: help, internal + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; + +;;; Code: + +(defconst tutorial-supported-languages + '(("French" fr iso-8859-1) + ("German" de iso-8859-1) + ("Norwegian" no iso-8859-1) + ("Croatian" hr iso-8859-2)) + "Alist of supported languages in TUTORIAL files. +Add languages here, as more are translated.") + +;; TUTORIAL arg is XEmacs addition +(defun help-with-tutorial (&optional tutorial language) + "Select the XEmacs learn-by-doing tutorial. +Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\". +With a prefix argument, choose the language." + (interactive "i\nP") + (or tutorial + (setq tutorial "TUTORIAL")) + (when (and language (consp language)) + (let ((completion-ignore-case t)) + (setq language (assoc (completing-read "Language: " + tutorial-supported-languages + nil t) + tutorial-supported-languages)))) + (when language + (setq tutorial (format "%s.%s" tutorial (cadr language)))) + (let ((file (expand-file-name tutorial "~"))) + (delete-other-windows) + (let ((buffer (or (get-file-buffer file) + (create-file-buffer file))) + (window-configuration (current-window-configuration))) + (condition-case error-data + (progn + (switch-to-buffer buffer) + (setq buffer-file-name file) + (setq default-directory (expand-file-name "~/")) + (setq buffer-auto-save-file-name nil) + ;; Because of non-Mule users, TUTORIALs are not coded + ;; independently, so we must guess the coding according to + ;; the language. + (let ((coding-system-for-read (nth 2 language))) + (insert-file-contents (expand-file-name tutorial + data-directory))) + (goto-char (point-min)) + (search-forward "\n<<") + (delete-region (point-at-bol) (point-at-eol)) + (let ((n (- (window-height (selected-window)) + (count-lines (point-min) (point)) + 6))) + (if (< n 12) + (newline n) + ;; Some people get confused by the large gap. + (newline (/ n 2)) + (insert "[Middle of page left blank for didactic purposes. " + "Text continues below]") + (newline (- n (/ n 2))))) + (goto-char (point-min)) + (set-buffer-modified-p nil)) + ;; TUTORIAL was not found: kill the buffer and restore the + ;; window configuration. + (file-error (kill-buffer buffer) + (set-window-configuration window-configuration) + ;; Now, signal the error + (signal (car error-data) (cdr error-data))))))) + + +(provide 'help-nomule) + +;;; help-nomule.el ends here \ No newline at end of file diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/help.el --- a/lisp/prim/help.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/help.el Mon Aug 13 10:03:52 2007 +0200 @@ -243,37 +243,38 @@ ;;(define-key global-map 'backspace 'deprecated-help-command) +;; This function has been moved to help-nomule.el and mule-help.el. ;; TUTORIAL arg is XEmacs addition -(defun help-with-tutorial (&optional tutorial) - "Select the XEmacs learn-by-doing tutorial. -Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\"." - (interactive) - (if (null tutorial) - (setq tutorial "TUTORIAL")) - (let ((file (expand-file-name (concat "~/" tutorial)))) - (delete-other-windows) - (if (get-file-buffer file) - (switch-to-buffer (get-file-buffer file)) - (switch-to-buffer (create-file-buffer file)) - (setq buffer-file-name file) - (setq default-directory (expand-file-name "~/")) - (setq buffer-auto-save-file-name nil) - (insert-file-contents (expand-file-name tutorial data-directory)) - (goto-char (point-min)) - (search-forward "\n<<") - (delete-region (point-at-bol) (point-at-eol)) - (let ((n (- (window-height (selected-window)) - (count-lines (point-min) (point)) - 6))) - (if (< n 12) - (newline n) - ;; Some people get confused by the large gap. - (newline (/ n 2)) - (insert "[Middle of page left blank for didactic purposes. " - "Text continues below]") - (newline (- n (/ n 2))))) - (goto-char (point-min)) - (set-buffer-modified-p nil)))) +;(defun help-with-tutorial (&optional tutorial) +; "Select the XEmacs learn-by-doing tutorial. +;Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\"." +; (interactive) +; (if (null tutorial) +; (setq tutorial "TUTORIAL")) +; (let ((file (expand-file-name (concat "~/" tutorial)))) +; (delete-other-windows) +; (if (get-file-buffer file) +; (switch-to-buffer (get-file-buffer file)) +; (switch-to-buffer (create-file-buffer file)) +; (setq buffer-file-name file) +; (setq default-directory (expand-file-name "~/")) +; (setq buffer-auto-save-file-name nil) +; (insert-file-contents (expand-file-name tutorial data-directory)) +; (goto-char (point-min)) +; (search-forward "\n<<") +; (delete-region (point-at-bol) (point-at-eol)) +; (let ((n (- (window-height (selected-window)) +; (count-lines (point-min) (point)) +; 6))) +; (if (< n 12) +; (newline n) +; ;; Some people get confused by the large gap. +; (newline (/ n 2)) +; (insert "[Middle of page left blank for didactic purposes. " +; "Text continues below]") +; (newline (- n (/ n 2))))) +; (goto-char (point-min)) +; (set-buffer-modified-p nil)))) ;; used by describe-key, describe-key-briefly, insert-key-binding, etc. @@ -798,31 +799,38 @@ (defun function-at-point () "Return the function whose name is around point. If that gives no function, return the function which is called by the -list containing point. If that doesn't give a function, return nil." - (or (condition-case () - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (or (not (zerop (skip-syntax-backward "_w"))) - (eq (char-syntax (char-after (point))) ?w) - (eq (char-syntax (char-after (point))) ?_) - (forward-sexp -1)) - (skip-chars-forward "`'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (fboundp obj) obj))) - (set-syntax-table stab))) - (error nil)) - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) - (backward-up-list 1) - (forward-char 1) - (let (obj) - (setq obj (read (current-buffer))) - (and (symbolp obj) (fboundp obj) obj)))) - (error nil)))) +list containing point. If that doesn't give a function, return nil. + +If `function-at-point-function' is non nil, the function it names is +called instead." + (if (and (fboundp function-at-point-function) + (not (eq function-at-point-function 'function-at-point))) + (funcall function-at-point-function) + (or (condition-case () + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table emacs-lisp-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (char-after (point))) ?w) + (eq (char-syntax (char-after (point))) ?_) + (forward-sexp -1)) + (skip-chars-forward "`'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (fboundp obj) obj))) + (set-syntax-table stab))) + (error nil)) + (condition-case () + (save-excursion + (save-restriction + (narrow-to-region (max (point-min) (- (point) 1000)) + (point-max)) + (backward-up-list 1) + (forward-char 1) + (let (obj) + (setq obj (read (current-buffer))) + (and (symbolp obj) (fboundp obj) obj)))) + (error nil))))) ;; Default to nil for the non-hackers? Not until we find a way to ;; distinguish hackers from non-hackers automatically! @@ -832,11 +840,11 @@ :type 'boolean :group 'help-appearance) -(defcustom find-function-function 'function-at-point - "*The function used by `describe-function', `where-is' and -`find-function' to select the function near point. +(defcustom function-at-point-function nil + "*Set this to name an alternative function to be used by +`function-at-point' instead of itself. -For example `function-at-point' or `function-called-at-point'." +For example `function-called-at-point'." :type 'function :group 'help) @@ -852,10 +860,10 @@ (defun describe-function (function) "Display the full documentation of FUNCTION (a symbol). -When run interactively, it defaults to any function found by the -value of `find-function-function'." +When run interactively, it defaults to any function found by +`function-at-point'." (interactive - (let* ((fn (funcall find-function-function)) + (let* ((fn (function-at-point)) (val (let ((enable-recursive-minibuffers t)) (completing-read (if fn @@ -1047,7 +1055,7 @@ ;;; ## this doesn't seem to be used for anything ;; (defun describe-function-arglist (function) -;; (interactive (list (or (function-called-at-point) +;; (interactive (list (or (function-at-point) ;; (error "no function call at point")))) ;; (let ((b nil)) ;; (unwind-protect @@ -1223,10 +1231,10 @@ (defun where-is (definition) "Print message listing key sequences that invoke specified command. Argument is a command definition, usually a symbol with a function definition. -When run interactively, it defaults to any function found by the -value of `find-function-function'." +When run interactively, it defaults to any function found by +`function-at-point'." (interactive - (let ((fn (funcall find-function-function)) + (let ((fn (function-at-point)) (enable-recursive-minibuffers t) val) (setq val (read-command diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/keymap.el --- a/lisp/prim/keymap.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/keymap.el Mon Aug 13 10:03:52 2007 +0200 @@ -347,8 +347,41 @@ (signal 'wrong-type-argument (list 'eventp event)))) (setq i (1+ i))) new)))) + -;FSFmacs #### +(defun next-key-event () + "Return the next available keyboard event." + (let (event) + (while (not (key-press-event-p (setq event (next-event)))) + (dispatch-event event)) + event)) + +(defun key-sequence-list-description (keys) + "Convert a key sequence KEYS to the full [(modifiers... key)...] form. +Argument KEYS can be in any form accepted by `define-key' function." + (let ((vec + (cond ((vectorp keys) + keys) + ((stringp keys) + (vconcat keys)) + (t + (vector keys)))) + (event-to-list + #'(lambda (ev) + (append (event-modifiers ev) (list (event-key ev)))))) + (mapvector + #'(lambda (key) + (cond ((key-press-event-p key) + (funcall event-to-list key)) + ((characterp key) + (funcall event-to-list (character-to-event key))) + ((listp key) + key) + (t + (list key)))) + vec))) + + ;;; Support keyboard commands to turn on various modifiers. ;;; These functions -- which are not commands -- each add one modifier @@ -367,21 +400,41 @@ (defun event-apply-meta-modifier (ignore-prompt) (event-apply-modifier 'meta)) +;;; #### `key-translate-map' is ignored for now. (defun event-apply-modifier (symbol) "Return the next key event, with a modifier flag applied. -SYMBOL is the name of this modifier, as a symbol." - (let (event) - (while (not (key-press-event-p (setq event (next-command-event)))) - (dispatch-event event)) - (vconcat (list symbol) - (delq symbol (event-modifiers event)) - (list (event-key event))))) +SYMBOL is the name of this modifier, as a symbol. +`function-key-map' is scanned for prefix bindings." + (let (events binding) + ;; read keystrokes scanning `function-key-map' + (while (keymapp + (setq binding + (lookup-key + function-key-map + (vconcat + (setq events + (append events (list (next-key-event))))))))) + (if binding ; found a binding + (progn + ;; allow for several modifiers + (if (and (symbolp binding) (fboundp binding)) + (setq binding (funcall binding nil))) + (setq events (append binding nil)) + ;; put remaining keystrokes back into input queue + (setq unread-command-events + (mapcar 'character-to-event (cdr events)))) + (setq unread-command-events (cdr events))) + ;; add a modifier SYMBOL to the first keystroke or event + (vector + (append (list symbol) + (delq symbol + (aref (key-sequence-list-description (car events)) 0)))))) ;; This looks dirty. The following code should maybe go to another ;; file, and `create-console-hook' should maybe default to nil. (add-hook 'create-console-hook - (lambda (console) + #'(lambda (console) (letf (((selected-console) console)) (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/minibuf.el --- a/lisp/prim/minibuf.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/minibuf.el Mon Aug 13 10:03:52 2007 +0200 @@ -205,8 +205,15 @@ (interactive) (and minibuffer-electric-file-name-behavior (eq ?/ (char-before (point))) + (not (save-excursion + (goto-char (point-min)) + (and (looking-at "^/.+:~?") + (re-search-forward "^/.+:~?[^/]*" nil t) + (progn + (delete-region (point) (point-max)) + t)))) (not (eq (point) (1+ (point-min)))) ; permit `//hostname/path/to/file' - (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' + (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' (delete-region (point-min) (point))) (insert ?/)) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/mouse.el --- a/lisp/prim/mouse.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/mouse.el Mon Aug 13 10:03:52 2007 +0200 @@ -184,8 +184,8 @@ Text drops follow the `mouse-yank-at-point' variable." ;; by Oliver Graf (interactive "e") - (let ((type (car (event-dnd-data event))) - (data (cadr (event-dnd-data event))) + (let ((type (car (event-drag-and-drop-data event))) + (data (cadr (event-drag-and-drop-data event))) (frame (event-channel event))) (cond ((= type 2) (let ((x pop-up-windows)) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/obsolete.el --- a/lisp/prim/obsolete.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/obsolete.el Mon Aug 13 10:03:52 2007 +0200 @@ -615,11 +615,6 @@ (color-instance-rgb-components (make-color-instance color))) (make-compatible 'x-color-values 'color-instance-rgb-components) -;; The name of char-int is unintuitive and silly, but in CLtL2. -(define-compatible-function-alias 'char-int 'char-to-int) -;; likewise with int-char. -(define-compatible-function-alias 'int-char 'int-to-char) - ;; Two loser functions which shouldn't be used. (make-obsolete 'following-char 'char-after) (make-obsolete 'preceding-char 'char-before) @@ -694,4 +689,6 @@ ;; Keywords already do The Right Thing in XEmacs (make-compatible 'define-widget-keywords "Just use them") +(make-obsolete 'function-called-at-point 'function-at-point) + ;;; obsolete.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/packages.el --- a/lisp/prim/packages.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/packages.el Mon Aug 13 10:03:52 2007 +0200 @@ -100,13 +100,18 @@ (locate-file library (or path load-path) - (if nosuffix - "" - (if (or (rassq 'jka-compr-handler file-name-handler-alist) - (and (boundp 'find-file-hooks) - (member 'crypt-find-file-hook find-file-hooks))) - ".elc:.el:" - ".elc:.elc.gz:elc.Z:.el:.el.gz:.el.Z::.gz:.Z")) + (cond ((or (rassq 'jka-compr-handler file-name-handler-alist) + (and (boundp 'find-file-hooks) + (member 'crypt-find-file-hook find-file-hooks))) + ;; Compression involved. + (if nosuffix + ":.gz:.Z" + ".elc:.elc.gz:elc.Z:.el:.el.gz:.el.Z::.gz:.Z")) + (t + ;; No compression. + (if nosuffix + "" + ".elc:.el:"))) 4))) (and interactive-call (if result @@ -151,13 +156,15 @@ autolist)) ;; The following function is called from temacs -(defun packages-find-packages-1 (package path-only) +(defun packages-find-packages-1 (package path-only user-package) "Search the supplied directory for associated directories. The top level is assumed to look like: info/ Contain texinfo files for lisp installed in this hierarchy etc/ Contain data files for lisp installled in this hiearchy lisp/ Contain directories which either have straight lisp code - or are self-contained packages of their own." + or are self-contained packages of their own. + +This is an internal function. Do not call it after startup." ;; Info files (if (and (null path-only) (file-directory-p (concat package "/info"))) (let ((dir (concat package "/info/"))) @@ -170,16 +177,34 @@ ;; Lisp files (if (file-directory-p (concat package "/lisp")) (progn - ;; (print (concat "DIR: " package "/lisp/")) +; (print (concat "DIR: " +; (if user-package "[USER]" "") +; package +; "/lisp/")) (setq load-path (cons (concat package "/lisp/") load-path)) + (if user-package + (condition-case nil + (load (concat package "/lisp/" + (file-name-sans-extension autoload-file-name))) + (t nil))) (let ((dirs (directory-files (concat package "/lisp/") t "^[^-.]" nil 'dirs-only)) dir) (while dirs (setq dir (car dirs)) - ;; (print (concat "DIR: " dir "/")) +; (print (concat "DIR: " dir "/")) (setq load-path (cons (concat dir "/") load-path)) - (packages-find-packages-1 dir path-only) + (if user-package + (condition-case nil + (progn +; (print +; (concat dir "/" +; (file-name-sans-extension autoload-file-name))) + (load + (concat dir "/" + (file-name-sans-extension autoload-file-name)))) + (t nil))) + (packages-find-packages-1 dir path-only user-package) (setq dirs (cdr dirs))))))) ;; The following function is called from temacs @@ -197,11 +222,13 @@ (while path (setq dir (car path)) ;; (prin1 (concat "Find: " (expand-file-name dir) "\n")) - (if (null (and suppress-user + (if (null (and (or suppress-user inhibit-package-init) (string-match "^~" dir))) (progn ;; (print dir) - (packages-find-packages-1 (expand-file-name dir) path-only))) + (packages-find-packages-1 (expand-file-name dir) + path-only + (string-match "^~" dir)))) (setq path (cdr path))))) ;; Data-directory is really a list now. Provide something to search it for diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/profile.el --- a/lisp/prim/profile.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/profile.el Mon Aug 13 10:03:52 2007 +0200 @@ -26,7 +26,7 @@ ;;; Commentary: -;; In addition to Lisp-based `elp', XEmacs contains a set of +;; In addition to Lisp-based `elp', XEmacs provides a set of ;; primitives able to profile evaluation of Lisp functions, created by ;; the illustrious Ben Wing. The functions in this file can be used ;; to gain easy access to the internal profiling functions. @@ -36,16 +36,16 @@ ;; The output of this process is an alist with keys being the ;; functions, and values being the number of ticks per function. From ;; this, `profiling-results' easily extracts the total number of -;; ticks, and the percentage CPU time of each function. - -;; Unless stated otherwise, profiling info is being accumulated (the -;; current info is returned by `get-profiling-info'). Use +;; Unless stated otherwise, profiling info is being accumulated +;; incrementally through several profile runs (the current info is +;; always available by `get-profiling-info'). Use ;; `clear-profiling-info' to break the accumulation chain. ;; Caveats (ELP users should read this): ;; 1) The time reported is function time, rather than ;; function+descendants time; -;; 2) The Time/ms is CPU time (user+kernel), not the real time; +;; 2) Each tick is equivalent to 1ms (which can be changed), but this +;; is CPU time (user+kernel), not the real time; ;; 3) Only the actuall funcalls are profiled. If a subr Ffoo calls ;; Fbar using Fbar (), only Ffoo will appear in the profile. @@ -60,12 +60,6 @@ ;;; Code: -(defun profile-align (form width) - ;; Bletch! this is what (format "%-*s" width form) should do. - (let ((printed-form (format "%s" form))) - (concat printed-form - (make-string (max 0 (- width (length printed-form))) ?\ )))) - ;;;###autoload (defun profile-results (&optional info stream) "Print profiling info INFO to STREAM in a pretty format. @@ -88,26 +82,25 @@ ;; Calculate the longest function (maxfunlen (apply #'max (length "Function Name") - (mapcar (lambda (el) - ;; Functions longer than 40 - ;; characters don't qualify - (let ((l (length (format "%s" (car el))))) - (if (< l 40) - l 0))) - info)))) - (princ (format "%s Ticks %%/Total\n" - (profile-align "Function Name" maxfunlen))) + (mapcar + (lambda (el) + ;; Functions longer than 50 characters (usually + ;; anonymous functions) don't qualify + (let ((l (length (format "%s" (car el))))) + (if (< l 50) + l 0))) + info)))) + (princ (format "%-*s Ticks %%/Total\n" maxfunlen "Function Name")) (princ (make-string maxfunlen ?=)) (princ " ===== =======\n") (let ((sum (float (apply #'+ (mapcar #'cdr info))))) (dolist (entry (nreverse (sort info #'cdr-less-than-cdr))) - (princ (format "%s %-5d %-6.3f\n" - (profile-align (car entry) maxfunlen) - (cdr entry) (* 100 (/ (cdr entry) sum))))) + (princ (format "%-*s %-5d %-6.3f\n" + maxfunlen (car entry) (cdr entry) + (* 100 (/ (cdr entry) sum))))) (princ (make-string maxfunlen ?-)) (princ "--------------------\n") - (princ (format "%s %-5d %-6.2f\n" - (profile-align "Total" maxfunlen) sum 100.0)) + (princ (format "%-*s %-5d %-6.2f\n" maxfunlen "Total" sum 100.0)) (princ (format "\n\nOne tick = %g ms\n" (/ default-profiling-interval 1000.0))))) (when (and (not stream) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/simple.el --- a/lisp/prim/simple.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 10:03:52 2007 +0200 @@ -2903,6 +2903,7 @@ (defun assoc-ignore-case (key alist) "Like `assoc', but assumes KEY is a string and ignores case when comparing." + (setq key (downcase key)) (let (element) (while (and alist (not element)) (if (equal key (downcase (car (car alist)))) @@ -3141,19 +3142,22 @@ (defun capitalize-region-or-word (arg) "Capitalize the selected region or the following word (or ARG words)." (interactive "p") - (if (region-active-p) (capitalize-region (region-beginning) (region-end)) + (if (region-active-p) + (capitalize-region (region-beginning) (region-end)) (capitalize-word arg))) (defun upcase-region-or-word (arg) "Upcase the selected region or the following word (or ARG words)." (interactive "p") - (if (region-active-p) (upcase-region (region-beginning) (region-end)) + (if (region-active-p) + (upcase-region (region-beginning) (region-end)) (upcase-word arg))) (defun downcase-region-or-word (arg) "Downcase the selected region or the following word (or ARG words)." (interactive "p") - (if (region-active-p) (downcase-region (region-beginning) (region-end)) + (if (region-active-p) + (downcase-region (region-beginning) (region-end)) (downcase-word arg))) ;;; @@ -3202,7 +3206,7 @@ (extent-object zmacs-region-extent))) buffer (marker-buffer (car region)))) (t - (signal 'error (list "invalid region" region)))) + (signal 'error (list "Invalid region" region)))) (if valid nil @@ -3210,7 +3214,7 @@ ;; otherwise incapacitated. (condition-case () (if (listp zmacs-region-extent) - (mapcar 'delete-extent zmacs-region-extent) + (mapc 'delete-extent zmacs-region-extent) (delete-extent zmacs-region-extent)) (error nil))) @@ -3289,7 +3293,7 @@ (if zmacs-region-extent (let ((inhibit-quit t)) (if (listp zmacs-region-extent) - (mapcar 'delete-extent zmacs-region-extent) + (mapc 'delete-extent zmacs-region-extent) (delete-extent zmacs-region-extent)) (setq zmacs-region-extent nil))) (run-hooks 'zmacs-deactivate-region-hook) @@ -3300,17 +3304,19 @@ You shouldn't need to call this; the command loop calls it when appropriate. Calling this function will call the hook `zmacs-update-region-hook', if the region is active." - (if zmacs-region-active-p - (progn - (if (marker-buffer (mark-marker t)) - (zmacs-make-extent-for-region (cons (point-marker t) - (mark-marker t)))) - (run-hooks 'zmacs-update-region-hook)))) + (when zmacs-region-active-p + (when (marker-buffer (mark-marker t)) + (zmacs-make-extent-for-region (cons (point-marker t) + (mark-marker t)))) + (run-hooks 'zmacs-update-region-hook))) ;;;;;; ;;;;;; echo area stuff ;;;;;; +;;; #### Should this be moved to a separate file, for clarity? +;;; -hniksic + ;;; The `message-stack' is an alist of labels with messages; the first ;;; message in this list is always in the echo area. A call to ;;; `display-message' inserts a label/message pair at the head of the @@ -3742,11 +3748,11 @@ (setq display-p nil)) (save-excursion (let ((buffer (get-buffer-create "*Warnings*"))) - (if display-p - ;; The C code looks at display-warning-tick to determine - ;; when it should call `display-warning-buffer'. Change it - ;; to get the C code's attention. - (setq display-warning-tick (1+ display-warning-tick))) + (when display-p + ;; The C code looks at display-warning-tick to determine + ;; when it should call `display-warning-buffer'. Change it + ;; to get the C code's attention. + (incf display-warning-tick)) (set-buffer buffer) (goto-char (point-max)) (setq warning-count (1+ warning-count)) @@ -3776,11 +3782,10 @@ "Make the buffer that contains the warnings be visible. The C code calls this periodically, right before redisplay." (let ((buffer (get-buffer-create "*Warnings*"))) - (if (or (not warning-marker) (not (eq (marker-buffer warning-marker) - buffer))) - (progn - (setq warning-marker (make-marker)) - (set-marker warning-marker 1 buffer))) + (when (or (not warning-marker) + (not (eq (marker-buffer warning-marker) buffer))) + (setq warning-marker (make-marker)) + (set-marker warning-marker 1 buffer)) (set-window-start (display-buffer buffer) warning-marker) (set-marker warning-marker (point-max buffer) buffer))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/startup.el --- a/lisp/prim/startup.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/startup.el Mon Aug 13 10:03:52 2007 +0200 @@ -39,7 +39,7 @@ (defvar command-line-processed nil "t once command line has been processed") -(defconst startup-message-timeout 1200) ; More or less disable the timeout +(defconst startup-message-timeout 12000) ; More or less disable the timeout (defconst inhibit-startup-message nil "*Non-nil inhibits the initial startup message. @@ -211,6 +211,8 @@ -unmapped Do not map the initial frame. -no-site-file Do not load the site-specific init file (site-start.el). -no-init-file Do not load the user-specific init file (~/.emacs). + -no-packages Do not process the package path. + -vanilla Equivalent to -q -no-site-file -no-packages. -q Same as -no-init-file. -user Load user's init file instead of your own. -u Same as -user.\n") @@ -461,6 +463,12 @@ (setq init-file-user nil)) ((string= arg "-no-site-file") (setq site-start-file nil)) + ((string= arg "-no-packages") + (setq inhibit-package-init t)) + ((string= arg "-vanilla") + (setq init-file-user nil + site-start-file nil + inhibit-package-init t)) ((or (string= arg "-u") (string= arg "-user")) (setq init-file-user (pop args))) @@ -654,47 +662,48 @@ (load filename)) (defun command-line-1 () - (if (null command-line-args-left) - (unless (or inhibit-startup-message - noninteractive - ;; Don't clobber a non-scratch buffer if init file - ;; has selected it. - (not (string= (buffer-name) "*scratch*")) - (input-pending-p)) - - ;; If there are no switches to process, run the term-setup-hook - ;; before displaying the copyright notice; there may be some need - ;; to do it before doing any output. If we're not going to - ;; display a copyright notice (because other options are present) - ;; then this is run after those options are processed. - (run-hooks 'term-setup-hook) - ;; Don't let the hook be run twice. - (setq term-setup-hook nil) + (cond + ((null command-line-args-left) + (unless noninteractive + ;; If there are no switches to process, run the term-setup-hook + ;; before displaying the copyright notice; there may be some need + ;; to do it before doing any output. If we're not going to + ;; display a copyright notice (because other options are present) + ;; then this is run after those options are processed. + (run-hooks 'term-setup-hook) + ;; Don't let the hook be run twice. + (setq term-setup-hook nil) - (let ((timeout nil)) - (unwind-protect - ;; Guts of with-timeout - (catch 'timeout - (setq timeout (add-timeout startup-message-timeout - (lambda (ignore) - (condition-case nil - (throw 'timeout t) - (error nil))) - nil)) - (startup-splash-frame) - (or nil;; (pos-visible-in-window-p (point-min)) - (goto-char (point-min))) - (sit-for 0) - (setq unread-command-event (next-command-event))) - (when timeout (disable-timeout timeout)) - (with-current-buffer (get-buffer "*scratch*") - (erase-buffer) - (when (stringp initial-scratch-message) - (insert initial-scratch-message)) - ;; In case the XEmacs server has already selected - ;; another buffer, erase the one our message is in. - (set-buffer-modified-p nil))))) - + ;; Don't clobber a non-scratch buffer if init file + ;; has selected it. + (when (string= (buffer-name) "*scratch*") + (unless (or inhibit-startup-message + (input-pending-p)) + (let ((timeout nil)) + (unwind-protect + ;; Guts of with-timeout + (catch 'timeout + (setq timeout (add-timeout startup-message-timeout + (lambda (ignore) + (condition-case nil + (throw 'timeout t) + (error nil))) + nil)) + (startup-splash-frame) + (or nil;; (pos-visible-in-window-p (point-min)) + (goto-char (point-min))) + (sit-for 0) + (setq unread-command-event (next-command-event))) + (when timeout (disable-timeout timeout))))) + (with-current-buffer (get-buffer "*scratch*") + ;; In case the XEmacs server has already selected + ;; another buffer, erase the one our message is in. + (erase-buffer) + (when (stringp initial-scratch-message) + (insert initial-scratch-message)) + (set-buffer-modified-p nil))))) + + (t ;; Command-line-options exist (let ((dir command-line-default-directory) (file-count 0) @@ -740,7 +749,7 @@ (> file-count 2) (not (get-buffer-window first-file-buffer))) (other-window 1) - (buffer-menu nil))))) + (buffer-menu nil)))))) (defvar startup-presentation-hack-keymap (let ((map (make-sparse-keymap))) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/prim/subr.el --- a/lisp/prim/subr.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/subr.el Mon Aug 13 10:03:52 2007 +0200 @@ -396,6 +396,12 @@ (define-function 'string< 'string-lessp) (define-function 'int-to-string 'number-to-string) (define-function 'string-to-int 'string-to-number) + +;; These two names are a bit awkward, as they conflict with the normal +;; foo-to-bar naming scheme, but CLtL2 has them, so they stay. +(define-function 'char-int 'char-to-int) +(define-function 'int-char 'int-to-char) + ;; alist/plist functions (defun plist-to-alist (plist) @@ -572,7 +578,7 @@ abbrev-table-name-list))))))) (defun functionp (obj) - "Returns t if OBJ is a function, nil otherwise." + "Non-nil if OBJECT is a type of object that can be called as a function." (cond ((symbolp obj) (fboundp obj)) ((subrp obj)) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/ChangeLog --- a/lisp/psgml/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,974 +0,0 @@ -1997-10-10 Per Abrahamsen - - * custom/wid-edit.el (variable-link): New widget. - (widget-variable-link-action): New function. - (function-link): New widget. - (widget-function-link-action): New function. - -1997-10-10 Karl M. Hegbloom - - * prim/modeline.el (modeline-minor-mode-menu): menus are toggles - not strings now. - -1997-10-10 SL Baur - - * psgml-html.el (html-quote-region): Grow bounds when performing - substitutions. - From Adrian Aichner - -1997-09-26 SL Baur - - * iso-sgml.el: Correct email address. - - * psgml-parse.el (sgml-compile-dtd): no-conversion -> binary - coding system. - (sgml-bdtd-merge): Ditto. - (sgml-push-to-entity): Ditto. - -1997-06-15 Steven L Baur - - * psgml-parse.el (sgml-parse-chars): De-ebolify. - (sgml-read-peek): Use char-after not following-char. - -1997-06-14 Steven L Baur - - * psgml-parse.el (sgml-read-model): Ebola vaccine. - From Andrew J Cosgriff - -Wed Apr 23 11:28:10 1997 Steven L Baur - - * psgml-charent.el (sgml-display-char-list-filename): Move - iso88591.map to a proper location. - -Tue Apr 22 02:05:09 1997 Steven L Baur - - * psgml-xemacs.el (sgml-xemacs-get-popup-value): Allow for - interactive function. - -Sat Mar 22 19:58:27 1997 Steven L Baur - - * psgml-html.el (html-mode): Too many backslashes in DOCSTRING. - -Wed Mar 19 22:58:40 1997 Steven L Baur - - * psgml-html.el (html-helper-address-string): Use - user-mail-address function. - -Mon Jan 27 13:12:41 1997 Jin S. Choi - - * psgml.el: Fix location of CATALOG in `sgml-validate-command'. - -Thu Jan 16 18:23:51 1997 Steven L Baur - - * psgml.el: Use newer interface form of nsgmls. - -Wed Nov 20 19:40:05 1996 Lennart Staflin - - * psgml-parse.el (sgml-modify-dtd): set sgml-current-tree to - sgml-top-tree. Needed by sgml-open-element. - -Mon Nov 11 01:50:40 1996 Lennart Staflin - - * Version 1.0 released. - -Sun Sep 15 14:07:24 1996 Lennart Staflin - - * psgml.el (sgml-mode): modify mode-line-format with subst, don't - replicate the whole format in the code. - -Thu Sep 12 20:27:38 1996 Lennart Staflin - - * psgml-parse.el (sgml-external-file): Try to find system - identifiers using the sgml-public-map - if sgml-system-identifiers-are-preferred; this way that flag will - have effect even if the sgml-public-map contains `%s'. - (sgml-final): moved to be defined before use. - - * psgml-dtd.el (sgml-parse-parameter-literal): Try to handle - character references to character number above 255 by leaving a - character reference in then parsed entity text. - -Thu Sep 5 14:11:00 1996 Dave Love - - * psgml-other.el (sgml-set-face-for): Nullify - {after,before}-change-functions as well as (obsolete) - {after,before}-change-function. - -Tue Sep 10 17:52:40 1996 Steven L Baur - - * Various files: Sync'ed with 1.0a12 - -Fri Jul 12 18:20:07 1996 Steven L Baur - - * Various files: Sync'ed up to Wingpsgml - - * iso-sgml.el: Added Appendix 2 Proposed entity additions to Latin-2 - -Fri Jul 12 03:38:10 1996 Adrian Aichner - - * psgml-edit.el: Allow user to control capitalization of auto-inserted - keywords. - - -Sun Sep 1 01:53:33 1996 Lennart Staflin - - * Version 1.0a12 - - * psgml-maint.el: new file. Used to compile psgml. - -Tue Aug 20 23:11:30 1996 Lennart Staflin - - * psgml.el: - (sgml-validate-error-regexps): Fixes from Dave Love - and David Megginson for use with nsgmls. - (sgml-validate-command): changed default validate command to use - nsgmls. - -Sun Aug 11 19:21:56 1996 Lennart Staflin - - * iso88591.map: added code to character mappings. - -Thu Jun 13 20:43:53 1996 Lennart Staflin - - * psgml-parse.el (sgml-get-and-move): use sgml-final, not - sgml-state-final-p. In this case the substate can be an AND-state. - -Tue May 21 07:39:34 1996 Lennart Staflin - - * Version 1.0a11 released. - -Mon May 20 23:14:02 1996 Lennart Staflin - - * psgml.el (psgml-version): bump version. - (sgml-build-custom-menus): fix button3 after easy-menu redefines - it. (this was actually done at an earlier date). - -Fri May 3 18:16:18 1996 Lennart Staflin - - * psgml-parse.el (sgml-push-to-entity): remove binding - before/after change functions. This probably made them nil in the - main buffer. - -Fri Apr 5 14:37:47 1996 Karl Eichwalder - - * psgml.texi, psgml-api.texi: Add INFO-DIR-ENTRY. - - * aclocal.m4, configure.in, Makefile.in: New. - * INSTALL, install-sh, mkinstalldirs: Add from autoconf-2.9 - package. - -Fri Apr 5 09:47:01 1996 Lennart Staflin - - * Version 1.0a10 released. - -Thu Mar 21 22:14:43 1996 Lennart Staflin - - * psgml-parse.el (sgml-cache-catalog): use file-truename on file - to be cached. - -Wed Mar 20 20:59:35 1996 Lennart Staflin - - * psgml-info.el (sgml-eltype-refrenced-elements): allow for - exceptions. - -Tue Mar 19 21:59:27 1996 Lennart Staflin - - * psgml-api.el (sgml-map-content): use max from main buffer when - setting parser goal. (fix bug 75). - -Sun Mar 17 15:06:26 1996 Lennart Staflin - - * psgml-edit.el (sgml-list-valid-tags): Show current - shortreference map name. - - * psgml-parse.el (sgml-lookup-shortref-name): new func. - - * psgml-edit.el (sgml-what-element): display 'shortref' if cursor - over beginning of a shortref - - * psgml-parse.el (sgml-is-goal-after-start): handle stag in entity - differently from stag in buffer. - -Tue Mar 12 21:22:52 1996 Lennart Staflin - - * psgml-parse.el: removed use of & in functions and variable - names. - - * psgml-dtd.el (sgml-remove-redundant-states-1): remove unused - variable res. - - * psgml.el (sgml-parse-colon-path): remove unused variable cd-prefix - -Sun Feb 18 16:33:43 1996 Lennart Staflin - - * psgml-parse.el (sgml-push-to-entity): set mc-flag to nil so that - MULE does not mangle binary data. (reported by Jeffrey Friedl - ) - -Mon Jan 22 22:57:54 1996 Lennart Staflin - - * psgml-edit.el (sgml-down-element): make sure sgml-last-element - has a reasonable value even if there is an error - -Sat Jan 6 22:07:44 1996 Lennart Staflin - - * psgml-parse.el (sgml-parse-nametoken): change buffer-substring - to buffer-substring-no-properties - -Sun Nov 5 13:41:36 1995 Lennart Staflin - - * psgml-dtd.el (sgml-parse-attribute-definition): remove - unnecessary call to sgml-general-case. - (sgml-check-nametoken-group): added a revers to get name tokens in - same order as declared. - -Sat Nov 4 12:58:56 1995 Lennart Staflin - - * psgml.el (sgml-validate-error-regexps): added new regexp for - nsgmls (from David M). - - * psgml-edit.el (sgml-insert-attributes): call auto-fill-function - after. - - * psgml.el (sgml-default-validate-command): add %v for - sgml-declaration variable - -Sat Aug 26 13:57:07 1995 Lennart Staflin - - * fs.el (fs-para): fix typo (bug 61). - - * psgml-edit.el (sgml-custom-dtd): new arglist to - sgml-doctype-insert. - - * psgml-api.el (sgml-map-content): don't take hook-variables as - parameters. Move data parsing to separate function. (bug 59) - -Wed Aug 23 20:53:50 1995 Lennart Staflin - - * Version 1.0 a8 released. - - * psgml-edit.el (sgml-expand-shortref-to-text): use - sgml-rs-ignore-pos. - (sgml-expand-shortref-to-entity): dito. - - * psgml-other.el (sgml-build-custom-menus): make menu entry call - sgml-insert-markup. - - * psgml.el (sgml-doctype): typo. - - * psgml-parse.el (sgml-rs-ignore-pos): Replaces - sgml-last-start-pos, now buffer local. (bug 49) - (sgml-push-to-entity): set sgml-rs-ignore-pos to start of entity - reference. (bug 49) - - * psgml-edit.el (sgml-doctype-insert): Remove &rest (bug 56). - - * psgml-lucid.el (sgml-build-custom-menus): Fix (bug 56). - - * psgml-other.el (sgml-build-custom-menus): Fix (bug 56). - - * psgml-edit.el (sgml-edit-attrib-specification-list): Use the - attlist for attribute names, not the name parsed from the - buffer. This fixes problems with attached text properties. - (fixes bug 53). - -Tue Aug 22 20:56:06 1995 Lennart Staflin - - * Version 1.0a7 released - - * psgml.el (psgml-version): bump version - -Mon Aug 21 23:38:49 1995 Lennart Staflin - - * psgml-parse.el (sgml-extid-sysid): handle old style extids. - (sgml-check-entities): log message on missmatch - -Wed Aug 16 22:54:42 1995 Lennart Staflin - - * psgml-parse.el - (sgml-make-extid): optional argument dir added. New representation - for external identifiers. - (sgml-extid-dir): New attr of extid - (sgml-extid-expand): new fun. - (sgml-path-lookup): use sgml-extid-expand - (sgml-lookup-sysid-as-file): take extid as argument instead of sysid, - use sgml-extid-expand - (sgml-parse-external): don't expand sysid - - -Thu Aug 10 22:33:50 1995 Lennart Staflin - - * psgml.el (sgml-default-validate-command): new function. - (sgml-validate): use new func. - (sgml-validate-command): new possible value: a list of templates - to try. - -Mon Jul 31 22:34:10 1995 Lennart Staflin - - * psgml-parse.el (sgml-entity-insert-text): mark entities not - found. - (sgml-entity-marked-undefined-p): new func. - (sgml-push-to-entity): set default-directory to that of external - entities file. - (sgml-parse-external): expand sysid as file name - - * psgml-info.el (sgml-display-table): add nosort option. - (sgml-general-dtd-info): more info. including undef entities. - -Sun Jul 30 22:23:15 1995 Lennart Staflin - - * test/son2.sgml: check that inclusions are inherited from the doc - element. - - * test/doc.dtd: adding ix element as inclusion in doc. - -Wed Jul 26 22:07:16 1995 Lennart Staflin - - * psgml-parse.el (sgml-parse-catalog-buffer): recoded. Now all - entries are on the format (type name file) and name might be nil - for "noname" entries. - (sgml-catalog-lookup): changed to handle new internal catalog - format. - -Mon Jul 24 00:07:02 1995 Lennart Staflin - - * psgml-parse.el (sgml-parse-catalog-buffer): Handle full catalog - format. - (sgml-catalog-lookup): Handle new catalog format including - parameter entities. - (sgml-search-catalog): new function, can be used to look up - SGMLDECL etc.. - - * psgml.el (sgml-system-identifiers-are-preferred): new option. - -Sun Jul 23 20:56:00 1995 Lennart Staflin - - * psgml-other.el (sgml-popup-multi-menu): kludge to force - x-popup-menu to be two level. - - * psgml-parse.el (sgml-do-data): move start after data consumed. - -Mon May 1 20:57:29 1995 Lennart Staflin - - * psgml-edit.el (sgml-normalize-content): fixing arithmetic error - - * psgml-parse.el (sgml-make-shortmap): add missing = to skip strings - -Sun Apr 23 23:01:35 1995 Lennart Staflin - - * Id 46: turns on autofill, fixed. - - * psgml-parse.el (sgml-auto-fill-inhibit-function): new variable - (do-auto-fill): advise do-auto-fill to honour above variable - (sgml-need-dtd): set sgml-auto-fill-inhibit-function, and don't - set auto-fill-function. - (sgml-safe-context-of): new fun - (sgml-safe-element-at): new fun - (sgml-in-prolog-p): new fun - -Mon Apr 10 21:26:30 1995 Lennart Staflin - - * psgml-dtd.el (sgml-write-dtd): set file-type for oemacs. - -Tue Mar 28 19:01:53 1995 Lennart Staflin - - * psgml-parse.el (sgml-try-merge-compiled-dtd): entd should be - ents. - - -Mon Mar 27 18:31:26 1995 Lennart Staflin - - * psgml-parse.el (sgml-bdtd-load): var. renamed. - (sgml-eltypes-in-state): fix som inconsitencies with - token/eltype/symbol. - (sgml-list-implications): fix bug handling empty elements. - - * psgml.el (sgml-recompile-out-of-date-cdtd): renamed from - sgml-ignore-out-of-date-cdtd. - -Sun Mar 26 16:25:10 1995 Lennart Staflin - - * Id 34: CATALOG searching priorities, fixed. - - * psgml-parse.el (sgml-catalog-lookup): - Giv PUBLIC entries priority over ENTITY and DOCTYPE - - * Id 35: Entity manager handling of system id, fixed. - - * psgml-parse.el (sgml-lookup-sysid-as-file): new func. - (sgml-external-file): call new func. - - * Id 41: selecting from a popup menu should not be an error - Installing patch from Tim Bradshaw , - Also fixing consequences. - Also making new menu function sgml-popup-multi-menu, - which uses call-back style. Nicer attributes menu. - - * psgml-other.el (sgml-set-face-for): Use sgml-type instead of - type for overlay property. - - * psgml-edit.el (sgml-attrib-menu): Make all attributes into one - list with submenues for every attribute. - -Thu Mar 23 20:23:26 1995 Lennart Staflin - - * psgml.el (sgml-mode): append to post-command-hook, this makes - psgml work better with auto-show. - - * psgml-parse.el (sgml-throw-on-error): new var. - (sgml-error): Throw if sgml-throw-on-error is set. - (sgml-push-to-entity): remove fifth arg to insert-file-contents - - * psgml-edit.el: (sgml-indent-line) - Make sgml-indent-line better behaved. - 1. Don't tab outside document element. - 2. Ignore parse errors. - - -Sun Mar 19 16:46:45 1995 Lennart Staflin - - * psgml-parse.el (sgml-bdtd-load): if sgml-ignore-out-of-date-cdtd - is ask, ask before recompiling. - -Thu Mar 2 19:08:59 1995 Lennart Staflin - - * Id 38: auto-fill breaks pubid, fixed - - * psgml-parse.el (sgml-do-auto-fill): new function, won't - auto-fill outside document element - (sgml-need-dtd): set auto-fill-function. - -Wed Feb 22 22:51:30 1995 Lennart Staflin - - * Id 37: sgml-kill-element with cursor inside tag - fixed. - - * psgml-edit.el (sgml-kill-element): signal error if point is - inside markup - -Sat Jan 28 14:35:01 1995 Lennart Staflin - - * psgml-edit.el (sgml-insert-element): Leave point at the end of - the element. - - * psgml.texi: Patch from Kevin R - -Mon Jan 23 19:29:33 1995 Lennart Staflin - - * psgml-edit.el (sgml-tag-regexp): make it handle unclosed tags - and net tags. - - * psgml-parse.el (struct sgml-tree): new field asl, constuctor - changed. - (sgml-open-element): pass asl to sgml-make-tree - (sgml-element-attribute-specification-list): use sgml-tree-asl. - -Sat Jan 14 16:27:46 1995 Lennart Staflin - - * psgml.el (sgml-mode-abbrev-table): new var. From patch by Karl - Eichwalder. - (sgml-validate-command): fixed doc. (Kevin Rodgers) - -Thu Jan 12 16:57:05 1995 Lennart Staflin - - * psgml-other.el (sgml-set-face-for): installed patch from Kevin - - * psgml-parse.el (sgml-do-end-tag): move call to sgml-set-markup-type - -Sun Dec 11 16:38:29 1994 Lennart Staflin - - * psgml-edit.el (sgml-do-set-option): take care of - read-from-string. - - * psgml.el (psgml-version): bump - (sgml-ignore-out-of-date-cdtd): new option - - * psgml-parse.el (sgml-bdtd-load): make up to date test optional. - -Fri Dec 9 22:02:13 1994 Lennart Staflin - - * psgml-other.el: Add ranges to multipart menus. - - * psgml-edit.el (sgml-normalize-start-tag): Don't recreate - NET-start tags. - -Sun Dec 4 01:23:46 1994 Lennart Staflin - - * psgml-edit.el (sgml-expand-shortref-to-text): update sgml-goal - (sgml-expand-shortref-to-entity): dito - -Tue Nov 29 13:13:13 1994 Lennart Staflin - - * psgml-dtd.el (sgml-before-eltype-modification): obsolete? - - * psgml-parse.el: Major changes to handling of compiled dtds - -Fri Nov 25 23:01:46 1994 Lennart Staflin - - * psgml-edit.el (sgml-entities-menu): sort entities menu - -Thu Nov 17 20:45:02 1994 Lennart Staflin - - * psgml-parse.el (sgml-path-lookup): set cand not res. - -Sat Nov 12 08:09:13 1994 Lennart Staflin - - * psgml-dtd.el (sgml-code-dtd): map over all eltypes, not only - defined, when outputing the names - -Thu Nov 3 06:47:17 1994 Lennart Staflin - - * Patch from Norman Walsh - - * psgml-parse.el (sgml-do-entity-ref): check - sgml-warn-about-undefined-entities. - - * psgml.el (sgml-warn-about-undefined-entities): new var. - -Mon Oct 31 20:10:58 1994 Lennart Staflin - - * psgml-parse.el (sgml-try-merge-compiled-dtd): Immediately exit - entity check loop if discrepancy found. - -Sun Oct 30 17:02:09 1994 Lennart Staflin - - * psgml-parse.el (sgml-copy-eltypes): remove - - * psgml.el ((fboundp 'run-hook-with-args)): conditionally define - - * psgml-edit.el (sgml-list-valid-tags): don't show shortmap. - - * psgml-dtd.el (sgml-before-eltype-modification): use - sgml-merge-eltypes instead of sgml-copy-eltypes. - (sgml-do-usemap-element): call sgml-before-eltype-modification. - - * psgml-parse.el (sgml-merge-eltypes): don't overwrite values in - old eltypes. - -Sat Oct 29 00:15:41 1994 Lennart Staflin - - * psgml-parse.el (sgml-setup-doctype): new func. - - -Thu Oct 27 01:51:37 1994 Lennart Staflin - - * psgml-parse.el (sgml-show-warnings): instead of suppress - warnings, defualt nil. Set to t by next trouble spot. Warnings - also shown when parsing dtd. - (sgml-parse-external): moved - (sgml-do-doctype): include the code that sgml-check-doctype-body - did have - (sgml-make-primitive-content-token): moved - -Wed Oct 26 23:23:26 1994 Lennart Staflin - - * psgml.el (psgml-version): bump version - (sgml-ignore-undefined-elements): new option - - * psgml-parse.el (sgml-eltype-all-miscdata): replace the function - sgml-eltype-all-appdata. - (sgml-eltype-set-all-miscdata): new func. - -Tue Oct 25 01:26:03 1994 Lennart Staflin - - * psgml-dtd.el (sgml-declare-entity): handle #DEFAULT - - * psgml-parse.el (sgml-lookup-entity): support default entity - (sgml-entity-declare): dito - (sgml-merge-entity-tables): dito - -Sat Oct 22 01:24:50 1994 Lennart Staflin - - * psgml-parse.el (sgml-read-dtd): Decode current buffer. - -Fri Oct 14 00:41:19 1994 Lennart Staflin - - * psgml-dtd.el (sgml-code-dtd): take dtd as argument - (sgml-save-dtd): take optional dtd - - * Id 27: insert-element looping - Test if inside markup when producing menus and completion tables. - -Wed Sep 28 08:10:19 1994 Lennart Staflin - - * psgml-parse.el (sgml-set-parse-state): Use smgl-goto-epos - (sgml-push-to-entity): reuse buffers always - (sgml-close-element): don't promote position of tag - - * psgml-dtd.el (sgml-parse-external): remove use of sgml-gname-symbol - (sgml-check-declared-value): "- - (sgml-check-default-value): "- - -Tue Sep 27 20:11:57 1994 Lennart Staflin - - * psgml-parse.el (sgml-open-element): take attribute specification - list as argument. Call hook sgml-open-element-hook. - (sgml-data-function): new var - (sgml-pi-function): new var - remove sgml-{g,e}name-symbol - (sgml-skip-cdata): rename to sgml-do-data - -Mon Sep 26 09:44:35 1994 Lennart Staflin - - * Version 1.0 a3 - -Sun Sep 25 16:12:06 1994 Lennart Staflin - - * psgml-parse.el: move sgml-set-markup-type - - * psgml-edit.el (sgml-do-set-option): add event argument - - * Id 1: C-c C-d may hang - psgml-edit.el (sgml-next-data-field): check if at end of buffer - - * psgml-edit.el (sgml-normalize-start-tag): can`t use - sgml-change-start-tag becuse trimming may have moved cursor to - some other place if the tag is implied. - - -Sun Sep 25 14:54:19 1994 Lennart Staflin (lenst@lysita) - - * psgml-lucid.el: Implement changes in psgml-other. - * Id 24: Lucid menubar problems, see above. - -Sun Sep 25 10:17:25 1994 Lennart Staflin - - * psgml-other.el (sgml-popup-menu): new func. - (sgml-max-menu-size): move here - - * psgml.el: split sgml-user-options into sgml-file-options and - sgml-user-options. Fix some properties and buffer local status. - (sgml-valid-option): new func. - (sgml-save-options): save all file options that are valid. - - * psgml-edit.el: options menu split into file and user options, - sgml-split-menu move to emacs specific files (psgml-other, - psgml-lucid). The emacs specific provides a sgml-popup-menu. - - * psgml.el (sgml-live-element-indicator): remove buffer localness - - * psgml-parse.el (sgml-parse-catalog-buffer): use sgml-parse-name - for doctype. - -Fri Sep 23 00:19:18 1994 Lennart Staflin - - * psgml-dtd.el (sgml-reduce-|): inline sgml-make-alt - - * psgml-parse.el (sgml-add-move-to-set): make into macro - (sgml-state-final-p): make into macro - - * psgml-dtd.el (sgml-make-primitive-content-token): make defsubst - - * psgml-parse.el (sgml-parse-name): remove defsubst - (sgml-parse-name): add compiler macro - - * psgml-dtd.el (sgml-remove-redundant-states-1): new optimizer - (sgml-make-*): use it - (sgml-make-+): use it - (sgml-make-conc): use it - - * psgml-parse.el (sgml-parse-ds): make defsubst - (sgml-parse-parameter-entity-ref): make defsubst - (sgml-do-parameter-entity-ref): new sub for above - (sgml-eltype-token): def compiler macro - (sgml-token-eltype): def compiler macro - - * psgml-dtd.el (sgml-parse-connector): make defsubst - (sgml-make-opt): nconc instead of append - - * psgml-parse.el (sgml-parser-loop): check for end tag before - skipping cdata - (sgml-skip-ps): make defsubst - - * psgml-dtd.el (sgml-parse-prolog): add cleanup entities - - * psgml-parse.el (sgml-parser-loop): move parsing of end-tag to - after shortref - - * psgml.el (sgml-debug): use sgml-log-message - - * psgml-parse.el (sgml-deref-shortmap): respect the nobol argument - (sgml-last-start-pos): New variable - (sgml-push-to-entity): set sgml-last-start-pos to buffer start if - entering an internal entity - (sgml-pop-entity): set sgml-last-start-pos - (sgml-parse-to): set sgml-last-start-pos - (sgml-parser-loop): call deref map with disabling of &#RS if point - is equal to sgml-last-start-pos - -Thu Sep 22 01:03:56 1994 Lennart Staflin - - * psgml-parse.el (sgml-cleanup-entities): clean up buffers used by - sgml-push-to-entity if some looping code has left a lot of buffers. - (sgml-need-dtd): call sgml-cleanup-entities - (sgml-push-to-entity): check that the sgml-cleanup-entities works, - cludge to make sure shortref maps don't find record-start in the - beginning of internal entities. This cludge breaks the epos - promotion code. - (sgml-set-parse-state): when setting parse state to start of a - element goto epos-end (not start+len). - -Sun Sep 18 05:49:17 1994 Lennart Staflin - - * psgml-parse.el - (sgml-parse-parameter-entity-ref): call sgml-push-to-entity with - optional argument 'param. - (sgml-push-to-entity): take new optional argument and pass it to - sgml-entity-insert-text. - (sgml-entity-insert-text): take extra type argument. - ci 2.8 - (sgml-eltype-mixed): add comp.macro - (sgml-parse-name): make defsubst - -Thu Sep 15 02:06:22 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-current-entity-map): add default-directory - (sgml-set-global): set default-directory in - sgml-current-entity-map - (sgml-check-name): fix bug in compiler-macro - (sgml-insert-external-entity): don't accepty directories as result - (sgml-push-to-entity): copy default-directory to new buffer - - * psgml.el (sgml-catalog-files): new default value - -Wed Sep 14 04:36:29 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-dtd): make type an untyped vector - -Tue Sep 13 06:35:43 1994 Lennart Staflin - - * psgml-parse.el (sgml-check-name): add comp-mac - (sgml-final): make defsubst - (sgml-final&): sub for above - (sgml-parse-pcdata): make defsubst - (sgml-eltype-name): add comp-mac - -Mon Sep 12 05:11:38 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-parse-processing-instruction): make defsubst - (sgml-do-processing-instruction): broken out from above - -Mon Sep 12 01:36:46 1994 Lennart Staflin - - * psgml-parse.el (sgml-parse-general-entity-ref): make defsubst - (sgml-do-general-entity-ref): broken out from above - (sgml-set-markup-type): make defsubst - -Sun Sep 11 21:49:14 1994 Lennart Staflin - - * psgml-parse.el (sgml-is-enabled-net): make defsubst - (sgml-parse-s): make defsubst - (sgml-element-mixed): add a compiler macro - -Sun Sep 11 00:00:45 1994 Lennart Staflin (lenst@lysita) - - * psgml-lucid.el: Install patch - From: Tim Bradshaw - in 4.0b2 with lemacs 19.10 and up I don't think you want to add - the SGML menus before the "Help" menu since then they come out at - the right hand of the menubar. Attached patch to psgml-lucid does - the trick. - - -Thu Sep 8 23:38:20 1994 Lennart Staflin - - * psgml-dtd.el (sgml-check-content): ANY also mixed - - -Thu Sep 8 22:35:19 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-make-shortmap): Only warning for strange - short ref delimiter - - * psgml-dtd.el (sgml-dtd-shortmaps): New variable - (sgml-declare-shortref): add mapping to variable - (sgml-check-doctype-body): add shortref maps from variable to dtd - struct - - * psgml-edit.el (sgml-custom-dtd): new command - (sgml-custom-markup): new command - -Thu Sep 8 01:17:59 1994 Lennart Staflin - - * psgml-edit.el (sgml-normalize): expand short references also - -Wed Sep 7 20:56:41 1994 Lennart Staflin - - * psgml-parse.el (sgml-reparse-buffer): New function. - - * nefarious.el (sgml-map-element-types): Update for 1.0 - - -Sun Sep 4 17:09:27 1994 Lennart Staflin - - * psgml-edit.el (sgml-untag-element): require tags to be in the - buffer - - * psgml-parse.el (sgml-update-display): parse to point-max after - parse to window-end - - * psgml.el (sgml-validate-command): change to use format string - (sgml-validate): use format - - * psgml-edit.el (sgml-operate-on-tags): give tags uniq numbers as - invisible property - -Sun Sep 4 10:21:54 1994 Lennart Staflin (lenst@lysita) - - * psgml-dtd.el (sgml-check-element-type): Fix problem with ranked - groups - - -Sun Sep 4 00:10:50 1994 Lennart Staflin - - * psgml-edit.el (sgml-indent-line): use sgml-find-context-of at - end of buffer. - -Sun Sep 3 23:00:00 1994 Lennart Staflin - - * Version 0.4b2 - -Fri Sep 2 19:48:41 1994 Lennart Staflin (lenst@lysita) - - * psgml.el (sgml-local-catalogs): new variable - - * psgml-parse.el: Implement local serach maps for entities - - -Tue Aug 30 17:28:42 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el: Introduce sgml-current-omittag and - sgml-current-shorttag that holds golbal copies of sgml-omittag and - sgml-shorttag. Change variable references where apropriate - - * psgml-edit.el (sgml-next-trouble-spot): ignore warnings before - point - (sgml-expand-entity-reference): New command - -Mon Aug 29 07:44:48 1994 Lennart Staflin - - * psgml-parse.el (sgml-parser-loop): Take argument: a function - that should return t if the loop should be prematurely exited - (sgml-parse-to): take optional argument to pass to sgml-parser-loop - - * psgml.el (sgml-command-post): function called from - post-command-hook. Activates DTD is `sgml-auto-activate-dtd' is - set and call `sgml-update-display' in psgml-parse if there is an - active DTD. - (sgml-auto-activate-dtd): New variable. - - * psgml-parse.el (sgml-update-display): instead of - sgml-set-live-indicator - - * psgml-dtd.el (sgml-parse-character-reference): only parse - function character refrences if optional argument is true - -Sat Aug 27 10:53:54 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el: Implement short references - -Fri Aug 26 02:47:35 1994 Lennart Staflin - - * psgml-edit.el (sgml-operate-on-tags): only set inivisible - property (and rear-nonsticky) - - * psgml-parse.el (sgml-parse-to): remove sgml-hide manipulation - -Fri Aug 26 00:02:30 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-set-live-element-indicator): don't let - point be inside an invisible region. - -Thu Aug 25 04:35:33 1994 Lennart Staflin (lenst@konrad) - - * psgml-edit.el (sgml-operate-on-tags): use category sgml-hide - instead of invisible+read-only. - - * psgml-parse.el (sgml-parse-to): temporary set sgml-hide's - property intangible to nil when parsing. - - * psgml.el (sgml-max-menu-size): set as 2/3 of frame-height - (psgml-version): bump version - - * psgml-parse.el (sgml-do-pcdata): set markup type nil, to delete - any overlays left from previous parse. - - * psgml-other.el (sgml-mode-map): change Fold to View - (sgml-set-face-after-change): disable - - * Version 1a1 - -Wed Aug 24 20:29:37 1994 Lennart Staflin (lenst@dell) - - * psgml-edit.el: changing append to nconc - - * psgml-parse.el: changing append to nconc - -Wed Aug 24 07:06:39 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-set-live-element-indicator): parse to - window-end after sit-for to set faces. - - * psgml.el (sgml-exposed-tags): new variable. - - * psgml-edit.el (sgml-operate-on-tags): install patch - From: kevinr@airedale (Kevin Rodgers) - (sgml-operate-on-tags): installed another patch from above. Added - variable sgml-exposed-tags. - -Tue Aug 23 02:32:45 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-load-dtd): install patch - date: 1994/08/19 18:30:03; author: kevinr; state: Exp; - lines: +3 -3 sgml-load-dtd, sgml-external-file: Use - `expand-file-name' instead of `concat'. - - * psgml-dtd.el (sgml-make-pcdata): change sgml-make-opt to - sgml-make-* - -Mon Aug 22 21:30:04 1994 Lennart Staflin (lenst@lysita) - - * psgml-edit.el: split psgml-parse into psgml-parse and psgml-edit - -Sat Aug 20 02:10:32 1994 Lennart Staflin (lenst@lysita) - - * psgml.texi (Attributes): add C-c C-d in attribute edit mode. - -Sat Aug 13 00:59:17 1994 Lennart Staflin (lenst@lysita) - - * psgml.el (sgml-mode): add some documentation. - -Mon Jul 19 1994 00:33:28 Kevin Rodgers - - * psgml-parse.el (sgml-close-element-hook): Define. - (sgml-close-element): Invoke `sgml-close-element-hook' after - `(sgml-tree-end sgml-current-tree)' and `(sgml-tree-etag-len - sgml-current-tree)' have been set. - -Fri Aug 12 21:19:52 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-pub-expand-char): remove test -- expand any - character. - - * experiment.el (sgml-pub-expand-char): remove test -- expand any - character. - -Thu Aug 11 20:13:44 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-push-to-param): move call to - sgml-external-file to before set-buffer. Simplify testing. - -Tue Jul 12 1994 21:39:20 Kevin Rodgers - - * psgml-parse.el (sgml-map-public): Accept an additional - optional argument, NAME, and map `n' to it if it's not nil. - (sgml-external-file): Pass the optional argument NAME to - `sgml-map-public'. - (sgml-pub-expand-char): Recognize `n' as well as `c', `o', and - `d' (and their upper-case variants). - -Wed Jul 6 21:17:41 1994 Lennart Staflin (lenst@konrad) - - * psgml-parse.el (sgml-next-data-field): stop any where but avoid - current element (previously only stopped at the beginning of an - element) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/README.psgml --- a/lisp/psgml/README.psgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,317 +0,0 @@ -This is the READ ME file for psgml.el version 1.0 -*- text -*- - - PSGML is a major mode for editing SGML documents. It works with -GNU Emacs 19.19 and later or with XEmacs 19.13. - -This distribution should contain the following source files: - psgml.el - psgml.texi - psgml-other.el - psgml-lucid.el - psgml-edit.el - psgml-parse.el - psgml-dtd.el - psgml-info.el - psgml-charent.el - psgml-api.texi -- internals documentation - psgml-api.el -- Extra functions for the API - iso88591.map - Makefile.in - -In addition the distribution contains the formatted versions of the -documentation files (psgml.info, ...). But the compiled elisp code is -no longer supplied. You will have to byte compile the files before -PSGML will achieve usable speed. - -PSGML now comes with autoconf support. See INSTALL for generic -instructions. Run - - sh configure - make - -and possibly - - make install - -If you are using xemacs, you can run give the argument `--with-xemacs' -to configure, or use `make xemacs'. - -Instead of using configure you can load the psgml-main.el file and run -the command psgml-compile-files. Then you have to set load-path or -move the .elc files. - -Send bug reports, comments and suggestions to lenst@lysator.liu.se. - -New in version 1.0 - -* Main changes - -** Support for general entities - -** Support for short reference - -** Support for catalog files - -** New mechanism for caching parsed DTD - -** Includes commands to list various aspects of the DTD - -* Entity support - -PSGML will recognize entity references (except in attribute values). If -the entity is a general text entity, PSGML will also parse the content -of the entity. To support this PSGML has a new entity manager with a -new mechanism for looking up entities (see belove). - -Short references are also supported, for the short reference delimiters -from the concrete reference syntax. - -There are some new and changed commands to complete the entity support: - -** Command: `sgml-expand-entity-reference' - -Insert the text of the entity referenced at point. - -** Command: `sgml-expand-all-shortrefs' - -Expand all short references in the buffer. Short references to text -entities are expanded to the replacement text of the entity, other -short references are expanded into general entity references. If -argument, `to-entity', is non-nil, or if called interactive with -numeric prefix argument, all short references are replaced by generally -entity references. - -** Command: `sgml-normalize' - -Changed to expand short references also. Normalize buffer by filling in -omitted tags and expanding empty tags. Argument `to-entity' controls -how short references are expanded as with `sgml-expand-all-shortrefs'. - -* Fontification - -If `sgml-set-face' is true and the DTD has been activated, PSGML will -automatically set the face of markup in the buffer. - -First the current line is parsed and fontified. If this would mean -parsing more than 500 chars, wait 1 second first. - -The rest of the buffer is fontified after 6 seconds idle time. - -Fontification can be interrupted by any input event. - -The buffer can be fontified initially if `sgml-auto-activate-dtd' is -true. - -* New entity manager - -The new entity manager will handle an entity reference thus: - -** If the entity has a system identifier, the entity manager will first -try and call the functions on `sgml-sysid-resolve-functions' with the -system identifier as argument, and if any function returns non-nil -assume that the function has handled the entity. - -** If the entity has a system identifier and -`sgml-system-identifiers-are-preferred' is non-nil, the system -identifier will be used as a file name relative to the file containing -the entity declaration. - -** Next the entity manager will try the catalog, and - -** if not found there use the `sgml-public-map'. - -** Finally if the entity has not been found and it has a system -identifier, this will be used as a file name. - -Note: `sgml-system-path' is no longer used for entity lookup. - -The catalog files searched is given by the variable -`sgml-local-catalogs' and `sgml-catalog-files'. The -`sgml-catalog-files' variable is initialized from the environment -variable `SGML_CATALOG_FILES' (should be a colon separated list of -files). The `sgml-local-catalogs' variable is assumed to be set in a -files local variables. - -File names for external entities (e.g system identifiers) are relative -to the directory containing the file declaring the entity. - -The `sgml-public-map' is initialized from the environment variable -`SGML_PATH'. - -`sgml-system-path' defaults to nil. - -Supports most of sgmls substitutions for sgml-public-map. Supported: -%%, %N, %P, %S, %Y, %C, %L, %O, %T, %V. Unsupported: %D, %X, %A, %E, -%I, %R, %U. Note: that %D is and alias for %C in PSGML (historical -accident). - -* New and changed options - -** `sgml-recompile-out-of-date-cdtd' - -** New options for insert-element: -`sgml-insert-missing-element-comment' and -`sgml-insert-end-tag-on-new-line'. - -** `sgml-validate-files' and slight change of `sgml-validate-command' - -The variable `sgml-validate-command' can now be a list of strings. The -strings can contain %-sequences that will be expanded: %b to buffer -file name, %s to SGML Declaration file, either the value of -sgml-declaration variable or SGML Declaration file for parent document -or DOCTYPE file or SGMLDECL from catalog. %d value of `sgml-doctype'. - -** `sgml-set-face' - -Now automatically sets faces for all visible text, with a delay of 1s. - -** `sgml-exposed-tags' - -The list of tag names that remain visible, despite `M-x -sgml-hide-tags'. Each name is a lowercase string, and start-tags and -end-tags must be listed individually. - -** `sgml-auto-activate-dtd' - -PSGML was behaving inconsistent when a new file was loaded. If the -variable `sgml-set-face' was true the DTD would automatically be -activated (loaded or parsed), but only if psgml-parse already loaded. - -Rather than let `sgml-set-face' decide if the DTD is activated, there -is now a distinct option for this. This option works even the first -time. - -If non-nil, loading a sgml-file will automatically try to activate its -DTD. Activation means either to parse the document type declaration or -to load a previously saved parsed DTD. The name of the activated DTD -will be shown in the mode line. - -* Various - -** Tracing catalog lookup - -To help debug entity lookup there is a new option -`sgml-trace-entity-lookup'. If this option is t messages will be logged -in *SGML LOG* buffer when external entities are looked up. These -messages shows entity, catalogs searched, and entry type in catalog -where entity was found. - -** Translating between characters and entity references - -Set the variable `sgml-display-char-list-filename' to a file that -contains mappings between all characters present in the presentation -character set, and their "standard replacement text" names, e.g. "å" -> -"[aring ]", e.t.c. The default value for this variable is -`iso88591.map'. - -Use the functions (also in the Modify menu) -`sgml-charent-to-display-char' and `sgml-display-char-to-charent' to -translate between entities and characters. - -** Handling of missing DOCTYPE - -If the document prolog does not contain a document type declaration, -PSGML will try to supply one on the form `' If the variable `sgml-default-doctype-name' is defined this -will be used for the document type name, otherwise the GI of the first -start tag will be used. I.e., if the document starts with `', a -document type declaration `' will be assumed. - -** Handling of tags for undefined elements - -*** Start-tags for undefined elements will either be ignored, if -`sgml-ignore-undefined-elements' is `t', or assumed to be acceptable in -the current element and defined with `O O ANY'. - -*** An end-tag for an element that is not currently open will be -ignored. - -** Cleaned up Markup menu - -The removed entries can be added with sgml-custom-markup: - -(setq sgml-custom-markup - '(("" "\n") - ("" "\n") - ("" "\n") - ("" "\n") - ("Local variables comment" "\n") - ("Comment" "\n") )) - -** New commands - -Thanks to David Megginson the custom menus are now reachable from the -keyboard: - -`C-c C-u C-d' (`sgml-custom-dtd') - -`C-c C-u C-m' (`sgml-custom-markup') - -* Changes to API - -** New hooks - -*** `sgml-close-element-hook' - -The hook run by `sgml-close-element'. These functions are invoked with -`sgml-current-tree' bound to the element just parsed. - -*** `sgml-new-attribute-list-function' - -This hook is run when a new element is inserted to construct the -attribute specification list. The default function prompts for the -required attributes. - -*** `sgml-doctype-parsed-hook' - -This hook is called after the doctype has been parsed. It can be used -to load any additional information into the DTD structure. - -Example: add description to element types - -(defun set-help-info () - (let ((help '(("para" "A Paragraph") - ("q" "A Quotation") - ("date" "A Date"))) - (dtd (sgml-pstate-dtd sgml-buffer-parse-state))) - (loop for h in help do - (setf (sgml-eltype-appdata (sgml-lookup-eltype (first h) dtd) - 'help-string) - (second h))))) -(add-hook 'sgml-doctype-parsed-hook 'set-help-info) -(defun sgml-help-for-element () - (interactive) - (let* ((el (sgml-find-element-of (point))) - (help (sgml-element-appdata el 'help-string))) - (and help - (message "%s" help)))) - -*** sgml-sysid-resolve-functions - -This variable should contain a list of functions. Each function should -take one argument, the system identifier of an entity. If the function -can handle that identifier, it should insert the text of the entity -into the current buffer at point and return t. If the system identifier -is not handled the function should return nil. - -Example use: Support URLs as system identifiers - -(defun sgml-url-sysid (sysid) - (cond ((string-match "^\\([a-z]+\\):" sysid) ; looks like url - (require 'url) - (set-buffer (prog1 (current-buffer) - (url-retrieve sysid))) - (insert-buffer url-working-buffer) - t))) -(add-hook 'sgml-sysid-resolve-functions 'sgml-url-sysid) - -** New file psgml-api.el - -This file contain API-functions that are not used by other parts of -psgml. Use `(require 'psgml-api)' to use the API functions (psgml-api -includes the rest of the psgml files). - -Local variables: -mode: text -mode: outline -end: diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/auto-autoloads.el --- a/lisp/psgml/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,95 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'psgml-autoloads) (error "Already loaded")) - -;;;### (autoloads (style-format) "psgml-fs" "psgml/psgml-fs.el") - -(autoload 'style-format "psgml-fs" nil t nil) - -;;;*** - -;;;### (autoloads nil "psgml-html" "psgml/psgml-html.el") - -(autoload 'html-mode "psgml-html" "\ -HTML mode." t) - -(autoload 'html3-mode "psgml-html" "\ -HTML3 mode." t) - -;;;*** - -;;;### (autoloads (sgml-mode) "psgml" "psgml/psgml.el") - -(autoload 'sgml-mode "psgml" "\ -Major mode for editing SGML.\\ -Makes > display the matching <. Makes / display matching /. -Use \\[sgml-validate] to validate your document with an SGML parser. - -You can find information with: -\\[sgml-show-context] Show the nesting of elements at cursor position. -\\[sgml-list-valid-tags] Show the tags valid at cursor position. - -Insert tags with completion of contextually valid tags with \\[sgml-insert-tag]. -End the current element with \\[sgml-insert-end-tag]. Insert an element (i.e. -both start and end tag) with \\[sgml-insert-element]. Or tag a region with -\\[sgml-tag-region]. - -To tag a region with the mouse, use transient mark mode or secondary selection. - -Structure editing: -\\[sgml-backward-element] Moves backwards over the previous element. -\\[sgml-forward-element] Moves forward over the next element. -\\[sgml-down-element] Move forward and down one level in the element structure. -\\[sgml-backward-up-element] Move backward out of this element level. -\\[sgml-beginning-of-element] Move to after the start tag of the current element. -\\[sgml-end-of-element] Move to before the end tag of the current element. -\\[sgml-kill-element] Kill the element following the cursor. - -Finding interesting positions -\\[sgml-next-data-field] Move forward to next point where data is allowed. -\\[sgml-next-trouble-spot] Move forward to next point where something is - amiss with the structure. - -Folding and unfolding -\\[sgml-fold-element] Fold the lines comprising the current element, leaving - the first line visible. -\\[sgml-fold-subelement] Fold the elements in the content of the current element. - Leaving the first line of every element visible. -\\[sgml-unfold-line] Show hidden lines in current line. - -User options: - -sgml-omittag Set this to reflect OMITTAG in the SGML declaration. -sgml-shortag Set this to reflect SHORTTAG in the SGML declaration. -sgml-auto-insert-required-elements If non-nil, automatically insert required - elements in the content of an inserted element. -sgml-balanced-tag-edit If non-nil, always insert start-end tag pairs. -sgml-omittag-transparent If non-nil, will show legal tags inside elements - with omitable start tags and legal tags beyond omitable end tags. -sgml-leave-point-after-insert If non-nil, the point will remain after - inserted tag(s). -sgml-warn-about-undefined-elements If non-nil, print a warning when a tag - for a undefined element is found. -sgml-max-menu-size Max number of entries in Tags and Entities menus before - they are split into several panes. -sgml-always-quote-attributes If non-nil, quote all attribute values - inserted after finishing edit attributes. -sgml-minimize-attributes Determines minimization of attributes inserted by - edit-attributes. -sgml-normalize-trims If non-nil, sgml-normalize will trim off white space - from end of element when adding end tag. -sgml-indent-step How much to increament indent for every element level. -sgml-indent-data If non-nil, indent in data/mixed context also. -sgml-set-face If non-nil, psgml will set the face of parsed markup. -sgml-markup-faces The faces used when the above variable is non-nil. -sgml-system-path List of directories used to look for system identifiers. -sgml-public-map Mapping from public identifiers to file names. -sgml-offer-save If non-nil, ask about saving modified buffers before - \\[sgml-validate] is run. - -All bindings: -\\{sgml-mode-map} -" t nil) - -;;;*** - -(provide 'psgml-autoloads) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/custom-load.el --- a/lisp/psgml/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Thu Oct 9 20:52:27 1997 - -;;; Code: - -(custom-put 'extensions 'custom-loads '("tempo")) -(custom-put 'psgml-dtd 'custom-loads '("psgml")) -(custom-put 'html 'custom-loads '("psgml-html")) -(custom-put 'psgml 'custom-loads '("psgml-html" "psgml")) -(custom-put 'psgml-html 'custom-loads '("psgml-html")) -(custom-put 'sgml 'custom-loads '("psgml-html" "psgml")) -(custom-put 'tempo 'custom-loads '("tempo")) -(custom-put 'languages 'custom-loads '("psgml")) -(custom-put 'psgml-insert 'custom-loads '("psgml")) - -;;; custom-load.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/iso-sgml.el --- a/lisp/psgml/iso-sgml.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,264 +0,0 @@ -;; iso-sgml.el --- display SGML entity references as ISO 8859-1 characters - -;; Copyright (C) 1994 Frederic Lepied - -;; Author: Frederic Lepied -;; Maintainer: lepied@cenaath.cena.dgac.fr -;; Keywords: SGML, HTML, ISO, Latin, i18n -;; Status: Works with emacs 19.24 -;; Created: 1994-06-21 -;; Last Modified By: Frederic Lepied [STERIA SIT] 69577103 -;; Last Modified On: Wed Dec 7 10:14:41 1994 -;; Update Count: 5 - -;; LCD Archive Entry: -;; iso-sgml|Frederic Lepied|lepied@cenaath.cena.dgac.fr| -;; Edit SGML or HTML buffers with ISO 8859-1 (Latin-1) display| -;; 10-May-1995|1.4|~/misc/iso-sgml.el.Z| - -;; $Id: iso-sgml.el,v 1.2 1997/09/27 16:57:46 steve Exp $ - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, you can either send email to this -;; program's maintainer or write to: The Free Software Foundation, -;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA. - -;; Commentary: -;; Based on iso-cvt.el from Michael Gschwind , -;; iso-sgml.el transparently displays entity references in SGML or HTML -;; buffers as ISO 8859-1 (aka Latin-1) characters. -;; Modified for XEmacs 19.15 to include the proposed extensions to Latin-1 -;; by Steve Baur - -;; SEE ALSO: -;; iso-cvt.el -;; If you are interested in questions related to using the ISO 8859-1 -;; characters set (configuring emacs, Unix, etc. to use ISO), then you -;; can get the ISO 8859-1 FAQ via anonymous ftp from -;; ftp.vlsivie.tuwien.ac.at in /pub/bit/FAQ-ISO-8859-1 - -;; INSTALLATION: -;; add the following line to your .emacs : -;; (load "iso-sgml") -;; If you want it to work with other modes change the value of the -;; the variable isosgml-modes-list like this : -;; (setq isosgml-modes-list '(my-mode)) - -;; Code: - -(defconst isosgml-version "$Id: iso-sgml.el,v 1.2 1997/09/27 16:57:46 steve Exp $" - "iso-sgml RCS version number") - -(defvar isosgml-modes-list '(html-mode html-helper-mode sgml-mode) - "*List of modes to translate between SGML or HTML entity references - and the ISO 8859-1 character set.") - - -(defun isosgml-translate-conventions (trans-tab) - "Use the translation table argument to translate the current buffer." - (save-excursion - (let ((beg (point-min-marker)) ; see the `(elisp)Narrowing' Info node - (end (point-max-marker))) - (unwind-protect - (progn - (widen) - (goto-char (point-min)) - (let ((buffer-read-only nil) ; (inhibit-read-only t)? - (case-fold-search nil)) - (while trans-tab - (save-excursion - (let ((trans-this (car trans-tab))) - (while (search-forward (car trans-this) nil t) - (replace-match (car (cdr trans-this)) t t))) - (setq trans-tab (cdr trans-tab)))))) - (narrow-to-region beg end))))) - -(defvar sgml2iso-trans-tab - '( - ("Æ\;" "Æ") - ("Á\;" "Á") - ("Â\;" "Â") - ("À\;" "À") - ("Ã\;" "Ã") - ("Ç\;" "Ç") - ("É\;" "É") - ("È\;" "È") - ("Ë\;" "Ë") - ("Í\;" "Í") - ("Î\;" "Î") - ("Ì\;" "Ì") - ("Ï\;" "Ï") - ("Ñ\;" "Ñ") - ("Ó\;" "Ó") - ("Ô\;" "Ô") - ("Ò\;" "Ò") - ("Ø\;" "Ø") - ("Ú\;" "Ú") - ("Ù\;" "Ù") - ("Ý\;" "Ý") - ("á\;" "á") - ("â\;" "â") - ("´\;" "´") - ("æ\;" "æ") - ("à\;" "à") - ("å\;" "å") - ("ã\;" "ã") - ("¦\;" "¦") - ("ç\;" "ç") - ("¸\;" "¸") - ("¢\;" "¢") - ("©\;" "©") - ("¤\;" "¤") - ("°\;" "°") - ("é\;" "é") - ("ê\;" "ê") - ("è\;" "è") - ("ë\;" "ë") - ("½\;" "½") - ("¼\;" "¼") - ("¾\;" "¾") - ("í\;" "í") - ("î\;" "î") - ("ì\;" "ì") - ("¡\;" "¡") - ("¿\;" "¿") - ("ï\;" "ï") - ("«\;" "«") - ("¯\;" "¯") - ("µ\;" "µ") - ("·\;" "·") - (" \;" " ") - ("¬\;" "¬") - ("ñ\;" "ñ") - ("ó\;" "ó") - ("ô\;" "ô") - ("ò\;" "ò") - ("ª\;" "ª") - ("º\;" "º") - ("ø\;" "ø") - ("õ\;" "õ") - ("¶\;" "¶") - ("£\;" "£") - ("±\;" "±") - ("«\;" "»") - ("®\;" "®") - ("§\;" "§") - ("­\;" "­") - ("¹\;" "¹") - ("²\;" "²") - ("²\;" "³") - ("ú\;" "ú") - ("û\;" "û") - ("ù\;" "ù") - ("¨\;" "¨") - ("ý\;" "ý") - ("¥\;" "¥") - ("Ä\;" "Ä") - ("ä\;" "ä") - ("Ö\;" "Ö") - ("ö\;" "ö") - ("Ü\;" "Ü") - ("ü\;" "ü") - ("ß\;" "ß") - ("§\;" "§") - ("¶\;" "¶") - ("©\;" "©") - ("¡\;" "¡") - ("¿\;" "¿") - ("¢\;" "¢") - ("£\;" "£") - ("×\;" "×") - ("±\;" "±") - ("÷\;" "÷") - ("¬\;" "¬") - ("&mu\;" "µ") - ("&Ae\;" "Ä") - ("&ae\;" "ä") - ("&Oe\;" "Ö") - ("&oe\;" "ö") - ("&Ue\;" "Ü") - ("&ue\;" "ü") - ("&sz\;" "ß") - ) - "Translation table from SGML entity references to ISO 8859-1 characters.") - -(defun fix-sgml2iso () - "Replace SGML entity references with ISO 8859-1 (aka Latin-1) characters." - (interactive) - (if (member major-mode isosgml-modes-list) - (let ((buffer-modified-p (buffer-modified-p))) - (unwind-protect - (isosgml-translate-conventions sgml2iso-trans-tab) - (set-buffer-modified-p buffer-modified-p))))) - -(defvar iso2sgml-trans-tab - (mapcar (function (lambda (entity-char) ; (ENTITY CHAR) - ;; Return (CHAR ENTITY) - (list (car (cdr entity-char)) - (car entity-char)))) - sgml2iso-trans-tab) - "Translation table from ISO 8859-1 characters to SGML entity references.") - -(defun fix-iso2sgml () - "Replace ISO 8859-1 (aka Latin-1) characters with SGML entity references." - (interactive) - (if (member major-mode isosgml-modes-list) - (let ((buffer-modified-p (buffer-modified-p))) - (unwind-protect - (isosgml-translate-conventions iso2sgml-trans-tab) - (set-buffer-modified-p buffer-modified-p))))) - - -(add-hook 'find-file-hooks 'fix-sgml2iso) -(add-hook 'write-file-hooks 'fix-iso2sgml) -(add-hook 'after-save-hook 'fix-sgml2iso) - -(provide 'iso-sgml) - -;; iso-sgml.el ends here - -; $Log: iso-sgml.el,v $ -; Revision 1.2 1997/09/27 16:57:46 steve -; Patches to beta24 -; -; Revision 1.4 1995/05/10 06:19:41 lepied -; * protect code with unwind-protect to prevent errors -; -; Revision 1.3 1994/12/07 09:08:07 lepied -; Thanks to kevinr@ihs.com (Kevin Rodgers) -; * replace regular expression search with normal one -; * cleanup interactive use -; -; Revision 1.2 1994/11/24 06:49:08 lepied -; Integrated patch from kevinr@ihs.com (Kevin Rodgers) : -; -; * iso-sgml.el (sgml2iso-trans-tab): Delete backslash (`\') from -; "±" entity reference. -; -; * iso-sgml.el (file header, library header (Keywords), LCD -; Archive Entry (description) [comment blocks]): Properly refer to -; SGML entity references; uppercase acronyms (ISO, SGML, HTML); -; capitalize Latin. -; (Commentary [comment block]): Rewrite as a complete sentence. -; (sgml2iso-trans-tab, fix-sgml2iso [doc strings]): Properly refer -; to SGML entity references. -; (iso2sgml-trans-tab, fix-iso2sgml [doc strings]): Properly refer -; to SGML entity references. -; -; * iso-sgml.el (iso2sgml-trans-tab): Initialize by -; programmatically reversing elements of sgml2iso-trans-tab, -; instead of hand-coding each element. -; -; Revision 1.1 1994/06/22 15:15:13 lepied -; Initial revision -; diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-api.el --- a/lisp/psgml/psgml-api.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,107 +0,0 @@ -;;; psgml-api.el --- Extra API functions for PSGML -;; $Id: psgml-api.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;; Commentary: - -;; Provides some extra functions for the API to PSGML. - - -;;; Code: - -(provide 'psgml-api) -(require 'psgml) -(require 'psgml-parse) - - -;;;; Mapping: map and modify - -(defun sgml-map-element-modify (el-fun element) - "Apply EL-FUN to ELEMENT and the elements in its content. -The EL-FUN may change the buffer. But if it changes the buffer and -leaves the element with no start-tag some elements may be ignored." - (let ((level ; level in the element tree - 0) - next - (tick ; change counter - (buffer-modified-tick))) - (while element - (funcall el-fun element) - ;; If the function has modified the buffer, a fresh parse is needed - (when (/= tick (buffer-modified-tick)) - (setq element (sgml-find-element-of (sgml-element-start element))) - (setq tick (buffer-modified-tick))) - (cond - ;; Map content if any - ((setq next (sgml-element-content element)) - (incf level)) - ;; If in a sub-tree, move to next element - (t - (while (and (> level 0) - (null (setq next (sgml-element-next element)))) - (setq element (sgml-element-parent element)) - (decf level)))) - (setq element next)))) - -;;;; Map content - -(defun sgml-map-content (element element-fun - &optional data-fun pi-fun entity-fun) - "Map content of ELEMENT, calling ELEMENT-FUN for every element. -Also calling DATA-FUN, if non-nil, with data in content." - (sgml-pop-all-entities) - (sgml-need-dtd) - (sgml-element-end element) ; Make sure all content is parsed - (let ((main-buffer-max (point-max))) - (save-excursion - (sgml-set-parse-state element 'start) - (when (eobp) (sgml-pop-entity)) - (when (eolp) (forward-char 1)) - (sgml-parse-data main-buffer-max data-fun pi-fun entity-fun) - (let ((c (sgml-tree-content element))) - (while c - (sgml-pop-all-entities) - (funcall element-fun c) - (sgml-set-parse-state c 'after) - (sgml-parse-data main-buffer-max data-fun pi-fun entity-fun) - (setq c (sgml-tree-next c))))) - ) - (sgml-pop-all-entities)) - -(defun sgml-parse-data (sgml-goal sgml-data-function sgml-pi-function - sgml-entity-function) - (let ((sgml-throw-on-element-change 'el-done)) - (catch sgml-throw-on-element-change - (sgml-with-parser-syntax - (sgml-parser-loop nil))))) - -;;;; Entity management - -(defun sgml-push-to-string (string) - "Create an entity from STRING and push it on the top of the entity stack. -After this the current buffer will be a scratch buffer containing the text -of the new entity with point at the first character. - Use `sgml-pop-entity' to exit from this buffer." - (sgml-push-to-entity (sgml-make-entity "#STRING" 'text string))) - - - -;;; psgml-api.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-charent.el --- a/lisp/psgml/psgml-charent.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,118 +0,0 @@ -;;;; psgml-charent.el -;;; Last edited: Mon Nov 28 22:18:09 1994 by lenst@lysistrate (Lennart Staflin) -;;; $Id: psgml-charent.el,v 1.2 1997/04/24 04:00:12 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Steinar Bang, Falch Hurtigtrykk as., Oslo, 940711 -;; Lennart Staflin -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Functions to convert character entities into displayable characters -;; and displayable characters back into character entities. - - -;;;; Code: - -(provide 'psgml-charent) -(require 'psgml-parse) - - -;;;; Variable declarations - -(defvar sgml-display-char-list-filename - (expand-file-name "sgml/iso88591.map" data-directory) - "*Name of file holding relations between character codes and character -names of displayable characters") - -(defvar sgml-display-char-alist-cache nil) - - -;;;; Function declarations - -(defun sgml-display-char-alist () - "Return the current display character alist. -Alist with entity name as key and display character as content." - (unless (file-exists-p sgml-display-char-list-filename) - (error "No display char file: %s" - sgml-display-char-list-filename)) - (sgml-cache-catalog sgml-display-char-list-filename - 'sgml-display-char-alist-cache - (function sgml-read-display-char-alist))) - -(defun sgml-read-display-char-alist () - (let (key disp-char alist) - (while (re-search-forward "^\\([0-9]+\\)[ \t]+\\(.+\\)$" nil t) - (setq key (buffer-substring (match-beginning 2) (match-end 2))) - (setq disp-char - (char-to-string - (string-to-number - (buffer-substring (match-beginning 1) (match-end 1))))) - (push (cons key disp-char) - alist)) - alist)) - -(defun sgml-charent-to-dispchar-alist () - "Association list to hold relations of the type - (CHARACTER-NAME . CHARACTER) - where - CHARACTER-NAME is a string holding a character name - CHARACTER is a string holding a single displayable character" - (sgml-need-dtd) - (let ((display-chars (sgml-display-char-alist)) - (alist nil)) - (sgml-map-entities - (function - (lambda (entity) - (let ((char (cdr (assoc (sgml-entity-text entity) - display-chars)))) - (when char - (push (cons (sgml-entity-name entity) char) alist))))) - (sgml-dtd-entities sgml-dtd-info)) - - alist)) - - -(defun sgml-charent-to-display-char () - "Replace character entities with their display character equivalents" - (interactive) - (let ((charent-to-char - (sgml-charent-to-dispchar-alist)) - charent replacement) - (save-excursion - (goto-char (point-min)) - (sgml-with-parser-syntax - (while (re-search-forward "&\\(\\w\\(\\w\\|\\s_\\)+\\);?" nil t) - (setq charent (buffer-substring (match-beginning 1) (match-end 1))) - (if (setq replacement (cdr (assoc charent charent-to-char))) - (replace-match replacement t t))))))) - -(defun sgml-display-char-to-charent () - "Replace displayable characters with their character entity equivalents" - (interactive) - (let ((case-fold-search nil)) - (save-excursion - (loop for pair in (sgml-charent-to-dispchar-alist) - do (goto-char (point-min)) - (while (search-forward (cdr pair) nil t) - (replace-match (concat "&" (car pair) ";") t t)))))) - - - -;;; psgml-charent.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-debug.el --- a/lisp/psgml/psgml-debug.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,370 +0,0 @@ -;;;;\filename dump.el -;;;\Last edited: Sun Mar 24 19:17:42 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin) -;;;\RCS $Id: psgml-debug.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ -;;;\author {Lennart Staflin} -;;;\maketitle - -;;\begin{codeseg} -(provide 'psgml-debug) -(require 'psgml) -(require 'psgml-parse) -(require 'psgml-edit) -(require 'psgml-dtd) -(autoload 'sgml-translate-model "psgml-dtd" "" nil) - -;;;; Debugging - -(define-key sgml-mode-map "\C-c," 'sgml-goto-cache) -(define-key sgml-mode-map "\C-c\C-x" 'sgml-dump-tree) -(define-key sgml-mode-map "\C-c." 'sgml-shortref-identify) - -(defun sgml-this-element () - (interactive) - (let ((tree (sgml-find-element-of (point)))) - (sgml-dump-rec tree))) - -(defun sgml-goto-cache () - (interactive) - (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state) - sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state)) - (sgml-find-start-point (point)) - (message "%s" (sgml-dump-node sgml-current-tree))) - -(defun sgml-dump-tree (arg) - (interactive "P") - (when arg - (sgml-parse-to-here)) - (with-output-to-temp-buffer "*Dump*" - (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state)))) - -(defun sgml-auto-dump () - (let ((standard-output (get-buffer-create "*Dump*")) - (cb (current-buffer))) - - (when sgml-buffer-parse-state - (unwind-protect - (progn (set-buffer standard-output) - (erase-buffer)) - (set-buffer cb)) - - (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state)) - - )) - ) - -(defun sgml-start-auto-dump () - (interactive) - (add-hook 'post-command-hook - (function sgml-auto-dump) - 'append)) - -(defun sgml-comepos (epos) - (if (sgml-strict-epos-p epos) - (format "%s:%s" - (sgml-entity-name (sgml-eref-entity (sgml-epos-eref epos))) - (sgml-epos-pos epos)) - (format "%s" epos))) - -(defun sgml-dump-node (u) - (format - "%s%s start:%s(%s) end:%s(%s) epos:%s/%s net:%s\n" - (make-string (sgml-tree-level u) ?. ) - (sgml-element-gi u) - (sgml-element-start u) (sgml-tree-stag-len u) - (if (sgml-tree-etag-epos u) (sgml-tree-end u)) (sgml-tree-etag-len u) - (sgml-comepos (sgml-tree-stag-epos u)) - (sgml-comepos (sgml-tree-etag-epos u)) - (sgml-tree-net-enabled u))) - -(defun sgml-dump-rec (u) - (while u - (princ (sgml-dump-node u)) - (sgml-dump-rec (sgml-tree-content u)) - (setq u (sgml-tree-next u)))) - -(defun sgml-shortref-identify () - (interactive) - (sgml-find-context-of (point)) - (let* ((nobol (eq (point) sgml-rs-ignore-pos)) - (tem (sgml-deref-shortmap sgml-current-shortmap nobol))) - (message "%s (%s)" tem nobol))) - -(defun sgml-lookup-shortref-name (table map) - (car (rassq map (cdr table)))) - -(defun sgml-show-current-map () - (interactive) - (sgml-find-context-of (point)) - (let ((name (sgml-lookup-shortref-name - (sgml-dtd-shortmaps sgml-dtd-info) - sgml-current-shortmap))) - (message "Current map: %s" - (or name "#EMPTY")))) - -;;;; For edebug - -;;(put 'when 'edebug-form-hook t) -;;(put 'unless 'edebug-form-hook t) -;;(put 'push 'edebug-form-hook '(form sexp)) -;;(put 'setf 'edebug-form-hook '(sexp form)) - -(setq edebug-print-level 3 - edebug-print-length 5 - edebug-print-circle nil -) - -(eval-when (load) - (unless sgml-running-xemacs - (def-edebug-spec sgml-with-parser-syntax (&rest form)) - (def-edebug-spec sgml-skip-upto (sexp)) - (def-edebug-spec sgml-check-delim (sexp &optional sexp)) - (def-edebug-spec sgml-parse-delim (sexp &optional sexp)) - (def-edebug-spec sgml-is-delim (sexp &optional sexp sexp sexp)))) - -;;;; dump - -(defun sgml-dump-dtd (&optional dtd) - (interactive ) - (unless dtd - (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state))) - (with-output-to-temp-buffer "*DTD dump*" - (princ (format "Dependencies: %S\n" - (sgml-dtd-dependencies dtd))) - (loop for et being the symbols of (sgml-dtd-eltypes dtd) - do (sgml-dp-element et)))) - -(defun sgml-dump-element (el-name) - (interactive - (list (completing-read "Element: " - (sgml-dtd-eltypes - (sgml-pstate-dtd sgml-buffer-parse-state)) - nil t))) - (with-output-to-temp-buffer "*Element dump*" - (sgml-dp-element (sgml-lookup-eltype el-name)))) - -(defun sgml-dp-element (el) - (cond - ((sgml-eltype-defined el) - (princ (format "Element %s %s %s%s:\n" - (sgml-eltype-name el) - (if (sgml-eltype-stag-optional el) "O" "-") - (if (sgml-eltype-etag-optional el) "O" "-") - (if (sgml-eltype-mixed el) " mixed" ""))) - (cond - ((sgml-model-group-p (sgml-eltype-model el)) - (sgml-dp-model (sgml-eltype-model el))) - (t - (prin1 (sgml-eltype-model el)) - (terpri))) - (princ (format "Exeptions: +%S -%S\n" - (sgml-eltype-includes el) - (sgml-eltype-excludes el))) - (princ (format "Attlist: %S\n" (sgml-eltype-attlist el))) - (princ (format "Plist: %S\n" (symbol-plist el)))) - (t - (princ (format "Undefined element %s\n" (sgml-eltype-name el))))) - (terpri)) - - -(defun sgml-dp-model (model &optional indent) - (or indent (setq indent 0)) - (let ((sgml-code-xlate (sgml-translate-model model))) - (loop - for i from 0 - for x in sgml-code-xlate do - (cond ((sgml-normal-state-p (car x)) - (princ (format "%s%d: opts=%s reqs=%s\n" - (make-string indent ? ) i - (sgml-untangel-moves (sgml-state-opts (car x))) - (sgml-untangel-moves (sgml-state-reqs (car x)))))) - (t ; and-node - (princ (format "%s%d: and-node next=%d\n" - (make-string indent ? ) i - (sgml-code-xlate (sgml-and-node-next (car x))))) - (loop for m in (sgml-and-node-dfas (car x)) - do (sgml-dp-model m (+ indent 2)))))))) - -(defun sgml-untangel-moves (moves) - (loop for m in moves - collect (list (sgml-move-token m) - (sgml-code-xlate (sgml-move-dest m))))) - - -;;;; Dump state - -(defun sgml-dump-state () - (interactive) - (with-output-to-temp-buffer "*State dump*" - (sgml-dp-state sgml-current-state))) - -(defun sgml-dp-state (state &optional indent) - (or indent (setq indent 0)) - (cond - ((sgml-normal-state-p state) - (sgml-dp-model state indent)) - (t - (princ (format "%sand-state\n" (make-string indent ? ))) - (sgml-dp-state (sgml-and-state-substate state) (+ 2 indent)) - (princ (format "%s--next\n" (make-string indent ? ))) - (sgml-dp-state (sgml-and-state-next state) (+ 2 indent)) - (princ (format "%s--dfas\n" (make-string indent ? ))) - (loop for m in (sgml-and-state-dfas state) - do (sgml-dp-model m (+ indent 2)) - (princ (format "%s--\n" (make-string indent ? ))))))) - - -;;;; Build autoloads for all interactive functions in psgml-parse - -(defun sgml-build-autoloads () - (interactive) - (with-output-to-temp-buffer "*autoload*" - (loop - for file in '("psgml-parse" "psgml-edit" "psgml-dtd" - "psgml-info" "psgml-charent") - do - (set-buffer (find-file-noselect (concat file ".el"))) - (goto-char (point-min)) - (while (and - (not (eobp)) - (re-search-forward "^(defun +\\([^ ]+\\)" nil t)) - (let ((name (buffer-substring (match-beginning 1) - (match-end 1))) - doc) - (forward-sexp 1) ; skip argument list - (skip-chars-forward " \n\t") - (when (eq ?\" (following-char)) ; doc string - (setq doc (buffer-substring (point) - (progn (forward-sexp 1) - (point))))) - (skip-chars-forward " \n\t") - (when (looking-at "(interactive") - (if (null doc) - (message "No doc for %s" name)) - (princ (format - "(autoload '%s \"%s\" %s t)\n" - name file doc)))))))) - -;;;; Test psgml with sgmls test cases - -(defun test-sgml (start) - (interactive "p") - (let (file - (sgml-show-warnings t)) - (with-output-to-temp-buffer "*Testing psgml*" - (while - (progn - (setq file (format "/usr/local/src/sgmls-1.1/test/test%03d.sgm" - start)) - (file-exists-p file)) - (princ (format "*** File test%03d ***\n" start)) - (find-file file) - (condition-case errcode - (progn - (sgml-parse-prolog) - ;;(sgml-next-trouble-spot) - (sgml-parse-until-end-of nil) - ) - (error - (princ errcode) - (terpri))) - (if (get-buffer sgml-log-buffer-name) - (princ (save-excursion - (set-buffer sgml-log-buffer-name) - (buffer-string)))) - (terpri) - (terpri) - (sit-for 0) - (kill-buffer (current-buffer)) - (setq start (1+ start)))))) - - -;;;; Profiling - -(defun profile-sgml (&optional file) - (interactive) - (or file (setq file (expand-file-name "~/src/psgml/0/test/shortref.sgml"))) - (find-file file) - (sgml-need-dtd) - (sgml-instrument-parser) - (elp-reset-all) - (dotimes (i 20) - (garbage-collect) - (sgml-reparse-buffer (function sgml-handle-shortref))) - (elp-results)) - -(defun sgml-instrument-parser () - (interactive) - (require 'elp) - (setq elp-function-list nil) - (elp-restore-all) - (setq elp-function-list - '( - sgml-parse-to - sgml-parser-loop - sgml-parse-markup-declaration - sgml-do-processing-instruction - sgml-pop-entity - sgml-tree-net-enabled - sgml-do-end-tag - sgml-do-data - sgml-deref-shortmap - sgml-handle-shortref - sgml-do-start-tag - sgml-do-general-entity-ref - sgml-set-face-for - sgml-pcdata-move - sgml-shortmap-skipstring - ;; - )) - (elp-instrument-list)) - - -(defun sgml-instrument-dtd-parser () - (interactive) - (require 'elp) - (setq elp-function-list nil) - (elp-restore-all) - (setq elp-function-list - '( - sgml-parse-prolog - sgml-skip-ds - sgml-parse-markup-declaration - sgml-check-doctype-body - ;; - sgml-check-dtd-subset - sgml-parse-ds - sgml-declare-attlist - sgml-declare-entity - sgml-declare-element - sgml-declare-shortref - ;; - sgml-parse-parameter-literal - sgml-check-element-type - sgml-check-primitive-content-token - sgml-check-model-group - ;; In sgml-check-model-group - sgml-parse-modifier - sgml-make-pcdata - sgml-skip-ts - sgml-make-opt - sgml-make-* - sgml-make-+ - sgml-reduce-, - sgml-reduce-| - sgml-make-& - sgml-make-conc - sgml-copy-moves - ;; is ps* - sgml-do-parameter-entity-ref - ;; - sgml-make-primitive-content-token - sgml-push-to-entity - sgml-lookup-entity - sgml-lookup-eltype - sgml-one-final-state - sgml-remove-redundant-states-1 - )) - (elp-instrument-list)) - - -;¤¤\end{codeseg} diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-dtd.el --- a/lisp/psgml/psgml-dtd.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,925 +0,0 @@ -;;;; psgml-dtd.el --- DTD parser for SGML-editing mode with parsing support -;; $Id: psgml-dtd.el,v 1.2 1997/01/03 03:10:27 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Part of major mode for editing the SGML document-markup language. - - -;;;; Code: - -(provide 'psgml-dtd) -(require 'psgml) -(require 'psgml-parse) - - -;;;; Variables - -;; Variables used during doctype parsing and loading -(defvar sgml-used-pcdata nil - "True if model group built is mixed") - - -;;;; Constructing basic - -(defun sgml-copy-moves (s1 s2) - "Copy all moves from S1 to S2, keeping their status." - (let ((l (sgml-state-opts s1))) - (while l - (sgml-add-opt-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))) - (setq l (sgml-state-reqs s1)) - (while l - (sgml-add-req-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))))) - -(defun sgml-copy-moves-to-opt (s1 s2) - "Copy all moves from S1 to S2 as optional moves." - (let ((l (sgml-state-opts s1))) - (while l - (sgml-add-opt-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))) - (setq l (sgml-state-reqs s1)) - (while l - (sgml-add-opt-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))))) - - -(defun sgml-some-states-of (state) - ;; List of some states reachable from STATE, includes all final states - (let* ((states (list state)) - (l states) - s ms m) - (while l - (setq s (car l) - ms (append (sgml-state-opts s) (sgml-state-reqs s))) - (while ms - (setq m (sgml-move-dest (car ms)) - ms (cdr ms)) - (unless (sgml-normal-state-p m) - (setq m (sgml-and-node-next m))) - (unless (memq m states) - (nconc states (list m)))) - (setq l (cdr l))) - states)) - -(defmacro sgml-for-all-final-states (s dfa &rest forms) - "For all final states S in DFA do FORMS. -Syntax: var dfa-expr &body forms" - (` (let ((L-states (sgml-some-states-of (, dfa))) - (, s)) - (while L-states - (when (sgml-state-final-p (setq (, s) (car L-states))) - (,@ forms)) - (setq L-states (cdr L-states)))))) - -(put 'sgml-for-all-final-states 'lisp-indent-hook 2) -(put 'sgml-for-all-final-states 'edebug-form-hook '(symbolp &rest form)) - - -;;;; Optimization for the dfa building - -(defsubst sgml-empty-state-p (s) - ;; True if S hase no outgoing moves - (and (sgml-normal-state-p s) - (null (sgml-state-reqs s)) - (null (sgml-state-opts s))) ) - -(defun sgml-one-final-state (s) - ;; Collaps all states that have no moves - ;; This is a safe optimization, useful for (..|..|..) - (sgml-debug "OPT one final: reqs %d opts %d" - (length (sgml-state-reqs s)) - (length (sgml-state-opts s))) - (let ((final nil) - dest) - (loop for m in (append (sgml-state-reqs s) - (sgml-state-opts s)) - do - (setq dest (sgml-move-dest m)) - (when (sgml-empty-state-p dest) - (cond ((null final) - (setq final dest)) - (t - (setf (sgml-move-dest m) final))))))) - -(defun sgml-states-equal (s1 s2) - (and (= (length (sgml-state-opts s1)) - (length (sgml-state-opts s2))) - (= (length (sgml-state-reqs s1)) - (length (sgml-state-reqs s2))) - (loop for m in (sgml-state-opts s1) - always - (eq (sgml-move-dest m) - (sgml-move-dest (sgml-moves-lookup (sgml-move-token m) - (sgml-state-opts s2))))) - (loop for m in (sgml-state-reqs s1) - always - (eq (sgml-move-dest m) - (sgml-move-dest (sgml-moves-lookup (sgml-move-token m) - (sgml-state-reqs s2))))))) - -(defun sgml-remove-redundant-states-1 (s) - ;; Remove states accessible from s with one move and equivalent to s, - ;; by changing the moves from s. - (sgml-debug "OPT redundant-1: reqs %d opts %d" - (length (sgml-state-reqs s)) - (length (sgml-state-opts s))) - (let ((yes nil) - (no (list s)) - (l (sgml-state-reqs s)) - (nl (sgml-state-opts s)) - dest) - (while (or l (setq l (prog1 nl (setq nl nil)))) - (cond - ((not (sgml-normal-state-p (setq dest (sgml-move-dest (car l)))))) - ((memq dest no)) - ((memq dest yes)) - ((sgml-states-equal s dest) - (progn (push dest yes)))) - (setq l (cdr l))) - (setq l (sgml-state-opts s) - nl (sgml-state-reqs s)) - (when yes - (sgml-debug "OPT redundant-1: sucess %s" (length yes)) - (while (or l (setq l (prog1 nl (setq nl nil)))) - (cond ((memq (sgml-move-dest (car l)) yes) - (setf (sgml-move-dest (car l)) s))) - (setq l (cdr l)))))) - - - -;;;; Constructing - -(defun sgml-make-opt (s1) - (when (sgml-state-reqs s1) - (setf (sgml-state-opts s1) - (nconc (sgml-state-opts s1) - (sgml-state-reqs s1))) - (setf (sgml-state-reqs s1) nil)) - s1) - -(defun sgml-make-* (s1) - (setq s1 (sgml-make-+ s1)) - (when (sgml-state-reqs s1) - (sgml-make-opt s1)) - (sgml-remove-redundant-states-1 s1) - s1) - -(defun sgml-make-+ (s1) - (sgml-for-all-final-states s s1 - (sgml-copy-moves-to-opt s1 s)) - (sgml-remove-redundant-states-1 s1) ; optimize - s1) - -(defun sgml-make-conc (s1 s2) - (let ((moves (append (sgml-state-reqs s1) (sgml-state-opts s1)))) - (cond - (;; optimize the case where all moves from s1 goes to empty states - (loop for m in moves - always (sgml-empty-state-p (sgml-move-dest m))) - (loop for m in moves do (setf (sgml-move-dest m) s2)) - (when (sgml-state-final-p s1) - (sgml-copy-moves s2 s1))) - (t ; general case - (sgml-for-all-final-states s s1 - (sgml-copy-moves s2 s) - (sgml-remove-redundant-states-1 s))))) - s1) - -(defun sgml-make-pcdata () - (sgml-make-* (sgml-make-primitive-content-token sgml-pcdata-token))) - -(defun sgml-reduce-, (l) - (while (cdr l) - (setcar (cdr l) - (sgml-make-conc (car l) (cadr l))) - (setq l (cdr l))) - (car l)) - -(defun sgml-reduce-| (l) - (while (cdr l) ; apply the binary make-alt - (cond ((or (sgml-state-final-p (car l)) ; is result optional - (sgml-state-final-p (cadr l))) - (sgml-make-opt (car l)) - (sgml-copy-moves-to-opt (cadr l) (car l))) - (t - (sgml-copy-moves (cadr l) (car l)))) - (setcdr l (cddr l))) - (sgml-one-final-state (car l)) ; optimization - (car l)) - -(defun sgml-make-& (dfas) - (let ((&n (sgml-make-and-node dfas (sgml-make-state))) - (s (sgml-make-state)) - (l dfas)) - (while l ; For each si: - ;; For m in opts(si): add optional move from s to &n on token(m). - (loop for m in (sgml-state-opts (car l)) - do (sgml-add-opt-move s (sgml-move-token m) &n)) - ;; For m in reqs(si): add required move from s to &n on token(m). - (loop for m in (sgml-state-reqs (car l)) - do (sgml-add-req-move s (sgml-move-token m) &n)) - (setq l (cdr l))) - ;; Return s. - s)) - - - -;(sgml-make-conc (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list)) -;(sgml-make-conc (sgml-make-& (list (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list))) (sgml-make-primitive-content-token 'foo)) - -;(setq x (sgml-some-states-of (sgml-make-primitive-content-token 'para))) -;(sgml-state-final-p (car x) ) -;(sgml-state-final-p (cadr x)) - - -;;;; Parse doctype: General - -(defun sgml-skip-ts () - ;; Skip over ts* - ;;70 ts = 5 s | EE | 60+ parameter entity reference - ;;For simplicity I use ps* - ;;65 ps = 5 s | EE | 60+ parameter entity reference | 92 comment - ;;*** some comments are accepted that shouldn't - (sgml-skip-ps)) - -(defun sgml-parse-character-reference (&optional dofunchar) - ;; *** Actually only numerical character references - ;; I don't know how to handel the function character references. - ;; For the shortrefs let's give them numeric values. - (if (if dofunchar - (sgml-parse-delim "CRO" (digit nmstart)) - (sgml-parse-delim "CRO" (digit))) - (prog1 (if (sgml-is-delim "NULL" digit) - (string-to-int (sgml-check-nametoken)) - (let ((spec (sgml-check-name))) - (or (cdr (assoc spec '(("re" . 10) - ("rs" . 1) - ("tab" . 9) - ("space" . 32)))) - ;; *** What to do with other names? - 127))) - (or (sgml-parse-delim "REFC") - (sgml-parse-RE))))) - -(defun sgml-parse-parameter-literal (&optional dofunchar) - (let* (lita ; flag if lita - (value ; accumulates literals value - "") - (original-buffer ; Buffer (entity) where lit started - (current-buffer)) - temp - ) - (cond - ((or (sgml-parse-delim "LIT") - (setq lita (sgml-parse-delim "LITA"))) - (while (not (and (eq (current-buffer) original-buffer) - (if lita - (sgml-parse-delim "LITA") - (sgml-parse-delim "LIT")))) - (cond ((eobp) - (or (sgml-pop-entity) - (sgml-error "Parameter literal unterminated"))) - ((sgml-parse-parameter-entity-ref)) - ((setq temp (sgml-parse-character-reference dofunchar)) - (setq value (concat value (if (< temp 256) - (format "%c" temp) - (format "&#%d;" temp))))) - (t - (setq value - (concat value - (buffer-substring - (point) - (progn (forward-char 1) - (if lita - (sgml-skip-upto ("LITA" "PERO" "CRO")) - (sgml-skip-upto ("LIT" "PERO" "CRO"))) - (point))))))) - ) - value)))) - -(defun sgml-check-parameter-literal () - (or (sgml-parse-parameter-literal) - (sgml-parse-error "Parameter literal expected"))) - -(defsubst sgml-parse-connector () - (sgml-skip-ps) - (cond ((sgml-parse-delim "SEQ") - (function sgml-reduce-,)) - ((sgml-parse-delim "OR") - (function sgml-reduce-|)) - ((sgml-parse-delim "AND") - (function sgml-make-&)))) - -(defun sgml-parse-name-group () - "Parse a single name or a name group (general name case) . -Returns a list of strings or nil." - (let (names) - (cond - ((sgml-parse-delim "GRPO") - (sgml-skip-ps) - (setq names (sgml-parse-name-group)) ; *** Allows more than it should - (while (sgml-parse-connector) - (sgml-skip-ps) - (nconc names (sgml-parse-name-group))) - (sgml-check-delim "GRPC") - names) - ((setq names (sgml-parse-name)) - (list names))))) - -(defun sgml-check-name-group () - (or (sgml-parse-name-group) - (sgml-parse-error "Expecting a name or a name group"))) - -(defun sgml-check-nametoken-group () - "Parse a name token group, return a list of strings. -Case transformed for general names." - (sgml-skip-ps) - (let ((names nil)) - (cond - ((sgml-parse-delim GRPO) - (while (progn - (sgml-skip-ps) - (push (sgml-general-case (sgml-check-nametoken)) names) - (sgml-parse-connector))) - (sgml-check-delim GRPC) - (nreverse names)) ; store in same order as declared - (t - (list (sgml-general-case (sgml-check-nametoken))))))) - -(defun sgml-check-element-type () - "Parse and check an element type, returns list of strings." -;;; 117 element type = [[30 generic identifier]] -;;; | [[69 name group]] -;;; | [[118 ranked element]] -;;; | [[119 ranked group]] - (cond - ((sgml-parse-delim GRPO) - (sgml-skip-ts) - (let ((names (list (sgml-check-name)))) - (while (progn (sgml-skip-ts) - (sgml-parse-connector)) - (sgml-skip-ts) - (nconc names (list (sgml-check-name)))) - (sgml-check-delim GRPC) - ;; A ranked group will have a rank suffix here - (sgml-skip-ps) - (if (sgml-is-delim "NULL" digit) - (let ((suffix (sgml-parse-nametoken))) - (loop for n in names - collect (concat n suffix))) - names))) - (t ; gi/ranked element - (let ((name (sgml-check-name))) - (sgml-skip-ps) - (list (if (sgml-is-delim "NULL" digit) - (concat name (sgml-check-nametoken)) - name)))))) - - -(defun sgml-check-external () - (or (sgml-parse-external) - (sgml-parse-error "Expecting a PUBLIC or SYSTEM"))) - -;;;; Parse doctype: notation - -(defun sgml-declare-notation () - ;;148 notation declaration = MDO, "NOTATION", - ;; 65 ps+, 41 notation name, - ;; 65 ps+, 149 notation identifier, - ;; 65 ps*, MDC - ;;41 notation name = 55 name - ;;149 notation identifier = 73 external identifier - (sgml-skip-ps) - (sgml-check-name) - (sgml-skip-ps) - (sgml-check-external)) - - -;;;; Parse doctype: Element - -(defun sgml-parse-opt () - (sgml-skip-ps) - (cond ((or (sgml-parse-char ?o) - (sgml-parse-char ?O)) - t) - ((sgml-parse-char ?-) - nil))) - -(defun sgml-parse-modifier () - (cond ((sgml-parse-delim PLUS) - (function sgml-make-+)) - ((sgml-parse-delim REP) - (function sgml-make-*)) - ((sgml-parse-delim OPT) - (function sgml-make-opt)))) - -(defun sgml-check-primitive-content-token () - (sgml-make-primitive-content-token - (sgml-eltype-token - (sgml-lookup-eltype - (sgml-check-name))))) - -(defun sgml-check-model-group () - (sgml-skip-ps) - (let (el mod) - (cond - ((sgml-parse-delim "GRPO") - (let ((subs (list (sgml-check-model-group))) - (con1 nil) - (con2 nil)) - (while (setq con2 (sgml-parse-connector)) - (cond ((and con1 - (not (eq con1 con2))) - (sgml-parse-error "Mixed connectors"))) - (setq con1 con2) - (setq subs (nconc subs (list (sgml-check-model-group))))) - (sgml-check-delim "GRPC") - (setq el (if con1 - (funcall con1 subs) - (car subs))))) - ((sgml-parse-rni "pcdata") ; #PCDATA - (setq sgml-used-pcdata t) - (setq el (sgml-make-pcdata))) - ((sgml-parse-delim "DTGO") ; data tag group - (sgml-skip-ts) - (let ((tok (sgml-check-primitive-content-token))) - (sgml-skip-ts) (sgml-check-delim "SEQ") - (sgml-skip-ts) (sgml-check-data-tag-pattern) - (sgml-skip-ts) (sgml-check-delim "DTGC") - (setq el (sgml-make-conc tok (sgml-make-pcdata))) - (setq sgml-used-pcdata t))) - (t - (setq el (sgml-check-primitive-content-token)))) - (setq mod (sgml-parse-modifier)) - (if mod - (funcall mod el) - el))) - -(defun sgml-check-data-tag-pattern () - ;; 134 data tag pattern - ;; template | template group - (cond ((sgml-parse-delim GRPO) - (sgml-skip-ts) - (sgml-check-parameter-literal) ; data tag template, - (while (progn (sgml-skip-ts) - (sgml-parse-delim OR)) - (sgml-skip-ts) - (sgml-check-parameter-literal)) ; data tag template - (sgml-skip-ts) - (sgml-check-delim GRPC)) - (t - (sgml-check-parameter-literal))) ; data tag template - (sgml-skip-ts) - (when (sgml-parse-delim SEQ) - (sgml-check-parameter-literal))) ; data tag padding template - -(defun sgml-check-content-model () - (sgml-check-model-group)) - -(defun sgml-check-content () - (sgml-skip-ps) - (cond ((sgml-is-delim GRPO) - (sgml-check-content-model)) - (t - ;; ANY, CDATA, RCDATA or EMPTY - (let ((dc (intern (upcase (sgml-check-name))))) - (when (eq dc 'ANY) - (setq sgml-used-pcdata t)) - dc)))) - -(defun sgml-parse-exeption (type) - (sgml-skip-ps) - (if (sgml-parse-char type) - (mapcar (function sgml-lookup-eltype) - (sgml-check-name-group)))) - -(defun sgml-before-eltype-modification () -;;; (let ((merged (sgml-dtd-merged sgml-dtd-info))) -;;; (when (and merged -;;; (eq (sgml-dtd-eltypes sgml-dtd-info) -;;; (sgml-dtd-eltypes (cdr merged)))) -;;; (setf (sgml-dtd-eltypes sgml-dtd-info) -;;; (sgml-merge-eltypes (sgml-make-eltypes-table) -;;; (sgml-dtd-eltypes sgml-dtd-info))))) - ) - -(defun sgml-declare-element () - (let* ((names (sgml-check-element-type)) - (stag-opt (sgml-parse-opt)) - (etag-opt (sgml-parse-opt)) - (sgml-used-pcdata nil) - (model (sgml-check-content)) - (exclusions (sgml-parse-exeption ?-)) - (inclusions (sgml-parse-exeption ?+))) - (sgml-before-eltype-modification) - (while names - (sgml-debug "Defining element %s" (car names)) - (let ((et (sgml-lookup-eltype (car names)))) - (setf (sgml-eltype-stag-optional et) stag-opt - (sgml-eltype-etag-optional et) etag-opt - (sgml-eltype-model et) model - (sgml-eltype-mixed et) sgml-used-pcdata - (sgml-eltype-excludes et) exclusions - (sgml-eltype-includes et) inclusions)) - (setq names (cdr names))) - (sgml-lazy-message "Parsing doctype (%s elements)..." - (incf sgml-no-elements)))) - -;;;; Parse doctype: Entity - -(defun sgml-declare-entity () - (let (name ; Name of entity - dest ; Entity table - (type 'text) ; Type of entity - text ; Text of entity - extid ; External id - ) - (cond - ((sgml-parse-delim "PERO") ; parameter entity declaration - (sgml-skip-ps) - (setq name (sgml-check-name t)) - (setq dest (sgml-dtd-parameters sgml-dtd-info))) - (t ; normal entity declaration - (or (sgml-parse-rni "default") - (setq name (sgml-check-name t))) - (setq dest (sgml-dtd-entities sgml-dtd-info)))) - (sgml-skip-ps) - ;;105 entity text = 66 parameter literal - ;; | 106 data text - ;; | 107 bracketed text - ;; | 108 external entity specification - (setq extid (sgml-parse-external)) - (setq text - (cond - (extid ; external entity specification = - ; 73 external identifier, - ; (65 ps+, 109+ entity type)? - (sgml-skip-ps) - (setq type (or (sgml-parse-entity-type) 'text)) - extid) - ((sgml-startnm-char-next) - (let ((token (intern (sgml-check-name)))) - (sgml-skip-ps) - (cond - ((memq token '(cdata sdata)) ; data text *** - (setq type token) - (sgml-check-parameter-literal)) - ((eq token 'pi) - (concat "")) - ((eq token 'starttag) - (sgml-start-tag-of (sgml-check-parameter-literal))) - ((eq token 'endtag) - (sgml-end-tag-of (sgml-check-parameter-literal))) - ((eq token 'ms) ; marked section - (concat "")) - ((eq token 'md) ; Markup declaration - (concat ""))))) - ((sgml-check-parameter-literal)))) - (when dest - (sgml-entity-declare name dest type text)))) - - -(defun sgml-parse-entity-type () - ;;109+ entity type = "SUBDOC" - ;; | (("CDATA" | "NDATA" | "SDATA"), - ;; 65 ps+, - ;; 41 notation name, - ;; 149.2+ data attribute specification?) - (let ((type (sgml-parse-name))) - (when type - (setq type (intern (downcase type))) - (cond ((eq type 'subdoc)) - ((memq type '(cdata ndata sdata)) - (sgml-skip-ps) - (sgml-check-name) - ;;149.2+ data attribute specification - ;; = 65 ps+, DSO, - ;; 31 attribute specification list, - ;; 5 s*, DSC - (sgml-skip-ps) - (when (sgml-parse-delim DSO) - (sgml-parse-attribute-specification-list) - (sgml-parse-s) - (sgml-check-delim DSC))) - (t (sgml-error "Illegal entity type: %s" type)))) - type)) - - -;;;; Parse doctype: Attlist - -(defun sgml-declare-attlist () - (let* ((assnot (cond ((sgml-parse-rni "notation") - (sgml-skip-ps) - t))) - (assel (sgml-check-name-group)) - (attlist nil) ; the list - (attdef nil)) - (while (setq attdef (sgml-parse-attribute-definition)) - (push attdef attlist)) - (setq attlist (nreverse attlist)) - (unless assnot - (sgml-before-eltype-modification) - (loop for elname in assel do - (setf (sgml-eltype-attlist (sgml-lookup-eltype elname)) - attlist))))) - -(defun sgml-parse-attribute-definition () - (sgml-skip-ps) - (if (sgml-is-delim MDC) ; End of attlist? - nil - (sgml-make-attdecl (sgml-check-name) - (sgml-check-declared-value) - (sgml-check-default-value)))) - -(defun sgml-check-declared-value () - (sgml-skip-ps) - (let ((type 'name-token-group) - (names nil)) - (unless (eq (following-char) ?\() - (setq type (intern (sgml-check-name))) - (sgml-skip-ps)) - (when (memq type '(name-token-group notation)) - (setq names (sgml-check-nametoken-group))) - (sgml-make-declared-value type names))) - -(defun sgml-check-default-value () - (sgml-skip-ps) - (let* ((rni (sgml-parse-rni)) - (key (if rni (intern (sgml-check-name))))) - (sgml-skip-ps) - (sgml-make-default-value - key - (if (or (not rni) (eq key 'fixed)) - (sgml-check-attribute-value-specification))))) - - -;;;; Parse doctype: Shortref - -;;;150 short reference mapping declaration = MDO, "SHORTREF", -;;; [[65 ps]]+, [[151 map name]], -;;; ([[65 ps]]+, [[66 parameter literal]], -;;; [[65 ps]]+, [[55 name]])+, -;;; [[65 ps]]*, MDC - -(defun sgml-declare-shortref () - (let ((mapname (sgml-check-name)) - mappings literal name) - (while (progn - (sgml-skip-ps) - (setq literal (sgml-parse-parameter-literal 'dofunchar))) - (sgml-skip-ps) - (setq name (sgml-check-name t)) - (push (cons literal name) mappings)) - (sgml-add-shortref-map - (sgml-dtd-shortmaps sgml-dtd-info) - mapname - (sgml-make-shortmap mappings)))) - -;;;152 short reference use declaration = MDO, "USEMAP", -;;; [[65 ps]]+, [[153 map specification]], -;;; ([[65 ps]]+, [[72 associated element type]])?, -;;; [[65 ps]]*, MDC - -(defun sgml-do-usemap-element (mapname) - ;; This is called from sgml-do-usemap with the mapname - (sgml-before-eltype-modification) - (loop for e in (sgml-parse-name-group) do - (setf (sgml-eltype-shortmap (sgml-lookup-eltype e sgml-dtd-info)) - (if (null mapname) - 'empty - mapname)))) - - -;;;; Parse doctype - -(defun sgml-check-dtd-subset () - (let ((sgml-parsing-dtd t) - (eref sgml-current-eref)) - (while - (progn - (setq sgml-markup-start (point)) - (cond - ((and (eobp) (eq sgml-current-eref eref)) - nil) - ((sgml-parse-ds)) - ((sgml-parse-markup-declaration 'dtd)) - ((sgml-parse-delim "MS-END"))))))) - - -;;;; Save DTD: compute translation - -(defvar sgml-translate-table nil) - -(defun sgml-translate-node (node) - (assert (not (numberp node))) - (let ((tp (assq node sgml-translate-table))) - (unless tp - (setq tp (cons node (length sgml-translate-table))) - (nconc sgml-translate-table (list tp))) - (cdr tp))) - -(defun sgml-translate-moves (moves) - (while moves - (sgml-translate-node (sgml-move-dest (car moves))) - (setq moves (cdr moves)))) - -(defun sgml-translate-model (model) - (let* ((sgml-translate-table (list (cons model 0))) - (p sgml-translate-table)) - (while p - (cond ((sgml-normal-state-p (caar p)) - (sgml-translate-moves (sgml-state-opts (caar p))) - (sgml-translate-moves (sgml-state-reqs (caar p)))) - (t - (sgml-translate-node (sgml-and-node-next (caar p))))) - (setq p (cdr p))) - sgml-translate-table)) - -;;;; Save DTD: binary coding - -(defvar sgml-code-token-numbers nil) -(defvar sgml-code-xlate nil) - -(defsubst sgml-code-xlate (node) - ;;(let ((x (cdr (assq node sgml-code-xlate)))) (assert x) x) - (cdr (assq node sgml-code-xlate))) - -(defun sgml-code-number (num) - (if (> num sgml-max-single-octet-number) - (insert (+ (lsh (- num sgml-max-single-octet-number) -8) - sgml-max-single-octet-number 1) - (logand (- num sgml-max-single-octet-number) 255)) - (insert num))) - -(defun sgml-code-token-number (token) - (let ((bp (assq token sgml-code-token-numbers))) - (unless bp - (setq sgml-code-token-numbers - (nconc sgml-code-token-numbers - (list (setq bp (cons token - (length sgml-code-token-numbers))))))) - (cdr bp))) - -(defun sgml-code-token (token) - (sgml-code-number (sgml-code-token-number token))) - -(defmacro sgml-code-sequence (loop-c &rest body) - "Produce the binary coding of a counted sequence from a list. -Syntax: (var seq) &body forms -FORMS should produce the binary coding of element in VAR." - (let ((var (car loop-c)) - (seq (cadr loop-c))) - (` (let ((seq (, seq))) - (sgml-code-number (length seq)) - (loop for (, var) in seq - do (,@ body)))))) - -(put 'sgml-code-sequence 'lisp-indent-hook 1) -(put 'sgml-code-sequence 'edbug-forms-hook '(sexp &rest form)) - -(defun sgml-code-sexp (sexp) - (let ((standard-output (current-buffer))) - (prin1 sexp) - (terpri))) - -(defun sgml-code-tokens (l) - (sgml-code-sequence (x l) - (sgml-code-token x))) - -(defsubst sgml-code-move (m) - (sgml-code-token (sgml-move-token m)) - (insert (sgml-code-xlate (sgml-move-dest m)))) - -(defun sgml-code-model (m) - (let ((sgml-code-xlate (sgml-translate-model m))) - (sgml-code-sequence (s sgml-code-xlate) ; s is (node . number) - (setq s (car s)) ; s is node - (cond - ((sgml-normal-state-p s) - (assert (and (< (length (sgml-state-opts s)) 255) - (< (length (sgml-state-reqs s)) 256))) - (sgml-code-sequence (x (sgml-state-opts s)) - (sgml-code-move x)) - (sgml-code-sequence (x (sgml-state-reqs s)) - (sgml-code-move x))) - (t ; s is a &-node - (insert 255) ; Tag &-node - (insert (sgml-code-xlate (sgml-and-node-next s))) - (sgml-code-sequence (m (sgml-and-node-dfas s)) - (sgml-code-model m))))))) - -(defun sgml-code-element (et) - (sgml-code-sexp (sgml-eltype-all-miscdata et)) - (cond - ((not (sgml-eltype-defined et)) - (insert 128)) - (t - (insert (sgml-eltype-flags et)) - (let ((c (sgml-eltype-model et))) - (cond ((eq c sgml-cdata) (insert 0)) - ((eq c sgml-rcdata) (insert 1)) - ((eq c sgml-empty) (insert 2)) - ((eq c sgml-any) (insert 3)) - ((null c) (insert 4)) - (t - (assert (sgml-model-group-p c)) - (insert 128) - (sgml-code-model c)))) - (sgml-code-tokens (sgml-eltype-includes et)) - (sgml-code-tokens (sgml-eltype-excludes et))))) - - -(defun sgml-code-dtd (dtd) - "Produce the binary coding of the current DTD into the current buffer." - (sgml-code-sexp (sgml-dtd-dependencies dtd)) - (sgml-code-sexp (sgml-dtd-parameters dtd)) - (sgml-code-sexp (sgml-dtd-doctype dtd)) - (let ((done 0) ; count written elements - tot) - (setq sgml-code-token-numbers nil) - (sgml-code-token-number sgml-pcdata-token) ; Make #PCDATA token 0 - (sgml-map-eltypes ; Assign numbers to all tokens - (function (lambda (et) - (sgml-code-token-number (sgml-eltype-token et)))) - dtd nil t) - (setq tot (length sgml-code-token-numbers)) - ;; Produce the counted sequence of element type names - (sgml-code-sequence (pair (cdr sgml-code-token-numbers)) - (sgml-code-sexp (sgml-eltype-name (car pair)))) - ;; Produce the counted sequence of element types - (sgml-code-sequence (pair (cdr sgml-code-token-numbers)) - (setq done (1+ done)) - (sgml-code-element (car pair)) - (sgml-lazy-message "Saving DTD %d%% done" (/ (* 100 done) tot))) - (sgml-code-sexp (sgml-dtd-entities dtd)) - (sgml-code-sexp (sgml-dtd-shortmaps dtd)) - (sgml-code-sexp (sgml-dtd-notations dtd)))) - - -;;;; Save DTD - -(defun sgml-save-dtd (file) - "Save the parsed dtd on FILE." - (interactive - (let* ((tem (expand-file-name - (or sgml-default-dtd-file - (sgml-default-dtd-file)))) - (dir (file-name-directory tem)) - (nam (file-name-nondirectory tem))) - (list - (read-file-name "Save DTD in: " dir tem nil nam)))) - (setq file (expand-file-name file)) - (when (equal file (buffer-file-name)) - (error "Would clobber current file")) - (sgml-need-dtd) - (sgml-push-to-entity (sgml-make-entity "#SAVE" nil "")) - (sgml-write-dtd sgml-dtd-info file) - (sgml-pop-entity) - (setq sgml-default-dtd-file - (if (equal (expand-file-name default-directory) - (file-name-directory file)) - (file-name-nondirectory file) - file)) - (setq sgml-loaded-dtd file)) - -(defun sgml-write-dtd (dtd file) - "Save the parsed dtd on FILE. -Construct the binary coded DTD (bdtd) in the current buffer." - (insert - ";;; This file was created by psgml on " (current-time-string) "\n" - "(sgml-saved-dtd-version 6)\n") - (sgml-code-dtd dtd) - (setq file-type 1) - (write-region (point-min) (point-max) file)) - - -;;; psgml-dtd.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-edit.el --- a/lisp/psgml/psgml-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1717 +0,0 @@ -;;; psgml-edit.el --- Editing commands for SGML-mode with parsing support -;;-*-byte-compile-warnings:(free-vars unused-vars unresolved callargs redefine)-*- -;; $Id: psgml-edit.el,v 1.2 1997/03/08 23:26:53 steve Exp $ - -;; Copyright (C) 1994, 1995, 1996 Lennart Staflin - -;; Author: Lennart Staflin - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Part of major mode for editing the SGML document-markup language. - - -;;;; Code: - -(provide 'psgml-edit) -(require 'psgml) -(require 'psgml-parse) -(require 'tempo) - - -;;;; Variables - -(defvar sgml-split-level nil - "Used by sgml-split-element") - - -;;;; SGML mode: structure editing - -(defun sgml-last-element () - "Return the element where last command left point. -This either uses the save value in `sgml-last-element' or parses the buffer -to find current open element." - (setq sgml-markup-type nil) - (if (and (memq last-command sgml-users-of-last-element) - sgml-last-element) ; Don't return nil - sgml-last-element - (setq sgml-last-element (sgml-find-context-of (point)))) ) - -(defun sgml-set-last-element (&optional el) - (if el (setq sgml-last-element el)) - (sgml-show-context sgml-last-element)) - -(defun sgml-beginning-of-element () - "Move to after the start-tag of the current element. -If the start-tag is implied, move to the start of the element." - (interactive) - (goto-char (sgml-element-stag-end (sgml-last-element))) - (sgml-set-last-element (if (sgml-element-empty sgml-last-element) - (sgml-element-parent sgml-last-element)))) - -(defun sgml-end-of-element () - "Move to before the end-tag of the current element." - (interactive) - (goto-char (sgml-element-etag-start (sgml-last-element))) - (sgml-set-last-element (if (sgml-element-empty sgml-last-element) - (sgml-element-parent sgml-last-element)))) - -(defun sgml-backward-up-element () - "Move backward out of this element level. -That is move to before the start-tag or where a start-tag is implied." - (interactive) - (goto-char (sgml-element-start (sgml-last-element))) - (sgml-set-last-element (sgml-element-parent sgml-last-element))) - -(defun sgml-up-element () - "Move forward out of this element level. -That is move to after the end-tag or where an end-tag is implied." - (interactive) - (goto-char (sgml-element-end (sgml-last-element))) - (sgml-set-last-element (sgml-element-parent sgml-last-element))) - -(defun sgml-forward-element () - "Move forward over next element." - (interactive) - (let ((next - (sgml-find-element-after (point) (sgml-last-element)))) - (goto-char (sgml-element-end next)) - (sgml-set-last-element (sgml-element-parent next)))) - -(defun sgml-backward-element () - "Move backward over previous element at this level. -With implied tags this is ambigous." - (interactive) - (let ((prev ; previous element - (sgml-find-previous-element (point) (sgml-last-element)))) - (goto-char (sgml-element-start prev)) - (sgml-set-last-element (sgml-element-parent prev)))) - -(defun sgml-down-element () - "Move forward and down one level in the element structure." - (interactive) - (let ((to - (sgml-find-element-after (point) (sgml-last-element)))) - (when (sgml-strict-epos-p (sgml-element-stag-epos to)) - (error "Sub-element in other entity")) - (goto-char (sgml-element-stag-end to)) - (sgml-set-last-element (if (sgml-element-empty to) - (sgml-element-parent to) - to)))) - - -(defun sgml-kill-element () - "Kill the element following the cursor." - (interactive "*") - (sgml-parse-to-here) - (when sgml-markup-type - (error "Point is inside markup")) - (kill-region (point) - (sgml-element-end (sgml-find-element-after (point))))) - -(defun sgml-transpose-element () - "Interchange element before point with element after point, leave point after." - (interactive "*") - (let ((pre (sgml-find-previous-element (point))) - (next (sgml-find-element-after (point))) - s1 s2 m2) - (goto-char (sgml-element-start next)) - (setq m2 (point-marker)) - (setq s2 (buffer-substring (point) - (sgml-element-end next))) - (delete-region (point) (sgml-element-end next)) - (goto-char (sgml-element-start pre)) - (setq s1 (buffer-substring (point) (sgml-element-end pre))) - (delete-region (point) (sgml-element-end pre)) - (insert-before-markers s2) - (goto-char m2) - (insert s1) - (sgml-message ""))) - -(defun sgml-mark-element () - "Set mark after next element." - (interactive) - (push-mark (sgml-element-end (sgml-find-element-after (point))) nil t)) - -(defun sgml-mark-current-element () - "Set mark at end of current element, and leave point before current element." - (interactive) - (let ((el (sgml-find-element-of (point)))) - (goto-char (sgml-element-start el)) - (push-mark (sgml-element-end el) nil t))) - - -(defun sgml-change-element-name (gi) - "Replace the name of the current element with a new name. -Eventual attributes of the current element will be translated if -possible." - (interactive - (list (let ((el (sgml-find-element-of (point)))) - (goto-char (sgml-element-start el)) - (sgml-read-element-name - (format "Change %s to: " (sgml-element-name el)))))) - (when (or (null gi) (equal gi "")) - (error "Illegal name")) - (let* ((element (sgml-find-element-of (point))) - (attspec (sgml-element-attribute-specification-list element)) - (oldattlist (sgml-element-attlist element))) - (unless (sgml-element-empty element) - (goto-char (sgml-element-end element)) - (delete-char (- (sgml-element-etag-len element))) - (tempo-process-and-insert-string (sgml-end-tag-of gi))) - (goto-char (sgml-element-start element)) - (delete-char (sgml-element-stag-len element)) - (tempo-process-and-insert-string (sgml-start-tag-of gi)) - (forward-char -1) - (let* ((newel (sgml-find-element-of (point))) - (newattlist (sgml-element-attlist newel)) - (newasl (sgml-translate-attribute-specification-list - attspec oldattlist newattlist))) - (sgml-insert-attributes newasl newattlist)))) - -(defun sgml-translate-attribute-specification-list (values from to) - "Translate attribute specification from one element type to another. -Input attribute values in VALUES using attlist FROM is translated into -a list using attlist TO." - (let ((new-values nil) - (sgml-show-warnings t) - tem) - (loop for attspec in values - as from-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) from) - as to-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) to) - do - (cond - ;; Special case ID attribute - ((and (eq 'id (sgml-attdecl-declared-value from-decl)) - (setq tem (sgml-attribute-with-declared-value to 'id))) - (push - (sgml-make-attspec (sgml-attdecl-name tem) - (sgml-attspec-attval attspec)) - new-values)) - ;; Use attribute with same name if compatible type - ((equal (sgml-attdecl-declared-value from-decl) - (sgml-attdecl-declared-value to-decl)) - (push attspec new-values)) - (to-decl - (sgml-log-warning - "Attribute %s has new declared-value" - (sgml-attspec-name attspec)) - (push attspec new-values)) - (t - (sgml-log-warning "Can't translate attribute %s = %s" - (sgml-attspec-name attspec) - (sgml-attspec-attval attspec))))) - new-values)) - -(defun sgml-untag-element () - "Remove tags from current element." - (interactive "*") - (let ((el (sgml-find-element-of (point)))) - (when (or (sgml-strict-epos-p (sgml-element-stag-epos el)) - (sgml-strict-epos-p (sgml-element-etag-epos el))) - (error "Current element has some tag inside an entity reference")) - (goto-char (sgml-element-etag-start el)) - (delete-char (sgml-element-etag-len el)) - (goto-char (sgml-element-start el)) - (delete-char (sgml-element-stag-len el)))) - -(defun sgml-kill-markup () - "Kill next tag, markup declaration or process instruction." - (interactive "*") - (let ((start (point))) - (sgml-with-parser-syntax - (sgml-parse-s) - (setq sgml-markup-start (point)) - (cond ((sgml-parse-markup-declaration 'ignore)) - ((sgml-parse-processing-instruction)) - ((sgml-skip-tag))) - (kill-region start (point))))) - - -;;;; SGML mode: folding - -(defun sgml-fold-region (beg end &optional unhide) - "Hide (or if prefixarg unhide) region. -If called from a program first two arguments are start and end of -region. And optional third argument true unhides." - (interactive "r\nP") - (let ((mp (buffer-modified-p)) - (inhibit-read-only t) ; - (buffer-read-only nil) ; should not need this, but - ; perhaps some old version of - ; emacs does not understand - ; inhibit-read-only - (before-change-function nil) - (after-change-function nil)) - (setq selective-display t) - (unwind-protect - (subst-char-in-region beg end - (if unhide ?\r ?\n) - (if unhide ?\n ?\r) - 'noundo) - (when sgml-buggy-subst-char-in-region - (set-buffer-modified-p mp))))) - -(defun sgml-fold-element () - "Fold the lines comprising the current element, leaving the first line visible. -This uses the selective display feature." - (interactive) - (sgml-parse-to-here) - (cond ((and (eq sgml-current-tree sgml-top-tree) ; outside document element - sgml-markup-type) - (sgml-fold-region sgml-markup-start - (save-excursion - (sgml-parse-to (point)) - (point)))) - ((and (eq sgml-current-tree sgml-top-tree) ; outside document element - (looking-at " *= col w) - (setq col (+ (length str) 2)) - (terpri))) - (princ " ") - (princ str)) - (terpri)))) - -(defun sgml-show-context (&optional element) - "Display where the cursor is in the element hierarchy." - (interactive) - (let* ((el (or element (sgml-last-element))) - (model (sgml-element-model el))) - (sgml-message "%s %s" - (cond - ((and (null element) ; Don't trust sgml-markup-type if - ; explicit element is given as argument - sgml-markup-type)) - ((sgml-element-mixed el) - "#PCDATA") - ((not (sgml-model-group-p model)) - model) - (t "")) - (if (eq el sgml-top-tree) - "in empty context" - (sgml-element-context-string el))))) - -(defun sgml-what-element () - "Display what element is under the cursor." - (interactive) - (let* ((pos (point)) - (nobol (eq (point) sgml-rs-ignore-pos)) - (sref (sgml-deref-shortmap sgml-current-shortmap nobol)) - (el nil)) - (goto-char pos) - (setq el (sgml-find-element-of pos)) - (assert (not (null el))) - (message "%s %s" - (cond ((eq el sgml-top-tree) - "outside document element") - ((< (point) (sgml-element-stag-end el)) - "start-tag") - ((>= (point) (sgml-element-etag-start el)) - "end-tag") - (sref - "shortref") - (t - "content")) - (sgml-element-context-string el)))) - -;;;; SGML mode: keyboard inserting - -(defun sgml-insert-tag (tag &optional silent no-nl-after) - "Insert a tag, reading tag name in minibuffer with completion. -If the variable sgml-balanced-tag-edit is t, also inserts the -corresponding end tag. If sgml-leave-point-after-insert is t, the point -is left after the inserted tag(s), unless the element has som required -content. If sgml-leave-point-after-insert is nil the point is left -after the first tag inserted." - (interactive - (list - (completing-read "Tag: " (sgml-completion-table) nil t "<" ))) - (sgml-find-context-of (point)) - (assert (null sgml-markup-type)) - ;; Fix white-space before tag - (unless (sgml-element-data-p (sgml-parse-to-here)) - (skip-chars-backward " \t") - (cond ((bolp) - (if (looking-at "^\\s-*$") - (fixup-whitespace))) - (t - (insert "\n")))) - (tempo-process-and-insert-string tag) - (sgml-indent-line) - (unless no-nl-after - (save-excursion - (unless (sgml-element-data-p (sgml-parse-to-here)) - (unless (eolp) - (save-excursion (insert "\n")))))) - (or silent (sgml-show-context))) - -(defvar sgml-new-attribute-list-function - (function sgml-default-asl)) - -(defun sgml-insert-element (name &optional after silent) - "Reads element name from minibuffer and inserts start and end tags." - (interactive (list (sgml-read-element-name "Element: ") - sgml-leave-point-after-insert)) - (let (newpos ; position to leave cursor at - element ; inserted element - (sgml-show-warnings nil)) - (when (and name (not (equal name ""))) - (sgml-insert-tag (sgml-start-tag-of name) 'silent) - (forward-char -1) - (setq element (sgml-find-element-of (point))) - (sgml-insert-attributes (funcall sgml-new-attribute-list-function - element) - (sgml-element-attlist element)) - (forward-char 1) - (when (not (sgml-element-empty element)) - (when (and sgml-auto-insert-required-elements - (sgml-model-group-p sgml-current-state)) - (let (tem) - (while (and (setq tem (sgml-required-tokens sgml-current-state)) - (null (cdr tem))) - (setq tem (sgml-insert-element (car tem) t t)) - (setq newpos (or newpos tem)) - (sgml-parse-to-here)) - (when tem ; more than one req elem - (insert "\n") - (when sgml-insert-missing-element-comment - (insert (format "" tem)) - (sgml-indent-line nil element))))) - (setq newpos (or newpos (point))) - (when sgml-insert-end-tag-on-new-line - (insert "\n")) - (sgml-insert-tag (sgml-end-tag-of name) 'silent) - (unless after - (goto-char newpos)) - (unless silent (sgml-show-context))) - newpos))) - -(defun sgml-default-asl (element) - (loop for attdecl in (sgml-element-attlist element) - when (sgml-default-value-type-p (sgml-attdecl-default-value attdecl) - 'required) - collect - (sgml-make-attspec - (sgml-attdecl-name attdecl) - (sgml-read-attribute-value attdecl nil)))) - -(defun sgml-tag-region (element start end) - "Reads element name from minibuffer and inserts start and end tags." - (interactive - (list - (save-excursion (goto-char (region-beginning)) - (sgml-read-element-name "Tag region with element: ")) - (region-beginning) - (region-end))) - (save-excursion - (when (and element (not (equal element ""))) - (goto-char end) - (tempo-process-and-insert-string (sgml-end-tag-of element)) - (goto-char start) - (sgml-insert-tag (sgml-start-tag-of element))))) - -(defun sgml-insert-attributes (avl attlist) - "Insert the attributes with values AVL and declarations ATTLIST. -AVL should be a assoc list mapping symbols to strings." - (let (name val dcl def) - (loop for attspec in attlist do - (setq name (sgml-attspec-name attspec) - val (cdr-safe (sgml-lookup-attspec name avl)) - dcl (sgml-attdecl-declared-value attspec) - def (sgml-attdecl-default-value attspec)) - (unless val ; no value given - ;; Supply the default value if a value is needed - (cond ((sgml-default-value-type-p 'required def) - (setq val "")) - ((and (not (or sgml-omittag sgml-shorttag)) - (consp def)) - (setq val (sgml-default-value-attval def))))) - (cond - ((null val)) ; Ignore - ;; Ignore attributes with default value - ((and (consp def) - (eq sgml-minimize-attributes 'max) - (or sgml-omittag sgml-shorttag) - (equal val (sgml-default-value-attval def)))) - ;; No attribute name for token groups - ((and sgml-minimize-attributes sgml-shorttag - (member (sgml-general-case val) - (sgml-declared-value-token-group dcl))) - (tempo-process-and-insert-string (concat " " val))) - (t - (tempo-process-and-insert-string (concat " " name "=")) - (insert (sgml-quote-attribute-value val))))) - (when auto-fill-function - (funcall auto-fill-function)))) - - -(defun sgml-quote-attribute-value (value) - "Add quotes to the string VALUE unless minimization is on." - (let ((quote "")) - (cond ((and (not sgml-always-quote-attributes) - sgml-shorttag - (string-match "\\`[.A-Za-z0-9---]+\\'" value)) - ) ; no need to quote - ((not (string-match "\"" value)) ; can use "" quotes - (setq quote "\"")) - (t ; use '' quotes - (setq quote "'"))) - (concat quote value quote))) - -(defun sgml-completion-table (&optional avoid-tags-in-cdata) - (sgml-parse-to-here) - (when sgml-markup-type - (error "No tags allowed")) - (cond ((or (sgml-model-group-p sgml-current-state) - (eq sgml-current-state sgml-any)) - (append - (mapcar (function (lambda (x) (cons (sgml-end-tag-of x) x))) - (sgml-current-list-of-endable-eltypes)) - (mapcar (function (lambda (x) (cons (sgml-start-tag-of x) x))) - (sgml-current-list-of-valid-eltypes)))) - (t - (sgml-message "%s" sgml-current-state) - nil))) - -(defun sgml-element-endable-p () - (sgml-parse-to-here) - (and (not (eq sgml-current-tree sgml-top-tree)) - (sgml-final-p sgml-current-state))) - -(defun sgml-insert-end-tag () - "Insert end-tag for the current open element." - (interactive "*") - (sgml-parse-to-here) - (cond - ((eq sgml-current-tree sgml-top-tree) - (sgml-error "No open element")) - ((not (sgml-final-p sgml-current-state)) - (sgml-error "Can`t end element here")) - (t - (when (and sgml-indent-step - (not (sgml-element-data-p sgml-current-tree))) - (delete-horizontal-space) - (unless (bolp) - (insert "\n"))) - (when (prog1 (bolp) - (tempo-process-and-insert-string - (if (eq t (sgml-element-net-enabled sgml-current-tree)) - "/" - ;; wing change: If there is more than one endable - ;; tag, we probably want the outermost one rather - ;; than the innermost one. Thus, we end a - ;; even when a is possible. - (sgml-end-tag-of - (car (last (sgml-current-list-of-endable-eltypes))))))) - (sgml-indent-line))))) - -(defun sgml-insert-start-tag (name asl attlist &optional net) - (tempo-process-and-insert-string (concat "<" name)) - (sgml-insert-attributes asl attlist) - (insert (if net "/" ">"))) - -(defun sgml-change-start-tag (element asl) - (let ((name (sgml-element-gi element)) - (attlist (sgml-element-attlist element))) - (assert (sgml-bpos-p (sgml-element-stag-epos element))) - (goto-char (sgml-element-start element)) - (delete-char (sgml-element-stag-len element)) - (sgml-insert-start-tag name asl attlist - (eq t (sgml-element-net-enabled element))))) - -(defun sgml-read-attribute-value (attdecl curvalue) - "Return the attribute value read from user. -ATTDECL is the attribute declaration for the attribute to read. -CURVALUE is nil or a string that will be used as default value." - (assert attdecl) - (let* ((name (sgml-attdecl-name attdecl)) - (dv (sgml-attdecl-declared-value attdecl)) - (tokens (sgml-declared-value-token-group dv)) - (notations (sgml-declared-value-notation dv)) - (type (cond (tokens "token") - (notations "notation") - (t (symbol-name dv)))) - (prompt - (format "Value for %s (%s%s): " - name type - (if curvalue - (format " Default: %s" curvalue) - ""))) - value) - (setq value - (if (or tokens notations) - (completing-read prompt - (mapcar 'list (or tokens notations)) - nil t) - (read-string prompt))) - (if (and curvalue (equal value "")) - curvalue value))) - -(defun sgml-non-fixed-attributes (attlist) - (loop for attdecl in attlist - unless (sgml-default-value-type-p 'fixed - (sgml-attdecl-default-value attdecl)) - collect attdecl)) - -(defun sgml-insert-attribute (name value) - "Read attribute name and value from minibuffer and insert attribute spec." - (interactive - (let* ((el (sgml-find-attribute-element)) - (name - (completing-read - "Attribute name: " - (mapcar (function (lambda (a) (list (sgml-attdecl-name a)))) - (sgml-non-fixed-attributes (sgml-element-attlist el))) - nil t))) - (list name - (sgml-read-attribute-value - (sgml-lookup-attdecl name (sgml-element-attlist el)) - (sgml-element-attval el name))))) - ;; Body - (assert (stringp name)) - (assert (or (null value) (stringp value))) - (let* ((el (sgml-find-attribute-element)) - (asl (cons (sgml-make-attspec name value) - (sgml-element-attribute-specification-list el))) - (in-tag (< (point) (sgml-element-stag-end el)))) - (sgml-change-start-tag el asl) - (when in-tag (forward-char -1)))) - -(defun sgml-split-element () - "Split the current element at point. -If repeated, the containing element will be split before the beginning -of then current element." - (interactive "*") - (setq sgml-split-level - (if (eq this-command last-command) - (1+ sgml-split-level) - 0)) - (let ((u (sgml-find-context-of (point))) - (start (point-marker))) - (loop repeat sgml-split-level do - (goto-char (sgml-element-start u)) - (setq u (sgml-element-parent u))) - ;; Verify that a new element can be started - (unless (and (sgml-element-pstate u) ; in case of top element - (sgml-get-move (sgml-element-pstate u) - (sgml-element-name u))) - - (sgml-error "The %s element can't be split" - (sgml-element-name u))) - ;; Do the split - (sgml-insert-end-tag) - (sgml-insert-tag (sgml-start-tag-of u) 'silent) - (skip-chars-forward " \t\n") - (sgml-indent-line) - (when (> sgml-split-level 0) - (goto-char start)) - (or (eq sgml-top-tree - (setq u (sgml-element-parent u))) - (sgml-message - "Repeat the command to split the containing %s element" - (sgml-element-name u))))) - -;;; David Megginson's custom menus for keys - -(defun sgml-custom-dtd (doctype) - "Insert a DTD declaration from the sgml-custom-dtd alist." - (interactive - (list (completing-read "Insert DTD: " sgml-custom-dtd nil t))) - (let ((entry (assoc doctype sgml-custom-dtd))) - (sgml-doctype-insert (second entry) (cddr entry)))) - -(defun sgml-custom-markup (markup) - "Insert markup from the sgml-custom-markup alist." - (interactive - (list (completing-read "Insert Markup: " sgml-custom-markup nil t))) - (sgml-insert-markup (cadr (assoc markup sgml-custom-markup)))) - - -;;;; SGML mode: Menu inserting - -(defun sgml-tags-menu (event) - "Pop up a menu with valid tags and insert the choosen tag. -If the variable sgml-balanced-tag-edit is t, also inserts the -corresponding end tag. If sgml-leave-point-after-insert is t, the point -is left after the inserted tag(s), unless the element has som required -content. If sgml-leave-point-after-insert is nil the point is left -after the first tag inserted." - (interactive "*e") - (let ((end (sgml-mouse-region))) - (sgml-parse-to-here) - (cond - ((eq sgml-markup-type 'start-tag) - (sgml-attrib-menu event)) - (t - (let ((what - (sgml-menu-ask event (if (or end sgml-balanced-tag-edit) - 'element 'tags)))) - (cond - ((null what)) - (end - (sgml-tag-region what (point) end)) - (sgml-balanced-tag-edit - (sgml-insert-element what)) - (t - (sgml-insert-tag what)))))))) - -(defun sgml-element-menu (event) - "Pop up a menu with valid elements and insert choice. -If sgml-leave-point-after-insert is nil the point is left after the first -tag inserted." - (interactive "*e") - (let ((what (sgml-menu-ask event 'element))) - (and what (sgml-insert-element what)))) - -(defun sgml-start-tag-menu (event) - "Pop up a menu with valid start-tags and insert choice." - (interactive "*e") - (let ((what (sgml-menu-ask event 'start-tag))) - (and what (sgml-insert-tag what)))) - -(defun sgml-end-tag-menu (event) - "Pop up a menu with valid end-tags and insert choice." - (interactive "*e") - (let ((what (sgml-menu-ask event 'end-tag))) - (and what (sgml-insert-tag what)))) - -(defun sgml-tag-region-menu (event) - "Pop up a menu with valid elements and tag current region with the choice." - (interactive "*e") - (let ((what (sgml-menu-ask event 'element))) - (and what (sgml-tag-region what - (region-beginning) - (region-end))))) - -(defun sgml-menu-ask (event type) - (sgml-parse-to-here) - (let (tab - (title (capitalize (symbol-name type)))) - (cond - (sgml-markup-type) - ((eq type 'element) - (setq tab - (mapcar (function symbol-name) - (sgml-current-list-of-valid-eltypes)))) - (t - (unless (eq type 'start-tag) - (setq tab - (mapcar (function sgml-end-tag-of) - (sgml-current-list-of-endable-eltypes)))) - (unless (eq type 'end-tag) - (setq tab - (nconc tab - (mapcar (function sgml-start-tag-of) - (sgml-current-list-of-valid-eltypes))))))) - (or tab - (error "No valid %s at this point" type)) - (or - (sgml-popup-menu event - title - (mapcar (function (lambda (x) (cons x x))) - tab)) - (message nil)))) - -(defun sgml-entities-menu (event) - (interactive "*e") - (sgml-need-dtd) - (let ((menu - (mapcar (function (lambda (x) (cons x x))) - (sort (sgml-map-entities (function sgml-entity-name) - (sgml-dtd-entities sgml-dtd-info) - t) - (function string-lessp)))) - choice) - (unless menu - (error "No entities defined")) - (setq choice (sgml-popup-menu event "Entities" menu)) - (when choice - (insert "&" choice ";")))) - -(defun sgml-doctype-insert (doctype vars) - "Insert string DOCTYPE (ignored if nil) and set variables in &rest VARS. -VARS should be a list of variables and values. -For backward compatibility a single string instead of a variable is -assigned to sgml-default-dtd-file. -All variables are made buffer local and are also added to the -buffers local variables list." - (when doctype - (unless (bolp) - (insert "\n")) - (unless (eolp) - (insert "\n") - (forward-char -1)) - (sgml-insert-markup doctype)) - (while vars - (cond ((stringp (car vars)) - (sgml-set-local-variable 'sgml-default-dtd-file (car vars)) - (setq vars (cdr vars))) - ((car vars) ; Avoid nil - (sgml-set-local-variable (car vars) (cadr vars)) - (setq vars (cddr vars))))) - (setq sgml-top-tree nil)) - -(defun sgml-attrib-menu (event) - "Pop up a menu of the attributes of the current element -\(or the element whith start-tag before point)." - (interactive "e") - (let ((menu (sgml-make-attrib-menu (sgml-find-attribute-element)))) - (sgml-popup-multi-menu event "Attributes" menu))) - -(defun sgml-make-attrib-menu (el) - (let ((attlist (sgml-non-fixed-attributes (sgml-element-attlist el)))) - (or attlist - (error "No non-fixed attributes for element")) - (loop for attdecl in attlist - for name = (sgml-attdecl-name attdecl) - for defval = (sgml-attdecl-default-value attdecl) - for tokens = (or (sgml-declared-value-token-group - (sgml-attdecl-declared-value attdecl)) - (sgml-declared-value-notation - (sgml-attdecl-declared-value attdecl))) - collect - (cons - (sgml-attdecl-name attdecl) - (nconc - (if tokens - (loop for val in tokens collect - (list val - (list 'sgml-insert-attribute name val))) - (list - (list "Set attribute value" - (list 'sgml-insert-attribute - (sgml-attdecl-name attdecl) - (list 'sgml-read-attribute-value - (list 'quote attdecl) - (sgml-element-attval el name)))))) - (if (sgml-default-value-type-p 'required defval) - nil - (list "--" - (list (if (sgml-default-value-type-p nil defval) - (format "Default: %s" - (sgml-default-value-attval defval)) - "#IMPLIED") - (list 'sgml-insert-attribute name nil)))))))) - ) - -;;;; SGML mode: Fill - -(defun sgml-fill-element (element) - "Fill bigest enclosing element with mixed content. -If current element has pure element content, recursively fill the -subelements." - (interactive (list (sgml-find-element-of (point)))) - ;; - (message "Filling...") - (when (sgml-element-mixed element) - ;; Find bigest enclosing element with mixed content - (while (sgml-element-mixed (sgml-element-parent element)) - (setq element (sgml-element-parent element)))) - ;; - (sgml-do-fill element) - (sgml-message "Done")) - -(defun sgml-do-fill (element) - (when sgml-debug - (goto-char (sgml-element-start element)) - (sit-for 0)) - (save-excursion - (cond - ((sgml-element-mixed element) - (let (last-pos - (c (sgml-element-content element)) - (agenda nil)) ; regions to fill later - (goto-char (sgml-element-stag-end element)) - (when (eolp) (forward-char 1)) - (setq last-pos (point)) - (while c - (cond - ((sgml-element-mixed c)) - (t - ;; Put region before element on agenda. Can't fill it now - ;; that would mangel the parse tree that is being traversed. - (push (cons last-pos (sgml-element-start c)) - agenda) - (goto-char (sgml-element-start c)) - (sgml-do-fill c) - ;; Fill may change parse tree, get a fresh - (setq c (sgml-find-element-of (point))) - (setq last-pos (sgml-element-end c)))) - (setq c (sgml-element-next c))) - ;; Fill the last region in content of element, - ;; but get a fresh parse tree, if it has change due to other fills. - (sgml-fill-region last-pos - (sgml-element-etag-start - (sgml-find-element-of - (sgml-element-start element)))) - (while agenda - (sgml-fill-region (caar agenda) (cdar agenda)) - (setq agenda (cdr agenda))))) - (t - ;; If element is not mixed, fill subelements recursively - (let ((c (sgml-element-content element))) - (while c - (goto-char (sgml-element-start c)) - (sgml-do-fill c) - (setq c (sgml-element-next (sgml-find-element-of (point)))))))))) - -(defun sgml-fill-region (start end) - (sgml-message "Filling...") - (save-excursion - (goto-char end) - (skip-chars-backward " \t\n") - (while (progn (beginning-of-line 1) - (< start (point))) - (delete-horizontal-space) - (delete-char -1) - (insert " ")) - (end-of-line 1) - (let (give-up prev-column opoint) - (while (and (not give-up) (> (current-column) fill-column)) - (setq prev-column (current-column)) - (setq opoint (point)) - (move-to-column (1+ fill-column)) - (skip-chars-backward "^ \t\n") - (if (bolp) - (re-search-forward "[ \t]" opoint t)) - (setq opoint (point)) - (skip-chars-backward " \t") - (if (bolp) - (setq give-up t) - (delete-region (point) opoint) - (newline) - (sgml-indent-line) - (end-of-line 1) - (setq give-up (>= (current-column) prev-column))))))) - -;;;; SGML mode: Attribute editing - -(defvar sgml-start-attributes nil) -(defvar sgml-main-buffer nil) -(defvar sgml-attlist nil) - -(defun sgml-edit-attributes () - "Edit attributes of current element. -Editing is done in a separate window." - (interactive) - (let ((element (sgml-find-attribute-element))) - (unless (sgml-bpos-p (sgml-element-stag-epos element)) - (error "Element's start-tag is not in the buffer")) - (push-mark) - (goto-char (sgml-element-start element)) - (let* ((start (point-marker)) - (asl (sgml-element-attribute-specification-list element)) - (cb (current-buffer)) - (quote sgml-always-quote-attributes)) - (switch-to-buffer-other-window - (sgml-attribute-buffer element asl)) - (sgml-edit-attrib-mode) - (make-local-variable 'sgml-attlist) - (setq sgml-attlist (sgml-element-attlist element)) - (make-local-variable 'sgml-start-attributes) - (setq sgml-start-attributes start) - (make-local-variable 'sgml-always-quote-attributes) - (setq sgml-always-quote-attributes quote) - (make-local-variable 'sgml-main-buffer) - (setq sgml-main-buffer cb)))) - -(defun sgml-attribute-buffer (element asl) - (let ((bname "*Edit attributes*") - (buf nil) - (inhibit-read-only t)) - (save-excursion - (when (setq buf (get-buffer bname)) - (kill-buffer buf)) - (setq buf (get-buffer-create bname)) - (set-buffer buf) - (erase-buffer) - (sgml-insert '(read-only t rear-nonsticky (read-only)) - "<%s -- Edit values and finish with C-c C-c --\n" - (sgml-element-name element)) - (loop - for attr in (sgml-element-attlist element) do - ;; Produce text like - ;; name = value - ;; -- declaration : default -- - (let* ((aname (sgml-attdecl-name attr)) - (dcl-value (sgml-attdecl-declared-value attr)) - (def-value (sgml-attdecl-default-value attr)) - (cur-value (sgml-lookup-attspec aname asl))) - (sgml-insert ; atribute name - '(read-only t rear-nonsticky (read-only)) - " %s = " aname) - (cond ; attribute value - ((sgml-default-value-type-p 'fixed def-value) - (sgml-insert '(read-only t category sgml-fixed - rear-nonsticky (category)) - "#FIXED %s" - (sgml-default-value-attval def-value))) - ((and (null cur-value) - (or (memq def-value '(implied conref current)) - (sgml-default-value-attval def-value))) - (sgml-insert '(category sgml-default rear-nonsticky (category)) - "#DEFAULT")) - ((not (null cur-value)) - (sgml-insert nil "%s" (sgml-attspec-attval cur-value)))) - (sgml-insert - '(read-only 1) - "\n\t-- %s: %s --\n" - (cond ((sgml-declared-value-token-group dcl-value)) - ((sgml-declared-value-notation dcl-value) - (format "NOTATION %s" - (sgml-declared-value-notation dcl-value))) - (t - dcl-value)) - (cond ((sgml-default-value-attval def-value)) - (t - (concat "#" (upcase (symbol-name def-value)))))))) - (sgml-insert '(read-only t) ">") - (goto-char (point-min)) - (sgml-edit-attrib-next)) - buf)) - -(defvar sgml-edit-attrib-mode-map (make-sparse-keymap)) -(define-key sgml-edit-attrib-mode-map "\C-c\C-c" 'sgml-edit-attrib-finish) -(define-key sgml-edit-attrib-mode-map "\C-c\C-d" 'sgml-edit-attrib-default) -(define-key sgml-edit-attrib-mode-map "\C-c\C-k" 'sgml-edit-attrib-clear) - -(define-key sgml-edit-attrib-mode-map "\C-a" 'sgml-edit-attrib-field-start) -(define-key sgml-edit-attrib-mode-map "\C-e" 'sgml-edit-attrib-field-end) -(define-key sgml-edit-attrib-mode-map "\t" 'sgml-edit-attrib-next) - -(defun sgml-edit-attrib-mode () - "Major mode to edit attribute specification list.\\ -Use \\[sgml-edit-attrib-next] to move between input fields. Use -\\[sgml-edit-attrib-default] to make an attribute have its default -value. To abort edit kill buffer (\\[kill-buffer]) and remove window -(\\[delete-window]). To finsh edit use \\[sgml-edit-attrib-finish]. - -\\{sgml-edit-attrib-mode-map}" - (kill-all-local-variables) - (setq mode-name "SGML edit attributes" - major-mode 'sgml-edit-attrib-mode) - (use-local-map sgml-edit-attrib-mode-map) - (run-hooks 'text-mode-hook 'sgml-edit-attrib-mode-hook)) - -(defun sgml-edit-attrib-finish () - "Finish editing and insert attribute values in original buffer." - (interactive) - (let ((cb (current-buffer)) - (asl (sgml-edit-attrib-specification-list)) - ;; save buffer local variables - (start sgml-start-attributes)) - (when (markerp start) - (delete-windows-on cb) - (switch-to-buffer (marker-buffer start)) - (kill-buffer cb) - (goto-char start) - (let ((element (sgml-find-element-of start))) - ;; *** Should the it be verified that this element - ;; is the one edited? - (sgml-change-start-tag element asl))))) - - -(defun sgml-edit-attrib-specification-list () - (goto-char (point-min)) - (forward-line 1) - (sgml-with-parser-syntax - (let ((asl nil) - (al sgml-attlist)) - (while (not (eq ?> (following-char))) - (sgml-parse-s) - (sgml-check-nametoken) ; attribute name, should match head of al - (forward-char 3) - (unless (memq (get-text-property (point) 'category) - '(sgml-default sgml-fixed)) - (push - (sgml-make-attspec (sgml-attdecl-name (car al)) - (sgml-extract-attribute-value - (sgml-attdecl-declared-value (car al)))) - asl)) - (while (progn (beginning-of-line 2) - (or (eolp) - (not (get-text-property (point) 'read-only))))) - - (forward-line 1) - (setq al (cdr al))) - asl))) - - -(defun sgml-extract-attribute-value (type) - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (sgml-edit-attrib-field-end) - (point))) - (unless (eq type 'cdata) - (subst-char-in-region (point-min) (point-max) ?\n ? ) - (goto-char (point-min)) - (delete-horizontal-space)) - (goto-char (point-min)) - (when (search-forward "\"" nil t) ; don't allow both " and ' - (goto-char (point-min)) - (while (search-forward "'" nil t) ; replace ' with char ref - (replace-match "'"))) - (buffer-string)))) - -(defun sgml-edit-attrib-default () - "Set current attribute value to default." - (interactive) - (sgml-edit-attrib-clear) - (save-excursion - (sgml-insert '(category sgml-default) - "#DEFAULT"))) - -(defun sgml-edit-attrib-clear () - "Kill the value of current attribute." - (interactive) - (kill-region - (progn (sgml-edit-attrib-field-start) (point)) - (progn (sgml-edit-attrib-field-end) (point)))) - -(defun sgml-edit-attrib-field-start () - "Go to the start of the attribute value field." - (interactive) - (let (start) - (beginning-of-line 1) - (while (not (eq t (get-text-property (point) 'read-only))) - (beginning-of-line 0)) - (setq start (next-single-property-change (point) 'read-only)) - (unless start (error "No attribute value here")) - (assert (number-or-marker-p start)) - (goto-char start))) - -(defun sgml-edit-attrib-field-end () - "Go to the end of the attribute value field." - (interactive) - (sgml-edit-attrib-field-start) - (let ((end (if (and (eolp) - (get-text-property (1+ (point)) 'read-only)) - (point) - (next-single-property-change (point) 'read-only)))) - (assert (number-or-marker-p end)) - (goto-char end))) - -(defun sgml-edit-attrib-next () - "Move to next attribute value." - (interactive) - (or (search-forward-regexp "^ *[.A-Za-z0-9---]+ *= ?" nil t) - (goto-char (point-min)))) - - -;;;; SGML mode: Hiding tags/attributes - -(defconst sgml-tag-regexp - "\\(\\|?\\)") - -(defun sgml-operate-on-tags (action &optional attr-p) - (let ((buffer-modified-p (buffer-modified-p)) - (inhibit-read-only t) - (buffer-read-only nil) - (before-change-function nil) - (markup-index ; match-data index in tag regexp - (if attr-p 2 1)) - (tagcount ; number tags to give them uniq - ; invisible properties - 1)) - (unwind-protect - (save-excursion - (goto-char (point-min)) - (while (re-search-forward sgml-tag-regexp nil t) - (cond - ((eq action 'hide) - (let ((tag (downcase - (buffer-substring-no-properties - (1+ (match-beginning 0)) - (match-beginning 2))))) - (if (or attr-p (not (member tag sgml-exposed-tags))) - (add-text-properties - (match-beginning markup-index) (match-end markup-index) - (list 'invisible tagcount - 'rear-nonsticky '(invisible face)))))) - ((eq action 'show) ; ignore markup-index - (remove-text-properties (match-beginning 0) (match-end 0) - '(invisible nil))) - (t (error "Invalid action: %s" action))) - (incf tagcount))) - (set-buffer-modified-p buffer-modified-p)))) - -(defun sgml-hide-tags () - "Hide all tags in buffer." - (interactive) - (sgml-operate-on-tags 'hide)) - -(defun sgml-show-tags () - "Show hidden tags in buffer." - (interactive) - (sgml-operate-on-tags 'show)) - -(defun sgml-hide-attributes () - "Hide all attribute specifications in the buffer." - (interactive) - (sgml-operate-on-tags 'hide 'attributes)) - -(defun sgml-show-attributes () - "Show all attribute specifications in the buffer." - (interactive) - (sgml-operate-on-tags 'show 'attributes)) - - -;;;; SGML mode: Normalize (and misc manipulations) - -(defun sgml-expand-shortref-to-text (name) - (let (before-change-function - (entity (sgml-lookup-entity name (sgml-dtd-entities sgml-dtd-info)))) - (cond - ((null entity) (sgml-error "Undefined entity %s" name)) - ((sgml-entity-data-p entity) - (sgml-expand-shortref-to-entity name)) - (t - (delete-region sgml-markup-start (point)) - (sgml-entity-insert-text entity) - (setq sgml-goal (point-max)) ; May have changed size of buffer - ;; now parse the entity text - (setq sgml-rs-ignore-pos sgml-markup-start) - (goto-char sgml-markup-start))))) - -(defun sgml-expand-shortref-to-entity (name) - (let ((end (point)) - (re-found nil) - before-change-function) - (goto-char sgml-markup-start) - (setq re-found (search-forward "\n" end t)) - (delete-region sgml-markup-start end) - (insert "&" name (if re-found "\n" ";")) - (setq sgml-goal (point-max)) ; May have changed size of buffer - (goto-char (setq sgml-rs-ignore-pos sgml-markup-start)))) - -(defun sgml-expand-all-shortrefs (to-entity) - "Expand all short references in the buffer. -Short references to text entities are expanded to the replacement text -of the entity other short references are expanded into general entity -references. If argument, TO-ENTITY, is non-nil, or if called -interactive with numeric prefix argument, all short references are -replaced by generaly entity references." - (interactive "*P") - (sgml-reparse-buffer - (if to-entity - (function sgml-expand-shortref-to-entity) - (function sgml-expand-shortref-to-text)))) - -(defun sgml-normalize (to-entity &optional element) - "Normalize buffer by filling in omitted tags and expanding empty tags. -Argument TO-ENTITY controls how short references are expanded as with -`sgml-expand-all-shortrefs'. An optional argument ELEMENT can be the -element to normalize insted of the whole buffer, if used no short -references will be expanded." - (interactive "*P") - (unless element - (sgml-expand-all-shortrefs to-entity)) - (let ((only-one (not (null element)))) - (setq element (or element (sgml-top-element))) - (goto-char (sgml-element-end element)) - (let ((before-change-function nil)) - (sgml-normalize-content element only-one))) - (sgml-note-change-at (sgml-element-start element)) - (sgml-message "Done")) - -(defun sgml-normalize-element () - (interactive "*") - (sgml-normalize nil (sgml-find-element-of (point)))) - -(defun sgml-normalize-content (element only-first) - "Normalize all elements in a content where ELEMENT is first element. -If sgml-normalize-trims is non-nil, trim off white space from ends of -elements with omitted end-tags." - (let ((content nil)) - (while element ; Build list of content elements - (push element content) - (setq element (if only-first - nil - (sgml-element-next element)))) - (while content - (setq element (car content)) - ;; Progress report - (sgml-lazy-message "Normalizing %d%% left" - (/ (point) (/ (+ (point-max) 100) 100))) - ;; Fix the end-tag - (sgml-normalize-end-tag element) - ;; Fix tags of content - (sgml-normalize-content (sgml-tree-content element) nil) - ;; Fix the start-tag - (sgml-normalize-start-tag element) - ;; Next content element - (setq content (cdr content))))) - -(defun sgml-normalize-start-tag (element) - (when (sgml-bpos-p (sgml-element-stag-epos element)) - (goto-char (min (point) (sgml-element-start element))) - (let ((name (sgml-element-gi element)) - (attlist (sgml-element-attlist element)) - (asl (sgml-element-attribute-specification-list element))) - (save-excursion - (assert (or (zerop (sgml-element-stag-len element)) - (= (point) (sgml-element-start element)))) - (delete-char (sgml-element-stag-len element)) - (sgml-insert-start-tag name asl attlist nil))))) - -(defun sgml-normalize-end-tag (element) - (unless (sgml-element-empty element) - (when (sgml-bpos-p (sgml-element-etag-epos element)) - (goto-char (min (point) (sgml-element-etag-start element))) - (if (and (zerop (sgml-element-etag-len element)) - sgml-normalize-trims) - (skip-chars-backward " \t\n\r")) - (delete-char (sgml-tree-etag-len element)) - (save-excursion (tempo-process-and-insert-string (sgml-end-tag-of element)))))) - - -(defun sgml-make-character-reference (&optional invert) - "Convert character after point into a character reference. -If called with a numeric argument, convert a character reference back -to a normal character. If called from a program, set optional -argument INVERT to non-nil." - (interactive "*P") - (cond - (invert - (or (looking-at "&#\\([0-9]+\\)[;\n]?") - (error "No character reference after point")) - (let ((c (string-to-int (buffer-substring (match-beginning 1) - (match-end 1))))) - (delete-region (match-beginning 0) - (match-end 0)) - (insert c))) - ;; Convert character to &#nn; - (t - (let ((c (following-char))) - (delete-char 1) - (insert (format "&#%d;" c)))))) - -(defun sgml-expand-entity-reference () - "Insert the text of the entity referenced at point." - (interactive) - (sgml-with-parser-syntax - (setq sgml-markup-start (point)) - (sgml-check-delim "ERO") - (let* ((ename (sgml-check-name t)) - (entity (sgml-lookup-entity ename - (sgml-dtd-entities - (sgml-pstate-dtd - sgml-buffer-parse-state))))) - (unless entity - (error "Undefined entity %s" ename)) - (or (sgml-parse-delim "REFC") - (sgml-parse-RE)) - (delete-region sgml-markup-start (point)) - (sgml-entity-insert-text entity)))) - - -;;;; SGML mode: TAB completion - -(defun sgml-complete () - "Complete the word/tag/entity before point. -If it is a tag (starts with < or -;; Version: $Id: psgml-fs.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ -;; Keywords: -;; Last edited: Thu Mar 21 22:32:27 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin) - -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to lenst@lysator.liu.se) or from -;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA -;;; 02139, USA. -;;; -;;; Commentary: - -;; The function `style-format' formats the SGML-file in the current -;; buffer according to the style defined in the file `psgml-style.fs' -;; (or the file given by the variable `fs-style'). - -;; To try it load this file and open the test file example.sgml. Then -;; run the emacs command `M-x style-format'. - -;; The style file should contain a single Lisp list. The elements of -;; this list, are them self lists, describe the style for an element type. -;; The sublists begin with the generic identifier for the element types and -;; the rest of the list are characteristic/value pairs. - -;; E.g. ("p" block t left 4 top 2) - -;; Defines the style for p-elements to be blocks with left margin 4 and -;; at least to blank lines before the block. - - -;;; Code: -(require 'psgml-api) - -;;;; Formatting parameters - -(defvar fs-char - '((left . 0) - (first . nil) - (default-top . 0) - (default-bottom . 0) - (ignore-empty-para . nil) - (literal . nil))) - -(defvar fs-special-styles - '(top bottom before after hang-from text) - "Style attribues that should not be entered in the characteristics table.") - - -;;;; Formatting engine - -(defun fs-char (p) - (cdr (assq p fs-char))) - -(defvar fs-para-acc "" - "Accumulate text of paragraph") - -(defvar fs-hang-from nil - "Hanging indent of current pargraph") - -(defvar fs-first-indent nil) -(defvar fs-left-indent nil) - -(defvar fs-vspace 0 - "Vertical space after last paragraph") - -(defun fs-addvspace (n) - (when (> n fs-vspace) - (princ (make-string (- n fs-vspace) ?\n)) - (setq fs-vspace n))) - - -(defun fs-para () - (when (if (fs-char 'ignore-epmty-para) - (string-match "[^\t\n ]" fs-para-acc) - fs-left-indent) - (assert fs-left-indent) - (fs-output-para fs-para-acc fs-first-indent fs-left-indent - fs-hang-from - (fs-char 'literal)) - (setq fs-vspace 0 - fs-hang-from nil)) - (setq fs-para-acc "" - fs-first-indent nil - fs-left-indent nil)) - -(defun fs-paraform-data (data) - (unless fs-left-indent - (setq fs-left-indent (fs-char 'left) - fs-first-indent (fs-char 'first))) - (setq fs-para-acc (concat fs-para-acc data))) - -(defun fs-output-para (text first-indent indent hang-from literal) - (sgml-push-to-string text) - (let ((indent-tabs-mode nil) - (fill-prefix (make-string indent ? ))) - (cond - (literal - (goto-char (point-max)) - (unless (bolp) - (insert ?\n)) - (goto-char (point-min)) - (while (not (eobp)) - (insert fill-prefix) - (beginning-of-line 2))) - (t - (while (re-search-forward "[ \t\n\r]+" nil t) - (replace-match " ")) - (goto-char (point-min)) - (delete-horizontal-space) - (insert - (if hang-from - hang-from - (make-string (or first-indent indent) ? ))) - (fill-region-as-paragraph (point-min) (point-max)) - )) - (princ (buffer-string))) - (sgml-pop-entity)) - -(defun fs-element-content (e) - (let ((fs-para-acc "")) - (sgml-map-content e - (function fs-paraform-phrase) - (function fs-paraform-data) - nil - (function fs-paraform-entity)) - fs-para-acc)) - -(defun fs-paraform-phrase (e) - (sgml-map-content e - (function fs-paraform-phrase) - (function fs-paraform-data) - nil - (function fs-paraform-entity))) - -(defun fs-paraform-entity (entity) - (let ((entity-map (fs-char 'entity-map)) - (text nil)) - (when entity-map - (setq text - (loop for (name val) on entity-map by 'cddr - thereis (if (equal name (sgml-entity-name entity)) - val)))) - (unless text - (setq text (sgml-entity-text entity))) - (fs-paraform-data text))) - -;;;; Style driven engine - -(defvar fs-style "psgml-style.fs" - "*Style sheet to use for `style-format'. -The value can be the style-sheet list, or it can be a file name -\(string) of a file containing the style sheet or it can be the name -\(symbol) of a variable containing the style sheet." ) - -(defvar fs-cached-styles nil) - -(defun fs-get-style (style) - (cond ((stringp style) - (sgml-cache-catalog style - 'fs-cached-styles - (function (lambda () - (read (current-buffer)))))) - ((symbolp style) - (fs-get-style (symbol-value style))) - ((listp style) - style) - (t - (error "Illegal style value: %s" style)))) - -(defun fs-engine (e) - (fs-do-style e - (cdr (or (assoc (sgml-element-gi e) fs-style) - (assq t fs-style))))) - -(defun fs-do-style (e style) - (let ((hang-from (getf style 'hang-from))) - (when hang-from - (setq fs-hang-from - (format "%s%s " - (make-string (fs-char 'left) ? ) - (eval hang-from))))) - (let ((fs-char (nconc - (loop for st on style by 'cddr - unless (memq (car st) fs-special-styles) - collect (cons (car st) - (eval (cadr st)))) - fs-char))) - (when (getf style 'block) - (fs-para) - (fs-addvspace (or (getf style 'top) - (fs-char 'default-top)))) - (let ((before (getf style 'before))) - (when before - (fs-do-style e before))) - (cond ((getf style 'text) - (fs-paraform-data (eval (getf style 'text)))) - (t - (sgml-map-content e - (function fs-engine) - (function fs-paraform-data) - nil - (function fs-paraform-entity)))) - (let ((after (getf style 'after))) - (when after - (fs-do-style e after))) - (when (getf style 'block) - (fs-para) - (fs-addvspace (or (getf style 'bottom) - (fs-char 'default-bottom)))))) - -;;;###autoload -(defun style-format () - (interactive) - (setq fs-para-acc "") - (let ((fs-style (fs-get-style fs-style))) - (with-output-to-temp-buffer "*Formatted*" - (fs-engine (sgml-top-element)) - (fs-para)))) - - - -;;;; Helper functions for use in style sheet - -(defun fs-attval (name) - (sgml-element-attval e name)) - - -;;; psgml-fs.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-html.el --- a/lisp/psgml/psgml-html.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,798 +0,0 @@ -;;; psgml-html.el --- HTML mode in conjunction with PSGML - -;; Copyright (C) 1994 Nelson Minar. -;; Copyright (C) 1995 Nelson Minar and Ulrik Dickow. -;; Copyright (C) 1996 Ben Wing. - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XEmacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: FSF 19.30. - -;;; Author: Ben Wing. - -;;; Commentary: - -; Parts were taken from html-helper-mode and from code by Alastair Burt. - -; If you'd like to use the hm--html-minor-mode together with this -; mode, you have to put the following line to your ~/.emacs: -; (add-hook 'html-mode-hook 'hm--html-minor-mode) - -;;; Code: - -(defvar html-auto-sgml-entity-conversion nil - "*Control automatic sgml entity to ISO-8859-1 conversion") - -(require 'psgml) -(require 'derived) -(when html-auto-sgml-entity-conversion - (require 'iso-sgml)) -(require 'tempo) ;essential part of html-helper-mode - -;;{{{ user variables - -(defgroup html nil - "HyperText Markup Language" - :group 'sgml) - -(defgroup psgml-html nil - "HTML mode in conjunction with PSGML" - :tag "Psgml Html" - :prefix "html-helper-" - :group 'html - :group 'psgml) - -;; Set this to be whatever signature you want on the bottom of your pages. -(defcustom html-helper-address-string - (concat "" - (user-full-name) "") - "*The default author string of each file." - :type 'string - :group 'psgml-html) - -(defcustom html-helper-htmldtd-version "\n" - "*Version of HTML DTD you're using." - :type 'string - :group 'psgml-html) - -(defcustom html-helper-do-write-file-hooks t - "*If not nil, then modify `local-write-file-hooks' to do timestamps." - :type 'boolean - :group 'psgml-html) - -(defcustom html-helper-build-new-buffer t - "*If not nil, then insert `html-helper-new-buffer-strings' for new buffers." - :type 'boolean - :group 'psgml-html) - -(defcustom html-helper-timestamp-hook 'html-helper-default-insert-timestamp - "*Hook called for timestamp insertion. -Override this for your own timestamp styles." - :type 'boolean - :group 'psgml-html) - -;; strings you might want to change - -(defcustom html-helper-new-buffer-template - '(html-helper-htmldtd-version - "\n" - " \n" - " " (p "Document Title: " title) "\n" - " \n" - "\n" - " \n" - "

    " (s title) "

    \n\n" - p - "\n\n
    \n" - "
    " html-helper-address-string "
    \n" - (html-helper-return-created-string) - html-helper-timestamp-start - html-helper-timestamp-end - "\n \n\n") - "*Template for new buffers. -Inserted by `html-helper-insert-new-buffer-strings' if -`html-helper-build-new-buffer' is set to t" - :type 'sexp - :group 'psgml-html) - -(defcustom html-helper-timestamp-start "\n" - "*Start delimiter for timestamps. -Everything between `html-helper-timestamp-start' and -`html-helper-timestamp-end' will be deleted and replaced with the output -of the functions `html-helper-timestamp-hook' if -`html-helper-do-write-file-hooks' is t" - :type 'string - :group 'psgml-html) - -(defcustom html-helper-timestamp-end "" - "*End delimiter for timestamps. -Everything between `html-helper-timestamp-start' and -`html-helper-timestamp-end' will be deleted and replaced with the output -of the function `html-helper-insert-timestamp' if -`html-helper-do-write-file-hooks' is t" - :type 'string - :group 'psgml-html) - -;; control over what types of tags to load. By default, we load all the -;; ones we know of. - -(defcustom html-helper-types-to-install - '(anchor header logical phys list textel entity image head form) - "*List of tag types to install when html-helper-mode is first loaded. -If you want to not install some type of tag, override this variable. -Order is significant: menus go in this order." - :type '(repeat symbol) - :group 'psgml-html) - -;;}}} end of user variables -;;{{{ type based keymap and menu variable and function setup - -;; html-helper-mode has a concept of "type" of tags. Each type is a -;; list of tags that all go together in one keymap and one menu. -;; Types can be added to the system after html-helper has been loaded, -;; briefly by doing html-helper-add-type-to-alist, then -;; html-helper-install-type, then html-helper-add-tag (for each tag) -;; then html-helper-rebuild-menu. See the mode documentation for more detail. - -(defconst html-helper-type-alist nil - "Alist: type of tag -> keymap, keybinding, menu, menu string. -Add to this with `html-helper-add-type-to-alist'.") - -;;{{{ accessor functions for html-helper-type-alist - -(defun html-helper-keymap-for (type) - "Accessor function for alist: for type, return keymap or nil" - (nth 0 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-key-for (type) - "Accessor function for alist: for type, return keybinding or nil" - (nth 1 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-menu-for (type) - "Accessor function for alist: for type, return menu or nil" - (nth 2 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-menu-string-for (type) - "Accessor function for alist: for type, return menustring or nil" - (nth 3 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-normalized-menu-for (type) - "Helper function for building menus from submenus: add on string to menu." - (cons (html-helper-menu-string-for type) - (eval (html-helper-menu-for type)))) - -;;}}} - -(define-derived-mode html-mode sgml-mode "HTML" - "Major mode for editing HTML documents. -This is based on PSGML mode, and has a sophisticated SGML parser in it. -It knows how to properly indent HTML/SGML documents, and it can do - a form of document validation (use \\[sgml-next-trouble-spot] to find - the next error in your document). -Commands beginning with C-z insert various types of HTML tags - (prompting for the required information); to iconify or suspend, - use C-z C-z. -To literally insert special characters such as < and &, use C-c followed - by the character. -Use \\[sgml-insert-end-tag] to insert the proper closing tag. -Use \\[sgml-edit-attributes] to edit the attributes for a tag. -Use \\[sgml-show-context] to show the current HTML context. - -More specifically: -\\{html-mode-map} -" - (make-local-variable 'sgml-declaration) - (make-local-variable 'sgml-default-doctype-name) - (setq sgml-declaration (expand-file-name "html.decl" - sgml-data-directory) - sgml-default-doctype-name "html" - sgml-always-quote-attributes t - sgml-indent-step 2 - sgml-indent-data t - sgml-inhibit-indent-tags '("pre") - sgml-minimize-attributes nil - sgml-omittag t - sgml-shortag t) - - ;; font-lock setup for various emacsen: XEmacs, Emacs 19.29+, Emacs <19.29. - ;; By Ulrik Dickow . (Last update: 05-Sep-1995). - (cond ((string-match "XEmacs\\|Lucid" (emacs-version)) ; XEmacs/Lucid - (put major-mode 'font-lock-keywords-case-fold-search t)) - ;; XEmacs (19.13, at least) guesses the rest correctly. - ;; If any older XEmacsen don't, then tell me. - ;; - ((string-lessp "19.28.89" emacs-version) ; Emacs 19.29 and later - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(html-font-lock-keywords t t))) - ;; - (t ; Emacs 19.28 and older - (make-local-variable 'font-lock-keywords-case-fold-search) - (make-local-variable 'font-lock-keywords) - (make-local-variable 'font-lock-no-comments) - (setq font-lock-keywords-case-fold-search t) - (setq font-lock-keywords html-font-lock-keywords) - (setq font-lock-no-comments t))) - - (if html-helper-do-write-file-hooks - (add-hook 'local-write-file-hooks 'html-helper-update-timestamp)) - - (if (and html-helper-build-new-buffer (zerop (buffer-size))) - (html-helper-insert-new-buffer-strings)) - - (set (make-local-variable 'sgml-custom-markup) - '(("" "\r"))) - - ;; Set up the syntax table. - (modify-syntax-entry ?< "(>" html-mode-syntax-table) - (modify-syntax-entry ?> ")<" html-mode-syntax-table) - (modify-syntax-entry ?\" ". " html-mode-syntax-table) - (modify-syntax-entry ?\\ ". " html-mode-syntax-table) - (modify-syntax-entry ?' "w " html-mode-syntax-table) - - ; sigh ... need to call this now to get things working. - (sgml-build-custom-menus) - (add-submenu nil sgml-html-menu "SGML") - (delete-menu-item '("SGML"))) - -(defun html-helper-add-type-to-alist (type) - "Add a type specification to the alist. -The spec goes (type . (keymap-symbol keyprefix menu-symbol menu-string)). -See code for an example." - (setq html-helper-type-alist (cons type html-helper-type-alist))) - -;; Here are the types provided by html-helper-mode. -(mapcar 'html-helper-add-type-to-alist - '((entity . (nil nil html-helper-entity-menu "Insert Character Entities")) - (textel . (nil nil html-helper-textel-menu "Insert Text Elements")) - (head . (html-helper-head-map "\C-zb" html-helper-head-menu "Insert Structural Elements")) - (header . (html-helper-base-map "\C-z" html-helper-header-menu "Insert Headers")) - (anchor . (html-helper-base-map "\C-z" html-helper-anchor-menu "Insert Hyperlinks")) - (logical . (html-helper-base-map "\C-z" html-helper-logical-menu "Insert Logical Styles")) - (phys . (html-helper-base-map "\C-z" html-helper-phys-menu "Insert Physical Styles")) - (list . (html-helper-list-map "\C-zl" html-helper-list-menu "Insert List Elements")) - (form . (html-helper-form-map "\C-zf" html-helper-form-menu "Insert Form Elements")) - (image . (html-helper-image-map "\C-zm" html-helper-image-menu "Insert Inlined Images")))) - -;; Once html-helper-mode is aware of a type, it can then install the -;; type: arrange for keybindings, menus, etc. - -(defconst html-helper-installed-types nil - "The types that have been installed (used when building menus). -There is no support for removing a type once it has been installed.") - -(defun html-helper-install-type (type) - "Install a new tag type: add it to the keymap, menu structures, etc. -For this to work, the type must first have been added to the list of types -with html-helper-add-type-to-alist." - (setq html-helper-installed-types (cons type html-helper-installed-types)) - (let ((keymap (html-helper-keymap-for type)) - (key (html-helper-key-for type)) - (menu (html-helper-menu-for type)) - (menu-string (html-helper-menu-string-for type))) - (and key - (progn - (set keymap nil) - (define-prefix-command keymap) - (define-key html-mode-map key keymap))) - (and menu - (progn - (set menu nil))))) - -;; install the default types. -(mapcar 'html-helper-install-type html-helper-types-to-install) - -;;}}} - -;;{{{ html-helper-add-tag function for building basic tags - -(defvar html-helper-tempo-tags nil - "List of tags used in completion.") - -;; this while loop is awfully Cish -;; isn't there an emacs lisp function to do this? -(defun html-helper-string-to-symbol (input-string) - "Given a string, downcase it and replace spaces with -. -We use this to turn menu entries into good symbols for functions. -It's not entirely successful, but fortunately emacs lisp is forgiving." - (let* ((s (copy-sequence input-string)) - (l (1- (length s)))) - (while (> l 0) - (if (char-equal (aref s l) ?\ ) - (aset s l ?\-)) - (setq l (1- l))) - (concat "html-" (downcase s)))) - - -(defun html-helper-add-tag (l) - "Add a new tag to html-helper-mode. -Builds a tempo-template for the tag and puts it into the -appropriate keymap if a key is requested. Format: -`(html-helper-add-tag '(type keybinding completion-tag menu-name template doc)'" - (let* ((type (car l)) - (keymap (html-helper-keymap-for type)) - (menu (html-helper-menu-for type)) - (key (nth 1 l)) - (completer (nth 2 l)) - (name (nth 3 l)) - (tag (nth 4 l)) - (doc (nth 5 l)) - (command (tempo-define-template (html-helper-string-to-symbol name) - tag completer doc - 'html-helper-tempo-tags))) - - (if (null (memq type html-helper-installed-types)) ;type loaded? - t ;no, do nothing. - (if (stringp key) ;bind key somewhere? - (if keymap ;special keymap? - (define-key (eval keymap) key command) ;t: bind to prefix - (define-key html-mode-map key command)) ;nil: bind to global - t) - (if menu ;is there a menu? - (set menu ;good, cons it in - (cons (vector name command t) (eval menu)))) - ))) - -;;}}} - -;;{{{ most of the HTML tags - -;; These tags are an attempt to be HTML/2.0 compliant, with the exception -;; of container

    ,

  • ,
    ,
    (we adopt 3.0 behaviour). -;; For reference see - -;; order here is significant: within a tag type, menus and mode help -;; go in the reverse order of what you see here. Sorry about that, it's -;; not easy to fix. - -(mapcar - 'html-helper-add-tag - '( - ;;entities - (entity "\C-c#" "&#" "Ascii Code" ("&#" (r "Ascii: ") ";")) - (entity "\C-c\"" """ "Quotation mark" (""")) - (entity "\C-c$" "®" "Registered" ("®")) - (entity "\C-c@" "©" "Copyright" ("©")) - (entity "\C-c-" "­" "Soft Hyphen" ("­")) - (entity "\C-c " " " "Nonbreaking Space" (" ")) - (entity "\C-c&" "&" "Ampersand" ("&")) - (entity "\C-c>" ">" "Greater Than" (">")) - (entity "\C-c<" "<" "Less Than" ("<")) - - ;; logical styles - (logical "q" "
    " "Blockquote" ("
    " (r "Quote: ") "
    ")) - (logical "c" "" "Code" ("" (r "Code: ") "")) - (logical "x" "" "Sample" ("" (r "Sample code") "")) - (logical "r" "" "Citation" ("" (r "Citation: ") "")) - (logical "k" "" "Keyboard Input" ("" (r "Keyboard: ") "")) - (logical "v" "" "Variable" ("" (r "Variable: ") "")) - (logical "d" "" "Definition" ("" (r "Definition: ") "")) - (logical "a" "
    " "Address" ("
    " r "
    ")) - (logical "e" "" "Emphasized" ("" (r "Text: ") "")) - (logical "s" "" "Strong" ("" (r "Text: ") "")) - (logical "p" "
    "		"Preformatted"   	  ("
    " (r "Text: ") "
    ")) - - ;;physical styles - (phys "-" "" "Strikethru" ("" (r "Text: ") "")) - (phys "u" "" "Underline" ("" (r "Text: ") "")) - (phys "o" "" "Italic" ("" (r "Text: ") "")) - (phys "b" "" "Bold" ("" (r "Text: ") "")) - (phys "t" "" "Fixed" ("" (r "Text: ") "")) - - ;;headers - (header "6" "
    " "Header 6" ("
    " (r "Header: ") "
    ")) - (header "5" "
    " "Header 5" ("
    " (r "Header: ") "
    ")) - (header "4" "

    " "Header 4" ("

    " (r "Header: ") "

    ")) - (header "3" "

    " "Header 3" ("

    " (r "Header: ") "

    ")) - (header "2" "

    " "Header 2" ("

    " (r "Header: ") "

    ")) - (header "1" "

    " "Header 1" ("

    " (r "Header: ") "

    ")) - - ;; forms - (form "o" "
    " > (r "Definition: "))) - (list "l" "
  • " "List Item" (& "
  • " > (r "Item: "))) - (list "r" "" "DirectoryList" (& "" > "\n
  • " > (r "Item: ") "\n
  • " >)) - (list "m" "
    " "Menu List" (& "" > "\n
  • " > (r "Item: ") "\n
  • " >)) - (list "o" "
      " "Ordered List" (& "
        " > "\n
      1. " > (r "Item: ") "\n
      " >)) - (list "d" "
      " "Definition List" (& "
      " > "\n
      " > (p "Term: ") "\n
      " > (r "Definition: ") "\n
      " >)) - (list "u" "
        " "Unordered List" (& "
          " > "\n
        • " > (r "Item: ") "\n
        " >)) - - ;;anchors - (anchor "n" "" (r "Anchor text: ") "")) - (anchor "h" "" (r "Anchor text: ") "")) - - ;;graphics - (image "a" nil "Aligned Image" ("")) - (image "i" "")) - (image "e" "\""")) - (image "t" "	")) - - ;;text elements - (textel "\C-c=" nil "Horizontal Line" (& "
        \n")) - (textel "\C-c\C-m" nil "Line Break" ("
        \n")) - (textel "\e\C-m" nil "Paragraph" ("

        " (progn (sgml-indent-line) nil) "\n")) - - ;;head elements - (head "H" "" "Head" ("\n" "\n")) - (head "B" "" "Body" ("\n" "\n")) - (head "i" "" "Isindex" ("\n")) - (head "n" "" "Nextid" ("\n")) - (head "h" "\n")) - (head "m" "\n")) - (head "l" "")) - (head "b" "")) - (head "t" "" "Title" ("<title>" (r "Document title: ") "")) - )) - -;;}}} -;;{{{ html-helper-smart-insert-item - -;; there are two different kinds of items in HTML - those in regular -;; lists

      • and those in dictionaries
        ..
        -;; This command will insert the appropriate one depending on context. - -(defun html-helper-smart-insert-item (&optional arg) - "Insert a new item, either in a regular list or a dictionary." - (interactive "*P") - (let ((case-fold-search t)) - (if - (save-excursion - (re-search-backward "
      • \\|
        \\|
          \\|
            \\|
            \\|\\|\\|
            " nil t) - (looking-at "
            \\|
            \\|
            ")) - (tempo-template-html-definition-item arg) - (tempo-template-html-list-item arg)))) - -;; special keybindings in the prefix maps (not in the list of tags) -(and (boundp 'html-helper-base-map) - (define-key html-helper-base-map "i" 'html-helper-smart-insert-item)) - -(define-key html-mode-map "\C-z\C-z" 'suspend-or-iconify-emacs) -(define-key html-mode-map "\C-zg" 'html-insert-mailto-reference-from-click) - -;; and, special menu bindings -(and (boundp 'html-helper-list-menu) - (setq html-helper-list-menu - (cons '["List Item" html-helper-smart-insert-item t] html-helper-list-menu))) - -;;}}} -;;{{{ patterns for font-lock - -; Old patterns from html-mode.el -;(defvar html-font-lock-keywords -; (list -; '("\\(<[^>]*>\\)+" . font-lock-comment-face) -; '("[Hh][Rr][Ee][Ff]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t) -; '("[Ss][Rr][Cc]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t)) -; "Patterns to highlight in HTML buffers.") - -;; By Ulrik Dickow . -;; -;; Originally aimed at Emacs 19.29. Later on disabled syntactic fontification -;; and reordered regexps completely, to be compatible with XEmacs (it doesn't -;; understand OVERRIDE=`keep'). -;; -;; We make an effort on handling nested tags intelligently. - -;; font-lock compatibility with XEmacs/Lucid and older Emacsen (<19.29). -;; -(if (string-match "XEmacs\\|Lucid" (emacs-version)) - ;; XEmacs/Lucid - ;; Make needed faces if the user hasn't already done so. - ;; Respect X resources (`make-face' uses them when they exist). - (let ((change-it - (function (lambda (face) - (or (if (fboundp 'facep) - (facep face) - (memq face (face-list))) - (make-face face)) - (not (face-differs-from-default-p face)))))) - (if (funcall change-it 'html-helper-bold-face) - (copy-face 'bold 'html-helper-bold-face)) - (if (funcall change-it 'html-helper-italic-face) - (copy-face 'italic 'html-helper-italic-face)) - (if (funcall change-it 'html-helper-underline-face) - (set-face-underline-p 'html-helper-underline-face t)) - (if (funcall change-it 'font-lock-variable-name-face) - (set-face-foreground 'font-lock-variable-name-face "salmon")) - (if (funcall change-it 'font-lock-reference-face) - (set-face-foreground 'font-lock-reference-face "violet"))) - ;; Emacs (any version) - ;; - ;; Note that Emacs evaluates the face entries in `font-lock-keywords', - ;; while XEmacs doesn't. So XEmacs doesn't use the following *variables*, - ;; but instead the faces with the same names as the variables. - (defvar html-helper-bold-face 'bold - "Face used as bold. Typically `bold'.") - (defvar html-helper-italic-face 'italic - "Face used as italic. Typically `italic'.") - (defvar html-helper-underline-face 'underline - "Face used as underline. Typically `underline'.") - ;; - (if (string-lessp "19.28.89" emacs-version) - () ; Emacs 19.29 and later - ;; Emacs 19.28 and older - ;; Define face variables that don't exist until Emacs 19.29. - (defvar font-lock-variable-name-face 'font-lock-doc-string-face - "Face to use for variable names -- and some HTML keywords.") - (defvar font-lock-reference-face 'underline ; Ugly at line breaks - "Face to use for references -- including HTML hyperlink texts."))) - -(defvar html-font-lock-keywords - (let (;; Titles and H1's, like function defs. - ;; We allow for HTML 3.0 attributes, like `

            '. - (tword "\\(h1\\|title\\)\\([ \t\n]+[^>]+\\)?") - ;; Names of tags to boldify. - (bword "\\(b\\|h[2-4]\\|strong\\)\\([ \t\n]+[^>]+\\)?") - ;; Names of tags to italify. - (iword "\\(address\\|cite\\|em\\|i\\|var\\)\\([ \t\n]+[^>]+\\)?") - ;; Regexp to match shortest sequence that surely isn't a bold end. - ;; We simplify a bit by extending "" to "]\\|" - "h\\([^2-4]\\|[2-4][^>]\\)\\|" - "s\\([^t]\\|t[^r]\\)\\)\\)\\)")) - (not-iend (concat "\\([^<]\\|<\\([^/]\\|/\\([^aceiv]\\|" - "a\\([^d]\\|d[^d]\\)\\|" - "c\\([^i]\\|i[^t]\\)\\|" - "e\\([^m]\\|m[^>]\\)\\|" - "i[^>]\\|" - "v\\([^a]\\|a[^r]\\)\\)\\)\\)")) - (not-tend (concat "\\([^<]\\|<\\([^/]\\|/\\([^ht]\\|" - "h[^1]\\|t\\([^i]\\|i[^t]\\)\\)\\)\\)"))) - (list ; Avoid use of `keep', since XEmacs will treat it the same as `t'. - ;; First fontify the text of a HREF anchor. It may be overridden later. - ;; Anchors in headings will be made bold, for instance. - '("]*>\\([^>]+\\)" - 1 font-lock-reference-face t) - ;; Tag pairs like ... etc. - ;; Cunning repeated fontification to handle common cases of overlap. - ;; Bold complex --- possibly with arbitrary other non-bold stuff inside. - (list (concat "<" bword ">\\(" not-bend "*\\)") - 3 'html-helper-bold-face t) - ;; Italic complex --- possibly with arbitrary non-italic kept inside. - (list (concat "<" iword ">\\(" not-iend "*\\)") - 3 'html-helper-italic-face t) - ;; Bold simple --- first fontify bold regions with no tags inside. - (list (concat "<" bword ">\\(" "[^<]" "*\\)") - 3 'html-helper-bold-face t) - ;; Any tag, general rule, just after bold/italic stuff. - '("\\(<[^>]*>\\)" 1 font-lock-type-face t) - ;; Titles and level 1 headings (anchors do sometimes appear in h1's) - (list (concat "<" tword ">\\(" not-tend "*\\)") - 3 'font-lock-function-name-face t) - ;; Underline is rarely used. Only handle it when no tags inside. - '("\\([^<]*\\)" 1 html-helper-underline-face t) - ;; Forms, anchors & images (also fontify strings inside) - '("\\(<\\(form\\|i\\(mg\\|nput\\)\\)\\>[^>]*>\\)" - 1 font-lock-variable-name-face t) - '("" 0 font-lock-keyword-face t) - '("\\(]*>\\)" 1 font-lock-keyword-face t) - '("=[ \t\n]*\\(\"[^\"]+\"\\)" 1 font-lock-string-face t) - ;; Large-scale structure keywords (like "program" in Fortran). - ;; "" "" "" "" "" "" "" - '("" - 0 font-lock-variable-name-face t) - ;; HTML special characters - '("&[^;\n]*;" 0 font-lock-string-face t) - ;; SGML things like with possible inside. - '("\\([^<>]*\\(<[^>]*>[^<>]*\\)*>\\)" - 1 font-lock-comment-face t) - ;; Comments: . They traditionally override anything else. - ;; It's complicated 'cause we won't allow "-->" inside a comment, and - ;; font-lock colours the *longest* possible match of the regexp. - '("\\(\\)" - 1 font-lock-comment-face t))) - "Additional expressions to highlight in HTML mode.") - -(put 'html-mode 'font-lock-defaults '(html-font-lock-keywords)) -(put 'html3-mode 'font-lock-defaults '(html-font-lock-keywords)) - -;;}}} - -;;{{{ patterns for hilit19 - -;; Define some useful highlighting patterns for the hilit19 package. -;; These will activate only if hilit19 has already been loaded. -;; Thanks to for some pattern suggestions - -(if (featurep 'hilit19) - (hilit-set-mode-patterns - 'html-helper-mode - '(("" comment) - ("[^<>]*\\(<[^>]*>[^<>]*\\)*>" nil comment) ; - ("" "" defun) - ("" "" bold) ;only colour inside tag - ("" define) - ("" nil define) - ("" include) - ("" include) - ;; First highlighting just handles unnested tags, then do nesting - ("[^<]*" nil italic) - ("" "" bold) - ("" "" italic) - ("" "" underline) - ("&[^;\n]*;" nil string) - ("<" ">" keyword)) - nil 'case-insensitive) - nil) - -;;}}} - -;;{{{ timestamps - -(defun html-helper-update-timestamp () - "Basic function for updating timestamps. -It finds the timestamp in the buffer by looking for -`html-helper-timestamp-start', deletes all text up to -`html-helper-timestamp-end', and runs `html-helper-timestamp-hook' which -will should insert an appropriate timestamp in the buffer." - (save-excursion - (goto-char (point-max)) - (if (not (search-backward html-helper-timestamp-start nil t)) - (message "timestamp delimiter start was not found") - (let ((ts-start (+ (point) (length html-helper-timestamp-start))) - (ts-end (if (search-forward html-helper-timestamp-end nil t) - (- (point) (length html-helper-timestamp-end)) - nil))) - (if (not ts-end) - (message "timestamp delimiter end was not found. Type C-c C-t to insert one.") - (delete-region ts-start ts-end) - (goto-char ts-start) - (run-hooks 'html-helper-timestamp-hook))))) - nil) - -(defun html-helper-return-created-string () - "Return a \"Created:\" string." - (let ((time (current-time-string))) - (concat "\n"))) - -(defun html-helper-default-insert-timestamp () - "Default timestamp insertion function." - (let ((time (current-time-string))) - (insert "Last modified: " - (substring time 0 20) - (nth 1 (current-time-zone)) - " " - (substring time -4) - "\n"))) - -(defun html-helper-insert-timestamp-delimiter-at-point () - "Simple function that inserts timestamp delimiters at point. -Useful for adding timestamps to existing buffers." - (interactive) - (insert html-helper-timestamp-start) - (insert html-helper-timestamp-end)) - -;;}}} - -(defun mail-address-at-point (pos &optional buffer) - "Return a list (NAME ADDRESS) of the address at POS in BUFFER." - (or buffer (setq buffer (current-buffer))) - (let (beg end) - (save-excursion - (set-buffer buffer) - (save-excursion - (goto-char pos) - (or (re-search-forward "[\n,]" nil t) - (error "Can't find address at position")) - (backward-char) - (setq end (point)) - (or (re-search-backward "[\n,:]" nil t) - (error "Can't find address at position")) - (forward-char) - (re-search-forward "[ \t]*" nil t) - (setq beg (point)) - (mail-extract-address-components (buffer-substring beg end)))))) - -(defun html-insert-mailto-reference-from-click () - "Insert a mailto: reference for the clicked-on e-mail address." - (interactive) - (let (event) - (message "Click on a mail address:") - (save-excursion - (setq event (next-command-event)) - (or (mouse-event-p event) - (error "Aborted."))) - (let ((lis (mail-address-at-point (event-closest-point event) - (event-buffer event)))) - (insert "" - (or (car lis) (car (cdr lis))) "")))) - -(defun html-quote-region (begin end) - "\"Quote\" any characters in the region that have special HTML meanings. -This converts <'s, >'s, and &'s into the HTML commands necessary to -get those characters to appear literally in the output." - (interactive "r") - (save-excursion - (goto-char begin) - (while (search-forward "&" end t) - (forward-char -1) - (delete-char 1) - (insert "&") - (setq end (+ 4 end))) - (goto-char begin) - (while (search-forward "<" end t) - (forward-char -1) - (delete-char 1) - (insert "<") - (setq end (+ 3 end))) - (goto-char begin) - (while (search-forward ">" end t) - (forward-char -1) - (delete-char 1) - (insert ">") - (setq end (+ 3 end))))) - -;;{{{ html-helper-insert-new-buffer-strings - -(tempo-define-template "html-skeleton" html-helper-new-buffer-template - nil - "Insert a skeleton for a HTML document") - -(defun html-helper-insert-new-buffer-strings () - "Insert `html-helper-new-buffer-strings'." - (tempo-template-html-skeleton)) - -;;}}} - -;;;###autoload -(autoload 'html-mode "psgml-html" "HTML mode." t) - -;;;###autoload -(autoload 'html3-mode "psgml-html" "HTML3 mode." t) - -(defvar sgml-html-menu - (cons "HTML" - (append '(["View in Netscape" sgml-html-netscape-file - (buffer-file-name - (current-buffer))] - ["View in W3" w3-preview-this-buffer t] - "---" - ["HTML-Quote Region" html-quote-region t] - "---") - (cdr sgml-main-menu)))) - -(defun sgml-html-netscape-file () - "Preview the file for the current buffer in Netscape." - (interactive) - (highlight-headers-follow-url-netscape - (concat "file:" (buffer-file-name (current-buffer))))) - -(define-derived-mode html3-mode html-mode "HTML3" - (setq sgml-declaration (expand-file-name "html3.decl" - sgml-data-directory) - sgml-default-doctype-name "html-3" - sgml-shortag nil )) - diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-info.el --- a/lisp/psgml/psgml-info.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,413 +0,0 @@ -;;;; psgml-info.el -;;; Last edited: Wed Mar 20 21:24:16 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin) -;;; $Id: psgml-info.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ - -;; Copyright (C) 1994, 1995 Lennart Staflin - -;; Author: Lennart Staflin - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; This file is an addon to the PSGML package. - -;; This file contains some commands to print out information about the -;; current DTD. - -;; sgml-list-elements -;; Will list all elements and the attributes declared for the element. - -;; sgml-list-attributes -;; Will list all attributes declared and the elements that use them. - -;; sgml-list-terminals -;; Will list all elements that can contain data. - -;; sgml-list-occur-in-elements -;; Will list all element types and where it can occur. - -;; sgml-list-content-elements -;; Will list all element types and the element types that can occur -;; in its content. - -;;;; Code: - -(require 'psgml) -(require 'psgml-parse) - -(defconst sgml-attr-col 18) - - -;;;; Utility functions - -(defsubst sgml-add-to-table (row-index elem table) - (let ((p (assoc row-index table))) - (cond ((null p) - (cons (list row-index elem) table)) - (t - (nconc p (list elem)) - table)))) - -(defsubst sgml-add-last-unique (x l) - (unless (memq x l) - (nconc l (list x)))) - -(defun sgml-map-element-types (func) - (sgml-need-dtd) - (sgml-map-eltypes func - (sgml-pstate-dtd sgml-buffer-parse-state) - t)) - -(defun sgml-eltype-refrenced-elements (eltype) - "List of element types referenced in the model of ELTYPE." - ;; Now with cache. Uses appdata prop re-cache. - (or - (sgml-eltype-appdata eltype 're-cache) - (let* ((res ; result list (eltypes) - nil) - (states ; list of states - (list (sgml-eltype-model eltype))) - (agenda ; point into states - states)) - (cond - ((not (sgml-model-group-p (car states))) - nil) - (t - (while agenda - (cond - ((sgml-normal-state-p (car agenda)) - (loop for m in (append (sgml-state-opts (car agenda)) - (sgml-state-reqs (car agenda))) - do - (pushnew (sgml-move-token m) res) - (sgml-add-last-unique (sgml-move-dest m) states))) - - (t ; &-node - (sgml-add-last-unique (sgml-and-node-next (car agenda)) states) - (loop for dfa in (sgml-and-node-dfas (car agenda)) do - (sgml-add-last-unique dfa states)))) - (setq agenda (cdr agenda))) - (setq res (sort (set-difference - (union res (sgml-eltype-includes eltype)) - (sgml-eltype-excludes eltype)) - (function string-lessp))) - (setf (sgml-eltype-appdata eltype 're-cache) res) - res))))) - - -;;;; List elements - -(defun sgml-list-elements () - "List the elements and their attributes in the current DTD." - (interactive) - (message "Creating table...") - (sgml-display-table - (sgml-map-element-types - (function - (lambda (eltype) - (cons (sgml-eltype-name eltype) - (mapcar (function sgml-attdecl-name) - (sgml-eltype-attlist eltype)))))) - "Elements" "Element" "Attribute")) - - -;;;; List attributes - -(defun sgml-list-attributes () - "List the attributes and in which elements they occur." - (interactive) - (let ((attributes nil)) - (message "Creating table...") - (sgml-map-element-types - (function - (lambda (eltype) - (loop for a in (sgml-eltype-attlist eltype) do - (setq attributes - (sgml-add-to-table (sgml-attdecl-name a) - (sgml-eltype-name eltype) - attributes)))))) - (sgml-display-table attributes - "Attributes" "Attribute" "Element"))) - - - - -;;;; List terminals - -(defun sgml-list-terminals () - "List the elements that can have data in their content." - (interactive) - (message "Creating table...") - (let ((data-models (list sgml-cdata sgml-rcdata sgml-any))) - (sgml-display-table - (delq nil - (sgml-map-element-types - (function - (lambda (eltype) - (if (or (sgml-eltype-mixed eltype) - (memq (sgml-eltype-model eltype) data-models)) - (list (sgml-eltype-name eltype) - (symbol-name - (if (sgml-model-group-p (sgml-eltype-model eltype)) - 'mixed - (sgml-eltype-model eltype))))))))) - "Terminals" "Element" "Content"))) - - -;;;; Element cross reference list - -(defun sgml-list-content-elements () - "List all element types and the element types that can occur in its content." - (interactive) - (message "Creating table...") - (sgml-display-table - (sgml-map-element-types - (function - (lambda (eltype) - (cons (sgml-eltype-name eltype) - (mapcar (function sgml-eltype-name) - (sgml-eltype-refrenced-elements eltype)))))) - "Elements refrenced by elements" - "Element" "Content")) - -(defun sgml-list-occur-in-elements () - "List all element types and where it can occur." - (interactive) - (message "Creating table...") - (let ((cross nil)) - (sgml-map-element-types - (function - (lambda (eltype) - (loop for ref in (sgml-eltype-refrenced-elements eltype) - do (setq cross (sgml-add-to-table ref - (sgml-eltype-name eltype) - cross)))))) - (sgml-display-table - cross - "Cross referenced element types" "Element" "Can occur in"))) - - -;;;; Display table - -(defun sgml-display-table (table title col-title1 col-title2 - &optional width nosort) - (or width - (setq width sgml-attr-col)) - (let ((buf (get-buffer-create (format "*%s*" title)))) - (message "Preparing display...") - (set-buffer buf) - (erase-buffer) - (insert col-title1) - (indent-to width) - (insert col-title2 "\n") - (insert-char ?= (length col-title1)) - (indent-to width) - (insert-char ?= (length col-title2)) - (insert "\n") - (unless nosort - (setq table (sort table (function (lambda (a b) - (string< (car a) (car b))))))) - (loop for e in table do - (insert (format "%s" (car e))) - (loop for name in (if nosort - (cdr e) - (sort (cdr e) (function string-lessp))) - do - (when (> (+ (length name) (current-column)) - fill-column) - (insert "\n")) - (when (< (current-column) sgml-attr-col) - (indent-to width)) - (insert name " ")) - (insert "\n")) - (goto-char (point-min)) - (display-buffer buf) - (message nil))) - - -;;;; Describe entity - -(defun sgml-describe-entity (name) - "Describe the properties of an entity as declared in the current DTD." - (interactive - (let (default input) - (sgml-need-dtd) - (save-excursion - (sgml-with-parser-syntax - (unless (sgml-parse-delim "ERO") - (skip-chars-backward "^&\"'= \t\n")) - (setq default (or (sgml-parse-name t) "")))) - (setq input (completing-read - (format "Entity name (%s): " default) - (sgml-entity-completion-table - (sgml-dtd-entities - (sgml-pstate-dtd sgml-buffer-parse-state))))) - (list - (if (equal "" input) default input)))) - - (with-output-to-temp-buffer "*Help*" - (let ((entity (sgml-lookup-entity name - (sgml-dtd-entities - (sgml-pstate-dtd - sgml-buffer-parse-state))))) - (or entity (error "Undefined entity")) - (princ (format "Entity %s is %s\n" - name - (cond ((null entity) - "undefined") - (t - (format "a %s entity" - (sgml-entity-type entity)))))) - (when entity - (let ((text (sgml-entity-text entity))) - (cond ((stringp text) - (princ "Defined to be:\n") - (princ text)) - (t - (princ "With external identifier ") - (princ (if (car text) "PUBLIC" "SYSTEM")) - (when (car text) - (princ (format " '%s'" (car text)))) - (when (cdr text) - (princ (format " '%s'" (cdr text))))))))))) - - - -;;;; Describe element type - -(defun sgml-describe-element-type (et-name) - "Describe the properties of an element type as declared in the current DTD." - (interactive - (let (default input) - (sgml-need-dtd) - (save-excursion - (sgml-with-parser-syntax - (unless (sgml-parse-delim "STAGO") - (skip-syntax-backward "w_")) - (setq default (sgml-parse-name)) - (unless (and default - (sgml-eltype-defined (sgml-lookup-eltype default))) - (setq default nil)))) - (setq input (sgml-read-element-type (if default - (format "Element type (%s): " - default) - "Element type: ") - sgml-dtd-info - default)) - - (list - (sgml-eltype-name input)))) - - (sgml-need-dtd) - (let ((et (sgml-lookup-eltype et-name))) - (with-output-to-temp-buffer "*Help*" - (princ (format "ELEMENT: %s\n\n" (sgml-eltype-name et))) - (princ (format " Start-tag is %s.\n End-tag is %s.\n" - (if (sgml-eltype-stag-optional et) - "optional" "required") - (if (sgml-eltype-etag-optional et) - "optional" "required"))) - (princ "\nATTRIBUTES:\n") - (loop for attdecl in (sgml-eltype-attlist et) do - (let ((name (sgml-attdecl-name attdecl)) - (dval (sgml-attdecl-declared-value attdecl)) - (defl (sgml-attdecl-default-value attdecl))) - (when (listp dval) - (setq dval (concat (if (eq (first dval) - 'notation) - "#NOTATION (" "(") - (mapconcat (function identity) - (second dval) - "|") - ")"))) - (cond ((sgml-default-value-type-p 'fixed defl) - (setq defl (format "#FIXED '%s'" - (sgml-default-value-attval defl)))) - ((symbolp defl) - (setq defl (upcase (format "#%s" defl)))) - (t - (setq defl (format "'%s'" - (sgml-default-value-attval defl))))) - (princ (format " %-9s %-30s %s\n" name dval defl)))) - ;; ---- - (let ((s (sgml-eltype-shortmap et))) - (when s - (princ (format "\nUSEMAP: %s\n" s)))) - ;; ---- - (princ "\nOCCURS IN:\n\n") - (let ((occurs-in ())) - (sgml-map-eltypes - (function (lambda (cand) - (when (memq et (sgml-eltype-refrenced-elements cand)) - (push cand occurs-in)))) - (sgml-pstate-dtd sgml-buffer-parse-state)) - - (loop with col = 0 - for occur-et in (sort occurs-in (function string-lessp)) - for name = (sgml-eltype-name occur-et) - do - (when (and (> col 0) (> (+ col (length name) 1) fill-column)) - (princ "\n") - (setq col 0)) - (princ " ") (princ name) - (incf col (length name)) - (incf col 1)))))) - - -;;;; Print general info about the DTD. - -(defun sgml-general-dtd-info () - "Display information about the current DTD." - (interactive) - (sgml-need-dtd) - (let ((elements 0) - (entities 0) - (parameters 0) - (fmt "%20s %s\n") - (hdr "") - ) - (sgml-map-eltypes (function (lambda (e) (incf elements))) - sgml-dtd-info) - (sgml-map-entities (function (lambda (e) (incf entities))) - (sgml-dtd-entities sgml-dtd-info)) - (sgml-map-entities (function (lambda (e) (incf parameters))) - (sgml-dtd-parameters sgml-dtd-info)) - - (with-output-to-temp-buffer "*Help*" - (princ (format fmt "Doctype:" (sgml-dtd-doctype sgml-dtd-info))) - (when (sgml-dtd-merged sgml-dtd-info) - (princ (format fmt "Compiled DTD:" - (car (sgml-dtd-merged sgml-dtd-info))))) - (princ (format fmt "Element types:" (format "%d" elements))) - (princ (format fmt "Entities:" (format "%d" entities))) - (princ (format fmt "Parameter entities:" (format "%d" parameters))) - - (setq hdr "Files used:") - (loop for x in (sgml-dtd-dependencies sgml-dtd-info) - if (stringp x) - do (princ (format fmt hdr x)) - (setq hdr "")) - - (setq hdr "Undef parameters:") - (sgml-map-entities - (function (lambda (entity) - (when (sgml-entity-marked-undefined-p entity) - (princ (format fmt hdr (sgml-entity-name entity))) - (setq hdr "")))) - (sgml-dtd-parameters sgml-dtd-info))))) - -;;; psgml-info.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-other.el --- a/lisp/psgml/psgml-other.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,183 +0,0 @@ -;;;; psgml-other.el --- Part of SGML-editing mode with parsing support -;; $Id: psgml-other.el,v 1.3 1997/03/08 23:26:53 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin - -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;;; Part of psgml.el. Code not compatible with XEmacs. - - -;;;; Code: - -(require 'psgml) -(require 'easymenu) - -(defvar sgml-max-menu-size (/ (* (frame-height) 2) 3) - "*Max number of entries in Tags and Entities menus before they are split -into several panes.") - - -;;;; Key Commands - -;; Doesn't this work in Lucid? *** -(define-key sgml-mode-map [(meta control space)] 'sgml-mark-element) - -(define-key sgml-mode-map [(shift button-3)] 'sgml-tags-menu) - - -;;;; Pop Up Menus - -(defun sgml-popup-menu (event title entries) - "Display a popup menu. -ENTRIES is a list where every element has the form (STRING . VALUE) or -STRING." - (x-popup-menu - event - (let ((menus (list (cons title entries)))) - (cond - ((> (length entries) sgml-max-menu-size) - (setq menus - (loop for i from 1 while entries - collect - (let ((submenu - (subseq entries 0 (min (length entries) - sgml-max-menu-size)))) - (setq entries (nthcdr sgml-max-menu-size entries)) - (cons - (format "%s '%s'-'%s'" - title - (sgml-range-indicator (caar submenu)) - (sgml-range-indicator (caar (last submenu)))) - submenu)))))) - (cons title menus)))) - -(defun sgml-range-indicator (string) - (substring string - 0 - (min (length string) sgml-range-indicator-max-length))) - -(defun sgml-popup-multi-menu (event title menus) - "Display a popup menu. -MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...). -ITEM should have to form (STRING EXPR) or STRING. The EXPR gets evaluated -if the item is selected." - (nconc menus '(("---" "---"))) ; Force x-popup-menu to use two level - ; menu even if there is only one entry - ; on the first level - (eval (car (x-popup-menu event (cons title menus))))) - - -;;;; Insert with properties - -(defvar sgml-write-protect-intagible - (not (boundp 'emacs-minor-version))) - -(defun sgml-insert (props format &rest args) - (let ((start (point))) - (insert (apply (function format) - format - args)) - (when (and sgml-write-protect-intagible - (getf props 'intangible)) - (setf (getf props 'read-only) t)) - (add-text-properties start (point) props))) - - -;;;; Set face of markup - -(defvar sgml-use-text-properties nil) - -(defun sgml-set-face-for (start end type) - (let ((face (cdr (assq type sgml-markup-faces)))) - (cond - (sgml-use-text-properties - (let ((inhibit-read-only t) - (after-change-function nil) ; obsolete variable - (before-change-function nil) ; obsolete variable - (after-change-functions nil) - (before-change-functions nil)) - (put-text-property start end 'face face))) - (t - (let ((current (overlays-at start)) - (pos start) - old-overlay) - (while current - (cond ((and (null old-overlay) - (eq type (overlay-get (car current) 'sgml-type))) - (setq old-overlay (car current))) - ((overlay-get (car current) 'sgml-type) - (message "delov: %s" (overlay-get (car current) 'sgml-type)) - (delete-overlay (car current)))) - (setq current (cdr current))) - (while (< (setq pos (next-overlay-change pos)) - end) - (setq current (overlays-at pos)) - (while current - (when (overlay-get (car current) 'sgml-type) - (delete-overlay (car current))) - (setq current (cdr current)))) - (cond (old-overlay - (move-overlay old-overlay start end) - (if (null (overlay-get old-overlay 'face)) - (overlay-put old-overlay 'face face))) - (face - (setq old-overlay (make-overlay start end)) - (overlay-put old-overlay 'sgml-type type) - (overlay-put old-overlay 'face face)))))))) - -(defun sgml-set-face-after-change (start end &optional pre-len) - ;; If inserting in front of an markup overlay, move that overlay. - ;; this avoids the overlay being deleted and recreated by - ;; sgml-set-face-for. - (when (and sgml-set-face (not sgml-use-text-properties)) - (loop for o in (overlays-at start) - do (cond - ((not (overlay-get o 'sgml-type))) - ((= start (overlay-start o)) - (move-overlay o end (overlay-end o))))))) - -(defun sgml-fix-overlay-after-change (overlay flag start end &optional size) - (message "sfix(%s): %d-%d (%s)" flag start end size) - (overlay-put overlay 'front-nonsticky t) - (when nil - (move-overlay overlay end (overlay-end overlay)))) - -(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el - -(defun sgml-clear-faces () - (interactive) - (loop for o being the overlays - if (overlay-get o 'sgml-type) - do (delete-overlay o))) - - -;;;; Emacs before 19.29 - -(unless (fboundp 'buffer-substring-no-properties) - (defalias 'buffer-substring-no-properties 'buffer-substring)) - - -;;;; Provide - -(provide 'psgml-other) - -;;; psgml-other.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-parse.el --- a/lisp/psgml/psgml-parse.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4273 +0,0 @@ -;;;; psgml-parse.el --- Parser for SGML-editing mode with parsing support -;; $Id: psgml-parse.el,v 1.8 1997/09/27 16:57:47 steve Exp $ - -;; Copyright (C) 1994, 1995 Lennart Staflin - -;; Author: Lennart Staflin -;; Acknowledgment: -;; The catalog parsing code was contributed by -;; David Megginson - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Part of major mode for editing the SGML document-markup language. - - -;;;; Code: - -(require 'psgml) - -;;; Interface to psgml-dtd -(eval-and-compile - (autoload 'sgml-do-usemap-element "psgml-dtd") - (autoload 'sgml-write-dtd "psgml-dtd") - (autoload 'sgml-check-dtd-subset "psgml-dtd") - ) - - -;;;; Advise to do-auto-fill - -(defvar sgml-auto-fill-inhibit-function nil - "If non-nil, it should be a function of no arguments. -The functions is evaluated before the standard auto-fill function, -do-auto-fill, tries to fill a line. If the function returns a true -value the auto-fill is inhibited.") - -;;(defadvice do-auto-fill (around disable-auto-fill-hook activate) -;; (or (and sgml-auto-fill-inhibit-function -;; (funcall sgml-auto-fill-inhibit-function)) -;; ad-do-it)) - - -;;;; Variables - -;;; Hooks - -(defvar sgml-open-element-hook nil - "The hook run by `sgml-open-element'. -Theses functions are called with two arguments, the first argument is -the opened element and the second argument is the attribute specification -list. It is probably best not to refer to the content or the end-tag of -the element.") - -(defvar sgml-close-element-hook nil - "The hook run by `sgml-close-element'. -These functions are invoked with `sgml-current-tree' bound to the -element just parsed.") - -(defvar sgml-doctype-parsed-hook nil - "This hook is caled after the doctype has been parsed. -It can be used to load any additional information into the DTD structure.") - -(defvar sgml-sysid-resolve-functions nil - "This variable should contain a list of functions. -Each function should take one argument, the system identifier of an entity. -If the function can handle that identifier, it should insert the text -of the entity into the current buffer at point and return t. If the -system identifier is not handled the function should return nil.") - -;;; Internal variables - -(defconst sgml-pcdata-token (intern "#PCDATA")) - -(defvar sgml-computed-map nil - "Internal representation of entity search map.") - -(defvar sgml-used-entity-map nil - "The value of `sgml-current-entity-map' used to compute the map in -`sgml-compute-map'.") - -(defvar sgml-last-element nil - "Used to keep information about position in element structure between -commands.") - -(defconst sgml-users-of-last-element - '(sgml-beginning-of-element - sgml-end-of-element - sgml-up-element - sgml-backward-up-element - sgml-backward-element - sgml-forward-element - sgml-down-element - sgml-show-context - sgml-next-data-field - ) - "List of commands that set the sgml-last-element variable.") - -(defvar sgml-parser-syntax nil - "Syntax table used during parsing.") - -(defvar sgml-ecat-assoc nil - "Assoc list caching parsed ecats.") - -(defvar sgml-catalog-assoc nil - "Assoc list caching parsed catalogs.") - - -;;; Variables dynamically bound to affect parsing - -(defvar sgml-throw-on-warning nil - "Set to a symbol other than nil to make sgml-log-warning throw to that symbol.") - -(defvar sgml-throw-on-error nil - "Set to a symbol other than nil to make sgml-error throw to that symbol.") - -(defvar sgml-show-warnings nil - "Set to t to show warnings.") - -(defvar sgml-close-element-trap nil - "Can be nil for no trap, an element or t for any element. -Tested by sgml-close-element to see if the parse should be ended.") - -(defvar sgml-goal 0 - "Point in buffer to parse up to.") - -(defvar sgml-shortref-handler (function sgml-handle-shortref) - "Function called by parser to handle a short reference. -Called with the entity as argument. The start and end of the -short reference is `sgml-markup-start' and point.") - -(defvar sgml-data-function nil - "Function called with parsed data.") - -(defvar sgml-entity-function nil - "Function called with entity referenced at current point in parse.") - -(defvar sgml-pi-function nil - "Function called with parsed process instruction.") - -(defvar sgml-signal-data-function nil - "Called when some data characters are conceptually parsed, -e.g. a data entity reference.") - -(defvar sgml-throw-on-element-change nil - "Throw tag.") - -;;; Global variables active during parsing - -(defvar sgml-parsing-dtd nil - "This variable is bound to `t' while parsing a DTD (subset).") - -(defvar sgml-rs-ignore-pos nil - "Set to position of last parsing start in current buffer.") -(make-variable-buffer-local 'sgml-rs-ignore-pos) - -(defvar sgml-dtd-info nil - "Holds the `sgml-dtd' structure describing the current DTD.") - -(defvar sgml-current-omittag nil - "Value of `sgml-omittag' in main buffer. Valid during parsing.") - -(defvar sgml-current-shorttag nil - "Value of `sgml-shorttag' in main buffer. Valid during parsing.") - -(defvar sgml-current-localcat nil - "Value of `sgml-local-catalogs' in main buffer. Valid during parsing.") - -(defvar sgml-current-local-ecat nil - "Value of `sgml-local-ecat-files' in main buffer. Valid during parsing.") - -(defvar sgml-current-top-buffer nil - "The buffer of the document entity, the main buffer. -Valid during parsing. This is used to find current directory for -catalogs.") - -(defvar sgml-current-state nil - "Current state in content model or model type if CDATA, RCDATA or ANY.") - -(defvar sgml-current-shortmap nil - "The current active short reference map.") - -(defvar sgml-current-tree nil - "Current parse tree node, identifies open element.") - -(defvar sgml-previous-tree nil - "Previous tree node in current tree. -This is nil if no previous node.") - -(defvar sgml-markup-type nil -"Contains the type of markup parsed last. -The value is a symbol: -nil - pcdata or space -CDATA - CDATA or RCDATA -comment - comment declaration -doctype - doctype declaration -end-tag -ignored - ignored marked section -ms-end - marked section start, if not ignored -ms-start - marked section end, if not ignored -pi - processing instruction -sgml - SGML declaration -start-tag -entity - general entity reference -param - parameter reference -shortref- short reference -mdecl - markup declaration -") - -(defvar sgml-top-tree nil - "Root node of parse tree during parsing.") - -(defvar sgml-markup-tree nil - "Tree node of markup parsed. -In case markup closed element this is different from sgml-current-tree. -Only valid after `sgml-parse-to'.") - -(defvar sgml-markup-start nil - "Start point of markup being parsed.") - -(defvar sgml-conref-flag nil - "This variable is set by `sgml-parse-attribute-specification-list' -if a CONREF attribute is parsed.") - -(defvar sgml-no-elements nil - "Number of declared elements.") - -;;; Vars used in *param* buffers - -(defvar sgml-previous-buffer nil) - -(defvar sgml-current-eref nil - "This is the entity reference used to enter current entity. -If this is nil, then current entity is main buffer.") - -(defvar sgml-scratch-buffer nil - "The global value of this variable is the first scratch buffer for -entities. The entity buffers can have a buffer local value for this variable -to point to the next scratch buffer.") - -(defvar sgml-last-entity-buffer nil) - -;;; For loading DTD - -(eval-and-compile - (defconst sgml-max-single-octet-number 250 - "Octets greater than this is the first of a two octet coding.")) - -(defvar sgml-read-token-vector nil) ; Vector of symbols used to decode - ; token numbers. -(defvar sgml-read-nodes nil) ; Vector of nodes used when reading - ; a finite automaton. - -;; Buffer local variables - -(defvar sgml-loaded-dtd nil - "File name corresponding to current DTD.") -(make-variable-buffer-local 'sgml-loaded-dtd) - -(defvar sgml-current-element-name nil - "Name of current element for mode line display.") - - -;;;; Build parser syntax table - -(setq sgml-parser-syntax (make-syntax-table)) - -(let ((i 0)) - (while (< i 256) - (modify-syntax-entry i " " sgml-parser-syntax) - (setq i (1+ i)))) - -(mapconcat (function (lambda (c) - (modify-syntax-entry c "w" sgml-parser-syntax))) - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrtsuvwxyz" "") -(mapconcat (function (lambda (c) - (modify-syntax-entry c "_" sgml-parser-syntax))) - "-.0123456789" "") -(mapconcat (function (lambda (c) - (modify-syntax-entry c "." sgml-parser-syntax))) - "&%#[]" ".") - -;;(progn (set-syntax-table sgml-parser-syntax) (describe-syntax)) - - -(defmacro sgml-with-parser-syntax (&rest body) - (` (let ((normal-syntax-table (syntax-table))) - (set-syntax-table sgml-parser-syntax) - (unwind-protect - (progn (,@ body)) - (set-syntax-table normal-syntax-table))))) - - -;;;; State machine - -;; From the parsers POV a state is a mapping from tokens (in sgml it -;; is primitive state tokens) to states. The pairs of the mapping is -;; called moves. - -;; DFAs are always represented by the start state, which is a -;; normal state. Normal states contain moves of two types: -;; 1. moves for required tokens, 2. moves for optional tokens. -;; By design these are keept in two different sets. -;; [Alt: they could perhaps have been keept in one set but -;; marked in different ways.] - -;; The and-model groups creates too big state machines, therefor -;; there is a datastruture called and-node. - -;; A and-node is a specification for a dfa that has not been computed. -;; It contains a set of dfas that all have to be traversed befor going -;; to the next state. The and-nodes are only stored in moves and are -;; not seen by the parser. When a move is taken the and-node is converted -;; to a and-state. - -;; A and-state keeps track of which dfas still need to be -;; traversed and the state of the current dfa. - -;; move = - -;; node = normal-state | and-node - -;; and-node = -;; where: dfas is a set of normal-state -;; next is a normal-state - -;; State = normal-state | and-state -;; The parser only knows about the state type. - -;; normal-state = -;; where: opts is a set of moves for optional tokens -;; reqs is a set of moves for required tokens - -;; and-state = -;; where: substate is a normal-state -;; dfas is a set of states -;; next is the next state - -;; The and-state is only used during the parsing. -;; Primitiv functions to get data from parse state need -;; to know both normal-state and and-state. - - -;;; Representations: - -;;move: (token . node) - -(defmacro sgml-make-move (token node) - (` (cons (, token) (, node)))) - -(defmacro sgml-move-token (x) - (` (car (, x)))) - -(defmacro sgml-move-dest (x) - (` (cdr (, x)))) - -;; set of moves: list of moves - -(defmacro sgml-add-move-to-set (token node set) - (`(cons (cons (, token) (, node)) (, set)))) - -(defmacro sgml-moves-lookup (token set) - (` (assq (, token) (, set)))) - -;; normal-state: ('normal-state opts . reqs) - -(defsubst sgml-make-state () - (cons 'normal-state (cons nil nil))) - -(defmacro sgml-normal-state-p (s) - (` (eq (car (, s)) 'normal-state))) - -(defmacro sgml-state-opts (s) - (` (cadr (, s)))) - -(defmacro sgml-state-reqs (s) - (` (cddr (, s)))) - -(defmacro sgml-state-final-p (s) - (`(null (sgml-state-reqs (, s))))) - -;; adding moves -;; *** Should these functions check for ambiguity? -;; What if adding a optional move for a token that has a -;; required move? -;; What about the other way? - -(defsubst sgml-add-opt-move (s token dest) - (or (sgml-moves-lookup token (sgml-state-opts s)) - (setf (sgml-state-opts s) - (sgml-add-move-to-set token dest (sgml-state-opts s))))) - -(defsubst sgml-add-req-move (s token dest) - (or (sgml-moves-lookup token (sgml-state-reqs s)) - (setf (sgml-state-reqs s) - (sgml-add-move-to-set token dest (sgml-state-reqs s))))) - -(defsubst sgml-make-primitive-content-token (token) - (let ((s1 (sgml-make-state)) - (s2 (sgml-make-state))) - (sgml-add-req-move s1 token s2) - s1)) - -;;and-state: (state next . dfas) - -(defsubst sgml-make-and-state (state dfas next) - (cons state (cons next dfas))) - -(defsubst sgml-step-and-state (state and-state) - (cons state (cdr and-state))) - -(defsubst sgml-and-state-substate (s) - (car s)) - -(defsubst sgml-and-state-dfas (s) - (cddr s)) - -(defsubst sgml-and-state-next (s) - (cadr s)) - - -;;and-node: (next . dfas) - -(defsubst sgml-make-and-node (dfas next) - (cons next dfas)) - -(defmacro sgml-and-node-next (n) - (` (car (, n)))) - -(defmacro sgml-and-node-dfas (n) - (` (cdr (, n)))) - - -;;; Using states - -(defsubst sgml-final (state) - (if (sgml-normal-state-p state) - (sgml-state-final-p state) - (sgml-final-and state))) - -(defun sgml-final-and (state) - (and (sgml-final (sgml-and-state-substate state)) - (loop for s in (sgml-and-state-dfas state) - always (sgml-state-final-p s)) - (sgml-state-final-p (sgml-and-state-next state)))) - -;; get-move: State x Token --> State|nil - -(defsubst sgml-get-move (state token) - "Return a new state or nil, after traversing TOKEN from STATE." - (cond - ((sgml-normal-state-p state) - (let ((c (or (sgml-moves-lookup token (sgml-state-opts state)) - (sgml-moves-lookup token (sgml-state-reqs state))))) - (if c - (let ((dest (sgml-move-dest c))) - (if (sgml-normal-state-p dest) - dest - ;; dest is a and-node - (sgml-next-sub-and (sgml-and-node-dfas dest) - token - (sgml-and-node-next dest))))))) - (t ;state is a and-state - (sgml-get-and-move state token)))) - -(defun sgml-get-and-move (state token) - ;; state is a and-state - (let ((m (sgml-get-move (sgml-and-state-substate state) token))) - (cond (m (cons m (cdr state))) - ((sgml-final (sgml-and-state-substate state)) - (sgml-next-sub-and (sgml-and-state-dfas state) - token - (sgml-and-state-next state)))))) - -(defun sgml-next-sub-and (dfas token next) - "Compute the next state, choosing from DFAS and moving by TOKEN. -If this is not possible, but all DFAS are final, move by TOKEN in NEXT." - (let ((allfinal t) - (l dfas) - (res nil) - s1 s2) - (while (and l (not res)) - (setq s1 (car l) - allfinal (and allfinal (sgml-state-final-p s1)) - s2 (sgml-get-move s1 token) - res (and s2 (sgml-make-and-state s2 (remq s1 dfas) next)) - l (cdr l))) - (cond (res) - (allfinal (sgml-get-move next token))))) - -(defsubst sgml-tokens-of-moves (moves) - (mapcar (function (lambda (m) (sgml-move-token m))) - moves)) - -(defun sgml-required-tokens (state) - (if (sgml-normal-state-p state) - (sgml-tokens-of-moves (sgml-state-reqs state)) - (or (sgml-required-tokens (sgml-and-state-substate state)) - (loop for s in (sgml-and-state-dfas state) - nconc (sgml-tokens-of-moves (sgml-state-reqs s))) - (sgml-tokens-of-moves (sgml-state-reqs (sgml-and-state-next state)))))) - -(defun sgml-optional-tokens (state) - (if (sgml-normal-state-p state) - (sgml-tokens-of-moves (sgml-state-opts state)) - (nconc - (sgml-optional-tokens (sgml-and-state-substate state)) - (if (sgml-final (sgml-and-state-substate state)) - (loop for s in (sgml-and-state-dfas state) - nconc (sgml-tokens-of-moves (sgml-state-opts s)))) - (if (loop for s in (sgml-and-state-dfas state) - always (sgml-state-final-p s)) - (sgml-tokens-of-moves - (sgml-state-opts (sgml-and-state-next state))))))) - - -;;;; Attribute Types - -;;; Basic Types -;; name = string attribute names are lisp symbols -;; attval = string attribute values are lisp strings - -;;; Attribute Declaration Type -;; attdecl = - -;; This is the result of the ATTLIST declarations in the DTD. -;; All attribute declarations for an element is the elements -;; attlist. - -;;; Attribute Declaration Operations -;; sgml-make-attdecl: name declared-value default-value -> attdecl -;; sgml-attdecl-name: attdecl -> name -;; sgml-attdecl-declared-value: attdecl -> declared-value -;; sgml-attdecl-default-value: attdecl -> default-value - -;;; Attribute Declaration List Type -;; attlist = attdecl* - -;;; Attribute Declaration List Operations -;; sgml-lookup-attdecl: name x attlist -> attdecl - -;;; Declared Value Type -;; declared-value = (token-group | notation | simpel) -;; token-group = nametoken+ -;; notation = nametoken+ -;; simple = symbol lisp symbol corresponding to SGML type - -;;; Declared Value Operations -;; sgml-declared-value-token-group: declared-value -> list of symbols -;; sgml-declared-value-notation: declared-value -> list of symbols -;; (empty list if not token-group/notation) - -;;; Default Value Type -;; default-value = (required | implied | conref | specified ) -;; implied, conref = constant symbol -;; specified = (fixed | normal) -;; fixed, normal = attval - -;;; Default Value Operations -;; sgml-default-value-attval: default-value -> (attval | nil) -;; sgml-default-value-type-p: type x default-value -> cond - -;;; Attribute Specification Type -;; attspec = - -;; This is the result of parsing an attribute specification. - -;; sgml-make-attspec: name x attval -> attspec -;; sgml-attspec-name: attspec -> name -;; sgml-attspec-attval: attspec -> attval - - -;;; Attribute Specification List Type -;; asl = attspec* - -;; aka. attribute value list - - -;;; Code - -;;; attdecl representation = (name declared-value default-value) - -(defun sgml-make-attdecl (name dcl-value default-value) - (list name dcl-value default-value)) - -(defun sgml-attdecl-name (attdecl) - (car attdecl)) - -(defun sgml-attdecl-declared-value (attdecl) - "The declared value of ATTDECL. -It may be a symbol or (name-token-group (NAME1 ... NAMEn)) -or (notation (NOT1 ... NOTn))" - (cadr attdecl)) - -(defun sgml-attdecl-default-value (attdecl) - "The default value of ATTDECL. -The default value is either a symbol (required | implied | current | -conref) or a list with first element nil or symbol 'fixed' and second -element the value." - (caddr attdecl)) - - -;;; attlist representation = (attspec*) - -(defun sgml-lookup-attdecl (name attlist) - "Return the attribute declaration for NAME in ATTLIST." - (assoc name attlist)) - -(defun sgml-attribute-with-declared-value (attlist declared-value) - "Find the first attribute in ATTLIST that has DECLARED-VALUE." - (let ((found nil)) - (while (and attlist (not found)) - (when (equal declared-value - (sgml-attdecl-declared-value (car attlist))) - (setq found (car attlist))) - (setq attlist (cdr attlist))) - found)) - - -;;; declared-value representation -;; token-group = (name-token (symbol+)) -;; notation = (notation (symbol+)) -;; simple = symbol lisp symbol correspoinding to SGML type - -(defun sgml-make-declared-value (type &optional names) - "Make a declared-value of TYPE. -TYPE should be a symbol. If TYPE is name-token-group or notation -NAMES should be a list of symbols." - (if (consp names) - (list type names) - type)) - -(defun sgml-declared-value-token-group (declared-value) - "Return the name token group for the DECLARED-VALUE. -This applies to name token groups. For other declared values nil is -returned." - (and (consp declared-value) - (eq 'name-token-group (car declared-value)) - (cadr declared-value))) - -(defun sgml-declared-value-notation (declared-value) - "Return the list of notation names for the DECLARED-VALUE. -This applies to notation declared value. For other declared values -nil is returned." - (and (consp declared-value) - (eq 'notation (car declared-value)) - (cadr declared-value))) - -;;; default-value representation = symbol | ((nil | 'fixed) attval) - -(defun sgml-make-default-value (type &optional attval) - (if attval - (list type attval) - type)) - -(defun sgml-default-value-attval (default-value) - "Return the actual default value of the declared DEFAULT-VALUE. -The actual value is a string. Return nil if no actual value." - (and (consp default-value) - (cadr default-value))) - -(defun sgml-default-value-type-p (type default-value) - "Return true if DEFAULT-VALUE is of TYPE. -Where TYPE is a symbol, one of required, implied, conref, or fixed." - (or (eq type default-value) - (and (consp default-value) - (eq type (car default-value))))) - - -;;; attspec representation = (symbol . string) - -(defun sgml-make-attspec (name attval) - "Create an attspec from NAME and ATTVAL. -Special case, if ATTVAL is nil this is an implied attribute." - (cons name attval)) - -;; sgml-attspec-name: attspec -> name -(defun sgml-attspec-name (attspec) - (car attspec)) - -;; sgml-attspec-attval: attspec -> attval -(defun sgml-attspec-attval (attspec) - "Return the value of attribute specification ATTSPEC. -If ATTSPEC is nil, nil is returned." - (cdr attspec)) - -;;; asl representaion = (attspec*) - -(defun sgml-lookup-attspec (name asl) - (assoc name asl)) - - -;;;; Element content types - -;; The content of an element is defined as -;; (125 declared content | 126 content model), -;; 125 declared content = "CDATA" | "RCDATA" | "EMPTY" -;; 126 content model = (127 model group | "ANY"), -;; (65 ps+, 138 exceptions)? - -;; I represent a model group with the first state of a corresponding finite -;; automaton (this is a cons). Exceptions are handled separately. -;; The other content types are represented by symbols. - -(defsubst sgml-model-group-p (model) - (consp model)) - -(defconst sgml-cdata 'CDATA) -(defconst sgml-rcdata 'RCDATA) -(defconst sgml-empty 'EMPTY) -(defconst sgml-any 'ANY) - - -;;;; External identifier -;; extid = (pubid? sysid? dir) -;; Representation as (pubid sysid . dir) -;; where pubid = nil | string -;; sysid = nil | string -;; dir = string - -(defun sgml-make-extid (pubid sysid &optional dir) - (cons pubid (cons sysid (or dir default-directory)))) - -(defun sgml-extid-pubid (extid) - (car extid)) - -(defun sgml-extid-sysid (extid) - (if (consp (cdr extid)) - (cadr extid) - (cdr extid))) - -(defun sgml-extid-dir (extid) - "Directory where EXTID was declared" - (if (consp (cdr extid)) - (cddr extid) - nil)) - -(defun sgml-extid-expand (file extid) - "Expand file name FILE in the context of EXTID." - (expand-file-name file (sgml-extid-dir extid))) - -;;;; DTD - -;; DTD = (doctype, eltypes, parameters, entities, shortmaps, -;; notations, dependencies, merged) -;; DTDsubset ~=~ DTD, but doctype is unused -;; -;; doctype = name -;; eltypes = oblist -;; parameters = entity* -;; entities = entity* -;; shortmaps = (name, shortmap)* -;; dependencies = file* -;; merged = Compiled-DTD? where Compiled-DTD = (file, DTD) - -(defstruct (sgml-dtd - (:type vector) - (:constructor sgml-make-dtd (doctype))) - doctype ; STRING, name of doctype - (eltypes ; OBLIST, element types defined - (sgml-make-eltype-table)) - (parameters ; ALIST - (sgml-make-entity-table)) - (entities ; ALIST - (sgml-make-entity-table)) - (shortmaps ; ALIST - (sgml-make-shortref-table)) - (notations ; ?? - nil) - (dependencies ; LIST - nil) - (merged ; (file . DTD) - nil) - (undef-entities ; LIST of entity names - nil)) - - -;;;; Element type objects - -;; An element type object contains the information about an element type -;; obtained from parsing the DTD. - -;; An element type object is represented by a symbol in a special oblist. -;; A table of element type objects is represented by a oblist. - - -;;; Element type objects - -(defun sgml-eltype-name (et) - (symbol-name et)) - -(define-compiler-macro sgml-eltype-name (et) - (`(symbol-name (, et)))) - -(defun sgml-eltype-defined (et) - (fboundp et)) - -(defun sgml-eltype-token (et) - "Return a token for the element type" - et) - -(define-compiler-macro sgml-eltype-token (et) - et) - -(defun sgml-token-eltype (token) - "Return the element type corresponding to TOKEN." - token) - -(define-compiler-macro sgml-token-eltype (token) - token) - -(defmacro sgml-prop-fields (&rest names) - (cons - 'progn - (loop for n in names collect - (`(defmacro (, (intern (format "sgml-eltype-%s" n))) (et) - (list 'get et ''(, n))))))) - -(sgml-prop-fields - ;;flags ; optional tags and mixed - ; (perhaps in value field) - ;;model ; Content type - ; (perhaps in function field) - attlist ; List of defined attributes - includes ; List of included elements - excludes ; List of excluded elements - shortmap ; Associated shortref map - ; nil if none and 'empty if #empty - ) - -(defmacro sgml-eltype-flags (et) - (` (symbol-value (, et)))) - -(defun sgml-eltype-model (et) - (if (fboundp et) - (symbol-function et) - sgml-any)) - -(defsetf sgml-eltype-model fset) - - -(defun sgml-eltype-stag-optional (et) - (oddp (sgml-eltype-flags et))) - -(defun sgml-eltype-etag-optional (et) - (/= 0 (logand 2 (sgml-eltype-flags et)))) - -(defun sgml-eltype-mixed (et) - (< 3 (sgml-eltype-flags et))) -(define-compiler-macro sgml-eltype-mixed (et) - (`(< 3 (sgml-eltype-flags (, et))))) - -(defsetf sgml-eltype-stag-optional (et) (f) - (list 'sgml-set-eltype-flag et 1 f)) -(defsetf sgml-eltype-etag-optional (et) (f) - (list 'sgml-set-eltype-flag et 2 f)) -(defsetf sgml-eltype-mixed (et) (f) - (list 'sgml-set-eltype-flag et 4 f)) - -(defun sgml-set-eltype-flag (et mask f) - (setf (sgml-eltype-flags et) - (logior (logand (if (boundp et) - (sgml-eltype-flags et) - 0) - (lognot mask)) - (if f mask 0)))) - -(defun sgml-maybe-put (sym prop val) - (when val (put sym prop val))) - -(defsetf sgml-eltype-includes (et) (l) - (list 'sgml-maybe-put et ''includes l)) - -(defsetf sgml-eltype-excludes (et) (l) - (list 'sgml-maybe-put et ''excludes l)) - -(defmacro sgml-eltype-appdata (et prop) - "Get application data from element type ET with name PROP. -PROP should be a symbol, reserved names are: flags, model, attlist, -includes, excludes, conref-regexp, mixed, stag-optional, etag-optional." - (` (get (, et) (, prop)))) - -(defun sgml-eltype-all-miscdata (et) - (loop for p on (symbol-plist et) by (function cddr) - unless (memq (car p) '(model flags includes excludes)) - nconc (list (car p) (cadr p)))) - -(defun sgml-eltype-set-all-miscdata (et miscdata) - (setf (symbol-plist et) - (nconc (symbol-plist et) miscdata))) - -(defun sgml-make-eltype (name) - (let ((et (make-symbol name))) - (setf (sgml-eltype-flags et) 0) - et)) - - -;;; Element type tables - -(defun sgml-make-eltype-table () - "Make an empty table of element types." - (make-vector 73 0)) - -(defun sgml-eltype-table-empty (eltype-table) - (loop for x across eltype-table always (eq x 0))) - -(defun sgml-merge-eltypes (eltypes1 eltypes2) - "Return the merge of two element type tables ELTYPES1 and ELTYPES2. -This may change ELTYPES1, ELTYPES2 is unchanged. Returns the new table." - (if (sgml-eltype-table-empty eltypes1) - eltypes2 - (progn - (mapatoms - (function (lambda (sym) - (let ((et (intern (symbol-name sym) eltypes1))) - (unless (fboundp et) ; not yet defined by (following-char) sgml-max-single-octet-number) - (+ (* (- (following-char) (eval-when-compile - (1+ sgml-max-single-octet-number))) - 256) - (prog1 (char-after (1+ (point))) - (forward-char 2)) - sgml-max-single-octet-number) - (sgml-read-octet))) - -(defsubst sgml-read-peek () - (char-after (point))) - -(defun sgml-read-sexp () - (prog1 - (let ((standard-input (current-buffer))) - (read)) - (skip-chars-forward " \t") - (forward-char 1))) - -(defsubst sgml-read-token () - (aref sgml-read-token-vector (sgml-read-number))) - -(defsubst sgml-read-node-ref () - (aref sgml-read-nodes (sgml-read-octet))) - -(defun sgml-read-model-seq () - (loop repeat (sgml-read-number) collect (sgml-read-model))) - -(defun sgml-read-token-seq () - (loop repeat (sgml-read-number) collect (sgml-read-token))) - -(defun sgml-read-moves () - (loop repeat (sgml-read-number) - collect (sgml-make-move (sgml-read-token) (sgml-read-node-ref)))) - -(defun sgml-read-model () - (let* ((n (sgml-read-number)) - (sgml-read-nodes (make-vector n nil))) - (loop for i below n do (aset sgml-read-nodes i (sgml-make-state))) - (loop for e across sgml-read-nodes do - (cond ((eq ?\377 (sgml-read-peek)) ; a and-node - (sgml-read-octet) ; skip - (setf (sgml-and-node-next e) (sgml-read-node-ref)) - (setf (sgml-and-node-dfas e) (sgml-read-model-seq))) - (t ; a normal-state - (setf (sgml-state-opts e) (sgml-read-moves)) - (setf (sgml-state-reqs e) (sgml-read-moves))))) - (aref sgml-read-nodes 0))) - -(defun sgml-read-content () - (let ((c (sgml-read-octet))) - (cond ((eq c 0) sgml-cdata) - ((eq c 1) sgml-rcdata) - ((eq c 2) sgml-empty) - ((eq c 3) sgml-any) - ((eq c 4) nil) - ((eq c 128) - (sgml-read-model))))) - -(defun sgml-read-decode-flag (flag mask) - (not (zerop (logand flag mask)))) - -(defun sgml-read-element (et) - (sgml-eltype-set-all-miscdata et (sgml-read-sexp)) - (let ((flags (sgml-read-octet))) - (unless (= flags 128) - (setf (sgml-eltype-flags et) flags - (sgml-eltype-model et) (sgml-read-content) - (sgml-eltype-includes et) (sgml-read-token-seq) - (sgml-eltype-excludes et) (sgml-read-token-seq))))) - -(defun sgml-read-dtd () - "Decode the saved DTD in current buffer, return the DTD." - (let ((gc-cons-threshold (max gc-cons-threshold 500000)) - temp dtd) - (setq temp (sgml-read-sexp)) ; file-version - (cond - ((equal temp '(sgml-saved-dtd-version 5)) - ;; Doctype -- create dtd structure - (setq dtd (sgml-make-dtd (sgml-read-sexp))) - ;; Element type names -- read and create token vector - (setq temp (sgml-read-number)) ; # eltypes - (setq sgml-read-token-vector (make-vector (1+ temp) nil)) - (aset sgml-read-token-vector 0 sgml-pcdata-token) - (loop for i from 1 to temp do - (aset sgml-read-token-vector i - (sgml-lookup-eltype (sgml-read-sexp) dtd))) - ;; Element type descriptions - (loop for i from 1 to (sgml-read-number) do - (sgml-read-element (aref sgml-read-token-vector i))) - (setf (sgml-dtd-parameters dtd) (sgml-read-sexp)) - (setf (sgml-dtd-entities dtd) (sgml-read-sexp)) - (setf (sgml-dtd-shortmaps dtd) (sgml-read-sexp)) - (setf (sgml-dtd-notations dtd) (sgml-read-sexp)) - (setf (sgml-dtd-dependencies dtd) (sgml-read-sexp))) - ;; New version - ((equal temp '(sgml-saved-dtd-version 6)) - (setq dtd (sgml-bdtd-read-dtd))) - ;; Something else - (t - (error "Unknown file format for saved DTD: %s" temp))) - dtd)) - -(defun sgml-load-dtd (file) - "Load a saved DTD from FILE." - (interactive - (let ((tem (expand-file-name - (or sgml-default-dtd-file - (sgml-default-dtd-file))))) - (list (read-file-name "Load DTD from: " - (file-name-directory tem) - tem - t - (file-name-nondirectory tem))))) - (setq sgml-loaded-dtd nil) ; Allow reloading of DTD - ;; Search for 'file' on the sgml-system-path [ndw] - (let ((real-file (car (mapcan (function - (lambda (dir) - (let ((f (expand-file-name file dir))) - (if (file-exists-p f) - (list f))))) - (cons "." - ;; wing change -- add sgml-data-directory - (append sgml-system-path - (list sgml-data-directory))))))) - (or real-file - (error "Saved DTD file %s not found" file)) - (let ((cb (current-buffer)) - (tem nil) - (dtd nil) - (l (buffer-list)) - (find-file-type ; Allways binary - (function (lambda (fname) 1)))) - ;; Search loaded buffer for a already loaded DTD - (while (and l (null tem)) - (set-buffer (car l)) - (if (equal sgml-loaded-dtd real-file) - (setq tem (current-buffer))) - (setq l (cdr l))) - (cond - (tem ; loaded DTD found - (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state))) - (t ; load DTD from file - (set-buffer cb) - (sgml-push-to-entity real-file) - (message "Loading DTD from %s..." real-file) - (setq dtd (sgml-read-dtd)) - (message "Loading DTD from %s...done" real-file) - (sgml-pop-entity))) - (set-buffer cb) - (sgml-set-initial-state dtd) - (setq sgml-default-dtd-file file) - (setq sgml-loaded-dtd real-file)))) - -;;;; Biniary coded DTD module -;;; Works on the binary coded compiled DTD (bdtd) - -;;; bdtd-load: cfile dtdfile ents -> bdtd -;;; bdtd-merge: bdtd dtd -> dtd? -;;; bdtd-read-dtd: bdtd -> dtd - -;;; Implement by letting bdtd be implicitly the current buffer and -;;; dtd implicit in sgml-dtd-info. - -(defun sgml-bdtd-load (cfile dtdfile ents) - "Load the compiled dtd from CFILE into the current buffer. -If this file does not exists, is of an old version or out of date, a -new compiled dtd will be creted from file DTDFILE and parameter entity -settings in ENTS." - ;;(Assume the current buffer is a scratch buffer and is empty) - (sgml-debug "Trying to load compiled DTD from %s..." cfile) - (or (and (file-readable-p cfile) - (let ((find-file-type ; Allways binary - (function (lambda (fname) 1)))) - ;; fifth arg to insert-file-contents is not available in early - ;; v19. - (insert-file-contents cfile nil nil nil)) - (equal '(sgml-saved-dtd-version 6) (sgml-read-sexp)) - (or (sgml-up-to-date-p cfile (sgml-read-sexp)) - (if (eq 'ask sgml-recompile-out-of-date-cdtd) - (not (y-or-n-p - "Compiled DTD is out of date, recompile? ")) - (not sgml-recompile-out-of-date-cdtd)))) - (sgml-compile-dtd dtdfile cfile ents))) - -(defun sgml-up-to-date-p (file dependencies) - "Check if FILE is newer than all files in the list DEPENDENCIES. -If DEPENDENCIES contains the symbol `t', FILE is not considered newer." - (if (memq t dependencies) - nil - (loop for f in dependencies - always (file-newer-than-file-p file f)))) - -(defun sgml-compile-dtd (dtd-file to-file ents) - "Construct a binary code compiled dtd from DTD-FILE and write it to TO-FILE. -The dtd will be constructed with the parameter entities set according -to ENTS. The bdtd will be left in the current buffer. The current -buffer is assumend to be empty to start with." - (sgml-log-message "Recompiling DTD file %s..." dtd-file) - (let* ((sgml-dtd-info (sgml-make-dtd nil)) - (parameters (sgml-dtd-parameters sgml-dtd-info)) - (sgml-parsing-dtd t)) - (push dtd-file - (sgml-dtd-dependencies sgml-dtd-info)) - (loop for (name . val) in ents - do (sgml-entity-declare name parameters 'text val)) - (sgml-push-to-entity dtd-file) - (sgml-check-dtd-subset) - (sgml-pop-entity) - (erase-buffer) - ;; For XEmacs-20.0/Mule - (setq buffer-file-coding-system 'binary) - (sgml-write-dtd sgml-dtd-info to-file) - t)) - -(defun sgml-check-entities (params1 params2) - "Check that PARAMS1 is compatible with PARAMS2." - (block check-entities - (sgml-map-entities - (function (lambda (entity) - (let ((other - (sgml-lookup-entity (sgml-entity-name entity) - params2))) - (unless (or (null other) - (equal entity other)) - (sgml-log-message - "Parameter %s in complied DTD has wrong value;\ - is '%s' should be '%s'" - (sgml-entity-name entity) - (sgml-entity-text other) - (sgml-entity-text entity)) - (return-from check-entities nil))))) - params1) - t)) - -(defun sgml-bdtd-merge () - "Merge the binary coded dtd in the current buffer with the current dtd. -The current dtd is the variable sgml-dtd-info. Return t if mereged -was successfull or nil if failed." - (setq buffer-file-coding-system 'binary) - (goto-char (point-min)) - (sgml-read-sexp) ; skip filev - (let ((dependencies (sgml-read-sexp)) - (parameters (sgml-read-sexp)) - (gc-cons-threshold (max gc-cons-threshold 500000)) - temp) - ;; Check comaptibility of parameters - (and (sgml-check-entities (sgml-dtd-parameters sgml-dtd-info) - parameters) - (progn - ;; Do the merger - (sgml-message "Reading compiled DTD...") - (sgml-merge-entity-tables (sgml-dtd-parameters sgml-dtd-info) - parameters) - (setf (sgml-dtd-dependencies sgml-dtd-info) - (nconc (sgml-dtd-dependencies sgml-dtd-info) - dependencies)) - ;; Doctype - (setq temp (sgml-read-sexp)) - (when (and temp (null (sgml-dtd-doctype sgml-dtd-info))) - (setf (sgml-dtd-doctype sgml-dtd-info) temp)) - - ;; Element type names -- read and create token vector - (setq temp (sgml-read-number)) ; # eltypes - (setq sgml-read-token-vector (make-vector (1+ temp) nil)) - (aset sgml-read-token-vector 0 sgml-pcdata-token) - (loop for i from 1 to temp do - (aset sgml-read-token-vector i - (sgml-lookup-eltype (sgml-read-sexp)))) - ;; Element type descriptions - (loop for i from 1 to (sgml-read-number) do - (sgml-read-element (aref sgml-read-token-vector i))) - (sgml-merge-entity-tables (sgml-dtd-entities sgml-dtd-info) - (sgml-read-sexp)) - (sgml-merge-shortmaps (sgml-dtd-shortmaps sgml-dtd-info) - (sgml-read-sexp)) - (setf (sgml-dtd-notations sgml-dtd-info) (sgml-read-sexp)) - t)))) - -(defun sgml-bdtd-read-dtd () - "Create and return a dtd from the binary coded dtd in the current buffer." - (let ((sgml-dtd-info (sgml-make-dtd nil))) - (sgml-bdtd-merge) - sgml-dtd-info)) - -;;;; Set markup type - -(defsubst sgml-set-markup-type (type) - "Set the type of the markup parsed to TYPE. -The markup starts at position given by variable sgml-markup-start and -ends at point." - (when (and sgml-set-face - (null sgml-current-eref)) - (sgml-set-face-for sgml-markup-start (point) type)) - (setq sgml-markup-type type)) - - -;;;; Parsing delimiters - -(eval-and-compile - (defconst sgml-delimiters - '("AND" "&" - "COM" "--" - "CRO" "&#" - "DSC" "]" - "DSO" "[" - "DTGC" "]" - "DTGO" "[" - "ERO" "&" - "ETAGO" "" - "MDO" "" - "PIO" "" - "VI" "=" - ;; Some combinations - "MS-START" "" ; MSC MDC - ;; Pseudo - "NULL" "" - ))) - - -(defmacro sgml-is-delim (delim &optional context move offset) - "Macro for matching delimiters. -Syntax: DELIM &optional CONTEXT MOVE -where DELIM is the delimiter name (string or symbol), -CONTEXT the contextual constraint, and -MOVE is `nil', `move' or `check'. - -Test if the text following point in current buffer matches the SGML -delimiter DELIM. Also check the characters after the delimiter for -CONTEXT. Applicable values for CONTEXT is -`gi' -- name start or TAGC if SHORTTAG YES, -`com' -- if COM or MDC, -`nmstart' -- name start character, -`stagc' -- TAGC if SHORTTAG YES, -`digit' -- any Digit, -string -- delimiter with that name, -list -- any of the contextual constraints in the list." - - (or offset (setq offset 0)) - (let ((ds (member (upcase (format "%s" delim)) - sgml-delimiters))) - (assert ds) - (setq delim (car ds) - ds (cadr ds)) - (cond ((eq context 'gi) - (setq context '(nmstart stagc))) - ((eq context 'com) - (setq context '("COM" "MDC"))) - ((null context) - (setq context '(t))) - ((not (listp context)) - (setq context (list context)))) - (`(if (and ; This and checks that characters - ; of the delimiter - (,@(loop for i from 0 below (length ds) collect - (` (eq (, (aref ds i)) - (sgml-following-char (, (+ i offset))))))) - (or - (,@(loop - for c in context collect ; context check - (cond - ((eq c 'nmstart) ; name start character - (`(sgml-startnm-char - (or (sgml-following-char (, (length ds))) 0)))) - ((eq c 'stagc) - (`(and sgml-current-shorttag - (sgml-is-delim "TAGC" nil nil (, (length ds)))))) - ((eq c 'digit) - (`(memq (sgml-following-char (, (length ds))) - '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))) - ((stringp c) - (`(sgml-is-delim (, c) nil nil (, (length ds))))) - ((eq c t)) - (t (error "Context type: %s" c)))) - ))) - - (progn ; Do operations if delimiter found - (,@ (if move (`((forward-char (, (length ds))))))) - (,@ (if (not (eq move 'check)) - '(t)))) - (,@ (if (eq move 'check) - (`((sgml-delimiter-parse-error (, delim)))))))))) - -(defmacro sgml-following-char (n) - (cond ((zerop n) '(following-char)) - ((= n 1) '(char-after (1+ (point)))) - (t (` (char-after (+ (, n) (point))))))) - -(defun sgml-delimiter-parse-error (delim) - (sgml-parse-error "Delimiter %s (%s) expected" - delim (cadr (member delim sgml-delimiters)))) - -(defmacro sgml-parse-delim (delim &optional context) - (`(sgml-is-delim (, delim) (, context) move))) - -(defmacro sgml-check-delim (delim &optional context) - (`(sgml-is-delim (, delim) (, context) check))) - -(defmacro sgml-skip-upto (delim) - "Skip until the delimiter or first char of one of the delimiters. -If DELIM is a string/symbol this is should be a delimiter role. -Characters are skipped until the delimiter is recognized. -If DELIM is a list of delimiters, skip until a character that is first -in any of them." - (cond - ((consp delim) - (list 'skip-chars-forward - (concat "^" - (loop for d in delim - concat (let ((ds (member (upcase (format "%s" d)) - sgml-delimiters))) - (assert ds) - (let ((s (substring (cadr ds) 0 1))) - (if (member s '("-" "\\")) - (concat "\\" s) - s))))))) - (t - (let ((ds (member (upcase (format "%s" delim)) - sgml-delimiters))) - (assert ds) - (setq ds (cadr ds)) - (if (= 1 (length ds)) - (list 'skip-chars-forward (concat "^" ds)) - (`(and (search-forward (, ds) nil t) - (backward-char (, (length ds)))))))))) - - -;;(macroexpand '(sgml-is-delim mdo)) -;;(macroexpand '(sgml-parse-delim mdo)) -;;(macroexpand '(sgml-check-delim mdo)) - - -;;;; General lexical functions -;;; Naming conventions -;;; sgml-parse-xx try to parse xx, return nil if can't else return -;;; some propriate non-nil value. -;;; Except: for name/nametoken parsing, return 0 if can't. -;;; sgml-check-xx require xx, report error if can't parse. Return -;;; aproporiate value. - -(defmacro sgml-parse-char (char) - (` (cond ((eq (, char) (following-char)) - (forward-char 1) - t)))) - -(defmacro sgml-parse-chars (char1 char2 &optional char3) - "Parse two or three chars; return nil if can't" - (if (null char3) - (` (cond ((and (eq (, char1) (char-after (point))) - (eq (, char2) (char-after (1+ (point))))) - (forward-char 2) - t))) - (` (cond ((and (eq (, char1) (char-after (point))) - (eq (, char2) (char-after (1+ (point)))) - (eq (, char3) (char-after (1+ (1+ (point)))))) - (forward-char 3) - t))))) - -(defun sgml-check-char (char) - (cond ((not (sgml-parse-char char)) - (sgml-parse-error "Expecting %c" char)))) - -(defun sgml-parse-RE () - (or (sgml-parse-char ?\n) - (sgml-parse-char ?\r))) - -(defmacro sgml-startnm-char (c) - (` (eq ?w (char-syntax (, c))))) - -(defun sgml-startnm-char-next () - (and (not (eobp)) - (sgml-startnm-char (following-char)))) - -(defun sgml-name-char (c) - (and c - (or (sgml-startnm-char c) - (eq ?_ (char-syntax c))))) - -(defun sgml-is-end-tag () - (sgml-is-delim "ETAGO" gi)) - -(defsubst sgml-is-enabled-net () - (and (sgml-is-delim "NET") - sgml-current-shorttag - (sgml-tree-net-enabled sgml-current-tree))) - -(defun sgml-is-start-tag () - (sgml-is-delim "STAGO" gi)) - -(defsubst sgml-parse-s (&optional shortmap) - (if shortmap - (or (/= 0 (skip-chars-forward " ")) - (/= 0 (skip-chars-forward "\t")) - (sgml-parse-char ?\n) - (sgml-parse-char ?\r)) - (/= 0 (skip-chars-forward " \t\n\r")))) - -(defsubst sgml-parse-processing-instruction () - (if (sgml-parse-delim "PIO") - (sgml-do-processing-instruction))) - -(defun sgml-do-processing-instruction () - (let ((start (point))) - (sgml-skip-upto "PIC") - (when sgml-pi-function - (funcall sgml-pi-function - (buffer-substring-no-properties start (point))))) - (sgml-check-delim "PIC") - (sgml-set-markup-type 'pi) - t) - - -(defmacro sgml-general-case (string) (`(downcase (, string)))) -(defmacro sgml-entity-case (string) string) - -(defun sgml-parse-name (&optional entity-name) - (if (sgml-startnm-char-next) - (let ((name (buffer-substring-no-properties - (point) - (progn (skip-syntax-forward "w_") - (point))))) - (if entity-name - (sgml-entity-case name) - (sgml-general-case name))))) - -(define-compiler-macro sgml-parse-name (&whole form &optional entity-name) - (cond - ((memq entity-name '(nil t)) - (` (if (sgml-startnm-char-next) - ((, (if entity-name 'sgml-entity-case 'sgml-general-case)) - (buffer-substring-no-properties (point) - (progn (skip-syntax-forward "w_") - (point))))))) - (t - form))) - -(defun sgml-check-name (&optional entity-name) - (or (sgml-parse-name entity-name) - (sgml-parse-error "Name expected"))) - -(define-compiler-macro sgml-check-name (&optional entity-name) - (`(or (, (if entity-name - (`(sgml-parse-name (, entity-name))) - '(sgml-parse-name))) - (sgml-parse-error "Name expected")))) - - -(defun sgml-parse-nametoken (&optional entity-name) - "Parses a name token and returns a string or nil if no nametoken." - (if (sgml-name-char (following-char)) - (let ((name (buffer-substring-no-properties - (point) - (progn (skip-syntax-forward "w_") - (point))))) - (if entity-name - (sgml-entity-case name) - (sgml-general-case name))))) - -(defun sgml-check-nametoken () - (or (sgml-parse-nametoken) - (sgml-parse-error "Name token expected"))) - -;;(defun sgml-gname-symbol (string) -;; "Convert a string to a general name/nametoken/numbertoken." -;; (intern (sgml-general-case string))) - -;;(defun sgml-ename-symbol (string) -;; "Convert a string to an entity name." -;; (intern (sgml-entity-case string))) - -(defsubst sgml-parse-general-entity-ref () - (if (sgml-parse-delim "ERO" nmstart) - (sgml-do-general-entity-ref))) - -(defun sgml-do-general-entity-ref () - (sgml-do-entity-ref - (prog1 (sgml-parse-name t) - (or (sgml-parse-delim "REFC") - (sgml-parse-RE)) - (sgml-set-markup-type 'entity))) - t) - -(defun sgml-do-entity-ref (name) - (let ((entity - (sgml-lookup-entity name - (sgml-dtd-entities sgml-dtd-info)))) - (cond ((and (null entity) - sgml-warn-about-undefined-entities) - (sgml-log-warning - "Undefined entity %s" name)) - ((sgml-entity-data-p entity) - (when sgml-signal-data-function - (funcall sgml-signal-data-function)) - (cond - (sgml-entity-function - (funcall sgml-entity-function entity)) - (sgml-data-function - (sgml-push-to-entity entity sgml-markup-start) - (funcall sgml-data-function (buffer-string)) - (sgml-pop-entity)))) - (t - (sgml-push-to-entity entity sgml-markup-start))))) - -(defsubst sgml-parse-parameter-entity-ref () - "Parse and push to a parameter entity, return nil if no ref here." - ;;(setq sgml-markup-start (point)) - (if (sgml-parse-delim "PERO" nmstart) - (sgml-do-parameter-entity-ref))) - -(defun sgml-do-parameter-entity-ref () - (let* ((name (sgml-parse-name t)) - (ent (sgml-lookup-entity name - (sgml-dtd-parameters sgml-dtd-info)))) - (or (sgml-parse-delim "REFC") - (sgml-parse-char ?\n)) - ;;(sgml-set-markup-type 'param) - (cond (ent - (sgml-push-to-entity ent sgml-markup-start 'param)) - (t - (sgml-log-warning - "Undefined parameter entity %s" name))) - t)) - -(defun sgml-parse-comment () - (if (sgml-parse-delim "COM") - (progn (sgml-skip-upto "COM") - (sgml-check-delim "COM") - t))) - -(defun sgml-skip-cs () - "Skip over the separator used in the catalog. -Return true if not at the end of the buffer." - (while (or (sgml-parse-s) - (sgml-parse-comment))) - (not (eobp))) - -(defsubst sgml-skip-ps () - "Move point forward stopping before a char that isn't a parameter separator." - (while - (or (sgml-parse-s) - (if (eobp) (sgml-pop-entity)) - (sgml-parse-parameter-entity-ref) - (sgml-parse-comment)))) - -(defsubst sgml-parse-ds () -;71 ds = 5 s | EE | 60+ parameter entity reference -; | 91 comment declaration -; | 44 processing instruction -; | 93 marked section declaration *** - (or (and (eobp) (sgml-pop-entity)) ;EE - (sgml-parse-s) ;5 s - ;;(sgml-parse-comment-declaration) ;91 comment declaration - (sgml-parse-parameter-entity-ref) - (sgml-parse-processing-instruction))) - -(defun sgml-skip-ds () - (while (sgml-parse-ds))) - -(defmacro sgml-parse-rni (&optional name) - "Parse a RNI (#) return nil if none; with optional NAME, -a RNI must be followed by NAME." - (cond - (name - (` (if (sgml-parse-delim "RNI") - (sgml-check-token (, name))))) - (t '(sgml-parse-delim "RNI")))) - -(defun sgml-check-token (name) - (or (equal (sgml-check-name) name) - (sgml-parse-error "Reserved name not expected"))) - -(defun sgml-parse-literal () - "Parse a literal and return a string, if no literal return nil." - (let (lita start value) - (cond ((or (sgml-parse-delim "LIT") - (setq lita (sgml-parse-delim "LITA"))) - (setq start (point)) - (if lita - (sgml-skip-upto "LITA") - (sgml-skip-upto "LIT")) - (setq value (buffer-substring-no-properties start (point))) - (if lita - (sgml-check-delim "LITA") - (sgml-check-delim "LIT")) - value)))) - -(defun sgml-check-literal () - (or (sgml-parse-literal) - (sgml-parse-error "A litteral expected"))) - -(defun sgml-parse-minimum-literal () - "Parse a quoted SGML string and return it, if no string return nil." - (cond - ((memq (following-char) '(?\" ?\')) - (let* ((qchar (following-char)) - (blanks " \t\r\n") - (qskip (format "^%s%c" blanks qchar)) - (start (point)) - (value ; accumulates the literal value - "") - (spaced "")) - (forward-char 1) - (skip-chars-forward blanks) - (while (not (sgml-parse-char qchar)) - (cond ((eobp) - (goto-char start) - (sgml-parse-error "Unterminated literal")) - ((sgml-parse-s) - (setq spaced " ")) - (t - (setq value - (concat value spaced - (buffer-substring-no-properties - (point) - (progn (skip-chars-forward qskip) - (point)))) - spaced "")))) - value)))) - -(defun sgml-check-minimum-literal () - (or (sgml-parse-minimum-literal) - (sgml-parse-error "A minimum literal expected"))) - -(defun sgml-parse-external () - "Leaves nil if no external id, or (pubid . sysid)" - (sgml-skip-ps) - (let* ((p (point)) - (token (sgml-parse-nametoken))) - (cond - (token - (sgml-skip-ps) - (cond ((member token '("public" "system")) - (let* ((pubid ; the public id - (if (string-equal token "public") - (or (sgml-parse-minimum-literal) - (sgml-parse-error "Public identifier expected")))) - (sysid ; the system id - (progn (sgml-skip-ps) - (sgml-parse-literal)))) - (sgml-make-extid pubid sysid))) - (t - (goto-char p) - nil)))))) - -(defun sgml-skip-tag () - (when (sgml-parse-char ?<) - (sgml-parse-char ?/) - (unless (search-forward-regexp - "\\([^\"'<>/]\\|\"[^\"]*\"\\|'[^']*'\\)*" - nil t) - (sgml-error "Invalid tag")) - (or (sgml-parse-char ?>) - (sgml-parse-char ?/)))) - - -;;;; Entity Manager - -(defstruct (sgml-entity - (:type list) - (:constructor sgml-make-entity (name type text))) - name ; Name of entity (string) - type ; Type of entity CDATA NDATA PI SDATA - text ; string or external - ) - -(defun sgml-entity-data-p (entity) - "True if ENTITY is a data entity, that is not a text entity." - (not (eq (sgml-entity-type entity) 'text))) - -(defun sgml-entity-marked-undefined-p (entity) - (cdddr entity)) - - -;;; Entity tables -;; Represented by a cons-cell whose car is the default entity (or nil) -;; and whose cdr is as an association list. - -(defun sgml-make-entity-table () - (list nil)) - -(defun sgml-lookup-entity (name entity-table) - (or (assoc name (cdr entity-table)) - (car entity-table))) - -(defun sgml-entity-declare (name entity-table type text) - "Declare an entity with name NAME in table ENTITY-TABLE. -TYPE should be the type of the entity (text|cdata|ndata|sdata...). -TEXT is the text of the entity, a string or an external identifier. -If NAME is nil, this defines the default entity." - (cond - (name - (unless (sgml-lookup-entity name entity-table) - (sgml-debug "Declare entity %s %s as %S" name type text) - (nconc entity-table - (list (sgml-make-entity name type text))))) - (t - (unless (car entity-table) - (sgml-debug "Declare default entity %s as %S" type text) - (setcar entity-table (sgml-make-entity name type text)))))) - -(defun sgml-entity-completion-table (entity-table) - "Make a completion table from the ENTITY-TABLE." - (cdr entity-table)) - -(defun sgml-map-entities (fn entity-table &optional collect) - (if collect - (mapcar fn (cdr entity-table)) - (loop for e in (cdr entity-table) do (funcall fn e)))) - -(defun sgml-merge-entity-tables (tab1 tab2) - "Merge entity table TAB2 into TAB1. TAB1 is modified." - (nconc tab1 (cdr tab2)) - (setcar tab1 (or (car tab1) (car tab2)))) - - -(defun sgml-entity-insert-text (entity &optional ptype) - "Insert the text of ENTITY. -PTYPE can be 'param if this is a parameter entity." - (let ((text (sgml-entity-text entity))) - (cond - ((stringp text) - (insert text)) - (t - (sgml-insert-external-entity text - (or ptype - (sgml-entity-type entity)) - (sgml-entity-name entity)))))) - -;;;; External identifyer resolve - -(defun sgml-cache-catalog (file cache-var parser-fun - &optional default-dir) - "Return parsed catalog. -FILE is the file containing the catalog. Maintains a cache of parsed -catalog files in variable CACHE-VAR. The parsing is done by function -PARSER-FUN that should parse the current buffer and return the parsed -repreaentation of the catalog." - (setq file (file-truename (expand-file-name file default-dir))) - (and - (file-readable-p file) - (let ((c (assoc file (symbol-value cache-var))) - (modtime (elt (file-attributes file) 5))) - (if (and c (equal (second c) modtime)) - (cddr c) - (when c (set cache-var (delq c (symbol-value cache-var)))) - (let (new) - (message "Loading %s ..." file) - (sgml-push-to-entity file) - (setq default-directory (file-name-directory file)) - (setq new (funcall parser-fun)) - (sgml-pop-entity) - (push (cons file (cons modtime new)) (symbol-value cache-var)) - (message "Loading %s ... done" file) - new))))) - -(defun sgml-main-directory () - "Directory of the document entity." - (let ((cb (current-buffer))) - (set-buffer sgml-current-top-buffer) - (prog1 default-directory - (set-buffer cb)))) - -(defun sgml-trace-lookup (&rest args) - "Log a message like `sgml-log-message', but only if `sgml-trace-entity-lookup' is set." - (when sgml-trace-entity-lookup - (apply (function sgml-log-message) args))) - - -(defun sgml-catalog-lookup (files pubid type name) - "Look up the public identifier/entity name in catalogs. -FILES is a list of catalogs to use. PUBID is the public identifier -\(if any). TYPE is the entity type and NAME is the entity name." - (cond ((eq type 'param) - (setq name (format "%%%s" name) - type 'entity)) - ((eq type 'dtd) - (setq type 'doctype))) - ;;(sgml-trace-lookup " [pubid='%s' type=%s name='%s']" pubid type name) - (loop - for f in files thereis - (let ((cat (sgml-cache-catalog f 'sgml-catalog-assoc - (function sgml-parse-catalog-buffer) - (sgml-main-directory)))) - (sgml-trace-lookup " catalog: %s %s" - (expand-file-name f (sgml-main-directory)) - (if (null cat) "empty/non existent" "exists")) - (or - ;; Giv PUBLIC entries priority over ENTITY and DOCTYPE - (if pubid - (loop for (key cname file) in cat - thereis (if (and (eq 'public key) - (string= pubid cname)) - (if (file-readable-p file) - (progn - (sgml-trace-lookup " >> %s [by pubid]" file) - file) - (progn - (sgml-trace-lookup " !unreadable %s" file) - nil))))) - (loop for (key cname file) in cat - ;;do (sgml-trace-lookup " %s %s" key cname) - thereis (if (and (eq type key) - (or (null cname) - (string= name cname))) - (if (file-readable-p file) - (progn - (sgml-trace-lookup " >> %s [by %s %s]" - file key cname) - file) - (progn - (sgml-trace-lookup " !unreadable %s" file) - nil)))))))) - -(defun sgml-path-lookup (extid type name) - (let* ((pubid (sgml-extid-pubid extid)) - (sysid (sgml-extid-sysid extid)) - (subst (list '(?% ?%)))) - (when pubid - (nconc subst (list (cons ?p (sgml-transliterate-file pubid))) - (sgml-pubid-parts pubid)) - (setq pubid (sgml-canonize-pubid pubid))) - (when sysid (nconc subst (list (cons ?s sysid)))) - (when name (nconc subst (list (cons ?n name)))) - (when type (nconc subst (list (cons ?y (cond ((eq type 'dtd) "dtd") - ((eq type 'text) "text") - ((eq type 'param) "parm") - (t "sgml")))))) - (sgml-debug "Ext. file subst. = %S" subst) - (loop for cand in sgml-public-map - thereis - (and (setq cand (sgml-subst-expand cand subst)) - (file-readable-p - (setq cand - (sgml-extid-expand (substitute-in-file-name cand) - extid))) - (not (file-directory-p cand)) - cand)))) - -(defun sgml-external-file (extid &optional type name) - "Return file name for entity with external identifier EXTID. -Optional argument TYPE should be the type of entity and NAME should be -the entity name." - ;; extid is (pubid . sysid) - (let ((pubid (sgml-extid-pubid extid))) - (when pubid (setq pubid (sgml-canonize-pubid pubid))) - (sgml-trace-lookup "Start looking for %s entity %s public %s system %s" - (or type "-") - (or name "?") - pubid - (sgml-extid-sysid extid)) - (or (if (and sgml-system-identifiers-are-preferred - (sgml-extid-sysid extid)) - (or (sgml-lookup-sysid-as-file extid) - (sgml-path-lookup ;Try the path also, but only using sysid - (sgml-make-extid nil (sgml-extid-sysid extid)) - nil nil))) - (sgml-catalog-lookup sgml-current-localcat pubid type name) - (sgml-catalog-lookup sgml-catalog-files pubid type name) - (if (not sgml-system-identifiers-are-preferred) - (sgml-lookup-sysid-as-file extid)) - (sgml-path-lookup extid type name)))) - -(defun sgml-lookup-sysid-as-file (extid) - (let ((sysid (sgml-extid-sysid extid))) - (and sysid - (loop for pat in sgml-public-map - never (string-match "%[Ss]" pat)) - (file-readable-p (setq sysid (sgml-extid-expand sysid extid))) - sysid))) - -(defun sgml-insert-external-entity (extid &optional type name) - "Insert the contents of an external entity at point. -EXTID is the external identifier of the entity. Optional arguments TYPE -is the entity type and NAME is the entity name, used to find the entity. -Returns nil if entity is not found." - (let* ((pubid (sgml-extid-pubid extid)) - (sysid (sgml-extid-sysid extid))) - (or (if sysid - (loop for fn in sgml-sysid-resolve-functions - thereis (funcall fn sysid))) - (let ((file (sgml-external-file extid type name))) - (and file (insert-file-contents file))) - (progn - (sgml-log-warning "External entity %s not found" name) - (when pubid - (sgml-log-warning " Public identifier %s" pubid)) - (when sysid - (sgml-log-warning " System identfier %s" sysid)) - nil)))) - - -;; Parse a buffer full of catalogue entries. -(defun sgml-parse-catalog-buffer () - "Parse all entries in a catalogue." - (sgml-trace-lookup " (Parsing catalog)") - (loop - while (sgml-skip-cs) - for type = (downcase (sgml-check-cat-literal)) - for class = (cdr (assoc type '(("public" . public) ("dtddecl" . public) - ("entity" . name) ("linktype" . name) - ("doctype" . name) ("sgmldecl" . noname) - ("document" . noname)))) - when (not (null class)) - collect - (let* ((name - (cond ((eq class 'public) - (sgml-skip-cs) - (sgml-canonize-pubid (sgml-check-minimum-literal))) - ((string= type "doctype") - (sgml-general-case (sgml-check-cat-literal))) - ((eq class 'name) - (sgml-entity-case (sgml-check-cat-literal))))) - (file - (expand-file-name (sgml-check-cat-literal)))) - (list (intern type) name file)))) - - -(defun sgml-check-cat-literal () - "Read the next catalog token. -Skips any leading spaces/comments." - (sgml-skip-cs) - (or (sgml-parse-literal) - (buffer-substring-no-properties - (point) - (progn (skip-chars-forward "^ \r\n\t") - (point))))) - -(defconst sgml-formal-pubid-regexp - (concat - "^\\(+//\\|-//\\|\\)" ; Registered indicator [1] - "\\(\\([^/]\\|/[^/]\\)+\\)" ; Owner [2] - "//" - "\\([^ ]+\\)" ; Text class [4] - " " - "\\(\\([^/]\\|/[^/]\\)*\\)" ; Text description [5] - "//" - "\\(\\([^/]\\|/[^/]\\)*\\)" ; Language [7] - "\\(//" ; [9] - "\\(\\([^/]\\|/[^/]\\)*\\)" ; Version [10] - "\\)?")) - -(defun sgml-pubid-parts (pubid) - (nconc - (if (string-match sgml-formal-pubid-regexp pubid) - (nconc - (list - (cons ?o (sgml-transliterate-file (sgml-matched-string pubid 2))) - (cons ?c (downcase (sgml-matched-string pubid 4))) - (cons ?d (sgml-transliterate-file (sgml-matched-string pubid 5))) - ;; t alias for d (%T used by sgmls) - (cons ?t (sgml-transliterate-file (sgml-matched-string pubid 5))) - (cons ?l (downcase (sgml-matched-string pubid 7)))) - (if (match-beginning 9) - (list (cons ?v (sgml-transliterate-file - (sgml-matched-string pubid 10))))))))) - -(defun sgml-canonize-pubid (pubid) - (if (string-match sgml-formal-pubid-regexp pubid) - (concat - (sgml-matched-string pubid 1) ; registered indicator - (sgml-matched-string pubid 2) ; Owner - "//" - (upcase (sgml-matched-string pubid 4)) ; class - " " - (sgml-matched-string pubid 5) ; Text description - "//" - (upcase (sgml-matched-string pubid 7)) ; Language - "//" - (if (match-beginning 9) - (sgml-matched-string pubid 10) "")))) - -(defun sgml-transliterate-file (string) - (mapconcat (function (lambda (c) - (char-to-string - (or (cdr-safe (assq c sgml-public-transliterations)) - c)))) - string "")) - -(defun sgml-subst-expand-char (c parts) - (cdr-safe (assq (downcase c) parts))) - -(defun sgml-subst-expand (s parts) - (loop for i from 0 to (1- (length s)) - as c = (aref s i) - concat (if (eq c ?%) - (or (sgml-subst-expand-char (aref s (incf i)) parts) - (return nil)) - (char-to-string (aref s i))))) - -(defun sgml-matched-string (string n &optional regexp noerror) - (let ((res (if regexp - (or (string-match regexp string) - noerror - (error "String match fail"))))) - (if (or (null regexp) - (numberp res)) - (substring string (match-beginning n) - (match-end n))))) - -;;;; Files for SGML declaration and DOCTYPE declaration - -(defun sgml-declaration () - (or sgml-declaration - (if sgml-doctype - (sgml-in-file-eval sgml-doctype - '(sgml-declaration))) - (if sgml-parent-document - (sgml-in-file-eval (car sgml-parent-document) - '(sgml-declaration))) - ;; *** check for sgmldecl comment - (sgml-external-file nil 'sgmldecl) - ) - ) - -(defun sgml-in-file-eval (file expr) - (let ((cb (current-buffer))) - (set-buffer (find-file-noselect file)) - (prog1 (eval expr) - (set-buffer cb)))) - - -;;;; Entity references and positions - -(defstruct (sgml-eref - (:constructor sgml-make-eref (entity start end)) - (:type list)) - entity - start ; type: epos - end) - -(defun sgml-make-epos (eref pos) - (cons eref pos)) - -(defun sgml-epos-eref (epos) - (if (consp epos) - (car epos))) - -(defun sgml-epos-pos (epos) - "The buffer position of EPOS withing its entity." - (if (consp epos) - (cdr epos) - epos)) - -(defun sgml-bpos-p (epos) - "True if EPOS is a position in the main buffer." - (numberp epos)) - -(defun sgml-strict-epos-p (epos) - "True if EPOS is a position in an entity other then the main buffer." - (consp epos)) - -(defun sgml-epos (pos) - "Convert a buffer position POS into an epos." - (if sgml-current-eref - (sgml-make-epos sgml-current-eref pos) - pos)) - -(defun sgml-epos-before (epos) - "The last position in buffer not after EPOS. -If EPOS is a buffer position this is the same. If EPOS is in an entity -this is the buffer position before the entity reference." - (while (consp epos) - (setq epos (sgml-eref-start (sgml-epos-eref epos)))) - epos) - -(defun sgml-epos-after (epos) - "The first position in buffer after EPOS. -If EPOS is in an other entity, buffer position is after -entity reference leading to EPOS." - (while (consp epos) - (setq epos (sgml-eref-end (sgml-epos-eref epos)))) - epos) - -(defun sgml-epos-promote (epos) - "Convert position in entity structure EPOS to a buffer position. -If EPOS is in an entity, the buffer position will be the position -before the entity reference if EPOS is first character in entity -text. Otherwise buffer position will be after entity reference." - (while (and (consp epos) - (= (cdr epos) 1)) - (setq epos (sgml-eref-start (car epos)))) - (sgml-epos-after epos)) - - -;;;; DTD repository -;;compiled-dtd: extid -> Compiled-DTD? -;;extid-cdtd-name: extid -> file? -;;up-to-date-p: (file, dependencies) -> cond - -;; Emacs Catalogues: -;; Syntax: -;; ecat ::= (cs | ecat-entry)* -;; cs ::= (s | comment) -;; ecat-entry ::= (pub-entry | file-entry) -;; pub-entry ::= ("PUBLIC", minimal literal, ent-spec?, cat literal) -;; pub-entry ::= ("FILE", literal, ent-spec?, cat literal) -;; ent-spec ::= ("[", (name, literal)*, "]") - -;; Parsed ecat = (eent*) -;; eent = (type ...) -;; = ('public pubid cfile . ents) -;; = ('file file cfile . ents) - -(defun sgml-load-ecat (file) - "Return ecat for FILE." - (sgml-cache-catalog - file 'sgml-ecat-assoc - (function - (lambda () - (let (new type ents from to name val) - (while (progn (sgml-skip-cs) - (setq type (sgml-parse-name))) - (setq type (intern (downcase type))) - (setq ents nil from nil) - (sgml-skip-cs) - (cond - ((eq type 'public) - (setq from (sgml-canonize-pubid (sgml-check-minimum-literal)))) - ((eq type 'file) - (setq from (expand-file-name (sgml-check-cat-literal))))) - (cond - ((null from) - (error "Syntax error in ECAT: %s" file)) - (t - (sgml-skip-cs) - (when (sgml-parse-char ?\[) - (while (progn (sgml-skip-cs) - (setq name (sgml-parse-name t))) - (sgml-skip-cs) - (setq val (sgml-check-literal)) - (push (cons name val) ents)) - (sgml-check-char ?\]) - (sgml-skip-cs)) - (setq to (expand-file-name (sgml-check-cat-literal))) - (push (cons type (cons from (cons to ents))) - new)))) - (nreverse new)))))) - -(defun sgml-ecat-lookup (files pubid file) - "Return (file . ents) or nil." - (let ((params (sgml-dtd-parameters sgml-dtd-info))) - (loop - for f in files - do (sgml-debug "Search ECAT %s" f) - thereis - (loop - for (type name cfile . ents) in (sgml-load-ecat f) - thereis - (if (and (cond ((eq type 'public) (equal name pubid)) - ((eq type 'file) (equal name file))) - (loop for (name . val) in ents - for entity = (sgml-lookup-entity name params) - always (and entity - (equal val (sgml-entity-text entity))))) - (cons cfile ents)))))) - -;;(let ((sgml-dtd-info (sgml-make-dtd nil))) -;; (sgml-ecat-lookup sgml-ecat-files -;; "-//lenst//DTD My DTD//EN//" -;; "/home/u5/lenst/src/psgml/bar.dtd")) - - -;;;; Merge compiled dtd - -(defun sgml-try-merge-compiled-dtd (pubid file) - (when pubid (setq pubid (sgml-canonize-pubid pubid))) - (when file (setq file (expand-file-name file))) - (sgml-debug "Find compiled dtd for %s %s" pubid file) - (let ((ce (or (sgml-ecat-lookup sgml-current-local-ecat pubid file) - (sgml-ecat-lookup sgml-ecat-files pubid file)))) - (and ce - (let ((cfile (car ce)) - (ents (cdr ce))) - (sgml-debug "Found %s" cfile) - (if (sgml-use-special-case) - (sgml-try-merge-special-case pubid file cfile ents) - (and (sgml-bdtd-load cfile file ents) - (sgml-bdtd-merge))))))) - -(defun sgml-use-special-case () - (and (null (sgml-dtd-merged sgml-dtd-info)) - (sgml-eltype-table-empty (sgml-dtd-eltypes sgml-dtd-info)) - (eq 'dtd (sgml-entity-type (sgml-eref-entity sgml-current-eref))))) - -(defun sgml-try-merge-special-case (pubid file cfile ents) - (let (cdtd) - (sgml-debug "Merging special case") - ;; Look for a compiled dtd in som other buffer - (let ((cb (current-buffer))) - (loop for b in (buffer-list) - until - (progn (set-buffer b) - (and sgml-buffer-parse-state - (let ((m (sgml-dtd-merged - (sgml-pstate-dtd sgml-buffer-parse-state)))) - (and m - (string-equal cfile (car m)) - (setq cdtd (cdr m))))))) - (set-buffer cb)) - ;; Load a new compiled dtd - (unless cdtd - (and (sgml-bdtd-load cfile file ents) - (setq cdtd (sgml-bdtd-read-dtd)))) - ;; Do the merger - (cond - ((and cdtd - (sgml-check-entities (sgml-dtd-parameters sgml-dtd-info) - (sgml-dtd-parameters cdtd))) - (setf (sgml-dtd-eltypes sgml-dtd-info) - (sgml-dtd-eltypes cdtd)) - (sgml-merge-entity-tables (sgml-dtd-entities sgml-dtd-info) - (sgml-dtd-entities cdtd)) - (sgml-merge-entity-tables (sgml-dtd-parameters sgml-dtd-info) - (sgml-dtd-parameters cdtd)) - (sgml-merge-shortmaps (sgml-dtd-shortmaps sgml-dtd-info) - (sgml-dtd-shortmaps cdtd)) - (setf (sgml-dtd-dependencies sgml-dtd-info) - (nconc (sgml-dtd-dependencies sgml-dtd-info) - (sgml-dtd-dependencies cdtd))) - (setf (sgml-dtd-merged sgml-dtd-info) (cons cfile cdtd)))))) - - -;;;; Pushing and poping entities - -(defun sgml-push-to-entity (entity &optional ref-start type) - "Set current buffer to a buffer containing the entity ENTITY. -ENTITY can also be a file name. Optional argument REF-START should be -the start point of the entity reference. Optional argument TYPE, -overrides the entity type in entity look up." - (sgml-debug "Push to %s" - (cond ((stringp entity) - (format "string '%s'" entity)) - (t - (sgml-entity-name entity)))) - (when ref-start - ;; don't consider a RS shortref here again - (setq sgml-rs-ignore-pos ref-start)) - (unless (and sgml-scratch-buffer - (buffer-name sgml-scratch-buffer)) - (setq sgml-scratch-buffer (generate-new-buffer " *entity*"))) - (let ((cb (current-buffer)) - (dd default-directory) - ;;*** should eref be argument ? - (eref (sgml-make-eref (if (stringp entity) - (sgml-make-entity entity nil nil) - entity) - (sgml-epos (or ref-start (point))) - (sgml-epos (point))))) - (set-buffer sgml-scratch-buffer) - ;; For MULE to not misinterpret binary data set the mc-flag - ;; (reported by Jeffrey Friedl ) - (setq mc-flag nil) - ;; For XEmacs 20.0/Mule - (setq buffer-file-coding-system 'binary) - (when (eq sgml-scratch-buffer (default-value 'sgml-scratch-buffer)) - (make-local-variable 'sgml-scratch-buffer) - (setq sgml-scratch-buffer nil)) - (when after-change-function ;*** - (message "OOPS: after-change-function not NIL in scratch buffer %s: %s" - (current-buffer) - after-change-function) - (setq before-change-function nil - after-change-function nil)) - (setq sgml-last-entity-buffer (current-buffer)) - (erase-buffer) - (setq default-directory dd) - (make-local-variable 'sgml-current-eref) - (setq sgml-current-eref eref) - (set-syntax-table sgml-parser-syntax) - (make-local-variable 'sgml-previous-buffer) - (setq sgml-previous-buffer cb) - (setq sgml-rs-ignore-pos ; don't interpret beginning of buffer - ; as #RS if internal entity. - (if (or (stringp entity) - (stringp (sgml-entity-text entity))) - (point) - 0)) - (when sgml-buffer-parse-state - (sgml-debug "-- pstate set in scratch buffer") - (setq sgml-buffer-parse-state nil)) - (cond - ((stringp entity) ; a file name - (save-excursion (insert-file-contents entity)) - (setq default-directory (file-name-directory entity))) - ((consp (sgml-entity-text entity)) ; external id? - (let* ((extid (sgml-entity-text entity)) - (file - (sgml-external-file extid - (or type (sgml-entity-type entity)) - (sgml-entity-name entity)))) - (when sgml-parsing-dtd - (push (or file t) - (sgml-dtd-dependencies sgml-dtd-info))) - (sgml-debug "Push to %s = %s" extid file) - (cond - ((and file sgml-parsing-dtd - (sgml-try-merge-compiled-dtd (sgml-extid-pubid extid) - file)) - (goto-char (point-max))) - (file - ;; fifth arg not available in early v19 - (erase-buffer) - (insert-file-contents file nil nil nil) - (setq default-directory (file-name-directory file)) - (goto-char (point-min))) - (t ;; No file for entity - (save-excursion - (let* ((pubid (sgml-extid-pubid extid)) - (sysid (sgml-extid-sysid extid))) - (or (if sysid ; try the sysid hooks - (loop for fn in sgml-sysid-resolve-functions - thereis (funcall fn sysid))) - (progn - ;; Mark entity as not found - (setcdr (cddr entity) t) ;*** - (sgml-log-warning "External entity %s not found" - (sgml-entity-name entity)) - (when pubid - (sgml-log-warning " Public identifier %s" pubid)) - (when sysid - (sgml-log-warning " System identfier %s" sysid)) - nil)))))))) - (t ;; internal entity - (save-excursion - (insert (sgml-entity-text entity))))))) - -(defun sgml-pop-entity () - (cond ((and (boundp 'sgml-previous-buffer) - (bufferp sgml-previous-buffer)) - (sgml-debug "Exit entity") - (setq sgml-last-entity-buffer sgml-previous-buffer) - (set-buffer sgml-previous-buffer) - t))) - -(defun sgml-goto-epos (epos) - "Goto a position in an entity given by EPOS." - (assert epos) - (cond ((sgml-bpos-p epos) - (goto-char epos)) - (t - (let ((eref (sgml-epos-eref epos))) - (sgml-cleanup-entities) - (sgml-goto-epos (sgml-eref-end eref)) - (sgml-push-to-entity (sgml-eref-entity eref) - (sgml-epos-pos (sgml-eref-start eref)))) - (goto-char (sgml-epos-pos epos))))) - -(defun sgml-pop-all-entities () - (while (sgml-pop-entity))) - -(defun sgml-cleanup-entities () - (let ((cb (current-buffer)) - (n 0)) - (while (and sgml-scratch-buffer (buffer-name sgml-scratch-buffer)) - (set-buffer sgml-scratch-buffer) - (assert (not (eq sgml-scratch-buffer - (default-value 'sgml-scratch-buffer)))) - (incf n)) - (while (> n 10) - (set-buffer (prog1 sgml-previous-buffer - (kill-buffer (current-buffer)))) - (decf n)) - (set-buffer cb))) - -(defun sgml-any-open-param/file () - "Return true if there currently is a parameter or file open." - (and (boundp 'sgml-previous-buffer) - sgml-previous-buffer)) - - -;;;; Parse tree - -(defstruct (sgml-tree - (:type vector) - (:constructor sgml-make-tree - (eltype stag-epos stag-len parent level - excludes includes pstate net-enabled - conref &optional shortmap pshortmap asl))) - eltype ; element object - ;;start ; start point in buffer - ;;end ; end point in buffer - stag-epos ; start-tag entity position - etag-epos ; end-tag entity position - stag-len ; length of start-tag - etag-len ; length of end-tag - parent ; parent tree - level ; depth of this node - excludes ; current excluded elements - includes ; current included elements - pstate ; state in parent - next ; next sibling tree - content ; child trees - net-enabled ; if NET enabled (t this element, - ; other non-nil, some parent) - conref ; if conref attribute used - shortmap ; shortmap at start of element - pshortmap ; parents shortmap - asl ; attribute specification list -) - - -(defun sgml-tree-end (tree) - "Buffer position after end of TREE." - (let ((epos (sgml-tree-etag-epos tree)) - (len (sgml-tree-etag-len tree))) - (cond ((sgml-bpos-p epos) - (+ epos len)) - ((zerop len) - (sgml-epos-promote epos)) - (t - (sgml-epos-after epos))))) - - -;;;; (text) Element view of parse tree - -(defmacro sgml-alias-fields (orig dest &rest fields) - (let ((macs nil)) - (while fields - (push - (` (defmacro (, (intern (format "%s-%s" dest (car fields)))) (element) - (, (format "Return %s field of ELEMENT." (car fields))) - (list - '(, (intern (format "%s-%s" orig (car fields)))) - element))) - macs) - (setq fields (cdr fields))) - (cons 'progn macs))) - -(sgml-alias-fields sgml-tree sgml-element - eltype ; element object - ;; start ; start point in buffer - stag-epos - etag-epos - stag-len ; length of start-tag - etag-len ; length of end-tag - parent ; parent tree - level ; depth of this node - excludes ; current excluded elements - includes ; current included elements - pstate ; state in parent - net-enabled ; if NET enabled - ) - -(defun sgml-element-model (element) - "Declared content or content model of ELEMENT." - (sgml-eltype-model (sgml-tree-eltype element))) - -(defun sgml-element-name (element) - "Return name (symbol) of ELEMENT." - (sgml-tree-eltype element)) - -(defun sgml-element-gi (element) - "Return general identifier (string) of ELEMENT." - (sgml-eltype-name (sgml-tree-eltype element))) - -(defun sgml-element-appdata (element prop) - "Return the application data named PROP associated with the type of ELEMENT." - (sgml-eltype-appdata (sgml-tree-eltype element) prop)) - -(defmacro sgml-element-stag-optional (element) - "True if start-tag of ELEMENT is omissible." - (`(sgml-eltype-stag-optional (sgml-tree-eltype (, element))))) - -(defun sgml-element-etag-optional (element) - "True if end-tag of ELEMENT is omissible." - (sgml-eltype-etag-optional (sgml-tree-eltype element))) - -(define-compiler-macro sgml-element-etag-optional (element) - "True if end-tag of ELEMENT is omissible." - (`(sgml-eltype-etag-optional (sgml-tree-eltype (, element))))) - -(defun sgml-element-attlist (element) - "Return the attribute specification list of ELEMENT." - (sgml-eltype-attlist (sgml-tree-eltype element))) - -(defun sgml-element-mixed (element) - "True if ELEMENT has mixed content." - (sgml-eltype-mixed (sgml-tree-eltype element))) - -(define-compiler-macro sgml-element-mixed (element) - (`(sgml-eltype-mixed (sgml-tree-eltype (, element))))) - -(defun sgml-element-start (element) - "Position before start of ELEMENT." - (sgml-epos-promote (sgml-tree-stag-epos element))) - -(defun sgml-element-stag-end (element) - "Position after start-tag of ELEMENT." - (let ((epos (sgml-tree-stag-epos element)) - (len (sgml-tree-stag-len element))) - (cond ((sgml-bpos-p epos) - (+ epos len)) - ((zerop len) - (sgml-epos-promote epos)) - (t - (sgml-epos-after epos))))) - -(defun sgml-element-empty (element) - "True if ELEMENT is empty." - (or (eq sgml-empty (sgml-element-model element)) - (sgml-tree-conref element))) - -(defun sgml-element-data-p (element) - "True if ELEMENT can have data characters in its content." - (or (sgml-element-mixed element) - (eq sgml-cdata (sgml-element-model element)) - (eq sgml-rcdata (sgml-element-model element)))) - -(defun sgml-element-context-string (element) - "Return string describing context of ELEMENT." - (if (eq element sgml-top-tree) - "" - (format "in %s %s" - (sgml-element-gi element) - (sgml-element-context-string (sgml-tree-parent element))))) - -;;;; Display and Mode-line - -(defun sgml-update-display () - (when (not (eq this-command 'keyboard-quit)) - ;; Don't let point be inside an invisible region - (when (and (get-text-property (point) 'invisible) - (eq (get-text-property (point) 'invisible) - (get-text-property (1- (point)) 'invisible))) - (setq sgml-last-element nil) ; May not be valid after point moved - (if (memq this-command '(backward-char previous-line backward-word)) - (goto-char (or (previous-single-property-change (point) 'invisible) - (point-min))) - (goto-char (or (next-single-property-change (point) 'invisible) - (point-max))))) - (when (and (not executing-macro) - (or sgml-live-element-indicator - sgml-set-face) - (not (null sgml-buffer-parse-state)) - (sit-for 0)) - (let ((deactivate-mark nil)) - (sgml-need-dtd) - (let ((start - (save-excursion (sgml-find-start-point (point)) - (sgml-pop-all-entities) - (point))) - (eol-pos - (save-excursion (end-of-line 1) (point)))) - (let ((quiet (< (- (point) start) 500))) - ;;(message "Should parse %s to %s => %s" start (point) quiet) - (when (if quiet - t - (setq sgml-current-element-name "?") - (sit-for 1)) - - ;; Find current element - (cond ((and (memq this-command sgml-users-of-last-element) - sgml-last-element) - (setq sgml-current-element-name - (sgml-element-gi sgml-last-element))) - (sgml-live-element-indicator - (save-excursion - (condition-case nil - (sgml-parse-to - (point) (function input-pending-p) quiet) - (error - (setq sgml-current-element-name "*error*"))) - (unless (input-pending-p) - (setq sgml-current-element-name - (sgml-element-gi sgml-current-tree)))))) - ;; Set face on current line - (when (and sgml-set-face (not (input-pending-p))) - (save-excursion - (condition-case nil - (sgml-parse-to - eol-pos (function input-pending-p) quiet) - (error nil))))))) - ;; Set face in rest of buffer - (sgml-fontify-buffer 6) ;*** make option for delay - )))) - -(defun sgml-fontify-buffer (delay) - (and - sgml-set-face - (null (sgml-tree-etag-epos - (sgml-pstate-top-tree sgml-buffer-parse-state))) - (sit-for delay) - (condition-case nil - (save-excursion - (message "Fontifying...") - (sgml-parse-until-end-of nil nil - (function input-pending-p) - t) - (message "Fontifying...done")) - (error nil)))) - -(defun sgml-set-active-dtd-indicator (name) - (set (make-local-variable 'sgml-active-dtd-indicator) - (list (format " [%s" name) - '(sgml-live-element-indicator ("/" sgml-current-element-name)) - "]")) - (force-mode-line-update)) - -;;;; Parser state - -(defstruct (sgml-pstate - (:constructor sgml-make-pstate (dtd top-tree))) - dtd - top-tree) - -;(defsubst sgml-excludes () -; (sgml-tree-excludes sgml-current-tree)) - -;(defsubst sgml-includes () -; (sgml-tree-includes sgml-current-tree)) - -(defsubst sgml-current-mixed-p () - (sgml-element-mixed sgml-current-tree)) - -(defun sgml-set-initial-state (dtd) - "Set initial state of parsing" - (make-local-variable 'before-change-function) - (setq before-change-function 'sgml-note-change-at) - (make-local-variable 'after-change-function) - (setq after-change-function 'sgml-set-face-after-change) - (sgml-set-active-dtd-indicator (sgml-dtd-doctype dtd)) - (let ((top-type ; Fake element type for the top - ; node of the parse tree - (sgml-make-eltype "#DOC") ; was "Document (no element)" - )) - (setf (sgml-eltype-model top-type) - (sgml-make-primitive-content-token - (sgml-eltype-token - (sgml-lookup-eltype (sgml-dtd-doctype dtd) dtd)))) - (setq sgml-buffer-parse-state - (sgml-make-pstate dtd - (sgml-make-tree top-type - 0 0 nil 0 nil nil nil nil nil))))) - -(defun sgml-set-parse-state (tree where) - "Set parse state from TREE, either from start of TREE if WHERE is start -or from after TREE if WHERE is after." - (setq sgml-current-tree tree - sgml-markup-tree tree - sgml-rs-ignore-pos 0 ) - (let ((empty - (sgml-element-empty tree))) - (cond ((and (eq where 'start) - (not empty)) - (setq sgml-current-state (sgml-element-model sgml-current-tree) - sgml-current-shortmap (sgml-tree-shortmap sgml-current-tree) - sgml-previous-tree nil) - (setq sgml-markup-type - (if (and (not (zerop (sgml-tree-stag-len tree))) - (sgml-bpos-p (sgml-tree-stag-epos tree))) - 'start-tag) - sgml-markup-start (sgml-element-start sgml-current-tree)) - (sgml-goto-epos (sgml-tree-stag-epos sgml-current-tree)) - (forward-char (sgml-tree-stag-len sgml-current-tree))) - (t - (setq sgml-current-state (sgml-tree-pstate sgml-current-tree) - sgml-current-shortmap (sgml-tree-pshortmap sgml-current-tree) - sgml-previous-tree sgml-current-tree) - (sgml-goto-epos (sgml-tree-etag-epos sgml-current-tree)) - (forward-char (sgml-tree-etag-len sgml-current-tree)) - (setq sgml-markup-type (if empty 'start-tag 'end-tag) - sgml-markup-start (- (point) - (sgml-tree-etag-len sgml-current-tree))) - (setq sgml-current-tree (sgml-tree-parent sgml-current-tree)))) - (assert sgml-current-state))) - -(defsubst sgml-final-p (state) - ;; Test if a state/model can be ended - (or (not (sgml-model-group-p state)) - (sgml-final state))) - -;(defun sgml-current-element-contains-data () -; "Retrun true if the current open element is either mixed or is (r)cdata." -; (or (eq sgml-cdata sgml-current-state) -; (eq sgml-rcdata sgml-current-state) -; (sgml-current-mixed-p))) - -;(defun sgml-current-element-content-class () -; "Return a string describing the type of content in the current element. -;The type can be CDATA, RCDATA, ANY, #PCDATA or none." -; (cond ((eq sgml-cdata sgml-current-state) -; "CDATA") -; ((eq sgml-rcdata sgml-current-state) -; "RCDATA") -; ((eq sgml-any sgml-current-state) -; "ANY") -; ((sgml-current-mixed-p) -; "#PCDATA") -; (t ""))) - -(defun sgml-promoted-epos (start end) - "Return an entity position for start of region START END. -If region is empty, choose return an epos as high in the -entity hierarchy as possible." -;; This does not work if the entity is entered by a shortref that -;; only is active in the current element. - (let ((epos (sgml-epos start))) - (when (= start end) - (while (and (sgml-strict-epos-p epos) - (= 1 (sgml-epos-pos epos))) - (setq epos (sgml-eref-start (sgml-epos-eref epos))))) - epos)) - -(defun sgml-open-element (eltype conref before-tag after-tag &optional asl) - (unless (sgml-eltype-defined eltype) - (setf (sgml-eltype-mixed eltype) t) - (setf (sgml-eltype-etag-optional eltype) t) - (when sgml-warn-about-undefined-elements - (sgml-log-warning - "Start-tag of undefined element %s; assume O O ANY" - (sgml-eltype-name eltype)))) - (let* ((emap (sgml-eltype-shortmap eltype)) - (newmap (if emap - (if (eq 'empty emap) - nil - (sgml-lookup-shortref-map - (sgml-dtd-shortmaps sgml-dtd-info) - emap)) - sgml-current-shortmap)) - (nt (sgml-make-tree - eltype - (sgml-promoted-epos before-tag after-tag) ; stag-epos - (- after-tag before-tag) ; stag-len - sgml-current-tree ; parent - (1+ (sgml-tree-level sgml-current-tree)) ; level - (append (sgml-eltype-excludes eltype) - (sgml-tree-excludes sgml-current-tree)) - (append (sgml-eltype-includes eltype) - (sgml-tree-includes sgml-current-tree)) - sgml-current-state - (if (sgml-tree-net-enabled sgml-current-tree) 1) - conref - newmap - sgml-current-shortmap - asl))) -;; (let ((u (sgml-tree-content sgml-current-tree))) -;; (cond ((and u (> before-tag (sgml-element-start u))) -;; (while (and (sgml-tree-next u) -;; (> before-tag -;; (sgml-element-start (sgml-tree-next u)))) -;; (setq u (sgml-tree-next u))) -;; (setf (sgml-tree-next u) nt)) -;; (t -;; (setf (sgml-tree-content sgml-current-tree) nt)))) - ;; Install new node in tree - (cond (sgml-previous-tree - (sgml-debug "Open element %s: after %s" - eltype (sgml-tree-eltype sgml-previous-tree)) - (setf (sgml-tree-next sgml-previous-tree) nt)) - (t - (sgml-debug "Open element %s: first in %s" - eltype (sgml-tree-eltype sgml-current-tree)) - (setf (sgml-tree-content sgml-current-tree) nt))) - ;; Prune tree - ;; *** all the way up? tree-end = nil? - (setf (sgml-tree-next sgml-current-tree) nil) - ;; Set new state - (setq sgml-current-state (sgml-eltype-model eltype) - sgml-current-shortmap newmap - sgml-current-tree nt - sgml-previous-tree nil) - (assert sgml-current-state) - (setq sgml-markup-tree sgml-current-tree) - (run-hook-with-args 'sgml-open-element-hook sgml-current-tree asl) - (when (sgml-element-empty sgml-current-tree) - (sgml-close-element after-tag after-tag)))) - -(defun sgml-fake-open-element (tree el &optional state) - (sgml-make-tree - el 0 0 - tree - 0 - (append (sgml-eltype-excludes el) (sgml-tree-excludes tree)) - (append (sgml-eltype-includes el) (sgml-tree-includes tree)) - state - nil - nil)) - -(defun sgml-close-element (before-tag after-tag) - (when (or (eq sgml-close-element-trap t) - (eq sgml-close-element-trap sgml-current-tree)) - (setq sgml-goal (point))) - (when sgml-throw-on-element-change - (throw sgml-throw-on-element-change 'end)) - (sgml-debug "Close element %s" (sgml-tree-eltype sgml-current-tree)) - (setf (sgml-tree-etag-epos sgml-current-tree) - ;;(sgml-promoted-epos before-tag after-tag) - (sgml-epos before-tag)) - (setf (sgml-tree-etag-len sgml-current-tree) (- after-tag before-tag)) - (run-hooks 'sgml-close-element-hook) - (setq sgml-markup-tree sgml-current-tree) - (cond ((eq sgml-current-tree sgml-top-tree) - (unless (eobp) - (sgml-error "Parse ended"))) - (t - (setq sgml-previous-tree sgml-current-tree - sgml-current-state (sgml-tree-pstate sgml-current-tree) - sgml-current-shortmap (sgml-tree-pshortmap sgml-current-tree) - sgml-current-tree (sgml-tree-parent sgml-current-tree)) - (assert sgml-current-state)))) - -(defun sgml-fake-close-element (tree) - (sgml-tree-parent tree)) - -(defun sgml-note-change-at (at &optional end) - ;; Inform the cache that there have been some changes after AT - (when sgml-buffer-parse-state - (sgml-debug "sgml-note-change-at %s" at) - (let ((u (sgml-pstate-top-tree sgml-buffer-parse-state))) - (when u - ;;(message "%d" at) - (while - (cond - ((and (sgml-tree-next u) ; Change clearly in next element - (> at (sgml-element-stag-end (sgml-tree-next u)))) - (setq u (sgml-tree-next u))) - (t ; - (setf (sgml-tree-next u) nil) ; Forget next element - (cond - ;; If change after this element and it is ended by an end - ;; tag no pruning is done. If the end of the element is - ;; implied changing the tag that implied it may change - ;; the extent of the element. - ((and (sgml-tree-etag-epos u) - (> at (sgml-tree-end u)) - (or (> (sgml-tree-etag-len u) 0) - (sgml-element-empty u))) - nil) - (t - (setf (sgml-tree-etag-epos u) nil) - (cond;; Enter into content if change is clearly in it - ((and (sgml-tree-content u) - (> at (sgml-element-stag-end (sgml-tree-content u)))) - (setq u (sgml-tree-content u))) - ;; Check if element has no start tag, - ;; then it must be pruned as a change could create - ;; a valid start tag for the element. - ((and (zerop (sgml-tree-stag-len u)) - (> at (sgml-element-start u))) - ;; restart from to with new position - ;; this can't loop forever as - ;; position allways gets smaller - (setq at (sgml-element-start u) - u sgml-top-tree)) - (t - (setf (sgml-tree-content u) nil)))))))))))) - -(defun sgml-list-implications (token type) - "Return a list of the tags implied by a token TOKEN. -TOKEN is a token, and the list elements are either tokens or `t'. -Where the latter represents end-tags." - (let ((state sgml-current-state) - (tree sgml-current-tree) - (temp nil) - (imps nil)) - (while ; Until token accepted - (cond - ;; Test if accepted in state - ((or (eq state sgml-any) - (and (sgml-model-group-p state) - (not (memq token (sgml-tree-excludes tree))) - (or (memq token (sgml-tree-includes tree)) - (sgml-get-move state token)))) - nil) - ;; Test if end tag implied - ((or (eq state sgml-empty) - (and (sgml-final-p state) - (not (eq tree sgml-top-tree)))) - (unless (eq state sgml-empty) ; not realy implied - (push t imps)) - (setq state (sgml-tree-pstate tree) - tree (sgml-fake-close-element tree)) - t) - ;; Test if start-tag can be implied - ((and (setq temp (sgml-required-tokens state)) - (null (cdr temp))) - (setq temp (car temp) - tree (sgml-fake-open-element tree temp - (sgml-get-move state temp)) - state (sgml-element-model tree)) - (push temp imps) - t) - ;; No implictions and not accepted - (t - (sgml-log-warning "Out of context %s" type) - (setq imps nil)))) - ;; Return the implications in correct order - (nreverse imps))) - - -(defun sgml-eltypes-in-state (tree state) - "Return list of element types (eltype) valid in STATE and TREE." - (let* ((req ; Required tokens - (if (sgml-model-group-p state) - (sgml-required-tokens state))) - (elems ; Normally valid tokens - (if (sgml-model-group-p state) - (nconc req - (delq sgml-pcdata-token (sgml-optional-tokens state)))))) - ;; Modify for exceptions - (loop for et in (sgml-tree-includes tree) ;*** Tokens or eltypes? - unless (memq et elems) do (push et elems)) - (loop for et in (sgml-tree-excludes tree) - do (setq elems (delq et elems))) - ;; Check for omitable start-tags - (when (and sgml-omittag-transparent - (not (sgml-final-p state)) - req - (null (cdr req))) - (let ((et (sgml-token-eltype (car req)))) - (when (sgml-eltype-stag-optional et) - (setq elems - (nconc elems ; *** possibility of duplicates - (sgml-eltypes-in-state - (sgml-fake-open-element tree et) - (sgml-eltype-model et))))))) - elems)) - -(defun sgml-current-list-of-valid-eltypes () - "Returns a list of contextually valid element types (eltype)." - (let ((elems (sgml-eltypes-in-state sgml-current-tree sgml-current-state)) - (tree sgml-current-tree) - (state sgml-current-state)) - (when sgml-omittag-transparent - (while (and tree - (sgml-final-p state) - (sgml-element-etag-optional tree)) - (setq state (sgml-tree-pstate tree) - tree (sgml-tree-parent tree)) - (loop for e in (sgml-eltypes-in-state tree state) do - (when (not (memq e elems)) - (setq elems (nconc elems (list e))))))) - ;; *** Filter out elements that are undefined? - (sort elems (function string-lessp)))) - -(defun sgml-current-list-of-endable-eltypes () - "Return a list of the element types endable in current state." - (let* ((elems nil) - (tree sgml-current-tree) - (state sgml-current-state)) - (while - (and (sgml-final-p state) - (not (eq tree sgml-top-tree)) - (progn - (setq elems - (nconc elems (list (sgml-tree-eltype tree)))) - sgml-omittag) - (sgml-eltype-etag-optional (sgml-tree-eltype tree))) - (setq state (sgml-tree-pstate tree) - tree (sgml-tree-parent tree))) - elems)) - -;;;; Logging of warnings - -(defconst sgml-log-buffer-name "*SGML LOG*") - -(defvar sgml-log-last-size 0) - -(defun sgml-display-log () - (let ((buf (get-buffer sgml-log-buffer-name))) - (when buf - (display-buffer buf) - (setq sgml-log-last-size (save-excursion (set-buffer buf) - (point-max)))))) - -(defun sgml-log-warning (format &rest things) - (when sgml-throw-on-warning - (apply 'message format things) - (throw sgml-throw-on-warning t)) - (when (or sgml-show-warnings sgml-parsing-dtd) - (apply 'sgml-message format things) - (apply 'sgml-log-message format things))) - -(defun sgml-log-message (format &rest things) - (let ((mess (apply 'format format things)) - (buf (get-buffer-create sgml-log-buffer-name)) - (cb (current-buffer))) - (set-buffer buf) - (goto-char (point-max)) - (insert mess "\n") - (when (get-buffer-window buf) - (setq sgml-log-last-size (point-max))) - (set-buffer cb))) - -(defun sgml-error (format &rest things) - (when sgml-throw-on-error - (throw sgml-throw-on-error nil)) - (while (and (boundp 'sgml-previous-buffer) sgml-previous-buffer) - (when sgml-current-eref - (sgml-log-message - "Line %s in %S " - (count-lines (point-min) (point)) - (sgml-entity-name (sgml-eref-entity sgml-current-eref)))) - (sgml-pop-entity)) - (apply 'sgml-log-warning format things) - (apply 'error format things)) - -(defun sgml-parse-error (format &rest things) - (apply 'sgml-error - (concat format "; at: %s") - (append things (list (buffer-substring-no-properties - (point) - (min (point-max) (+ (point) 12))))))) - -(defun sgml-message (format &rest things) - (let ((buf (get-buffer sgml-log-buffer-name))) - (when (and buf - (> (save-excursion (set-buffer buf) - (point-max)) - sgml-log-last-size)) - (sgml-display-log))) - (apply 'message format things)) - -(defun sgml-reset-log () - (let ((buf (get-buffer sgml-log-buffer-name))) - (when buf - (setq sgml-log-last-size - (save-excursion (set-buffer buf) - (point-max)))))) - -(defun sgml-clear-log () - (let ((b (get-buffer sgml-log-buffer-name))) - (when b - (delete-windows-on b) - (kill-buffer b) - (setq sgml-log-last-size 0)))) - -(defun sgml-show-or-clear-log () - "Show the *SGML LOG* buffer if it is not showing, or clear and -remove it if it is showing." - (interactive) - (cond ((and (get-buffer sgml-log-buffer-name) - (null (get-buffer-window sgml-log-buffer-name))) - (sgml-display-log)) - (t - (sgml-clear-log)))) - - - -;;; This has noting to do with warnings... - -(defvar sgml-lazy-time 0) - -(defun sgml-lazy-message (&rest args) - (unless (= sgml-lazy-time (second (current-time))) - (apply 'message args) - (setq sgml-lazy-time (second (current-time))))) - -;;;; Shortref maps - -(eval-and-compile - (defconst sgml-shortref-list - '( - "\t" ;&#TAB - "\n" ;&#RE; - "\001" ;&#RS; - "\001B" - "\001\n" - "\001B\n" - "B\n" - " " ;&#SPACE; - "BB" - "\"" ;" - "#" - "%" - "'" - "(" - ")" - "*" - "+" - "," - "-" - "--" - ":" - ";" - "=" - "@" - "[" - "]" - "^" - "_" - "{" - "|" - "}" - "~"))) - -(eval-and-compile - (defun sgml-shortref-index (string) - (let ((pos (member string sgml-shortref-list)) - (len (length sgml-shortref-list))) - (and pos (- len (length pos))) ))) - -(defun sgml-make-shortmap (pairs) - "Create a shortreference map from PAIRS. -Where PAIRS is a list of (delim . ename)." - (let ((map - (make-vector (1+ (length sgml-shortref-list)) - nil)) - index) - (loop for p in pairs - for delim = (car p) - for name = (cdr p) - do - (setq index (sgml-shortref-index delim)) - (cond ((null index) - (sgml-log-warning - "Illegal short reference delimiter '%s'" delim)) - (t - (aset map index name)))) - ;; Compute a suitable string for skip-chars-forward that - ;; can be used to skip over pcdata - (aset map - (eval-when-compile (length sgml-shortref-list)) - (if (some (function - (lambda (r) (aref map (sgml-shortref-index r)))) - '("\001B\n" "B\n" " " "BB")) - "^<]/& \n\t\"#%'()*+,\\-:;=@[]\\^_{|}~" - "^<]/&\n\t\"#%'()*+,\\-:;=@[]\\^_{|}~")) - map)) - -(defun sgml-shortmap-skipstring (map) - (if (bolp) - "" - (aref map (eval-when-compile (length sgml-shortref-list))))) - - -(defconst sgml-shortref-oneassq - (loop for d in sgml-shortref-list - for c = (aref d 0) - when (and (= 1 (length d)) - (/= 1 c) (/= 10 c)) - collect (cons c (sgml-shortref-index d)))) - -(defun sgml-parse-B () - (/= 0 (skip-chars-forward " \t"))) - -(defun sgml-deref-shortmap (map &optional nobol) - "Identify shortref delimiter at point and return entity name. -Also move point. Return nil, either if no shortref or undefined." - - (macrolet - ((delim (x) (` (aref map (, (sgml-shortref-index x)))))) - (let ((i (if nobol 1 0))) - (while (numberp i) - (setq i - (cond - ((and (bolp) (zerop i)) ; Either "\001" "\001B" - ; "\001\n" "\001B\n" - (cond ((sgml-parse-B) ; "\001B" - (if (eolp) - (delim "\001B\n") - (delim "\001B"))) - ((sgml-parse-RE) (delim "\001\n")) - ((delim "\001")) - (t 1))) - ((cond ((sgml-parse-char ?\t) (setq i (delim "\t")) t) - ((sgml-parse-char ? ) (setq i (delim " ")) t)) - (cond ((sgml-parse-B) (setq i (delim "BB")))) - (cond ((sgml-parse-char ?\n) - (delim "B\n")) - (t i))) - ((sgml-parse-RE) (delim "\n")) - ((sgml-parse-chars ?- ?-) (delim "--")) - ;; The other one character delimiters - ((setq i (assq (following-char) sgml-shortref-oneassq)) - (when i (forward-char 1)) - (aref map (cdr i)))))) - i))) - -;;; Table of shortref maps - -(defun sgml-make-shortref-table () - (list nil)) - -(defun sgml-add-shortref-map (table name map) - (nconc table (list (cons name map)))) - -(defun sgml-lookup-shortref-map (table name) - (cdr (assoc name (cdr table)))) - -(defun sgml-lookup-shortref-name (table map) - (car (rassq map (cdr table)))) - -(defun sgml-merge-shortmaps (tab1 tab2) - "Merge tables of short reference maps TAB2 into TAB1, modifying TAB1." - (nconc tab1 (cdr tab2))) - -;;;; Parse markup declarations - -(defun sgml-skip-until-dsc () - (while (progn - (sgml-skip-upto ("DSO" "DSC" "LITA" "LIT" "COM")) - (not (sgml-parse-delim "DSC"))) - (cond ((sgml-parse-literal)) - ((sgml-parse-delim "DSO") - (sgml-skip-until-dsc)) - ((sgml-parse-comment)) - (t (forward-char 1))))) - -(defun sgml-skip-upto-mdc () - "Move point forward until end of current markup declaration. -Assumes starts with point inside a markup declaration." - (while (progn - (sgml-skip-upto ("DSO" "MDC" "LIT" "LITA" "COM")) - (not (sgml-is-delim "MDC"))) - (cond ((sgml-parse-delim "DSO") - (sgml-skip-until-dsc)) - ((sgml-parse-literal)) - ((sgml-parse-comment)) - (t (forward-char 1))))) - -(defun sgml-do-sgml-declaration () - (sgml-skip-upto-mdc) - (setq sgml-markup-type 'sgml)) - -(defun sgml-do-doctype () - (cond - (sgml-dtd-info ; Has doctype already been defined - (sgml-skip-upto-mdc)) - (t - (let (sgml-markup-start) - (message "Parsing doctype...") - (sgml-setup-doctype (sgml-check-name) - (sgml-parse-external)) - (message "Parsing doctype...done")))) - (setq sgml-markup-type 'doctype)) - -(defun sgml-check-end-of-entity (type) - (unless (eobp) - (sgml-parse-error "Illegal character '%c' in %s" - (following-char) - type))) - -(defun sgml-setup-doctype (docname external) - (let ((sgml-parsing-dtd t)) - (setq sgml-no-elements 0) - (setq sgml-dtd-info (sgml-make-dtd docname)) - ;;(setq sgml-dtd-shortmaps nil) - (sgml-skip-ps) - (cond - ((sgml-parse-delim "DSO") - (let ((original-buffer (current-buffer))) - (sgml-check-dtd-subset) - (if (eq (current-buffer) original-buffer) - (sgml-check-delim "DSC") - (sgml-parse-error "Illegal character '%c' in doctype declaration" - (following-char)))))) - (cond (external - (sgml-push-to-entity (sgml-make-entity docname 'dtd external)) - (sgml-check-dtd-subset) - (sgml-check-end-of-entity "DTD subset") - (sgml-pop-entity))) -;;; (loop for map in sgml-dtd-shortmaps do -;;; (sgml-add-shortref-map -;;; (sgml-dtd-shortmaps sgml-dtd-info) -;;; (car map) -;;; (sgml-make-shortmap (cdr map)))) - (sgml-set-initial-state sgml-dtd-info) - (run-hooks 'sgml-doctype-parsed-hook))) - -(defun sgml-do-data (type &optional marked-section) - "Move point forward until there is an end-tag open after point." - (let ((start (point)) - (done nil) - (eref sgml-current-eref) - sgml-signal-data-function) - (while (not done) - (cond (marked-section - (skip-chars-forward (if (eq type sgml-cdata) "^]" "^&]")) - (when sgml-data-function - (funcall sgml-data-function (buffer-substring-no-properties - start (point)))) - (setq done (sgml-parse-delim "MS-END"))) - (t - (skip-chars-forward (if (eq type sgml-cdata) "^ (- sgml-goal (point)) 10000)))) - (when bigparse - (sgml-message "Parsing...")) - (sgml-with-parser-syntax - (sgml-parser-loop extra-cond)) - (when bigparse - (sgml-message "")))) - -(defun sgml-parse-continue (sgml-goal &optional extra-cond quiet) - "Parse until (at least) SGML-GOAL." - (assert sgml-current-tree) - (unless quiet - (sgml-message "Parsing...")) - (sgml-with-parser-syntax - (sgml-parser-loop extra-cond)) - (unless quiet - (sgml-message ""))) - -(defun sgml-reparse-buffer (shortref-fun) - "Reparse the buffer and let SHORTREF-FUN take care of short references. -SHORTREF-FUN is called with the entity as argument and `sgml-markup-start' -pointing to start of short ref and point pointing to the end." - (sgml-note-change-at (point-min)) - (let ((sgml-shortref-handler shortref-fun)) - (sgml-parse-until-end-of nil))) - -(defun sgml-move-current-state (token) - (setq sgml-current-state - (or (sgml-get-move sgml-current-state token) - sgml-current-state))) - -(defun sgml-execute-implied (imps type) - (loop for token in imps do - (if (eq t token) - (sgml-implied-end-tag type sgml-markup-start sgml-markup-start) - (sgml-move-current-state token) - (when sgml-throw-on-element-change - (throw sgml-throw-on-element-change 'start)) - (sgml-open-element (sgml-token-eltype token) - nil sgml-markup-start sgml-markup-start) - (unless (and sgml-current-omittag - (sgml-element-stag-optional sgml-current-tree)) - (sgml-log-warning - "%s start-tag implied by %s; not minimizable" - (sgml-eltype-name (sgml-token-eltype token)) - type))))) - -(defun sgml-do-move (token type) - (sgml-execute-implied (sgml-list-implications token type) type) - (unless (eq sgml-any sgml-current-state) - (sgml-move-current-state token))) - -(defun sgml-pcdata-move () - "Moify parser state to reflect parsed data." - (sgml-do-move sgml-pcdata-token "data character")) - -(defsubst sgml-parse-pcdata () - (/= 0 - (if sgml-current-shortmap - (skip-chars-forward (sgml-shortmap-skipstring sgml-current-shortmap)) - (skip-chars-forward "^<]/&")))) - -(defsubst sgml-do-pcdata () - ;; Parse pcdata - (sgml-pcdata-move) - ;;*** assume sgml-markup-start = point - ;;*** should perhaps handle &#nn;? - (forward-char 1) - (sgml-parse-pcdata) - (when sgml-data-function - (funcall sgml-data-function (buffer-substring-no-properties - sgml-markup-start - (point)))) - (sgml-set-markup-type nil)) - -(defun sgml-parser-loop (extra-cond) - (let (tem - (sgml-signal-data-function (function sgml-pcdata-move))) - (while (and (eq sgml-current-tree sgml-top-tree) - (or (< (point) sgml-goal) sgml-current-eref) - (progn (setq sgml-markup-start (point) - sgml-markup-type nil) - (or (sgml-parse-s) - (sgml-parse-markup-declaration 'prolog) - (sgml-parse-processing-instruction))))) - (while (and (or (< (point) sgml-goal) sgml-current-eref) - (not (if extra-cond (funcall extra-cond)))) - (assert sgml-current-tree) - (setq sgml-markup-start (point) - sgml-markup-type nil) - (cond - ((eobp) (sgml-pop-entity)) - ((and (or (eq sgml-current-state sgml-cdata) - (eq sgml-current-state sgml-rcdata))) - (if (or (sgml-parse-delim "ETAGO" gi) - (sgml-is-enabled-net)) - (sgml-do-end-tag) - (sgml-do-data sgml-current-state))) - ((and sgml-current-shortmap - (or (setq tem (sgml-deref-shortmap sgml-current-shortmap - (eq (point) - sgml-rs-ignore-pos))) - ;; Restore position, to consider the delim for S+ or data - (progn (goto-char sgml-markup-start) - nil))) - (setq sgml-rs-ignore-pos sgml-markup-start) ; don't reconsider RS - (funcall sgml-shortref-handler tem)) - ((and (not (sgml-current-mixed-p)) - (sgml-parse-s sgml-current-shortmap))) - ((or (sgml-parse-delim "ETAGO" gi) - (sgml-is-enabled-net)) - (sgml-do-end-tag)) - ((sgml-parse-delim "STAGO" gi) - (sgml-do-start-tag)) - ((sgml-parse-general-entity-ref)) - ((sgml-parse-markup-declaration nil)) - ((sgml-parse-delim "MS-END") ; end of marked section - (sgml-set-markup-type 'ms-end)) - ((sgml-parse-processing-instruction)) - (t - (sgml-do-pcdata)))))) - -(defun sgml-handle-shortref (name) - (sgml-set-markup-type 'shortref) - (sgml-do-entity-ref name)) - -(defun sgml-do-start-tag () - ;; Assume point after STAGO - (when sgml-throw-on-element-change - (throw sgml-throw-on-element-change 'start)) - (setq sgml-conref-flag nil) - (let (net-enabled et asl) - (setq et (if (sgml-is-delim "TAGC") ; empty start-tag - (sgml-do-empty-start-tag) - (sgml-lookup-eltype (sgml-check-name)))) - (unless (sgml-parse-delim "TAGC") ; optimize common case - (setq asl (sgml-parse-attribute-specification-list et)) - (or - (if (sgml-parse-delim "NET") - (prog1 (setq net-enabled t) - (or sgml-current-shorttag - (sgml-log-warning - "NET enabling start-tag is not allowed with SHORTTAG NO")))) - (sgml-check-tag-close))) - (sgml-set-markup-type 'start-tag) - (cond ((and sgml-ignore-undefined-elements - (not (sgml-eltype-defined et))) - (when sgml-warn-about-undefined-elements - (sgml-log-warning - "Start-tag of undefined element %s; ignored" - (sgml-eltype-name et)))) - (t - (sgml-do-move (sgml-eltype-token et) - (format "%s start-tag" (sgml-eltype-name et))) - (sgml-open-element et sgml-conref-flag - sgml-markup-start (point) asl) - (when net-enabled - (setf (sgml-tree-net-enabled sgml-current-tree) t)))))) - - -(defun sgml-do-empty-start-tag () - "Return eltype to use if empty start tag" - (cond - ;; Document element if no element is open - ((eq sgml-current-tree sgml-top-tree) - (sgml-lookup-eltype - (sgml-dtd-doctype sgml-dtd-info))) - ;; If omittag use current open element - (sgml-current-omittag - (sgml-tree-eltype sgml-current-tree)) - ;; Find the eltype of the last closed element. - ;; If element has a left sibling then use that - (sgml-previous-tree - (sgml-tree-eltype sgml-previous-tree)) - ;; No sibling, last closed must be found in enclosing element - (t - (loop named outer - for current = sgml-current-tree then (sgml-tree-parent current) - for parent = (sgml-tree-parent current) - do;; Search for a parent with a child before current - (when (eq parent sgml-top-tree) - (sgml-error "No previously closed element")) - (unless (eq current (sgml-tree-content parent)) - ;; Search content of u for element before current - (loop for c = (sgml-tree-content parent) then (sgml-tree-next c) - do (when (eq current (sgml-tree-next c)) - (return-from outer (sgml-tree-eltype c))))))))) - - -(defun sgml-do-end-tag () - "Assume point after goal (sgml-tree-stag-epos tree)) - (>= goal (sgml-epos-after (sgml-tree-stag-epos tree)))))) - -(defun sgml-find-start-point (goal) - (let ((u sgml-top-tree)) - (while - (cond - ((sgml-is-goal-after-start goal (sgml-tree-next u)) - (setq u (sgml-tree-next u))) - ((and (sgml-tree-etag-epos u) - (if (> (sgml-tree-etag-len u) 0) ; if threre is an end-tag - (>= goal (sgml-tree-end u)) ; precisely after is after - (> goal (sgml-tree-end u)))) ; else it could possibly - ; become part of the element - (sgml-set-parse-state u 'after) - nil) - ((sgml-is-goal-after-start goal (sgml-tree-content u)) - (setq u (sgml-tree-content u))) - (t - (sgml-set-parse-state u 'start) - nil))) - ) - ) - - -(defun sgml-check-tag-close () - (or - (sgml-parse-delim "TAGC") - (if (or (sgml-is-delim "STAGO" gi) - (sgml-is-delim "ETAGO" gi)) - (or sgml-current-shorttag - (sgml-log-warning - "Unclosed tag is not allowed with SHORTTAG NO") - t)) - (sgml-error "Invalid character in markup %c" - (following-char)))) - -(defun sgml-implied-end-tag (type start end) - (cond ((eq sgml-current-tree sgml-top-tree) - (unless (= start (point-max)) - (sgml-error - "document ended by %s" type))) - ((not - (and sgml-current-omittag - (sgml-element-etag-optional sgml-current-tree))) - (sgml-log-warning - "%s end-tag implied by %s; not minimizable" - (sgml-element-gi sgml-current-tree) - type))) - (sgml-close-element start end)) - - -;;;; Parsing tasks and extending the element view of the parse tree - -(defun sgml-find-context-of (pos) - "Find the parser context for POS, returns the parse tree. -Also sets sgml-current-tree and sgml-current-state. If POS is in -markup, sgml-markup-type will be a symbol identifying the markup -type. It will be nil otherwise." - (save-excursion - (sgml-parse-to pos) - (cond ((and (> (point) pos) - sgml-markup-type) - ;;(setq sgml-current-state sgml-markup-type) - (cond ((memq sgml-markup-type '(start-tag end-tag)) - (setq sgml-current-tree sgml-markup-tree)))) - (t - (setq sgml-markup-type nil))) - sgml-current-tree)) - -(defun sgml-parse-to-here () - "Find context of point. -See documentation of sgml-find-context-of." - (sgml-find-context-of (point))) - -(defun sgml-find-element-of (pos) - "Find the element containing character at POS." - (when (eq pos (point-max)) - (error "End of buffer")) - (save-excursion - (sgml-parse-to (1+ pos)) ; Ensures that the element is - ; in the tree. - ;; Find p in u: - ;; assert p >= start(u) - ;; if next(u) and p >= start(next(u)): find p in next(u) - ;; else if end(u) and p >= end(u): in parent(u) unless u is top - ;; else if content: - ;; if p < start(content(u)): in u - ;; else find p in content(u) - ;; else: in u - (let ((u sgml-top-tree)) - (while ; pos >= start(u) - (cond ((and (sgml-tree-next u) - (>= pos (sgml-element-start (sgml-tree-next u)))) - (setq u (sgml-tree-next u))) ; continue searching next node - ((and (sgml-tree-etag-epos u) - (>= pos (sgml-tree-end u))) - (setq u (sgml-tree-parent u)) ; must be parent node - nil) - ((and (sgml-tree-content u) - (>= pos (sgml-element-start (sgml-tree-content u)))) - (setq u (sgml-tree-content u))))) ; search content - u))) - -(defun sgml-find-previous-element (pos &optional in-element) - "Find the element before POS and return it, error if non found. -If in IN-ELEMENT is given look for previous element in IN-ELEMENT else -look in current element. If this element has no content elements but -end at POS, it will be returned as previous element." - (save-excursion - ;; Parse to point; now the previous element is in the parse tree - (sgml-parse-to pos) - ;; containing element may be given or obtained from parser - (or in-element (setq in-element sgml-current-tree)) - ;; in-element is the containing element - (let* ((c ; this is the content of the - ; containing element - (sgml-tree-content in-element))) - (while - (cond - ((null c) ; If c = Nil: no previous element. - ;; But maybe the containing element ends at pos too. - (cond ((= pos (sgml-element-end in-element)) - (setq c in-element))) ; Previous is parent! - nil) - ((<= pos (sgml-element-start c)) ; Pos before first content el - (setq c nil)) ; No, previous element. - ((null (sgml-tree-next c)) nil) ; No next, c must be the prev el - ((>= (sgml-element-start (sgml-tree-next c)) pos) - nil) - (t - (setq c (sgml-tree-next c))))) - (or c - (error "No previous element in %s element" - (sgml-element-gi in-element)))))) - -(defun sgml-find-element-after (pos &optional in-element) - "Find the first element starting after POS. -Returns parse tree; error if no element after POS." - (setq in-element (or in-element - (save-excursion (sgml-find-context-of pos)))) - (or - ;; First try to find element after POS in IN-ELEMENT/current element - (let ((c ; content of in-element - (sgml-element-content in-element))) - (while (and c - (> pos (sgml-element-start c))) - (setq c (sgml-element-next c))) - c) - ;; If there is no more elements IN-ELEMENT/current element try - ;; to identify the element containing the character after POS. - ;; If this element starts at POS, use it for element after POS. - (let ((el (sgml-find-element-of pos))) - (if (and el (= pos (sgml-element-start el))) - el)) - (progn - (sgml-message "") ; force display of log buffer - (error "No more elements in %s element" - (sgml-element-gi in-element))))) - -(defun sgml-element-content (element) - "First element in content of ELEMENT, or nil." - (when (null (or (sgml-tree-content element) - (sgml-tree-etag-epos element))) - (save-excursion (sgml-parse-until-end-of t))) - (sgml-tree-content element)) - -(defun sgml-element-next (element) - "Next sibling of ELEMENT." - (unless (sgml-tree-etag-epos element) - (save-excursion (sgml-parse-until-end-of element))) - (unless (or (sgml-tree-next element) - (sgml-tree-etag-epos (sgml-tree-parent element))) - (save-excursion (sgml-parse-until-end-of t))) - (sgml-tree-next element)) - -(defun sgml-element-etag-start (element) - "Last position in content of ELEMENT and start of end-tag, if any." - (unless (sgml-tree-etag-epos element) - (save-excursion - (sgml-parse-until-end-of element))) - (assert (sgml-tree-etag-epos element)) - (sgml-epos-promote (sgml-tree-etag-epos element))) - -(defun sgml-element-end (element) - "First position after ELEMENT." - (sgml-element-etag-start element) ; make end be defined - (sgml-tree-end element)) - -(defun sgml-read-element-name (prompt) - (sgml-parse-to-here) - (cond (sgml-markup-type - (error "No elements allowed in markup")) - ((and ;;sgml-buffer-eltype-map - (not (eq sgml-current-state sgml-any))) - (let ((tab - (mapcar (function (lambda (x) (cons (symbol-name x) nil))) - (sgml-current-list-of-valid-eltypes)))) - (cond ((null tab) - (error "No element valid at this point")) - (t - (completing-read prompt tab nil t - (and (null (cdr tab)) (caar tab))))))) - (t - (read-from-minibuffer prompt)))) - -(defun sgml-element-attribute-specification-list (element) - "Return the attribute specification list for ELEMENT. -This is a list of (attname value) lists." -;;; (if (> (sgml-element-stag-len element) 2) -;;; (save-excursion -;;; (sgml-with-parser-syntax -;;; (sgml-goto-epos (sgml-element-stag-epos element)) -;;; (sgml-check-delim "STAGO") -;;; (sgml-check-name) -;;; (prog1 (sgml-parse-attribute-specification-list -;;; (sgml-element-eltype element)) -;;; (sgml-pop-all-entities))))) - (sgml-tree-asl element)) - -(defun sgml-find-attribute-element () - "Return the element to which an attribute editing command should be applied." - (let ((el (sgml-find-element-of (point)))) - (save-excursion - (sgml-parse-to (point)) - ;; If after a start-tag of an empty element return that element - ;; instead of current element - (if (eq sgml-markup-type 'start-tag) - sgml-markup-tree ; the element of the start-tag - el)))) - - -(defun sgml-element-attval (element attribute) - "Return the value of the ATTRIBUTE in ELEMENT, string or nil." - (let ((asl (sgml-element-attribute-specification-list element)) - (def (sgml-attdecl-default-value - (sgml-lookup-attdecl attribute (sgml-element-attlist element))))) - (or (sgml-attspec-attval (sgml-lookup-attspec attribute asl)) - (sgml-default-value-attval def)))) - - -(defun sgml-cohere-name (x) - "Convert X into a string where X can be a string, a symbol or an element." - (cond ((stringp x) x) - ((symbolp x) (symbol-name x)) - (t (sgml-element-gi x)))) - -(defun sgml-start-tag-of (element) - "Return the start-tag for ELEMENT." - (format "<%s>" (sgml-cohere-name element))) - -(defun sgml-end-tag-of (element) - "Return the end-tag for ELEMENT (token or element)." - (format "" (sgml-cohere-name element))) - -(defun sgml-top-element () - "Return the document element." - (sgml-element-content (sgml-find-context-of (point-min)))) - -(defun sgml-off-top-p (element) - "True if ELEMENT is the pseudo element above the document element." - (null (sgml-tree-parent element))) - -(defun sgml-safe-context-of (pos) - (let ((sgml-throw-on-error 'parse-error)) - (catch sgml-throw-on-error - (sgml-find-context-of pos)))) - -(defun sgml-safe-element-at (pos) - (let ((sgml-throw-on-error 'parse-error)) - (catch sgml-throw-on-error - (if (= pos (point-max)) - (sgml-find-context-of pos) - (sgml-find-element-of pos))))) - -(defun sgml-in-prolog-p () - (let ((el (sgml-safe-context-of (point)))) - (or (null el) - (sgml-off-top-p el)))) - - -;;;; Provide - -(provide 'psgml-parse) - -;; Local variables: -;; byte-compile-warnings:(free-vars unresolved callargs redefine) -;; End: -;;; psgml-parse.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-style.fs --- a/lisp/psgml/psgml-style.fs Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -;;; style.fs --- example style file for fs.el and catalog.sgml -*- lisp -*- - -( - ("example" - default-top 1 - default-bottom 1) - ("front") - ("body") - ("pubfront" text "") - ("abstract" - block t - before (block t text "ABSTRACT") - left 4) - ("p" block t) - ("title" block t) - ("titlegrp" block t bottom 2 default-bottom 0 default-top 0) - ("subtitle" before (text " // ")) - ("list" block t) - ("head" block t) - ("item" - left (+ (fs-char 'left) 3) - hang-from " * ") - ("keyword" - before (text "|") - after (text "|")) - ("chapter" block t top 2 before (text "CHAPTER")) - ("lit" block t literal t) - (t - before (text (format "<%s>" (sgml-element-gi e))) - after (text " ") - ) -) diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml-xemacs.el --- a/lisp/psgml/psgml-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,255 +0,0 @@ -;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support -;; $Id: psgml-xemacs.el,v 1.2 1997/04/24 04:00:12 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin -;; William M. Perry -;; Synced up with Ben Wing's changes for XEmacs 19.14 by -;; Steven L Baur - -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;;; Part of psgml.el - -;;; Menus for use with XEmacs - - -;;;; Code: - -(require 'psgml) -;;(require 'easymenu) - -(eval-and-compile - (autoload 'sgml-do-set-option "psgml-edit")) - -(defvar sgml-max-menu-size (/ (* (frame-height) 2) 3) - "*Max number of entries in Tags and Entities menus before they are split -into several panes.") - -;;;; Pop Up Menus - -(defun sgml-popup-menu (event title entries) - "Display a popup menu." - (setq entries - (loop for ent in entries collect - (vector (car ent) - (list 'setq 'value (list 'quote (cdr ent))) - t))) - (cond ((> (length entries) sgml-max-menu-size) - (setq entries - (loop for i from 1 while entries collect - (let ((submenu - (subseq entries 0 (min (length entries) - sgml-max-menu-size)))) - (setq entries (nthcdr sgml-max-menu-size - entries)) - (cons - (format "%s '%s'-'%s'" - title - (sgml-range-indicator (aref (car submenu) 0)) - (sgml-range-indicator - (aref (car (last submenu)) 0))) - submenu)))))) - (sgml-xemacs-get-popup-value (cons title entries))) - - -(defun sgml-range-indicator (string) - (substring string - 0 - (min (length string) sgml-range-indicator-max-length))) - - -(defun sgml-xemacs-get-popup-value (menudesc) - (let ((value nil) - (event nil)) - (popup-menu menudesc) - (while (popup-up-p) - (setq event (next-command-event event)) - (cond ((menu-event-p event) - (cond - ((eq (event-object event) 'abort) - (signal 'quit nil)) - ((eq (event-object event) 'menu-no-selection-hook) - nil) - ((commandp (event-object event)) - (call-interactively (event-object event)) - (signal 'quit nil)) - (t - (eval (event-object event))))) - ((button-release-event-p event) ; don't beep twice - nil) - ;; [sb] added condition - ((and (fboundp 'event-matches-key-specifier-p) - (event-matches-key-specifier-p event (quit-char))) - (signal 'quit nil)) - (t - (beep) - (message "please make a choice from the menu.")))) - value)) - -(defun sgml-popup-multi-menu (pos title menudesc) - "Display a popup menu. -MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...). -ITEM should have to form (STRING EXPR) or STRING. The EXPR gets evaluated -if the item is selected." - (popup-menu - (cons title - (loop for menu in menudesc collect - (cons (car menu) ; title - (loop for item in (cdr menu) collect - (if (stringp item) - item - (vector (car item) (cadr item) t)))))))) - - -;;;; XEmacs menu bar - -(defun sgml-make-options-menu (vars) - (loop for var in vars - for type = (sgml-variable-type var) - for desc = (sgml-variable-description var) - collect - (cond - ((eq type 'toggle) - (vector desc (list 'setq var (list 'not var)) - ':style 'toggle ':selected var)) - ((consp type) - (cons desc - (loop for c in type collect - (if (atom c) - (vector (prin1-to-string c) - (`(setq (, var) (, c))) - :style 'toggle - :selected (`(eq (, var) '(, c)))) - (vector (car c) - (`(setq (, var) '(,(cdr c)))) - :style 'toggle - :selected (`(eq (, var) '(,(cdr c))))))))) - (t - (vector desc - (`(sgml-do-set-option '(, var))) - t))))) - - -(unless (or (not (boundp 'emacs-major-version)) - (and (boundp 'emacs-minor-version) - (< emacs-minor-version 10))) - (loop for ent on sgml-main-menu - if (vectorp (car ent)) - do (cond - ((equal (aref (car ent) 0) "File Options >") - (setcar ent - (cons "File Options" - (sgml-make-options-menu sgml-file-options)))) - ((equal (aref (car ent) 0) "User Options >") - (setcar ent - (cons "User Options" - (sgml-make-options-menu sgml-user-options))))))) - - -;;;; Key definitions - -(define-key sgml-mode-map [button3] 'sgml-tags-menu) - - -;;;; Insert with properties - -(defun sgml-insert (props format &rest args) - (let ((start (point)) - tem) - (insert (apply (function format) - format - args)) - (remf props 'rear-nonsticky) ; not useful in XEmacs - - ;; Copy face prop from category - (when (setq tem (getf props 'category)) - (when (setq tem (get tem 'face)) - (set-face-underline-p (make-face 'underline) t) - (setf (getf props 'face) tem))) - - (add-text-properties start (point) props) - - ;; A read-only value of 1 is used for the text after values - ;; and this should in XEmacs be open at the front. - (if (eq 1 (getf props 'read-only)) - (set-extent-property - (extent-at start nil 'read-only) - 'start-open t)))) - - -;;;; Set face of markup - -(defun sgml-set-face-for (start end type) - (let ((face (cdr (assq type sgml-markup-faces))) - o) - (loop for e being the extents from start to end - do (when (extent-property e 'sgml-type) - (cond ((and (null o) - (eq type (extent-property e 'sgml-type))) - (setq o e)) - (t (delete-extent e))))) - - (cond (o - (set-extent-endpoints o start end)) - (face - (setq o (make-extent start end)) - (set-extent-property o 'sgml-type type) - (set-extent-property o 'face face) - (set-extent-property o 'start-open t) - (set-extent-face o face))))) - -(defun sgml-set-face-after-change (start end &optional pre-len) - ;; This should not be needed with start-open t - (when sgml-set-face - (let ((o (extent-at start nil 'sgml-type))) - (cond - ((null o)) - ((= start (extent-start-position o)) - (set-extent-endpoints o end (extent-end-position o))) - (t (delete-extent o)))))) - -;(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el - -(defun sgml-clear-faces () - (interactive) - (loop for o being the overlays - if (extent-property o 'type) - do (delete-extent o))) - - -;;;; Functions not in XEmacs - -(unless (fboundp 'frame-width) - (defalias 'frame-width 'screen-width)) - -(unless (fboundp 'frame-height) - (defalias 'frame-height 'screen-height)) - -(unless (fboundp 'buffer-substring-no-properties) - (defalias 'buffer-substring-no-properties 'buffer-substring)) - - -;;;; Provide - -(provide 'psgml-xemacs) - - -;;; psgml-xemacs.el ends here diff -r d3e9274cbc4e -r e45d5e7c476e lisp/psgml/psgml.el --- a/lisp/psgml/psgml.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1532 +0,0 @@ -;;; psgml.el --- SGML-editing mode with parsing support -;; $Id: psgml.el,v 1.10 1997/10/12 01:39:52 steve Exp $ - -;; Copyright (C) 1993, 1994, 1995, 1996 Lennart Staflin -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Lennart Staflin -;; James Clark -;; Maintainer: Lennart Staflin -;; Keywords: languages - -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;; Commentary: - -;; Major mode for editing the SGML document-markup language. - -;; Send bugs to lenst@lysator.liu.se - -;; WHAT IT CAN DO - -;; - Identify structural errors (but it is not a validator) -;; - Menus for inserting tags with only the contextually valid tags -;; - Edit attribute values in separate window with information about types -;; and defaults -;; - Hide attributes -;; - Fold elements -;; - Indent according to element nesting depth -;; - Show context -;; - Structure editing: move and kill by element -;; - Find next data context - -;; LIMITATIONS - -;; - only accepts the referece concrete syntax, though it does allow -;; unlimited lengths on names - - -;;; Code: - -(defconst psgml-version "1.0.1" - "Version of psgml package.") - -(defconst psgml-maintainer-address "lenst@lysator.liu.se") - -(require 'cl) -(require 'easymenu) - -(defvar sgml-debug nil) - -(defmacro sgml-debug (&rest x) - (list 'if 'sgml-debug (cons 'sgml-log-message x))) - - -;;;; Variables - -(defvar sgml-mode-abbrev-table nil - "Abbrev table in use in sgml-mode.") -(define-abbrev-table 'sgml-mode-abbrev-table ()) - -(defvar sgml-running-xemacs - (not (not (string-match "Lucid\\|XEmacs" emacs-version)))) - -;;; User settable options: - -(defgroup sgml nil - "Standard Generalized Markup Language" - :group 'languages) - -(defgroup psgml nil - "SGML-editing mode with parsing support" - :prefix "sgml-" - :group 'sgml) - -(defgroup psgml-insert nil - "Inserting features of psgml" - :prefix "sgml-" - :group 'psgml) - -(defgroup psgml-dtd nil - "DTD, CATALOG and DOCTYPE customizations in psgml" - :prefix "sgml-" - :group 'psgml) - - -(defcustom sgml-insert-missing-element-comment t - "*If true, and sgml-auto-insert-required-elements also true, -`sgml-insert-element' will insert a comment if there is an element required -but there is more than one to choose from." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-insert-end-tag-on-new-line nil - "*If true, `sgml-insert-element' will put the end-tag on a new line -after the start-tag. Useful on slow terminals if you find the end-tag after -the cursor irritating." - :type 'boolean - :group 'psgml-insert) - -(defvar sgml-doctype nil - "*If set, this should be the name of a file that contains the doctype -declaration to use. -Setting this variable automatically makes it local to the current buffer.") -(put 'sgml-doctype 'sgml-type 'string) -(make-variable-buffer-local 'sgml-doctype) - -(defcustom sgml-system-identifiers-are-preferred nil - "*If nil, PSGML will look up external entities by searching the catalogs -in `sgml-local-catalogs' and `sgml-catalog-files' and only if the -entity is not found in the catalogs will a given system identifer be -used. If the variable is non-nil and a system identifer is given, the -system identifier will be used for the entity. If no system identifier -is given the catalogs will searched." - :type 'boolean - :group 'psgml-dtd) - -(defcustom sgml-range-indicator-max-length 9 - "*Maximum number of characters used from the first and last entry -of a submenu to indicate the range of that menu." - :type 'integer - :group 'psgml) - -(defcustom sgml-default-doctype-name nil - "*Document type name to use if no document type declaration is present." - :type '(choice string (const nil)) - :group 'psgml-dtd) - -(put 'sgml-default-doctype-name 'sgml-type 'string-or-nil) - -(defcustom sgml-markup-faces '((start-tag . bold) - (end-tag . bold) - (comment . italic) - (pi . bold) - (sgml . bold) - (doctype . bold) - (entity . bold-italic) - (shortref . bold)) - "*List of markup to face mappings. -Element are of the form (MARKUP-TYPE . FACE). -Possible values for MARKUP-TYPE is: -comment - comment declaration -doctype - doctype declaration -end-tag -ignored - ignored marked section -ms-end - marked section start, if not ignored -ms-start- marked section end, if not ignored -pi - processing instruction -sgml - SGML declaration -start-tag -entity - general entity reference -shortref- short reference" - :type '(repeat (cons symbol face)) - :group 'psgml) - -(defvar sgml-buggy-subst-char-in-region - (or (not (boundp 'emacs-minor-version)) - (not (natnump emacs-minor-version)) - (< emacs-minor-version 23)) - "*If non-nil, work around a bug in subst-char-in-region. -The bug sets the buffer modified. If this is set, folding commands -will be slower.") - -(defcustom sgml-set-face nil - "*If non-nil, psgml will set the face of parsed markup." - :type 'boolean - :group 'psgml) -(put 'sgml-set-face 'sgml-desc "Set face of parsed markup") - -(defcustom sgml-live-element-indicator nil - "*If non-nil, indicate current element in mode line." - :type 'boolean - :group 'psgml) - -(defcustom sgml-auto-activate-dtd nil - "*If non-nil, loading a sgml-file will automatically try to activate its DTD. -Activation means either to parse the document type declaration or to -load a previously saved parsed DTD. The name of the activated DTD -will be shown in the mode line." - :type 'boolean - :group 'psgml-dtd) -(put 'sgml-auto-activate-dtd 'sgml-desc "Auto Activate DTD") - -(defcustom sgml-offer-save t - "*If non-nil, ask about saving modified buffers before \\[sgml-validate] is run." - :type 'boolean - :group 'psgml) - -(defvar sgml-parent-document nil - "* Used when the current file is part of a bigger document. - -The variable describes how the current file's content fit into the element -hierarchy. The variable should have the form - - (PARENT-FILE CONTEXT-ELEMENT* TOP-ELEMENT (HAS-SEEN-ELEMENT*)?) - -PARENT-FILE is a string, the name of the file contatining the - document entity. -CONTEXT-ELEMENT is a string, that is the name of an element type. - It can occur 0 or more times and is used to set up - exceptions and short reference map. Good candidates - for these elements are the elements open when the - entity pointing to the current file is used. -TOP-ELEMENT is a string that is the name of the element type - of the top level element in the current file. The file - should contain one instance of this element, unless - the last \(lisp) element of sgml-parent-document is a - list. If it is a list, the top level of the file - should follow the content model of top-element. -HAS-SEEN-ELEMENT is a string that is the name of an element type. This - element is satisfied in the content model of top-element. - -Setting this variable automatically makes it local to the current buffer.") -(make-variable-buffer-local 'sgml-parent-document) -(put 'sgml-parent-document 'sgml-type 'list) - -(defcustom sgml-tag-region-if-active t ;; wing change - "*If non-nil, the Tags menu will tag a region if the region is -considered active by Emacs. If nil, region must be active and -transient-mark-mode/zmacs-regions must be on for the region to be tagged." - :type 'boolean - :group 'psgml) - -(defvar sgml-normalize-trims t - "*If non-nil, sgml-normalize will trim off white space from end of element -when adding end tag.") - -(defvar sgml-omittag t - "*Set to non-nil, if you use OMITTAG YES. - -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-omittag) -(put 'sgml-omittag 'sgml-desc "OMITTAG") - -(defvar sgml-shorttag t - "*Set to non-nil, if you use SHORTTAG YES. - -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-shorttag) -(put 'sgml-shorttag 'sgml-desc "SHORTTAG") - -(defvar sgml-minimize-attributes nil - "*Determines minimization of attributes inserted by edit-attributes. -Actually two things are done -1. If non-nil, omit attribute name, if attribute value is from a token group. -2. If 'max, omit attributes with default value. - -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-minimize-attributes) -(put 'sgml-minimize-attributes 'sgml-type - '(("No" . nil) ("Yes" . t) ("Max" . max))) - -(defvar sgml-always-quote-attributes t - "*If non-nil, quote all attribute values inserted after finishing edit attributes. -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-always-quote-attributes) - -(defcustom sgml-auto-insert-required-elements t - "*If non-nil, automatically insert required elements in the content -of an inserted element." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-balanced-tag-edit t - "*If non-nil, always insert start-end tag pairs." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-omittag-transparent (not sgml-balanced-tag-edit) ;; wing change - "*If non-nil, will show legal tags inside elements with omittable start tags -and legal tags beyond omittable end tags." - :type 'boolean - :group 'psgml) - -(defcustom sgml-leave-point-after-insert nil - "*If non-nil, the point will remain after inserted tag(s). -If nil, the point will be placed before the inserted tag(s)." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-warn-about-undefined-elements t - "*If non-nil, print a warning when a tag for an undefined element is found." - :type 'boolean - :group 'psgml) - -(defcustom sgml-warn-about-undefined-entities t - "*If non-nil, print a warning when an undefined entity is found." - :type 'boolean - :group 'psgml) - -(defcustom sgml-ignore-undefined-elements nil - "*If non-nil, recover from an undefined element by ignoring the tag. -If nil, recover from an undefined element by assuming it can occur any -where and has content model ANY." - :type 'boolean - :group 'psgml) - -(defcustom sgml-recompile-out-of-date-cdtd 'ask - "*If non-nil, out of date compiled DTDs will be automatically recompiled. -If the value is `ask', PSGML will ask before recompiling. A `nil' -value will cause PSGML to silently load an out of date compiled DTD. -A DTD that referes to undefined external entities is always out of -date, thus in such case it can be useful to set this variable to -`nil'." - :type 'symbol - :group 'psgml-dtd) -(put 'sgml-recompile-out-of-date-cdtd 'sgml-type '(("No" . nil) - ("Yes" . t) - ("Ask" . ask))) - -(defcustom sgml-trace-entity-lookup nil - "*If non-nil, log messages about catalog files used to look for -external entities." - :type 'boolean - :group 'psgml-dtd) - -(defvar sgml-indent-step 2 - "*How much to increment indent for every element level. -If nil, no indentation. -Setting this variable automatically makes it local to the current buffer.") -(make-variable-buffer-local 'sgml-indent-step) -(put 'sgml-indent-step 'sgml-type '(("None" . nil) 0 1 2 3 4 5 6 7 8)) - -(defvar sgml-indent-data nil - "*If non-nil, indent in data/mixed context also. -Setting this variable automatically makes it local to the current buffer.") -(make-variable-buffer-local 'sgml-indent-data) - -;;; Wing addition -(defcustom sgml-inhibit-indent-tags nil - "*List of tags within which indentation is inhibited. -The tags should be given as strings." - :type 'boolean - :group 'psgml) - -(defcustom sgml-data-directory (expand-file-name "sgml" data-directory) - "*Directory for pre-supplied data files (DTD's and such). -Set this before loading psgml." - :type 'directory - :group 'psgml) - -(defcustom sgml-system-path nil - ;; wing addition - "*List of directories used to look for system identifiers. -The directory listed in `sgml-data-directory' is always searched in -addition to the directories listed here." - :type '(repeat directory) - :group 'psgml) -(put 'sgml-system-path 'sgml-type 'list) - -(defun sgml-parse-colon-path (cd-path) - "Explode a colon-separated list of paths into a string list." - (let (cd-list (cd-start 0) cd-colon) - (setq cd-path (concat cd-path ":")) - (while (setq cd-colon (string-match ":" cd-path cd-start)) - (setq cd-list - (nconc cd-list - (list (if (= cd-start cd-colon) - nil - (substitute-in-file-name - (substring cd-path cd-start cd-colon)))))) - (setq cd-start (+ cd-colon 1))) - cd-list)) - -(defcustom sgml-public-map (sgml-parse-colon-path - (or (getenv "SGML_PATH") - ;; Wing change - (concat "%S:" (directory-file-name - sgml-data-directory) - "/%o/%c/%d"))) - - "*Mapping from public identifiers to file names. -This is a list of possible file names. To find the file for a public -identifier the elements of the list are used one at the time from the -beginning. If the element is a string a file name is constructed from -the string by substitution of the whole public identifier for %P, -owner for %O, public text class for %C, and public text description -for %D. The text class will be converted to lower case and the owner -and description will be transliterated according to the variable -sgml-public-transliterations. If the file exists it will be the file -used for the public identifier. An element can also be a dotted pair -(regexp . filename), the filename is a string treated as above, but -only if the regular expression, regexp, matches the public -identifier." - :type '(repeat file) - :group 'psgml-dtd) -(put 'sgml-public-map 'sgml-type 'list) - -(defcustom sgml-local-catalogs nil -"*A list of SGML entity catalogs to be searched first when parsing the buffer. -This is used in addtion to `sgml-catalog-files', and `sgml-public-map'. -This variable is automatically local to the buffer." - :type '(repeat file) - :group 'psgml-dtd) -(make-variable-buffer-local 'sgml-local-catalogs) -(put 'sgml-local-catalogs 'sgml-type 'list) - -(defcustom sgml-catalog-files (sgml-parse-colon-path - (or (getenv "SGML_CATALOG_FILES") - ;; Wing addition - (concat "CATALOG:" - (expand-file-name - "CATALOG" - sgml-data-directory)))) - "*List of catalog entry files. -The files are in the format defined in the SGML Open Draft Technical -Resolution on Entity Management." - :type '(repeat file) - :group 'psgml-dtd) -(put 'sgml-catalog-files 'sgml-type 'list) - -;;; Wing addition -(defcustom sgml-ecat-files (list - "ECAT" - "~/sgml/ECAT" - (expand-file-name "ECAT" sgml-data-directory)) - "*List of catalog files for PSGML." - :type '(repeat file) - :group 'psgml-dtd) -(put 'sgml-ecat-files 'sgml-type 'list) - -(defcustom sgml-local-ecat-files nil - "*List of local catalog files for PSGML. -Automatically becomes buffer local if set." - :type '(repeat file) - :group 'psgml-dtd) -(make-variable-buffer-local 'sgml-local-ecat-files) -(put 'sgml-local-ecat-files 'sgml-type 'list) - -(defvar sgml-public-transliterations '((? . ?_) (?/ . ?%)) - "*Transliteration for characters that should be avoided in file names. -This is a list of dotted pairs (FROM . TO); where FROM is the the -character to be translated to TO. This is used when parts of a public -identifier are used to construct a file name.") - -(defvar sgml-default-dtd-file nil - "*This is the default file name for saved DTD. -This is set by sgml-mode from the buffer file name. -Can be changed in the Local variables section of the file.") -(put 'sgml-default-dtd-file 'sgml-type 'string) -(put 'sgml-default-dtd-file 'sgml-desc "Default (saved) DTD File") - -(defvar sgml-exposed-tags '() - "*The list of tag names that remain visible, despite \\[sgml-hide-tags]. -Each name is a lowercase string, and start-tags and end-tags must be -listed individually. - -`sgml-exposed-tags' is local to each buffer in which it has been set; -use `setq-default' to set it to a value that is shared among buffers.") -(make-variable-buffer-local 'sgml-exposed-tags) -(put 'sgml-exposed-tags 'sgml-type 'list) - - -(defvar sgml-custom-markup nil - "*Menu entries to be added to the Markup menu. -The value should be a list of lists of two strings. The first is a -string is the menu line and the second string is the text inserted -when the menu item is chosen. The second string can contain a \\r -where the cursor should be left. Also if a selection is made -according the same rules as for the Tags menu, the selection is -replaced with the second string and \\r is replaced with the -selection. - -Example: - - ((\"Version1\" \"\") - (\"New page\" \"\")) -") - -(defcustom sgml-custom-dtd nil - "Menu entries to be added to the DTD menu. -The value should be a list of entries to be added to the DTD menu. -Every entry should be a list. The first element of the entry is a string -used as the menu entry. The second element is a string containing a -doctype declaration (this can be nil if no doctype). The rest of the -list should be a list of variables and values. For backward -compatibility a singel string instead of a variable is assigned to -sgml-default-dtd-file. All variables are made buffer local and are also -added to the buffers local variables list. - -Example: - ((\"HTML\" nil - sgml-default-dtd-file \"~/sgml/html.ced\" - sgml-omittag nil sgml-shorttag nil) - (\"HTML+\" \"\" - \"~/sgml/htmlplus.ced\" - sgml-omittag t sgml-shorttag nil) - (\"DOCBOOK\" \"\" - \"~/sgml/docbook.ced\" - sgml-omittag nil sgml-shorttag t))) -" - :type '(repeat (list (string :tag "Menu Entry") - (choice (const :tag "No doctype") - (string :tag "Declaration")) - (repeat :inline t - (list :inline t - (symbol :tag "Variable") - (sexp :tag "Value"))))) - :group 'psgml-dtd) - - - -;;; Faces used in edit attribute buffer: -(put 'sgml-default 'face 'underline) ; Face for #DEFAULT -(put 'sgml-fixed 'face 'underline) ; Face of #FIXED "..." - - -;;; sgmls is a free SGML parser available from -;;; ftp.uu.net:pub/text-processing/sgml -;;; Its error messages can be parsed by next-error. -;;; The -s option suppresses output. - -(defcustom sgml-validate-command (concat "nsgmls -s -m " - sgml-data-directory - "/CATALOG %s %s") - "*The shell command to validate an SGML document. - -This is a `format' control string that by default should contain two -`%s' conversion specifications: the first will be replaced by the -value of `sgml-declaration' \(or the empty string, if nil\); the -second will be replaced by the current buffer's file name \(or the -empty string, if nil\). - -If `sgml-validate-files' is non-nil, the format string should contain -one `%s' conversion specification for each element of its result. - -If sgml-validate-command is a list, then every element should be a -string. The strings will be tried in order and %-sequences in the -string will be replaced according to the list below, if the string contains -%-sequences with no replacement value the next string will be tried. - -%b means the visited file of the current buffer -%s means the SGML declaration specified in the sgml-declaration variable -%d means the file containing the DOCTYPE declaration, if not in the buffer -" - :type 'string - :group 'psgml) - -(defvar sgml-validate-files nil - "If non-nil, a function of no arguments that returns a list of file names. -These file names will serve as the arguments to the `sgml-validate-command' -format control string instead of the defaults.") - -(defvar sgml-validate-error-regexps - '((":\\(.+\\):\\([0-9]+\\):\\([0-9]+\\):[EX]: " 1 2 3) - ("\\(error\\|warning\\) at \\([^,]+\\), line \\([0-9]+\\)" 2 3) - ("\n[a-zA-Z]?:?[^0-9 \n\t:]+:[ \t]*\\([^ \n\t:]+\\):\ -\\([0-9]+\\):\\(\\([0-9]+\\)[: \t]\\)?" 1 2 4)) - "Alist of regexps to recognize error messages from `sgml-validate'. -See `compilation-error-regexp-alist'.") - -(defcustom sgml-declaration nil - "*If non-nil, this is the name of the SGML declaration file." - :type 'hook - :group 'psgml-dtd) -(put 'sgml-declaration 'sgml-type 'string) - -(defcustom sgml-mode-hook nil - "A hook or list of hooks to be run when entering sgml-mode" - :type 'hook - :group 'psgml) - -(defconst sgml-file-options - '( - sgml-omittag - sgml-shorttag - sgml-minimize-attributes - sgml-always-quote-attributes - sgml-indent-step - sgml-indent-data - sgml-doctype - sgml-parent-document - sgml-default-dtd-file - sgml-exposed-tags - sgml-local-catalogs - sgml-local-ecat-files - ) - "Options for the current file, can be saved or set from menu." - ) - -(defconst sgml-user-options - '( - sgml-set-face - sgml-live-element-indicator - sgml-auto-activate-dtd - sgml-offer-save - sgml-tag-region-if-active - sgml-normalize-trims - sgml-auto-insert-required-elements - sgml-balanced-tag-edit - sgml-omittag-transparent - sgml-leave-point-after-insert - sgml-insert-missing-element-comment - sgml-insert-end-tag-on-new-line - sgml-warn-about-undefined-elements - sgml-warn-about-undefined-entities - sgml-ignore-undefined-elements - sgml-recompile-out-of-date-cdtd - sgml-default-doctype-name - sgml-declaration - sgml-validate-command - sgml-markup-faces - sgml-system-identifiers-are-preferred - sgml-trace-entity-lookup - sgml-system-path - sgml-public-map - sgml-catalog-files - sgml-ecat-files - ) - "User options that can be saved or set from menu." - ) - -;;; Internal variables - -(defvar sgml-validate-command-history nil - "The minibuffer history list for `sgml-validate''s COMMAND argument.") - -(defvar sgml-mode-map nil "Keymap for SGML mode") - -(defvar sgml-active-dtd-indicator nil - "Displayed in the mode line") - - -;;;; User options handling - -(defun sgml-variable-description (var) - (or (get var 'sgml-desc) - (let ((desc (symbol-name var))) - (if (string= "sgml-" (substring desc 0 5)) - (setq desc (substring desc 5))) - (loop for c across-ref desc - do (if (eq c ?-) (setf c ? ))) - (capitalize desc)))) - -(defun sgml-variable-type (var) - (or (get var 'sgml-type) - (if (memq (symbol-value var) '(t nil)) - 'toggle))) - -(defun sgml-set-local-variable (var val) - "Set the value of variable VAR to VAL in buffer and local variables list." - (set (make-local-variable var) val) - (save-excursion - (let ((prefix "") - (suffix "") - (case-fold-search t)) - (goto-char (max (point-min) (- (point-max) 3000))) - (cond ((search-forward "Local Variables:" nil t) - (setq suffix (buffer-substring (point) - (save-excursion (end-of-line 1) - (point)))) - (setq prefix - (buffer-substring (save-excursion (beginning-of-line 1) - (point)) - (match-beginning 0)))) - (t - (goto-char (point-max)) - (unless (bolp) - (insert ?\n)) - (insert - "\n") - (forward-line -3))) - (let* ((endpos (save-excursion - (search-forward (format "\n%send:" prefix)))) - (varpos (search-forward (format "\n%s%s:" prefix var) endpos t))) - (cond (varpos - (delete-region (point) - (save-excursion (end-of-line 1) - (point))) - (insert (format "%S" val) suffix)) - (t - (goto-char endpos) - (beginning-of-line 1) - (insert prefix (format "%s:%S" var val) suffix ?\n))))))) - -(defun sgml-valid-option (var) - (let ((type (sgml-variable-type var)) - (val (symbol-value var))) - (cond ((eq 'string type) - (stringp val)) - ((eq 'list-or-string type) - (or (stringp val) - (consp val))) - (t - t)))) - -(defun sgml-save-options () - "Save user options for sgml-mode that have buffer local values." - (interactive) - (loop for var in sgml-file-options do - (when (sgml-valid-option var) - (sgml-set-local-variable var (symbol-value var))))) - - -;;;; Run hook with args - -(unless (fboundp 'run-hook-with-args) - (defun run-hook-with-args (hook &rest args) - "Run HOOK with the specified arguments ARGS. -HOOK should be a symbol, a hook variable. If HOOK has a non-nil -value, that value may be a function or a list of functions to be -called to run the hook. If the value is a function, it is called with -the given arguments and its return value is returned. If it is a list -of functions, those functions are called, in order, -with the given arguments ARGS. -It is best not to depend on the value return by `run-hook-with-args', -as that may change." - (and (boundp hook) - (symbol-value hook) - (let ((value (symbol-value hook))) - (if (and (listp value) (not (eq (car value) 'lambda))) - (mapcar '(lambda (foo) (apply foo args)) - value) - (apply value args)))))) - - - - -;;;; SGML mode: template functions - -(defun sgml-markup (entry text) - (cons entry - (` (lambda () - (interactive) - (sgml-insert-markup (, text)))))) - -(defun sgml-insert-markup (text) - (let ((end (sgml-mouse-region)) - before after - old-text) - (when end - (setq old-text (buffer-substring (point) end)) - (delete-region (point) end)) - (setq before (point)) - (if (stringp text) - (insert text) - (eval text)) - (setq after (point)) - (goto-char before) - (when (search-forward "\r" after t) - (delete-char -1)) - (when old-text (insert old-text)))) - -(defun sgml-mouse-region () - (let (start end) - (cond - (sgml-running-xemacs - (cond - ((null (mark-marker)) nil) - (t (setq start (region-beginning) - end (region-end))))) - ((and transient-mark-mode - mark-active) - (setq start (region-beginning) - end (region-end))) - ((and mouse-secondary-overlay - (eq (current-buffer) - (overlay-buffer mouse-secondary-overlay))) - (setq start (overlay-start mouse-secondary-overlay) - end (overlay-end mouse-secondary-overlay)) - (delete-overlay mouse-secondary-overlay))) - (when start - (goto-char start)) - end)) - - -;;;; SGML mode: indentation - -(defun sgml-indent-or-tab () - "Indent line in proper way for current major mode." - (interactive) - (if (null sgml-indent-step) - (insert-tab) - (funcall indent-line-function))) - -;;;; Bug reporting - -(eval-and-compile - (autoload 'reporter-submit-bug-report "reporter")) - -(defun sgml-submit-bug-report () - "Submit via mail a bug report on PSGML." - (interactive) - (and (y-or-n-p "Do you really want to submit a report on PSGML? ") - (reporter-submit-bug-report - psgml-maintainer-address - (concat "psgml.el " psgml-version) - (list - 'sgml-always-quote-attributes - 'sgml-auto-activate-dtd - 'sgml-auto-insert-required-elements - 'sgml-balanced-tag-edit - 'sgml-catalog-files - 'sgml-declaration - 'sgml-doctype - 'sgml-ecat-files - 'sgml-indent-data - 'sgml-indent-step - 'sgml-leave-point-after-insert - 'sgml-live-element-indicator - 'sgml-local-catalogs - 'sgml-local-ecat-files - 'sgml-markup-faces - 'sgml-minimize-attributes - 'sgml-normalize-trims - 'sgml-omittag - 'sgml-omittag-transparent - 'sgml-parent-document - 'sgml-public-map - 'sgml-set-face - 'sgml-shorttag - 'sgml-tag-region-if-active - )))) - - -;;;; SGML mode: keys and menus - -(if sgml-mode-map - () - (setq sgml-mode-map (make-sparse-keymap))) - -;;; Key commands - -(define-key sgml-mode-map [(tab)] 'sgml-indent-or-tab) -;;;(define-key sgml-mode-map [(?<)] 'sgml-insert-tag) -(define-key sgml-mode-map [(?>)] 'sgml-close-angle) -(define-key sgml-mode-map [(?/)] 'sgml-slash) -(define-key sgml-mode-map [(control ?c) (?#)] 'sgml-make-character-reference) -(define-key sgml-mode-map [(control ?c) (?-)] 'sgml-untag-element) -(define-key sgml-mode-map [(control ?c) (?+)] 'sgml-insert-attribute) -(define-key sgml-mode-map [(control ?c) (?/)] 'sgml-insert-end-tag) -(define-key sgml-mode-map [(control ?c) (?<)] 'sgml-insert-tag) -(define-key sgml-mode-map [(control ?c) (?=)] 'sgml-change-element-name) -(define-key sgml-mode-map [(control ?c) (control ?a)] 'sgml-edit-attributes) -(define-key sgml-mode-map [(control ?c) (control ?c)] 'sgml-show-context) -(define-key sgml-mode-map [(control ?c) (control ?d)] 'sgml-next-data-field) -(define-key sgml-mode-map [(control ?c) (control ?e)] 'sgml-insert-element) -(define-key sgml-mode-map [(control ?c) (control ?k)] 'sgml-kill-markup) -(define-key sgml-mode-map [(control ?c) (control ?l)] 'sgml-show-or-clear-log) -(define-key sgml-mode-map [(control ?c) (control ?n)] 'sgml-up-element) -(define-key sgml-mode-map [(control ?c) (control ?o)] 'sgml-next-trouble-spot) -(define-key sgml-mode-map [(control ?c) (control ?p)] 'sgml-parse-prolog) -(define-key sgml-mode-map [(control ?c) (control ?q)] 'sgml-fill-element) -(define-key sgml-mode-map [(control ?c) (control ?r)] 'sgml-tag-region) -(define-key sgml-mode-map [(control ?c) (control ?s)] 'sgml-unfold-line) -(define-key sgml-mode-map [(control ?c) (control ?t)] 'sgml-list-valid-tags) -(define-key sgml-mode-map [(control ?c) (control ?v)] 'sgml-validate) -(define-key sgml-mode-map [(control ?c) (control ?w)] 'sgml-what-element) -(define-key sgml-mode-map [(control ?c) (control ?z)] 'sgml-trim-and-leave-element) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?e)] 'sgml-fold-element) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?r)] 'sgml-fold-region) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?s)] 'sgml-fold-subelement) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?x)] 'sgml-expand-element) -(define-key sgml-mode-map [(meta control ?O)] 'sgml-split-element) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?e)] 'sgml-unfold-element) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?a)] 'sgml-unfold-all) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?l)] 'sgml-unfold-line) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?d)] 'sgml-custom-dtd) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?m)] 'sgml-custom-markup) - -(define-key sgml-mode-map [(meta control ?a)] 'sgml-beginning-of-element) -(define-key sgml-mode-map [(meta control ?e)] 'sgml-end-of-element) -(define-key sgml-mode-map [(meta control ?f)] 'sgml-forward-element) -(define-key sgml-mode-map [(meta control ?b)] 'sgml-backward-element) -(define-key sgml-mode-map [(meta control ?d)] 'sgml-down-element) -(define-key sgml-mode-map [(meta control ?u)] 'sgml-backward-up-element) -(define-key sgml-mode-map [(meta control ?k)] 'sgml-kill-element) -(define-key sgml-mode-map [(meta control ?@)] 'sgml-mark-element) -(define-key sgml-mode-map [(meta control ?h)] 'sgml-mark-current-element) -(define-key sgml-mode-map [(meta control ?t)] 'sgml-transpose-element) -(define-key sgml-mode-map [(meta tab)] 'sgml-complete) - -;;;; Menu bar - -(easy-menu-define - sgml-dtd-menu sgml-mode-map "DTD menu" - '("DTD")) - -(defconst sgml-dtd-root-menu - '("DTD" - ["Parse DTD" sgml-parse-prolog t] - ("Info" - ["General DTD info" sgml-general-dtd-info t] - ["Describe element type" sgml-describe-element-type t] - ["Describe entity" sgml-describe-entity t] - ["List elements" sgml-list-elements t] - ["List attributes" sgml-list-attributes t] - ["List terminals" sgml-list-terminals t] - ["List content elements" sgml-list-content-elements t] - ["List occur in elements" sgml-list-occur-in-elements t] - ) - "--" - ["Load Parsed DTD" sgml-load-dtd t] - ["Save Parsed DTD" sgml-save-dtd t] - )) - -(easy-menu-define - sgml-view-menu sgml-mode-map "View menu" - '("View" - ["Fold Element" sgml-fold-element t] - ["Fold Subelement" sgml-fold-subelement t] - ["Unfold Line" sgml-unfold-line t] - ["Unfold Element" sgml-unfold-element t] - ["Expand" sgml-expand-element t] - ["Fold Region" sgml-fold-region t] - ["Unfold All" sgml-unfold-all t] - ["Hide Tags" sgml-hide-tags t] - ["Hide Attributes" sgml-hide-attributes t] - ["Show All Tags" sgml-show-tags t] - ) - ) - - -(defconst sgml-markup-root-menu - '("Markup" - ["Insert Element" sgml-element-menu t] - ["Insert Start-Tag" sgml-start-tag-menu t] - ["Insert End-Tag" sgml-end-tag-menu t] - ["Tag Region" sgml-tag-region-menu t] - ["Insert Attribute" sgml-attrib-menu t] - ["Insert Entity" sgml-entities-menu t] - )) - -(easy-menu-define - sgml-markup-menu sgml-mode-map "Markup menu" - sgml-markup-root-menu) - -(easy-menu-define - sgml-move-menu sgml-mode-map "Menu of move commands" - '("Move" - ["Next trouble spot" sgml-next-trouble-spot t] - ["Next data field" sgml-next-data-field t] - ["Forward element" sgml-forward-element t] - ["Backward element" sgml-backward-element t] - ["Up element" sgml-up-element t] - ["Down element" sgml-down-element t] - ["Backward up element" sgml-backward-up-element t] - ["Beginning of element" sgml-beginning-of-element t] - ["End of element" sgml-end-of-element t] - )) - -(easy-menu-define - sgml-modify-menu sgml-mode-map "Menu of modification commands" - '("Modify" - ["Normalize" sgml-normalize t] - ["Expand All Short References" sgml-expand-all-shortrefs t] - ["Expand Entity Reference" sgml-expand-entity-reference t] - ["Normalize Element" sgml-normalize-element t] - ["Make Character Reference" sgml-make-character-reference t] - ["Unmake Character Reference" (sgml-make-character-reference t) t] - ["Fill Element" sgml-fill-element t] - ["Change Element Name..." sgml-change-element-name t] - ["Edit Attributes..." sgml-edit-attributes t] - ["Kill Markup" sgml-kill-markup t] - ["Kill Element" sgml-kill-element t] - ["Untag Element" sgml-untag-element t] - ["Trim and leave element" sgml-trim-and-leave-element t] - ["Decode Character Entities" sgml-charent-to-display-char t] - ["Encode Characters" sgml-display-char-to-charent t] - ) - ) - -(easy-menu-define - sgml-main-menu sgml-mode-map "Main menu" - '("SGML" - ["Reset Buffer" normal-mode t] - ["End Element" sgml-insert-end-tag t] - ["Show Context" sgml-show-context t] - ["What Element" sgml-what-element t] - ["List Valid Tags" sgml-list-valid-tags t] - ["Show/Hide Warning Log" sgml-show-or-clear-log t] - ["Validate" sgml-validate t] - ["File Options >" sgml-file-options-menu t] - ["User Options >" sgml-user-options-menu t] - ["Save File Options" sgml-save-options t] - ["Submit Bug Report" sgml-submit-bug-report t] - ) - ) - - -(defun sgml-build-custom-menus () - "Build custom parts of Markup and DTD menus." - (let ((button3 (lookup-key (current-local-map) [button3]))) - (easy-menu-define - sgml-markup-menu sgml-mode-map "Markup menu" - (append sgml-markup-root-menu - (list "----") - (loop for e in sgml-custom-markup collect - (vector (first e) - (` (sgml-insert-markup (, (cadr e)))) - t)))) - (easy-menu-define - sgml-dtd-menu sgml-mode-map "DTD menu" - (append sgml-dtd-root-menu - (list "----") - (loop for e in sgml-custom-dtd collect - (vector (first e) - (` (sgml-doctype-insert (, (cadr e)) - '(, (cddr e)))) - t)))) - (unless (or (null button3) - (numberp button3)) - (local-set-key [button3] button3)))) - - -;;;; Post command hook - -(defvar sgml-auto-activate-dtd-tried nil) -(make-variable-buffer-local 'sgml-auto-activate-dtd-tried) - -(defvar sgml-buffer-parse-state nil - "If the buffers DTD has been activated this contains the parser state. -The parser state has been created with `sgml-make-pstate' and contains -the information about the DTD and the parse tree. This parse state is -actually only the state that persists between commands.") -(make-variable-buffer-local 'sgml-buffer-parse-state) - -(eval-and-compile ; Interface to psgml-parse - (loop for fun in '(sgml-need-dtd sgml-update-display - sgml-fontify-buffer - sgml-subst-expand - sgml-declaration) - do (autoload fun "psgml-parse"))) - - -(defun sgml-command-post () - (when (eq major-mode 'sgml-mode) - (when (and (null sgml-buffer-parse-state) - sgml-auto-activate-dtd - (null sgml-auto-activate-dtd-tried) - (not (zerop (buffer-size))) - (looking-at ".*<")) - (setq sgml-auto-activate-dtd-tried t) - (sgml-need-dtd) - (sgml-fontify-buffer 0)) - (when sgml-buffer-parse-state - (sgml-update-display)))) - - -;;;; SGML mode: major mode definition - -;;; This section is mostly from sgml-mode by James Clark. - -;;;###autoload -(defun sgml-mode () - "Major mode for editing SGML.\\ -Makes > display the matching <. Makes / display matching /. -Use \\[sgml-validate] to validate your document with an SGML parser. - -You can find information with: -\\[sgml-show-context] Show the nesting of elements at cursor position. -\\[sgml-list-valid-tags] Show the tags valid at cursor position. - -Insert tags with completion of contextually valid tags with \\[sgml-insert-tag]. -End the current element with \\[sgml-insert-end-tag]. Insert an element (i.e. -both start and end tag) with \\[sgml-insert-element]. Or tag a region with -\\[sgml-tag-region]. - -To tag a region with the mouse, use transient mark mode or secondary selection. - -Structure editing: -\\[sgml-backward-element] Moves backwards over the previous element. -\\[sgml-forward-element] Moves forward over the next element. -\\[sgml-down-element] Move forward and down one level in the element structure. -\\[sgml-backward-up-element] Move backward out of this element level. -\\[sgml-beginning-of-element] Move to after the start tag of the current element. -\\[sgml-end-of-element] Move to before the end tag of the current element. -\\[sgml-kill-element] Kill the element following the cursor. - -Finding interesting positions -\\[sgml-next-data-field] Move forward to next point where data is allowed. -\\[sgml-next-trouble-spot] Move forward to next point where something is - amiss with the structure. - -Folding and unfolding -\\[sgml-fold-element] Fold the lines comprising the current element, leaving - the first line visible. -\\[sgml-fold-subelement] Fold the elements in the content of the current element. - Leaving the first line of every element visible. -\\[sgml-unfold-line] Show hidden lines in current line. - -User options: - -sgml-omittag Set this to reflect OMITTAG in the SGML declaration. -sgml-shortag Set this to reflect SHORTTAG in the SGML declaration. -sgml-auto-insert-required-elements If non-nil, automatically insert required - elements in the content of an inserted element. -sgml-balanced-tag-edit If non-nil, always insert start-end tag pairs. -sgml-omittag-transparent If non-nil, will show legal tags inside elements - with omitable start tags and legal tags beyond omitable end tags. -sgml-leave-point-after-insert If non-nil, the point will remain after - inserted tag(s). -sgml-warn-about-undefined-elements If non-nil, print a warning when a tag - for a undefined element is found. -sgml-max-menu-size Max number of entries in Tags and Entities menus before - they are split into several panes. -sgml-always-quote-attributes If non-nil, quote all attribute values - inserted after finishing edit attributes. -sgml-minimize-attributes Determines minimization of attributes inserted by - edit-attributes. -sgml-normalize-trims If non-nil, sgml-normalize will trim off white space - from end of element when adding end tag. -sgml-indent-step How much to increament indent for every element level. -sgml-indent-data If non-nil, indent in data/mixed context also. -sgml-set-face If non-nil, psgml will set the face of parsed markup. -sgml-markup-faces The faces used when the above variable is non-nil. -sgml-system-path List of directories used to look for system identifiers. -sgml-public-map Mapping from public identifiers to file names. -sgml-offer-save If non-nil, ask about saving modified buffers before - \\[sgml-validate] is run. - -All bindings: -\\{sgml-mode-map} -" - (interactive) - (kill-all-local-variables) - (setq local-abbrev-table sgml-mode-abbrev-table) - (use-local-map sgml-mode-map) - (setq mode-name "SGML") - (setq major-mode 'sgml-mode) - - ;; A start or end tag by itself on a line separates a paragraph. - ;; This is desirable because SGML discards a newline that appears - ;; immediately after a start tag or immediately before an end tag. - - (set (make-local-variable 'paragraph-separate) - "^[ \t\n]*$\\|\ -^[ \t]*$") - (set (make-local-variable 'paragraph-start) - paragraph-separate) - - (set-syntax-table text-mode-syntax-table) - (make-local-variable 'comment-start) - (setq comment-start "") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'sgml-comment-indent) - (make-local-variable 'comment-start-skip) - ;; This will allow existing comments within declarations to be - ;; recognized. [Does not work well with auto-fill, Lst/940205] - ;;(setq comment-start-skip "--[ \t]*") - (setq comment-start-skip " -@end example - -You can also put a line at the top of the file to tell emacs to use sgml -mode: - -@example - -@end example - -But remember that you can't have a comment before the @emph{SGML -declaration}. - - -@c ------------------------------------------------------------------------- -@node Entity manager, Validate, Invoke, Top -@comment node-name, next, previous, up -@chapter The Entity Manager -@cindex public identifier -@cindex system identifier -@cindex external identifier -@cindex entity catalog - -@c *** sgml-sysid-resolve-functions - -SGML can refer to an external file (really entity) with an -@emph{external identifier}, this is a @emph{public identifier} or a -@emph{system identifier}, or both. - -A typical public identifier looks like - -@example -PUBLIC "ISO 8879:1986//ENTITIES Added Latin 1//EN" -@end example - -@noindent -where ``ISO 8879:1986'' is the owner, ``ENTITIES'' is the text class and -``Added Latin 1'' is the text description (and ``EN'' is language). - -A system identifier looks like - -@example -SYSTEM "htmlplus.dtd" -@end example - -@noindent where ``htmlplus.dtd'' is a system-specific identifier. - -To map external identifiers to file names, PSGML first searches entity -catalog files and then search the list of file name templates in the -variable @code{sgml-public-map}. - -The catalog format is according to SGML/Opens resolution on entity -management. The catalog consists of a series of entries and comments. A -comment is delimited by @samp{--} like in a markup declaration. -The entry types recognized are described in the following table. - -@table @samp - -@item public @var{pubid} @var{file} -The @var{file} will be used for the entity text of an entity -with the public identifier @var{pubid}. - -@item entity @var{name} @var{file} -The @var{file} will be used for the entity text of an entity -with the name @var{name}. If the @var{name} starts with a @samp{%} the -rest of the name will be matched against parameter entities. - -@item doctype @var{name} @var{file} -The @var{file} will be used for the entity text of an entity -used as external subset of a document declaration with @var{name} as -document type name. - -@item sgmldecl @var{file} -Used to specify a default SGML declaration. Recognized but not used by -PSGML other than to pass to an external validation command -(@code{sgml-validate-command}). - -@end table - -When PSGML is looking for the file containing an external entity, the -following things will be tried in order: - -@enumerate - -@vindex sgml-system-identifiers-are-preferred -@item -Try the system identifier, as a file name, if there is a system -identifier and the variable @code{sgml-system-identifiers-are-preferred} -is non-@code{nil} and there is no elements containing @samp{%s} in -@code{sgml-public-map}. If the system identifier is a relative file name -it will be relative to the directory containing the defining entity. - -@item -Look thru each catalog in @code{sgml-local-catalogs} and -@code{sgml-catalog-files} in order. For each catalog look first for -entries matching the public identifier, if any. Then look for other -matching entries in the order they appear in the catalog. - -Currently an entry will be ignored if it is matching but its file is -non-existent or unreadable. (This is under reconsideration, perhaps it -should signal error instead). - -@item -Try the system identifier, if any, as a file name. -If @code{sgml-system-identifiers-are-preferred} is @code{nil} -and there is no elements containing @samp{%s} in @code{sgml-public-map}. - -@item -Try the entries in @code{sgml-public-map}. Using the catalogs are -preferred. The @code{sgml-public-map} may disappear in a future version -of PSGML (not soon though). - -@end enumerate - -The @code{sgml-public-map} variable can contain a list of file name -templates where @samp{%P} will be substituted with the whole public -identifier, owner is substituted for @samp{%O}, public text class for -@samp{%C}, and public text description for @samp{%D}. The text class -will be converted to lower case and the owner and description will be -transliterated according to the variable -@code{sgml-public-transliterations}. The templates in the list is tried -in order until an existing file is found. The @code{sgml-public-map} is -modeled after @file{sgmls} environment variable @code{SGML_PATH} and -psgml understand the following substitution characters: %%, %N, %P, %S, -%Y, %C, %L, %O, %T, and %V. The the default value of -@code{sgml-public-map} is taken from the environment variable -@code{SGML_PATH}. - -Given the public identifier above and the file name template -@samp{/usr/local/lib/sgml/%o/%c/%d}, the resulting file name is - -@example -/usr/local/lib/sgml/ISO_8879:1986/entities/Added_Latin_1 -@end example - -Note: blanks are transliterated to @samp{_} (and also @samp{/} to -@samp{%}) and the text class is down cased. - - - -@defopt sgml-catalog-files -This is a list of catalog entry files. -The files are in the format defined in the SGML Open Draft Technical -Resolution on Entity Management. The Emacs variable is initialized from -the environment variable @code{SGML_CATALOG_FILES} or if this variable -is undefined the default is - -@lisp -("CATALOG" "/usr/local/lib/sgml/CATALOG") -@end lisp -@end defopt - -@defopt sgml-local-catalogs -A list of SGML entity catalogs to be searched first when parsing the -buffer. This is used in addition to @code{sgml-catalog-files}, and -@code{sgml-public-map}. This variable is automatically local to the -buffer. -@end defopt - -@defopt sgml-system-identifiers-are-preferred -If @code{nil}, PSGML will look up external entities by searching the -catalogs in @code{sgml-local-catalogs} and @code{sgml-catalog-files} and -only if the entity is not found in the catalogs will a given system -identifier be used. If the variable is non-nil and a system identifier is -given, the system identifier will be used for the entity. If no system -identifier is given the catalogs will searched. -@end defopt - - -@defopt sgml-public-map -This should be a list of file name templates. This variable is -initialized from the environment variable @code{SGML_PATH}. This is -the same environment variable that @file{sgmls} uses. If the -environment variable is undefined the default is - -@lisp -("%S" "/usr/local/lib/sgml/%o/%c/%d") -@end lisp -@c Mapping from public identifiers to file names. -@end defopt - -@c the colon separated list in @code{SGML_PATH} is converted to a lisp list - -@c ------------------------------------------------------------------------- -@node Validate, SGML declaration, Entity manager, Top -@comment node-name, next, previous, up -@chapter Running an external SGML parser - -@kindex C-c C-v -@findex sgml-validate -PSGML can not validate an SGML document (see below what it can -and can't do). If you have a validating SGML parser, like -@file{sgmls}, you can run the parser on your file with the -command @kbd{C-c C-v} (@code{sgml-validate}). - -Some variables control this function: - -@defopt sgml-validate-command -The shell command to validate an SGML document. - -This is a @code{format} control string that by default should contain two -@code{%s} conversion specifications: the first will be replaced by the -value of @code{sgml-declaration} (or the empty string, if nil); the -second will be replaced by the current buffer's file name (or the -empty string, if nil). - -If @code{sgml-validate-files} is non-nil, the format string should contain -one @code{%s} conversion specification for each element of its result. - -If sgml-validate-command is a list, then every element should be a -string. The strings will be tried in order and @samp{%}-sequences in the -string will be replaced according to the list below, if the string contains -@samp{%}-sequences with no replacement value the next string will be tried. - -@table @code -@item %b -means the visited file of the current buffer - -@item %s -means the SGML declaration specified in the sgml-declaration variable - -@item %d -means the file containing the DOCTYPE declaration, if not in the buffer -@end table - -The default value is @code{nsgmls -s %s %s}. -@end defopt - -@defopt sgml-validate-files -If non-nil, a function of no arguments that returns a list of -file names. These file names will serve as the arguments to the -@code{sgml-validate-command} format control string instead of -the defaults. -@end defopt - -@defopt sgml-declaration -The name of the SGML declaration file. -@end defopt - -@defopt sgml-offer-save -If non-nil, @kbd{C-c C-v} (@code{sgml-validate}) will ask about -saving modified buffers before running the validate command. -The default value is @code{t}. -@end defopt - - -@kindex C-c C-o -@findex sgml-next-trouble-spot -The built-in parser can find some markup errors. The command @kbd{C-c -C-o} (@code{sgml-next-trouble-spot}) is the best way to use the built-in -parser for this. To check the whole file go to the beginning of the -buffer and use @kbd{C-c C-o}. - -Some of the markup errors not found are: - -@itemize @bullet -@item -Errors in the SGML declaration. -@item -Errors in attribute specifications. -@item -Omitted start-tags for empty elements. -@end itemize - - -@c -------------------------------------------------------------------------- -@node SGML declaration, Managing the DTD, Validate, Top -@comment node-name, next, previous, up -@chapter SGML Declaration -@cindex SHORTTAG -@cindex OMITTAG - -PSGML does not understand the SGML declaration, it accepts one in the -file but it is ignored. If you have the SGML declaration in another -file you can make @file{sgmls} use it when you use the @kbd{C-c C-v} -(@code{sgml-validate}) command (@pxref{Validate}). - -PSGML has some options in what features it uses and what markup it -creates. You have to set these options to make PSGML's behavior -consistent with your SGML declaration and personal preferences. - -@defopt sgml-omittag -Set this to @code{t} if the SGML declaration has @samp{OMITTAG YES} and -to @code{nil} otherwise. -@end defopt - -@defopt sgml-shorttag -Set this to @code{t} if the SGML declaration has @samp{SHORTTAG YES} and -to @code{nil} otherwise. -@end defopt - -@defopt sgml-always-quote-attributes -If non-nil, quote all attribute values inserted after finishing edit -attributes. If this variable is @code{nil} and @code{sgml-shorttag} is -non-@code{nil}, attribute values that consists of only name characters -will not be quoted. -@end defopt - -@defopt sgml-minimize-attributes -Determines minimization of attributes inserted by edit-attributes. If -non-nil, omit attribute name if the attribute value is from a token -group. If @code{max}, omit attributes with default value. Minimization -will only be done if they produce legal SGML (assuming -@code{sgml-omittag} and @code{sgml-shorttag} are set correctly). -@end defopt - - -@c -------------------------------------------------------------------------- -@node Managing the DTD, Edit, SGML declaration, Top -@comment node-name, next, previous, up -@chapter Document Type Declaration -@cindex DOCTYPE -@cindex DTD - -@vindex sgml-default-doctype-name -PSGML needs to know about the DTD you are using for many of its commands. -If you do not have a @samp{DOCTYPE} declaration in your file, -PSGML will try assume that there is one of the form - -@example - -@end example - -where @var{name} is the value of @code{sgml-default-doctype-name}, if -the value is non-@code{nil}, else the GI of the first tag will be used. - -@findex sgml-parse-prolog -@vindex sgml-auto-activate-dtd -PSGML will try to parse the document type declaration the first time -you do something that needs to parse the document or immediately if the -variable @code{sgml-auto-activate-dtd} is @code{t}. You can also -initiate the parsing of the document type declaration with the command -@code{sgml-parse-prolog}. Big DTDs take some time to parse. - -When the DTD has been parsed or loaded the name of the document element -will be displayed in the mode line inside brackets. If there was an -error parsing the DTD or there is no DTD, the mode line will display -@samp{[ANY]} (*** this is not really correct! a DTD will be established -even if there are missing entities, it may even be empty). - -@menu -* Precompiled DTD Subsets:: -* Using a Split Document:: -* Inserting a DOCTYPE:: -* Information from the DTD:: -@end menu - - -@c ------------------------------------------------------------ -@node Precompiled DTD Subsets, Using a Split Document, Managing the DTD, Managing the DTD -@comment node-name, next, previous, up -@section Precompiled DTD Subsets - -If parsing the DTD takes too long time you can arrange to have PSGML -cache an internal complied version of the DTD. Caching can be done of -DTD fragments in favourable situations. It is possible to have an -external DTD subset cached but still have an internal DTD subset as long -as the internal subset does not define parameter entities that affect -the parsing of the external subset (*** what is the exact conditions?, -probably you can't use the cached external subset if the internal subset -defines parameter entities that are also defined in the external subset -with another value). - -@vindex sgml-ecat-files -@vindex sgml-local-ecat-files -To enable caching you have to create special catalog files, hear after -called ECAT files due to (temporary) lack of imagination. These catalogs -have similar syntax to the entity catalogs and there are two variables -containing lists of catalogs to search: @code{sgml-ecat-files} and -@code{sgml-local-ecat-files}. The ECAT files can contain the following -types of entries: - -@table @samp -@item file @var{dtdfile} @var{entitydef} @var{cfile} -The @var{dtdfile} is the name of a file containing a DTD subset that -should be cached in @var{cfile}. The @var{entitydef} is optional and if -given have the following syntax: -@example -[ @var{name1} @var{literal1} @var{name2} @var{literal2} @dots{} ] -@end example -Using @var{entitydef} will modify the DTD subset by defining the -parameter entity with name @var{name1} to be @var{literal1}, @dots{}. The -cached version of the subset will be created with those entity -definitions, and when PSGML search for a matching cached subset will check -that the parameter entities in @var{entitydef} has been defined with -those values before trying to use @file{cfile}. - -@item public @var{pubid} @var{entitydef} @var{cfile} -Cache the DTD subset with public identifier @var{pubid} in file -@var{cfile}. -@end table - - -@defopt sgml-recompile-out-of-date-cdtd -If non-@code{nil}, out of date compiled DTDs will be automatically -recompiled. If the value is @code{ask}, PSGML will ask before -recompiling. A @code{nil} value will cause PSGML to silently load an out -of date compiled DTD. A DTD that refers to undefined external entities -is always out of date, thus in such case it can be useful to set this -variable to @code{nil}. -@end defopt - - -Previous versions of PSGML have had another way of speeding up DTD -parsing. This code remains in this version of PSGML, but is not actively -maintained and may disappear in the future. - -@findex sgml-save-dtd -@findex sgml-load-dtd -@vindex sgml-default-dtd-file -You can save the parsed DTD in a file using the command @kbd{M-x -sgml-save-dtd}. Next time PSGML can load that file instead of parsing -the DTD. For PSGML to find the saved DTD you must either save the DTD -using the default name or do a @kbd{M-x sgml-save-options} after saving -the DTD. To directly use an already parsed and saved DTD, load the file -containing the saved DTD with the command @kbd{M-x sgml-load-dtd}. - -@defopt sgml-default-dtd-file -This is the default file name for saved DTD. This is set by -@code{sgml-mode} to the buffer file name less extension plus the -extension @code{.ced}, if that file exists. Can be changed in the Local -variables section of the file. -@end defopt - -@c true with system-path -@c either or by creating a saved DTD and setting -@c @code{sgml-default-dtd-file} to that file. If -@c @code{sgml-default-dtd-file} contains a relative file name, the -@c directories in @code{sgml-system-path} will be searched for the file. - - -@c ------------------------------------------------------------ -@node Using a Split Document, Inserting a DOCTYPE, Precompiled DTD Subsets, Managing the DTD -@comment node-name, next, previous, up -@section Using a Split Document - -@c *** why not defopt?? -@vindex sgml-doctype -You can have the @samp{DOCTYPE} declaration in another file by setting -@code{sgml-doctype} to the other file. - -@defopt sgml-parent-document -Used when the current file is part of a bigger document. - -The variable describes how the current file's content fit into the element -hierarchy. The variable should have the form - -@lisp -(@var{parent-file} @var{context-element}* @var{top-element} (@var{has-seen-element}*)?) -@end lisp - -@table @var -@item parent-file -is a string, the name of the file containing the -document entity. - -@item context-element -is a string, that is the name of an element type. -It can occur 0 or more times and is used to set up -exceptions and short reference map. Good candidates -for these elements are the elements open when the -entity pointing to the current file is used. - -@item top-element -is a string that is the name of the element type -of the top level element in the current file. The file -should contain one instance of this element, unless -the last (lisp) element of sgml-parent-document is a -list. If it is a list, the top level of the file -should follow the content model of top-element. - -@item has-seen-element -is a string that is the name of an element type. This -element is satisfied in the content model of top-element. -@end table -@end defopt - - -@c ------------------------------------------------------------ -@node Inserting a DOCTYPE, Information from the DTD, Using a Split Document, Managing the DTD -@comment node-name, next, previous, up -@section Inserting a DOCTYPE - -@kindex C-c C-u C-d -@findex sgml-custom-dtd -*** Describe the DTD menu in general. Describe customized entries for -special DTDs. Mention @kbd{C-c C-u C-d} for inserting a DOCTYPE from -keyboard. - -If you change the doctype you must execute @code{sgml-parse-prolog}, -changes in the doctype are not automatically recognized. - -@defopt sgml-custom-dtd -Menu entries to be added to the DTD menu. The value should be a list of -entries to be added to the DTD menu. - -Every entry should be a list. The first element of the entry is a string -used as the menu entry. The second element is a string containing a -doctype declaration (this can be nil if no doctype). The rest of the -list should be a list of variables and values. For backward -compatibility a single string instead of a variable is assigned to -@code{sgml-default-dtd-file}. All variables are made buffer local and -are also added to the buffers local variables list. - -When an entry is selected from the DTD menu, the doctype declaration will -be inserted, the variables will be set to the values in the entry and a -local variables list will be created in the buffer. - -Example: - -@example - (("HTML" nil - sgml-default-dtd-file "~/sgml/html.ced" - sgml-omittag nil sgml-shorttag nil) - ("HTML+" "" - "~/sgml/htmlplus.ced" - sgml-omittag t sgml-shorttag nil) - ("DOCBOOK" "" - "~/sgml/docbook.ced" - sgml-omittag nil sgml-shorttag t))) -@end example -@end defopt - - -@c ------------------------------------------------------------ -@node Information from the DTD, , Inserting a DOCTYPE, Managing the DTD -@comment node-name, next, previous, up -@section Information from the DTD -@cindex DTD -@cindex Element - -PSGML can list various information about the current DTD. -The following commands can be used via @kbd{M-x} and -can also be found in the DTD menu. - -@table @code -@findex sgml-general-dtd-info -@item sgml-general-dtd-info -Display information about the current DTD. - -@findex sgml-describe-element-type -@item sgml-describe-element-type -Describe the properties of an element type as declared in the current DTD. - -@cindex entity -@findex sgml-describe-entity -@item sgml-describe-entity -Describe the properties of an entity as declared in the current DTD. - -@findex sgml-list-elements -@item sgml-list-elements -Will list all elements and the attributes declared for the element. - -@findex sgml-list-attributes -@item sgml-list-attributes - Will list all attributes declared and the elements that use them. - -@findex sgml-list-terminals -@item sgml-list-terminals -Will list all elements that can contain data. - -@findex sgml-list-occur-in-elements -@item sgml-list-occur-in-elements -Will list all element types and where it can occur. - -@findex sgml-list-content-elements -@item sgml-list-content-elements -Will list all element types and the element types that can occur -in its content. -@end table - - -@c --------------------------------------------------------------------------- -@node Edit, Display, Managing the DTD, Top -@comment node-name, next, previous, up -@chapter Commands for editing - -@menu -* Insert:: Inserting Markup -* Complete:: Markup completion -* Information:: Showing information -* Indent:: Indentation according to structure -* Move:: Move in the element structure -* Attributes:: Editing attributes -* Change and delete:: Changing and deleting markup -* Translating characters and entities:: -@end menu - -@c ------------------------------------------------------------------ -@node Insert, Complete, Edit, Edit -@comment node-name, next, previous, up -@section Inserting Markup - -@c erik says "inserts" ?? -The commands that insert start-tags works only if the document has an -associated DTD. - -Keyboard commands for inserting: - -@table @kbd -@kindex C-c < -@findex sgml-insert-tag -@item C-c < -Will ask, for the tag to insert, in the mini-buffer with completion on the -tags that are valid at point (@code{sgml-insert-tag}). - -If the option @code{sgml-balanced-tag-edit} is non-nil, inserting a -start-tag will also insert the corresponding end-tag. If, in addition, -@code{sgml-auto-insert-required-elements} is non-nil, tags for elements -required between the inserted tags will also be inserted. - -The list of valid tags, computed for a position in the buffer, will -contain: - -@enumerate -@item -The end-tag for the current element, if it can be ended at the position -and @code{sgml-balanced-tag-edit} is nil. Furthermore it will contain -end-tags for enclosing elements if the necessary omissible end-tag -declarations have been made in the DTD. - -@item -The start-tags of all elements that could occur after point. If -@code{sgml-omittag-transparent} is nil, the above will be limited to the -elements that can occur within the current element. -@end enumerate - - -@kindex C-c C-e -@findex sgml-insert-element -@vindex sgml-insert-end-tag-on-new-line -@item C-c C-e -Insert start and end-tags for an element -(@code{sgml-insert-element}). The name of the element is read -from the mini-buffer with completion on valid elements. If -@code{sgml-insert-end-tag-on-new-line} is non-nil or the -element has element content, the end-tag will be inserted on a -new line after the start-tag. - -@vindex sgml-omittag-transparent -If @code{sgml-omittag-transparent} is nil, the list of valid elements -will only contain the elements that can be in the content of the current -element. - -@vindex sgml-auto-insert-required-elements -@vindex sgml-insert-missing-element-comment -Required elements in the content will be automatically inserted if the -option @code{sgml-auto-insert-required-elements} is non-nil. -When the content model demands an element but there is more -than one to choose from, a comment can be inserted with the -available choices if the option -@code{sgml-insert-missing-element-comment} is non-nil. - -@kindex C-c C-r -@findex sgml-tag-region -@item C-c C-r -Makes the region into a new element (@code{sgml-tag-region}). Reads -element name from mini-buffer with completion as for @kbd{C-c C-e}. - -@kindex C-c / -@findex sgml-insert-end-tag -@item C-c / -Inserts an end-tag for the current element (@code{sgml-insert-end-tag}). - -@kindex C-c RET -@findex sgml-split-element -@item C-c RET -Split the current element at point. If repeated, the containing element -will be split before the beginning of then current element. - -Typical use is to start a new paragraph element when inside a paragraph. - -@kindex C-c + -@findex sgml-insert-attribute -@item C-c + -Read attribute name and value from mini-buffer and insert attribute -specification (@code{sgml-insert-attribute}). If point is immediately -after a start-tag, this command operates on that start-tag. Otherwise -the command will operate on the element after point. - -The attribute name will be read with completion. If the attribute has a -token list as declared value the attribute value will also be read with -completion. The prompt for attribute value will typically look like: - -@example -Value for @var{attribute} (@var{type} Default: @var{current value}): -@end example - -@kindex C-c C-u C-m -@findex sgml-custom-markup -@item C-c C-u C-m -Give keyboard access to the customized part of the Markup menu. -Emacs will prompt for the markup to insert using the menu line as -selector. (See @var{sgml-custom-markup} below.) - -@end table - -Menu bar: - -@table @samp -@item Markup -Selecting from this menu will insert markup. The menu contains -sub menus with tags and with entities, some other markup and a user -defined section. - -Sub menus: - -@item Insert element -Pops up a menu of valid elements and insert start and end-tags for -the selected element. Selections from the menu works like the @kbd{C-c -C-e} command. - -@item Insert start-tag -Pops up a menu of valid start-tags and insert the selected tag. The -menu has the same start-tags as the completion list for @kbd{C-c <}. - -@item Insert end-tag -Pops up a menu of valid end-tags and insert the selected tag. - -@item Tag region -Pops up a menu of valid elements and tag the region with the -selection. Selections from the menu works like the @kbd{C-c C-r} -command. - -@item Insert entity -Menu of all general entities defined in the DTD. - -@item Insert attribute -Pops up a menu with all the attributes of an element. The element is -either the one which start-tag is immediately before point or the -element after point. Selecting from this menu edits the attribute -specification list for the element. - -The menu has a sub menu for every attribute which declared value is a -token list. The rest of the attributes are collected in one sub menu. -For the token list attributes, selecting a value will insert that -attribute-value pair. Selecting some other attribute reads the -attribute-value from the mini-buffer and inserts the attribute value -pair. -@end table - -@kindex S-@key{mouse-1} -A menu is also available directly with a mouse button click in the -buffer. In GNU Emacs it is the first mouse button combined with shift -(@kbd{S-@key{mouse-1}}). In XEmacs it is bound to the third mouse -button. The mouse button click will pop-up a menu of valid tags or a -menu of attributes if the point is in a start-tag. The attributes menu -works as the ``Insert attribute'' menu from the menu-bar. The tags list -is the list of valid tags described above for command @kbd{C-c <}. -Selection from the tags menu works like the @kbd{C-c <} command, with -the following exception: - -You can tag a region, with start and end-tag. There are two ways to -indicate the region to mark: - -@enumerate -@item -Use the normal mouse commands to mark region. - -For this to work you must either use @dfn{transient mark mode} -(@pxref{Transient Mark, , Transient Mark Mode, emacs, The Emacs -Editor}) or set the option @code{sgml-tag-region-if-active} to non-nil -(don't set this unless you are sure that you want it). - -@item -Alternatively make a secondary selection, this is done by holding down -the meta key and using the mouse buttons. -@xref{Secondary selection, , , emacs, The Emacs Editor}. -Some window managers intercept these events, which makes it hard use the -secondary selection in Emacs. -@end enumerate - -@defopt sgml-balanced-tag-edit -If non-nil, inserting a start-tag will also insert the corresponding -end-tag. -@end defopt - -@defopt sgml-auto-insert-required-elements -If non-nil, automatically inserts required elements in the content -of an inserted element. -@end defopt - -@defopt sgml-omittag-transparent -If non-nil, will show legal tags inside elements with omissible start-tags -and legal tags beyond omissible end-tags. -@end defopt - -@defopt sgml-tag-region-if-active -If non-nil, the @samp{Insert tags} menu will tag a region if the region -is considered active by emacs. If nil, region must be active and -@code{transient-mark-mode} must be on for the region to be tagged. -@end defopt - -@defopt sgml-custom-markup -Menu entries to be added to the Markup menu. The value should be a list -of lists of two strings. The first string is the menu line and the -second string is the text inserted when the menu item is selected. The -second string can contain a @samp{\r} where the cursor should be left. -Also, if a selection is made according to the same rules as for the -@kbd{S-mouse-1} menu, the selection is replaced with the second string -and @samp{\r} is replaced with the selection. - -Example: - -@example - (("Version1" "") - ("New page" "")) -@end example -@end defopt - - -@defopt sgml-insert-missing-element-comment -If non-nil, and sgml-auto-insert-required-elements also true, -@code{sgml-insert-element} will insert a comment if there is an -element required but there is more than one to choose from. -@end defopt - -@defopt sgml-insert-end-tag-on-new-line -If non-nil, @code{sgml-insert-element} will put the end-tag on -a new line after the start-tag. Useful on slow terminals if you -find the end-tag after the cursor irritating. -@end defopt - - -@c ------------------------------------------------------------------------- -@node Complete, Information, Insert, Edit -@comment node-name, next, previous, up -@section Markup completion - -@kindex M-TAB -@findex sgml-complete -If you are typing in markup directly, @kbd{M-TAB} will help you by -completing a tag name, an entity name or a markup declaration name. If -you type @kbd{M-TAB} after a plain word, @code{ispell-complete-word} -will be invoked instead. - -If you have typed (@point{} marks the position of point) - -@example -&At@point{} -@end example - -@noindent and type @kbd{M-TAB} (assuming you use the @file{ISOLat1} -entity set) you get: - -@example -Ã@point{} -@end example - - -@c --------------------------------------------------------------------------- -@node Information, Indent, Complete, Edit -@comment node-name, next, previous, up -@section Showing information - -Commands for showing information obtained by parsing the buffer. - -@table @kbd -@kindex C-c C-c -@findex sgml-show-context -@item C-c C-c -Shows in the message area: context at point, if in a tag or in mixed -content and the open elements (@code{sgml-show-context}). - -@kindex C-c C-w -@findex sgml-what-element -@item C-c C-w -Shows what element the character after point (under the cursor) belongs -to; also shows context of element (@code{sgml-what-element}). - -@kindex C-c C-t -@findex sgml-list-valid-tags -@item C-c C-t -List contextually valid tags (@code{sgml-list-valid-tags}). Displays -information about current element, all valid end-tags, valid start-tags -in current element, and start-tags valid at this point but in other -elements together with the tags omitted. -@end table - -You can make the mode-line display the name of the current open element -by setting the @code{sgml-live-element-indicator} variable. Setting -this will make all commands slower due to the work needed to keep the -mode-line up to date. - -@defopt sgml-live-element-indicator -If non-nil, indicate current element in mode line. - -NOTE: Setting this implies that every command can cause a parse. -@end defopt - - - -@c -------------------------------------------------------------------------- -@node Indent, Move, Information, Edit -@comment node-name, next, previous, up -@section Indentation according to structure - -@kindex @key{TAB} -@kindex @key{LFD} -@findex sgml-indent-or-tab -@findex newline-and-indent -You can indent a line according to the depth of element nesting at the -beginning of the line. To indent the current line use @kbd{@key{TAB}}. -You can also use @kbd{@key{LFD}} (@code{newline-and-indent}) to start a -new line with correct indentation. - -@defopt sgml-indent-step -How much to increment indent for every element level. If nil, no -indentation. - -If this is nil, @kbd{@key{TAB}} will insert a tab instead of indenting. -@end defopt - -@defopt sgml-indent-data -If non-nil, indent in data/mixed context also. -@end defopt - - - -@c --------------------------------------------------------------------------- -@node Move, Attributes, Indent, Edit -@comment node-name, next, previous, up -@section Move in the element structure - -These commands move in the element structure. The commands uses -knowledge of SGML syntax, and if available the specific DTD. - -@table @kbd -@kindex C-M-a -@findex sgml-beginning-of-element -@item C-M-a -Move to the (content) beginning of the current element -(@code{sgml-beginning-of-element}). - -@kindex C-M-e -@findex sgml-end-of-element -@item C-M-e -Move to the (content) end of the current element (@code{sgml-end-of-element}). - -@kindex C-M-f -@findex sgml-forward-element -@item C-M-f -Move forward by element (@code{sgml-forward-element}). - -@kindex C-M-b -@findex sgml-backward-element -@item C-M-b -Move backward by element (@code{sgml-backward-element}). - -@kindex C-M-u -@findex sgml-backward-up-element -@item C-M-u -Move up to before current element (@code{sgml-backward-up-element}). - -@kindex C-c C-n -@findex sgml-up-element -@item C-c C-n -Move up to after current element (@code{sgml-up-element}). - -@kindex C-M-d -@findex sgml-down-element -@item C-M-d -Move down to the (content) beginning of the next element -(@code{sgml-down-element}). - -@kindex C-c C-d -@findex sgml-next-data-field -@item C-c C-d -Move to the next place where data is allowed (@code{sgml-next-data-field}). -@end table - -You can also move to the next place where there is some structural error -with @kbd{C-c C-o} (@pxref{Validate}). - - -@c --------------------------------------------------------------------------- -@node Attributes, Change and delete, Move, Edit -@comment node-name, next, previous, up -@section Editing attributes - -@findex sgml-edit-attributes -@kindex C-c C-a -If you want to change the attributes of a start-tag you can simply edit -them directly in the buffer. Or you can place the cursor at or after -the start-tag and use the @code{sgml-edit-attributes} command, available -from the @samp{SGML}-menu or on @kbd{C-c C-a}. This will create a new -Emacs window with all possible attributes listed in the form - -@example -@var{attribute name} = @var{current value}. -@end example - -The @var{current value} may be shown as @samp{#DEFAULT} if the attribute -has not been given a value in the start-tag. The list also contains the -attributes declaration as a comment. Note also that the @var{current -value} is show without eventual quotes. - -@kindex C-c C-d -@kindex @key{TAB} -It is now possible to edit the attribute values. You can move to the -next attribute with @kbd{@key{TAB}}. If you want to let an attribute -have its default value use @kbd{C-c C-d}, this will insert a -@samp{#DEFAULT} in the value field. - -If Emacs is running in an X window, the @samp{#DEFAULT} will be -underlined to distinguish it from normal values. - -@kindex C-c C-c -Finish the editing with @kbd{C-c C-c}; this will replace the attribute -values in the main buffer with those edited. Note that values will be -quoted as needed. - -If you want to abort the editing, you can remove the window with -@kbd{C-x 0} or if you want it neat, kill the buffer and remove the -window. - -Some other keys are: -@table @kbd -@kindex C-a -@findex sgml-edit-attrib-field-start -@item C-a -Go to the beginning of the value field -(@code{sgml-edit-attrib-field-start}). - -@kindex C-e -@findex sgml-edit-attrib-field-end -@item C-e -Go to the end of the value field -(@code{sgml-edit-attrib-field-end}). - -@kindex C-c C-k -@findex sgml-edit-attrib-clear -@item C-c C-k -Clear the value field -(@code{sgml-edit-attrib-clear}). - -@kindex C-c C-d -@findex sgml-edit-attrib-default -@item C-c C-d -Set the value field to @samp{#DEFAULT} -(@code{sgml-edit-attrib-default}). This is a special value that will -make the attribute be implied. -@end table - - -@c -------------------------------------------------------------------------- -@node Change and delete, Translating characters and entities, Attributes, Edit -@comment node-name, next, previous, up -@section Changing and deleting markup - -@table @kbd -@kindex C-c = -@findex sgml-change-element-name -@item C-c = -Change the name of the current element (@code{sgml-change-element-name}). -Tries to translate attribute specifications. An attribute will be -translated to an attribute with the same name. If the new element has -no attribute with the same name, the attribute will be ignored. If -there is an attribute with the same name but different declared content, -a warning is given. - -ID attributes are handled specially, an attribute with declared value ID -will always be translated to the attribute with declared value ID. - -@kindex C-c C-k -@findex sgml-kill-markup -@item C-c C-k -Kill next tag, markup declaration or process instruction -(@code{sgml-kill-markup}). - -@kindex C-M-k -@findex sgml-kill-element -@item C-M-k -Kill the element following the cursor (@code{sgml-kill-element}). - -@kindex C-c - -@findex sgml-untag-element -@item C-c - -Remove tags from current element (@code{sgml-untag-element}). - -@kindex C-c # -@findex sgml-make-character-reference -@item C-c # -Convert character after point to a character reference -(@code{sgml-make-character-reference}). If called with a numeric -argument, convert a character reference back to a normal character. - -@kindex C-c C-q -@findex sgml-fill-element -@item C-c C-q -Fills an element as a paragraph (@code{sgml-fill-element}). This is a -substitute for the normal @code{fill-paragraph}. The command uses -heuristics to decide what should be a paragraph. - -@enumerate -@item -If point is in an element content, recursively fill the sub-elements. -@item -Find the biggest element with mixed content containing point. -@item -If the above element is mixed but contains elements with pure element -content then fill what is between the pure elements as paragraphs and -fill the pure elements recursively. -@end enumerate - -@findex sgml-expand-all-shortrefs -@item M-x sgml-expand-all-shortrefs -Short references to text entities are expanded to the replacement text -of the entity other short references are expanded into general entity -references. If argument, @var{to-entity}, is non-@code{nil}, or if -called interactive with numeric prefix argument, all short references -are replaced by generally entity references. - -@findex sgml-normalize -@item M-x sgml-normalize -Normalize the document in the buffer. This will - -@enumerate -@item -expand short references, -@item -insert missing tags, -@item -replace minimized tags with full tags, -@item -fix attribute specification lists according to options set. -@end enumerate - -There is one argument, @var{to-entity}, with the same meaning as for -@code{sgml-expand-all-shortrefs}. - -There is one option for the normalize command. With its default value, -normalize may actually change the data content of some elements. But -only by removing some white-space from the end of elements with omitted -end-tags. -@end table - -@defopt sgml-normalize-trims -If non-nil, @code{sgml-normalize} will trim off white space from end of -element when adding end-tag. - -Default: @code{t}. -@end defopt - - -@c -------------------------------------------------------------------------- -@node Translating characters and entities, , Change and delete, Edit -@comment node-name, next, previous, up -@section Translating between characters and entity references - -@c *** Need work.. - -Set the variable @code{sgml-display-char-list-filename} to a file file that -contains mappings between all characters present in the presentation -character set, and their "standard replacement text" names, e.g. "å" --> "[aring ]", e.t.c. - -The default value for this variable is `iso88591.map'. - -The use the functions (also in the Modify menu) - -@table @code -@findex sgml-charent-to-display-char -@item sgml-charent-to-display-char -@findex sgml-display-char-to-charent -@item sgml-display-char-to-charent -@end table - -to translate between entities and characters. - -@c --------------------------------------------------------------------------- -@node Display, Miscellaneous options, Edit, Top -@comment node-name, next, previous, up -@chapter Appearance of text in the buffer - -@menu -* Fold:: Folding editing -* Hiding markup:: -* Highlight:: Highlighting markup -@end menu - -@c --------------------------------------------------------------------------- -@node Fold, Hiding markup, Display, Display -@comment node-name, next, previous, up -@section Folding editing - -With these commands you can make parts of the text temporarily invisible -to make it easier to see the overall structure of your text. - -When folding a region all the lines but the first will be invisible. -The first line of the region will still be visible with an ellipsis at -the end. - -@xref{Outline Mode, , , emacs, The Emacs Editor}. - -@table @kbd -@kindex C-c C-f C-r -@findex sgml-fold-region -@item C-c C-f C-r -The region between point and mark will be folded (@code{sgml-fold-region}). - -@kindex C-c C-f C-e -@findex sgml-fold-element -@item C-c C-f C-e -The region between the start and end of the current element will be -folded (@code{sgml-fold-element}). - -This command can also fold the SGML declaration or the DOCTYPE -declaration. - -@kindex C-c C-f C-s -@findex sgml-fold-subelement -@item C-c C-f C-s -Fold all the sub elements of the current element -(@code{sgml-fold-subelement}). - -@kindex C-c C-s -@kindex C-c C-u C-l -@findex sgml-unfold-line -@item C-c C-s -@itemx C-c C-u C-l -Unfold the current line, assuming it is the first line of a folded -region (@code{sgml-unfold-line}). - -@kindex C-c C-u C-e -@findex sgml-unfold-element -@item C-c C-u C-e -Make all lines in current element visible (@code{sgml-unfold-element}). - -@kindex C-c C-u C-a -@findex sgml-unfold-all -@item C-c C-u C-a -Make all lines in current buffer visible (@code{sgml-unfold-all}). - -@kindex C-c C-f C-x -@findex sgml-expand-element -@item C-c C-f C-x -Unfold current element and then fold the subelements -(@code{sgml-expand-element}). If the current element is folded this -expands what is visible. -@end table - - -@c --------------------------------------------------------------------------- -@node Hiding markup, Highlight, Fold, Display -@comment node-name, next, previous, up -@section Hiding markup - -*** Describe hide-tags - - -@c --------------------------------------------------------------------------- -@node Highlight, , Hiding markup, Display -@comment node-name, next, previous, up -@section Highlighting markup - - -PSGML can highlight the markup giving the markup a different @dfn{face} -(@pxref{Faces, , Using Multiple Typefaces, emacs, The Emacs Editor}). -The highlighting will only be done if the variable @code{sgml-set-face} -is non-@code{nil}. The default settings make tags bold and comments -italic, but this can be modified with the variable -@code{sgml-markup-faces}. When highlighting is on PSGML will parse after -every command until the whole buffer has been parsed or user event -occurs. - -@findex sgml-clear-faces -To remove the highlighting type @kbd{M-x sgml-clear-faces}. - -@defopt sgml-set-face -If non-nil, psgml will set the face of parsed markup. -@end defopt - -@defopt sgml-markup-faces -A list of markup to face mappings. -Each element looks like @code{(@var{markup-type} . @var{face})}. -Possible values for @var{markup-type} is: - -@table @code -@item comment -comment declaration -@item doctype -doctype declaration -@item end-tag -end-tag -@item ignored -ignored marked section -@item ms-start -marked section end, if not ignored -@item ms-end -marked section start, if not ignored -@item pi -processing instruction -@item sgml -SGML declaration -@item start-tag -start-tag -@item entity -entity reference -@item shortref -short reference -@end table -@end defopt - - - -@c ------------------------------------------------------------------ -@node Miscellaneous options, Bugs, Display, Top -@comment node-name, next, previous, up -@chapter Miscellaneous options - -*** describe sgml-save-options - -@defopt sgml-ignore-undefined-elements -Start-tags for undefined elements will either be ignored, if -@code{sgml-ignore-undefined-elements} is @code{t}, or assumed to be -acceptable in the current element and defined with @code{O O ANY} -@end defopt - -@defopt sgml-range-indicator-max-length -Maximum number of characters used from the first and last entry -of a sub-menu to indicate the range of that menu. - -@vindex sgml-max-menu-size -This is used for long menus of elements, tags or entities that are split -into @code{sgml-max-menu-size} big sub-menus. -@end defopt - - - - -@c ------------------------------------------------------------------ -@node Bugs, Index, Miscellaneous options, Top -@comment node-name, next, previous, up -@chapter Bugs - - -If you encounter something that you think is a bug, please report -it. Try to include a clear description of the undesired behaviour. -A test case that exhibits the bug, would also be useful. - -You can report a bug with the command @kbd{M-x sgml-submit-bug-report}. - -When PSGML needs contextual information it parses the document up to -the point. During the parsing, it builds a parse tree. The parse -tree is used to initialize the next parse, to avoid having to parse -things already parsed. Changes to the buffer is supposed to prune -the tree of all outdated information. But if you get strange -complaints from the parser, try and back up a bit and use @kbd{C-c -C-o} (@code{sgml-next-trouble-spot}). - - - -@c ------------------------------------------------------------------ -@node Index, , Bugs, Top -@comment node-name, next, previous, up -@chapter Index - -@printindex cp - -@contents -@bye diff -r d3e9274cbc4e -r e45d5e7c476e man/umlaute.texi --- a/man/umlaute.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -@catcode`@ß=@active -@catcode`@Ä=@active -@catcode`@ä=@active -@catcode`@Ö=@active -@catcode`@ö=@active -@catcode`@Ü=@active -@catcode`@ü=@active -@defß{@ss} -@defÄ{@"A} -@defä{@"a} -@defÖ{@"O} -@defö{@"o} -@defÜ{@"U} -@defü{@"u} diff -r d3e9274cbc4e -r e45d5e7c476e man/viper.texi --- a/man/viper.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4422 +0,0 @@ -% -*-texinfo-*- - -% -\input texinfo - -@comment Using viper.info instead of viper in setfilename breaks DOS. -@comment @setfilename viper -@comment @setfilename viper.info -@setfilename ../info/viper - -@iftex -@finalout -@end iftex - -@titlepage -@title Viper Is a Package for Emacs Rebels -@subtitle a Vi emulator for GNU Emacs 20 and XEmacs 20 -@subtitle August 1997, Viper Version 3.0 (Polyglot) - -@author Michael Kifer (Viper) -@author Aamod Sane (VIP 4.4) -@author Masahiko Sato (VIP 3.5) - -@page -@vskip 0pt plus 1fill -@end titlepage - -@unnumbered Distribution - -@noindent -Copyright @copyright{} 1995, 1996, 1997 Free Software Foundation, Inc. - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the same conditions as for modified versions. - -@ifinfo -@node Top, Overview,, (DIR) - -@unnumbered Viper - -We believe that one or more of the following statements are adequate -descriptions: - -@example -Viper Is a Package for Emacs Rebels; -it is a VI Plan for Emacs Rescue -and/or a venomous VI PERil. -@end example - -Technically speaking, Viper is a Vi emulation package for GNU Emacs and -XEmacs. It implements all Vi and Ex commands, occasionally improving on -them and adding many new features. It gives the user the best of both -worlds: Vi keystrokes for editing combined with the power of Emacs environment. - -Viper emulates Vi at several levels, from the one that closely follows Vi -conventions to the one that departs from many of them. It has many -customizable options, which can be used to tailor Viper to the work habits -of various users. -This manual describes Viper, concentrating on the differences from Vi and -new features of Viper. - -Viper, formerly known as VIP-19, was written by Michael Kifer. It is based -on VIP version 3.5 by Masahiko Sato and VIP version 4.4 by Aamod Sane. -Viper tries to be compatible with these packages. - -Viper is intended to be usable without reading this manual --- the defaults -are set to make Viper as close to Vi as possible. At startup, Viper will -try to set the most appropriate default environment for you, based on -your familiarity with Emacs. It will also tell you the basic GNU Emacs window -management commands to help you start immediately. - -Although this manual explains how to customize Viper, some basic -familiarity with Emacs Lisp would be a plus. - -It is recommended that you read the Overview node. The other nodes may -be visited as needed. - -Comments and bug reports are welcome. -@code{kifer@@cs.emacs.edu} is the current address for Viper bug reports. -Please use the Ex command @kbd{:submitReport} for this purpose.@refill - -@end ifinfo - -@menu -* Overview:: Must read to get started -* Improvements over Vi:: New features, Improvements -* Customization:: How to customize Viper -* Commands:: Vi and Ex Commands - -* Key Index:: Index of Vi and Ex Commands -* Function Index:: Index of Viper Functions -* Variable Index:: Index of Viper Variables -* Package Index:: Index of Packages Mentioned in this Document -* Concept Index:: Vi, Ex and Emacs concepts - -* Acknowledgments:: -@end menu -@iftex -@unnumbered Introduction - -We believe that one or more of the following statements are adequate -descriptions: - -@example -Viper Is a Package for Emacs Rebels; -it is a VI Plan for Emacs Rescue -and/or a venomous VI PERil. -@end example - -Viper is a Vi emulation package for GNU Emacs 20 and XEmacs 20. Viper -contains virtually all of Vi and Ex functionality and much more. It -gives you the best of both worlds: Vi keystrokes for editing combined -with the GNU Emacs environment. Viper also fixes some common complaints -with Vi commands. This manual describes Viper, concentrating on the -differences from Vi and on the new features of Viper. - -Viper was written by Michael Kifer. It is based on VIP version 3.5 by -Masahiko Sato and VIP version 4.4 by Aamod Sane. Viper tries to be -compatible with these packages. - -Viper is intended to be usable out of the box, without reading this manual ---- the defaults are set to make Viper as close to Vi as possible. At -startup, Viper will attempt to set the most appropriate default environment -for you, based on your familiarity with Emacs. It will also tell you the -basic GNU Emacs window management commands to help you start immediately. - -Although this manual explains how to customize Viper, some basic -familiarity with Emacs Lisp would be a plus. - -It is recommended that you read the chapter Overview. The other chapters -will be useful for customization and advanced usage. - -You should also learn to use the Info on-line hypertext manual system that -comes with Emacs. This manual can be read as an Info file. Try the command -@kbd{@key{ESC} x info} with vanilla Emacs sometime. - -Comments and bug reports are welcome. -@code{kifer@@cs.sunysb.edu} is the current address for Viper bug reports. -Please use the Ex command @kbd{:submitReport} for this purpose.@refill - -@end iftex - -@node Overview,Improvements over Vi,Top,Top -@chapter Overview of Viper - -Viper is a Vi emulation on top of Emacs. At the same time, Viper provides a -virtually unrestricted access to Emacs facilities. Perfect compatibility -with Vi is possible but not desirable. This chapter tells you about the -Emacs ideas that you should know about, how to use Viper within Emacs and -some incompatibilities. - -Viper was formerly known as VIP-19, which was -a descendant of VIP 3.5 by Masahiko Sato and VIP 4.4 by Aamod Sane. - -@menu -* Emacs Preliminaries:: Basic concepts in Emacs. -* Loading Viper:: Loading and Preliminary Configuration. -* States in Viper:: Viper has four states orthogonal to - modes in Emacs. -* The Minibuffer:: Command line in Emacs. -* Multiple Files in Viper:: True multiple file handling. -* Unimplemented Features:: That are unlikely to be implemented. -@end menu - -@node Emacs Preliminaries, Loading Viper, Overview, Overview -@section Emacs Preliminaries - -@cindex buffer -@cindex point -@cindex mark -@cindex text -@cindex looking at -@cindex end (of buffer) -@cindex end (of line) -@cindex region - -Emacs can edit several files at once. A file in Emacs is placed in a -@dfn{buffer} that usually has the same name as the file. Buffers are also used -for other purposes, such as shell interfaces, directory editing, etc. -@xref{Dired,,Directory Editor,emacs,The -Gnu Emacs Manual}, for an example.@refill - -A buffer has a distinguished position called the @dfn{point}. -A @dfn{point} is always between 2 characters, and is @dfn{looking at} -the right hand character. The cursor is positioned on the right hand -character. Thus, when the @dfn{point} is looking at the end-of-line, -the cursor is on the end-of-line character, i.e. beyond the last -character on the line. This is the default Emacs behavior.@refill - -The default settings of Viper try to mimic the behavior of Vi, -preventing the cursor from going beyond the last character on the line. -By using Emacs commands directly (such as those bound to arrow keys), it is -possible -to get the cursor beyond the end-of-line. However, this won't (or shouldn't) -happen if you restrict yourself to standard Vi keys, unless you modify the -default editing style. @xref{Customization}.@refill - -In addition to the @dfn{point}, there is another distinguished buffer -position called the @dfn{mark}. @xref{Mark,,Mark,emacs,The GNU Emacs -manual}, for more info on the mark. The text between the @dfn{point} and the -@dfn{mark} is called the @dfn{region} of the buffer. For the Viper user, -this simply means that in addition to the Vi textmarkers a--z, there is -another marker called @dfn{mark}. This is similar to the unnamed Vi marker -used by the jump commands (`` and ''), which move the cursor to the -position of the last absolute jump. -Viper provides access to the region in most -text manipulation commands as @kbd{r} and @kbd{R} suffix to commands -that operate on text regions, e.g., @kbd{dr} to delete region, etc. -@xref{Basics}, for more info.@refill - -@cindex window -@cindex mode line -@cindex buffer information -@cindex Minibuffer -@cindex command line -@cindex buffer (modified) - -Emacs divides the screen into tiled @dfn{windows}. You can see the -contents of a buffer through the window associated with the buffer. The -cursor of the screen is positioned on the character after @dfn{point}. -Every window has a @dfn{mode line} that displays information about the buffer. -You can change the format of the mode -line, but normally if you see @samp{**} at the beginning of a mode line it -means that the buffer is @dfn{modified}. If you write out the contents of -a buffer to a file, then the buffer will become not modified. Also if -you see @samp{%%} at the beginning of the mode line, it means that the file -associated with the buffer is write protected. The mode line will also -show the buffer name and current major and minor modes (see below). -A special buffer called @dfn{Minibuffer} is displayed as the last line -in a Minibuffer window. The Minibuffer window is used for command input -output. Viper uses Minibuffer window for @kbd{/} and @kbd{:} -commands.@refill - -@cindex mode -@cindex keymap -@cindex local keymap -@cindex global keymap -@cindex major mode -@cindex minor mode - -An Emacs buffer can have a @dfn{major mode} that customizes Emacs for -editing text of a particular sort by changing the functionality of the keys. -Keys are defined using a @dfn{keymap} that records the bindings between -keystrokes and -functions. The @dfn{global keymap} is common to all the -buffers. Additionally, each buffer has its @dfn{local keymap} that determines the -@dfn{mode} of the buffer. If a function is bound to some key in the local -keymap then that function will be executed when you type the key. -If no function is bound to a key in the -local map, however, the function bound to the key in the global map -will be executed. @xref{Major Modes,Major Modes,Major Modes,emacs,The -GNU Emacs Manual}, for more information.@refill - -A buffer can also have a @dfn{minor mode}. Minor modes are options that -you can use or not. A buffer in @code{text-mode} can have -@code{auto-fill-mode} as minor mode, which can be turned off or on at -any time. In Emacs, a minor mode may have it own keymap, -which overrides the local keymap when the minor mode is turned on. For -more information, @pxref{Minor Modes,Minor Modes,Minor Modes,emacs,The -GNU Emacs Manual} @refill - -@cindex Viper as minor mode -@cindex Control keys -@cindex Meta key - -Viper is implemented as a collection of minor modes. Different minor modes -are involved when Viper emulates Vi command mode, Vi insert mode, etc. -You can also turn Viper on and off at any time while in Vi command mode. -@xref{States in Viper}, for -more information.@refill - -Emacs uses Control and Meta modifiers. These are denoted as C and M, -e.g. @kbd{^Z} as @kbd{C-z} and @kbd{Meta-x} as @kbd{M-x}. The Meta key is -usually located on each side of the Space bar; it is used in a manner -similar to the Control key, e.g., @kbd{M-x} means typing @kbd{x} while -holding the Meta key down. For keyboards that do not have a Meta key, -@key{ESC} is used as Meta. Thus @kbd{M-x} is typed as @kbd{@key{ESC} -x}. Viper uses @key{ESC} to switch from Insert state to Vi state. Therefore -Viper defines @kbd{C-\} as its Meta key in Vi state. @xref{Vi State}, for -more info.@refill - -Emacs is structured as a lisp interpreter around a C core. Emacs keys -cause lisp functions to be called. It is possible to call these -functions directly, by typing @kbd{M-x function-name}. - -@node Loading Viper, States in Viper, Emacs Preliminaries, Overview -@section Loading Viper - -The most common way to load it automatically is to include the following -lines (in the given order!): - -@lisp -(setq viper-mode t) -(require 'viper) -@end lisp - -@noindent -in your @file{~/.emacs} file. The @file{.emacs} file is placed in your -home directory and it is be executed every time you invoke Emacs. This is -the place where all general Emacs customization takes place. Beginning with -version 20.0, Emacsen have an interactive interface, which simplifies the -job of customization significantly. - -Viper also uses the file @file{~/.viper} for Viper-specific customization. -If you wish to be in Vi command state whenever this is deemed appropriate -by the author, you can include the following line in your @file{.viper}: -@lisp -(setq viper-always t) -@end lisp -@noindent -(@xref{Vi State}, for the explanation of Vi command state.) - -The location of Viper customization file can be changed by setting the -variable @code{viper-custom-file-name} in @file{.emacs} @emph{prior} to loading -Viper. - -Once invoked, Viper will arrange to bring up Emacs buffers in Vi state -whenever this makes sense. -@xref{Packages that Change Keymaps}, to find out when forcing Vi command state -on a buffer may be counter-productive. - -Even if your @file{.emacs} and @file{.viper} files do not contain any of the -above lines, you can still load Viper and enter Vi command state by typing the -following from within Emacs: - -@lisp -M-x viper-mode -@end lisp - -When Emacs first comes up, if you have not specified a file on the -command line, it will show the @samp{*scratch*} buffer, in the -@samp{Lisp Interaction} mode. After you invoke Viper, you can start -editing files by using @kbd{:e}, @kbd{:vi}, or @kbd{v} commands. -(@xref{File and Buffer Handling}, for more information on @kbd{v} and other -new commands that, in many cases, are more convenient than @kbd{:e}, -@kbd{:vi}, and similar old-style Vi commands.)@refill - -Finally, if at some point you would want to get de-Viperize your running -copy of Emacs after Viper has been loaded, the command @kbd{M-x -viper-go-away} will do it for you. The function @code{toggle-viper-mode} -toggles Viperization of Emacs on and off. - -@node States in Viper, The Minibuffer, Loading Viper,Overview -@section States in Viper - -@kindex @kbd{C-z} -@kindex @key{ESC} -@kindex @kbd{i} -@cindex Emacs state -@cindex Vi state -@cindex Insert state -@cindex Replace state -@cindex Ex commands -@findex @code{viper-go-away} -@findex @code{toggle-viper-mode} - -Viper has four states, Emacs, Vi, Insert, and Replace. - -@table @samp -@item Emacs state -This is the state plain vanilla Emacs is normally in. After you have loaded -Viper, @kbd{C-z} will normally take you to Vi command state. Another -@kbd{C-z} will take you back to Emacs state. This toggle key can be -changed, @pxref{Customization} You can also type @kbd{M-x viper-mode} to -change to Vi state.@refill - - -For users who chose to set their user level to 1 at Viper setup time, -switching to Emacs state is deliberately made harder in order to not -confuse the novice user. In this case, @kbd{C-z} will either iconify Emacs -(if Emacs runs as an application under X Windows) or it will stop Emacs (if -Emacs runs on a dumb terminal or in an Xterm window). - -@item Vi state -This is the Vi command mode. Any of the Vi commands, such as @kbd{i, o, a}, -@dots{}, will take you to Insert state. All Vi commands may -be used in this mode. Most Ex commands can also be used. -For a full list of Ex commands supported by Viper, type -@kbd{:} and then @key{TAB}. To get help on any issue, including the Ex -commands, type @kbd{:help}. This will invoke Viper Info -(if it is installed). Then typing @kbd{i} will prompt you for a topic to -search in the index. Note, to search for Ex commands in the index, you -should start them with a ``@kbd{:}'', e.g., @kbd{:WW}. - -@item Insert state -Insert state is the Vi insertion mode. @key{ESC} will take you back to -Vi state. Insert state editing can be done, including auto-indentation. By -default, Viper disables Emacs keybindings in Insert state. - -@item Replace state -Commands like @kbd{cw} invoke the Replace state. When you cross the -boundary of a replacement region (usually designated via a @samp{$} sign), -it will automatically change to Insert state. You do not have to worry -about it. The key bindings remain practically the same as in Insert -state. If you type @key{ESC}, Viper will switch to Vi command mode, terminating the -replacement state. @refill -@end table - -@cindex mode line - -The modes are indicated on the @dfn{mode line} as , , , and , -so that the multiple modes do not confuse you. Most of your editing can be -done in Vi and Insert states. Viper will try to make all new buffers be in Vi -state, but sometimes they may come up in Emacs state. @kbd{C-z} -will take you to Vi state in such a case. In some major modes, like Dired, -Info, Gnus, etc., you should not switch to Vi state (and Viper will not -attempt to do so) because these modes are not intended for text editing and -many of the Vi keys have special meaning there. If you plan to read news, -browse directories, read mail, etc., from Emacs (which you should start -doing soon!), you should learn about the meaning of the various keys in -those special modes (typing @kbd{C-h m} in a buffer provides -help with key bindings for the major mode of that buffer). - -If you switch to Vi in Dired or similar modes---no harm is done. It is just -that the special keybindings provided by those modes will be temporarily -overshadowed by Viper's bindings. Switching back to Viper's Emacs state -will revive the environment provided by the current major mode. - -States in Viper are orthogonal to Emacs major modes, such as C mode or Dired -mode. You can turn Viper on and off for any Emacs state. When Viper is turned -on, Vi state can be used to move around. In Insert state, the bindings for -these modes can be accessed. For beginners (users at Viper levels 1 and 2), -these bindings are suppressed in Insert state, so that new users are not -confused by the Emacs states. Note that unless you allow Emacs bindings in -Insert state, you cannot do many interesting things, like language -sensitive editing. For the novice user (at Viper level 1), all major mode -bindings are turned off in Vi state as well. This includes the bindings for -key sequences that start with @kbd{C-c}, which practically means that all -major mode bindings are supported. @xref{Customization}, to find out how -to allow Emacs keys in Insert state. - -@menu -* Emacs State:: This is the state you should learn more about when - you get up to speed with Viper. -* Vi State:: Vi commands are executed in this state. -* Insert State:: You can enter text, and also can do sophisticated - editing if you know enough Emacs commands. -* Replace State:: Like Insert mode, but it is invoked via the - replacement commands, such as cw, C, R, etc. -@end menu - -@node Emacs State, Vi State, States in Viper, States in Viper -@subsection Emacs State - -@kindex @kbd{C-z} -@cindex Emacs state - - -You will be in this mode only by accident (hopefully). This is the state -Emacs is normally in (imagine!!). Now leave it as soon as possible by -typing @kbd{C-z}. Then you will be in Vi state (sigh of relief) :-). - -Emacs state is actually a Viperism to denote all the major and minor modes -(@xref{Emacs Preliminaries}) other than Viper that Emacs can be in. Emacs -can have several modes, such as C mode for editing C programs, LaTeX mode -for editing LaTeX documents, Dired for directory editing, etc. These are -major modes, each with a different set of key-bindings. Viper states are -orthogonal to these Emacs major modes. The presence of these language -sensitive and other modes is a major win over Vi. @xref{Improvements over -Vi}, for more.@refill - -The bindings for these modes can be made available in the Viper Insert state -as well as in Emacs state. Unless you specify your user level as 1 (a -novice), all major mode key sequences that start with @kbd{C-x} and -@kbd{C-c} are also available in Vi state. This is important because major -modes designed for editing files, such as cc-mode or latex-mode, use key -sequences that begin with @kbd{C-x} and @kbd{C-c}. - -There is also a key that lets you temporarily escape to Vi command state -from Emacs or Insert states: typing @kbd{C-c \} will let you execute a -single Vi command while staying in Viper's Emacs or Insert state. -In Insert state, the same can also be achieved by typing @kbd{C-z}. - - -@node Vi State, Insert State, Emacs State, States in Viper -@subsection Vi State - -@cindex Vi state - -This is the Vi command mode. When Viper is in Vi state, you will see the sign - in the mode line. Most keys will work as in Vi. The notable -exceptions are: - -@table @kbd -@item C-x -@kindex @kbd{C-x} -@kbd{C-x} is used to invoke Emacs commands, mainly those that do window -management. @kbd{C-x 2} will split a window, @kbd{C-x 0} will close a -window. @kbd{C-x 1} will close all other windows. @kbd{C-xb} is used to -switch buffers in a window, and @kbd{C-xo} to move through windows. -These are about the only necessary keystrokes. -For the rest, see the GNU Emacs Manual. - -@item C-c -@kindex @kbd{C-c} -For user levels 2 and higher, this key serves as a prefix key for the key -sequences used by various major modes. For users at Viper level 1, @kbd{C-c} -simply beeps. - -@item C-g and C-] -@kindex @kbd{C-g} -@kindex @kbd{C-]} - -These are the Emacs @samp{quit} keys. -There will be cases where you will have to -use @kbd{C-g} to quit. Similarly, @kbd{C-]} is used to exit -@samp{Recursive Edits} in Emacs for which there is no comparable Vi -functionality and no key-binding. Recursive edits are indicated by -@samp{[]} brackets framing the modes on the mode line. -@xref{Recursive Edit,Recursive -Edit,Recursive Edit,emacs,The GNU Emacs Manual}. -At user level 1, @kbd{C-g} is bound to @code{viper-info-on-file} -function instead. -@refill -@item C-\ -@kindex @kbd{C-\} -@cindex Meta key - -Viper uses @key{ESC} as a switch between Insert and Vi states. Emacs uses -@key{ESC} for Meta. The Meta key is very important in Emacs since many -finctions are accessible only via that key as @kbd{M-x function-name}. -Therefore, we need to simulate it somehow. In Viper's Vi, Insert, and -Replace states, the meta key is set to be @kbd{C-\}. Thus, to get -@kbd{M-x}, you should type @kbd{C-\ x} (if the keyboard has no Meta key). -This works both in the Vi command state and in the Insert and Replace -states. In Vi command state, you can also use @kbd{\ @key{ESC}} as the -meta key. - -Note: Emacs binds @kbd{C-\} to a function that offers to change the -keyboard input method in the multilingual environment. Viper overrides this -binding. However, it is still possible to switch the input method by typing -@kbd{\ C-\} in the Vi command state and @kbd{C-z \ C-\} in the Insert state. -Or you can use the MULE menu in the menubar. -@end table -@noindent -Other differences are mostly improvements. The ones you should know -about are: - -@table @samp -@item Undo -@kindex @kbd{u} -@kbd{u} will undo. Undo can be repeated by the @kbd{.} key. Undo itself -can be undone. Another @kbd{u} will change the direction. The presence -of repeatable undo means that @kbd{U}, undoing lines, is not very -important. Therefore, @kbd{U} also calls @code{viper-undo}. -@cindex multiple undo -@cindex undo - - -@item Counts -Most commands, @kbd{~}, @kbd{[[}, @kbd{p}, @kbd{/}, @dots{}, etc., take counts. - -@comment ]] Just to balance parens -@item Regexps -Viper uses Emacs Regular Expressions for searches. These are a superset of -Vi regular -expressions, excepting the change-of-case escapes @samp{\u}, @samp{\L}, -@dots{}, etc. @xref{Regular Expressions,,Regular Expressions,emacs,The -GNU Emacs Manual}, for details. -Files specified to @kbd{:e} use @code{csh} regular expressions -(globbing, wildcards, what have you). -However, the function @code{viper-toggle-search-style}, bound to @kbd{C-c /}, -lets the user switch from search with regular expressions to plain vanilla -search and vice versa. It also lets one switch from case-sensitive search -to case-insensitive and back. -@xref{Viper Specials}, for more details. -@cindex regular expressions -@cindex vanilla search -@cindex case-sensitive search -@cindex case-insensitive search -@kindex @kbd{C-c /} - -@item Ex commands -@cindex Ex commands -The current working directory of a buffer is automatically inserted in the -minibuffer if you -type @kbd{:e} then space. -Absolute filenames are required less often in Viper. -For path names, -Emacs uses a convention that is slightly different from that of Unix. -It is designed to minimize the need for deleting path names that Emacs -provides in its prompts. (This is usually convenient, but occasionally -the prompt may suggest a wrong path name for you.) If you see a prompt -@kbd{/usr/foo/} and you wish to edit the file @kbd{~/.viper}, you don't -have to erase the prompt. Instead, simply continue typing what you -need. Emacs will interpret @kbd{/usr/foo/~/.viper} correctly. Similarly, -if the prompt is @kbd{~/foo/} and you need to get to @kbd{/bar/file}, keep -typing. Emacs interprets @kbd{~/foo//bar/} as @kbd{/bar/file}, since when it -sees @samp{//}, it understands that @kbd{~/foo/} is to be discarded. - -The command @kbd{:cd} will change the default directory for the -current buffer. The command @kbd{:e} will interpret the -filename argument in @code{csh}. @xref{Customization}, if you -want to change the default shell. -The command @kbd{:next} takes counts from -@kbd{:args}, so that @kbd{:rew} is obsolete. Also, @kbd{:args} will show only -the invisible files (i.e., those that are not currently seen in Emacs -windows). - -When applicable, Ex commands support file completion and history. This -means that by typing a partial file name and then @key{TAB}, Emacs will try -to complete the name or it will offer a menu of possible completions. -This works similarly to Tcsh and extends the behavior of Csh. While Emacs -is waiting for a file name, you can type @kbd{M-p} to get the previous file -name you typed. Repeatedly typing @kbd{M-p} and @kbd{M-n} will let you -browse through the file history. - -Like file names, partially typed Ex commands can be completed by typing -@key{TAB}, and Viper keeps the history of Ex commands. After typing -@kbd{:}, you can browse through the previously entered Ex commands by -typing @kbd{M-p} and @kbd{M-n}. Viper tries to rationalize when it puts Ex -commands on the history list. For instance, if you typed @kbd{:w! foo}, -only @kbd{:w!} will be placed on the history list. This is because the -last history element is the default that can be invoked simply by typing -@kbd{: @key{RET}}. If @kbd{:w! foo} were placed on the list, it would be all to -easy to override valuable data in another file. Reconstructing the full -command, @kbd{:w! foo}, from the history is still not that hard, since Viper -has a separate history for file names. By typing @kbd{: M-p}, you will get -@kbd{:w!} in the Minibuffer. Then, repeated @kbd{M-p} will get you through -the file history, inserting one file name after another. - -In contrast to @kbd{:w! foo}, if the command were @kbd{:r foo}, the entire -command will appear in the history list. This is because having @kbd{:r} -alone as a default is meaningless, since this command requires a file -argument. -@refill -@end table -@noindent -As Vi, Viper's destructive commands can be re-executed by typing `@kbd{.}'. -However, in addition, Viper keeps track of the history of such commands. This -history can be perused by typing @kbd{C-c M-p} and @kbd{C-c M-n}. -Having found the appropriate command, it can be then executed by typing -`@kbd{.}'. -@xref{Improvements over Vi}, for more information. - -@node Insert State, Replace State, Vi State, States in Viper -@subsection Insert State - -@cindex Insert state - -To avoid confusing the beginner (at Viper level 1 and 2), Viper makes only the -standard Vi keys available in Insert state. The implication is that -Emacs major modes cannot be used Insert state. -It is strongly recommended that as soon as you are comfortable, make the -Emacs state bindings visible (by changing your user level to 3 or higher). -@xref{Customization}, -to see how to do this.@refill - -Once this is done, it is possible to do quite a bit of editing in -Insert state. For instance, Emacs has a @dfn{yank} command, @kbd{C-y}, -which is similar to Vi's @kbd{p}. However, unlike @kbd{p}, @kbd{C-y} can be -used in Insert state of Viper. Emacs also has a kill ring where it keeps -pieces of text you deleted while editing buffers. The command @kbd{M-y} is -used to delete the text previously put back by Emacs' @kbd{C-y} or by Vi's -@kbd{p} command and reinsert text that was placed on the kill-ring earlier. - -This works both in Vi and Insert states. -In Vi state, @kbd{M-y} is a much better alternative to the usual Vi's way -of recovering the 10 previously deleted chunks of text. In Insert state, -you can -use this as follows. Suppose you deleted a piece of text and now you need -to re-insert it while editing in Insert mode. The key @kbd{C-y} will put -back the most recently deleted chunk. If this is not what you want, type -@kbd{M-y} repeatedly and, hopefully, you will find the chunk you want. - -Finally, in Insert and Replace states, Viper provides the history of -pieces of text inserted in previous insert or replace commands. These -strings of text can be recovered by repeatedly typing @kbd{C-c M-p} or -@kbd{C-c M-n} while in Insert or Replace state. (This feature is disabled -in the minibuffer: the above keys are usually bound to other histories, -which are more appropriate in the minibuffer.) - - -@cindex Meta key - -You can call Meta functions from Insert state. As in Vi state, the Meta key -is @kbd{C-\}. Thus @kbd{M-x} is typed as @kbd{C-\ x}. - -Other Emacs commands that are useful in Insert state are @kbd{C-e} -and @kbd{C-a}, which move the cursor to the end and the beginning of the -current line, respectively. You can also use @kbd{M-f} and @kbd{M-b}, -which move the cursor forward (or backward) one word. -If your display has a Meta key, these functions are invoked by holding the -Meta key and then typing @kbd{f} and @kbd{b}, respectively. On displays -without the Meta key, these functions are invoked by typing -@kbd{C-\ f} and @kbd{C-\ b} (@kbd{C-\} simulates the Meta key in Insert -state, as explained above). - -The key @kbd{C-z} is sometimes also useful in Insert state: it allows you -to execute a single command in Vi state without leaving the Insert state! -For instance, @kbd{C-z d2w} will delete the next two words without leaving -the Insert state. - -When Viper is in Insert state, you will see in the mode line. - -@node Replace State,, Insert State, States in Viper -@subsection Replace State - -@cindex Replace state - -This state is entered through Vi replacement commands, such as @kbd{C}, -@kbd{cw}, etc., or by typing @kbd{R}. In Replace state, Viper puts in -the mode line to let you know which state is in effect. If Replace state is -entered through @kbd{R}, Viper stays in that state until the user hits -@key{ESC}. If this state is entered via the other replacement commands, -then Replace state is in effect until you hit @key{ESC} or until you cross -the rightmost boundary of the replacement region. In the latter case, Viper -changes its state from Replace to Insert (which you will notice by the -change in the mode line). - -Since Viper runs under Emacs, it is possible to switch between buffers -while in Replace state. You can also move the cursor using the arrow keys -(even on dumb terminals!) and the mouse. Because of this freedom (which is -unattainable in regular Vi), it is possible to take the cursor outside the -replacement region. (This may be necessary for several reasons, including -the need to enable text selection and region-setting with the mouse.) - -The issue then arises as to what to do when the user -hits the @key{ESC} key. In Vi, this would cause the text between cursor and -the end of the replacement region to be deleted. But what if, as is -possible in Viper, the cursor is not inside the replacement region? - -To solve the problem, Viper keeps track of the last cursor position while it -was still inside the replacement region. So, in the above situation, Viper -would delete text between this position and the end of the replacement -region. - -@node The Minibuffer,Multiple Files in Viper, States in Viper, Overview -@section The Minibuffer - -@cindex Minibuffer - -The Minibuffer is where commands are entered in. Editing can be done -by commands from Insert state, namely: - -@table @kbd -@item C-h -Backspace -@item C-w -Delete Word -@item C-u -Erase line -@item C-v -Quote the following character -@item @key{RET} -Execute command -@item C-g and C-] -Emacs quit and abort keys. These may be necessary. @xref{Vi State}, for an -explanation. -@item M-p and M-n -These keys are bound to functions that peruse minibuffer history. The -precise history to be perused depends on the context. It may be the history -of search strings, Ex commands, file names, etc. -@end table - -Most of the Emacs keys are functional in the Minibuffer. While in the -Minibuffer, Viper tries to make editing resemble Vi's behavior when the -latter is waiting for the user to type an Ex command. In particular, you -can use the regular Vi commands to edit the Minibuffer. You can switch -between the Vi state and Insert state at will, and even use the replace mode. -Initially, the Minibuffer comes up in Insert state. - -Some users prefer plain Emacs bindings in the Minibuffer. To this end, set -@code{viper-vi-style-in-minibuffer} to @code{nil} in @file{.viper}. -@xref{Customization}, to learn how to do this. - -When the Minibuffer changes Viper states, you will notice that the appearance -of the text there changes as well. This is useful because the Minibuffer -has no mode line to tell which Vi state it is in. -The appearance of the text in the Minibuffer can be changed. -@xref{Viper Specials}, for more details. - -@node Multiple Files in Viper,Unimplemented Features,The Minibuffer,Overview -@section Multiple Files in Viper - -@cindex multiple files -@cindex managing multiple files - -Viper can edit multiple files. This means, for example that you never need -to suffer through @code{No write since last change} errors. -Some Viper elements are common over all the files. - -@table @samp -@item Textmarkers -@cindex markers -@cindex textmarkers -Textmarkers remember @emph{files and positions}. -If you set marker @samp{a} in -file @file{foo}, start editing file @file{bar} and type @kbd{'a}, then -@emph{YOU WILL SWITCH TO FILE @file{foo}}. You can see the contents of a -textmarker using the Viper command @kbd{[} where are the -textmarkers, e.g., @kbd{[a} to view marker @samp{a} .@refill -@item Repeated Commands -Command repetitions are common over files. Typing @kbd{!!} will repeat the -last @kbd{!} command whichever file it was issued from. -Typing @kbd{.} will repeat the last command from any file, and -searches will repeat the last search. Ex commands can be repeated by typing -@kbd{: @key{RET}}.@refill -Note: in some rare cases, that @kbd{: @key{RET}} may do something dangerous. -However, usually its effect can be undone by typing @kbd{u}. -@item Registers -@cindex registers -Registers are common to files. Also, text yanked with @kbd{y} can be -put back (@kbd{p}) into any file. The Viper command @kbd{]}, where are -the registers, can be used to look at the contents of a register, e.g., -type @kbd{]a} to view register @samp{a}. - -There is one difference in text deletion that you should be -aware of. This difference comes from Emacs and was adopted in Viper -because we find it very useful. In Vi, if you delete a line, say, and then -another line, these two deletions are separated and are put back -separately if you use the @samp{p} command. In Emacs (and Viper), successive -series of deletions that are @emph{not interrupted} by other commands are -lumped together, so the deleted text gets accumulated and can be put back -as one chunk. If you want to break a sequence of deletions so that the -newly deleted text could be put back separately from the previously deleted -text, you should perform a non-deleting action, e.g., move the cursor one -character in any direction. -@item Absolute Filenames -@cindex absolute paths -The current directory name for a file is automatically prepended to the -file name in any -@kbd{:e}, @kbd{:r}, @kbd{:w}, etc., command (in Emacs, each buffer has a -current directory). -This directory is inserted in the Minibuffer once you type space after -@kbd{:e, r}, etc. Viper also supports completion of file names and Ex -commands (@key{TAB}), and it keeps track of -command and file history (@kbd{M-p}, @kbd{M-n}). -Absolute filenames are required less -often in Viper. - -You should be aware that Emacs interprets @kbd{/foo/bar//bla} as -@kbd{/bla} and @kbd{/foo/~/bar} as @kbd{~/bar}. This is designed to -minimize the need for erasing path names that Emacs suggests in its -prompts, if a suggested path name is not what you wanted. - -The command @kbd{:cd} will change the default directory for the -current Emacs buffer. The Ex command @kbd{:e} will interpret the -filename argument in @samp{csh}, by default. @xref{Customization}, if you -want to change this. -@end table - -@noindent -Currently undisplayed files can be listed using the @kbd{:ar} command. The -command @kbd{:n} can be given counts from the @kbd{:ar} list to switch to -other files. - -@node Unimplemented Features,,Multiple Files in Viper,Overview -@section Unimplemented Features - -Unimplemented features include: - -@itemize @bullet -@item -@kbd{:ab} and @kbd{:una} are not implemented. -Both @kbd{:map} and @kbd{:ab} are considered obsolete, since Emacs has much -more powerful facilities for defining keyboard macros and abbreviations. -@item -@kbd{:set option?} is not implemented. The current -@kbd{:set} can also be used to set Emacs variables. -@item -@kbd{:se list} requires modification of the display code for Emacs, so -it is not implemented. -A useful alternative is @code{cat -t -e file}. Unfortunately, it cannot -be used directly inside Emacs, since Emacs will obdurately change @samp{^I} -back to normal tabs.@refill -@end itemize - -@comment node-name, next, previous, up -@node Improvements over Vi, Customization, Overview, Top -@chapter Improvements over Vi - -Some common problems with Vi and Ex have been solved in Viper. This -includes better implementation of existing commands, new commands, and -the facilities provided by Emacs. - -@menu -* Basics:: Basic Viper differences, Multi-file effects. -* Undo and Backups:: Multiple undo, auto-save, backups and changes -* History:: History for Ex and Vi commands. -* Macros and Registers:: Keyboard Macros (extended ".") @@reg execution. -* Completion:: Filename and Command Completion for Ex. -* Improved Search:: Incremental Search and Buffer Content Search. -* Abbreviation Facilities:: Normal Abbrevs, Templates, and Dynamic Abbrevs. -* Movement and Markers:: Screen Editor movements, viewing textmarkers. -* New Commands:: Commands that do not exist in Vi. -* Useful Packages:: A Sampling of some Emacs packages, and things - you should know about. -@end menu - -@node Basics, Undo and Backups, Improvements over Vi, Improvements over Vi -@section Basics - -The Vi command set is based on the idea of combining motion commands -with other commands. The motion command is used as a text region -specifier for other commands. -We classify motion commands into @dfn{point commands} and -@dfn{line commands}.@refill - -@cindex point commands - -The point commands are: - -@quotation -@kbd{h}, @kbd{l}, @kbd{0}, @kbd{$}, @kbd{w}, @kbd{W}, @kbd{b}, @kbd{B}, -@kbd{e}, @kbd{E}, @kbd{(}, @kbd{)}, @kbd{/}, @kbd{?}, @kbd{`}, @kbd{f}, -@kbd{F}, @kbd{t}, @kbd{T}, @kbd{%}, @kbd{;}, @kbd{,}, @kbd{^} -@end quotation - -@cindex line commands - -The line commands are: - -@quotation -@kbd{j}, @kbd{k}, @kbd{+}, @kbd{-}, @kbd{H}, @kbd{M}, @kbd{L}, @kbd{@{}, -@kbd{@}}, @kbd{G}, @kbd{'}, @kbd{[[}, @kbd{]]}, @kbd{[]} -@end quotation - -@cindex region -@cindex region specification -@cindex expanding (region) -@cindex describing regions -@cindex movement commands - -@noindent -If a point command is given as an argument to a modifying command, the -region determined by the point command will be affected by the modifying -command. On the other hand, if a line command is given as an argument to a -modifying command, the region determined by the line command will be -enlarged so that it will become the smallest region properly containing the -region and consisting of whole lines (we call this process @dfn{expanding -the region}), and then the enlarged region will be affected by the modifying -command. -Text Deletion Commands (@xref{Deleting Text}), Change commands -(@xref{Changing Text}), even Shell Commands (@xref{Shell Commands}) -use these commands to describe a region of text to operate on. -Thus, type @kbd{dw} to delete a word, @kbd{>@}} to shift a paragraph, or -@kbd{!'afmt} to format a region from @samp{point} to textmarker -@samp{a}. - -@cindex r and R region specifiers - -Viper adds the region specifiers @samp{r} and @samp{R}. Emacs has a -special marker called @dfn{mark}. The text-area between the current cursor -position @dfn{point} and the @dfn{mark} is called the @dfn{region}. -@samp{r} specifies the raw region and @samp{R} is the expanded region -(i.e., the minimal contiguous chunk of full lines that contains the raw -region). -@kbd{dr} will now delete the region, @kbd{>r} will shift it, etc. -@kbd{r,R} are not motion commands, however. The special mark is set by -@kbd{m.} and other commands. @xref{Marking}, for more info. - -Viper also adds counts to most commands for which it would make sense. - -In the Overview chapter, some Multiple File issues were discussed -(@xref{Multiple Files in Viper}). In addition to the files, Emacs has -buffers. These can be seen in the @kbd{:args} list and switched using -@kbd{:next} if you type @kbd{:set ex-cycle-through-non-files t}, or -specify @code{(setq ex-cycle-through-non-files t)} in your @file{.viper} -file. @xref{Customization}, for details. - -@node Undo and Backups, History, Basics, Improvements over Vi -@section Undo and Backups - -@cindex undo - -Viper provides multiple undo. The number of undo's and the size is limited -by the machine. The Viper command @kbd{u} does an undo. Undo can be -repeated by typing @kbd{.} (a period). Another @kbd{u} will undo the undo, -and further -@kbd{.} will repeat it. Typing @kbd{u} does the first undo, and changes the -direction. - -@cindex backup files -@cindex auto save - -Since the undo size is limited, Viper can create backup files and -auto-save files. It will normally do this automatically. It is possible -to have numbered backups, etc. For details, @pxref{Backup,,Backup and -Auto-Save,emacs,The GNU Emacs Manual} @refill - -@comment [ balance parens -@cindex viewing registers and markers -@cindex registers -@cindex markers -@cindex textmarkers - -The results of the 9 previous changes are available in the 9 numeric -registers, as in Vi. The extra goody is the ability to @emph{view} these -registers, in addition to being able to access them through @kbd{p} and -@kbd{M-y} (@xref{Insert State}, for details.) -The Viper command @kbd{] register} will display the contents of any -register, numeric or alphabetical. The related command @kbd{[ textmarker} -will show the text around the textmarker. @samp{register} and @samp{textmarker} -can be any letters from a through z. -@comment ] balance parens - -@node History, Macros and Registers, Undo and Backups,Improvements over Vi -@section History - -@cindex history -@cindex Minibuffer - -History is provided for Ex commands, Vi searches, file names, pieces of -text inserted in earlier commands that use Insert or Replace state, and for -destructive commands in Vi state. These are -useful for fixing those small typos that screw up searches and @kbd{:s}, -and for eliminating routine associated with repeated typing of file names -or pieces of text that need to be inserted frequently. -At the @kbd{:} or @kbd{/} prompts in the Minibuffer, you can do the following: - -@table @kbd -@item M-p and M-n -To move to previous and next history items. This causes the history -items to appear on the command line, where you can edit them, or -simply type Return to execute. -@item M-r and M-s -To search backward and forward through the history. -@item @key{RET} -Type @key{RET} to accept a default (which is displayed in the prompt). -@end table - -The history of insertions can be perused by -typing @kbd{C-c M-p} and @kbd{C-c M-n} while in Insert or Replace state. -The history of destructive Vi commands can be perused via the same keys -when Viper is in Vi state. @xref{Viper Specials}, for details. - -All Ex commands have a file history. For instance, typing @kbd{:e}, space -and then @kbd{M-p} will bring up the name of the previously typed file -name. Repeatedly typing @kbd{M-p}, @kbd{M-n}, etc., will let you browse -through the file history. - -Similarly, commands that have to do with switching buffers -have a buffer history, and commands that expect strings or regular -expressions keep a history on those items. - -@node Macros and Registers,Completion,History,Improvements over Vi -@section Macros and Registers - -@cindex keyboard macros -@cindex macros -@cindex registers -@cindex register execution - -Viper facilitates the use of Emacs-style keyboard macros. @kbd{@@#} will -start a macro definition. As you type, the commands will be executed, and -remembered (This is called ``learn mode'' in some editors.) -@kbd{@@register} will complete the macro, putting it into @samp{register}, -where @samp{register} is any character from @samp{a} through @samp{z}. Then -you can execute this macro using @kbd{@@register}. It is, of course, -possible to yank some text into a register and execute it using -@kbd{@@register}. Typing @kbd{@@@@}, @kbd{@@RET}, or @kbd{@@C-j} will -execute the last macro that was executed using @kbd{@@register}.@refill - -Viper will automatically lowercase the register, so that pressing the -@kbd{SHIFT} key for @kbd{@@} will not create problems. This is for -@kbd{@@} macros and @kbd{"p} @emph{only}. In the case of @kbd{y}, -@kbd{"Ayy} will append to @emph{register a}. For @kbd{[,],',`}, it -is an error to use a Uppercase register name. - -@comment [ balance parens -@cindex viewing registers and markers - -The contents of a register can be seen by @kbd{]register}. (@kbd{[textmarker} -will show the contents of a textmarker). -@comment ] balance parens - -@cindex last keyboard macro - -The last keyboard macro can also be executed using -@kbd{*}, and it can be yanked into a register using @kbd{@@!register}. -This is useful for Emacs style keyboard macros defined using @kbd{C-x(} -and @kbd{C-x)}. Emacs keyboard macros have more capabilities. -@xref{Keyboard Macros,,Keyboard Macros,emacs, The GNU Emacs Manual}, for -details.@refill - -Keyboard Macros allow an interesting form of Query-Replace: -@kbd{/pattern} or @kbd{n} to go to the next pattern (the query), followed by a -Keyboard Macro execution @kbd{@@@@} (the replace). - -Viper also provides Vi-style macros. @xref{Vi Macros}, for details. - - -@node Completion, Improved Search, Macros and Registers, Improvements over Vi -@section Completion - -@cindex completion - -Completion is done when you type @key{TAB}. The Emacs completer does not -grok wildcards in filenames. Once you type a wildcard, the completer will -no longer work for that path. Remember that Emacs interprets a file name -of the form @kbd{/foo//bar} as @kbd{/bar} and @kbd{/foo/~/bar} as -@kbd{~/bar}. - -@node Improved Search, Abbreviation Facilities, Completion, Improvements over Vi -@section Improved Search - -@cindex buffer search -@cindex word search - -Viper provides buffer search, the ability to search the buffer for a region -under the cursor. You have to turn this on in @file{.viper} either by calling - -@example -(viper-buffer-search-enable) -@end example - -@noindent -or by setting @code{viper-buffer-search-char} to, say, @kbd{f3}: -@example -(setq viper-buffer-search-char [f3]) -@end example - -@noindent -If the user calls @code{viper-buffer-search-enable} explicitly (the first -method), then @code{viper-buffer-search-char} will be set to @kbd{g}. -Regardless of how this feature is enabled, the key -@code{viper-buffer-search-char} will take movement commands, like -@kbd{w,/,e}, to find a region and then search for the contents of that -region. This command is very useful for searching for variable names, etc., -in a program. The search can be repeated by @kbd{n} or reversed by @kbd{N}. - -@cindex incremental search - -Emacs provides incremental search. As you type the string in, the -cursor will move to the next match. You can snarf words from the buffer -as you go along. Incremental Search is normally bound to @kbd{C-s} and -@kbd{C-r}. @xref{Customization}, to find out how to change the bindings -of @kbd{C-r or C-s}. -For details, @pxref{Incremental Search,,Incremental -Search,emacs,The GNU Emacs Manual} @refill - -@cindex query replace - -Viper also provides a query replace function that prompts through the -Minibuffer. It is invoked by the @kbd{Q} key in Vi state. - -@cindex mouse search - -On a window display, Viper supports mouse search, i.e., you can search for a -word by clicking on it. @xref{Viper Specials}, for details. - -Finally, on a window display, Viper highlights search patterns as it finds -them. This is done through what is known as @emph{faces} in Emacs. The -variable that controls how search patterns are highlighted is -@code{viper-search-face}. If you don't want any highlighting at all, put -@example -(copy-face 'default 'viper-search-face) -@end example -@vindex @code{viper-search-face} -@noindent -in @file{~/.viper}. If you want to change how patterns are highlighted, you -will have to change @code{viper-search-face} to your liking. The easiest -way to do this is to use Emacs customization widget, which is accessible -from the menubar. Viper customization group is located under the -@emph{Emulations} customization group, which in turn is under the -@emph{Editing} group. All Viper faces are grouped together under Viper's -@emph{Highlighting} group. - -Try it: it is really simple! - -@node Abbreviation Facilities,Movement and Markers,Improved Search,Improvements over Vi -@section Abbreviation Facilities - -@cindex abbrevs - -It is possible in Emacs to define abbrevs based on the contents of the -buffer. -Sophisticated templates can be defined using the Emacs abbreviation -facilities. @xref{Abbrevs,,Abbreviations,emacs,The GNU Emacs Manual}, for -details. - -@cindex dynamic abbrevs - -Emacs also provides Dynamic Abbreviations. Given a partial word, Emacs -will search the buffer to find an extension for this word. For instance, -one can type @samp{Abbreviations} by typing @samp{A}, followed by a keystroke -that completed the @samp{A} to @samp{Abbreviations}. Repeated typing -will search further back in the buffer, so that one could get -@samp{Abbrevs} by repeating the -keystroke, which appears earlier in the text. Emacs binds this to -@kbd{@key{ESC} /}, so you will have to find a key and bind the function -@code{dabbrev-expand} to that key. -Facilities like this make Vi's @kbd{:ab} command obsolete. - -@node Movement and Markers, New Commands, Abbreviation Facilities, Improvements over Vi -@section Movement and Markers - -@cindex Ex style motion -@cindex line editor motion - -Viper can be set free from the line--limited movements in Vi, such as @kbd{l} -refusing to move beyond the line, @key{ESC} moving one character back, -etc. These derive from Ex, which is a line editor. If your @file{.viper} -contains - -@example -@code{(setq viper-ex-style-motion nil)} -@end example - -@noindent -the motion will be a true screen editor motion. One thing you must then -watch out for is that it is possible to be on the end-of-line character. -The keys @kbd{x} and @kbd{%} will still work correctly, i.e., as if they -were on the last character. - -@vindex @code{viper-syntax-preference} -@cindex syntax table - -The word-movement commands @kbd{w}, @kbd{e}, etc., and the associated -deletion/yanking commands, @kbd{dw}, @kbd{yw}, etc., can be made to -understand Emacs syntax tables. If the variable -@code{viper-syntax-preference} is set to @code{strict-vi} then -the meaning of @emph{word} is the same as in -Vi. However, if the value is @code{reformed-vi} (the default) then the -alphanumeric symbols will be those specified by the current Emacs syntax -table (which may be different for different major modes) plus the -underscore symbol @kbd{_}, minus some non-word symbols, like '.;,|, etc. -Both @code{strict-vi} and @code{reformed-vi} work close to Vi in -traditional cases, but @code{reformed-vi} does a better job when editing -text in non-Latin alphabets. - -The user can also specify the value @code{emacs}, which would -make Viper use exactly the Emacs notion of word. In particular, the -underscore may not be part of a word. Finally, if -@code{viper-syntax-preference} is set to @code{extended}, Viper words would -consist of characters that are classified as alphanumeric @emph{or} as -parts of symbols. This is convenient for writing programs and in many other -situations. - -@code{viper-syntax-preference} is a local variable, so it can have different -values for different major modes. For instance, in programming modes it can -have the value @code{extended}. In text modes where words contain special -characters, such as European (non-English) letters, Cyrillic letters, etc., -the value can be @code{reformed-vi} or @code{emacs}. - -Changes to @code{viper-syntax-preference} should be done in the hooks to -various major modes by executing @code{viper-set-syntax-preference} as in -the following example: - -@example -(viper-set-syntax-preference nil "emacs") -@end example - -@findex @code{viper-set-syntax-preference} - -The above discussion of the meaning of Viper's words concerns only Viper's -movement commands. In regular expressions, words remain the same as in -Emacs. That is, the expressions @code{\w}, @code{\>}, @code{\<}, etc., use -Emacs' idea of what is a word, and they don't look into the value of -variable @code{viper-syntax-preference}. This is because Viper doesn't change -syntax tables in fear of upsetting the various major modes that set these -tables. - -@cindex textmarkers - -Textmarkers in Viper remember the file and the position, so that you can -switch files by simply doing @kbd{'a}. If you set up a regimen for using -Textmarkers, this is very useful. Contents of textmarkers can be viewed -by @kbd{[marker}. (Contents of registers can be viewed by @kbd{]register}). - -@node New Commands, Useful Packages, Movement and Markers, Improvements over Vi -@section New Commands - -These commands have no Vi analogs. - -@table @kbd -@item C-x, C-c -@kindex @kbd{C-x} -@kindex @kbd{C-c} -These two keys invoke many important Emacs functions. For example, if you -hit @kbd{C-x} followed by @kbd{2}, then the current window will be split -into 2. Except for novice users, @kbd{C-c} is also set to execute an Emacs -command from the current major mode. @key{ESC} will do the same, if you -configure @key{ESC} as Meta by setting @code{viper-no-multiple-ESC} to nil -in @file{.viper}. @xref{Customization}. @kbd{C-\} in Insert, Replace, or Vi -states will make Emacs think @kbd{Meta} has been hit.@refill -@item \ -@kindex @kbd{\} -Escape to Emacs to execute a single Emacs command. For instance, -@kbd{\ @key{ESC}} will act like a Meta key. -@item Q -@kindex @kbd{Q} -@cindex query replace -@kbd{Q} is for query replace. By default, -each string to be replaced is treated as a regular expression. You can use -@code{(setq viper-re-query-replace nil)} in your @file{.emacs} file to -turn this off. (For normal searches, @kbd{:se nomagic} will work. Note -that @kbd{:se nomagic} turns Regexps off completely, unlike Vi). -@item v -@itemx V -@itemx C-v -@kindex @kbd{v} -@kindex @kbd{V} -@kindex @kbd{C-v} -These keys are used to visit files. @kbd{v} will switch to a buffer -visiting file whose name can be entered in the Minibuffer. @kbd{V} is -similar, but will use a window different from the current window. -@kbd{C-v} is like @kbd{V}, except that a new frame (X window) will be used -instead of a new Emacs window. -@item # -@kindex @kbd{#} -If followed by a certain character @var{ch}, it becomes an operator whose -argument is the region determined by the motion command that follows -(indicated as ). -Currently, @var{ch} can be one of @kbd{c}, @kbd{C}, @kbd{g}, @kbd{q}, and -@kbd{s}. For instance, @kbd{#qr} will prompt you for a string and then -prepend this string to each line in the buffer.@refill -@item # c -@kindex @kbd{#c} -@cindex changing case -Change upper-case characters in the region to lower-case -(@code{downcase-region}). -Emacs command @kbd{M-l} does the same for words. -@item # C -@kindex @kbd{#C} -Change lower-case characters in the region to upper-case. For instance, -@kbd{# C 3 w} will capitalize 3 words from the current point -(@code{upcase-region}). -Emacs command @kbd{M-u} does the same for words. -@item # g -@kindex @kbd{#g} -Execute last keyboard macro for each line in the region -(@code{viper-global-execute}).@refill -@item # q -@kindex @kbd{#q} -Insert specified string at the beginning of each line in the region -(@code{viper-quote-region}). -@item # s -@kindex @kbd{#s} -Check spelling of words in the region (@code{spell-region}). -The function used for spelling is determined from the variable -@code{viper-spell-function}. -@vindex @code{viper-spell-function} -@item * -@kindex @kbd{*} -Call last keyboard macro. -@item m . -Set mark at point and push old mark off the ring -@item m< -@item m> -Set mark at beginning and end of buffer, respectively. -@item m, -Jump to mark and pop mark off the ring. @xref{Mark,,Mark,emacs,The GNU -Emacs Manual}, for more info. -@item ] register -@kindex @kbd{]} -View contents of register -@item [ textmarker -@kindex @kbd{[} -View filename and position of textmarker -@item @@# -@item @@register -@item @@! -@kindex @kbd{@@#} -@kindex @kbd{@@} -@kindex @kbd{@@!} -@cindex keyboard macros -@cindex register execution - -Begin/end keyboard macro. @@register has a different meaning when used after -a @kbd{@@#}. @xref{Macros and Registers}, for details -@item [] -@kindex @kbd{[]} -Go to end of heading. -@item g <@emph{movement command}> -Search buffer for text delimited by movement command. The canonical -example is @kbd{gw} to search for the word under the cursor. -@xref{Improved Search}, for details.@refill -@item C-g and C-] -@kindex @kbd{C-g} -@kindex @kbd{C-]} -Quit and Abort Recursive edit. These may be necessary on occasion. -@xref{Vi State}, for a reason. -@item C-c g -@kindex @kbd{C-c g} -Hitting @kbd{C-c} followed by @kbd{g} will display the information on the -current buffer. This is the same as hitting @kbd{C-g} in Vi, but, as -explained above, @kbd{C-g} is needed for other purposes in Emacs. -@item C-c / -@kindex @kbd{C-c /} -Without a prefix argument, this command toggles -case-sensitive/case-insensitive search modes and plain vanilla/regular -expression search. With the prefix argument 1, i.e., -@kbd{1 C-c /}, this toggles case-sensitivity; with the prefix argument 2, -toggles plain vanilla search and search using -regular expressions. @xref{Viper Specials}, for alternative ways to invoke -this function. -@cindex vanilla search -@cindex case-sensitive search -@cindex case-insensitive search - -@item M-p and M-n -@kindex @kbd{M-p} -@kindex @kbd{M-n} -In the Minibuffer, these commands navigate through the minibuffer -histories, such as the history of search strings, Ex commands, etc. - -@item C-c M-p and C-c M-n -@kindex @kbd{C-c M-p} -@kindex @kbd{C-c M-n} -@cindex Insertion history -@cindex Insertion ring -@cindex Command history -@cindex Command ring - -In Insert or Replace state, these commands let the user -peruse the history of insertion strings used in previous insert or replace -commands. Try to hit @kbd{C-c M-p} or @kbd{C-c M-n} repeatedly and see what -happens. @xref{Viper Specials}, for more. - -In Vi state, these commands let the user peruse the history of Vi-style -destructive commands, such as @kbd{dw}, @kbd{J}, @kbd{a}, etc. -By repeatedly typing @kbd{C-c M-p} or @kbd{C-c M-n} you will cycle Viper -through the recent history of Vi commands, displaying the commands one by -one. Once -an appropriate command is found, it can be executed by typing `@kbd{.}'. - -Since typing @kbd{C-c M-p} is tedious, it is more convenient to bind an -appropriate function to a function key on the keyboard and use that key. -@xref{Viper Specials}, for details. - -@item Ex commands -@findex @kbd{:args} -@findex @kbd{:n} -@findex @kbd{:pwd} -@findex @kbd{:pre} -The commands @kbd{:args}, @kbd{:next}, @kbd{:pre} behave -differently. @kbd{:pwd} exists to get current directory. -The commands @kbd{:b} and @kbd{:B} switch buffers around. @xref{File and -Buffer Handling}, for details. -There are also the new commands @kbd{:RelatedFile} and -@kbd{PreviousRelatedFile} (which abbreviate to @kbd{R} and @kbd{P}, -respectively. @xref{Viper Specials}, for details. -@findex @kbd{:RelatedFile} -@findex @kbd{:PreviousRelatedFile} -@end table - -Apart from the new commands, many old commands have been enhanced. Most -notably, Vi style macros are much more powerful in Viper than in Vi. @xref{Vi -Macros}, for details. - -@node Useful Packages, ,New Commands, Improvements over Vi -@section Useful Packages - -Some Emacs packages are mentioned here as an aid to the new Viper user, to -indicate what Viper is capable of. -A vast number comes with the standard Emacs distribution, and many more exist -on the net and on the archives. - -This manual also mentions some Emacs features a new user -should know about. The details of these are found in the GNU Emacs -Manual. - -The features first. For details, look up the Emacs Manual. - -@table @samp -@item Make -@cindex make -@cindex compiling - -Makes and Compiles can be done from the editor. Error messages will be -parsed and you can move to the error lines. -@item Shell -@cindex shell -@cindex interactive shell -You can talk to Shells from inside the editor. Your entire shell session -can be treated as a file. -@item Mail -@cindex email -@cindex mail -Mail can be read from and sent within the editor. Several sophisticated -packages exist. -@item Language Sensitive Editing -Editing modes are written for most computer languages in existence. By -controlling indentation, they catch punctuation errors. -@end table - -The packages, below, represents a drop in the sea of special-purpose -packages that come with standard distribution of Emacs. - -@table @samp -@item Transparent FTP -@cindex transparent ftp -@pindex ange-ftp.el -@code{ange-ftp.el} can ftp from the editor to files on other machines -transparent to the user. -@item RCS Interfaces -@cindex version maintenance -@cindex RCS -@pindex vc.el -@code{vc.el} for doing RCS commands from inside the editor -@item Directory Editor -@cindex dired -@pindex dired.el -@code{dired.el} for editing contents of directories and for navigating in -the file system. -@item Syntactic Highlighting -@cindex font-lock -@pindex font-lock.el -@code{font-lock.el} for automatic highlighting various parts of a buffer -using different fonts and colors. -@item Saving Emacs Configuration -@cindex desktop -@pindex desktop.el -@code{desktop.el} for saving/restoring configuration on Emacs exit/startup. -@item Spell Checker -@cindex ispell -@pindex ispell.el -@code{ispell.el} for spell checking the buffer, words, regions, etc. -@item File and Buffer Comparison -@cindex ediff -@pindex ediff.el -@code{ediff.el} for finding differences between files and for applying -patches. -@end table - -@noindent -Emacs Lisp archives exist on -@samp{archive.cis.ohio-state.edu} -and @samp{wuarchive.wustl.edu}@refill - - -@node Customization,Commands,Improvements over Vi,Top -@chapter Customization - -@cindex customization - -Customization can be done in 2 ways. - -@itemize @bullet -@item -@cindex initialization -@cindex .viper -Elisp code in a @file{.viper} file in your home directory. Viper -loads @file{.viper} just before it does the binding for mode -hooks. This is the recommended method. -@item -@cindex .emacs -Elisp code in your @file{.emacs} file before and after the @code{(require -'viper)} line. This method is not recommended, unless you know what you are -doing. Only two variables, @code{viper-mode} and -@code{viper-custom-file-name} are supposed to be customized in @file{.emacs}, -prior to loading Viper.@refill -@end itemize - -@noindent -Most of Viper's behavior can be customized via the interactive Emacs user -interface. Choose "Customize" from the menubar, click on "Editing", then on -"Emulations". The customization widget is self-explanatory. Once you are -satisfied with your changes, save them into a file and then include the -contents of that file in the Viper customization repository, @file{.viper} -(except for @code{viper-mode} and @code{viper-custom-file-name}, which are -supposed to go into @code{.emacs}). - -Some advanced customization cannot be accomplished this way, however, and -has to be done in Emacs Lisp. For the common cases, examples are provided -that you can use directly. - -@menu -* Rudimentary Changes:: Simple constant definitions. -* Keybindings:: Enabling Emacs Keys, Rebinding keys, etc. -* Packages that Change Keymaps:: How to deal with such beasts. -* Viper Specials:: Special Viper commands. -* Vi Macros:: How to do Vi style macros. -@end menu - -@node Rudimentary Changes,Keybindings,Customization,Customization -@section Rudimentary Changes - -@cindex setting variables -@cindex variables for customization -@findex @kbd{:set} - -An easy way to customize Viper is to change the values of constants used in -Viper. Here is the list of the constants used in Viper and their default -values. The corresponding :se command is also indicated. (The symbols -@code{t} and @code{nil} represent ``true'' and ``false'' in Lisp). - -Viper supports both the abbreviated Vi variable names and their full -names. Variable completion is done on full names only. @key{TAB} and -@key{SPC} complete -variable names. Typing `=' will complete the name and then will prompt for -a value, if applicable. For instance, @kbd{:se au @key{SPC}} will complete the -command to @kbd{:set autoindent}; @kbd{:se ta @key{SPC}} will complete the command -and prompt further like this: @kbd{:set tabstop = }. -However, typing @kbd{:se ts @key{SPC}} will produce a ``No match'' message -because @kbd{ts} is an abbreviation for @kbd{tabstop} and Viper supports -completion on full names only. However, you can still hit @key{RET} -or @kbd{=}, which will complete the command like this: @kbd{:set ts = } and -Viper will be waiting for you to type a value for the tabstop variable. -To get the full list of Vi variables, type @kbd{:se @key{SPC} @key{TAB}}. - -@table @code -@item viper-auto-indent nil -@itemx :se ai (:se autoindent) -@itemx :se ai-g (:se autoindent-global) -If @code{t}, enable auto indentation. -by @key{RET}, @kbd{o} or @kbd{O} command. - -@code{viper-auto-indent} is a local variable. To change the value globally, use -@code{setq-default}. It may be useful for certain major modes to have their -own values of @code{viper-auto-indent}. This can be achieved by using -@code{setq} to change the local value of this variable in the hooks to the -appropriate major modes. - -@kbd{:se ai} changes the value of @code{viper-auto-indent} in the current -buffer only; @kbd{:se ai-g} does the same globally. -@item viper-electric-mode t -If not @code{nil}, auto-indentation becomes electric, which means that -@key{RET}, @kbd{O}, and @kbd{o} indent cursor according to the current -major mode. In the future, this variable may control additional electric -features. - -This is a local variable: @code{setq} changes the value of this variable -in the current buffer only. Use @code{setq-default} to change the value in -all buffers. -@item viper-case-fold-search nil -@itemx :se ic (:se ignorecase) -If not @code{nil}, search ignores cases. -This can also be toggled by quickly hitting @kbd{/} twice. -@item viper-re-search nil -@itemx :se magic -If not @code{nil}, search will use regular expressions; if @code{nil} then -use vanilla search. -This behavior can also be toggled by quickly hitting @kbd{/} trice. -@item buffer-read-only -@itemx :se ro (:se readonly) -Set current buffer to read only. To change globally put -@code{(setq-default buffer-read-only t)} in your @file{.emacs} file. -@item blink-matching-paren t -@itemx :se sm (:se showmatch) -Show matching parens by blinking cursor. -@item tab-width t (default setting via @code{setq-default}) -@itemx :se ts=value (:se tabstop=value) -@itemx :se ts-g=value (:se tabstop-global=value) -@code{tab-width} is a local variable that controls the width of the tab stops. -To change the value globally, use @code{setq-default}; for local settings, -use @code{setq}. - -The command @kbd{:se ts} -sets the tab width in the current -buffer only; it has no effect on other buffers. - -The command @kbd{:se ts-g} sets tab width globally, -for all buffers where the tab is not yet set locally, -including the new buffers. - -Note that typing @key{TAB} normally -doesn't insert the tab, since this key is usually bound to -a text-formatting function, @code{indent-for-tab-command} (which facilitates -programming and document writing). Instead, the tab is inserted via the -command @code{viper-insert-tab}, which is bound to @kbd{S-tab} (shift + tab). - -On some non-windowing terminals, Shift doesn't modify the @key{TAB} key, so -@kbd{S-tab} behaves as if it were @key{TAB}. In such a case, you will have -to bind @code{viper-insert-tab} to some other convenient key. - -@item viper-shift-width 8 -@itemx :se sw=value (:se shiftwidth=value) -The number of columns shifted by @kbd{>} and @kbd{<} commands. -@item viper-search-wrap-around t -@itemx :se ws (:se wrapscan) -If not @code{nil}, search wraps around the end/beginning of buffer. -@item viper-search-scroll-threshold 2 -If search lands within this many lines of the window top or bottom, the -window will be scrolled up or down by about 1/7-th of its size, to reveal -the context. If the value is negative---don't scroll. -@item viper-tags-file-name "TAGS" -The name of the file used as the tag table. -@item viper-re-query-replace nil -If not @code{nil}, use reg-exp replace in query replace. -@item viper-want-ctl-h-help nil -If not @code{nil}, @kbd{C-h} is bound to @code{help-command}; -otherwise, @kbd{C-h} is bound as usual in Vi. -@item viper-vi-style-in-minibuffer t -If not @code{nil}, Viper provides a high degree of compatibility with Vi -insert mode when you type text in the Minibuffer; if @code{nil}, typing in -the Minibuffer feels like plain Emacs. -@item viper-no-multiple-ESC t -If you set this to @code{nil}, you can use @key{ESC} as Meta in Vi state. -Normally, this is not necessary, since graphical displays have separate -Meta keys (usually on each side of the space bar). On a dumb terminal, Viper -sets this variable to @code{twice}, which is almost like @code{nil}, except -that double @key{ESC} beeps. This, too, lets @key{ESC} to be used as a Meta. -@item viper-ESC-keyseq-timeout 200 on tty, 0 on windowing display -Escape key sequences separated by this much delay (in miliseconds) are -interpreted as command, ignoring the special meaning of @key{ESC} in -VI. The default is suitable for most terminals. However, if your terminal -is extremely slow, you might want to increase this slightly. You will know -if your terminal is slow if the @key{ESC} key sequences emitted by the -arrow keys are interpreted as separately typed characters (and thus the -arrow keys won't work). Making this value too large will slow you down, so -exercise restraint. -@item viper-fast-keyseq-timeout 200 -Key sequences separated by this many miliseconds are treated as Vi-style -keyboard macros. If the key sequence is defined as such a macro, it will be -executed. Otherwise, it is processed as an ordinary sequence of typed keys. - -Setting this variable too high may slow down your typing. Setting it too -low may make it hard to type macros quickly enough. -@item viper-ex-style-motion t -Set this to @code{nil}, if you want @kbd{l,h} to cross -lines, etc. @xref{Movement and Markers}, for more info. -@item viper-ex-style-editing t -Set this to to @code{nil}, if you want -@kbd{C-h} and @key{DEL} to not stop -at the beginning of a line in Insert state, @key{X} and @key{x} to delete -characters across lines in Vi command state, etc. -@item viper-ESC-moves-cursor-back t -It t, cursor moves back 1 character when switching from insert state to vi -state. If nil, the cursor stays where it was before the switch. -@item viper-always t -@code{t} means: leave it to Viper to decide when a buffer must be brought -up in Vi state, -Insert state, or Emacs state. This heuristics works well in virtually all -cases. @code{nil} means you either has to invoke @code{viper-mode} manually -for each buffer (or you can add @code{viper-mode} to the appropriate major mode -hooks using @code{viper-load-hook}). - -This option must be set in the file @file{~/.viper}. -@item viper-custom-file-name "~/.viper" -File used for Viper-specific customization. -Change this setting, if you want. Must be set in @file{.emacs} (not @file{.viper}!) -before Viper is loaded. Note that you -have to set it as a string inside double quotes. -@item viper-spell-function 'ispell-region -Function used by the command @kbd{#c} to spell. -@item ex-nontrivial-find-file-function -The value of this variable is the function used to find all files that -match a wildcard. This is usually done when the user types @kbd{:e} and -specifies a wildcard in the file name (or if the file name contains unusual -symbols (e.g., a space). Viper provides two functions for this: one for -Unix-like systems (@code{viper-ex-nontrivial-find-file-unix}) and one for -DOS, W95, and NT (@code{viper-ex-nontrivial-find-file-ms}). If the default -function doesn't quite do what you expect or if you prefer to use ``fancy'' -shells, you may have to write your own version of this function and make it -into the value of @code{ex-nontrivial-find-file-function}. Use -@code{viper-ex-nontrivial-find-file-unix} and -@code{viper-ex-nontrivial-find-file-ms} as examples. -@vindex @code{ex-nontrivial-find-file-function}. -@findex @code{viper-ex-nontrivial-find-file-ms} -@findex @code{viper-ex-nontrivial-find-file-unix} -@item ex-cycle-other-window t -If not @code{nil}, @kbd{:n} and @kbd{:b} will cycle through files in another -window, if one exists. -@item ex-cycle-through-non-files nil -@kbd{:n} does not normally cycle through buffers. Set this to get -buffers also. -@item viper-want-emacs-keys-in-insert -This is set to @code{nil} for user levels 1 and 2 and to @code{t} for user -levels 3 and 4. Users who specify level 5 are allowed to set this variable -as they please (the default for this level is @code{t}). If set to -@code{nil}, complete Vi compatibility is provided in Insert state. This is -really not recommended, as this precludes you from using language-specific -features provided by the major modes. -@item viper-want-emacs-keys-in-vi -This is set to @code{nil} for user -level 1 and to @code{t} for user levels 2--4. -At level 5, users are allowed to set this variable as they please (the -default for this level is @code{t}). -If set to @code{nil}, complete Vi compatibility is provided -in Vi command state. Setting this to @code{nil} is really a bad idea, -unless you are a novice, as this precludes the use -of language-specific features provided by the major modes. -@item viper-keep-point-on-repeat t -If not @code{nil}, point is not moved when the user repeats the previous -command by typing `.' This is very useful for doing repeated changes with -the @kbd{.} key. -@item viper-repeat-from-history-key 'f12 -Prefix key used to invoke the macros @kbd{f12 1} and @kbd{f12 2} that repeat -the second-last and the third-last destructive command. -Both these macros are bound (as Viper macros) to -@code{viper-repeat-from-history}, -which checks the second key by which it is invoked to see which of the -previous commands to invoke. Viper binds @kbd{f12 1} and @kbd{f12 2} only, -but the user can bind more in @file{~/.viper}. @xref{Vi Macros}, for how to do -this. -@item viper-keep-point-on-undo nil -If not @code{nil}, Viper tries to not move point when undoing commands. -Instead, it will briefly move the cursor to the place where change has -taken place. However, if the undone piece of text is not seen in window, -then point will be moved to the place where the change took place. -Set it to @code{t} and see if you like it better. -@item viper-delete-backwards-in-replace nil -If not @code{nil}, @key{DEL} key will delete characters while moving the cursor -backwards. If @code{nil}, the cursor will move backwards without deleting -anything. -@item viper-replace-overlay-face 'viper-replace-overlay-face -On a graphical display, Viper highlights replacement regions instead of -putting a @samp{$} at the end. This variable controls the so called -@dfn{face} used to highlight the region. - -By default, @code{viper-replace-overlay-face} underlines the replacement on -monochrome displays and also lays a stipple over them. On color displays, -replacement regions are highlighted with color. - -If you know something about Emacs faces and don't like how Viper highlights -replacement regions, you can change @code{viper-replace-overlay-face} by -specifying a new face. (Emacs faces are described in the Emacs Lisp -reference.) On a color display, the following customization method is -usually most effective: -@example -(set-face-foreground viper-replace-overlay-face "DarkSlateBlue") -(set-face-background viper-replace-overlay-face "yellow") -@end example -For a complete list of colors available to you, evaluate the expression -@code{(x-defined-colors)}. (Type it in the buffer @code{*scratch*} and then -hit the @kbd{C-j} key. - -@item viper-replace-overlay-cursor-color "Red" -@vindex @code{viper-replace-overlay-cursor-color} -Cursor color when it is inside the replacement region. -This has effect only on color displays and only when Emacs runs as an X -application. -@item viper-insert-state-cursor-color nil -@vindex @code{viper-insert-state-cursor-color} -If set to a valid color, this will be the cursor color when Viper is in -insert state. -@item viper-replace-region-end-delimiter "$" -A string used to mark the end of replacement regions. It is used only on -TTYs or if @code{viper-use-replace-region-delimiters} is non-nil. -@item viper-replace-region-start-delimiter "" -A string used to mark the beginning of replacement regions. It is used -only on TTYs or if @code{viper-use-replace-region-delimiters} is non-nil. -@item viper-use-replace-region-delimiters -If non-nil, Viper will always use @code{viper-replace-region-end-delimiter} and -@code{viper-replace-region-start-delimiter} to delimit replacement regions, -even on color displays (where this is unnecessary). By default, this -variable is non-nil only on TTYs or monochrome displays. -@item viper-allow-multiline-replace-regions t -If non-nil, multi-line text replacement regions, such as those produced by -commands @kbd{c55w}, @kbd{3C}, etc., will stay around until the user exits -the replacement mode. In this variable is set to @code{nil}, Viper will -emulate the standard Vi behavior, which supports only intra-line -replacement regions (and multi-line replacement regions are deleted). -@item viper-toggle-key "\C-z" -Specifies the key used to switch from Emacs to Vi and back. -Must be set in @file{.viper}. This variable can't be -changed interactively after Viper is loaded. - -In Insert state, this key acts as a temporary escape to Vi state, i.e., it -will set Viper up so that the very next command will be executed as if it -were typed in Vi state. -@item viper-ESC-key "\e" -Specifies the key used to escape from Insert/Replace states to Vi. -Must be set in @file{.viper}. This variable cannot be -changed interactively after Viper is loaded. -@item viper-buffer-search-char nil -Key used for buffer search. @xref{Viper Specials}, for details. -@item viper-surrounding-word-function 'viper-surrounding-word -The value of this variable is a function name that is used to determine -what constitutes a word clicked upon by the mouse. This is used by mouse -search and insert. -@item viper-search-face 'viper-search-face -Variable that controls how search patterns are highlighted when they are -found. -@item viper-vi-state-hook nil -List of parameterless functions to be run just after entering the Vi -command state. -@item viper-insert-state-hook nil -Same for Insert state. This hook is also run after entering Replace state. -@item viper-replace-state-hook nil -List of (parameterless) functions called just after entering Replace state -(and after all @code{viper-insert-state-hook}). -@item viper-emacs-state-hook nil -List of (parameterless) functions called just after switching from Vi state -to Emacs state. -@item viper-load-hook nil -List of (parameterless) functions called just after loading Viper. This is -the last chance to do customization before Viper is up and running. -@end table -@noindent -You can reset some of these constants in Viper with the Ex command @kbd{:set} -(when so indicated in the table). Or you -can include a line like this in your @file{.viper} file: -@example -(setq viper-case-fold-search t) -@end example -@vindex @code{viper-auto-indent} -@vindex @code{viper-electric-mode} -@vindex @code{viper-case-fold-search} -@vindex @code{viper-re-search} -@vindex @code{viper-shift-width} -@vindex @code{buffer-read-only} -@vindex @code{viper-search-wrap-around} -@vindex @code{viper-search-scroll-threshold} -@vindex @code{viper-search-face} -@vindex @code{viper-tags-file-name} -@vindex @code{viper-re-query-replace} -@vindex @code{viper-want-ctl-h-help} -@vindex @code{viper-vi-style-in-minibuffer} -@vindex @code{viper-no-multiple-ESC} -@vindex @code{viper-always} -@vindex @code{viper-ESC-keyseq-timeout} -@vindex @code{viper-fast-keyseq-timeout} -@vindex @code{viper-ex-style-motion} -@vindex @code{viper-ex-style-editing} -@vindex @code{viper-ESC-moves-cursor-back} -@vindex @code{viper-custom-file-name} -@vindex @code{viper-spell-function} -@vindex @code{ex-cycle-other-window} -@vindex @code{ex-cycle-through-non-files} -@vindex @code{viper-want-emacs-keys-in-insert} -@vindex @code{viper-want-emacs-keys-in-vi} -@vindex @code{viper-keep-point-on-repeat} -@vindex @code{viper-keep-point-on-undo} -@vindex @code{viper-delete-backwards-in-replace} -@vindex @code{viper-replace-overlay-face} -@vindex @code{viper-replace-region-end-symbol} -@vindex @code{viper-replace-region-start-symbol} -@vindex @code{viper-allow-multiline-replace-regions} -@vindex @code{viper-toggle-key} -@vindex @code{viper-ESC-key} -@vindex @code{viper-buffer-search-char} -@vindex @code{viper-surrounding-word-function} -@vindex @code{viper-vi-state-hook} -@vindex @code{viper-insert-state-hook} -@vindex @code{viper-replace-state-hook} -@vindex @code{viper-emacs-state-hook} - -@node Keybindings, Packages that Change Keymaps, Rudimentary Changes,Customization -@section Keybindings - -@cindex keybindings -@cindex keymaps - -Viper lets you define hot keys, i.e., you can associate keyboard keys -such as F1, Help, PgDn, etc., with Emacs Lisp functions (that may already -exist or that you will write). Each key has a "preferred form" in -Emacs. For instance, the Up key's preferred form is [up], the Help key's -preferred form is [help], and the Undo key has the preferred form [f14]. -You can find out the preferred form of a key by typing @kbd{M-x -describe-key-briefly} and then typing the key you want to know about. - -Under X Windows, every keyboard key emits its preferred form, so you can -just type - -@lisp -(global-set-key [f11] 'calendar) ; L1, Stop -(global-set-key [f14] 'undo) ; L4, Undo -@end lisp - -@noindent -to bind L1 so it will invoke the Emacs Calendar and to bind L4 so it will -undo changes. -However, on a dumb terminal or in an Xterm window, even the standard arrow -keys may -not emit the right signals for Emacs to understand. To let Emacs know about -those keys, you will have to find out which key sequences they emit -by typing @kbd{C-q} and then the key (you should switch to Emacs state -first). Then you can bind those sequences to their preferred forms using -@code{function-key-map} as follows: - -@lisp -(cond ((string= (getenv "TERM") "xterm") -(define-key function-key-map "\e[192z" [f11]) ; L1 -(define-key function-key-map "\e[195z" [f14]) ; L4, Undo -@end lisp - -The above illustrates how to do this for Xterm. On VT100, you would have to -replace "xterm" with "vt100" and also change the key sequences (the same -key may emit different sequences on different types of terminals). - -The above keys are global, so they are overwritten by the local maps -defined by the major modes and by Viper itself. Therefore, if you wish to -change a binding set by a major mode or by Viper, read this. - -Viper users who wish to specify their own key bindings should be concerned -only with the following three keymaps: -@code{viper-vi-global-user-map} for Vi state commands, -@code{viper-insert-global-user-map} for Insert state commands, -and @code{viper-emacs-global-user-map} for Emacs state commands (note: -customized bindings for Emacs state made to @code{viper-emacs-global-user-map} -are @emph{not} inherited by Insert state). - -For more information on Viper keymaps, see the header of the file -@file{viper.el}. -If you wish to change a Viper binding, you can use the -@code{define-key} command, to modify @code{viper-vi-global-user-map}, -@code{viper-insert-global-user-map}, and @code{viper-emacs-global-user-map}, as -explained below. Each of these key maps affects the corresponding Viper state. -The keymap @code{viper-vi-global-user-map} also affects Viper's Replace state. - -@noindent -If you want to -bind a key, say @kbd{C-v}, to the function that scrolls -page down and to make @kbd{0} display information on the current buffer, -putting this in @file{.viper} will do the trick in Vi state: -@example -(define-key viper-vi-global-user-map "\C-v" 'scroll-down) -@end example -@noindent -To set a key globally, -@example -(define-key viper-emacs-global-user-map "\C-c m" 'smail) -(define-key viper-vi-global-user-map "0" 'viper-info-on-file) -@end example -@noindent -Note, however, that this binding may be overwritten by other keymaps, since -the global keymap has the lowest priority. -To make sure that nothing will override a binding in Emacs state, you -can write this: -@example -(define-key viper-emacs-global-user-map "\C-c m" 'smail) -@end example -@noindent -To customize the binding for @kbd{C-h} in Insert state: -@example -(define-key viper-insert-global-user-map "\C-h" 'my-del-backwards-function) -@end example -@noindent - -Each Emacs command key calls some lisp function. If you have enabled the -Help, (@xref{Rudimentary Changes}) @kbd{C-h k} will show you the function -for each specific key; @kbd{C-h b} will show all bindings, and @kbd{C-h m} -will provide information on the major mode in effect. If Help is not -enabled, you can still get help in Vi state by prefixing the above commands -with @kbd{\}, e.g., @kbd{\ C-h k} (or you can use the Help menu in the -menu bar, if Emacs runs under X Windows). - -Viper users can also change bindings on a per major mode basis. As with -global bindings, this can be done separately for each of the three main Viper -states. To this end, Viper provides the function -@code{viper-modify-major-mode}. -@findex @code{viper-modify-major-mode} - -To modify keys in Emacs state for @code{my-favorite-major-mode}, the user -needs to create a sparse keymap, say, @code{my-fancy-map}, bind whatever -keys necessary in that keymap, and put - -@example -(viper-modify-major-mode 'dired-mode 'emacs-state my-fancy-map) -@end example - -@noindent -in @file{~/.viper}. To do the same in Vi and Insert states, one should use -@code{vi-state} and @code{insert-state}. Changes in Insert state are also -in effect in Replace state. For instance, suppose that the user wants to -use @kbd{dd} in Vi state under Dired mode to delete files, @kbd{u} to unmark -files, etc. The following code in @file{~/.viper} will then do the job: - -@example -(setq my-dired-modifier-map (make-sparse-keymap)) -(define-key my-dired-modifier-map "dd" 'dired-flag-file-deletion) -(define-key my-dired-modifier-map "u" 'dired-unmark) -(viper-modify-major-mode 'dired-mode 'vi-state my-dired-modifier-map) -@end example - -A Vi purist may want to modify Emacs state under Dired mode so that -@kbd{k}, @kbd{l}, etc., will move around in directory buffers, as in -Vi. Although this is not recommended, as these keys are bound to useful -Dired functions, the trick can be accomplished via the following code: - -@example -(setq my-dired-vi-purist-map (make-sparse-keymap)) -(define-key my-dired-vi-purist-map "k" 'viper-previous-line) -(define-key my-dired-vi-purist-map "l" 'viper-forward-char) -(viper-modify-major-mode 'dired-mode 'emacs-state my-dired-vi-purist-map) -@end example - -Similar effect can be achieved by defining Vi keyboard macros using the -Ex commands @kbd{:map} and @kbd{:map!}. The difference is that multi-key -Vi macros do not override the keys they are bound to, unless these keys are -typed in quick succession. So, with macros, one can use the normal keys -alongside with the macros. If per-mode modifications are needed, the user -can try both ways and see which one is more convenient. -@findex @kbd{:map} -@xref{Vi Macros}, for details. - -Note: in major modes that come up in @emph{Emacs state} by default, the -aforesaid modifications may not take place immediately (but only after the -buffer switches to some other Viper state and then back to Emacs state). To -avoid this, one should add @code{viper-change-state-to-emacs} to an -appropriate hook of that major mode. (Check the function -@code{viper-set-hooks} in @file{viper.el} for examples.) However, if you -have set @code{viper-always} to @code{t}, chances are that you won't need to -perform the above procedure, because Viper will take care of most useful -defaults. - - -Finally, Viper has a facility that lets the user define per-buffer -bindings, i.e., bindings that are in effect in some specific buffers -only. Unlike per-mode bindings described above, per-buffer bindings can be -defined based on considerations other than the major mode. This is done -via the function @code{viper-add-local-keys}, which lets one specify bindings -that should be in effect in the current buffer only and for a specific Viper -state. For instance, -@lisp -(viper-add-local-keys 'vi-state '(("ZZ" . TeX-command-master) - ("ZQ" . viper-save-kill-buffer))) -@end lisp -@noindent -redefines @kbd{ZZ} to invoke @code{TeX-command-master} in @code{vi-state} -and @kbd{ZQ} to save-then-kill the current buffer. These bindings take -effect only in the buffer where this command is executed. The typical use -of this function is to execute the above expression from within a function -that is included in a hook to some major mode. For instance, the above -expression -could be called from a function, @code{my-tex-init}, which may be added to -@code{tex-mode-hook} as follows: -@lisp -(add-hook 'tex-mode-hook 'my-tex-init) -@end lisp -@noindent -When TeX mode starts, the hook is executed and the above Lisp expression is -evaluated. Then, the bindings for @kbd{ZZ} and @kbd{ZQ} are changed in Vi -command mode for all buffers in TeX mode. - -Another useful application is to bind @kbd{ZZ} to @code{send-mail} -in the Mail mode buffers (the specifics of this depend on which mail -package you are using, @code{rmail}, @code{mh-e}, @code{vm}, etc. -For instance, here is how to do this for @code{mh-e}, the Emacs interface -to MH: -@lisp -(defun mh-add-vi-keys () - "Set up ZZ for MH-e and XMH." - (viper-add-local-keys 'vi-state '(("ZZ" . mh-send-letter)))) -(add-hook 'mh-letter-mode-hook 'mh-add-vi-keys) -@end lisp - -You can also use @code{viper-add-local-keys} to set per buffer -bindings in Insert state and Emacs state by passing as a parameter the -symbols @code{insert-state} and @code{emacs-state}, respectively. -As with global bindings, customized local bindings done to Emacs state -are not inherited by Insert state. - -On rare occasions, local keys may be added by mistake. Usually this is done -indirectly, by invoking a major mode that adds local keys (e.g., -@code{shell-mode} redefines @key{RET}). In such a case, exiting the wrong -major mode won't rid you from unwanted local keys, since these keys are -local to Viper state and the current buffer, not to the major mode. -In such situations, the remedy is to type @kbd{M-x viper-zap-local-keys}. - -So much about Viper-specific bindings. -@xref{Customization,,Customization,emacs,The GNU Emacs -Manual}, and the Emacs quick reference card for the general info on key -bindings in Emacs. - -@vindex @code{function-key-map} -@vindex @code{viper-vi-global-user-map} -@vindex @code{viper-insert-global-user-map} -@vindex @code{viper-emacs-global-user-map} -@findex @code{viper-add-local-keys} -@findex @code{viper-zap-local-keys} - -@node Packages that Change Keymaps,Viper Specials,Keybindings,Customization -@subsection Packages that Change Keymaps -@cindex C-c and Viper -@cindex Viper and C-c - -Viper is designed to coexist with all major and minor modes of Emacs. This -means that bindings set by those modes are generally available with Viper -(unless you explicitly prohibit them by setting -@code{viper-want-emacs-keys-in-vi} and @code{viper-want-emacs-keys-in-insert} to -@code{nil}). -If @code{viper-always} is set to @code{t}, Viper will try to bring each buffer -in the Viper state that is most appropriate for that buffer. -Usually, this would be the Vi state, but sometimes it could be the Insert -state or the Emacs state. - -Some major mode bindings will necessarily be overwritten by Viper. Indeed, in -Vi state, most of the 1-character keys are used for Vi-style editing. This -usually causes no problems because most packages designed for editing files -typically do not bind such keys. Instead, they use key sequences that start -with @kbd{C-x} and @kbd{C-c}. This is why it was so important for us to -free up @kbd{C-x} and @kbd{C-c}. -It is common for language-specific major modes to bind @key{TAB} and -@kbd{C-j} (the line feed) keys to various formatting functions. This is -extremely useful, but may require some getting used to for a Vi user. If you -decide that this feature is not for you, you can re-bind these keys as -explained earlier (@xref{Customization}). - -Binding for @key{TAB} is one of the most unusual aspects of Viper for many -novice users. In Emacs, @key{TAB} is used to format text and programs, and -is extremely useful. For instance, hitting @key{TAB} causes the current -line to be re-indented in accordance with the context. In programming, -this is very important, since improper automatic indentation would -immediately alert the programmer to a possible error. For instance, if a -@kbd{)} or a @kbd{"} is missing somewhere above the current -line, @key{TAB} is likely to mis-indent the line. - -For this reason, Viper doesn't change the standard Emacs binding of -@key{TAB}, thereby sacrificing Vi compatibility -(except for users at level 1). Instead, in Viper, the key -@kbd{S-tab} (shift+ tab) is chosen to emulate Vi's @key{TAB}. - -We should note that on some non-windowing terminals, Shift doesn't modify -the @key{TAB} key, so @kbd{S-tab} behaves as if it were @key{TAB}. In such -a case, you will have to bind @code{viper-insert-tab} to some other -convenient key. - -Some packages, notably Dired, Gnus, Info, etc., attach special meaning to -common keys like @key{SPC}, @kbd{x}, @kbd{d}, @kbd{v}, and others. This -means that Vi command state is inappropriate for working with these -packages. Fortunately, these modes operate on read-only buffers and are -designed not for editing files, but for special-purpose browsing, reading -news, mail, etc., and Vi commands are meaningless in these situations. For -this reason, Viper doesn't force Vi state on such major modes. Rather, it -brings them in Emacs state. You can switch to Vi state by typing @kbd{C-z} -if, for instance, you want to do Vi-style search in a buffer (although, -usually, incremental search, which is bound to @kbd{C-s}, is sufficient in -these situations). But you should then switch back to Emacs state if you -plan to continue using these major modes productively. You can also switch -to Vi temporarily, to execute just one command. This is done by typing -@kbd{C-c \}. (In some of these modes, @kbd{/} and @kbd{:} are bound -Vi-style, unless these keys perform essential duties.) - -If you would like certain major modes to come up in Emacs state rather than -Vi state (but Viper thinks otherwise), you should put these major modes -on the @code{viper-non-vi-major-modes} list and also add -@code{viper-change-state-to-emacs} to these modes' hooks. -@vindex @code{viper-non-vi-major-modes} - -It is also possible to harness some major modes, even though they may bind -common keys to specialized commands. Harnessing can make sense for modes -that bind only a small number of common keys. For instance, if -@code{viper-always} is set to @code{t} in your @file{~/.viper} file, Viper will -harness Shell mode by changing the bindings for @kbd{C-m} and @kbd{C-d} -using @code{viper-add-local-keys} described in section on customization -(@xref{Customization}). In general, there is no single recipe for -harnessing modes. It can be as simple as adding the function -@code{viper-mode} to a hook associated with the mode, or it can be more -complex, as in the case of Shell mode and Emerge. Take a look at -@code{viper-set-hooks} function for some examples. - -Conversely, it may be the case that most of the major modes harnessed -by @code{viper-set-hooks} function fit your working style, except one or two -cases. In this case, you may still be able to set @code{viper-always} to -@code{t} and then remove a hook that forces Vi command state. For instance, -to unharness @code{lisp-interaction-mode}, you can execute the following line -in @code{viper-load-hook}: -@lisp -(remove-hook 'lisp-interaction-mode-hook 'viper-mode) -@end lisp -Note: this type of customization cannot be done in @code{.viper}! - -In some rare cases, some minor modes may override certain essential -bindings in Vi command state. This is not really catastrophic because this -may happen only in the beginning, when the minor mode kicks in. Typing -@code{M-x viper-mode} will correct the situation. Viper knows about -several such minor modes and takes care of them, so that the above trick -is usually not necessary. If you find that some minor mode, e.g., -@code{nasty-mode.el} interferes with Viper, putting the following in -@file{.viper} should fix the problem: -@lisp -(viper-harness-minor-mode "nasty-mode") -@end lisp -@noindent -The argument to @code{viper-harness-minor-mode} is the name of the file for the -offending minor mode with the suffixes @file{.el} and @file{.elc} removed. - -It may be tricky, however, to find out which minor mode is at fault. The -only guidance here is to look into the file that defines the minor mode you -are suspecting, say @code{nasty-mode.el}, and see if it has a variable -called @code{nasty-mode-map}. Then check if there is a statement of the form -@lisp -(define-key nasty-mode-map key function) -@end lisp -@noindent -that binds the misbehaving -keys. If so, use the above line to harness @code{nasty-mode}. If your -suspicion is wrong, no harm is done if you harness a minor mode that -doesn't need to be harnessed. - -@vindex @code{viper-want-emacs-keys-in-vi} -@vindex @code{viper-want-emacs-keys-in-insert} -@vindex @code{viper-always} -@findex @code{viper-set-hooks} -@findex @code{viper-mode} -@findex @code{viper-harness-minor-mode} -@findex @code{remove-hook} -@findex @code{add-hook} - -@node Viper Specials,Vi Macros,Packages that Change Keymaps,Customization -@section Viper Specials - -Viper extends Vi with a number of useful features. This includes various -search functions, histories of search strings, Ex commands, insertions, and -Vi's destructive commands. In addition, Viper supports file name completion -and history, completion of Ex commands and variables, and many other -features. Some of these features are explained in detail elsewhere in this -document. Other features are explained here. - -@table @code -@item (viper-buffer-search-enable) -@item viper-buffer-search-char nil -Enable buffer search. Explicit call to @code{viper-buffer-search-enable} -sets @code{viper-buffer-search-char} to @kbd{g}. Alternatively, the user can -set @code{viper-buffer-search-char} in @file{.viper} to a key sequence -to be used for buffer search. There is no need to call -@code{viper-buffer-search-enable} in that case. -@findex @code{viper-buffer-search-enable} -@vindex @code{viper-buffer-search-char} -@item viper-toggle-search-style -This function, bound to @kbd{C-c /}, lets one toggle case-sensitive and -case-insensitive search, and also switch between plain vanilla search and -search via regular expressions. Without the prefix argument, the user is -asked which mode to toggle. With prefix argument 1, this toggles -case-sensitivity. With prefix argument 2, regular expression/vanilla search -will be toggled. - -However, we found that the most convenient way to toggle -these options is to bind a Vi macro to -bind @kbd{//} to toggles case sensitivity and to @kbd{///} to toggles -vanilla search. Thus, quickly hitting @kbd{/} twice will switch Viper from -case sensitive search to case-insensitive. Repeating this once again will -restore the original state. Likewise, quickly hitting @kbd{/} three times -will switch you from vanilla-style search to search via regular expressions. -If you hit something other than @kbd{/} after the first @kbd{/} or if the -second @kbd{/} doesn't follow quickly enough, then Viper will issue the -usual prompt @kbd{/} and will wait for input, as usual in Vi. -If you don't like this behavior, you can ``unrecord'' these macros in your -@file{~/.viper} file. For instance, if you don't like the above feature, put -this in @file{~/.viper}: -@example -(viper-set-searchstyle-toggling-macros 'undefine) -@end example -@findex @code{viper-set-searchstyle-toggling-macros} - -@item Vi-isms in Emacs state -Some people find it useful to use the Vi-style search key, `/', to invoke -search in modes which Viper leaves in emacs-state. These modes are: -@code{dired-mode}, @code{mh-folder-mode}, @code{gnus-group-mode}, -@code{gnus-summary-mode}, @code{Info-mode}, and @code{Buffer-menu-mode} -(more may be added in the future). So, in the above modes, Viper binds `/' -so that it will behave Vi-style. Furthermore, in those major modes, Viper -binds `:' to invoke ex-style commands, like in vi-state. And, as described -above, `//' and `///' get bound to Vi-style macros that toggle -case-insensitivity and regexp-search. - -If you don't like these features---which I don't really understand---you -can unbind `/' and `:' in @code{viper-dired-modifier-map} (for Dired) or in -@code{viper-slash-and-colon-map}, for other modes. -@vindex @code{viper-slash-and-colon-map} -@vindex @code{viper-dired-modifier-map} - -To unbind the macros `//' and `///' for a major mode where you feel they -are undesirable, execute @code{viper-set-emacs-state-searchstyle-macros} with a -non-nil argument. This can be done either interactively, by supplying a -prefix argument, or by placing -@example -(viper-set-emacs-state-searchstyle-macros 'undefine) -@end example -@findex @code{viper-set-emacs-state-searchstyle-macros} -in the hook to the major mode (e.g., @code{dired-mode-hook}). -@xref{Vi Macros}, for more information on Vi macros. - -@item viper-heading-start -@item viper-heading-end -@cindex headings -@cindex sections -@cindex paragraphs -@cindex sentences -Regular Expressions for @kbd{[[} and @kbd{]]}. Note that Emacs defines -Regexps for paragraphs and sentences. @xref{Paragraphs,,Paragraphs and -Sentences,emacs,The GNU Emacs Manual}, for details. -@item M-x viper-set-expert-level -@findex @code{viper-set-expert-level} -Change your user level interactively. -@item viper-smart-suffix-list '("" "tex" "c" "cc" "el" "p") -@vindex @code{viper-smart-suffix-list} -Viper supports Emacs-style file completion when it prompts the user for a -file name. However, in many cases, the same directory may contain files -with identical prefix but different suffixes, e.g., prog.c, prog.o, -paper.tex, paper.dvi. In such cases, completion will stop at the `.'. -If the above variable is a list of strings representing suffixes, Viper will -try these suffixes -in the order listed and will check if the corresponding file exists. - -For instance, if completion stopped at `paper.' and the user typed -@key{RET}, -then Viper will check if the files `paper.', `paper.tex', `paper.c', etc., exist. -It will take the first such file. If no file exists, Viper will give a chance -to complete the file name by typing the appropriate suffix. If `paper.' was -the intended file name, hitting return will accept it. - -To turn this feature off, set the above variable to @code{nil}. - -@item viper-insertion-ring-size 14 -@vindex @code{viper-insertion-ring-size} -@cindex Insertion ring -Viper remembers what was previously inserted in Insert and Replace states. -Several such recent insertions are kept in a special ring of strings of size -@code{viper-insertion-ring-size}. -If you enter Insert or Replace state you can reinsert strings from this -ring by typing @kbd{C-c M-p} or @kbd{C-c M-n}. The former will search the -ring in -the direction of older insertions, and the latter will search in -the direction of newer insertions. Hitting @kbd{C-c M-p} or @kbd{C-c M-n} -in succession -will undo the previous insertion from the ring and insert the next item on -the ring. If a larger ring size is needed, change the value of the above -variable in the @file{~/.viper} file. - -Since typing these sequences of keys may be tedious, it is suggested that the -user should bind a function key, such as @kbd{f31}, as follows: -@example -(define-key viper-insert-global-user-map [f31] - 'viper-insert-prev-from-insertion-ring) -@end example -This binds @kbd{f31} (which is usually @kbd{R11} on a Sun workstation) -to the function that inserts the previous string in the insertion history. -To rotate the history in the opposite -direction, you can either bind an unused key to -@code{viper-insert-next-from-insertion-ring} or hit any digit (1 to 9) then -@kbd{f31}. - -One should not bind the above functions to @kbd{M-p} or @kbd{M-n}, since -this will interfere with the Minibuffer histories and, possibly, other -major modes. - -@item viper-command-ring-size 14 -@vindex @code{viper-command-ring-size} -@cindex Destructive command ring -@cindex Destructive command history -Viper keeps track of the recent history of destructive -commands, such as @kbd{dw}, @kbd{i}, etc. -In Vi state, -the most recent command can be re-executed by hitting `@kbd{.}', as in Vi. -However, repeated typing @kbd{C-c M-p} will cause Viper to show the -previous destructive commands in the minibuffer. Subsequent hitting `@kbd{.}' -will execute the command that was displayed last. -The key @kbd{C-c M-n} will cycle through the command history in the -opposite direction. -Since typing @kbd{C-c M-p} may be tedious, it is more convenient to bind an -appropriate function to an unused function key on the keyboard and use that -key. For instance, the following -@example -(define-key viper-vi-global-user-map [f31] - 'viper-prev-destructive-command) -@end example -binds the key @kbd{f31} (which is usually @kbd{R11} on a Sun workstation) -to the function that searches the command history in the direction of older -commands. To search in the opposite -direction, you can either bind an unused key to -@code{viper-next-destructive-command} or hit any digit (1 to 9) then @kbd{f31}. - -One should not bind the above functions to @kbd{M-p} or @kbd{M-n}, since -this will interfere with the Minibuffer histories and, possibly, other -major modes. - -@item viper-minibuffer-vi-face 'viper-minibuffer-vi-face -@item viper-minibuffer-insert-face 'viper-minibuffer-insert-face -@item viper-minibuffer-emacs-face 'viper-minibuffer-emacs-face -These faces control the appearance of the minibuffer text in the -corresponding Viper states. You can change the appearance of these faces -through Emacs' customization widget, which is accessible through the -menubar. - -Viper is located in this widget under the @emph{Emulations} customization -subgroup of the @emph{Editing} group. All Viper faces are grouped together -in Viper's @emph{Highlighting} customization subgroup. - -Note that only the text you type in is affected by the above faces. -Prompts and Minibuffer messages are not affected. - -Purists who do not like adornments in the minibuffer can always zap them by -putting -@example -(copy-face 'default 'viper-minibuffer-vi-face) -(copy-face 'default 'viper-minibuffer-insert-face) -(copy-face 'default 'viper-minibuffer-emacs-face) -@end example -in the @file{~/.viper} file or through the customization widget, as -described above. However, in that case, the user will not have any -indication of the current Viper state in the minibuffer. (This is important -if the user accidentally switches to another Viper state by typing @key{ESC} or -@kbd{C-z}). -@item M-x viper-go-away -@findex @code{viper-go-away} -Make Viper disappear from the face of your running Emacs instance. If your -fingers start aching again, @kbd{M-x viper-mode} might save your day. -@item M-x toggle-viper-mode -@findex @code{toggle-viper-mode} -Toggle Viperization of Emacs on and off. -@end table - -@cindex Multifile documents and programs - -Viper provides some support for multi-file documents and programs. -If a document consists of several files we can designate one of them as a -master and put the following at the end of that file: -@lisp -;;; Local Variables: -;;; eval: (viper-setup-master-buffer "file1" "file2" "file3" "file5" "file5") -;;; End: -@end lisp -@noindent -where @code{file1} to @code{file5} are names of files related to the master -file. Next time, when the master file is visited, the command -@code{viper-setup-master-buffer} will be evaluated and the above files will -be associated with the master file. Then, the new Ex command -@kbd{:RelatedFile} (abbr. @kbd{:R}) will display files 1 to 5 one after -another, so you can edit them. If a file is not in any Emacs buffer, it -will be visited. The command @kbd{PreviousRelatedFile} (abbr., @kbd{:P}) -goes through the file list in the opposite direction. -@findex @kbd{:RelatedFile} -@findex @kbd{:PreviousRelatedFile} - -These commands are akin to @kbd{:n} and @kbd{:N}, but they allow the user to -focus on relevant files only. - -Note that only the master file needs to have the aforementioned block of -commands. Also, ";;;" above can be replaced by some other -markers. Semicolon is good for Lisp programs, since it is considered a -comment designator there. For LaTeX, this could be "%%%", and for C the -above block should be commented out. - -Even though these commands are sometimes useful, they are no substitute for -the powerful @emph{tag table} facility of Emacs. Viper's @kbd{:tag} command -in a primitive interface to Emacs tags. @xref{Tags,Tags,Tags,emacs, -The Gnu Emacs Manual}, for more information on tags. - -The following two commands are normally bound to a mouse click and are part -of Viper. They work only if Emacs runs as an application under X -Windows (or under some other window system for which a port of GNU Emacs 20 -is available). Clicking the mouse when Emacs is invoked in an Xterm window -(using @code{emacs -nw}) will do no good. - -@table @code -@cindex mouse -@cindex mouse-search -@item viper-mouse-search-key (meta shift 1) -@vindex @code{viper-mouse-insert-key} -This variable controls the @emph{mouse-search} feature of Viper. The -default value -states that holding Meta and Shift keys while clicking mouse button 1 -should initiate search for a region under the mouse pointer (defined -below). This command can take a prefix argument, which indicates the -occurrence of the pattern to search for. - -Note: while loading initially, Viper binds this mouse action only if it is -not already bound to something else. If you want to use the mouse-seatch -feature and the Meta-Shift-button-1 mouse action is already bound to -something else you can rebind the mouse-search feature by setting -@code{viper-mouse-search-key} to something else in your @code{~/.viper} -file: -@lisp -(setq viper-mouse-search-key '(meta 1)) -@end lisp -This would bind mouse search to the action invoked by pressing the -Meta key and clicking mouse button 1. The allowed values of -@code{viper-mouse-search-key} are lists that contain a mouse-button number -(1,2, or 3) and any combination of the words `control', `meta', and -`shift'. - -If the requested mouse action (e.g., (meta 1)) is already taken for other -purposes then you have to confirm your intention by placing the following -command in @code{~/.viper} after setting @code{viper-mouse-search-key}: -@lisp -(viper-bind-mouse-search-key 'force) -@end lisp - -You can also change this setting interactively, through the customization -widget of Emacs (choose option "Customize.Customize Group" from the -menubar). - -The region that is chosen as a pattern to search for is determined as -follows. If search is invoked via a single click, Viper chooses the region -that lies between the beginning of the ``word'' under the pointer (``word'' -is understood in Vi sense) and the end of that word. The only difference -with Vi's words is that in Lisp major modes `-' is considered an -alphanumeric symbol. This is done for the convenience of working with Lisp -symbols, which often have an `-' in them. Also, if you click on a -non-alphanumeric character that is not a word separator (in Vi sense) then -this character will also be considered alphanumeric, provided that it is -adjacent (from either side) to an alphanumeric character. This useful -feature gives added control over the patterns selected by the mouse click. - -On a double-click, the region is determined by the beginning of the current -Vi's ``Word'' (i.e., the largest non-separator chunk of text) and the End -of that ``Word'' (as determined by the @kbd{E} command). - -On a triple-click, the region consists of the entire line where the click -occurred with all leading and trailing spaces and tabs removed. - -@cindex mouse-insert -@item viper-mouse-insert-key (meta shift 2) -@vindex @code{viper-mouse-insert-key} -This variable controls the @emph{mouse-insert} feature of Viper. -The above default value states that -holding Meta and Shift keys while clicking mouse button 2 -should insert the region surrounding the -mouse pointer. The rules defining this region are the same as for -mouse-search. This command takes an optional prefix argument, which -indicates how many such regions to snarf from the buffer and insert. (In -case of a triple-click, the prefix argument is ignored.) - -Note: while loading initially, Viper binds this mouse action only if it not -already bound to something else. If you want to use this feature and the -default mouse action is already bound, you can rebind mouse-insert by -placing this command in @code{~/.viper}: -@lisp -(setq viper-mouse-insert-key '(meta 2)) -@end lisp -If you want to bind mouse-insert to an action even if this action is -already taked for other purposes in Emacs, then you should add this command -to @code{~/.viper}, after setting @code{viper-mouse-insert-key}: -@lisp -(viper-bind-mouse-insert-key 'force) -@end lisp - -This value can also be changed via the Emacs customization widget at the -menubar. - -@item viper-multiclick-timeout -This variable controls the rate at which double-clicking must occur for the -purpose of mouse search and mouse insert. By default, this is set to -@code{double-click-time} in Emacs and to -@code{mouse-track-multi-click-time} milliseconds in XEmacs. -@end table -@kindex @kbd{S-mouse-1} -@kindex @kbd{S-mouse-2} -@kindex @kbd{meta shift button1up} -@kindex @kbd{meta shift button2up} -@vindex @code{viper-multiclick-timeout} -@findex @code{viper-mouse-click-insert-word} -@findex @code{viper-mouse-click-search-word} - -Note: The above functions search and insert in the selected window of -the latest active frame. This means that you can click in another window or -another frame and have search or insertion done in the frame and window you -just left. This lets one use these functions in a multi-frame -configuration. However, this may require some getting used to. For -instance, if you are typing in a frame, A, and then move the mouse to frame -B and click to invoke mouse search, search (or insertion) will be performed -in frame A. To perform search/insertion in frame B, you will first have to -shift focus there, which doesn't happen until you type a character or -perform some other action in frame B---mouse search doesn't shift focus (in -XEmacs, to shift focus to frame B, you will have to select this frame with -a mouse, by clicking. - -If you decide that you don't like the above feature and always want -search/insertion be performed in the frame where the click occurs, don't -bind (and unbind, if necessary) @code{viper-mouse-catch-frame-switch} from -the mouse event it is bound to. - -Mouse search is integrated with Vi-style search, so you can -repeat it with @kbd{n} and @kbd{N}. It should be also noted that, while -case-sensitivity of search in Viper is controlled by the variable -@code{viper-case-fold-search}, the case of mouse search is -controlled by the Emacs variable @code{case-fold-search}, which may be set -differently from @code{viper-case-fold-search}. Therefore, case-sensitivity -of mouse search may be different from that of the usual Vi-style search. - -Finally, if the way Viper determines the word to be searched for or to be -inserted is not what you want, there is a variable, -@code{viper-surrounding-word-function}, which can be changed to indicate -another function for snarfing words out of the buffer. The catch is that -you will then have to write such a function and make it known to your -Emacs. The function @code{viper-surrounding-word} in @file{viper.el} can be -used as a guiding example. - -@node Vi Macros, ,Viper Specials,Customization -@section Vi Macros - -@cindex Vi macros - -Viper supports much enhanced Vi-style macros and also facilitates the use -of Emacs-style macros. To define a temporary macro, it is generally more -convenient to use Emacs keyboard macro facility. Emacs keyboard macros are -usually defined anonymously, and the latest macro can be executed by typing -@kbd{C-x e} (or @kbd{*}, if Viper is in Vi state). If you need to use several -temporary macros, Viper lets you save them to a -register (a lowercase letter); such macros can then be executed by typing -@kbd{@@a} in Vi state (if a macro was previously saved in register -@kbd{a}). -@xref{Macros and Registers}, for details. - -If, however, you need to use a macro regularly, it must be given a -permanent name and saved. Emacs manual explains how to do this, but -invocation of named Emacs macros is quite different from Vi's. First, -invocation of permanent Emacs macros takes time because of the extra keys. -Second, binding such macros to function keys, for -fast access, hogs valuable real estate on the keyboard. - -Vi-style macros are better in that respect, since Vi lets the user overload -the meaning of key sequences: keys typed in fast succession are treated -specially, if this key sequence is bound to a macro. - -Viper provides keyboard macros through the usual Ex commands, @kbd{:map} and -@kbd{:map!}. Vi-style macros are much more powerful in Viper than -they are in the original Vi and in other emulators. This is because Viper -implements an enhanced vi-style -interface to the powerful Emacs keyboard macro facility. - -First, any Emacs -command can be executed while defining a macro, not just the Vi -commands. In particular, the user can invoke Emacs commands via @kbd{M-x -command-name} or by pressing various function keys on the keyboard. One -can even use the mouse, although this is usually not useful and is not -recommended (and macros defined with the use of the mouse cannot be saved in -command history and in the startup file, for future use). - -Macros defined by mixing Vi and Emacs commands are represented as -vectors. So, don't be confused when you see one (usually through the -history of Ex commands). For instance, if @kbd{gg} is defined by typing -@kbd{l}, the up-arrow key and @kbd{M-x next-line}, its definition will look -as follows in Emacs (in XEmacs, it looks slightly different, see below): - -@example -[l up (meta x) n e x t - l i n e return] -@end example - -Second, Viper macros are defined in a WYSIWYG style. This means that -commands are executed as you type them, so you can see precisely what is -being defined. Third, macros can be bound to arbitrary sequences of keys, -not just to printable keys. For instance, one can define a macro that will -be invoked by hitting @kbd{f3} then @kbd{f2} function keys. (The keys -@kbd{delete} and @kbd{backspace} are excluded; also, a macro invocation -sequence can't start with @key{ESC}. Some other keys, such as @kbd{f1} and -@kbd{help}, can't be bound to macros under Emacs (not XEmacs), since they -are bound in @code{key-translation-map}, which overrides any other binding -the user gives to keys. In general, keys that have a binding in -@code{key-translation-map} can't be bound to a macro.) - -Fourth, in Viper, one can define macros that are specific to a given -buffer, a given major mode, or macros that are defined for all buffers. In -fact, the same macro name can have several different definitions: one -global, several definitions for various major modes, and -definitions for various specific buffers. Buffer-specific definitions -override mode-specific definitions, which, in turn, override global -definitions. - -As if all that is not enough, Viper (through its interface to Emacs -macros) lets the user define keyboard macros that ask for confirmation or -even prompt the user for input and then continue. To do this, one should -type @kbd{C-x q} (for confirmation) or @kbd{C-u C-x q} (for prompt). -For details, @pxref{Kbd Macro Query,,Customization,emacs,The GNU Emacs -Manual} @refill - -When the user finishes defining a macro (which is done by typing @kbd{C-x)} --- -a departure from Vi), you will be asked whether you want this -macro to be global, mode-specific, or buffer-specific. You will also be -given a chance to save the macro in your @file{~/.viper} file. -This is the easiest way to save a macro and make -it permanently available. If you work your startup files with bare hands, -here is how Viper saves the above macro so that it will be -available in Viper's Insert state (and Replace state) in buffer @code{my-buf} -only: - -@example -(viper-record-kbd-macro "gg" 'insert-state - [l up (meta x) n e x t - l i n e return] - "my-buf") -@end example - -@noindent -To do the same for Vi state and all buffers with the major mode -@code{cc-mode}, use: - -@example -(viper-record-kbd-macro "gg" 'vi-state - [l up (meta x) n e x t - l i n e return] - 'cc-mode) -@end example - -@noindent -Both macro names and macro definitions are vectors of symbols that denote -keys on the keyboard. Some keys, like @kbd{\}, @kbd{ }, or digit-keys must -be escaped with a backslash. Modified keys are represented as lists. For -instance, holding Meta and Control and pressing @kbd{f4} is represented as -@kbd{(control meta f4)}. -If all members of a vectors are printable characters (or sequences, such as -@kbd{\e}, @kbd{\t}, for @key{ESC} and @key{TAB}), then they can also be represented as -strings: - -@example -(viper-record-kbd-macro "aa" 'vi-state "aaa\e" "my-buffer") -@end example - -@noindent -Thus, typing @kbd{aa} fast in Vi state will switch Viper to Insert state -(due to the first @kbd{a}), insert @kbd{aa}, and then it will switch back to Vi -state. All this will take effect only in the buffer named @code{my-buffer}. - -Note that the last argument to @code{viper-record-kbd-macro} must be either a -string (a buffer name), a symbol representing a major mode, or @code{t}; -the latter says that the macro is to be defined for all buffers -(which is how macros are defined in original Vi). - -For convenience, Viper also lets you define Vi-style macros in its Emacs -state. There is no Ex command, like @kbd{:map} and @kbd{:map!} for doing -this, but the user can include such a macro in the @file{~/.viper} file. The -only thing is that the @code{viper-record-kbd-macro} command should specify -@code{emacs-state} instead of @code{vi-state} or @code{insert-state}. - -The user can get rid of a macro either by using the Ex commands @kbd{:unmap} -and @kbd{:unmap!} or by issuing a call to @code{viper-unrecord-kbd-macro}. -The latter is more powerful, since it can delete macros even in -@code{emacs-state}. However, @code{viper-unrecord-kbd-macro} is usually -needed only when the user needs to get rid of the macros that are already -predefined in Viper. -The syntax is: -@findex @code{viper-unrecord-kbd-macro} -@example -(viper-unrecord-kbd-macro macro state) -@end example -@noindent -The second argument must be @code{vi-state}, @code{insert-state}, or -@code{emacs-state}. The first argument is a name of a macro. To avoid -mistakes in specifying names of existing macros, type @kbd{M-x -viper-describe-kbd-macros} and use a name from the list displayed by this -command. - -If an error occurs during macro definition, Emacs -aborts the process, and it must be repeated. This is analogous to Vi, -except that in Vi the user doesn't know there is an error until the macro is -actually run. All that means that in order for a definition to be -successful, the user must do some simple planning of the process in -advance, to avoid errors. For instance, if you want to map @kbd{gg} to -@kbd{llll} in Vi state, you must make sure that there is enough room on the -current line. Since @kbd{l} moves the cursor forward, it may signal an -error on reaching the end of line, which will abort the definition. - -These precautions are necessary only when defining macros; they will help -avoid the need to redo the job. When macros are actually run, an error -during the execution will simply terminate the current execution -(but the macro will remain mapped). - -A macro name can be a string of characters or a vector of keys. -The latter makes it possible to define macros bound to, say, double-hits -on a function key, such as @kbd{up} or @kbd{f13}. -This is very useful if you run out of function keys on your keyboard; it -makes Viper macro facility a @emph{keyboard doubler}, so to speak. - -Elsewhere (@xref{Keybindings}, for details), we review -the standard Emacs mechanism for binding function keys to commands. -For instance, - -@example -(global-set-key [f13] 'repeat-complex-command) -@end example - -@noindent -binds the key f13 to the Emacs function that repeats the last minibuffer -command. Under Viper, however, you may still use this key for additional -purposes, if you bind, say, a double-hitting action for that key to some -other function. Emacs doesn't allow the user to do that, but Viper does -this through its keyboard macro facility. To do this, type @kbd{:map } -first. When you are asked to enter a macro name, hit f13 twice, followed by -@key{RET} or @key{SPC}. - -Emacs will now start the mapping process by actually executing -Vi and Emacs commands, so that you could see what will happen each time the -macro is executed. Suppose now we wanted to bind the key sequence -@kbd{f13 f13} to the command @code{eval-last-sexp}. To accomplish this, we -can type @kbd{M-x eval-last-sexp} followed by @kbd{C-x )}. -If you answer positively to Viper's offer to save this macro in @file{~/.viper} -for future uses, the following will be inserted in that file: - -@example -(viper-record-kbd-macro [f16 f16] 'vi-state - [(meta x) e v a l - l a s t - s e x p] - 'lisp-interaction-mode) -@end example - -To illustrate the above point, Viper provides two canned macros, which, by -default, are bound to @kbd{[f12 \1]} and @kbd{[f12 \2]} (invoked by typing -@kbd{f12} then @kbd{1} and @kbd{2}, respectively). These macros are useful -shortcuts to Viper's command ring history. The first macro will execute the -second-last destructive command (the last one is executed by @kbd{.}, as -usual). The second macro executes the third-last command. - -If you need to go deeper into the command history, you will have to use -other commands, as described earlier in this section; or you can bind, -say, @kbd{f12 \3} like this: - -@example -(viper-record-kbd-macro [f12 \3] 'vi-state - [(meta x) r e p e a t - f r o m - h i s t o r y] - t) -@end example - - -Note that even though the macro uses the function key @kbd{f12}, the key is -actually free and can still be bound to some Emacs function via -@code{define-key} or @code{global-set-key}. - - -Viper allows the user to define macro names that are prefixes of other macros. -For instance, one can define @kbd{[[} and @kbd{[[[[} to be macros. -If you type the exact sequence of such keys and then pause, Viper will -execute the right macro. However, if you don't pause and, say, type -@kbd{[[[[text} then the conflict is resolved as follows. If only one of the -key sequences, @kbd{[[} or @kbd{[[[[} has a definition applicable to the -current buffer, then, in fact, there is no conflict and the right macro -will be chosen. If both have applicable definitions, then the first one -found will be executed. Usually this is the macro with a shorter name. So, -in our case, @kbd{[[[[text} will cause the macro @kbd{[[} to be executed -twice and then the remaining keys, @kbd{t e x t}, will be processed. - -When defining macros using @kbd{:map} or @kbd{:map!}, the user enters the -actually keys to be used to invoke the macro. For instance, you should hit -the actual key @kbd{f6} if it is to be part of a macro name; you do -@emph{not} write `f 6'. When entering keys, Viper displays them as strings or -vectors (e.g., "abc" or [f6 f7 a]). The same holds for unmapping. Hitting -@key{TAB} while typing a macro name in the @kbd{:unmap} or @kbd{:unmap!} command -will cause name completion. Completions are displayed as strings or vectors. -However, as before, you don't actually type ``"'', ``['', or ``]'' that -appear in the completions. These are meta-symbols that indicate whether -the corresponding macro name is a vector or a string. - -One last difference from Vi: Vi-style keyboard macros cannot be defined in -terms of other Vi-style keyboard macros (but named Emacs macros are OK). -More precisely, while defining or executing a macro, the special meaning -of key sequences (as Vi macros) is ignored. -This is because it is all too easy to create an infinite loop in this way. -Since Viper macros are much more powerful than Vi's it is impossible to -detect such loops. In practice, this is not really a limitation but, -rather, a feature. - -We should also note that Vi macros are disabled in the Minibuffer, which -helps keep some potential troubles away. - -The rate at which the user must type keys in order for them to be -recognized as a timeout macro is controlled by the variable -@code{viper-fast-keyseq-timeout}, which defaults to 200 milliseconds. - -For the most part, Viper macros defined in @file{~/.viper} can be shared -between Emacs, XEmacs, and X and TTY modes. However, macros defined via -function keys may need separate definitions when XEmacs and Emacs have -different names for the same keyboard key. For instance, the `Page Up' key -may be known in Emacs as @kbd{prior} and in XEmacs as @kbd{pgup}. -The problem with TTY may be that the function keys there generate sequences -of events instead of a single event (as under a window system). -Both Emacs and XEmacs mape some of these sequences back to the logical keys -(e.g., the sequences generated by the arrow keys are mapped to @kbd{up}, -@kbd{left}, etc.). However, not all function keys are mapped in this way. -Macros that are bound to key sequences that contain such unmapped function -keys have to be redefined for TTY's (and possibly for every type of TTY you -may be using). To do this, start Emacs on an appropriate TTY device and -define the macro using @kbd{:map}, as usual. - -@findex @code{viper-describe-kbd-macros} -Finally, Viper provides a function that conveniently displays all macros -currently defined. To see all macros along with their definitions, type -@kbd{M-x viper-describe-kbd-macros}. - -@node Commands,,Customization,Top,Top -@chapter Commands - -This section is a semi-automatically bowdlerized version of the Vi -reference created by @* @samp{maart@@cs.vu.nl} and others. It can be -found on the Vi archives. This reference has been adapted for Viper.@refill - -@menu -* Groundwork:: Textual Conventions and Viper basics -* Text Handling:: Moving, Editing, Undoing. -* Display:: Scrolling. -* File and Buffer Handling:: Editing, Writing and Quitting. -* Mapping:: Mapping Keys, Keyboard Macros -* Shell Commands:: Accessing Shell Commands, Processing Text -* Options:: Ex options, the @kbd{:set} commands -* Emacs Related Commands:: Meta Keys, Windows -* Mouse-bound Commands:: Search and insertion of text -@end menu - -@node Groundwork, Text Handling, Commands, Commands -@comment node-name, next, previous, up -@section Groundwork - -The VI command set is based on the idea of combining motion commands -with other commands. The motion command is used as a text region -specifier for other commands. -We classify motion commands into @dfn{point commands} and -@dfn{line commands}.@refill - -@cindex point commands - -The point commands are: - -@quotation -@kbd{h}, @kbd{l}, @kbd{0}, @kbd{$}, @kbd{w}, @kbd{W}, @kbd{b}, @kbd{B}, -@kbd{e}, @kbd{E}, @kbd{(}, @kbd{)}, @kbd{/}, @kbd{?}, @kbd{`}, @kbd{f}, -@kbd{F}, @kbd{t}, @kbd{T}, @kbd{%}, @kbd{;}, @kbd{,}, @kbd{^} -@end quotation - -@cindex line commands - -The line commands are: - -@quotation -@kbd{j}, @kbd{k}, @kbd{+}, @kbd{-}, @kbd{H}, @kbd{M}, @kbd{L}, @kbd{@{}, -@kbd{@}}, @kbd{G}, @kbd{'}, @kbd{[[}, @kbd{]]}, @kbd{[]} -@end quotation -@noindent - -Text Deletion Commands (@xref{Deleting Text}), Change commands -(@xref{Changing Text}), even Shell Commands (@xref{Shell Commands}) -use these commands to describe a region of text to operate on. - -@cindex r and R region specifiers - -Viper adds two region descriptors, @kbd{r} and @kbd{R}. These describe -the Emacs regions (@xref{Basics}), but they are not movement commands. - -The command description uses angle brackets @samp{<>} to indicate -metasyntactic variables, since the normal conventions of using simple -text can be confusing with Viper where the commands themselves are -characters. Watch out where @kbd{<} shift commands and @kbd{} are -mentioned together!!! - -@kindex -@kindex -@kindex
            -@cindex -@cindex -@cindex
            -@cindex movements - -@samp{} refers to the above movement commands, and @samp{} -refers to registers or textmarkers from @samp{a} to @samp{z}. Note -that the @samp{} is described by full move commands, that is to -say they will take counts, and otherwise behave like normal move commands. -@cindex Ex addresses -@samp{
            } refers to Ex line addresses, which include - -@table @kbd -@item . -Current line -@item .+n .-n -Add or subtract for current line -@item number -Actual line number, use @kbd{.=} to get the line number -@item ' -Textmarker -@item $ -Last line -@item x,y -Where x and y are one of the above -@item % -@cindex % (Ex address) -For the whole file, same as (1,$). -@item /pat/ -@item ?pat? -Next or previous line with pattern pat -@end table - -@cindex % (Current file) -Note that @samp{%} is used in Ex commands to mean current file. If you -want a @samp{%} in your command, it must be escaped as @samp{\%}. -@cindex # (Previous file) -Similarly, @samp{#} expands to the previous file. The previous file is -the first file in @kbd{:args} listing. This defaults to previous window -in the VI sense if you have one window only. - -@kindex -@kindex -@cindex -@cindex -@noindent -Others like @samp{ -- arguments}, @samp{ -- command} etc. -should be fairly obvious. - -@noindent -Common characters referred to include: - -@table @kbd -@item -Space -@item -Tab -@item -Linefeed -@item -Escape -@item -Return, Enter -@end table -@cindex -@cindex -@cindex -@cindex -@cindex - -@cindex words -@cindex WORDS -@cindex char -@cindex CHAR - -We also use @samp{word} for alphanumeric/non-alphanumeric words, and -@samp{WORD} for whitespace delimited words. @samp{char} refers to any -ASCII character, @samp{CHAR} to non-whitespace character. -Brackets @samp{[]} indicate optional parameters; @samp{} also -optional, usually defaulting to 1. Brackets are elided for -@samp{} to eschew obfuscation. - -Viper's idea of Vi's words is slightly different from Vi. First, Viper -words understand Emacs symbol tables. Therefore, all symbols declared to be -alphanumeric in a symbol table can automatically be made part of the Viper -word. This is useful when, for instance, editing text containing European, -Cyrillic, Japanese, etc., texts. - -Second, Viper lets you depart from Vi's idea of a word by changing the a -syntax preference via the customization widget (the variable -@code{viper-syntax-preference}) or by executing -@code{viper-set-syntax-preference} interactively. - -By default, Viper syntax preference is @code{reformed-vi}, which means that -Viper considers only those symbols to be part of a word that are specified -as word-symbols by the current Emacs syntax table (which may be different -for different major modes) plus the underscore symbol @kbd{_}, minus the -symbols that are not considered words in Vi (e.g., `,',;, etc.), but may be -considered as word-symbols by various Emacs major modes. Reformed-Vi works -very close to Vi, and it also recognizes words in other -alphabets. Therefore, this is the most appropriate mode for editing text -and is likely to fit all your needs. - -You can also set Viper syntax preference to @code{strict-vi}, which would -cause Viper to view all non-English letters as non-word-symbols. - -You can also specify @code{emacs} as your preference, which would -make Viper use exactly the same notion of a word as Emacs does. In -particular, the underscore may not be part of a word in some major modes. - -Finally, if @code{viper-syntax-preference} is set to @code{extended}, Viper -words would consist of characters that are classified as alphanumeric -@emph{or} as parts of symbols. This is convenient for editing programs. - -@code{viper-syntax-preference} is a local variable, so it can have different -values for different major modes. For instance, in programming modes it can -have the value @code{extended}. In text modes where words contain special -characters, such as European (non-English) letters, Cyrillic letters, etc., -the value can be @code{reformed-vi} or @code{emacs}. -If you consider using different syntactic preferences for different major -modes, you should execute, for example, - -@example -(viper-set-syntax-preference nil "extended") -@end example - -in the appropriate major mode hooks. - -@vindex @code{viper-syntax-preference} -@findex @code{viper-set-syntax-preference} -@cindex syntax table - - - -The above discussion concerns only the movement commands. In regular -expressions, words remain the same as in Emacs. That is, the expressions -@code{\w}, @code{\>}, @code{\<}, etc., use Emacs' idea of what is a word, -and they don't look into the value of variable -@code{viper-syntax-preference}. This is because Viper doesn't change syntax -tables in order to not thwart the various major modes that set these -tables. - -The usual Emacs convention is used to indicate Control Characters, i.e -C-h for Control-h. @emph{Do not confuse this to mean the separate -characters C - h!!!} The @kbd{^} is itself, never used to indicate a -Control character. - -@node Text Handling, Display, Groundwork, Commands -@section Text Handling - -@menu -* Move Commands:: Moving, Searching -* Marking:: Textmarkers in Viper and the Emacs Mark. -* Appending Text:: Text insertion, Shifting, Putting -* Editing in Insert State:: Autoindent, Quoting etc. -* Deleting Text:: Deleting -* Changing Text:: Changing, Replacement, Joining -* Search and Replace:: Searches, Query Replace, Pattern Commands -* Yanking:: Yanking, Viewing Registers -* Undoing:: Multiple Undo, Backups -@end menu - -@node Move Commands,Marking,,Text Handling -@subsection Move Commands - -@cindex movement commands -@cindex searching -@cindex textmarkers -@cindex markers -@cindex column movement -@cindex paragraphs -@cindex headings -@cindex sections -@cindex sentences -@cindex matching parens -@cindex paren matching - -@table @kbd -@item h C-h - chars to the left. -@item j C-n - lines downward. -@item l - chars to the right. -@item k C-p - lines upward. -@item $ -To the end of line from the cursor. -@item ^ -To the first CHAR - 1 lines lower. -@item - -To the first CHAR lines higher. -@item + -To the first CHAR lines lower. -@item 0 -To the first char of the line. -@item | -To column -@item f - s to the right (find). -@item t -Till before s to the right. -@item F - s to the left. -@item T -Till after s to the left. -@item ; -Repeat latest @kbd{f t F T} times. -@item , -Repeat latest @kbd{f t F T} - times in opposite direction. -@item w - words forward. -@item W - WORDS forward. -@item b - words backward. -@item B - WORDS backward. -@item e -To the end of word forward. -@item E -To the end of WORD forward. -@item G -Go to line (default end-of-file). -@item H -To line from top of the screen (home). -@item L -To line from bottom of the screen (last). -@item M -To the middle line of the screen. -@item ) - sentences forward. -@item ( - sentences backward. -@item @} - paragraphs forward. -@item @{ - paragraphs backward. -@item ]] -To the th heading. -@item [[ -To the th previous heading. -@item [] -To the end of th heading. -@item m -Mark the cursor position with a letter. -@item ` -To the mark. -@item ' -To the first CHAR of the line with the mark. -@item [ -Show contents of textmarker. -@item ] -Show contents of register. -@item `` -To the cursor position before the latest absolute -jump (of which are examples @kbd{/} and @kbd{G}). -@item '' -To the first CHAR of the line on which the cursor -was placed before the latest absolute jump. -@item / -To the th occurrence of . -@item / -To the th occurrence of from previous @kbd{/ or ?}. -@item ? -To the th previous occurrence of . -@item ? -To the th previous occurrence of from previous @kbd{? or /}. -@item n -Repeat latest @kbd{/} @kbd{?} (next). -@item N -Repeat latest search in opposite direction. -@item C-c / -Without a prefix argument, this command toggles -case-sensitive/case-insensitive search modes and plain vanilla/regular -expression search. With the prefix argument 1, i.e., -@kbd{1 C-c /}, this toggles case-sensitivity; with the prefix argument 2, -toggles plain vanilla search and search using -regular expressions. @xref{Viper Specials}, for alternative ways to invoke -this function. -@cindex vanilla search -@cindex case-sensitive search -@cindex case-insensitive search -@item % -Find the next bracket/parenthesis/brace and go to its match. -By default, Viper ignores brackets/parentheses/braces that occur inside -parentheses. You can change this by setting -@code{viper-parse-sexp-ignore-comments} to nil in your @file{.viper} fipe. -This option can also be toggled interactively if you quickly hit @kbd{%%%}. - -This latter feature is implemented as a vi-style keyboard macro. If you -don't want this macro, put - -@example -(viper-set-parsing-style-toggling-macro 'undefine) -@end example -@findex @code{viper-set-parsing-style-toggling-macro} - -in your @file{~/.viper} file. - -@end table -@kindex @kbd{%} -@kindex @kbd{C-c /} -@kindex @kbd{N} -@kindex @kbd{n} -@kindex @kbd{?} -@kindex @kbd{/} -@kindex @kbd{?} -@kindex @kbd{/} -@kindex @kbd{''} -@kindex @kbd{``} -@kindex @kbd{]} -@kindex @kbd{[} -@kindex @kbd{'} -@kindex @kbd{`} -@kindex @kbd{m} -@kindex @kbd{[]} -@kindex @kbd{[[} -@kindex @kbd{]]} -@kindex @kbd{@{} -@kindex @kbd{@}} -@kindex @kbd{(} -@kindex @kbd{)} -@kindex @kbd{M} -@kindex @kbd{L} -@kindex @kbd{H} -@kindex @kbd{G} -@kindex @kbd{E} -@kindex @kbd{e} -@kindex @kbd{B} -@kindex @kbd{b} -@kindex @kbd{W} -@kindex @kbd{w} -@kindex @kbd{,} -@kindex @kbd{;} -@kindex @kbd{T} -@kindex @kbd{F} -@kindex @kbd{t} -@kindex @kbd{f} -@kindex @kbd{|} -@kindex @kbd{0} -@kindex @kbd{} -@kindex @kbd{+} -@kindex @kbd{-} -@kindex @kbd{^} -@kindex @kbd{$} -@kindex @kbd{C-p} -@kindex @kbd{} -@kindex @kbd{} -@kindex @kbd{C-n} -@kindex @kbd{C-h} -@kindex @kbd{h} -@kindex @kbd{j} -@kindex @kbd{k} -@kindex @kbd{l} -@vindex @code{viper-parse-sexp-ignore-comments} - -@node Marking,Appending Text,Move Commands,Text Handling -@subsection Marking - -Emacs mark is referred to in the region specifiers @kbd{r} and @kbd{R}. -@xref{Emacs Preliminaries} and @pxref{Basics} for explanation. Also -see @ref{Mark,,Mark,emacs,The GNU Emacs manual}, for an explanation of -the Emacs mark ring. - -@cindex marking - -@table @kbd -@item m -Mark the current file and position with the specified letter. -@item m . -Set the Emacs mark (@xref{Emacs Preliminaries}) at point. -@item m < -Set the Emacs mark at beginning of buffer. -@item m > -Set the Emacs mark at end of buffer. -@item m , -Jump to the Emacs mark. -@item :mark -Mark position with text marker named . This is an Ex command. -@item :k -Same as @kbd{:mark}. -@item `` -Exchange point and mark. -@item '' -Exchange point and mark and go to the first CHAR on line. -@item ' -Go to specified Viper mark. -@item -Go to specified Viper mark and go to the first CHAR on line. -@end table -@kindex @kbd{m} -@kindex @kbd{m.} -@kindex @kbd{m>} -@kindex @kbd{m<} -@kindex @kbd{m,} -@findex @kbd{:mark} -@findex @kbd{:k} -@kindex @kbd{''} -@kindex @kbd{``} -@kindex @kbd{`} -@kindex @kbd{'} - -@node Appending Text, Editing in Insert State, Marking,Text Handling -@subsection Appending Text - -@xref{Options} to see how to change tab and shiftwidth size. See the GNU -Emacs manual, or try @kbd{C-ha tabs} (If you have turned Emacs help on). -Check out the variable @code{indent-tabs-mode} to put in just spaces. -Also see options for word-wrap. - -@cindex inserting -@cindex appending -@cindex paste -@cindex put - -@table @kbd -@item a - times after the cursor. -@item A - times at the end of line. -@item i - times before the cursor (insert). -@item I - times before the first CHAR of the line -@item o -On a new line below the current (open). -The count is only useful on a slow terminal. -@item O -On a new line above the current. -The count is only useful on a slow terminal. -@item > -Shift the lines described by one -shiftwidth to the right (layout!). -@item >> -Shift lines one shiftwidth to the right. -@item ["]p -Put the contents of the (default undo) buffer - times after the cursor. The register will -be automatically downcased. -@item ["]P -Put the contents of the (default undo) buffer - times before the cursor. The register will -@item [ -Show contents of textmarker. -@item ] -Show contents of register. -@item . -Repeat previous command times. For destructive -commands as well as undo. -@item f1 1 and f1 2 -While @kbd{.} repeats the last destructive command, -these two macros repeat the second-last and the third-last destructive -commands. @xref{Vi Macros}, for more information on Vi macros. -@item C-c M-p and C-c M-n -In Vi state, -these commands help peruse the history of Vi's destructive commands. -Successive typing of @kbd{C-c M-p} causes Viper to search the history in -the direction -of older commands, while hitting @kbd{C-c M-n} does so in reverse -order. Each command in the history is displayed in the Minibuffer. The -displayed command can -then be executed by typing `@kbd{.}'. - -Since typing the above sequences of keys may be tedious, the -functions doing the perusing can be bound to unused keyboard keys in the -@file{~/.viper} file. @xref{Viper Specials}, for details. -@end table -@kindex @kbd{C-c M-p} -@kindex @kbd{C-c M-n} -@kindex @kbd{.} -@kindex @kbd{]} -@kindex @kbd{[} -@kindex @kbd{P} -@kindex @kbd{p} -@kindex @kbd{"p} -@kindex @kbd{"P} -@kindex @kbd{>>} -@kindex @kbd{>} -@kindex @kbd{O} -@kindex @kbd{o} -@kindex @kbd{i} -@kindex @kbd{A} -@kindex @kbd{a} - -@node Editing in Insert State, Deleting Text, Appending Text,Text Handling -@subsection Editing in Insert State - -Minibuffer can be edited similarly to Insert state, and you can switch -between Insert/Replace/Vi states at will. -Some users prefer plain Emacs feel in the Minibuffer. To this end, set -@var{viper-vi-style-in-minibuffer} to @code{nil}. - -@cindex Insert state - -@table @kbd -@item C-v -Deprive the next char of its special meaning (quoting). -@item C-h -One char back. -@item C-w -One word back. -@item C-u -Back to the begin of the change on the -current line. - -@end table -@kindex @kbd{C-u} -@kindex @kbd{C-w} -@kindex @kbd{C-v} - -@node Deleting Text, Changing Text, Editing in Insert State, Text Handling -@subsection Deleting Text - - -There is one difference in text deletion that you should be -aware of. This difference comes from Emacs and was adopted in Viper -because we find it very useful. In Vi, if you delete a line, say, and then -another line, these two deletions are separated and are put back -separately if you use the @samp{p} command. In Emacs (and Viper), successive -series of deletions that are @emph{not interrupted} by other commands are -lumped together, so the deleted text gets accumulated and can be put back -as one chunk. If you want to break a sequence of deletions so that the -newly deleted text could be put back separately from the previously deleted -text, you should perform a non-deleting action, e.g., move the cursor one -character in any direction. - -@cindex shifting text - -@table @kbd -@item x -Delete chars under and after the cursor. -@item X -Delete chars before the cursor. -@item d -Delete from point to endpoint of . -@item dd -Delete lines. -@item D -The rest of the line. -@item < -Shift the lines described by one -shiftwidth to the left (layout!). -@item << -Shift lines one shiftwidth to the left. -@end table -@kindex @kbd{<<} -@kindex @kbd{<} -@kindex @kbd{D} -@kindex @kbd{dd} -@kindex @kbd{d} -@kindex @kbd{X} -@kindex @kbd{x} - -@node Changing Text, Search and Replace, Deleting Text,Text Handling -@subsection Changing Text - -@cindex joining lines -@cindex changing case -@cindex quoting regions -@cindex substitution - -@table @kbd -@item r -Replace chars by - no . -@item R -Overwrite the rest of the line, -appending change @var{count - 1} times. -@item s -Substitute chars. -@item S -Change lines. -@item c -Change from begin to endpoint of . -@item cc -Change lines. -@item C -The rest of the line and - 1 next lines. -@item = -Reindent the region described by move. -@item ~ -Switch lower and upper cases. -@item J -Join lines (default 2). -@item :[x,y]s/

            // -Substitute (on lines x through y) the pattern -

            (default the last pattern) with . Useful -flags are @samp{g} for @samp{global} (i.e. change every -non-overlapping occurrence of

            ) and @samp{c} for -@samp{confirm} (type @samp{y} to confirm a particular -substitution, else @samp{n} ). Instead of @kbd{/} any -punctuation CHAR unequal to and can be used as -delimiter. - -In Emacs, @samp{\&} stands for the last matched expression, so -@kbd{s/[ab]+/\&\&/} will double the string matched by @kbd{[ab]}. -Viper doesn't treat @samp{&} specially, unlike Vi: use @samp{\&} instead. -@item :[x,y]copy [z] -Copy text between @kbd{x} and @kbd{y} to the position after @kbd{z}. -@item :[x,y]t [z] -Same as @kbd{:copy}. -@item :[x,y]move [z] -Move text between @kbd{x} and @kbd{y} to the position after @kbd{z}. -@item & -Repeat latest Ex substitute command, e.g. -@kbd{:s/wrong/right}. -@item C-c / -Toggle case-sensitive search. With prefix argument, toggle vanilla/regular -expression search. -@item #c -Change upper-case characters in the region to lower-case. -@item #C -Change lower-case characters in the region to upper-case. -@item #q -Insert specified string at the beginning of each line in the region -@item C-c M-p and C-c M-n -In Insert and Replace states, these keys are bound to commands that peruse -the history of the text -previously inserted in other insert or replace commands. By repeatedly typing -@kbd{C-c M-p} or @kbd{C-c M-n}, you will cause Viper to -insert these previously used strings one by one. -When a new string is inserted, the previous one is deleted. - -In Vi state, these keys are bound to functions that peruse the history of -destructive Vi commands. -@xref{Viper Specials}, for details. -@end table -@kindex @kbd{C-c M-p} -@kindex @kbd{C-c M-n} -@kindex @kbd{#q } -@kindex @kbd{#C} -@kindex @kbd{#c} -@kindex @kbd{&} -@kindex @kbd{\&} -@findex @kbd{:substitute/

            //} -@findex @kbd{:s/

            //} -@findex @kbd{:copy [z]} -@findex @kbd{:t [z]} -@findex @kbd{:move [z]} -@kindex @kbd{J} -@kindex @kbd{~} -@kindex @kbd{=} -@kindex @kbd{C} -@kindex @kbd{cc} -@kindex @kbd{c} -@kindex @kbd{S} -@kindex @kbd{s} -@kindex @kbd{R} -@kindex @kbd{r} - -@node Search and Replace, Yanking, Changing Text,Text Handling -@subsection Search and Replace - -@xref{Groundwork}, for Ex address syntax. @xref{Options} to see how to -get literal (non-regular-expression) search and how to stop search from -wrapping around. - -@table @kbd -@item / -To the th occurrence of . -@item ? -To the th previous occurrence of . -@item g -Search for the text described by move. (off by default) -@item n -Repeat latest @kbd{/} @kbd{?} (next). -@item N -Idem in opposite direction. -@item % -Find the next bracket and go to its match -@item :[x,y]g// -@cindex text processing -Search globally [from line x to y] for -and execute the Ex on each occurrence. -@item :[x,y]v// -Execute on the lines that don't match. -@item #g -Execute the last keyboard macro for each line in the region. -@xref{Macros and Registers}, for more info. -@item Q -Query Replace. -@item :ta -Search in the tags file where is defined (file, line), and go to it. -@item :[x,y]s/

            // -Substitute (on lines x through y) the pattern

            (default the last -pattern) with . Useful -flags are @samp{g} for @samp{global} (i.e. change every -non-overlapping occurrence of

            ) and @samp{c} for -@samp{confirm} (type @samp{y} to confirm a particular -substitution, else @samp{n}). Instead of @kbd{/} any -punctuation character other than and can be used as -delimiter. -@item & -Repeat latest Ex substitute command, e.g. @kbd{:s/wrong/right}. -@item :global // -@itemx :g // -Execute on all lines that match . -@item :vglobal // -@itemx :v // -Execute on all lines that do not match . -@end table -@kindex @kbd{&} -@findex @kbd{:substitute/

            //} -@kindex @kbd{Q} -@kindex @kbd{#g} -@findex @kbd{:v} -@findex @kbd{:g} -@findex @kbd{:global} -@findex @kbd{:vglobal} -@findex @kbd{:tag } -@kindex @kbd{%} -@kindex @kbd{N} -@kindex @kbd{n} -@kindex @kbd{g} -@kindex @kbd{?} -@kindex @kbd{/} - -@node Yanking,Undoing,Search and Replace,Text Handling -@subsection Yanking - -@cindex cut and paste -@cindex paste - -@table @kbd -@item y -Yank from begin to endpoint of . -@item "y -Yank from begin to endpoint of to register. -@item "y -Yank from begin to endpoint of and append -to register. -@item yy - lines. -@item Y -Idem (should be equivalent to @kbd{y$} though). -@item m -Mark the cursor position with a letter. -@item [ -Show contents of textmarker. -@item ] -Show contents of register. -@item ["]p -Put the contents of the (default undo) buffer - times after the cursor. The register will -be automatically downcased. -@item ["]P -Put the contents of the (default undo) buffer - times before the cursor. The register will -@end table -@kindex @kbd{P} -@kindex @kbd{p} -@kindex @kbd{"p} -@kindex @kbd{"P} -@kindex @kbd{]} -@kindex @kbd{[} -@kindex @kbd{m} -@kindex @kbd{Y} -@kindex @kbd{yy} -@kindex @kbd{"y} -@kindex @kbd{"y} -@kindex @kbd{y} -@kindex @kbd{yank} -@findex @kbd{:yank} - -@node Undoing,, Yanking,Text Handling -@subsection Undoing - -@cindex undo -@cindex backup files - -@table @kbd -@item u U -Undo the latest change. -@item . -Repeat undo. -@item :q! -Quit Vi without writing. -@item :e! -Re-edit a messed-up file. -@item :rec -Recover file from autosave. Viper also creates backup files -that have a @samp{~} appended to them. -@end table -@findex @kbd{:rec} -@findex @kbd{:e!} -@findex @kbd{:q!} -@kindex @kbd{.} -@kindex @kbd{U} -@kindex @kbd{u} - -@node Display, File and Buffer Handling, Text Handling, Commands -@section Display - -@cindex scrolling - -@table @kbd -@item C-g -At user level 1, -give file name, status, current line number -and relative position. @* -At user levels 2 and higher, abort the current command. -@item C-c g -Give file name, status, current line number and relative position -- all -user levels. -@item C-l -Refresh the screen. -@item C-e -Expose more lines at bottom, cursor stays put (if possible). -@item C-y -Expose more lines at top, cursor stays put (if possible). -@item C-d -Scroll lines downward (default the number of the previous scroll; -initialization: half a page). -@item C-u -Scroll lines upward (default the number of the previous scroll; -initialization: half a page). -@item C-f - pages forward. -@item C-b - pages backward (in older versions @kbd{C-b} only works without count). -@item z -@item zH -Put line at the top of the window (default the current line). -@item z- -@item zL -Put line at the bottom of the window -(default the current line). -@item z. -@item zM -Put line in the center of the window -(default the current line). -@end table -@kindex @kbd{zM} -@kindex @kbd{zL} -@kindex @kbd{zH} -@kindex @kbd{z} -@kindex @kbd{z.} -@kindex @kbd{z-} -@kindex @kbd{z} -@kindex @kbd{C-b} -@kindex @kbd{C-f} -@kindex @kbd{C-u} -@kindex @kbd{C-d} -@kindex @kbd{C-y} -@kindex @kbd{C-e} -@kindex @kbd{C-l} -@kindex @kbd{C-g} - - -@node File and Buffer Handling, Mapping, Display,Commands -@section File and Buffer Handling - -@cindex multiple files - -In all file handling commands, space should be typed before entering the file -name. If you need to type a modifier, such as @kbd{>>} or @kbd{!}, don't -put any space between the command and the modifier. - -@table @kbd -@item :q -Quit buffer except if modified. -@item :q! -Quit buffer without checking. In Viper, these two commands -are identical. Confirmation is required if exiting modified buffers that -visit files. -@item :suspend -@item :stop -Suspend Viper -@item :[x,y] w -Write the file. Viper nakes sure that a final newline is always added to -any file where this newline is missing. This is done by setting Emacs -variable @code{require-final-newline} to @code{t}. If you don't like this -feature, use @code{setq-default} to set @code{require-final-newline} to -@code{nil}. This must be done in @file{.viper} file. -@item :[x,y] w -Write to the file . -@item :[x,y] w>> -Append the buffer to the file . There should be no space between -@kbd{w} and @kbd{>>}. Type space after the @kbd{>>} and see what happens. -@item :w! -Overwrite the file . In Viper, @kbd{:w} and @kbd{:w!} are identical. -Confirmation is required for writing to an existing file (if this is not -the file the buffer is visiting) or to a read-only file. -@item :x,y w -Write lines x through y to the file . -@item :wq -Write the file and kill buffer. -@item :r [ ...] -Read file into a buffer, inserting its contents after the current line. -@item :xit -Same as @kbd{:wq}. -@item :Write -@itemx :W -Save all unsaved buffers, asking for confirmation. -@item :WWrite -@itemx :WW -Like @kbd{W}, but without asking for confirmation. -@item ZZ -Save current buffer and kill it. If user level is 1, then save all files -and kill Emacs. Killing Emacs is the wrong way to use it, so you should -switch to higher user levels as soon as possible. -@item :x [] -Save and kill buffer. -@item :x! [] -@kbd{:w![]} and @kbd{:q}. -@item :pre -Preserve the file -- autosave buffers. -@item :rec -Recover file from autosave. -@item :f -Print file name and lines. -@item :cd [

            ] -Set the working directory to (default home directory). -@item :pwd -Print present working directory. -@item :e [+] -Edit files. If no filename is given, edit the file visited by the current -buffer. If buffer was modified or the file changed on disk, ask for -confirmation. Unlike Vi, Viper allows @kbd{:e} to take multiple arguments. -The first file is edited the same way as in Vi. The rest are visited -in the usual Emacs way. -@item :e! [+] -Re-edit file. If no filename, reedit current file. -In Viper, unlike Vi, @kbd{e!} is identical to @kbd{:e}. In both cases, the -user is asked to confirm if there is a danger of discarding changes to a -buffer. -@item :q! -Quit Vi without writing. -@item C-^ -Edit the alternate (normally the previous) file. -@item :rew -Obsolete -@item :args -List files not shown anywhere with counts for next -@item :n [count] [+] [] -Edit file, or edit files. The count comes from :args. -@item :N [count] [+] [] -Like @kbd{:n}, but the meaning of the variable -@var{ex-cycle-other-window} is reversed. -@item :b -Switch to another buffer. If @var{ex-cycle-other-window} is @code{t}, -switch in another window. Buffer completion is supported. -@item :B -Like @kbd{:b}, but the meaning of @var{ex-cycle-other-window} is reversed. -@item :
            r -Read the file into the buffer after the line
            . -@item v, V, C-v -Edit a file in current or another window, or in another frame. File name -is typed in Minibuffer. File completion and history are supported. -@end table -@kindex @kbd{v} -@kindex @kbd{V} -@findex @kbd{:args} -@findex @kbd{:rew} -@kindex @kbd{C-^} -@findex @kbd{:e! []} -@findex @kbd{:e []} -@findex @kbd{:edit []} -@findex @kbd{:edit! []} -@findex @kbd{:q!} -@findex @kbd{:q} -@findex @kbd{:quit} -@findex @kbd{:quit!} -@findex @kbd{:f} -@findex @kbd{:rec} -@findex @kbd{:r} -@findex @kbd{:read} -@findex @kbd{:pre} -@kindex @kbd{ZZ} -@findex @kbd{:wq} -@findex @kbd{:w } -@findex @kbd{:w! } -@findex @kbd{:w >> } -@findex @kbd{:write } -@findex @kbd{:write! } -@findex @kbd{:write >> } -@findex @kbd{:W} -@findex @kbd{:WW} -@findex @kbd{:Write} -@findex @kbd{:WWrite} -@findex @kbd{:WWrite} -@findex @kbd{:x} -@findex @kbd{:x!} -@findex @kbd{:suspend} -@findex @kbd{:stop} -@findex @kbd{:n [ | ]} -@findex @kbd{:cd []} -@findex @kbd{:pwd} - -@node Mapping, Shell Commands, File and Buffer Handling, Commands -@section Mapping - -@cindex keybindings -@cindex keymapping - -@table @kbd -@item :map -Start defining a Vi-style keyboard macro. -For instance, typing -@kbd{:map www} followed by @kbd{:!wc %} and then typing @kbd{C-x )} -will cause @kbd{www} to run wc on -current file (Vi replaces @samp{%} with the current file name). -@item C-x ) -Finish defining a keyboard macro. -In Viper, this command completes the process of defining all keyboard -macros, whether they are Emacs-style or Vi-style. -This is a departure from Vi, needed to allow WYSIWYG mapping of -keyboard macros and to permit the use of function keys and arbitrary Emacs -functions in the macros. -@item :unmap -Deprive of its mappings in Vi state. -@item :map! -Map a macro for Insert state. -@item :unmap! -Deprive of its mapping in Insert state (see @kbd{:unmap}). -@item @@ -In Vi state, -execute the contents of register as a command. -@item @@@@ -In Vi state, -repeat last register command. -@item @@# -In Vi state, -begin keyboard macro. End with @@. This will -put the macro in the proper register. Register will -be automatically downcased. -@xref{Macros and Registers}, for more info. -@item @@! -In Vi state, -yank anonymous macro to register -@item * -In Vi state, -execute anonymous macro (defined by C-x( and C-x )). -@item C-x e -Like @kbd{*}, but works in all Viper states. -@item #g -Execute the last keyboard macro for each line in the region. -@xref{Macros and Registers}, for more info. -@item [ -Show contents of textmarker. -@item ] -Show contents of register. -@end table -@kindex @kbd{]} -@kindex @kbd{[} -@kindex @kbd{#g} -@kindex @kbd{*} -@kindex @kbd{@@!} -@kindex @kbd{@@#} -@kindex @kbd{@@@@} -@kindex @kbd{@@} -@findex @kbd{:unmap } -@findex @kbd{:map } -@findex @kbd{:unmap! } -@findex @kbd{:map! } - -@node Shell Commands, Options, Mapping, Commands -@section Shell Commands - -@cindex % (Current file) - -Note that % is used in Ex commands to mean current file. If you want a % -in your command, it must be escaped as @samp{\%}. -@cindex % (Ex address) -However if % is the -first character, it stands as the address for the whole file. -@cindex # (Previous file) -Similarly, @samp{#} expands to the previous file. The previous file is -the first file in @kbd{:args} listing. This defaults -to the previous file in the VI sense if you have one window.@refill - -@cindex shell commands - -@table @kbd -@item :sh -Execute a subshell in another window -@item :[x,y]! -Execute a shell [on lines x through y; -% is replace by current file, \% is changed to % -@item :[x,y]!! [] -Repeat last shell command [and append ]. -@item :! -Just execute command and display result in a buffer. -@item :!! -Repeat last shell command and append -@item ! -The shell executes , with standard -input the lines described by , -next the standard output replaces those lines -(think of @samp{cb}, @samp{sort}, @samp{nroff}, etc.). -@item !! -Give lines as standard input to the -shell , next let the standard output -replace those lines. -@item :[x,y] w ! -Let lines x to y be standard input for -(notice the between @kbd{w} and @kbd{!}). -@item :
            r ! -Put the output of after the line
            (default current). -@item :
            r -Read the file into the buffer after the line
            (default -current). -@end table -@findex @kbd{:
            r } -@findex @kbd{:
            r !} -@findex @kbd{!} -@findex @kbd{!!} -@findex @kbd{!} -@findex @kbd{:w !} -@findex @kbd{:x,y w !} -@findex @kbd{:!! } -@findex @kbd{:!} -@findex @kbd{:sh} - -@node Options,Emacs Related Commands,Shell Commands,Commands -@section Options - -@cindex Vi options - -@table @kbd -@item autoindent -@itemx ai -@cindex autoindent -autoindent -- In append mode after a the -cursor will move directly below the first -character on the previous line. -This setting affects the current buffer only. -@item autoindent-global -@itemx ai-global -Same as `autoindent', but affects all buffers. -@item noautoindent -@itemx noai -Cancel autoindent. -@item noautoindent-global -@itemx noai-g -Cancel autoindent-global. -@item ignorecase -@itemx ic -@cindex case and searching -ignorecase -- No distinction between upper and lower cases when searching. -@item noignorecase -@itemx noic -Cancel ignorecase. -@item magic -@itemx ma -@cindex literal searching -Regular expressions used in searches; nomagic means no regexps. -@item nomagic -@item noma -Cancel magic. -@item readonly -@itemx ro -@cindex readonly files -readonly -- The file is not to be changed. -If the user attempts to write to this file, confirmation will be requested. -@item noreadonly -@itemx noro -Cancel readonly. -@item shell= -@itemx sh= -@cindex shell -shell -- The program to be used for shell escapes -(default @samp{$SHELL} (default @file{/bin/sh})). -@item shiftwidth= -@itemx sw= -@cindex layout -@cindex shifting text -shiftwidth -- Gives the shiftwidth (default 8 positions). -@item showmatch -@itemx sm -@cindex paren matching -@cindex matching parens -showmatch -- Whenever you append a @kbd{)}, Vi shows -its match if it's on the same page; also with -@kbd{@{} and @kbd{@}}. If there's no match, Vi will beep. -@item noshowmatch -@itemx nosm -Cancel showmatch. -@item tabstop= -@itemx ts= -@cindex changing tab width -@cindex tabbing -tabstop -- The length of a ; warning: this is -only IN the editor, outside of it s have -their normal length (default 8 positions). -This setting affects the current buffer only. -@item tabstop-global -@itemx ts-g -Same as `tabstop', but affects all buffers. -@item wrapmargin= -@itemx wm= -@cindex auto fill -@cindex word wrap -wrapmargin -- In append mode Vi automatically -puts a whenever there is a or -within columns from the right margin. -@item wrapscan -@itemx ws -@cindex searching -wrapscan -- When searching, the end is -considered @samp{stuck} to the begin of the file. -@item nowrapscan -@itemx nows -Cancel wrapscan. -@item :set