XEmacs-Patches November 2017

xemacs-patches@xemacs.org

4 participants
34 discussions

[COMMIT] Default to the system malloc, configure.ac 7 years, 1 month

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed. More recent Linuxes choke on both our gmalloc.c and use of some of the exotic glibc-specific functions. Make it less likely that we use them at configure time. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1510037100 0 # Tue Nov 07 06:45:00 2017 +0000 # Node ID 3130df547aa49dfcff4e7592d62613045471d3aa # Parent 92495f148d48c7e2fdfe53d7180fa14766e2afce 2017-11-07 Aidan Kehoe <kehoea(a)parhasard.net> * configure.ac (XE_COMPLEX_ARG): Document that we default to the system malloc. * configure.ac: Implement this. Use src/gmalloc.c if --with-system-malloc=no was supplied, otherwise use the system malloc. Document that the right next step is to remove src/gmalloc.c, and to use __after_morecore_hook and malloc_set_state if those are available in the system malloc, not otherwise. * configure: Regenerate. diff -r 92495f148d48 -r 3130df547aa4 ChangeLog --- a/ChangeLog Sun Nov 05 22:47:13 2017 +0000 +++ b/ChangeLog Tue Nov 07 06:45:00 2017 +0000 ＠＠ -1,3 +1,16 ＠＠ +2017-11-07 Aidan Kehoe <kehoea(a)parhasard.net> + + * configure.ac (XE_COMPLEX_ARG): + Document that we default to the system malloc. + * configure.ac: + Implement this. Use src/gmalloc.c if --with-system-malloc=no was + supplied, otherwise use the system malloc. + Document that the right next step is to remove src/gmalloc.c, and + to use __after_morecore_hook and malloc_set_state if those are + available in the system malloc, not otherwise. + * configure: + Regenerate. + 2017-03-13 Aidan Kehoe <kehoea(a)parhasard.net> * ChangeLog: diff -r 92495f148d48 -r 3130df547aa4 configure --- a/configure Sun Nov 05 22:47:13 2017 +0000 +++ b/configure Tue Nov 07 06:45:00 2017 +0000 ＠＠ -824,6 +824,7 ＠＠ docdir oldincludedir includedir +runstatedir localstatedir sharedstatedir sysconfdir ＠＠ -1110,6 +1111,7 ＠＠ sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' ＠＠ -1362,6 +1364,15 ＠＠ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ ＠＠ -1499,7 +1510,7 ＠＠ for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir + libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. ＠＠ -1652,6 +1663,7 ＠＠ --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] ＠＠ -1960,8 +1972,7 ＠＠ --with-rel-alloc Enable the relocating allocator. --with-dlmalloc Use Doug Lea's malloc implementation. - --with-system-malloc Use the system malloc, not the one distributed with - XEmacs. + --with-system-malloc Use the system malloc, (default). --with-debug-malloc Use a debugging malloc. --with-pdump Enable portable LISP preloader. --with-dump-in-exec Enable dumping into executable (enabled by default ＠＠ -10266,33 +10277,20 ＠＠ -case "$opsys" in - darwin ) - if test "$with_system_malloc" = "default"; then - system_malloc=yes - with_system_malloc=yes - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Forcing system malloc on Darwin." >&5 -$as_echo "$as_me: WARNING: Forcing system malloc on Darwin." >&2;} - fi ;; -esac - -GNU_MALLOC=yes -if test "$with_dlmalloc" != "no"; then - doug_lea_malloc=yes -else - doug_lea_malloc=no -fi -after_morecore_hook_exists=yes -ac_fn_c_check_func "$LINENO" "malloc_set_state" "ac_cv_func_malloc_set_state" + +if test "$with_dlmalloc" = "yes"; then + ac_fn_c_check_func "$LINENO" "malloc_set_state" "ac_cv_func_malloc_set_state" if test "x$ac_cv_func_malloc_set_state" = xyes; then : - + doug_lea_malloc=yes else doug_lea_malloc=no fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether __after_morecore_hook exists" >&5 + if test "$doug_lea_malloc" = "yes"; then + system_malloc=no + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether __after_morecore_hook exists" >&5 $as_echo_n "checking whether __after_morecore_hook exists... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ extern void (* __after_morecore_hook)(); int ＠＠ -10306,38 +10304,45 ＠＠ if ac_fn_c_try_link "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - after_morecore_hook_exists=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -if test "$system_malloc" = "yes" ; then - GNU_MALLOC=no - GNU_MALLOC_reason=" - - The GNU allocators don't work with this system configuration." -elif test "$with_system_malloc" = "yes" ; then - GNU_MALLOC=no - GNU_MALLOC_reason=" - - User chose not to use GNU allocators." + after_morecore_hook_exists=yes +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + after_morecore_hook_exists=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + GNU_MALLOC=yes + $as_echo "#define DOUG_LEA_MALLOC 1" >>confdefs.h + + if test "$after_morecore_hook_exists" = "no" ; then + GNU_MALLOC_reason=" + - Using Doug Lea's new malloc from the Linux C Library." + $as_echo "#define _NO_MALLOC_WARNING_ 1" >>confdefs.h + + else + GNU_MALLOC_reason=" + - Using Doug Lea's new malloc from the GNU C Library." + fi + else + system_malloc=yes + fi elif test "$with_debug_malloc" = "yes" ; then + debug_malloc=yes + system_malloc=yes GNU_MALLOC=no GNU_MALLOC_reason=" - User chose to use Debugging Malloc." -fi - -if test "$doug_lea_malloc" = "yes" -a "$GNU_MALLOC" = "yes" ; then +elif test "$with_system_malloc" = "no" ; then + GNU_MALLOC=yes GNU_MALLOC_reason=" - - Using Doug Lea's new malloc from the GNU C Library." - $as_echo "#define DOUG_LEA_MALLOC 1" >>confdefs.h - - if test "$after_morecore_hook_exists" = "no" ; then - GNU_MALLOC_reason=" - - Using Doug Lea's new malloc from the Linux C Library." - $as_echo "#define _NO_MALLOC_WARNING_ 1" >>confdefs.h - - fi + - System malloc explicitly overridden." + system_malloc=no +else + GNU_MALLOC=no + GNU_MALLOC_reason=" + - Defaulting to system malloc." + system_malloc=yes fi ＠＠ -11821,7 +11826,7 ＠＠ We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ -#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62)) +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; ＠＠ -11867,7 +11872,7 ＠＠ We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ -#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62)) +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; ＠＠ -11891,7 +11896,7 ＠＠ We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ -#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62)) +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; ＠＠ -11936,7 +11941,7 ＠＠ We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ -#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62)) +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; ＠＠ -11960,7 +11965,7 ＠＠ We can't simply define LARGE_OFF_T to be 9223372036854775807, since some C++ compilers masquerading as C compilers incorrectly reject 9223372036854775807. */ -#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62)) +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 && LARGE_OFF_T % 2147483647 == 1) ? 1 : -1]; ＠＠ -22069,11 +22074,11 ＠＠ -if test "$with_system_malloc" = "yes"; then $as_echo "#define USE_SYSTEM_MALLOC 1" >>confdefs.h - -elif test "$with_debug_malloc" = "yes"; then $as_echo "#define USE_DEBUG_MALLOC 1" >>confdefs.h - - $as_echo "#define USE_SYSTEM_MALLOC 1" >>confdefs.h +if test "$debug_malloc" = "yes"; then $as_echo "#define USE_DEBUG_MALLOC 1" >>confdefs.h + + $as_echo "#define USE_SYSTEM_MALLOC 1" >>confdefs.h + +elif test "$system_malloc" = "yes"; then $as_echo "#define USE_SYSTEM_MALLOC 1" >>confdefs.h fi test "$GCC" = "yes" && $as_echo "#define USE_GCC 1" >>confdefs.h ＠＠ -22182,7 +22187,7 ＠＠ fi echo " libc version: $libc_version" echo " Relocating allocator for buffers: $with_rel_alloc" -echo " GNU version of malloc: ${GNU_MALLOC}${GNU_MALLOC_reason}" +echo " Using gmalloc.c from XEmacs: ${GNU_MALLOC}${GNU_MALLOC_reason}" case "$ld_switch_site" in *nocombreloc*) echo " Linking with \`-z nocombreloc'. - Consider configuring with --with-pdump." ;; diff -r 92495f148d48 -r 3130df547aa4 configure.ac --- a/configure.ac Sun Nov 05 22:47:13 2017 +0000 +++ b/configure.ac Tue Nov 07 06:45:00 2017 +0000 ＠＠ -973,7 +973,7 ＠＠ AS_HELP_STRING([--with-dlmalloc],[Use Doug Lea's malloc implementation.]), [], [with_dlmalloc='default']) XE_MERGED_ARG([system-malloc], - AS_HELP_STRING([--with-system-malloc],[Use the system malloc, not the one distributed with XEmacs.]), + AS_HELP_STRING([--with-system-malloc],[Use the system malloc, (default).]), [], [with_system_malloc='default']) XE_MERGED_ARG([debug-malloc], AS_HELP_STRING([--with-debug-malloc],[Use a debugging malloc.]), ＠＠ -2533,56 +2533,51 ＠＠ dnl Do some misc autoconf-special tests dnl ----------------------------------- -dnl Can we use GNU malloc on this system? -dnl First, configure based-checks. -case "$opsys" in - darwin ) - if test "$with_system_malloc" = "default"; then - system_malloc=yes - with_system_malloc=yes - AC_MSG_WARN([Forcing system malloc on Darwin.]) - fi ;; -esac - -dnl Do the opsystem or machine files prohibit the use of the GNU malloc? -dnl Assume not, until told otherwise. -GNU_MALLOC=yes -if test "$with_dlmalloc" != "no"; then - doug_lea_malloc=yes -else - doug_lea_malloc=no -fi -after_morecore_hook_exists=yes -AC_CHECK_FUNC(malloc_set_state, ,doug_lea_malloc=no) -AC_MSG_CHECKING(whether __after_morecore_hook exists) -AC_LINK_IFELSE([AC_LANG_PROGRAM([extern void (* __after_morecore_hook)();], - [__after_morecore_hook = 0])], - [AC_MSG_RESULT(yes)], - [AC_MSG_RESULT(no) - after_morecore_hook_exists=no]) -if test "$system_malloc" = "yes" ; then - GNU_MALLOC=no - GNU_MALLOC_reason=" - - The GNU allocators don't work with this system configuration." -elif test "$with_system_malloc" = "yes" ; then - GNU_MALLOC=no - GNU_MALLOC_reason=" - - User chose not to use GNU allocators." +dnl Default to the system malloc. The right thing here is to remove +dnl src/gmalloc.c entirely, and just autoconfiscate and use malloc_set_state +dnl and __after_morecore_hook and if they are available, otherwise no. But +dnl this is a reasonable first step. + +if test "$with_dlmalloc" = "yes"; then + AC_CHECK_FUNC(malloc_set_state, doug_lea_malloc=yes,doug_lea_malloc=no) + if test "$doug_lea_malloc" = "yes"; then + system_malloc=no + AC_MSG_CHECKING(whether __after_morecore_hook exists) + AC_LINK_IFELSE([AC_LANG_PROGRAM([extern void (* __after_morecore_hook)();], + [__after_morecore_hook = 0])], + [AC_MSG_RESULT(yes) + after_morecore_hook_exists=yes], + [AC_MSG_RESULT(no) + after_morecore_hook_exists=no]) + GNU_MALLOC=yes + AC_DEFINE(DOUG_LEA_MALLOC) + if test "$after_morecore_hook_exists" = "no" ; then + GNU_MALLOC_reason=" + - Using Doug Lea's new malloc from the Linux C Library." + AC_DEFINE(_NO_MALLOC_WARNING_) + else + GNU_MALLOC_reason=" + - Using Doug Lea's new malloc from the GNU C Library." + fi + else + system_malloc=yes + fi elif test "$with_debug_malloc" = "yes" ; then + debug_malloc=yes + system_malloc=yes GNU_MALLOC=no GNU_MALLOC_reason=" - User chose to use Debugging Malloc." -fi - -if test "$doug_lea_malloc" = "yes" -a "$GNU_MALLOC" = "yes" ; then +elif test "$with_system_malloc" = "no" ; then + GNU_MALLOC=yes GNU_MALLOC_reason=" - - Using Doug Lea's new malloc from the GNU C Library." - AC_DEFINE(DOUG_LEA_MALLOC) - if test "$after_morecore_hook_exists" = "no" ; then - GNU_MALLOC_reason=" - - Using Doug Lea's new malloc from the Linux C Library." - AC_DEFINE(_NO_MALLOC_WARNING_) - fi + - System malloc explicitly overridden." + system_malloc=no +else + GNU_MALLOC=no + GNU_MALLOC_reason=" + - Defaulting to system malloc." + system_malloc=yes fi dnl #### mcheck is broken in all versions of Linux libc and glibc. ＠＠ -5830,9 +5825,9 ＠＠ dnl so that the user gets immediate feedback on the results of the dnl autodetection. -if test "$with_system_malloc" = "yes"; then AC_DEFINE(USE_SYSTEM_MALLOC) -elif test "$with_debug_malloc" = "yes"; then AC_DEFINE(USE_DEBUG_MALLOC) - AC_DEFINE(USE_SYSTEM_MALLOC) +if test "$debug_malloc" = "yes"; then AC_DEFINE(USE_DEBUG_MALLOC) + AC_DEFINE(USE_SYSTEM_MALLOC) +elif test "$system_malloc" = "yes"; then AC_DEFINE(USE_SYSTEM_MALLOC) fi test "$GCC" = "yes" && AC_DEFINE(USE_GCC) test "$XEMACS_CC_GPP" = "yes" && AC_DEFINE(USE_GPLUSPLUS) ＠＠ -5931,7 +5926,7 ＠＠ fi echo " libc version: $libc_version" echo " Relocating allocator for buffers: $with_rel_alloc" -echo " GNU version of malloc: ${GNU_MALLOC}${GNU_MALLOC_reason}" +echo " Using gmalloc.c from XEmacs: ${GNU_MALLOC}${GNU_MALLOC_reason}" case "$ld_switch_site" in *nocombreloc*) echo " Linking with \`-z nocombreloc'. - Consider configuring with --with-pdump." ;; -- ‘As I sat looking up at the Guinness ad, I could never figure out / How your man stayed up on the surfboard after forty pints of stout’ (C. Moore)

1 participants
0 comments

[COMMIT] Remove the last of the unified Big5 charset from the C code. 7 years, 1 month

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1509922033 0 # Sun Nov 05 22:47:13 2017 +0000 # Node ID 92495f148d48c7e2fdfe53d7180fa14766e2afce # Parent 51ad3b1a1b9288836a9efba679cc7141495c9e35 Remove the last of the unified Big5 charset from the C code. src/ChangeLog addition: 2017-11-05 Aidan Kehoe <kehoea(a)parhasard.net> * lisp.h: * fontcolor-xlike-inc.c: Remove the last references to the unified Vcharset_chinese_big5 charset, especially relevant with XFT. Thank you Stephen Turnbull and Raymond Toy! diff -r 51ad3b1a1b92 -r 92495f148d48 src/ChangeLog --- a/src/ChangeLog Thu Nov 02 21:38:04 2017 +0000 +++ b/src/ChangeLog Sun Nov 05 22:47:13 2017 +0000 ＠＠ -4,6 +4,14 ＠＠ Revert part of 417c790fd731, have this function return a list, never a cons. Thank you Raymond Toy! +2017-11-05 Aidan Kehoe <kehoea(a)parhasard.net> + + * lisp.h: + * fontcolor-xlike-inc.c: + Remove the last references to the unified Vcharset_chinese_big5 + charset, especially relevant with XFT. Thank you Stephen Turnbull + and Raymond Toy! + 2017-10-28 Aidan Kehoe <kehoea(a)parhasard.net> * file-coding.c (handle_possible_error_octet): diff -r 51ad3b1a1b92 -r 92495f148d48 src/fontcolor-xlike-inc.c --- a/src/fontcolor-xlike-inc.c Thu Nov 02 21:38:04 2017 +0000 +++ b/src/fontcolor-xlike-inc.c Sun Nov 05 22:47:13 2017 +0000 ＠＠ -389,13 +389,9 ＠＠ { &Vcharset_hebrew_iso8859_8, "Hebrew", "he" }, /* #### probably close enough for Ukraine? */ { &Vcharset_cyrillic_iso8859_5, "Russian", "ru" }, -#ifdef UNICODE_INTERNAL - { &Vcharset_chinese_big5, "traditional Chinese", "zh-tw" }, -#else /* #### these probably are not quite right */ { &Vcharset_chinese_big5_1, "traditional Chinese", "zh-tw" }, { &Vcharset_chinese_big5_2, "traditional Chinese", "zh-tw" }, -#endif { NULL, NULL, NULL } }; diff -r 51ad3b1a1b92 -r 92495f148d48 src/lisp.h --- a/src/lisp.h Thu Nov 02 21:38:04 2017 +0000 +++ b/src/lisp.h Sun Nov 05 22:47:13 2017 +0000 ＠＠ -5792,12 +5792,10 ＠＠ extern Lisp_Object Vcharset_japanese_jisx0212; extern Lisp_Object Vcharset_chinese_cns11643_1; extern Lisp_Object Vcharset_chinese_cns11643_2; -#ifdef UNICODE_INTERNAL -extern Lisp_Object Vcharset_chinese_big5; -extern Lisp_Object Vcharset_japanese_shift_jis; -#else extern Lisp_Object Vcharset_chinese_big5_1; extern Lisp_Object Vcharset_chinese_big5_2; +#ifdef UNICODE_INTERNAL +extern Lisp_Object Vcharset_japanese_shift_jis; #endif /* UNICODE_INTERNAL */ extern Lisp_Object Vcharset_composite; #endif /* MULE */ -- ‘As I sat looking up at the Guinness ad, I could never figure out / How your man stayed up on the surfboard after forty pints of stout’ (C. Moore)

1 participants
0 comments

[COMMIT edit-utils] Make `manual-entry' run asynchronously, increasing responsiveness. 7 years, 1 month

Aidan Kehoe

APPROVE COMMIT edit-utils NOTE: This patch has been committed # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1509893890 0 # Sun Nov 05 14:58:10 2017 +0000 # Node ID 759a527caec38f15f925a523bfdd8d5918532fac # Parent d71ad4063ecb9ad9015342592e7ad367759c7e3d Make `manual-entry' run asynchronously, increasing responsiveness. ChangeLog addition: 2017-11-05 Aidan Kehoe <kehoea(a)parhasard.net> * man.el: * man.el (Manual-switches): * man.el (Manual-mode-hook): * man.el (man-italic): * man.el (man-bold): * man.el (man-heading): * man.el (man-xref): * man.el (Manual-mode-map): * man.el (Manual-use-rosetta-man): Removed. * man.el (Manual-mode-xref-map): New. * man.el (Manual-unicode-to-char): New. * man.el (Manual-process-filter): New. * man.el (This function does four broad things): New. * man.el (manual-entry): * man.el (Manual-boldface-section-titles): New. * man.el (Manual-mode): * man.el (Manual-mode-and-display-buffer): New. * man.el (Manual-last-page): * man.el (Manual-delete-char): Removed. * man.el (Manual-nuke-nroff-bs): * man.el (Manual-nuke-nroff-bs-footers): * man.el (Manual-mouseify-xrefs): * man.el (Manual-follow-xref): * man.el (Manual-popup-menu): Extensive changes to this file. 1. Call `man' asynchronously, and display the output immediately as it starts to arrive. This gives a far more pleasant interactive experience with big man pages, in that XEmacs never becomes unresponsive dealing with a synchronous process output. 2. For those accented, punctuation and other non-ASCII characters that groff attempts to display using overstriking with ASCII characters, use mule characters instead, rather than just deleting them as the old code did. 3. Don't treat text like KSH(1) at the beginning and end of the file as a mouseable cross-reference, that is never the intention with it. 4. Fix problems with the interaction of Manual-mode-map and view-mode-minor-map, and make the implementation of Manual-last-page actually work, so l switches to another man page as is documented. 5. Make clickable hyperlinks respond to button1, return. 6. If there are no entries to show in the mode popup menu, give a menu showing that instead of erroring. Use #'menu-split-long-menu so the menu for big man pages isn't totally unwieldy. 7. Make `man-bold', `man-italic' inherit from the corresponding XEmacs faces, so they are distinctive by default. 8. Remove all mention of RosettaMan, now called PolyglotMan. This file doesn't actually work with it, and with an asynchronous implementation the speed benefit is not as important. diff -r d71ad4063ecb -r 759a527caec3 ChangeLog --- a/ChangeLog Mon Oct 12 09:46:24 2015 +0200 +++ b/ChangeLog Sun Nov 05 14:58:10 2017 +0000 ＠＠ -1,3 +1,55 ＠＠ +2017-11-05 Aidan Kehoe <kehoea(a)parhasard.net> + + * man.el: + * man.el (Manual-switches): + * man.el (Manual-mode-hook): + * man.el (man-italic): + * man.el (man-bold): + * man.el (man-heading): + * man.el (man-xref): + * man.el (Manual-mode-map): + * man.el (Manual-use-rosetta-man): Removed. + * man.el (Manual-mode-xref-map): New. + * man.el (Manual-unicode-to-char): New. + * man.el (Manual-process-filter): New. + * man.el (This function does four broad things): New. + * man.el (manual-entry): + * man.el (Manual-boldface-section-titles): New. + * man.el (Manual-mode): + * man.el (Manual-mode-and-display-buffer): New. + * man.el (Manual-last-page): + * man.el (Manual-delete-char): Removed. + * man.el (Manual-nuke-nroff-bs): + * man.el (Manual-nuke-nroff-bs-footers): + * man.el (Manual-mouseify-xrefs): + * man.el (Manual-follow-xref): + * man.el (Manual-popup-menu): + Extensive changes to this file. + 1. Call `man' asynchronously, and display the output immediately + as it starts to arrive. This gives a far more pleasant interactive + experience with big man pages, in that XEmacs never becomes + unresponsive dealing with a synchronous process output. + 2. For those accented, punctuation and other non-ASCII characters + that groff attempts to display using overstriking with ASCII + characters, use mule characters instead, rather than just deleting + them as the old code did. + 3. Don't treat text like KSH(1) at the beginning and end of the + file as a mouseable cross-reference, that is never the intention + with it. + 4. Fix problems with the interaction of Manual-mode-map and + view-mode-minor-map, and make the implementation of + Manual-last-page actually work, so l switches to another man page + as is documented. + 5. Make clickable hyperlinks respond to button1, return. + 6. If there are no entries to show in the mode popup menu, give a + menu showing that instead of erroring. Use #'menu-split-long-menu + so the menu for big man pages isn't totally unwieldy. + 7. Make `man-bold', `man-italic' inherit from the corresponding + XEmacs faces, so they are distinctive by default. + 8. Remove all mention of RosettaMan, now called PolyglotMan. This + file doesn't actually work with it, and with an asynchronous + implementation the speed benefit is not as important. + 2015-10-12 Norbert Koch <viteno(a)xemacs.org> * Makefile (VERSION): XEmacs package 2.57 released. diff -r d71ad4063ecb -r 759a527caec3 man.el --- a/man.el Mon Oct 12 09:46:24 2015 +0200 +++ b/man.el Sun Nov 05 14:58:10 2017 +0000 ＠＠ -50,13 +50,13 ＠＠ :group 'man) (defcustom Manual-switches nil - "List of switches to the man program." + "*List of switches to the man program." :type '(choice (const :tag "none" nil) (repeat (string :tag "switch"))) :group 'man) (defcustom Manual-mode-hook nil - "Function or functions run on entry to Manual-mode." + "*Function or functions run on entry to Manual-mode." :type 'hook :group 'man) ＠＠ -76,242 +76,686 ＠＠ :type 'boolean :group 'man) -;;Here is information on RosettaMan, from Neal.Becker(a)comsat.com (Neal Becker): - -;;RosettaMan is a filter for UNIX manual pages. It takes as input man -;;pages formatted for a variety of UNIX flavors (not [tn]roff source) -;;and produces as output a variety of file formats. Currently -;;RosettaMan accepts man pages as formatted by the following flavors of -;;UNIX: Hewlett-Packard HP-UX, AT&T System V, SunOS, Sun Solaris, OSF/1, -;;DEC Ultrix, SGI IRIX, Linux, SCO; and produces output for the following -;;formats: printable ASCII only (stripping page headers and footers), -;;section and subsection headers only, TkMan, [tn]roff, Ensemble, RTF, -;;SGML (soon--I finally found a DTD), HTML, MIME, LaTeX, LaTeX 2e, Perl 5's pod. - -;;RosettaMan improves on other man page filters in several ways: (1) its -;;analysis recognizes the structural pieces of man pages, enabling high -;;quality output, (2) its modular structure permits easy augmentation of -;;output formats, (3) it accepts man pages formatted with the varient -;;macros of many different flavors of UNIX, and (4) it doesn't require -;;modification or cooperation with any other program. - -;;RosettaMan is a rewrite of TkMan's man page filter, called bs2tk. (If -;;you haven't heard about TkMan, a hypertext man page browser, you -;;should grab it via anonymous ftp from ftp.cs.berkeley.edu: -;;/ucb/people/phelps/tkman.tar.Z.) Whereas bs2tk generated output only for -;;TkMan, RosettaMan generalizes the process so that the analysis can be -;;leveraged to new output formats. A single analysis engine recognizes -;;section heads, subsection heads, body text, lists, references to other -;;man pages, boldface, italics, bold italics, special characters (like -;;bullets), tables (to a degree) and strips out page headers and -;;footers. The engine sends signals to the selected output functions so -;;that an enhancement in the engine improves the quality of output of -;;all of them. Output format functions are easy to add, and thus far -;;average about about 75 lines of C code each. - - - -;;*** NOTES ON CURRENT VERSION *** - -;;Help! I'm looking for people to help with the following projects. -;;\(1) Better RTF output format. The current one works, but could be -;;made better. (2) Roff macros that produce text that is easily -;;parsable. RosettaMan handles a great variety, but some things, like -;;H-P's tables, are intractable. If you write an output format or -;;otherwise improve RosettaMan, please send in your code so that I may -;;share the wealth in future releases. - -;;This version can try to identify tables (turn this on with the -T -;;switch) by looking for lines with a large amount of interword spacing, -;;reasoning that this is space between columns of a table. This -;;heuristic doesn't always work and sometimes misidentifies ordinary -;;text as tables. In general I think it is impossible to perfectly -;;identify tables from nroff formatted text. However, I do think the -;;heuristics can be tuned, so if you have a collection of manual pages -;;with unrecognized tables, send me the lot, in formatted form (i.e., -;;after formatting with nroff -man), and uuencode them to preserve the -;;control characters. Better, if you can think of heuristics that -;;distinguish tables from ordinary text, I'd like to hear them. - -;;Notes for HTML consumers: This filter does real (heuristic) -;;parsing--no <PRE>! Man page references are turned into hypertext links. - -(defcustom Manual-use-rosetta-man (locate-file "rman" exec-path) - "If non-nil, use RosettaMan (rman) to filter man pages. -This makes man-page cleanup virtually instantaneous, instead of -potentially taking a long time." - :type '(choice (symbol :tag "Do not use Rosettaman" nil) - (file :tag "RosettaMan Programm")) - :group 'man) - (defface man-italic '((t (:italic t))) "Manual italics face" :group 'man) +(set-face-parent 'man-italic 'italic nil '(default)) (defface man-bold '((t (:bold t))) "Manual bold face" :group 'man) +(set-face-parent 'man-bold 'bold nil '(default)) (defface man-heading '((t (:bold t))) "Manual headings face" :group 'man) +(set-face-parent 'man-heading 'bold nil '(default)) (defface man-xref '((t (:underline t))) - "Manual xrefs face" + "Manual cross-reference face" :group 'man) - +(set-face-parent 'man-xref 'underline nil '(default)) (defvar Manual-mode-map (let ((m (make-sparse-keymap))) (set-keymap-name m 'Manual-mode-map) + ;; See the entertainment in #'Manual-mode-and-display-buffer about this + ;; key binding: (define-key m "l" 'Manual-last-page) (define-key m 'button2 'Manual-follow-xref) (define-key m 'button3 'Manual-popup-menu) m)) +(defvar Manual-mode-xref-map + (let ((m (make-sparse-keymap))) + (set-keymap-parents m Manual-mode-map) + (define-key m "\C-m" 'Manual-follow-xref) + (define-key m 'button1 'Manual-follow-xref) + m)) + (defvar Manual-mode-syntax-table nil "Syntax table used in Manual-mode buffers") -(if Manual-mode-syntax-table - () +(unless Manual-mode-syntax-table (setq Manual-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?: "_" Manual-mode-syntax-table) (modify-syntax-entry ?+ "." Manual-mode-syntax-table) (modify-syntax-entry ?- "." Manual-mode-syntax-table) (modify-syntax-entry ?/ "." Manual-mode-syntax-table) - (modify-syntax-entry ?* "." Manual-mode-syntax-table) - ) + (modify-syntax-entry ?* "." Manual-mode-syntax-table)) + +(defun Manual-unicode-to-char (fixnum) + "Limited compatibility version of `unicode-to-char'. + +Falls back to `decode-char' with a `ucs' first argument if that is available; +otherwise uses those Greek and CJK characters available within every Mule +emacs to represent typographical and other non-ASCII characters +emulated by troff using backspace composition. + +Note that several of the characters needed have no equivalent in those XEmacs +versions where any Unicode support is provided by the mule-ucs package." + (let (acons) + (cond + ((< fixnum #x100) (int-char fixnum)) + ((and (fboundp 'decode-char) (decode-char 'ucs fixnum))) + ((and + (setq acons (assq fixnum '((#x0398 greek-iso8859-7 72) + (#x03a6 greek-iso8859-7 86) + (#x03a7 greek-iso8859-7 87) + (#x03b6 greek-iso8859-7 102) + (#x03b8 greek-iso8859-7 104) + (#x03bb greek-iso8859-7 107) + (#x03be greek-iso8859-7 110) + (#x03c0 greek-iso8859-7 112) + (#x03c3 greek-iso8859-7 115) + (#x03c4 greek-iso8859-7 116) + (#x03c8 greek-iso8859-7 120) + (#x2020 japanese-jisx0208 34 119) + (#x2021 japanese-jisx0208 34 120) + (#x2022 chinese-big5-1 33 38) + (#x2200 japanese-jisx0208 34 79) + (#x2191 japanese-jisx0208 34 44) + (#x2193 japanese-jisx0208 34 45) + (#x222b japanese-jisx0208 34 105) + (#x222b japanese-jisx0208 34 105) + (#x2286 japanese-jisx0208 34 60) + (#x2286 japanese-jisx0208 34 60) + (#x2287 japanese-jisx0208 34 61) + (#x2287 japanese-jisx0208 34 61) + (#x2295 chinese-cns11643-1 34 83) + (#x0444 cyrillic-iso8859-5 100)))) + (featurep 'mule) + (apply #'make-char (cdr acons)))) + ;; For the last no-mule user in the world, at least transform bullets to + ;; something readable: + ((cdr (assq fixnum + (load-time-value + (acons #x2022 (let ((extent (make-extent 0 1 "o"))) + (set-extent-face extent 'man-bold) + (set-extent-property extent 'duplicable t) + (set-extent-property extent 'unique t) + (extent-object extent)) nil)))))))) + +(defun Manual-process-filter (process string &optional flush) + "Handle process output from PROCESS, started from `manual-entry'. + +STRING reflects the most recent output from PROCESS. FLUSH, if supplied, +indicates thaat `Manual-process-filter' should not save any data from STRING +for processing on its next call. + +This function does four broad things: + +1. It interprets the tty sequences for underline, removes them, and applies + the `man-italic' face to the associated text. +2. It interprets the tty sequences for overstriking with the same character, + removes them, and applies the `man-bold' face to the associated text. +3. It interprets other groff sequences with backspace to construct accented + characters and other non-ASCII characters, and transforms them to the + appropriate XEmacs character. +4. It sets up cross-references to other man pages, which can be followed by + right clicking or by hitting `return'. + +In addition, the first time it is called for a given PROCESS, it tells XEmacs +to display the buffer; see `Manual-buffer-view-mode'." + (let* ((buffer (process-buffer process)) + (process-mark (process-mark process)) + (length (length string)) + (last 0) + position character-before character-after stashed extent lookup + extent-start-position) + (defvar #123456=#:Manual-stashed-strings nil) + (with-current-buffer buffer + (save-excursion + (macrolet + ;; The first four of these are macros rather than inline labels + ;; because the macro approach will actually lead to inline code on + ;; 21.4, whereas code with #'labels won't. + ((character-after (position) + `((lambda (position) + (incf position) + (if (< position length) (aref string position))) ,position)) + (character-before (position) + `((lambda (position) + (decf position) + (if (>= position 0) + (if (< position length) + (aref string position)) + (char-after (+ (point) position)))) ,position)) + (stash-string (string) + ;; This was implemented initially as a property of + ;; PROCESS. Unfortunately this doesn't work on 21.4. Then I + ;; implemented it as a buffer-local variable; unfortunately + ;; this doesn't work for the first stashed string, we have a + ;; longstanding bug in the first use of buffer local + ;; variables. An alist is cheap and portable. + `(setq #123456# (cons (cons process ,string) + (delete* process #123456# :key #'car)))) + (get-stashed-string () + `(prog1 + (cdr (assq process #123456#)) + (setq #123456# (delete* process #123456# :key #'car)))) + (adjust-or-make-extent (face-name extent-end-position + fail-early-unless) + `(if (and ,fail-early-unless + (setf extent (extent-at extent-start-position + buffer 'face nil + 'before)) + (eq ,face-name (extent-face extent))) + (prog1 extent (setf (extent-end-position extent) + ,extent-end-position)) + (prog1 (setf extent (make-extent extent-start-position + ,extent-end-position + buffer)) + (setf (extent-face extent) ,face-name)))) + (cond-with-handlers (&rest clauses &environment env) + (cons 'cond + (loop for clause in clauses + collect (if (assq (car-safe clause) env) + (macroexpand clause env) + clause)))) + (try-two-character-sequence (first second output) + `((and (eql character-before ,first) (eql character-after + ,second) + (load-time-value (Manual-unicode-to-char ,output))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert (load-time-value (Manual-unicode-to-char ,output))) + (incf position 2) + (setf last position))) + (try-two-characters-with-table (first alist) + `((and (eql character-before ,first) character-after + (setf lookup + (assq character-after + (load-time-value + (mapcan #'(lambda (cons) + (let ((character + (Manual-unicode-to-char + (cdr cons)))) + (if character + `((,(car cons) . + ,character))))) + ,alist))))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert (cdr lookup)) + (incf position 2) + (setf last position))) + (try-compose-map (first map) + `((and (eql character-before ,first) character-after + (fboundp ',map) + (setf lookup (lookup-key ',map character-after))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert + (if (consp (aref lookup 0)) + (car (aref lookup 0)) + (event-to-character + (make-event 'key-press `(key ,(aref lookup 0))) + nil nil t))) + (incf position 2) + (setf last position)))) + (if (marker-buffer process-mark) + (goto-char process-mark) + (set-marker process-mark (point) buffer)) + (when (eql (point) (point-min)) + (add-one-shot-hook + 'pre-idle-hook ;; This is more responsive for me than + ;; #'enqueue-eval-event. + `(lambda () (Manual-mode-and-display-buffer ,buffer)))) + (when (setf stashed (get-stashed-string)) + (let ((position 2)) + (symbol-macrolet ((do-not-end-with + ;; These make it more likely we would have + ;; to stash the end of the concatted + ;; string. + '(?\b ?_ ?| ?+))) + (while (and (< position length) + (or (member* (aref string position) + do-not-end-with) + (member* (aref string (1- position)) + do-not-end-with))) + (incf position))) + (setf position (min (1+ position) length)) + (Manual-process-filter process + (concat stashed + (substring string 0 position)) + flush) + (setf last (- position (length + (setf stashed (get-stashed-string))))) + (goto-char process-mark))) + (setf buffer-read-only nil) + (while (setf position (position ?\b string :start last :end length)) + (cond-with-handlers + ((eql (setf character-before (character-before position)) + (setf character-after (character-after position))) + ;; Bold, implemented in the TTY as overstriking with the same + ;; character. + (insert (substring string last position)) + (setf extent-start-position (1- (point))) + (incf position 2) + (while (and (< position length) + (eql (setf character-before (aref string position)) + (setf character-after + (character-after (1+ position)))) + (eql (aref string (1+ position)) ?\b)) + (insert character-before) + (incf position 3)) + ;; We don't have extra code to handle overstriking multiple + ;; times; that's fine, the loop with #'position above does + ;; that implicitly. + (setf extent (adjust-or-make-extent + 'man-bold (point) + (eql (character-before + (- position + (* 3 (- (point) extent-start-position)) + 1)) + ?\b)) + last position)) + ((and (eql character-before ?_) character-after) + ;; Underline; treat as italic + (insert (substring string last position)) + ;; We do insert-and-delete rather than substring the inserted + ;; string because that interacts better with stashed strings. + (delete-region (1- (point)) (point)) + (setf extent-start-position (point)) + (insert character-after) + (incf position 2) + (while (and (< position length) + (eql (aref string position) ?_) + (eql (character-after position) ?\b) + (setf character-after + (character-after (1+ position)))) + (insert character-after) + (incf position 3)) + ;; Manual-nuke-nroff-bs, below, worries about the ambiguity + ;; of _\b_. This code treats it as bold--it usually is + ;; bold--unless it is preceded immediately by italic + ;; characters. This gives reasonable results. + (setf extent (adjust-or-make-extent + 'man-italic (point) + (eql (character-before + (- position + (* 3 (- (point) extent-start-position)) + 1)) + ?\b)) + last position)) + ((and (eql character-after ?\b) character-before + (eql character-before (character-after (1+ position)))) + ;; Bolded CJK double-width characters. + (insert (substring string last position)) + (setf extent-start-position (1- (point))) + (setf extent (adjust-or-make-extent + 'man-italic (point) + (eql (character-before + (- position + (* 3 (- (point) extent-start-position)) + 1)) + ?\b)) + position (+ position 3) + last position)) + ;; From here onwards we're dealing with attempts of groff + ;; -mtty-char to create non-ASCII characters using ASCII + ;; primitives and overstriking. If troff has been invoked + ;; using -Tutf8 and if we understand UTF-8 none of the below + ;; will apply, and the code will never execute, absent corrupt + ;; data, because the first three clauses will have matched, so + ;; its performance impact is minimal. + (try-two-character-sequence ?+ ?o #x2022) ;; Bullet + (try-two-characters-with-table + ?| '((?^ . #x2191) ;; Uparrow + (?v . #x2193) ;; Downarrow + (?- . #x2020) ;; Dagger + (?= . #x2021) ;; Double dagger + (?u . #x03C8) ;; Psi + (?o . #x0444))) ;; Phi; use lowercase CYRILLIC SMALL + ;; LETTER EF, to force a glyph without a + ;; loop. + (try-compose-map ?\" compose-diaeresis-map) + (try-two-character-sequence ?\" ?_ #x030b) + (try-compose-map ?' compose-acute-map) + (try-two-character-sequence ?' ?\` #x0306) + ((and (eql character-before ?') + (eql character-after ?,) + (eql (character-after (1+ position)) ?\b) + (eql (character-after (+ position 2)) ?I) + (load-time-value (Manual-unicode-to-char #x222b))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert (load-time-value (Manual-unicode-to-char #x222b))) + (incf position 4) + (setf last position)) + (try-compose-map ?^ compose-circumflex-map) + (try-compose-map ?` compose-grave-map) + ((and (eql character-before ?`) + (eql character-after ?') + (eql (character-after (+ position 1)) ?\b) + (eql (character-after (+ position 2)) ?o)) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert ?\xf0) ;; eth + (incf position 4) + (setf last position)) + (try-compose-map ?~ compose-tilde-map) + (try-two-characters-with-table + ?~ '((?_ . #xAC) ;; Logical not + (?t . #x03c4))) ;; Tau + (try-compose-map ?v compose-caron-map) + (try-compose-map ?/ compose-stroke-map) + (try-two-characters-with-table + ?/ '((?E . #x2209) ;; NOT AN ELEMENT OF + (?c . #xa2))) ;; CENT SIGN + (try-two-characters-with-table + ?, '((?C . #x03b6) ;; Zeta + (?E . #x03be) ;; GREEK SMALL LETTER XI + (?c . #xe7) ;; LATIN SMALL LETTER C WITH CEDILLA + (?f . #x0192) ;; LATIN SMALL LETTER F WITH HOOK + (?i . #xa1) ;; INVERTED EXCLAMATION MARK + (?u . #xb5))) ;; MICRO SIGN + (try-two-characters-with-table + ?- '((?0 . #x03B8) ;; GREEK SMALL LETTER THETA + (?D . #xd0) ;; LATIN CAPITAL LETTER ETH + (?L . #xa3) ;; POUND SIGN (sterling, that is) + (?O . #x0398) ;; GREEK CAPITAL LETTER THETA + (?V . #x2200) ;; FOR ALL + (?n . #x03C0) ;; GREEK SMALL LETTER PI + (?o . #x03C3) ;; GREEK SMALL LETTER SIGMA + (?w . #x03D6))) ;; GREEK PI SYMBOL + (try-two-characters-with-table + ?o '((?A . #xc5) ;; LATIN CAPITAL LETTER A WITH RING ABOVE + (?a . #xea) ;; LATIN SMALL LETTER E WITH CIRCUMFLEX + (?x . #xa4))) ;; CURRENCY SIGN + (try-two-characters-with-table + ?= '((?Y . #xa5) ;; YEN SIGN + (?v . #x21d3) ;; DOWNWARDS DOUBLE ARROW + (?^ . #x21d1))) ;; UPWARDS DOUBLE ARROW + ((and (eql character-before ?=) + (eql character-after ?_) + (eql (character-before (1- position)) ?$) + (load-time-value (Manual-unicode-to-char #x2286))) + (insert (substring string last position)) + (delete-region (- (point) 2) (point)) + ;; Reflex subset + (insert (load-time-value (Manual-unicode-to-char #x2286))) + (incf position 2) + (setf last position)) + ((and (eql character-before ?=) + (eql character-after ?_) + (eql (character-after (1+ position)) ?$) + (load-time-value (Manual-unicode-to-char #x2287))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + ;; Reflex superset + (insert (load-time-value (Manual-unicode-to-char #x2287))) + (incf position 3) + (setf last position)) + (try-two-character-sequence ?p ?b #xfe) + (try-two-characters-with-table + ?I '((?b . #xde) + (?O . #x03a6) + (?Y . #x03a7))) + (try-two-character-sequence ?> ?\\ #x03bb) ;; lambda + (try-two-characters-with-table + ?O '((?x . #x2297) ;; CIRCLED TIMES + (?+ . #x2295))) ;; CIRCLED PLUS + ((and (>= (+ position 3) length) (not flush)) + (stash-string (substring string position)) + (setf length position)) + ;; Let the clean-up below insert the trailing piece of the + ;; string. + (t + (incf position) + (insert (substring string last position)) + (setf last position)))) + (if (< last length) (insert (substring string last length))) + (goto-char process-mark) + (if (member "-k" + ;; #'process-command doesn't cons, to my surprise, no + ;; point saving whether this is an apropos or real + ;; man(1) call. + (process-command process)) + (progn + (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t) + (forward-char -2) + (delete-region (point) (1- (point)))) + (goto-char process-mark)) + (if (eql (point) (point-min)) + (progn + ;; Treat the first line as a heading. + (set-extent-face (make-extent (point) (point-at-eol)) + 'man-heading) + ;; Some of the Perl module man pages have ridiculously long + ;; titles, which groff chokes on for the title line, + ;; emitting backspaces with the intention of rubbing out an + ;; already-printed character. Handle that. + (while (re-search-forward "[^\b]\b" (point-at-eol) t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Skip the top line of manual pages, but not apropos + ;; listings. + (forward-line 1)) + ;; Zap ESC7, ESC8, and ESC9 + ;; This is for Sun man pages like "man 1 csh" + (backward-char) + (while (re-search-forward "\e[789]" nil t) + (delete-region (match-beginning 0) (point))) + (goto-char process-mark))) + (if (position ?\) string :end length) ;; Can a cross-reference have + ;; ended in the text we just + ;; inserted? + (Manual-mouseify-xrefs (point) (point-max))) + (setf (marker-position process-mark) (point-max) + buffer-read-only t + (buffer-modified-p buffer) nil)))))) + +(defun Manual-boldface-section-titles () + "Mark subsection header lines bold in the current buffer. + +These are recognized heuristically as text in the first column following two +newlines, and followed by indented text on the next line. + +This function also handles the title lines of meta-manpages created with +troff's .so command, and extra backspaces that may have been inserted into the +final title line." + (labels ((delete-extent-mapper (extent ignore) (delete-extent extent))) + ;; + ;; Turn subsection header lines into bold. The first line is bolded + ;; separately in `Manual-process-filter'. + (goto-char (point-min)) + ;; Regexp to match section headers changed to match a non-indented + ;; line preceded by a blank line and followed by an indented line. + ;; This seems to work ok for manual pages but gives better results + ;; with other nroff'd files + ;; + ;; Most systems have indented text the next line after a section + ;; header, but some (Tru64) have an extra newline in between. + (while (re-search-forward "\n\n\$[^ \t\n].*\$\n\n?[ \t]+[^ \t\n]" nil + t) + (goto-char (match-end 1)) + ;; section headings are often highlighted by the man page + ;; author, but other parts of the man page are highlighted the + ;; same way, so make our lisp-deduced section header + ;; highlighting higher priority. This also avoids having + ;; section headers being _random_ly highlighted alternately by + ;; either man-heading or man-bold, which sure looks like a bug. + ;; And for user interface issues, if it looks like a bug, it + ;; _is_ a bug. + (set-extent-properties (make-extent (match-beginning 1) + (match-end 1)) + '(face man-heading priority 1)) + (forward-line 1)) + (goto-char (point-min)) + ;; If this man page is a meta-manpage created with .so (cf. zshall(1)), + ;; the individual sub-manpages have first-lines included that + ;; Manual-mouseify-xref has made into cross-references. These should + ;; really be treated as first lines and given the heading face. + (while (re-search-forward "\n\n\n\n[A-Z0-9_.:]+([0-9][^)]*)[^\n]*\n\n\n\n" + nil t) + (map-extents #'delete-extent-mapper nil (match-beginning 0) (match-end 0) + nil nil 'man) + (set-extent-face (make-extent (+ (match-beginning 0) (length "\n\n\n\n")) + (- (match-end 0) (length "\n\n\n\n"))) + 'man-heading)) + ;; Do the same thing for the very last line, which tends to get an xref + ;; extent when it shouldn't. + (goto-char (point-max)) + (backward-char) + (map-extents #'delete-extent-mapper nil (point-at-bol) (point-max) nil nil + 'man) + (set-extent-face (make-extent (point-at-bol) (point)) 'man-heading) + ;; Some of the Perl module man pages have ridiculously long titles, which + ;; groff chokes on for the title line, emitting backspaces with the + ;; intention of rubbing out an already-printed character. Handle that. + (beginning-of-line) + (while (re-search-forward "[^\b]\b" (point-max) t) + (delete-region (match-beginning 0) (match-end 0))))) ;;;###autoload -(defun manual-entry (topic &optional arg silent) - "Display the Unix manual entry (or entries) for TOPIC. +(defun manual-entry (topic) + "Display the Unix manual entry for TOPIC. + If TOPIC starts with -k, then a system apropos search is performed using man -k for TOPIC." (interactive - (list (let* ((default (save-excursion - (buffer-substring - (progn - (if (not (eobp)) - (forward-char)) - (if (re-search-backward "\\sw\\|\\s_" nil t) - (forward-char)) - (re-search-backward - "\$\\sw\\|\\s_\$([0-9]+[A-Za-z]*\\=" - (point-at-bol) t) - (skip-syntax-backward "w_") - (point)) - (progn - (skip-syntax-forward "w_") - (re-search-forward "\\=([0-9]+[A-Za-z]*)" nil t) - (point) )))) - (thing (read-string - (if (equal default "") "Manual entry: " - (concat "Manual entry: (default " default ") ")) - nil 'Manual-page-minibuffer-history))) - (if (equal thing "") default thing)) - (prefix-numeric-value current-prefix-arg))) - (let (buffer) - (or arg (setq arg 1)) + (list (let ((default (save-excursion + (buffer-substring + (progn + (if (not (eobp)) + (forward-char)) + (if (re-search-backward "\\sw\\|\\s_" nil t) + (forward-char)) + (re-search-backward + "\$\\sw\\|\\s_\$([0-9]+[A-Za-z]*\\=" + (point-at-bol) t) + (skip-syntax-backward "w_") + (point)) + (progn + (skip-syntax-forward "w_") + (re-search-forward "\\=([0-9]+[A-Za-z]*)" nil t) + (point)))))) + (read-string (if (equal default "") + "Manual entry: " + (concat "Manual entry (default " default "): ")) + nil 'Manual-page-minibuffer-history default)))) + (let (buffer section apropos-mode bufname) ;; Allow leading chapter numbers (if (string-match "\$[1-9n][a-zA-Z0-9]*\$ \$.*\$" topic) - (setq topic (replace-match "\\2(\\1)" t nil topic)) - ) - (let (section apropos-mode) - (let ((case-fold-search nil)) - (if (and (null section) - (string-match - "\\`[ \t]*\$[^( \t]+\$[ \t]*(\$.+\$)[ \t]*\\'" - topic)) - (setq section (match-string 2 topic) - topic (match-string 1 topic)) + (setq topic (replace-match "\\2(\\1)" t nil topic))) + (let ((case-fold-search nil)) + (if (and (null section) + (string-match + "\\`[ \t]*\$[^( \t]+\$[ \t]*(\$.+\$)[ \t]*\\'" + topic)) + (setq section (match-string 2 topic) + topic (match-string 1 topic)) (if (string-match "\\`[ \t]*-k[ \t]+\$[^ \t]+\$\\'" topic) (setq section "-k" topic (substring topic (match-beginning 1)))))) - - (when Manual-snip-subchapter - ;; jwz: turn section "3x11" and "3n" into "3". - (if (and section (string-match "\\`\$[0-9]+\$[^0-9]" section)) - (setq section (match-string 1 section)))) - - (if (or (equal section "-k") (member "-k" Manual-switches)) - (setq apropos-mode t)) - - (let ((bufname (concat "Man" - (when apropos-mode " apropos") - ": " topic - (when section (concat "(" section ")")))) - (temp-buffer-show-function - (cond ((eq 't Manual-buffer-view-mode) - 'view-buffer) - ((eq 'nil Manual-buffer-view-mode) - temp-buffer-show-function) - (t - 'view-buffer-other-window)))) - - (cond ((get-buffer bufname) - ;; reselect an old man page buffer if it exists already. - (save-excursion - (set-buffer (get-buffer bufname)) - (Manual-mode) - (setq buffer (current-buffer))) - (if temp-buffer-show-function - (funcall temp-buffer-show-function (get-buffer bufname)) - (display-buffer bufname))) - (t - (with-output-to-temp-buffer bufname - (buffer-disable-undo standard-output) - (save-excursion - (set-buffer standard-output) - (setq buffer-read-only nil) - (erase-buffer) + (when Manual-snip-subchapter + ;; jwz: turn section "3x11" and "3n" into "3". + (if (and section (string-match "\\`\$[0-9]+\$[^0-9]" section)) + (setq section (match-string 1 section)))) - (let ((args (append Manual-switches (list topic))) - args-string) - (if section - (setq args - (if (and (eq system-type 'usg-unix-v) - (null apropos-mode)) - (cons "-s" (cons section args)) - (cons section args)))) - (setq args-string - (mapconcat 'identity - (cons Manual-program args) " ")) - (if (string-match "\\`\$[^ \t/]*/\$+" args-string) - (setq args-string - (substring args-string (match-end 0)))) - - (message "%s (running...)" args-string) - (apply 'call-process Manual-program nil '(t nil) nil args) - - (if (< (buffer-size) (if apropos-mode 20 200)) - (progn - (kill-buffer (current-buffer)) - (error "%s not found" args-string))) - - (message "%s (cleaning...)" args-string) - (Manual-nuke-nroff-bs apropos-mode) - (message "%s (done.)" args-string)) - (set-buffer-modified-p nil) - (Manual-mode) - (setq buffer (current-buffer)))))) - (let ((page (if section - (concat topic "(" section ")") - topic))) - (setq Manual-page-history - (cons (buffer-name) - (delete (buffer-name) Manual-page-history)) - Manual-page-minibuffer-history - (cons page (delete page Manual-page-minibuffer-history)))))) - - (message nil) - buffer)) + (if (or (equal section "-k") (member "-k" Manual-switches)) + (setq apropos-mode t)) + (setq bufname (concat "Man" (when apropos-mode " apropos") ": " topic + (when section (concat "(" section ")")))) + (if (setq buffer (get-buffer bufname)) + ;; Reselect an old man page buffer if it exists already. + (Manual-mode-and-display-buffer buffer) + (let ((args (append (if section (list section)) Manual-switches + (list topic))) + (process-environment + (list* "EMACS=t" "MAN_KEEP_FORMATTING=1" + "PAGER=cat" ;; apropos doesn't obery MANPAGER + process-environment)) + (page (if section (concat topic "(" section ")") topic)) + process) + (with-current-buffer (setq buffer (get-buffer-create bufname)) + (buffer-disable-undo buffer) + (defvar #424242=#:saved-window-configuration) + (set (make-local-variable '#424242#) (current-window-configuration))) + (message (concat + (mapconcat 'identity + (cons (file-name-nondirectory Manual-program) + args) " ") + " (running...)")) + (setf Manual-page-minibuffer-history + (cons page (delete page Manual-page-minibuffer-history)) + process (apply #'start-process (concat "Manual (" topic ")") + (if (fboundp 'process-stderr-buffer) + (list buffer (generate-new-buffer + " *Manual-standard-error*")) + buffer) + Manual-program args) + (process-filter process) 'Manual-process-filter + (process-sentinel process) + (lambda (process message) + (let* ((buffer (process-buffer process)) saved-point + process-stderr-buffer process-command) + (labels + ((chomp-buffer-string (buffer) + (buffer-substring + (point-min buffer) + (if (eql (char-before (point-max buffer)) ?\n) + (1- (point-max buffer)) + (point-max buffer)) + buffer))) + (when (member (process-status process) '(signal exit)) + (if (not (fboundp 'process-stderr-buffer)) + ;; XEmacs 21.4, no way to tell stderr from stdout + (when (not (eql (process-exit-status process) 0)) + (error (prog1 + (chomp-buffer-string buffer) + (kill-buffer buffer)))) + (setq process-stderr-buffer + (process-stderr-buffer process)) + (if (eql (process-exit-status process) 0) + (if (> (buffer-size process-stderr-buffer) 0) + (display-warning 'alert + (buffer-string process-stderr-buffer))) + (set-window-configuration + (symbol-value-in-buffer '#424242# buffer)) + (error (prog1 + (chomp-buffer-string + process-stderr-buffer) + (kill-buffer buffer) + (kill-buffer process-stderr-buffer)))) + (kill-buffer process-stderr-buffer)) + (setq saved-point (point buffer)) + ;; Flush any stashed data. + (Manual-process-filter process "" t) + (save-excursion + (setf process-command (process-command process) + (current-buffer) buffer + buffer-read-only nil + #424242# nil) + ;; This can't be done in the process filter because it + ;; depends on the number of lines of the complete + ;; output: + (Manual-nuke-nroff-bs-footers) + (or (member "-k" process-command) + ;; And this is tough to do in the filter because + ;; of the extra need to stash text that might + ;; overlap, when determining where the section + ;; titles are. + (Manual-boldface-section-titles)) + ; (message "%s (done.)" args-string) + (setf buffer-read-only t) + (set-buffer-modified-p nil buffer) + (goto-char saved-point) + (setf Manual-page-history + (cons (buffer-name) + (delete (buffer-name) + Manual-page-history))))))))))) + buffer)) ;;;###autoload (define-key help-map "\C-m" 'manual-entry) (defun Manual-mode () + "Major mode for viewing Unix manual entries. See `manual-entry'." (kill-all-local-variables) (setq buffer-read-only t) (use-local-map Manual-mode-map) + (set (make-local-variable 'Manual-mode) t) (set-syntax-table Manual-mode-syntax-table) (setq major-mode 'Manual-mode mode-name "Manual") ＠＠ -330,31 +774,69 ＠＠ nil t) (run-hooks 'Manual-mode-hook)) +(defun Manual-mode-and-display-buffer (buffer) + "Call `Manual-mode' in BUFFER, and then display it. + +BUFFER is displayed as described in `Manual-buffer-view-mode'." + (when (buffer-name buffer) ;; If we don't have a separate stderr, and + ;; man(3) has errored, BUFFER may have been + ;; killed. Don't choke on this. + (save-excursion (set-buffer buffer) (Manual-mode)) + (funcall (case Manual-buffer-view-mode + ((t) 'view-buffer) + ((nil) (or temp-buffer-show-function 'display-buffer)) + (otherwise 'view-buffer-other-window)) + buffer) + ;; view-minor-mode-map is a suppressed keymap; that is, usually + ;; self-inserting characters are explicitly undefined, and this + ;; un-definition overrides further keymaps that are searched when + ;; processing a keystroke. This means that the Manual mode local map is + ;; ignored for key-presses. Work around this by adding it to the + ;; minor-mode-map-alist ahead of view-minor-mode-map. + ;; view-minor-mode-map probably shouldn't be a suppressed keymap. + (if (or (and (assq 'Manual-mode minor-mode-map-alist) + (assq 'view-minor-mode minor-mode-map-alist) + (< (position 'view-minor-mode minor-mode-map-alist :key #'car) + (position 'Manual-mode minor-mode-map-alist :key #'car))) + (not (assq 'Manual-mode minor-mode-map-alist))) + (setq minor-mode-map-alist + (acons 'Manual-mode Manual-mode-map + (delete* 'Manual-mode minor-mode-map-alist :key #'car)))))) + (defun Manual-last-page () + "Switch to the last manual entry buffer viewed." (interactive) - (if Manual-page-history - (let ((page (pop Manual-page-history))) - (if page - (progn - (get-buffer page) - (cons Manual-page-history page) - (switch-to-buffer page)))) - (error "No manual page buffers found. Use `M-x manual-entry'"))) - - -(defmacro Manual-delete-char (n) - ;; in v19, delete-char is compiled as a function call, but delete-region - ;; is byte-coded, so it's much faster. (We were spending 40% of our time - ;; in delete-char alone.) - `(delete-region (point) (+ (point) ,n))) + (let ((list Manual-page-history)) + (while (or (not + (get-buffer + (car + (or + list + (error + 'invalid-argument + (substitute-command-keys + (format + "No %smanual page buffers found. Use \\[manual-entry]." + (if (eq 'Manual-mode major-mode) "other " "")))))))) + (eq (get-buffer (car list)) (current-buffer))) + (setq list (cdr list))) + (setq Manual-page-history + (cons (car list) (delete (car list) Manual-page-history))) + (switch-to-buffer (car Manual-page-history)))) ;; Hint: BS stands for more things than "back space" ;;;###autoload (defun Manual-nuke-nroff-bs (&optional apropos-mode) + ;; This function doesn't work as a process filter, and is mostly deprecated; + ;; it is still in use by #'pager-cleanup-hook, below, but + ;; #'pager-cleanup-hook is mostly not in use. (interactive "*") - (if (and Manual-use-rosetta-man (not apropos-mode)) - (call-process-region (point-min) (point-max) - Manual-use-rosetta-man t t nil) + (macrolet + ((Manual-delete-char (n) + ;; in v19, delete-char is compiled as a function call, but + ;; delete-region is byte-coded, so it's much faster. (We were + ;; spending 40% of our time in delete-char alone.) + `(delete-region (point) (+ (point) ,n)))) ;; ;; turn underlining into italics ;; ＠＠ -418,8 +900,8 ＠＠ (while (search-forward "\b" nil t) (Manual-delete-char -2)) - (Manual-nuke-nroff-bs-footers) - ) ;; not Manual-use-rosetta-man + (Manual-nuke-nroff-bs-footers)) + ;; ;; turn subsection header lines into bold ;; ＠＠ -462,25 +944,38 ＠＠ (forward-line 1)) ) - (if Manual-use-rosetta-man - nil - ;; Zap ESC7, ESC8, and ESC9 - ;; This is for Sun man pages like "man 1 csh" - (goto-char (point-min)) - (while (re-search-forward "\e[789]" nil t) - (replace-match ""))) - - (Manual-mouseify-xrefs apropos-mode) - ) + ;; Zap ESC7, ESC8, and ESC9 + ;; This is for Sun man pages like "man 1 csh" + (goto-char (point-min)) + (while (re-search-forward "\e[789]" nil t) + (replace-match "")) + (Manual-mouseify-xrefs (point-min) (point-max))) ;;;###autoload (defalias 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name +(defun Manual-nuke-nroff-bs-footers () + "Remove page footers from nroff output, for on-screen display. -(defun Manual-nuke-nroff-bs-footers () - "For info see comments in packages/man.el" +Some implementations of man use nroff to produce `paginated' output with a +page size of 66 lines, of which several are devoted to the header and footer. +Each header and footer consists of 3 newlines, one informational line, and +either 3 additional newlines in the case of Solaris nroff, or 2 additional +newlines in the case of groff. + +Of course, pagination is an incredibly stupid idea for online information +presentation instead of printing to real paper, and so some system vendors +have chosen to improve on traditional behavior by providing non-paginated +output. We conservatively autodetect whether the output is in fact paginated. +Misdetection is still possible, but highly unlikely. For starters, the output +from man must accidentally be a multiple of 66 lines. + +Note that if nroff spits out error messages, pages will be more than 66 lines +high, and we'll misdetect page starts. That's ok because standard nroff +doesn't do any diagnostics, and the `gnroff' wrapper for groff turns off error +messages for compatibility. (At least, it's supposed to.)" + ;; Autodetect and nuke headers and footers in nroff output. - (goto-char (point-min)) ;; first lose the status output ＠＠ -497,26 +992,6 ＠＠ (if (looking-at " *done\n") (delete-region (point) (match-end 0))))) - ;; Some implementations of man use nroff to produce "paginated" - ;; output with a page size of 66 lines, of which several are devoted - ;; to the header and footer. Each header and footer consists of 3 - ;; newlines, one informational line, and either 3 additional - ;; newlines in the case of Solaris nroff, or 2 additional newlines - ;; in the case of groff. - ;; - ;; Of course, pagination is an incredibly stupid idea for online - ;; information presentation instead of printing to real paper, and - ;; so some system vendors have chosen to improve on traditional - ;; behavior by providing non-paginated output. We conservatively - ;; autodetect whether the output is in fact paginated. Misdetection - ;; is still possible, but highly unlikely. For starters, the output - ;; from man must accidentally be a multiple of 66 lines. - ;; - ;; Note that if nroff spits out error messages, pages will be more - ;; than 66 lines high, and we'll misdetect page starts. That's ok - ;; because standard nroff doesn't do any diagnostics, and the - ;; "gnroff" wrapper for groff turns off error messages for - ;; compatibility. (At least, it's supposed to.) (block nuke-headers-and-footers (let* ((page-starts '()) (solaris-pagination ; 66 - 2 * (3 + 1 + 3) = 52 ＠＠ -545,7 +1020,7 ＠＠ (looking-at pagination) ; guaranteed to match, by first pass. ;; Delete footers, except merely trim whitespace from the last one. - (if (= (match-end 0) (point-max)) + (if (eql (match-end 0) (point-max)) (progn ;; last footer ;; Leave exactly two newlines before last footer. ＠＠ -579,7 +1054,7 ＠＠ (insert ?\n)))))) ;; Delete headers, except merely trim whitespace from the first one. - (if (= page-start (point-min)) + (if (eql page-start (point-min)) ;; Leave exactly two newlines between first header and body. (delete-region (match-end 1) (save-excursion (goto-char (match-end 1)) ＠＠ -604,72 +1079,94 ＠＠ (delete-region (point-min) (save-excursion (goto-char (point-min)) (skip-chars-forward "\n") - (point))) - ) + (point)))) + +(defun Manual-mouseify-xrefs (begin end) + "Make the manual cross-references between BEGIN and END clickable. -(defun Manual-mouseify-xrefs (&optional apropos-mode) - (goto-char (point-min)) - ;; skip the top line of manual pages, but not apropos listings. - (unless apropos-mode (forward-line 1)) - (let ((case-fold-search nil) - s e name splitp extent) - ;; possibly it would be faster to rewrite this expression to search for - ;; a less common sequence first (like "([0-9]") and then back up to see - ;; if it's really a match. This function is 15% of the total time, 13% - ;; of which is this call to re-search-forward. - (while (re-search-forward "[a-zA-Z_][-a-zA-Z0-9_.:]*([0-9][a-zA-Z0-9]*)" - nil t) +Clicking on a cross-reference of the form `ls(1)' calls `manual-entry' with an +appropriate TOPIC argument." + (let ((case-fold-search nil) s e name extent re-search-forward + found section-length) + (goto-char begin) + (while (progn + (while (and (not found) + (setq re-search-forward + (re-search-forward "([0-9]" end t))) + (goto-char (- (point) (length "(1"))) + (if (eql (skip-chars-backward "-a-zA-Z0-9_.:") 0) + ;; Don't limit the above #'skip-chars-forward by BEGIN, + ;; there may be parts of the command name before that. + (goto-char re-search-forward) + (if (looking-at + ;; This function used to just #'re-search-forward for + ;; the following regexp. It takes about a third of the + ;; time to #'re-search-forward for the shorter + ;; expression, above, and then to back up. + ;; + ;; This is reduced further by only calling + ;; #'Manual-mouseify-xrefs if there is a close + ;; parenthesis in the string supplied to + ;; #'Manual-process-filter; see that latter function. + "[a-zA-Z_][-a-zA-Z0-9_.:]*\$([0-9][a-zA-Z0-9]*)\$") + (setq found t) + (goto-char re-search-forward)))) + re-search-forward) (setq s (match-beginning 0) e (match-end 0) name (buffer-substring s e) - splitp nil) + section-length (- (match-end 1) (match-beginning 1)) + found nil) ;; Let the loop above continue next time around. - (goto-char s) - ;; if this is a hyphenated xref, we're on the second line, 1st char now. + ;; If there could be upper case letters in the section, downcase them. + (if (> section-length (length "(1)")) + (setq name (concat (substring name 0 (- section-length)) + (downcase (substring name (- section-length)))))) + + ;; If this is a hyphenated xref, we're on the second line, first char + ;; now. Deal with the part of the xref on the previous line. (when (progn (beginning-of-line) - (and (looking-at (concat "^[ \t]+" (regexp-quote name))) - (progn - (backward-char 1) - (or (equal (char-before) ?-) - (equal (char-before) ?\255))) - (setq s (progn - (skip-chars-backward "-\255_a-zA-Z0-9") - (point)) - name (buffer-substring s e)))) - (setq splitp t) - ;; delete the spaces and dash from `name' - (let (i) - (while (setq i (string-match "[-\255 \n\t]+" name i)) - (setq name (concat (substring name 0 i) - (substring name (match-end 0))) - i (1+ i))))) - - ;; if there are upper case letters in the section, downcase them. - (if (string-match "(.*[A-Z]+.*)$" name) - (setq name (concat (substring name 0 (match-beginning 0)) - (downcase (substring name (match-beginning 0)))))) - - ;; if the xref was hyphenated, don't highlight the indention spaces. - (if splitp - (progn - (setq extent (make-extent s (progn (goto-char s) (end-of-line) (point)))) - (set-extent-property extent 'man (list 'Manual-follow-xref name)) - (set-extent-property extent 'highlight t) - (set-extent-face extent 'man-xref) - (goto-char e) - (skip-chars-backward "-_a-zA-Z0-9()") - (setq extent (make-extent (point) e))) - (setq extent (make-extent s e))) - (set-extent-property extent 'man (list 'Manual-follow-xref name)) - (set-extent-property extent 'highlight t) - (set-extent-face extent 'man-xref) - (goto-char e)))) + (and (member* (char-before (1- (point))) '(?- ?\255)) + (looking-at (concat "^[ \t]+" (regexp-quote name))))) + (setf extent + ;; Make an extent just for the bit on the previous line. Either + ;; order for FROM, TO for the args is fine. + (make-extent + (progn (backward-char) (point)) + (progn (skip-chars-backward "-\255a-zA-Z0-9_.:") (point))) + ;; Construct the concatenated name, including the bits on both + ;; lines. Don't include the trailing ?- or ?\255 from this line. + name (concat (buffer-substring (point) (1- (point-at-eol))) + name) + ;; Now set the properties of this constructed extent. + (extent-property extent 'man) `(Manual-follow-xref ,name) + (extent-property extent 'highlight) t + (extent-property extent 'keymap) Manual-mode-xref-map + (extent-face extent) 'man-xref)) + ;; Create an extent reflecting the original matched regexp, using the + ;; NAME (possibly de-hyphenated). Create the appropriate interactive + ;; properties. + (setf extent (make-extent s e) + (extent-property extent 'man) `(Manual-follow-xref ,name) + (extent-property extent 'highlight) t + (extent-property extent 'keymap) Manual-mode-xref-map + (extent-face extent) 'man-xref) + (goto-char (min e (or re-search-forward 1)))))) (defun Manual-follow-xref (&optional name-or-event) "Invoke `manual-entry' on the cross-reference under the mouse. -When invoked noninteractively, the arg may be an xref string to parse instead." - (interactive "e") + +When invoked noninteractively, NAME-OR-EVENT may be a cross-reference string +to parse instead." + (interactive + (list (or current-mouse-event ;; also reflects current misc-user events + (and (eql last-command-char ?\C-m) + (let* ((extent (extent-at (point) nil 'man)) + (data (and extent (extent-property extent + 'man)))) + (and (eq 'Manual-follow-xref (car-safe data)) + (cadr data))))))) (if (eventp name-or-event) (let* ((p (event-point name-or-event)) (extent (and p (extent-at p ＠＠ -677,56 +1174,45 ＠＠ 'highlight))) (data (and extent (extent-property extent 'man)))) (if (eq (car-safe data) 'Manual-follow-xref) - (eval data) + (apply 'Manual-follow-xref (cdr data)) (error "no manual cross-reference there."))) - (or (manual-entry name-or-event) - ;; If that didn't work, maybe it's in a different section than the - ;; man page writer expected. For example, man pages tend assume - ;; that all user programs are in section 1, but X tends to generate - ;; makefiles that put things in section "n" instead... - (and (string-match "[ \t]*([^)]+)\\'" name-or-event) - (progn - (message "No entries found for %s; checking other sections..." - name-or-event) - (manual-entry - (substring name-or-event 0 (match-beginning 0)) - nil t)))))) + (manual-entry name-or-event))) -(defun Manual-popup-menu (&optional event) - "Pops up a menu of cross-references in this manual page. +(defun Manual-popup-menu (event) + "Pop up a menu of cross-references in this manual page. + If there is a cross-reference under the mouse button which invoked this command, it will be the first item on the menu. Otherwise, they are -on the menu in the order in which they appear in the buffer." +qon the menu in the order in which they appear in the buffer." (interactive "e") - (let ((buffer (current-buffer)) - (sep "---") - xref items) - (cond (event - (setq buffer (event-buffer event)) - (let* ((p (event-point event)) - (extent (and p (extent-at p buffer 'highlight))) - (data (and extent (extent-property extent 'man)))) - (if (eq (car-safe data) 'Manual-follow-xref) - (setq xref (nth 1 data)))))) - (if xref (setq items (list sep xref))) + (let* ((buffer (event-buffer event)) + (p (event-point event)) + (extent (and p (extent-at p buffer 'highlight))) + (data (and extent (extent-property extent 'man))) + (xref (and (eq (car-safe data) 'Manual-follow-xref) data)) + (sep "---") + (items (if xref (list xref)))) (map-extents #'(lambda (extent ignore) (let ((data (extent-property extent 'man))) (if (and (eq (car-safe data) 'Manual-follow-xref) - (not (member (nth 1 data) items))) - (setq items (cons (nth 1 data) items))) - nil)) - buffer) - (if (eq sep (car items)) (setq items (cdr items))) - (let ((popup-menu-titles t)) - (and (null items) (setq popup-menu-titles nil)) - (popup-menu - (cons "Manual Entry" - (mapcar #'(lambda (item) - (if (eq item sep) - item - (vector item - (list 'Manual-follow-xref item) t))) - (nreverse items))))))) + (not (member data items))) + (setq items (cons data items))) + nil)) + buffer nil nil nil nil 'man) + (popup-menu + (if items + `("Manual Entry" + ,＠(if xref `([,(cadr xref) ,xref t] ,sep)) + ,＠(menu-split-long-menu + (loop for item in (delete* xref items) + with result = nil + do (setq result + (cons (if (eq item sep) + item + (vector (cadr item) item t)) + result)) + finally return result))) + '("Manual Entry" ["No cross-references in this buffer" nil nil]))))) (defun pager-cleanup-hook () "cleanup man page if called via $PAGER" ＠＠ -759,3 +1245,5 ＠＠ (add-hook 'server-visit-hook 'pager-cleanup-hook) (provide 'man) + +;;; man.el ends here -- ‘As I sat looking up at the Guinness ad, I could never figure out / How your man stayed up on the surfboard after forty pints of stout’ (C. Moore)

1 participants
0 comments

[COMMIT] 7 years, 1 month

Aidan Kehoe

Ar an dara lá de mí na Samhain, scríobh Raymond Toy: > For the record make_time was changed from returning a list to a cons in > changeset: 5948:417c790fd731 > > Reverting that one change makes gnus happy. Yay! Ah, fair enough. Grand, I have reverted that, and that should settle things. Thank you for some excellent bug reporting! # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1509658684 0 # Thu Nov 02 21:38:04 2017 +0000 # Node ID 51ad3b1a1b9288836a9efba679cc7141495c9e35 # Parent efa8f1377817cf7f529bbd39b58857c7675c59ad Have make_time() return a true list, not a cons, thank you Raymond Toy! src/ChangeLog addition: 2017-11-02 Aidan Kehoe <kehoea(a)parhasard.net> * editfns.c (make_time): Revert part of 417c790fd731, have this function return a list, never a cons. Thank you Raymond Toy! tests/ChangeLog addition: 2017-11-02 Aidan Kehoe <kehoea(a)parhasard.net> * automated/os-tests.el: We've reverted to returning a list, not a cons, in #'encode-time. Update tests to reflect this, thank you Raymond Toy. diff -r efa8f1377817 -r 51ad3b1a1b92 src/ChangeLog --- a/src/ChangeLog Sun Oct 29 13:59:44 2017 +0000 +++ b/src/ChangeLog Thu Nov 02 21:38:04 2017 +0000 ＠＠ -1,3 +1,9 ＠＠ +2017-11-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * editfns.c (make_time): + Revert part of 417c790fd731, have this function return a list, + never a cons. Thank you Raymond Toy! + 2017-10-28 Aidan Kehoe <kehoea(a)parhasard.net> * file-coding.c (handle_possible_error_octet): diff -r efa8f1377817 -r 51ad3b1a1b92 src/editfns.c --- a/src/editfns.c Sun Oct 29 13:59:44 2017 +0000 +++ b/src/editfns.c Thu Nov 02 21:38:04 2017 +0000 ＠＠ -1182,7 +1182,7 ＠＠ Lisp_Object make_time (time_t tiempo) { - return Fcons (make_fixnum (tiempo < 0 ? tiempo / 0x10000 : tiempo >> 16), + return list2 (make_fixnum (tiempo < 0 ? tiempo / 0x10000 : tiempo >> 16), make_fixnum (tiempo & 0xFFFF)); } diff -r efa8f1377817 -r 51ad3b1a1b92 tests/ChangeLog --- a/tests/ChangeLog Sun Oct 29 13:59:44 2017 +0000 +++ b/tests/ChangeLog Thu Nov 02 21:38:04 2017 +0000 ＠＠ -1,3 +1,10 ＠＠ +2017-11-02 Aidan Kehoe <kehoea(a)parhasard.net> + + * automated/os-tests.el: + We've reverted to returning a list, not a cons, in + #'encode-time. Update tests to reflect this, thank you Raymond + Toy. + 2017-10-29 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el: diff -r efa8f1377817 -r 51ad3b1a1b92 tests/automated/os-tests.el --- a/tests/automated/os-tests.el Sun Oct 29 13:59:44 2017 +0000 +++ b/tests/automated/os-tests.el Thu Nov 02 21:38:04 2017 +0000 ＠＠ -127,9 +127,9 ＠＠ (Check-Error args-out-of-range (encode-time 24 4 20 11 5 2017 -86401)) (Assert (equal (encode-time 24 4 20 11 5 2017 -86400) - '(22806 . 5448))) ;; "05/12/17 09:04:25 PM" + '(22806 5448))) ;; "05/12/17 09:04:25 PM" (Assert (equal (encode-time 24 4 20 11 5 2017 86400) - '(22803 . 29256))) ;; "05/10/17 09:04:24 PM" + '(22803 29256))) ;; "05/10/17 09:04:24 PM" (Check-Error args-out-of-range (encode-time 24 4 20 11 5 2017 86401)) ;;; end of os-tests.el -- ‘As I sat looking up at the Guinness ad, I could never figure out / How your man stayed up on the surfboard after forty pints of stout’ (C. Moore)

1 participants
0 comments

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

XEmacs-Patches November 2017