# HG changeset patch # User cvs # Date 1186987616 -7200 # Node ID b82b59fe008d6f28a909ad39f2b3f55e8b6b3d33 # Parent 30df88044ec6f89a3515b12fc5cda2d1ca41c39a Import from CVS: tag r19-15b3 diff -r 30df88044ec6 -r b82b59fe008d CHANGES-beta --- a/CHANGES-beta Mon Aug 13 08:46:35 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 08:46:56 2007 +0200 @@ -1,4 +1,26 @@ -*- indented-text -*- +to 19.15 beta3 + +-- EDT/TPU modes synched from GNU Emacs, should actually work for the first + first time. +-- Lots of files synched with GNU Emacs 19.34. +-- Apropos mode enhancements. +-- locate-library is now silent when called non-interactively. +-- Non aggressive keyboard focus throwing is supported. +-- Various enhancements from Lars Magne Ingebrigtsen. +-- smtpmail.el added from GNU Emacs 19.34. +-- man.el & man-xref.el added from GNU Emacs 19.35. +-- crisp/brief emulation courtesy of Gary D. Foster. +-- id-select.el courtesy of Bob Weiner. +-- m4-mode 1.8 +-- etags.c 11.78 +-- ilisp 5.8 +-- cperl-mode 1.28 +-- cc-mode 4.322 +-- elp 2.37 +-- python-mode 2.83 +-- load-warn-when-source-newer now defaults to t +-- tm 7.95 to 19.15 beta2 diff -r 30df88044ec6 -r b82b59fe008d etc/sgml/CATALOG --- a/etc/sgml/CATALOG Mon Aug 13 08:46:35 2007 +0200 +++ b/etc/sgml/CATALOG Mon Aug 13 08:46:56 2007 +0200 @@ -47,3 +47,5 @@ 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 Experimental 19960712//EN" html-cougar.dtd +DOCTYPE HTML html-3.2.dtd +DOCTYPE HTML-3 html-3.dtd diff -r 30df88044ec6 -r b82b59fe008d lib-src/etags.c --- a/lib-src/etags.c Mon Aug 13 08:46:35 2007 +0200 +++ b/lib-src/etags.c Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,7 @@ /* Tags file maker to go with GNU Emacs Copyright (C) 1984, 87, 88, 89, 93, 94, 95 Free Software Foundation, Inc. and Ken Arnold + This file is not considered part of GNU Emacs. This program is free software; you can redistribute it and/or modify @@ -14,11 +15,8 @@ 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. */ - -/* Synched up with: FSF 19.30. */ +along with this program; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* * Authors: @@ -28,46 +26,44 @@ * Gnu Emacs TAGS format and modifications by RMS? * Sam Kendall added C++. * Francesco Potorti` reorganised C and C++ based on work by Joe Wells. -#ifdef ETAGS_REGEXPS * Regexp tags by Tom Tromey. -#endif * - * Francesco Potorti` (pot@cnuce.cnr.it) is the current maintainer. + * Francesco Potorti` (F.Potorti@cnuce.cnr.it) is the current maintainer. */ -char pot_etags_version[] = "@(#) pot revision number is 11.45"; +char pot_etags_version[] = "@(#) pot revision number is 11.78"; #define TRUE 1 #define FALSE 0 + #ifndef DEBUG # define DEBUG FALSE #endif #ifdef MSDOS -#include -#include +# include +# include +# include #endif /* MSDOS */ #ifdef WINDOWSNT +# include +# include +# include +# include +# define MAXPATHLEN _MAX_PATH +#endif + +#if !defined (MSDOS) && !defined (WINDOWSNT) && defined (STDC_HEADERS) #include -#include #include -#define MAXPATHLEN _MAX_PATH #endif #ifdef HAVE_CONFIG_H -#include <../src/config.h> -/* On some systems, Emacs defines static as nothing for the sake - of unexec. We don't want that here since we don't use unexec. */ -#undef static -#endif - -#if __STDC__ || defined(STDC_HEADERS) -#include -#include -#include -#else -extern char *getenv (); +# include + /* On some systems, Emacs defines static as nothing for the sake + of unexec. We don't want that here since we don't use unexec. */ +# undef static #endif #include @@ -86,7 +82,7 @@ #include #ifdef ETAGS_REGEXPS -#include +# include #endif /* ETAGS_REGEXPS */ /* Define CTAGS to make the program "ctags" compatible with the usual one. @@ -101,11 +97,11 @@ /* Exit codes for success and failure. */ #ifdef VMS -#define GOOD 1 -#define BAD 0 +# define GOOD 1 +# define BAD 0 #else -#define GOOD 0 -#define BAD 1 +# define GOOD 0 +# define BAD 1 #endif /* C extensions. */ @@ -113,31 +109,19 @@ #define C_STAR 0x00003 /* C* */ #define YACC 0x10000 /* yacc file */ -#define streq(s,t) (strcmp (s, t) == 0) -#define strneq(s,t,n) (strncmp (s, t, n) == 0) - -#define lowcase(c) tolower ((unsigned char)c) - -#define iswhite(arg) (_wht[(unsigned int) arg]) /* T if char is white */ -#define begtoken(arg) (_btk[(unsigned int) arg]) /* T if char can start token */ -#define intoken(arg) (_itk[(unsigned int) arg]) /* T if char can be in token */ -#define endtoken(arg) (_etk[(unsigned int) arg]) /* T if char ends tokens */ - -/* typedefs from down below, moved up for prototypes */ - -/* - * A `struct linebuffer' is a structure which holds a line of text. - * `readline' reads a line from a stream into a linebuffer and works - * regardless of the length of the line. - */ -struct linebuffer -{ - long size; - char *buffer; -}; +#define streq(s,t) ((DEBUG &&!(s)&&!(t)&&(abort(),1)) || !strcmp(s,t)) +#define strneq(s,t,n) ((DEBUG &&!(s)&&!(t)&&(abort(),1)) || !strncmp(s,t,n)) + +#define lowcase(c) tolower ((char)c) + +#define iswhite(arg) (_wht[arg]) /* T if char is white */ +#define begtoken(arg) (_btk[arg]) /* T if char can start token */ +#define intoken(arg) (_itk[arg]) /* T if char can be in token */ +#define endtoken(arg) (_etk[arg]) /* T if char ends tokens */ #ifdef DOS_NT -# define absolutefn(fn) (fn[0] == '/' || (isalpha (fn[0]) && fn[1] == ':')) +# define absolutefn(fn) (fn[0] == '/' \ + || (fn[1] == ':' && fn[2] == '/')) #else # define absolutefn(fn) (fn[0] == '/') #endif @@ -153,12 +137,12 @@ typedef int logical; typedef struct nd_st -{ /* sorting structure */ +{ /* sorting structure */ char *name; /* function or type name */ char *file; /* file name */ logical is_func; /* use pattern or line no */ logical been_warned; /* set if noticed dup */ - long lno; /* line number tag is on */ + int lno; /* line number tag is on */ long cno; /* character number line starts on */ char *pat; /* search pattern */ struct nd_st *left, *right; /* left and right sons */ @@ -166,17 +150,13 @@ extern char *getenv (); -char *concat (CONST char *s1, CONST char *s2, CONST char *s3); -char *savenstr (CONST char *cp, int len); -char *savestr (CONST char *cp); -char *etags_strchr (CONST char *sp, char c); -char *etags_strrchr (CONST char *sp, char c); -char *etags_getcwd (void); -char *relative_filename (CONST char *file, CONST char *dir); -char *absolute_filename (CONST char *file, CONST char *cwd); -char *absolute_dirname (char *file, CONST char *cwd); -void *xmalloc (unsigned int size); -void *xrealloc (void *ptr, unsigned int size); +char *concat (); +char *savenstr (), *savestr (); +char *etags_strchr (), *etags_strrchr (); +char *etags_getcwd (); +char *relative_filename (), *absolute_filename (), *absolute_dirname (); +void grow_linebuffer (); +long *xmalloc (), *xrealloc (); typedef void Lang_function (); #if FALSE /* many compilers barf on this */ @@ -185,79 +165,87 @@ Lang_function C_entries; Lang_function Cplusplus_entries; Lang_function Cstar_entries; +Lang_function Erlang_functions; Lang_function Fortran_functions; Lang_function Yacc_entries; Lang_function Lisp_functions; Lang_function Pascal_functions; Lang_function Perl_functions; -Lang_function Postscript_functions; Lang_function Prolog_functions; Lang_function Scheme_functions; Lang_function TeX_functions; Lang_function just_read_file; #else /* so let's write it this way */ -void Asm_labels (FILE *inf); -void C_entries (int c_ext, FILE *inf); -void default_C_entries (FILE *inf); -void plain_C_entries (FILE *inf); -void Cplusplus_entries (FILE *inf); -void Cstar_entries (FILE *inf); -void Fortran_functions (FILE *inf); -void Yacc_entries (FILE *inf); -void Lisp_functions (FILE *inf); -void Pascal_functions (FILE *inf); -void Perl_functions (FILE *inf); -void Postscript_functions (FILE *inf); -void Prolog_functions (FILE *inf); -void Scheme_functions (FILE *inf); -void TeX_functions (FILE *inf); -void just_read_file (FILE *inf); +void Asm_labels (); +void C_entries (); +void default_C_entries (); +void plain_C_entries (); +void Cplusplus_entries (); +void Cstar_entries (); +void Erlang_functions (); +void Fortran_functions (); +void Yacc_entries (); +void Lisp_functions (); +void Pascal_functions (); +void Perl_functions (); +void Prolog_functions (); +void Scheme_functions (); +void TeX_functions (); +void just_read_file (); #endif -Lang_function *get_language_from_name (char *name); -Lang_function *get_language_from_interpreter (char *interpreter); -Lang_function *get_language_from_suffix (CONST char *suffix); -int total_size_of_entries (NODE *node); -long readline (struct linebuffer *linebuffer, FILE *stream); -long readline_internal (struct linebuffer *linebuffer, FILE *stream); +Lang_function *get_language_from_name (); +Lang_function *get_language_from_interpreter (); +Lang_function *get_language_from_suffix (); +int total_size_of_entries (); +long readline (); +long readline_internal (); #ifdef ETAGS_REGEXPS -void add_regex (char *regexp_pattern); +void add_regex (); #endif -void add_node (NODE *node, NODE **cur_node_p); -void error (CONST char *s1, CONST void *s2); -void fatal (CONST char *s1, CONST char *s2); -void pfatal (CONST char *s1); -void find_entries (CONST char *file, FILE *inf); -void free_tree (NODE *); -void getit (FILE *inf); -void init (void); -void initbuffer (struct linebuffer *linebuffer); -void pfnote (char *name, logical is_func, char *linestart, - int linelen, int lno, long cno); -void process_file (CONST char *file); -void put_entries (NODE *node); -void takeprec (void); +void add_node (); +void error (); +void suggest_asking_for_help (); +void fatal (), pfatal (); +void find_entries (); +void free_tree (); +void getit (); +void init (); +void initbuffer (); +void pfnote (); +void process_file (); +void put_entries (); +void takeprec (); char searchar = '/'; /* use /.../ searches */ int lineno; /* line number of current line */ long charno; /* current character number */ - -long linecharno; /* charno of start of line; not used by C, - but by every other language. */ +long linecharno; /* charno of start of line */ char *curfile; /* current input file name */ char *tagfile; /* output file */ -CONST char *progname; /* name this program was invoked with */ +char *progname; /* name this program was invoked with */ char *cwd; /* current working directory */ char *tagfiledir; /* directory of tagfile */ FILE *tagf; /* ioptr for tags file */ NODE *head; /* the head of the binary tree of tags */ +/* + * A `struct linebuffer' is a structure which holds a line of text. + * `readline' reads a line from a stream into a linebuffer and works + * regardless of the length of the line. + */ +struct linebuffer +{ + long size; + char *buffer; +}; + struct linebuffer lb; /* the current line */ -struct linebuffer token_name; /* used by C_entries as temporary area */ +struct linebuffer token_name; /* used by C_entries as a temporary area */ struct { long linepos; @@ -266,13 +254,15 @@ /* boolean "functions" (see init) */ logical _wht[0177], _etk[0177], _itk[0177], _btk[0177]; -CONST char - *white = " \f\t\n\013", /* white chars */ - *endtk = " \t\n\013\"'#()[]{}=-+%*/&|^~!<>;,.:?", /* token ending chars */ - /* token starting chars */ - *begtk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$~", - /* valid in-token chars */ - *intk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$0123456789"; +char + /* white chars */ + *white = " \f\t\n\013", + /* token ending chars */ + *endtk = " \t\n\013\"'#()[]{}=-+%*/&|^~!<>;,.:?", + /* token starting chars */ + *begtk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$~@", + /* valid in-token chars */ + *intk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$0123456789"; logical append_to_tagfile; /* -a: append to tags */ /* The following three default to TRUE for etags, but to FALSE for ctags. */ @@ -281,7 +271,7 @@ /* 0 struct/enum/union decls, and C++ */ /* member functions. */ logical constantypedefs; /* -d: create tags for C #define and enum */ - /* constants. Enum consts not implemented. */ + /* constants. */ /* -D: opposite of -d. Default under ctags. */ logical update; /* -u: update tags */ logical vgrind_style; /* -v: create vgrind style index output */ @@ -341,7 +331,7 @@ Lang_function *lang_func = NULL; /* Assembly code */ -CONST char *Asm_suffixes [] = { "a", /* Unix assembler */ +char *Asm_suffixes [] = { "a", /* Unix assembler */ "asm", /* Microcontroller assembly */ "def", /* BSO/Tasking definition includes */ "inc", /* Microcontroller include files */ @@ -353,62 +343,51 @@ /* Note that .c and .h can be considered C++, if the --c++ flag was given. That is why default_C_entries is called here. */ -CONST char *default_C_suffixes [] = +char *default_C_suffixes [] = { "c", "h", NULL }; -/* C++ file */ -CONST char *Cplusplus_suffixes [] = - { "C", "H", "c++", "cc", "cpp", "cxx", "h++", "hh", "hpp", "hxx", - /* XEmacs addition: Postscript with C syntax */ - "pdb", NULL }; - -/* C* file */ -CONST char *Cstar_suffixes [] = +/* .M is for Objective C++ files. */ +char *Cplusplus_suffixes [] = + { "C", "H", "c++", "cc", "cpp", "cxx", "h++", "hh", "hpp", "hxx", "M", NULL}; + +char *Cstar_suffixes [] = { "cs", "hs", NULL }; -/* Fortran */ -CONST char *Fortran_suffixes [] = +char *Erlang_suffixes [] = + { "erl", "hrl", NULL }; + +char *Fortran_suffixes [] = { "F", "f", "f90", "for", NULL }; -/* Lisp source code */ -CONST char *Lisp_suffixes [] = +char *Lisp_suffixes [] = { "cl", "clisp", "el", "l", "lisp", "lsp", "ml", NULL }; -/* Pascal file */ -CONST char *Pascal_suffixes [] = +char *Pascal_suffixes [] = { "p", "pas", NULL }; -/* Perl file */ -CONST char *Perl_suffixes [] = +char *Perl_suffixes [] = { "pl", "pm", NULL }; -CONST char *Perl_interpreters [] = - { "perl", NULL }; - -/* Pro*C file. */ -CONST char *plain_C_suffixes [] = - { "pc", NULL }; - -/* XEmacs addition */ -/* Postscript source code */ -CONST char *Postscript_suffixes [] = - { "ps", NULL }; - -/* Prolog source code */ -CONST char *Prolog_suffixes [] = +char *Perl_interpreters [] = + { "perl", "@PERL@", NULL }; + +char *plain_C_suffixes [] = + { "pc", /* Pro*C file */ + "m", /* Objective C file */ + "lm", /* Objective lex file */ + NULL }; + +char *Prolog_suffixes [] = { "prolog", NULL }; -/* Scheme source code */ -/* FIXME Can't do the `SCM' or `scm' prefix with a version number */ -CONST char *Scheme_suffixes [] = +/* Can't do the `SCM' or `scm' prefix with a version number. */ +char *Scheme_suffixes [] = { "SCM", "SM", "oak", "sch", "scheme", "scm", "sm", "t", NULL }; -/* TeX/LaTeX source code */ -CONST char *TeX_suffixes [] = - { "bib", "clo", "cls", "ltx", "sty", "TeX", "tex", NULL }; - -/* Yacc file */ -CONST char *Yacc_suffixes [] = - { "y", NULL }; +char *TeX_suffixes [] = + { "TeX", "bib", "clo", "cls", "ltx", "sty", "tex", NULL }; + +char *Yacc_suffixes [] = + { "y", "ym", NULL }; /* .ym is Objective yacc file */ /* Table of language names and corresponding functions, file suffixes and interpreter names. @@ -416,39 +395,39 @@ name. I just didn't. */ struct lang_entry { - CONST char *name; + char *name; Lang_function *function; - CONST char **suffixes; - CONST char **interpreters; + char **suffixes; + char **interpreters; }; -CONST struct lang_entry lang_names [] = +struct lang_entry lang_names [] = { - { "asm", Asm_labels, Asm_suffixes }, - { "c", default_C_entries, default_C_suffixes }, - { "c++", Cplusplus_entries, Cplusplus_suffixes }, - { "c*", Cstar_entries, Cstar_suffixes }, - { "fortran", Fortran_functions, Fortran_suffixes }, - { "lisp", Lisp_functions, Lisp_suffixes }, - { "pascal", Pascal_functions, Pascal_suffixes }, - { "perl", Perl_functions, Perl_suffixes, Perl_interpreters }, - { "proc", plain_C_entries, plain_C_suffixes }, - { "prolog", Prolog_functions, Prolog_suffixes }, - { "postscript", Postscript_functions, Postscript_suffixes }, - { "scheme" , Scheme_functions, Scheme_suffixes }, - { "tex", TeX_functions, TeX_suffixes }, - { "yacc", Yacc_entries, Yacc_suffixes }, - { "auto", NULL }, /* default guessing scheme */ - { "none", just_read_file }, /* regexp matching only */ - { NULL, NULL } /* end of list */ + { "asm", Asm_labels, Asm_suffixes, NULL }, + { "c", default_C_entries, default_C_suffixes, NULL }, + { "c++", Cplusplus_entries, Cplusplus_suffixes, NULL }, + { "c*", Cstar_entries, Cstar_suffixes, NULL }, + { "erlang", Erlang_functions, Erlang_suffixes, NULL }, + { "fortran", Fortran_functions, Fortran_suffixes, NULL }, + { "lisp", Lisp_functions, Lisp_suffixes, NULL }, + { "pascal", Pascal_functions, Pascal_suffixes, NULL }, + { "perl", Perl_functions, Perl_suffixes, Perl_interpreters }, + { "proc", plain_C_entries, plain_C_suffixes, NULL }, + { "prolog", Prolog_functions, Prolog_suffixes, NULL }, + { "scheme", Scheme_functions, Scheme_suffixes, NULL }, + { "tex", TeX_functions, TeX_suffixes, NULL }, + { "yacc", Yacc_entries, Yacc_suffixes, NULL }, + { "auto", NULL }, /* default guessing scheme */ + { "none", just_read_file }, /* regexp matching only */ + { NULL, NULL } /* end of list */ }; -static void -print_language_names (void) +void +print_language_names () { - CONST struct lang_entry *lang; - CONST char **ext; + struct lang_entry *lang; + char **ext; puts ("\nThese are the currently supported languages, along with the\n\ default file name suffixes:"); @@ -471,20 +450,26 @@ #ifndef VERSION # define VERSION "19" #endif -static void -print_version (void) +void +print_version () { - printf ("%s for Emacs version %s\n", (CTAGS) ? "ctags" : "etags", VERSION); + printf ("%s (GNU Emacs %s)\n", (CTAGS) ? "ctags" : "etags", VERSION); + puts ("Copyright (C) 1996 Free Software Foundation, Inc. and Ken Arnold"); + puts ("This program is distributed under the same terms as Emacs"); exit (GOOD); } -static void -print_help (void) +void +print_help () { printf ("These are the options accepted by %s. You may use unambiguous\n\ abbreviations for the long option names. A - as file name means read\n\ -names from stdin.\n\n", progname); +names from stdin.", progname); + if (!CTAGS) + printf (" Absolute names are stored in the output file as they\n\ +are. Relative ones are stored relative to the output file's directory."); + puts ("\n"); puts ("-a, --append\n\ Append tag entries to existing tags file."); @@ -499,11 +484,11 @@ if (CTAGS) puts ("-d, --defines\n\ - Create tag entries for constant C #defines, too."); + Create tag entries for C #define constants and enum constants, too."); else puts ("-D, --no-defines\n\ - Don't create tag entries for constant C #defines. This makes\n\ - the tags file smaller."); + Don't create tag entries for C #define constants and enum constants.\n\ + This makes the tags file smaller."); if (!CTAGS) { @@ -569,24 +554,19 @@ print_language_names (); + puts (""); + puts ("Report bugs to bug-gnu-emacs@prep.ai.mit.edu"); + exit (GOOD); } -#ifdef ETAGS_REGEXPS enum argument_type { at_language, at_regexp, at_filename }; -#else /* !ETAGS_REGEXPS */ -enum argument_type -{ - at_language, - at_filename -}; -#endif /* !ETAGS_REGEXPS */ /* This structure helps us allow mixing of --lang and filenames. */ typedef struct @@ -629,7 +609,9 @@ #include #define OUTSIZE MAX_FILE_SPEC_LEN short -fn_exp (vspec *out, char *in) +fn_exp (out, in) + vspec *out; + char *in; { static long context = 0; static struct dsc$descriptor_s o; @@ -672,7 +654,9 @@ name of each file specified by the provided arg expanding wildcards. */ char * -gfnames (char *arg, logical *p_error) +gfnames (arg, p_error) + char *arg; + logical *p_error; { static vspec filename = {MAX_FILE_SPEC_LEN, "\0"}; @@ -691,16 +675,16 @@ } #ifndef OLD /* Newer versions of VMS do provide `system'. */ -void -system (char *cmd) +system (cmd) + char *cmd; { fprintf (stderr, "system() function not implemented under VMS\n"); } #endif #define VERSION_DELIM ';' -char * -massage_name (char *s) +char *massage_name (s) + char *s; { char *start = s; @@ -717,8 +701,10 @@ #endif /* VMS */ -void -main (int argc, char *argv[]) +int +main (argc, argv) + int argc; + char *argv[]; { int i; unsigned int nincluded_files = 0; @@ -748,7 +734,7 @@ /* * If etags, always find typedefs and structure tags. Why not? - * Also default is to find macro constants. + * Also default is to find macro constants and enum constants. */ if (!CTAGS) typedefs = typedefs_and_cplusplus = constantypedefs = TRUE; @@ -795,7 +781,7 @@ { fprintf (stderr, "%s: -%c option may only be given once.\n", progname, opt); - goto usage; + suggest_asking_for_help (); } tagfile = optarg; break; @@ -805,12 +791,6 @@ break; case 'l': argbuffer[current_arg].function = get_language_from_name (optarg); - if (argbuffer[current_arg].function == NULL) - { - fprintf (stderr, "%s: language \"%s\" not recognized.\n", - progname, optarg); - goto usage; - } argbuffer[current_arg].arg_type = at_language; ++current_arg; break; @@ -863,7 +843,7 @@ break; #endif /* CTAGS */ default: - goto usage; + suggest_asking_for_help (); } } @@ -878,27 +858,18 @@ if (nincluded_files == 0 && file_count == 0) { fprintf (stderr, "%s: No input files specified.\n", progname); - - usage: - fprintf (stderr, "\tTry `%s --help' for a complete list of options.\n", - progname); - exit (BAD); + suggest_asking_for_help (); } if (tagfile == NULL) - { - tagfile = CTAGS ? (char *) "tags" : (char *) "TAGS"; - } + tagfile = CTAGS ? "tags" : "TAGS"; cwd = etags_getcwd (); /* the current working directory */ - strcat (cwd, "/"); + if (cwd[strlen (cwd) - 1] != '/') + cwd = concat (cwd, "/", ""); if (streq (tagfile, "-")) - { - tagfiledir = cwd; - } + tagfiledir = cwd; else - { - tagfiledir = absolute_dirname (tagfile, cwd); - } + tagfiledir = absolute_dirname (tagfile, cwd); init (); /* set up boolean "functions" */ @@ -911,7 +882,15 @@ if (!CTAGS) { if (streq (tagfile, "-")) - tagf = stdout; + { + tagf = stdout; +#ifdef DOS_NT + /* Switch redirected `stdout' to binary mode (setting `_fmode' + doesn't take effect until after `stdout' is already open). */ + if (!isatty (fileno (stdout))) + setmode (fileno (stdout), O_BINARY); +#endif /* DOS_NT */ + } else tagf = fopen (tagfile, append_to_tagfile ? "a" : "w"); if (tagf == NULL) @@ -976,9 +955,6 @@ because we want them ordered. Let's do it now. */ if (cxref_style) { - tagf = fopen (tagfile, append_to_tagfile ? "a" : "w"); - if (tagf == NULL) - pfatal (tagfile); put_entries (head); exit (GOOD); } @@ -994,7 +970,7 @@ "mv %s OTAGS;fgrep -v '\t%s\t' OTAGS >%s;rm OTAGS", tagfile, argbuffer[i].what, tagfile); if (system (cmd) != GOOD) - fatal ("failed to execute shell command", 0); + fatal ("failed to execute shell command", (char *)NULL); } append_to_tagfile = TRUE; } @@ -1011,7 +987,7 @@ sprintf (cmd, "sort %s -o %s", tagfile, tagfile); exit (system (cmd)); } - exit (GOOD); + return GOOD; } @@ -1019,19 +995,27 @@ * Return a Lang_function given the name. */ Lang_function * -get_language_from_name (char *name) +get_language_from_name (name) + char *name; { - CONST struct lang_entry *lang; - - if (name == NULL) - return NULL; - for (lang = lang_names; lang->name != NULL; lang++) - { - if (streq (name, lang->name)) - return lang->function; - } - - return NULL; + struct lang_entry *lang; + + if (name != NULL) + for (lang = lang_names; lang->name != NULL; lang++) + { + if (streq (name, lang->name)) + return lang->function; + } + + fprintf (stderr, "%s: language \"%s\" not recognized.\n", + progname, optarg); + suggest_asking_for_help (); + + /* This point should never be reached. The function should either + return a function pointer or never return. Note that a NULL + pointer cannot be considered as an error, as it means that the + language has not been explicitely imposed by the user ("auto"). */ + return NULL; /* avoid warnings from compiler */ } @@ -1039,10 +1023,11 @@ * Return a Lang_function given the interpreter name. */ Lang_function * -get_language_from_interpreter (char *interpreter) +get_language_from_interpreter (interpreter) + char *interpreter; { - CONST struct lang_entry *lang; - CONST char **iname; + struct lang_entry *lang; + char **iname; if (interpreter == NULL) return NULL; @@ -1061,10 +1046,11 @@ * Return a Lang_function given the file suffix. */ Lang_function * -get_language_from_suffix (CONST char *suffix) +get_language_from_suffix (suffix) + char *suffix; { - CONST struct lang_entry *lang; - CONST char **ext; + struct lang_entry *lang; + char **ext; if (suffix == NULL) return NULL; @@ -1082,10 +1068,18 @@ * This routine is called on each file argument. */ void -process_file (CONST char *file) +process_file (file) + char *file; { struct stat stat_buf; FILE *inf; +#ifdef DOS_NT + char *p; + + for (p = file; *p != '\0'; p++) + if (*p == '\\') + *p = '/'; +#endif if (stat (file, &stat_buf) == 0 && !S_ISREG (stat_buf.st_mode)) { @@ -1138,21 +1132,21 @@ * of a char is TRUE if it is the string "white", else FALSE. */ void -init (void) +init () { - register CONST char *sp; + register char *sp; register int i; for (i = 0; i < 0177; i++) _wht[i] = _etk[i] = _itk[i] = _btk[i] = FALSE; for (sp = white; *sp; sp++) - _wht[(unsigned int) *sp] = TRUE; + _wht[*sp] = TRUE; for (sp = endtk; *sp; sp++) - _etk[(unsigned int) *sp] = TRUE; + _etk[*sp] = TRUE; for (sp = intk; *sp; sp++) - _itk[(unsigned int) *sp] = TRUE; + _itk[*sp] = TRUE; for (sp = begtk; *sp; sp++) - _btk[(unsigned int) *sp] = TRUE; + _btk[*sp] = TRUE; _wht[0] = _wht['\n']; _etk[0] = _etk['\n']; _btk[0] = _btk['\n']; @@ -1164,13 +1158,16 @@ * which finds the function and type definitions. */ void -find_entries (CONST char *file, FILE *inf) +find_entries (file, inf) + char *file; + FILE *inf; { char *cp; Lang_function *function; NODE *old_last_node; extern NODE *last_node; + /* Memory leakage here: the memory block pointed by curfile is never released. The amount of memory leaked here is the sum of the lengths of the input file names. */ @@ -1218,7 +1215,7 @@ continue; *cp = '\0'; - if (strlen (lp) > (size_t) 0) + if (strlen (lp) > 0) { function = get_language_from_interpreter (lp); if (function != NULL) @@ -1246,19 +1243,21 @@ } /* Record a tag. */ -#if 0 - char *name; /* tag name, if different from definition */ +void +pfnote (name, is_func, linestart, linelen, lno, cno) + char *name; /* tag name, or NULL if unnamed */ logical is_func; /* tag is a function */ char *linestart; /* start of the line where tag is */ int linelen; /* length of the line where tag is */ int lno; /* line number */ long cno; /* character number */ -#endif -void -pfnote (char *name, logical is_func, char *linestart, - int linelen, int lno, long cno) { - register NODE *np = xnew (1, NODE); + register NODE *np; + + if (CTAGS && name == NULL) + return; + + np = xnew (1, NODE); /* If ctags mode, change name "main" to M. */ if (CTAGS && !cxref_style && streq (name, "main")) @@ -1277,12 +1276,20 @@ np->lno = lno; /* Our char numbers are 0-base, because of C language tradition? ctags compatibility? old versions compatibility? I don't know. - Anyway, since emacs's are 1-base we espect etags.el to take care + Anyway, since emacs's are 1-base we expect etags.el to take care of the difference. If we wanted to have 1-based numbers, we would uncomment the +1 below. */ np->cno = cno /* + 1 */ ; np->left = np->right = NULL; - np->pat = savenstr (linestart, ((CTAGS && !cxref_style) ? 50 : linelen)); + if (CTAGS && !cxref_style) + { + if (strlen (linestart) < 50) + np->pat = concat (linestart, "$", ""); + else + np->pat = savenstr (linestart, 50); + } + else + np->pat = savenstr (linestart, linelen); add_node (np, &head); } @@ -1292,7 +1299,8 @@ * recurse on left children, iterate on right children. */ void -free_tree (NODE *node) +free_tree (node) + register NODE *node; { while (node) { @@ -1317,7 +1325,8 @@ */ NODE *last_node = NULL; void -add_node (NODE *node, NODE **cur_node_p) +add_node (node, cur_node_p) + NODE *node, **cur_node_p; { register int dif; register NODE *cur_node = *cur_node_p; @@ -1333,7 +1342,7 @@ { /* Etags Mode */ if (last_node == NULL) - fatal ("internal error in add_node", 0); + fatal ("internal error in add_node", (char *)NULL); last_node->right = node; last_node = node; } @@ -1374,7 +1383,8 @@ } void -put_entries (NODE *node) +put_entries (node) + register NODE *node; { register char *sp; @@ -1389,50 +1399,59 @@ if (!CTAGS) { if (node->name != NULL) - fprintf (tagf, "%s\177%s\001%ld,%ld\n", + fprintf (tagf, "%s\177%s\001%d,%d\n", node->pat, node->name, node->lno, node->cno); else - fprintf (tagf, "%s\177%ld,%ld\n", + fprintf (tagf, "%s\177%d,%d\n", node->pat, node->lno, node->cno); } - else if (!cxref_style) + else { - fprintf (tagf, "%s\t%s\t", - node->name, node->file); - - if (node->is_func) - { /* a function */ - putc (searchar, tagf); - putc ('^', tagf); - - for (sp = node->pat; *sp; sp++) - { - if (*sp == '\\' || *sp == searchar) - putc ('\\', tagf); - putc (*sp, tagf); - } - putc (searchar, tagf); + if (node->name == NULL) + error ("internal error: NULL name in ctags mode.", (char *)NULL); + + if (cxref_style) + { + if (vgrind_style) + fprintf (stdout, "%s %s %d\n", + node->name, node->file, (node->lno + 63) / 64); + else + fprintf (stdout, "%-16s %3d %-16s %s\n", + node->name, node->lno, node->file, node->pat); } else - { /* a typedef; text pattern inadequate */ - fprintf (tagf, "%ld", node->lno); + { + fprintf (tagf, "%s\t%s\t", node->name, node->file); + + if (node->is_func) + { /* a function */ + putc (searchar, tagf); + putc ('^', tagf); + + for (sp = node->pat; *sp; sp++) + { + if (*sp == '\\' || *sp == searchar) + putc ('\\', tagf); + putc (*sp, tagf); + } + putc (searchar, tagf); + } + else + { /* a typedef; text pattern inadequate */ + fprintf (tagf, "%d", node->lno); + } + putc ('\n', tagf); } - putc ('\n', tagf); } - else if (vgrind_style) - fprintf (stdout, "%s %s %ld\n", - node->name, node->file, (node->lno + 63) / 64); - else - fprintf (stdout, "%-16s %3ld %-16s %s\n", - node->name, node->lno, node->file, node->pat); /* Output subentries that follow this one */ put_entries (node->right); } /* Length of a number's decimal representation. */ -static int -number_len (long num) +int +number_len (num) + long num; { int len = 0; if (!num) @@ -1450,7 +1469,8 @@ * backward compatibility. */ int -total_size_of_entries (NODE *node) +total_size_of_entries (node) + register NODE *node; { register int total; @@ -1478,21 +1498,28 @@ */ enum sym_type { - st_none, st_C_struct, st_C_enum, st_C_define, st_C_typedef, st_C_typespec + st_none, st_C_objprot, st_C_objimpl, st_C_objend, st_C_gnumacro, + st_C_struct, st_C_enum, st_C_define, st_C_typedef, st_C_typespec }; /* Feed stuff between (but not including) %[ and %] lines to: - gperf -c -k1,3 -o -p -r -t + gperf -c -k 1,3 -o -p -r -t %[ -struct C_stab_entry { CONST char *name; int c_ext; enum sym_type type; } +struct C_stab_entry { char *name; int c_ext; enum sym_type type; } %% +@interface, 0, st_C_objprot +@protocol, 0, st_C_objprot +@implementation,0, st_C_objimpl +@end, 0, st_C_objend class, C_PLPL, st_C_struct +namespace, C_PLPL, st_C_struct domain, C_STAR, st_C_struct union, 0, st_C_struct struct, 0, st_C_struct enum, 0, st_C_enum typedef, 0, st_C_typedef define, 0, st_C_define +bool, C_PLPL, st_C_typespec long, 0, st_C_typespec short, 0, st_C_typespec int, 0, st_C_typespec @@ -1507,89 +1534,122 @@ static, 0, st_C_typespec const, 0, st_C_typespec volatile, 0, st_C_typespec +explicit, C_PLPL, st_C_typespec +mutable, C_PLPL, st_C_typespec +typename, C_PLPL, st_C_typespec +# DEFUN used in emacs, the next three used in glibc (SYSCALL only for mach). +DEFUN, 0, st_C_gnumacro +SYSCALL, 0, st_C_gnumacro +ENTRY, 0, st_C_gnumacro +PSEUDO, 0, st_C_gnumacro +# These are defined inside C functions, so currently they are not met. +# EXFUN used in glibc, DEFVAR_* in emacs. +#EXFUN, 0, st_C_gnumacro +#DEFVAR_, 0, st_C_gnumacro %] and replace lines between %< and %> with its output. */ /*%<*/ -/* C code produced by gperf version 1.8.1 (K&R C version) */ -/* Command-line: gperf -c -k1,3 -o -p -r -t */ - - -struct C_stab_entry { CONST char *name; int c_ext; enum sym_type type; }; +/* C code produced by gperf version 2.1 (K&R C version) */ +/* Command-line: gperf -c -k 1,3 -o -p -r -t */ + + +struct C_stab_entry { char *name; int c_ext; enum sym_type type; }; #define MIN_WORD_LENGTH 3 -#define MAX_WORD_LENGTH 8 -#define MIN_HASH_VALUE 10 -#define MAX_HASH_VALUE 62 +#define MAX_WORD_LENGTH 15 +#define MIN_HASH_VALUE 34 +#define MAX_HASH_VALUE 121 /* - 21 keywords - 53 is the maximum key range + 34 keywords + 88 is the maximum key range */ static int -hash (CONST char *str, int len) +hash (str, len) + register char *str; + register unsigned int len; { static unsigned char hash_table[] = { - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, - 62, 62, 62, 62, 62, 62, 62, 2, 62, 7, - 6, 9, 15, 30, 62, 24, 62, 62, 1, 24, - 7, 27, 13, 62, 19, 26, 18, 27, 1, 62, - 62, 62, 62, 62, 62, 62, 62, 62, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 45, 121, 121, 121, 16, 19, + 61, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 10, 121, 121, 20, 53, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 41, 45, 22, + 60, 47, 37, 28, 121, 55, 121, 121, 20, 14, + 29, 30, 5, 121, 50, 59, 30, 54, 6, 121, + 121, 121, 121, 121, 121, 121, 121, 121, }; - return len + hash_table[(int) str[2]] + hash_table[(int) str[0]]; + return len + hash_table[str[2]] + hash_table[str[0]]; } -static struct C_stab_entry * -in_word_set (CONST char *str, int len) +struct C_stab_entry * +in_word_set (str, len) + register char *str; + register unsigned int len; { static struct C_stab_entry wordlist[] = { - {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, - {"",}, + {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, + {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, + {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, + {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"volatile", 0, st_C_typespec}, - {"",}, + {"PSEUDO", 0, st_C_gnumacro}, + {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, + {"typedef", 0, st_C_typedef}, + {"typename", C_PLPL, st_C_typespec}, + {"",}, {"",}, {"",}, + {"SYSCALL", 0, st_C_gnumacro}, + {"",}, {"",}, {"",}, + {"mutable", C_PLPL, st_C_typespec}, + {"namespace", C_PLPL, st_C_struct}, {"long", 0, st_C_typespec}, + {"",}, {"",}, + {"const", 0, st_C_typespec}, + {"",}, {"",}, {"",}, + {"explicit", C_PLPL, st_C_typespec}, + {"",}, {"",}, {"",}, {"",}, + {"void", 0, st_C_typespec}, + {"",}, {"char", 0, st_C_typespec}, {"class", C_PLPL, st_C_struct}, - {"",}, {"",}, {"",}, {"",}, - {"const", 0, st_C_typespec}, - {"",}, {"",}, {"",}, {"",}, + {"",}, {"",}, {"",}, + {"float", 0, st_C_typespec}, + {"",}, + {"@implementation", 0, st_C_objimpl}, {"auto", 0, st_C_typespec}, - {"",}, {"",}, - {"define", 0, st_C_define}, - {"",}, - {"void", 0, st_C_typespec}, - {"",}, {"",}, {"",}, - {"extern", 0, st_C_typespec}, - {"static", 0, st_C_typespec}, - {"",}, + {"",}, + {"ENTRY", 0, st_C_gnumacro}, + {"@end", 0, st_C_objend}, + {"bool", C_PLPL, st_C_typespec}, {"domain", C_STAR, st_C_struct}, - {"",}, - {"typedef", 0, st_C_typedef}, - {"double", 0, st_C_typespec}, - {"enum", 0, st_C_enum}, - {"",}, {"",}, {"",}, {"",}, + {"",}, + {"DEFUN", 0, st_C_gnumacro}, + {"extern", 0, st_C_typespec}, + {"@interface", 0, st_C_objprot}, + {"",}, {"",}, {"",}, {"int", 0, st_C_typespec}, - {"",}, - {"float", 0, st_C_typespec}, - {"",}, {"",}, {"",}, - {"struct", 0, st_C_struct}, - {"",}, {"",}, {"",}, {"",}, + {"",}, {"",}, {"",}, {"",}, + {"signed", 0, st_C_typespec}, + {"short", 0, st_C_typespec}, + {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, + {"define", 0, st_C_define}, + {"@protocol", 0, st_C_objprot}, + {"enum", 0, st_C_enum}, + {"static", 0, st_C_typespec}, + {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"union", 0, st_C_struct}, - {"",}, - {"short", 0, st_C_typespec}, - {"",}, {"",}, + {"struct", 0, st_C_struct}, + {"",}, {"",}, {"",}, {"",}, + {"double", 0, st_C_typespec}, {"unsigned", 0, st_C_typespec}, - {"signed", 0, st_C_typespec}, }; if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH) @@ -1598,9 +1658,9 @@ if (key <= MAX_HASH_VALUE && key >= MIN_HASH_VALUE) { - register CONST char *s = wordlist[key].name; - - if (*s == *str && strneq (str + 1, s + 1, len - 1)) + register char *s = wordlist[key].name; + + if (*s == *str && !strncmp (str + 1, s + 1, len - 1)) return &wordlist[key]; } } @@ -1608,10 +1668,13 @@ } /*%>*/ -static enum sym_type -C_symtype (char *str, int len, int c_ext) +enum sym_type +C_symtype (str, len, c_ext) + char *str; + int len; + int c_ext; { - register struct C_stab_entry *se = in_word_set(str, len); + register struct C_stab_entry *se = in_word_set (str, len); if (se == NULL || (se->c_ext && !(c_ext & se->c_ext))) return st_none; @@ -1622,7 +1685,7 @@ * C functions are recognized using a simple finite automaton. * funcdef is its state variable. */ -typedef enum +enum { fnone, /* nothing seen */ ftagseen, /* function-like tag seen */ @@ -1630,23 +1693,21 @@ finlist, /* in parameter list */ flistseen, /* after parameter list */ fignore /* before open brace */ -} FUNCST; -FUNCST funcdef; +} funcdef; /* * typedefs are recognized using a simple finite automaton. - * typeddef is its state variable. + * typdef is its state variable. */ -typedef enum +enum { tnone, /* nothing seen */ ttypedseen, /* typedef keyword seen */ tinbody, /* inside typedef body */ tend, /* just before typedef tag */ tignore /* junk after typedef tag */ -} TYPEDST; -TYPEDST typdef; +} typdef; /* @@ -1654,35 +1715,57 @@ * using another simple finite automaton. `structdef' is its state * variable. */ -typedef enum +enum { snone, /* nothing seen yet */ skeyseen, /* struct-like keyword seen */ stagseen, /* struct-like tag seen */ scolonseen, /* colon seen after struct-like tag */ sinbody /* in struct body: recognize member func defs*/ -} STRUCTST; -STRUCTST structdef; +} structdef; /* * When structdef is stagseen, scolonseen, or sinbody, structtag is the * struct tag, and structtype is the type of the preceding struct-like * keyword. */ -CONST char *structtag = ""; +char *structtag = ""; enum sym_type structtype; /* + * When objdef is different from onone, objtag is the name of the class. + */ +char *objtag = ""; + +/* * Yet another little state machine to deal with preprocessor lines. */ -typedef enum +enum { dnone, /* nothing seen */ dsharpseen, /* '#' seen as first char on line */ ddefineseen, /* '#' and 'define' seen */ dignorerest /* ignore rest of line */ -} DEFINEST; -DEFINEST definedef; +} definedef; + +/* + * State machine for Objective C protocols and implementations. + */ +enum +{ + onone, /* nothing seen */ + oprotocol, /* @interface or @protocol seen */ + oimplementation, /* @implementations seen */ + otagseen, /* class name seen */ + oparenseen, /* parenthesis before category seen */ + ocatseen, /* category name seen */ + oinbody, /* in @implementation body */ + omethodsign, /* in @implementation body, after +/- */ + omethodtag, /* after method name */ + omethodcolon, /* after method colon */ + omethodparm, /* after method parameter */ + oignore /* wait for @end */ +} objdef; /* * Set this to TRUE, and the next token considered is called a function. @@ -1696,13 +1779,18 @@ logical yacc_rules; /* + * methodlen is the length of the method name stored in token_name. + */ +int methodlen; + +/* * consider_token () * checks to see if the current token is at the start of a * function, or corresponds to a typedef, or is a struct/union/enum - * tag. + * tag, or #define, or an enum constant. * - * *IS_FUNC gets TRUE iff the token is a function or macro with args. - * C_EXT is which language we are looking at. + * *IS_FUNC gets TRUE iff the token is a function or #define macro + * with args. C_EXT is which language we are looking at. * * In the future we will need some way to adjust where the end of * the token is; for instance, implementing the C++ keyword @@ -1714,20 +1802,19 @@ * structdef IN OUT * definedef IN OUT * typdef IN OUT + * objdef IN OUT * next_token_is_func IN OUT */ -#if 0 +logical +consider_token (str, len, c, c_ext, cblev, parlev, is_func) register char *str; /* IN: token pointer */ register int len; /* IN: token length */ register char c; /* IN: first char after the token */ int c_ext; /* IN: C extensions mask */ int cblev; /* IN: curly brace level */ + int parlev; /* IN: parenthesis level */ logical *is_func; /* OUT: function found */ -#endif -static logical -consider_token (char *str, int len, char c, int c_ext, int cblev, - logical *is_func) { enum sym_type toktype = C_symtype (str, len, c_ext); @@ -1763,7 +1850,7 @@ case dignorerest: return FALSE; default: - error ("internal error: definedef value.", 0); + error ("internal error: definedef value.", (char *)NULL); } /* @@ -1790,8 +1877,6 @@ case st_C_struct: case st_C_enum: break; - default: - break; } /* Do not return here, so the structdef stuff has a chance. */ break; @@ -1802,12 +1887,8 @@ case st_C_struct: case st_C_enum: return FALSE; - default: - break; } return TRUE; - default: - break; } /* @@ -1819,11 +1900,6 @@ * This structdef business is NOT invoked when we are ctags and the * file is plain C. This is because a struct tag may have the same * name as another tag, and this loses with ctags. - * - * This if statement deals with the typdef state machine as - * follows: if typdef==ttypedseen and token is struct/union/class/enum, - * return FALSE. All the other code here is for the structdef - * state machine. */ switch (toktype) { @@ -1836,9 +1912,8 @@ structtype = toktype; } return FALSE; - default: - break; } + if (structdef == skeyseen) { /* Save the tag for struct/union/class, for functions that may be @@ -1858,23 +1933,25 @@ return FALSE; } - /* Detect GNU macros. */ - if (definedef == dnone) - if (strneq (str, "DEFUN", len) /* Used in emacs */ -#if FALSE - These are defined inside C functions, so currently they - are not met anyway. - || strneq (str, "EXFUN", len) /* Used in glibc */ - || strneq (str, "DEFVAR_", 7) /* Used in emacs */ -#endif - || strneq (str, "SYSCALL", len) /* Used in glibc (mach) */ - || strneq (str, "ENTRY", len) /* Used in glibc */ - || strneq (str, "PSEUDO", len)) /* Used in glibc */ - - { - next_token_is_func = TRUE; - return FALSE; - } + /* Detect GNU macros. + + DEFUN note for writers of emacs C code: + The DEFUN macro, used in emacs C source code, has a first arg + that is a string (the lisp function name), and a second arg that + is a C function name. Since etags skips strings, the second arg + is tagged. This is unfortunate, as it would be better to tag the + first arg. The simplest way to deal with this problem would be + to name the tag with a name built from the function name, by + removing the initial 'F' character and substituting '-' for '_'. + Anyway, this assumes that the conventions of naming lisp + functions will never change. Currently, this method is not + implemented, so writers of emacs code are recommended to put the + first two args of a DEFUN on the same line. */ + if (definedef == dnone && toktype == st_C_gnumacro) + { + next_token_is_func = TRUE; + return FALSE; + } if (next_token_is_func) { next_token_is_func = FALSE; @@ -1883,14 +1960,86 @@ return TRUE; } - /* A function? */ + /* Detect Objective C constructs. */ + switch (objdef) + { + case onone: + switch (toktype) + { + case st_C_objprot: + objdef = oprotocol; + return FALSE; + case st_C_objimpl: + objdef = oimplementation; + return FALSE; + } + break; + case oimplementation: + /* Save the class tag for functions that may be defined inside. */ + objtag = savenstr (str, len); + objdef = oinbody; + return FALSE; + case oprotocol: + /* Save the class tag for categories. */ + objtag = savenstr (str, len); + objdef = otagseen; + *is_func = TRUE; + return TRUE; + case oparenseen: + objdef = ocatseen; + *is_func = TRUE; + return TRUE; + case oinbody: + break; + case omethodsign: + if (parlev == 0) + { + objdef = omethodtag; + methodlen = len; + grow_linebuffer (&token_name, methodlen+1); + strncpy (token_name.buffer, str, len); + token_name.buffer[methodlen] = '\0'; + return TRUE; + } + return FALSE; + case omethodcolon: + if (parlev == 0) + objdef = omethodparm; + return FALSE; + case omethodparm: + if (parlev == 0) + { + objdef = omethodtag; + methodlen += len; + grow_linebuffer (&token_name, methodlen+1); + strncat (token_name.buffer, str, len); + return TRUE; + } + return FALSE; + case oignore: + if (toktype == st_C_objend) + { + /* Memory leakage here: the string pointed by objtag is + never released, because many tests would be needed to + avoid breaking on incorrect input code. The amount of + memory leaked here is the sum of the lengths of the + class tags. + free (objtag); */ + objdef = onone; + } + return FALSE; + } + + /* A function or enum constant? */ switch (toktype) { case st_C_typespec: if (funcdef != finlist && funcdef != fignore) funcdef = fnone; /* should be useless */ return FALSE; - default: + case st_none: + if (constantypedefs && structdef == sinbody && structtype == st_C_enum) + return TRUE; if (funcdef == fnone) { funcdef = ftagseen; @@ -1904,9 +2053,9 @@ /* * C_entries () - * This routine finds functions, typedefs, #define's and - * struct/union/enum definitions in C syntax and adds them - * to the list. + * This routine finds functions, typedefs, #define's, enum + * constants and struct/union/enum definitions in C syntax + * and adds them to the list. */ typedef struct { @@ -1933,6 +2082,7 @@ do { \ curlinepos = charno; \ lineno++; \ + linecharno = charno; \ charno += readline (&curlb, inf); \ lp = curlb.buffer; \ quotednl = FALSE; \ @@ -1950,32 +2100,28 @@ definedef = dnone; \ } while (0) -#define make_tag(isfun) do \ -{ \ - if (tok.valid) \ - { \ - char *name = NULL; \ - if (tok.named) \ - name = savestr (token_name.buffer); \ - pfnote (name, isfun, tok.buffer, tok.linelen, tok.lineno, tok.linepos); \ - } \ - else if (DEBUG) abort (); \ +/* This macro should never be called when tok.valid is FALSE, but + we must protect about both invalid input and internal errors. */ +#define make_C_tag(isfun) do \ +if (tok.valid) { \ + char *name = NULL; \ + if (CTAGS || tok.named) \ + name = savestr (token_name.buffer); \ + pfnote (name, isfun, tok.buffer, tok.linelen, tok.lineno, tok.linepos); \ tok.valid = FALSE; \ -} while (0) - -#if 0 +} /* else if (DEBUG) abort (); */ while (0) + +void +C_entries (c_ext, inf) int c_ext; /* extension of C */ FILE *inf; /* input file */ -#endif -void -C_entries (int c_ext, FILE *inf) { register char c; /* latest char read; '\0' for end of line */ register char *lp; /* pointer one beyond the character `c' */ int curndx, newndx; /* indices for current and new lb */ TOKEN tok; /* latest token read */ - register int tokoff = 0; /* offset in line of start of current token */ - register int toklen = 0; /* length of current token */ + register int tokoff; /* offset in line of start of current token */ + register int toklen; /* length of current token */ int cblev; /* current curly brace level */ int parlev; /* current parenthesis level */ logical incomm, inquote, inchar, quotednl, midtoken; @@ -1989,7 +2135,8 @@ lp = curlb.buffer; *lp = 0; - definedef = dnone; funcdef = fnone; typdef = tnone; structdef = snone; + funcdef = fnone; typdef = tnone; structdef = snone; + definedef = dnone; objdef = onone; next_token_is_func = yacc_rules = FALSE; midtoken = inquote = inchar = incomm = quotednl = FALSE; tok.valid = savetok.valid = FALSE; @@ -2082,9 +2229,9 @@ incomm = TRUE; continue; } - else if (cplpl && *lp == '/') + else if (/* cplpl && */ *lp == '/') { - c = 0; + c = '\0'; break; } else @@ -2135,7 +2282,8 @@ /* Consider token only if some complicated conditions are satisfied. */ if ((definedef != dnone || (cblev == 0 && structdef != scolonseen) - || (cblev == 1 && cplpl && structdef == sinbody)) + || (cblev == 1 && cplpl && structdef == sinbody) + || (structdef == sinbody && structtype == st_C_enum)) && typdef != tignore && definedef != dignorerest && funcdef != finlist) @@ -2144,7 +2292,7 @@ { if (endtoken (c)) { - if (cplpl && c == ':' && *lp == ':' && begtoken(*(lp + 1))) + if (c == ':' && cplpl && *lp == ':' && begtoken(*(lp + 1))) { /* * This handles :: in the middle, but not at the @@ -2158,37 +2306,43 @@ logical is_func = FALSE; if (yacc_rules - || consider_token (newlb.buffer + tokoff, toklen, - c, c_ext, cblev, &is_func)) + || consider_token (newlb.buffer + tokoff, toklen, c, + c_ext, cblev, parlev, &is_func)) { if (structdef == sinbody && definedef == dnone && is_func) /* function defined in C++ class body */ { - int strsize = strlen(structtag) + 2 + toklen + 1; - while (token_name.size < strsize) - { - token_name.size *= 2; - token_name.buffer - = (char *) xrealloc (token_name.buffer, - token_name.size); - } + grow_linebuffer (&token_name, + strlen(structtag)+2+toklen+1); strcpy (token_name.buffer, structtag); strcat (token_name.buffer, "::"); strncat (token_name.buffer, newlb.buffer+tokoff, toklen); tok.named = TRUE; } + else if (objdef == ocatseen) + /* Objective C category */ + { + grow_linebuffer (&token_name, + strlen(objtag)+2+toklen+1); + strcpy (token_name.buffer, objtag); + strcat (token_name.buffer, "("); + strncat (token_name.buffer, + newlb.buffer+tokoff, toklen); + strcat (token_name.buffer, ")"); + tok.named = TRUE; + } + else if (objdef == omethodtag + || objdef == omethodparm) + /* Objective C method */ + { + tok.named = TRUE; + } else { - while (token_name.size < toklen + 1) - { - token_name.size *= 2; - token_name.buffer - = (char *) xrealloc (token_name.buffer, - token_name.size); - } + grow_linebuffer (&token_name, toklen+1); strncpy (token_name.buffer, newlb.buffer+tokoff, toklen); token_name.buffer[toklen] = '\0'; @@ -2209,13 +2363,14 @@ if (definedef == dnone && (funcdef == ftagseen || structdef == stagseen - || typdef == tend)) + || typdef == tend + || objdef != onone)) { if (current_lb_is_new) switch_line_buffers (); } else - make_tag (is_func); + make_C_tag (is_func); } midtoken = FALSE; } @@ -2237,22 +2392,18 @@ funcdef = finlist; continue; case flistseen: - make_tag (TRUE); + make_C_tag (TRUE); funcdef = fignore; break; case ftagseen: funcdef = fnone; break; - default: - break; } if (structdef == stagseen) structdef = snone; break; case dsharpseen: savetok = tok; - default: - break; } if (!yacc_rules || lp == newlb.buffer + 1) { @@ -2272,6 +2423,20 @@ case ':': if (definedef != dnone) break; + switch (objdef) + { + case otagseen: + objdef = oignore; + make_C_tag (TRUE); + break; + case omethodtag: + case omethodparm: + objdef = omethodcolon; + methodlen += 1; + grow_linebuffer (&token_name, methodlen+1); + strcat (token_name.buffer, ":"); + break; + } if (structdef == stagseen) structdef = scolonseen; else @@ -2280,15 +2445,13 @@ case ftagseen: if (yacc_rules) { - make_tag (FALSE); + make_C_tag (FALSE); funcdef = fignore; } break; case fstartlist: funcdef = fnone; break; - default: - break; } break; case ';': @@ -2298,7 +2461,7 @@ switch (typdef) { case tend: - make_tag (FALSE); + make_C_tag (FALSE); /* FALLTHRU */ default: typdef = tnone; @@ -2317,6 +2480,14 @@ case ',': if (definedef != dnone) break; + switch (objdef) + { + case omethodtag: + case omethodparm: + make_C_tag (TRUE); + objdef = oinbody; + break; + } if (funcdef != finlist && funcdef != fignore) funcdef = fnone; if (structdef == stagseen) @@ -2328,7 +2499,7 @@ if (cblev == 0 && typdef == tend) { typdef = tignore; - make_tag (FALSE); + make_C_tag (FALSE); break; } if (funcdef != finlist && funcdef != fignore) @@ -2339,6 +2510,8 @@ case '(': if (definedef != dnone) break; + if (objdef == otagseen && parlev == 0) + objdef = oparenseen; switch (funcdef) { case fnone: @@ -2352,11 +2525,9 @@ if (*lp != '*') { typdef = tignore; - make_tag (FALSE); + make_C_tag (FALSE); } break; - default: - break; } /* switch (typdef) */ break; case ftagseen: @@ -2365,14 +2536,17 @@ case flistseen: funcdef = finlist; break; - default: - break; } parlev++; break; case ')': if (definedef != dnone) break; + if (objdef == ocatseen && parlev == 1) + { + make_C_tag (TRUE); + objdef = oignore; + } if (--parlev == 0) { switch (funcdef) @@ -2381,13 +2555,11 @@ case finlist: funcdef = flistseen; break; - default: - break; } if (cblev == 0 && typdef == tend) { typdef = tignore; - make_tag (FALSE); + make_C_tag (FALSE); } } else if (parlev < 0) /* can happen due to ill-conceived #if's. */ @@ -2401,31 +2573,40 @@ switch (structdef) { case skeyseen: /* unnamed struct */ + structdef = sinbody; structtag = "_anonymous_"; - structdef = sinbody; break; case stagseen: case scolonseen: /* named struct */ structdef = sinbody; - make_tag (FALSE); - break; - default: + make_C_tag (FALSE); break; } switch (funcdef) { case flistseen: - make_tag (TRUE); + make_C_tag (TRUE); /* FALLTHRU */ case fignore: funcdef = fnone; break; case fnone: - /* Neutralize `extern "C" {' grot and look inside structs. */ - if (cblev == 0 && structdef == snone && typdef == tnone) - cblev = -1; - default: - break; + switch (objdef) + { + case otagseen: + make_C_tag (TRUE); + objdef = oignore; + break; + case omethodtag: + case omethodparm: + make_C_tag (TRUE); + objdef = oinbody; + break; + default: + /* Neutralize `extern "C" {' grot. */ + if (cblev == 0 && structdef == snone && typdef == tnone) + cblev = -1; + } } cblev++; break; @@ -2452,7 +2633,7 @@ /* Memory leakage here: the string pointed by structtag is never released, because I fear to miss something and break things while freeing the area. The amount of - memory leaked here is the sum of the lenghts of the + memory leaked here is the sum of the lengths of the struct tags. if (structdef == sinbody) free (structtag); */ @@ -2461,8 +2642,15 @@ structtag = ""; } break; - case '=': - case '#': case '+': case '-': case '~': case '&': case '%': case '/': + case '+': + case '-': + if (objdef == oinbody && cblev == 0) + { + objdef = omethodsign; + break; + } + /* FALLTHRU */ + case '=': case '#': case '~': case '&': case '%': case '/': case '|': case '^': case '!': case '<': case '>': case '.': case '?': if (definedef != dnone) break; @@ -2471,6 +2659,11 @@ funcdef = fnone; break; case '\0': + if (objdef == otagseen) + { + make_C_tag (TRUE); + objdef = oignore; + } /* If a macro spans multiple lines don't reset its state. */ if (quotednl) CNL_SAVE_DEFINEDEF; @@ -2487,7 +2680,8 @@ * of a global flag. */ void -default_C_entries (FILE *inf) +default_C_entries (inf) + FILE *inf; { C_entries (cplusplus ? C_PLPL : 0, inf); } @@ -2502,21 +2696,24 @@ /* Always do C++. */ void -Cplusplus_entries (FILE *inf) +Cplusplus_entries (inf) + FILE *inf; { C_entries (C_PLPL, inf); } /* Always do C*. */ void -Cstar_entries (FILE *inf) +Cstar_entries (inf) + FILE *inf; { C_entries (C_STAR, inf); } /* Always do Yacc. */ void -Yacc_entries (FILE *inf) +Yacc_entries (inf) + FILE *inf; { C_entries (YACC, inf); } @@ -2525,8 +2722,9 @@ char *dbp; -static logical -tail (CONST char *cp) +logical +tail (cp) + char *cp; { register int len = 0; @@ -2541,7 +2739,7 @@ } void -takeprec (void) +takeprec () { while (isspace (*dbp)) dbp++; @@ -2566,7 +2764,8 @@ } void -getit (FILE *inf) +getit (inf) + FILE *inf; { register char *cp; @@ -2593,11 +2792,13 @@ && (isalpha (*cp) || isdigit (*cp) || (*cp == '_') || (*cp == '$'))); cp++) continue; - pfnote (NULL, TRUE, lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + pfnote ((CTAGS) ? savenstr (dbp, cp-dbp) : NULL, TRUE, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); } void -Fortran_functions (FILE *inf) +Fortran_functions (inf) + FILE *inf; { lineno = 0; charno = 0; @@ -2682,7 +2883,8 @@ * look for '^[a-zA-Z_.$][a-zA_Z0-9_.$]*[: ^I^J]' */ void -Asm_labels (FILE *inf) +Asm_labels (inf) + FILE *inf; { register char *cp; @@ -2707,7 +2909,7 @@ if (*cp == ':' || isspace (*cp)) { /* Found end of label, so copy it and add it to the table. */ - pfnote (NULL, TRUE, + pfnote ((CTAGS) ? savenstr(lb.buffer, cp-lb.buffer) : NULL, TRUE, lb.buffer, cp - lb.buffer + 1, lineno, linecharno); } } @@ -2740,7 +2942,7 @@ cp++; while (*cp && ! isspace(*cp) && *cp != '{') cp++; - pfnote (NULL, TRUE, + pfnote ((CTAGS) ? savenstr (lb.buffer, cp-lb.buffer) : NULL, TRUE, lb.buffer, cp - lb.buffer + 1, lineno, linecharno); } } @@ -2749,13 +2951,6 @@ /* Added by Mosur Mohan, 4/22/88 */ /* Pascal parsing */ -#define GET_NEW_LINE \ -{ \ - linecharno = charno; lineno++; \ - charno += 1 + readline (&lb, inf); \ - dbp = lb.buffer; \ -} - /* * Locates tags for procedures & functions. Doesn't do any type- or * var-definitions. It does look for the keyword "extern" or @@ -2763,12 +2958,13 @@ * the tag is skipped. */ void -Pascal_functions (FILE *inf) +Pascal_functions (inf) + FILE *inf; { struct linebuffer tline; /* mostly copied from C_entries */ - long save_lcno = 0; - int save_lineno = 0, save_len = 0; - char c; + long save_lcno; + int save_lineno, save_len; + char c, *cp, *namebuf; logical /* each of these flags is TRUE iff: */ incomment, /* point is inside a comment */ @@ -2801,7 +2997,10 @@ c = *dbp++; if (c == '\0') /* if end of line */ { - GET_NEW_LINE; + lineno++; + linecharno = charno; + charno += readline (&lb, inf); + dbp = lb.buffer; if (*dbp == '\0') continue; if (!((found_tag && verify_tag) || @@ -2882,32 +3081,27 @@ { found_tag = FALSE; verify_tag = FALSE; - pfnote (NULL, TRUE, + pfnote (namebuf, TRUE, tline.buffer, save_len, save_lineno, save_lcno); continue; } } if (get_tagname) /* grab name of proc or fn */ { - int size; - if (*dbp == '\0') continue; /* save all values for later tagging */ - size = strlen (lb.buffer) + 1; - while (size > tline.size) - { - tline.size *= 2; - tline.buffer = (char *) xrealloc (tline.buffer, tline.size); - } + grow_linebuffer (&tline, strlen (lb.buffer) + 1); strcpy (tline.buffer, lb.buffer); save_lineno = lineno; save_lcno = linecharno; /* grab block name */ - for (dbp++; *dbp && (!endtoken (*dbp)); dbp++) + for (cp = dbp + 1; *cp && (!endtoken (*cp)); cp++) continue; + namebuf = (CTAGS) ? savenstr (dbp, cp-dbp) : NULL; + dbp = cp; /* set dbp to e-o-token */ save_len = dbp - lb.buffer + 1; get_tagname = FALSE; found_tag = TRUE; @@ -2939,16 +3133,18 @@ * lisp tag functions * look for (def or (DEF, quote or QUOTE */ -static int -L_isdef (char *strp) +int +L_isdef (strp) + register char *strp; { return ((strp[1] == 'd' || strp[1] == 'D') && (strp[2] == 'e' || strp[2] == 'E') && (strp[3] == 'f' || strp[3] == 'F')); } -static int -L_isquote (char *strp) +int +L_isquote (strp) + register char *strp; { return ((*(++strp) == 'q' || *strp == 'Q') && (*(++strp) == 'u' || *strp == 'U') @@ -2958,8 +3154,8 @@ && isspace(*(++strp))); } -static void -L_getit (void) +void +L_getit () { register char *cp; @@ -2978,11 +3174,13 @@ if (cp == dbp) return; - pfnote (NULL, TRUE, lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + pfnote ((CTAGS) ? savenstr (dbp, cp-dbp) : NULL, TRUE, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); } void -Lisp_functions (FILE *inf) +Lisp_functions (inf) + FILE *inf; { lineno = 0; charno = 0; @@ -3030,50 +3228,6 @@ } } -/* XEmacs addition: */ - -/* - * Postscript tag functions - * Just look for lines where the first character is '/' - */ - -static void -PS_getit (void) -{ - register char *cp; - char c; - char nambuf[BUFSIZ]; - - if (*dbp == 0) return; - for (cp = dbp+1; *cp && *cp != ' ' && *cp != '{'; cp++) - continue; - c = cp[0]; - cp[0] = 0; - strcpy(nambuf, dbp); - cp[0] = c; - pfnote (nambuf, TRUE, lb.buffer, cp - lb.buffer + 1, lineno, linecharno); -} - -void -Postscript_functions (FILE *fi) -{ - lineno = 0; - charno = 0; - - while (!feof (fi)) - { - lineno++; - linecharno = charno; - charno += readline (&lb, fi) + 1; - dbp = lb.buffer; - if (dbp[0] == '/') - { - PS_getit(); - } - } -} - - /* * Scheme tag functions * look for (def... xyzzy @@ -3082,10 +3236,11 @@ * look for (set! xyzzy */ -void get_scheme (void); +void get_scheme (); void -Scheme_functions (FILE *inf) +Scheme_functions (inf) + FILE *inf; { lineno = 0; charno = 0; @@ -3126,7 +3281,7 @@ } void -get_scheme (void) +get_scheme () { register char *cp; @@ -3137,7 +3292,8 @@ *cp && *cp != '(' && *cp != ')' && !isspace (*cp); cp++) continue; - pfnote (NULL, TRUE, lb.buffer, cp - lb.buffer + 1, lineno, linecharno); + pfnote ((CTAGS) ? savenstr (dbp, cp-dbp) : NULL, TRUE, + lb.buffer, cp - lb.buffer + 1, lineno, linecharno); } /* Find tags in TeX and LaTeX input files. */ @@ -3147,7 +3303,7 @@ CONVERT THIS TO USE THE Stab TYPE!! */ struct TEX_tabent { - CONST char *name; + char *name; int len; }; @@ -3156,15 +3312,15 @@ /* Default set of control sequences to put into TEX_toktab. The value of environment var TEXTAGS is prepended to this. */ -CONST char *TEX_defenv = "\ +char *TEX_defenv = "\ :chapter:section:subsection:subsubsection:eqno:label:ref:cite:bibitem\ :part:appendix:entry:index"; -void TEX_mode (FILE *inf); -struct TEX_tabent *TEX_decode_env (CONST char *evarname, CONST char *defenv); -int TEX_Token (char *cp); +void TEX_mode (); +struct TEX_tabent *TEX_decode_env (); +int TEX_Token (); #if TeX_named_tokens -void TEX_getit (char *name, int len); +void TEX_getit (); #endif char TEX_esc = '\\'; @@ -3175,7 +3331,8 @@ * TeX/LaTeX scanning loop. */ void -TeX_functions (FILE *inf) +TeX_functions (inf) + FILE *inf; { char *lasthit; @@ -3196,7 +3353,7 @@ charno += readline (&lb, inf); dbp = lb.buffer; lasthit = dbp; - while ((dbp = etags_strchr (dbp, TEX_esc)))/* Look at each esc in line */ + while (dbp = etags_strchr (dbp, TEX_esc)) /* Look at each esc in line */ { register int i; @@ -3207,7 +3364,7 @@ i = TEX_Token (lasthit); if (0 <= i) { - pfnote (NULL, TRUE, + pfnote ((char *)NULL, TRUE, lb.buffer, strlen (lb.buffer), lineno, linecharno); #if TeX_named_tokens TEX_getit (lasthit, TEX_toktab[i].len); @@ -3225,7 +3382,8 @@ /* Figure out whether TeX's escapechar is '\\' or '!' and set grouping chars accordingly. */ void -TEX_mode (FILE *inf) +TEX_mode (inf) + FILE *inf; { int c; @@ -3257,9 +3415,11 @@ /* Read environment and prepend it to the default string. Build token table. */ struct TEX_tabent * -TEX_decode_env (CONST char *evarname, CONST char *defenv) +TEX_decode_env (evarname, defenv) + char *evarname; + char *defenv; { - register CONST char *env, *p; + register char *env, *p; struct TEX_tabent *tab; int size, i; @@ -3269,7 +3429,7 @@ if (!env) env = defenv; else - env = concat (env, defenv, ""); /* never freed! */ + env = concat (env, defenv, ""); /* Allocate a token table */ for (size = 1, p = env; p;) @@ -3308,7 +3468,9 @@ The name being defined actually starts at (NAME + LEN + 1). But we seem to include the TeX command in the tag name. */ void -TEX_getit (char *name, int len) +TEX_getit (name, len) + char *name; + int len; { char *p = name + len; @@ -3329,7 +3491,8 @@ Keep the capital `T' in `Token' for dumb truncating compilers (this distinguishes it from `TEX_toktab' */ int -TEX_Token (char *cp) +TEX_Token (cp) + char *cp; { int i; @@ -3339,86 +3502,63 @@ return -1; } -/* Support for Prolog. */ - -/* Whole head (not only functor, but also arguments) - is gotten in compound term. */ -static void -prolog_getit (char *s) +/* + * Prolog support (rewritten) by Anders Lindgren, Mar. 96 + * + * Assumes that the predicate starts at column 0. + * Only the first clause of a predicate is added. + */ +void +Prolog_functions (inf) + FILE *inf; { - char *save_s; - int insquote, npar; - - save_s = s; - insquote = FALSE; - npar = 0; - while (1) - { - if (s[0] == '\0') /* syntax error. */ - return; - else if (insquote && s[0] == '\'' && s[1] == '\'') - s += 2; - else if (s[0] == '\'') - { - insquote = !insquote; - s++; - } - else if (!insquote && s[0] == '(') - { - npar++; - s++; - } - else if (!insquote && s[0] == ')') - { - npar--; - s++; - if (npar == 0) - break; - else if (npar < 0) /* syntax error. */ - return; - } - else if (!insquote && s[0] == '.' - && (isspace (s[1]) || s[1] == '\0')) - { /* fullstop. */ - if (npar != 0) /* syntax error. */ - return; - s++; - break; - } - else - s++; - } - pfnote (NULL, TRUE, save_s, s-save_s, lineno, linecharno); -} - -void skip_comment (struct linebuffer *plb, FILE *inf, int *plineno, - long *plinecharno); - -/* It is assumed that prolog predicate starts from column 0. */ -void -Prolog_functions (FILE *inf) -{ - lineno = linecharno = charno = 0; + int prolog_pred (); + void prolog_skip_comment (); + + char * last; + int len; + int allocated; + + allocated = 0; + len = 0; + last = NULL; + + lineno = 0; + linecharno = 0; + charno = 0; + while (!feof (inf)) { lineno++; linecharno += charno; - charno = readline (&lb, inf) + 1; /* 1 for newline. */ + charno = readline (&lb, inf); dbp = lb.buffer; - if (isspace (dbp[0])) /* not predicate header. */ + if (dbp[0] == '\0') /* Empty line */ continue; - else if (dbp[0] == '%') /* comment. */ + else if (isspace (dbp[0])) /* Not a predicate */ continue; else if (dbp[0] == '/' && dbp[1] == '*') /* comment. */ - skip_comment (&lb, inf, &lineno, &linecharno); - else /* found. */ - prolog_getit (dbp); + prolog_skip_comment (&lb, inf); + else if (len = prolog_pred (dbp, last)) + { + /* Predicate. Store the function name so that we only + * generates a tag for the first clause. */ + if (last == NULL) + last = xnew(len + 1, char); + else if (len + 1 > allocated) + last = (char *) xrealloc(last, len + 1); + allocated = len + 1; + strncpy (last, dbp, len); + last[len] = '\0'; + } } } + void -skip_comment (struct linebuffer *plb, FILE *inf, int *plineno, - long *plinecharno) +prolog_skip_comment (plb, inf) + struct linebuffer *plb; + FILE *inf; { char *cp; @@ -3427,11 +3567,345 @@ for (cp = plb->buffer; *cp != '\0'; cp++) if (cp[0] == '*' && cp[1] == '/') return; - (*plineno)++; - *plinecharno += readline (plb, inf) + 1; /* 1 for newline. */ + lineno++; + linecharno += readline (plb, inf); } while (!feof(inf)); } + +/* + * A predicate definition is added if it matches: + * ( + * + * It is added to the tags database if it doesn't match the + * name of the previous clause header. + * + * Return the size of the name of the predicate, or 0 if no header + * was found. + */ +int +prolog_pred (s, last) + char *s; + char *last; /* Name of last clause. */ +{ + int prolog_atom(); + int prolog_white(); + + int pos; + int len; + + pos = prolog_atom(s, 0); + if (pos < 1) + return 0; + + len = pos; + pos += prolog_white(s, pos); + + if ((s[pos] == '(') || (s[pos] == '.')) + { + if (s[pos] == '(') + pos++; + + /* Save only the first clause. */ + if ((last == NULL) || + (len != strlen(last)) || + (strncmp(s, last, len) != 0)) + { + pfnote ((CTAGS) ? savenstr (s, len) : NULL, TRUE, + s, pos, lineno, linecharno); + return len; + } + } + return 0; +} + +/* + * Consume a Prolog atom. + * Return the number of bytes consumed, or -1 if there was an error. + * + * A prolog atom, in this context, could be one of: + * - An alphanumeric sequence, starting with a lower case letter. + * - A quoted arbitrary string. Single quotes can escape themselves. + * Backslash quotes everything. + */ +int +prolog_atom (s, pos) + char *s; + int pos; +{ + int origpos; + + origpos = pos; + + if (islower(s[pos]) || (s[pos] == '_')) + { + /* The atom is unquoted. */ + pos++; + while (isalnum(s[pos]) || (s[pos] == '_')) + { + pos++; + } + return pos - origpos; + } + else if (s[pos] == '\'') + { + pos++; + + while (1) + { + if (s[pos] == '\'') + { + pos++; + if (s[pos] != '\'') + break; + pos++; /* A double quote */ + } + else if (s[pos] == '\0') + /* Multiline quoted atoms are ignored. */ + return -1; + else if (s[pos] == '\\') + { + if (s[pos+1] == '\0') + return -1; + pos += 2; + } + else + pos++; + } + return pos - origpos; + } + else + return -1; +} + +/* Consume whitespace. Return the number of bytes eaten. */ +int +prolog_white (s, pos) + char *s; + int pos; +{ + int origpos; + + origpos = pos; + + while (isspace(s[pos])) + pos++; + + return pos - origpos; +} + +/* + * Support for Erlang -- Anders Lindgren, Feb 1996. + * + * Generates tags for functions, defines, and records. + * + * Assumes that Erlang functions start at column 0. + */ +void +Erlang_functions (inf) + FILE *inf; +{ + int erlang_func (); + void erlang_attribute (); + + char * last; + int len; + int allocated; + + allocated = 0; + len = 0; + last = NULL; + + lineno = 0; + linecharno = 0; + charno = 0; + + while (!feof (inf)) + { + lineno++; + linecharno += charno; + charno = readline (&lb, inf); + dbp = lb.buffer; + if (dbp[0] == '\0') /* Empty line */ + continue; + else if (isspace (dbp[0])) /* Not function nor attribute */ + continue; + else if (dbp[0] == '%') /* comment */ + continue; + else if (dbp[0] == '"') /* Sometimes, strings start in column one */ + continue; + else if (dbp[0] == '-') /* attribute, e.g. "-define" */ + { + erlang_attribute(dbp); + last = NULL; + } + else if (len = erlang_func (dbp, last)) + { + /* + * Function. Store the function name so that we only + * generates a tag for the first clause. + */ + if (last == NULL) + last = xnew(len + 1, char); + else if (len + 1 > allocated) + last = (char *) xrealloc(last, len + 1); + allocated = len + 1; + strncpy (last, dbp, len); + last[len] = '\0'; + } + } +} + + +/* + * A function definition is added if it matches: + * ( + * + * It is added to the tags database if it doesn't match the + * name of the previous clause header. + * + * Return the size of the name of the function, or 0 if no function + * was found. + */ +int +erlang_func (s, last) + char *s; + char *last; /* Name of last clause. */ +{ + int erlang_atom (); + int erlang_white (); + + int pos; + int len; + + pos = erlang_atom(s, 0); + if (pos < 1) + return 0; + + len = pos; + pos += erlang_white(s, pos); + + if (s[pos++] == '(') + { + /* Save only the first clause. */ + if ((last == NULL) || + (len != strlen(last)) || + (strncmp(s, last, len) != 0)) + { + pfnote ((CTAGS) ? savenstr (s, len) : NULL, TRUE, + s, pos, lineno, linecharno); + return len; + } + } + return 0; +} + + +/* + * Handle attributes. Currently, tags are generated for defines + * and records. + * + * They are on the form: + * -define(foo, bar). + * -define(Foo(M, N), M+N). + * -record(graph, {vtab = notable, cyclic = true}). + */ +void +erlang_attribute (s) + char *s; +{ + int erlang_atom (); + int erlang_white (); + + int pos; + int len; + + if ((strncmp(s, "-define", 7) == 0) || + (strncmp(s, "-record", 7) == 0)) + { + pos = 7; + pos += erlang_white(s, pos); + + if (s[pos++] == '(') + { + pos += erlang_white(s, pos); + + if (len = erlang_atom(s, pos)) + { + pfnote ((CTAGS) ? savenstr (& s[pos], len) : NULL, TRUE, + s, pos + len, lineno, linecharno); + } + } + } + return; +} + + +/* + * Consume an Erlang atom (or variable). + * Return the number of bytes consumed, or -1 if there was an error. + */ +int +erlang_atom (s, pos) + char *s; + int pos; +{ + int origpos; + + origpos = pos; + + if (isalpha (s[pos]) || s[pos] == '_') + { + /* The atom is unquoted. */ + pos++; + while (isalnum (s[pos]) || s[pos] == '_') + pos++; + return pos - origpos; + } + else if (s[pos] == '\'') + { + pos++; + + while (1) + { + if (s[pos] == '\'') + { + pos++; + break; + } + else if (s[pos] == '\0') + /* Multiline quoted atoms are ignored. */ + return -1; + else if (s[pos] == '\\') + { + if (s[pos+1] == '\0') + return -1; + pos += 2; + } + else + pos++; + } + return pos - origpos; + } + else + return -1; +} + +/* Consume whitespace. Return the number of bytes eaten */ +int +erlang_white (s, pos) + char *s; + int pos; +{ + int origpos; + + origpos = pos; + + while (isspace (s[pos])) + pos++; + + return pos - origpos; +} #ifdef ETAGS_REGEXPS /* Take a string like "/blah/" and turn it into "blah", making sure @@ -3440,8 +3914,9 @@ an unquoted separator. Also turns "\t" into a Tab character. Returns pointer to terminating separator. Works in place. Null terminates name string. */ -static char * -scan_separators (char *name) +char * +scan_separators (name) + char *name; { char sep = name[0]; char *copyto = name; @@ -3479,7 +3954,8 @@ /* Turn a name, which is an ed-style (but Emacs syntax) regular expression, into a real regular expression by compiling it. */ void -add_regex (char *regexp_pattern) +add_regex (regexp_pattern) + char *regexp_pattern; { char *name; const char *err; @@ -3495,7 +3971,7 @@ if (regexp_pattern[0] == '\0') { - error ("missing regexp", 0); + error ("missing regexp", (char *)NULL); return; } if (regexp_pattern[strlen(regexp_pattern)-1] != regexp_pattern[0]) @@ -3506,7 +3982,7 @@ name = scan_separators (regexp_pattern); if (regexp_pattern[0] == '\0') { - error ("null regexp", 0); + error ("null regexp", (char *)NULL); return; } (void) scan_separators (name); @@ -3520,7 +3996,7 @@ err = re_compile_pattern (regexp_pattern, strlen (regexp_pattern), patbuf); if (err != NULL) { - error ("%s while compiling pattern", (void *) err); + error ("%s while compiling pattern", err); return; } @@ -3540,8 +4016,10 @@ * Do the substitutions indicated by the regular expression and * arguments. */ -static char * -substitute (char *in, char *out, struct re_registers *regs) +char * +substitute (in, out, regs) + char *in, *out; + struct re_registers *regs; { char *result = NULL, *t; int size = 0; @@ -3554,7 +4032,7 @@ ++t; if (!*t) { - fprintf (stderr, "%s: pattern subtitution ends prematurely\n", + fprintf (stderr, "%s: pattern substitution ends prematurely\n", progname); return NULL; } @@ -3596,7 +4074,8 @@ #endif /* ETAGS_REGEXPS */ /* Initialize a linebuffer for use */ void -initbuffer (struct linebuffer *linebuffer) +initbuffer (linebuffer) + struct linebuffer *linebuffer; { linebuffer->size = 200; linebuffer->buffer = xnew (200, char); @@ -3608,7 +4087,9 @@ * which is the length of the line including the newline, if any. */ long -readline_internal (struct linebuffer *linebuffer, FILE *stream) +readline_internal (linebuffer, stream) + struct linebuffer *linebuffer; + register FILE *stream; { char *buffer = linebuffer->buffer; register char *p = linebuffer->buffer; @@ -3630,6 +4111,7 @@ } if (c == EOF) { + *p = '\0'; chars_deleted = 0; break; } @@ -3638,7 +4120,16 @@ if (p > buffer && p[-1] == '\r') { *--p = '\0'; +#ifdef DOS_NT + /* Assume CRLF->LF translation will be performed by Emacs + when loading this file, so CRs won't appear in the buffer. + It would be cleaner to compensate within Emacs; + however, Emacs does not know how many CRs were deleted + before any given point in the file. */ + chars_deleted = 1; +#else chars_deleted = 2; +#endif } else { @@ -3658,15 +4149,15 @@ * line against any existing regular expressions. */ long -readline (struct linebuffer *linebuffer, FILE *stream) +readline (linebuffer, stream) + struct linebuffer *linebuffer; + FILE *stream; { /* Read new line. */ + long result = readline_internal (linebuffer, stream); #ifdef ETAGS_REGEXPS int i; -#endif - long result = readline_internal (linebuffer, stream); - -#ifdef ETAGS_REGEXPS + /* Match against all listed patterns. */ for (i = 0; i < num_patterns; ++i) { @@ -3678,12 +4169,7 @@ /* Some error. */ if (!patterns[i].error_signaled) { - /* To avoid casting an int to a pointer, format the string - * here, and pass the address of the string to `error'. */ - char int_string[12]; - - sprintf(int_string, "%d", i); - error ("error while matching pattern %s", int_string); + error ("error while matching pattern %d", i); patterns[i].error_signaled = TRUE; } break; @@ -3705,7 +4191,7 @@ else { /* Make an unnamed tag. */ - pfnote (NULL, TRUE, + pfnote ((char *)NULL, TRUE, linebuffer->buffer, match, lineno, linecharno); } break; @@ -3721,8 +4207,12 @@ * matching on files that have no language defined. */ void -just_read_file (FILE *inf) +just_read_file (inf) + FILE *inf; { + lineno = 0; + charno = 0; + while (!feof (inf)) { ++lineno; @@ -3737,7 +4227,8 @@ * with xnew where the string CP has been copied. */ char * -savestr (CONST char *cp) +savestr (cp) + char *cp; { return savenstr (cp, strlen (cp)); } @@ -3747,7 +4238,9 @@ * the string CP has been copied for at most the first LEN characters. */ char * -savenstr (CONST char *cp, int len) +savenstr (cp, len) + char *cp; + int len; { register char *dp; @@ -3764,9 +4257,10 @@ * Identical to System V strrchr, included for portability. */ char * -etags_strrchr (CONST char *sp, char c) +etags_strrchr (sp, c) + register char *sp, c; { - register CONST char *r; + register char *r; r = NULL; do @@ -3774,7 +4268,7 @@ if (*sp == c) r = sp; } while (*sp++); - return (char *)r; + return r; } @@ -3785,34 +4279,46 @@ * Identical to System V strchr, included for portability. */ char * -etags_strchr (CONST char *sp, char c) +etags_strchr (sp, c) + register char *sp, c; { do { if (*sp == c) - return (char *)sp; + return sp; } while (*sp++); return NULL; } /* Print error message and exit. */ void -fatal (CONST char *s1, CONST char *s2) +fatal (s1, s2) + char *s1, *s2; { error (s1, s2); exit (BAD); } void -pfatal (CONST char *s1) +pfatal (s1) + char *s1; { perror (s1); exit (BAD); } +void +suggest_asking_for_help () +{ + fprintf (stderr, "\tTry `%s --help' for a complete list of options.\n", + progname); + exit (BAD); +} + /* Print error message. `s1' is printf control string, `s2' is arg for it. */ void -error (CONST char *s1, CONST void *s2) +error (s1, s2) + char *s1, *s2; { fprintf (stderr, "%s: ", progname); fprintf (stderr, s1, s2); @@ -3822,7 +4328,8 @@ /* Return a newly-allocated string whose contents concatenate those of s1, s2, s3. */ char * -concat (CONST char *s1, CONST char *s2, CONST char *s3) +concat (s1, s2, s3) + char *s1, *s2, *s3; { int len1 = strlen (s1), len2 = strlen (s2), len3 = strlen (s3); char *result = xnew (len1 + len2 + len3 + 1, char); @@ -3837,25 +4344,10 @@ /* Does the same work as the system V getcwd, but does not need to guess the buffer size in advance. */ -/* Does the same work as the system V getcwd, but does not need to - guess the buffer size in advance. */ char * -etags_getcwd (void) +etags_getcwd () { -#ifdef DOS_NT - char *p, path[MAXPATHLEN + 1]; /* Fixed size is safe on MSDOS. */ - - getwd (path); - p = path; - while (*p) - if (*p == '\\') - *p++ = '/'; - else - *p++ = lowcase (*p); - - return strdup (path); -#else /* not DOS_NT */ -#if HAVE_GETCWD +#ifdef HAVE_GETCWD int bufsize = 200; char *path = xnew (bufsize, char); @@ -3867,47 +4359,68 @@ path = xnew (bufsize, char); } +#if WINDOWSNT + { + /* Convert backslashes to slashes. */ + char *p; + for (p = path; *p != '\0'; p++) + if (*p == '\\') + *p = '/'; + } +#endif + return path; -#else /* not DOS_NT and not HAVE_GETCWD */ + +#else /* not HAVE_GETCWD */ +#ifdef MSDOS + char *p, path[MAXPATHLEN + 1]; /* Fixed size is safe on MSDOS. */ + + getwd (path); + + for (p = path; *p != '\0'; p++) + if (*p == '\\') + *p = '/'; + else + *p = lowcase (*p); + + return strdup (path); +#else /* not MSDOS */ struct linebuffer path; - FILE *paype; + FILE *pipe; initbuffer (&path); - paype = (FILE *) popen ("pwd 2>/dev/null", "r"); - if (paype == NULL || readline_internal (&path, paype) == 0) + pipe = (FILE *) popen ("pwd 2>/dev/null", "r"); + if (pipe == NULL || readline_internal (&path, pipe) == 0) pfatal ("pwd"); - pclose (paype); + pclose (pipe); return path.buffer; +#endif /* not MSDOS */ #endif /* not HAVE_GETCWD */ -#endif /* not DOS_NT */ } /* Return a newly allocated string containing the filename of FILE relative to the absolute directory DIR (which should end with a slash). */ char * -relative_filename (CONST char *file, CONST char *dir) +relative_filename (file, dir) + char *file, *dir; { - char *fp; - CONST char *dp; - char *abbs, *res; - - /* Find the common root of file and dir. */ - abbs = absolute_filename (file, cwd); - fp = abbs; + char *fp, *dp, *abs, *res; + + /* Find the common root of file and dir (with a trailing slash). */ + abs = absolute_filename (file, cwd); + fp = abs; dp = dir; while (*fp++ == *dp++) continue; - do - { - fp--; - dp--; - } + fp--, dp--; /* back to the first differing char */ + do /* look at the equal chars until / */ + fp--, dp--; while (*fp != '/'); /* Build a sequence of "../" strings for the resulting relative filename. */ - for (dp = etags_strchr (dp + 1, '/'), res = (char *) ""; + for (dp = etags_strchr (dp + 1, '/'), res = ""; dp != NULL; dp = etags_strchr (dp + 1, '/')) { @@ -3916,7 +4429,7 @@ /* Add the filename relative to the common root of file and dir. */ res = concat (res, fp + 1, ""); - free (abbs); + free (abs); return res; } @@ -3925,14 +4438,21 @@ absolute filename of FILE given CWD (which should end with a slash). */ char * -absolute_filename (CONST char *file, CONST char *cwwd) +absolute_filename (file, cwd) + char *file, *cwd; { char *slashp, *cp, *res; if (absolutefn (file)) res = concat (file, "", ""); +#ifdef DOS_NT + /* We don't support non-absolute filenames with a drive + letter, like `d:NAME' (it's too much hassle). */ + else if (file[1] == ':') + fatal ("%s: relative filenames with drive letters not supported", file); +#endif else - res = concat (cwwd, file, ""); + res = concat (cwd, file, ""); /* Delete the "/dirname/.." and "/." substrings. */ slashp = etags_strchr (res, '/'); @@ -3946,17 +4466,24 @@ cp = slashp; do cp--; - while (cp >= res && *cp != '/'); + while (cp >= res && !absolutefn (cp)); if (*cp == '/') { strcpy (cp, slashp + 3); } +#ifdef DOS_NT + /* Under MSDOS and NT we get `d:/NAME' as absolute + filename, so the luser could say `d:/../NAME'. + We silently treat this as `d:/NAME'. */ + else if (cp[1] == ':') + strcpy (cp + 3, slashp + 4); +#endif else /* else (cp == res) */ { if (slashp[3] != '\0') strcpy (cp, slashp + 4); else - return (char *) "."; + return "."; } slashp = cp; continue; @@ -3978,37 +4505,59 @@ filename of dir where FILE resides given CWD (which should end with a slash). */ char * -absolute_dirname (char *file, CONST char *cwwd) +absolute_dirname (file, cwd) + char *file, *cwd; { char *slashp, *res; char save; +#ifdef DOS_NT + char *p; + + for (p = file; *p != '\0'; p++) + if (*p == '\\') + *p = '/'; +#endif slashp = etags_strrchr (file, '/'); if (slashp == NULL) - return (char *) cwwd; + return cwd; save = slashp[1]; slashp[1] = '\0'; - res = absolute_filename (file, cwwd); + res = absolute_filename (file, cwd); slashp[1] = save; return res; } -/* Like malloc but get fatal error if memory is exhausted. */ -void * -xmalloc (unsigned int size) +/* Increase the size of a linebuffer. */ +void +grow_linebuffer (bufp, toksize) + struct linebuffer *bufp; + int toksize; { - void *result = malloc (size); + while (bufp->size < toksize) + bufp->size *= 2; + bufp->buffer = (char *) xrealloc (bufp->buffer, bufp->size); +} + +/* Like malloc but get fatal error if memory is exhausted. */ +long * +xmalloc (size) + unsigned int size; +{ + long *result = (long *) malloc (size); if (result == NULL) - fatal ("virtual memory exhausted", 0); + fatal ("virtual memory exhausted", (char *)NULL); return result; } -void * -xrealloc (void *ptr, unsigned int size) +long * +xrealloc (ptr, size) + char *ptr; + unsigned int size; { - void *result = realloc (ptr, size); + long *result = (long *) realloc (ptr, size); if (result == NULL) - fatal ("virtual memory exhausted", 0); + fatal ("virtual memory exhausted", (char *)NULL); return result; } diff -r 30df88044ec6 -r b82b59fe008d lib-src/tm-au --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tm-au Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,40 @@ +#!/bin/sh - +# +# $Id: tm-au,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# + +if [ "$TM_TMP_DIR" = "" ]; then + TM_TMP_DIR=/tmp + export TM_TMP_DIR +fi + +if [ "$5" = "" ]; then + filename="$TM_TMP_DIR/mime$$.au" +else + filename="$TM_TMP_DIR/$5" +fi + + +case "$4" in +"play") + echo "$2; $3 ->" + if [ "$AUDIOSERVER" = "" ]; then + if [ `uname` = "IRIX" ]; then + tmdecode $3 $1 $filename + sfplay $filename + trap 'rm -f $filename' 0 1 2 3 13 15 + else + tmdecode $3 $1 /dev/audio + fi + else + tmdecode $3 $1 $filename + autool -v 40 $filename + trap 'rm -f $filename' 0 1 2 3 13 15 + fi + ;; +"extract") + echo "$2; $3 -> $filename" + echo "extract to $filename" + tmdecode $3 $1 $filename + ;; +esac diff -r 30df88044ec6 -r b82b59fe008d lib-src/tm-file --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tm-file Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,20 @@ +#!/bin/sh - +# +# $Id: tm-file,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# + +if [ "$TM_TMP_DIR" = "" ]; then + TM_TMP_DIR=/tmp + export TM_TMP_DIR +fi + +if [ "$5" = "" ]; then + filename="$TM_TMP_DIR/mime$$" +else + filename="$TM_TMP_DIR/$5" +fi + + +echo "$2; $3 -> $filename" + +tmdecode $3 $1 $filename diff -r 30df88044ec6 -r b82b59fe008d lib-src/tm-html --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tm-html Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,44 @@ +#!/bin/sh +# +# $Id: tm-html,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# + +if [ "$TM_TMP_DIR" = "" ]; then + TM_TMP_DIR=/tmp + export TM_TMP_DIR +fi + +if [ "$TM_WWW_BROWSER" = "" ]; then + TM_WWW_BROWSER=netscape + export TM_WWW_BROWSER +fi + +if [ "$5" = "" ]; then + filename="$TM_TMP_DIR/mime$$.html" +else + filename="$TM_TMP_DIR/$5" +fi + +echo "$2; $3 -> $filename" + +tmdecode "$3" $1 $filename + +case "$4" in +"play") + if [ `echo $TM_WWW_BROWSER | grep netscape` ]; then + echo netscape + if [ -h $HOME/.netscape/lock ]; then + netscape -remote "openURL(file:$filename,new-window)" + else + netscape $filename + fi + else + echo not netscape + $TM_WWW_BROWSER $filename + fi + trap 'rm -f $filename' 0 1 2 3 13 15 + ;; +"extract") + echo "extract to $filename" + ;; +esac diff -r 30df88044ec6 -r b82b59fe008d lib-src/tm-image --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tm-image Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,69 @@ +#!/bin/sh - +# +# $Id: tm-image,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# +# Copyright 1994, 1995, 1996 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +if [ "$TM_TMP_DIR" = "" ]; then + TM_TMP_DIR=/tmp + export TM_TMP_DIR +fi +if [ "$5" = "" ]; then + case "$2" in + "image/gif") + filename="$TM_TMP_DIR/mime$$.gif" + ;; + "image/jpeg") + filename="$TM_TMP_DIR/mime$$.jpg" + ;; + "image/tiff"|"image/x-tiff") + filename="$TM_TMP_DIR/mime$$.tif" + ;; + "image/x-xwd") + filename="$TM_TMP_DIR/mime$$.xwd" + ;; + "image/x-xbm") + filename="$TM_TMP_DIR/mime$$.xbm" + ;; + "image/x-pic") + filename="$TM_TMP_DIR/mime$$.pic" + ;; + "image/x-mag") + filename="$TM_TMP_DIR/mime$$.mag" + ;; + *) + filename="$TM_TMP_DIR/mime$$.img" + ;; + esac +else + filename="$TM_TMP_DIR/$5" +fi + +echo "$2; $3 -> $filename" + +tmdecode $3 $1 $filename + +case "$4" in +"play") + xv -geometry +1+1 $filename + trap 'rm -f $filename' 0 1 2 3 13 15 + ;; +"extract") + echo "extract to $filename" + ;; +esac diff -r 30df88044ec6 -r b82b59fe008d lib-src/tm-mpeg --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tm-mpeg Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,48 @@ +#!/bin/sh - +# +# $Id: tm-mpeg,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# +# Copyright 1994, 1995, 1996 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +if [ "$TM_TMP_DIR" = "" ]; then + TM_TMP_DIR=/tmp + export TM_TMP_DIR +fi +if [ "$5" = "" ]; then + filename="$TM_TMP_DIR/mime$$.mpg" +else + filename="$TM_TMP_DIR/$5" +fi + +echo "$2; $3 -> $filename" + +tmdecode $3 $1 $filename + +case "$4" in +"play") + if [ "$VIDEO_DITHER" = "" ]; then + VIDEO_DITHER=gray + export VIDEO_DITHER + fi + mpeg_play -dither $VIDEO_DITHER $filename + trap 'rm -f $filename' 0 1 2 3 13 15 + ;; +"extract") + echo "extract to $filename" + ;; +esac diff -r 30df88044ec6 -r b82b59fe008d lib-src/tm-plain --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tm-plain Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,30 @@ +#!/bin/sh - +# +# $Id: tm-plain,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# + +if [ "$TM_TMP_DIR" = "" ]; then + TM_TMP_DIR=/tmp + export TM_TMP_DIR +fi +if [ "$5" = "" ]; then + filename="$TM_TMP_DIR/mime$$.pln" +else + filename="$TM_TMP_DIR/$5" +fi + +case "$4" in +"play") + echo "$2; $3 ->" + tmdecode "$3" "$1" /dev/stdout + ;; +"extract") + echo "$2; $3 -> $filename" + echo "extract to $filename" + tmdecode "$3" "$1" $filename + ;; +"print") + echo "$2; $3 ->" + tmdecode "$3" "$1" /dev/stdout | lpr + ;; +esac \ No newline at end of file diff -r 30df88044ec6 -r b82b59fe008d lib-src/tm-ps --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tm-ps Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,48 @@ +#!/bin/sh - +# +# $Id: tm-ps,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# +# Copyright 1994, 1995, 1996 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +if [ "$TM_TMP_DIR" = "" ]; then + TM_TMP_DIR=/tmp + export TM_TMP_DIR +fi +if [ "$5" = "" ]; then + filename="$TM_TMP_DIR/mime$$.pln" +else + filename="$TM_TMP_DIR/$5" +fi + +case "$4" in +"play") + echo "$2; $3 -> $filename" + tmdecode $3 $1 $filename + ghostview $filename + trap 'rm -f $filename' 0 1 2 3 13 15 + ;; +"extract") + echo "$2; $3 -> $filename" + echo "extract to $filename" + tmdecode "$3" "$1" $filename + ;; +"print") + echo "$2; $3 ->" + tmdecode "$3" "$1" /dev/stdout | lpr + ;; +esac diff -r 30df88044ec6 -r b82b59fe008d lib-src/tmdecode --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib-src/tmdecode Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,57 @@ +#!/bin/sh - +# +# $Id: tmdecode,v 1.1.1.1 1996/12/18 03:52:12 steve Exp $ +# +# Copyright 1994, 1995, 1996 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +trap 'rm -f $2' 0 1 2 3 13 15 + +case "$3" in +/dev/stdout) + OUTPUT= + ;; +*) + OUTPUT='> $3' + ;; +esac + +case "$1" in +""|"7bit"|"8bit"|"binary") + eval "cat $2 $OUTPUT" + ;; +"base64") + #eval "decode-b < $2 $OUTPUT" + eval "mmencode -u $2 $OUTPUT" + ;; +"quoted-printable") + eval "mmencode -q -u $2 $OUTPUT" + ;; +"x-uue"|"x-uuencode") + (cd $TM_TMP_DIR ; uudecode $2) + ;; +"x-gzip64") + #eval "decode-b < $2 | gzip -cd $OUTPUT" + eval "mmencode -u $2 | gzip -cd $OUTPUT" + ;; +*) + echo "unknown encoding" + exit -1 + ;; +esac + +# echo "$2 was removed." diff -r 30df88044ec6 -r b82b59fe008d lisp/comint/background.el --- a/lisp/comint/background.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/comint/background.el Mon Aug 13 08:46:56 2007 +0200 @@ -4,20 +4,25 @@ ;; Keywords: processes ;; 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; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: ;; - Adapted to use comint and cleaned up somewhat. Olin Shivers 5/90 ;; - Background failed to set the process buffer's working directory @@ -38,6 +43,8 @@ ;; arg to shell-command --> BUFFER-NAME arg to background) from ;; FSF 19.30. Ben Wing +;;; Code: + (provide 'background) (require 'comint) @@ -116,3 +123,5 @@ (if at-end (goto-char (point-max)))) (set-buffer-modified-p nil))))) (store-match-data ms)))) + +;;; background.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/comint/dbx.el --- a/lisp/comint/dbx.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/comint/dbx.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,8 @@ ;;; dbx.el --- run dbx under Emacs + ;; Copyright (C) 1988 Free Software Foundation, Inc. -;; Main author Masanobu UMEDA (umerin@flab.fujitsu.junet) + +;; Author: Masanobu UMEDA (umerin@flab.fujitsu.junet) ;; Keywords: c, unix, tools, debugging ;; This file is part of XEmacs. @@ -17,7 +19,12 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Code: (require 'comint) @@ -160,3 +167,7 @@ (1+ (count-lines 1 (point)))))) (process-send-string dbx-process (concat "stop at \"" file-name "\":" line "\n")))) + +(provide 'dbx) + +;;; dbx.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/comint/gdb.el --- a/lisp/comint/gdb.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/comint/gdb.el Mon Aug 13 08:46:56 2007 +0200 @@ -21,7 +21,12 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: ;; Description of GDB interface: @@ -57,6 +62,8 @@ ;; gdb-display-frame is invoked automatically when a filename-and-line-number ;; appears in the output. +;;; Code: + (require 'comint) (require 'shell) @@ -664,3 +671,5 @@ (gdb-clear))) (provide 'gdb) + +;;; gdb.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/comint/gdbsrc.el --- a/lisp/comint/gdbsrc.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/comint/gdbsrc.el Mon Aug 13 08:46:56 2007 +0200 @@ -294,8 +294,9 @@ (and (eq major-mode 'gdb-mode) ; doesn't work w/ energize yet (setq current-gdb-buffer (current-buffer)) ;; XEmacs change: - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t)) + (progn + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'gdbsrc-reset nil t))) (error "Cannot determine current-gdb-buffer")) ;;; (set-process-filter ;;; (get-buffer-process current-gdb-buffer) 'gdbsrc-mode-filter) @@ -499,7 +500,7 @@ epnt extent (eq (window-buffer ewin) - (extent-buffer extent)) + (extent-object extent)) (extent-start-position extent) (> epnt (extent-start-position extent)) (> (extent-end-position extent) epnt)))) @@ -510,7 +511,7 @@ ;; stig@hackvan.com (and extent ; FIXME - I'm such a sinner... (eq (current-buffer) - (extent-buffer extent)) + (extent-object extent)) (> (point) (extent-start-position extent)) (>= (extent-end-position extent) (point)))) @@ -560,8 +561,8 @@ (let ((gbuf (or gdbsrc-associated-buffer current-gdb-buffer))) (cond ((eq (current-buffer) gbuf) (and gdb-arrow-extent - (extent-buffer gdb-arrow-extent) - (progn (pop-to-buffer (extent-buffer gdb-arrow-extent)) + (extent-object gdb-arrow-extent) + (progn (pop-to-buffer (extent-object gdb-arrow-extent)) (goto-char (extent-start-position gdb-arrow-extent))))) ((buffer-name gbuf) (pop-to-buffer gbuf)) ((y-or-n-p "No debugger. Start a new one? ") @@ -840,7 +841,7 @@ (ad-set-arg 2 'source) ; tell it not to select the gdb window ad-do-it (save-excursion - (let* ((buf (extent-buffer gdb-arrow-extent)) + (let* ((buf (extent-object gdb-arrow-extent)) (win (get-buffer-window buf))) (setq gdbsrc-last-src-buffer buf) (select-window win) diff -r 30df88044ec6 -r b82b59fe008d lisp/comint/history.el --- a/lisp/comint/history.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/comint/history.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,3 +1,5 @@ +;;; history.el --- Generic history stuff + ;; Copyright (C) 1989 Free Software Foundation, Inc. ;; This file is part of XEmacs. @@ -16,6 +18,10 @@ ;; 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: Not in FSF + +;;; Commentary: + ;; suggested generic history stuff -- tale ;; This is intended to provided easy access to a list of elements @@ -68,6 +74,8 @@ ;; ToDo: history-isearch +;;; Code: + (provide 'history) (defvar history-last-search "" @@ -163,3 +171,5 @@ (insert menu) (display-buffer buffer)) (with-output-to-temp-buffer buffer (princ menu))))) + +;;; history.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/comint/telnet.el --- a/lisp/comint/telnet.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/comint/telnet.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,6 @@ ;;; telnet.el --- run a telnet session from within an Emacs buffer -;;; Copyright (C) 1985, 1988, 1992, 1993, 1994 Free Software Foundation, Inc. +;;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc. ;; Author: William F. Schelter ;; Keywords: comm, unix @@ -20,9 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -54,17 +55,13 @@ (defvar telnet-new-line "\r") (defvar telnet-mode-map nil) -(make-variable-buffer-local 'telnet-new-line) -(defvar telnet-default-prompt-pattern "^[^#$%>\n]*[#$%>] *") -(defvar telnet-prompt-pattern telnet-default-prompt-pattern) +(defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *") (defvar telnet-replace-c-g nil) -(make-variable-buffer-local 'telnet-replace-c-g) -(defvar telnet-remote-echoes t - "True if the telnet process will echo input.") -(make-variable-buffer-local 'telnet-remote-echoes) -(defvar telnet-interrupt-string "\C-c" - "String sent by C-c.") -(make-variable-buffer-local 'telnet-interrupt-string) +(make-variable-buffer-local + (defvar telnet-remote-echoes t + "True if the telnet process will echo input.")) +(make-variable-buffer-local + (defvar telnet-interrupt-string "\C-c" "String sent by C-c.")) (defvar telnet-count 0 "Number of output strings read from the telnet process @@ -93,6 +90,7 @@ (interactive) (process-send-string nil "\C-z")) +;; XEmacs change (Keep telnet- prefix) (defun telnet-send-process-next-char () (interactive) (process-send-string nil @@ -104,22 +102,19 @@ ; initialization on first load. (if telnet-mode-map nil - (progn - (setq telnet-mode-map (make-sparse-keymap)) - (set-keymap-name telnet-mode-map 'telnet-mode-map) - (set-keymap-parents telnet-mode-map (list comint-mode-map)) - (define-key telnet-mode-map "\C-m" 'telnet-send-input) - ;;(define-key telnet-mode-map "\C-j" 'telnet-send-input) - (define-key telnet-mode-map "\C-c\C-q" 'telnet-send-process-next-char) - (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob) - (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z))) + (setq telnet-mode-map (nconc (make-sparse-keymap) comint-mode-map)) + (define-key telnet-mode-map "\C-m" 'telnet-send-input) +; (define-key telnet-mode-map "\C-j" 'telnet-send-input) + (define-key telnet-mode-map "\C-c\C-q" 'send-process-next-char) + (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob) + (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z)) ;;maybe should have a flag for when have found type (defun telnet-check-software-type-initialize (string) "Tries to put correct initializations in. Needs work." (let ((case-fold-search t)) (cond ((string-match "unix" string) - (setq telnet-prompt-pattern shell-prompt-pattern) + (setq telnet-prompt-pattern comint-prompt-pattern) (setq telnet-new-line "\n")) ((string-match "tops-20" string) ;;maybe add telnet-replace-c-g (setq telnet-prompt-pattern "[@>] *")) diff -r 30df88044ec6 -r b82b59fe008d lisp/dired/ange-ftp.el --- a/lisp/dired/ange-ftp.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/dired/ange-ftp.el Mon Aug 13 08:46:56 2007 +0200 @@ -1461,6 +1461,87 @@ directory)))) ;;;; ------------------------------------------------------------ +;;;; Remote file name syntax support. +;;;; ------------------------------------------------------------ +(defvar ange-ftp-name-format + '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4)) + "*Format of a fully expanded remote file name. +This is a list of the form \(REGEXP HOST USER NAME\), +where REGEXP is a regular expression matching +the full remote name, and HOST, USER, and NAME are the numbers of +parenthesized expressions in REGEXP for the components (in that order).") + +(defun ange-ftp-real-load (&rest args) + (ange-ftp-run-real-handler 'load args)) + +(defmacro ange-ftp-ftp-name-component (n ns name) + "Extract the Nth ftp file name component from NS." + (` (let ((elt (nth (, n) (, ns)))) + (if (match-beginning elt) + (substring (, name) (match-beginning elt) (match-end elt)))))) + +(defvar ange-ftp-ftp-name-arg "") +(defvar ange-ftp-ftp-name-res nil) + +;; Parse NAME according to `ange-ftp-name-format' (which see). +;; Returns a list (HOST USER NAME), or nil if NAME does not match the format. +(defun ange-ftp-ftp-name (name) + (if (string-equal name ange-ftp-ftp-name-arg) + ange-ftp-ftp-name-res + (setq ange-ftp-ftp-name-arg name + ange-ftp-ftp-name-res + (save-match-data + (if (posix-string-match (car ange-ftp-name-format) name) + (let* ((ns (cdr ange-ftp-name-format)) + (host (ange-ftp-ftp-name-component 0 ns name)) + (user (ange-ftp-ftp-name-component 1 ns name)) + (name (ange-ftp-ftp-name-component 2 ns name))) + (if (zerop (length user)) + (setq user (ange-ftp-get-user host))) + (list host user name)) + nil))))) + +;; Take a FULLNAME that matches according to ange-ftp-name-format and +;; replace the name component with NAME. +(defun ange-ftp-replace-name-component (fullname name) + (save-match-data + (if (posix-string-match (car ange-ftp-name-format) fullname) + (let* ((ns (cdr ange-ftp-name-format)) + (elt (nth 2 ns))) + (concat (substring fullname 0 (match-beginning elt)) + name + (substring fullname (match-end elt))))))) + +(defun ange-ftp-file-local-copy (file) + (let* ((fn1 (expand-file-name file)) + (pa1 (ange-ftp-ftp-name fn1))) + (if pa1 + (let ((tmp1 (ange-ftp-make-tmp-name (car pa1)))) + (ange-ftp-copy-file-internal fn1 tmp1 t nil + (format "Getting %s" fn1)) + tmp1)))) + +(defun ange-ftp-load (file &optional noerror nomessage nosuffix) + (if (ange-ftp-ftp-name file) + (let ((tryfiles (if nosuffix + (list file) + (list (concat file ".elc") (concat file ".el") file))) + copy) + (while (and tryfiles (not copy)) + (condition-case error + (setq copy (ange-ftp-file-local-copy (car tryfiles))) + (ftp-error nil)) + (setq tryfiles (cdr tryfiles))) + (if copy + (unwind-protect + (funcall 'load copy noerror nomessage nosuffix) + (delete-file copy)) + (or noerror + (signal 'file-error (list "Cannot open load file" file))))) + (ange-ftp-real-load file noerror nomessage nosuffix))) +(put 'load 'ange-ftp 'ange-ftp-load) + +;;;; ------------------------------------------------------------ ;;;; FTP process filter support. ;;;; ------------------------------------------------------------ @@ -4958,6 +5039,7 @@ (ange-ftp-overwrite-fn 'expand-file-name) (ange-ftp-overwrite-fn 'file-name-all-completions) (ange-ftp-overwrite-fn 'file-name-completion) +(ange-ftp-overwrite-fn 'load) (or (memq 'ange-ftp-set-buffer-mode find-file-hooks) (setq find-file-hooks diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/advise-eval-region.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/edebug/advise-eval-region.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,46 @@ +;;; advise-eval-region.el --- Wrap advice around eval-region +;; Copyright (C) 1996 Miranova Systems, Inc. + +;; Original-Author: Unknown +;; Adapted-By: Steven L Baur +;; Keywords: extensions lisp + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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: + +;; This file splits out advice to eval-region formerly done in cl-read.el. +;; Due to the way cl-read.el reads itself in twice during bytecompilation, +;; and the fact that functions shouldn't be advised twice, I split this out +;; into its own file. + +;;; Code: + +(require 'advice) + +;; Advise the redefined eval-region +(defadvice eval-region (around cl-read activate) + "Use the reader::read instead of the original read if cl-read-active." + (with-elisp-eval-region (not cl-read-active) + ad-do-it)) + +(provide 'advise-eval-region) + +;;; advise-eval-region.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/cl-read.el --- a/lisp/edebug/cl-read.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/edebug/cl-read.el Mon Aug 13 08:46:56 2007 +0200 @@ -2,23 +2,27 @@ ;; ;; Copyright (C) 1993 by Guido Bosch -;; This file is written in GNU Emacs Lisp, but not (yet) part of GNU Emacs. +;; This file is part of XEmacs -;; The software contained in this file 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 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;; +;;; Synched up with: Not in FSF + +;;; Commentary: + ;; Please send bugs and comments to the author. ;; ;; @@ -204,8 +208,8 @@ ; Change History ; ; $Log: cl-read.el,v $ -; Revision 1.1.1.2 1996/12/18 03:46:06 steve -; XEmacs 19.15-b2 +; Revision 1.1.1.3 1996/12/18 03:54:28 steve +; XEmacs 19.15-b3 ; ; Revision 1.19 94/03/21 19:59:24 liberte ; Add invalid-cl-read-syntax error symbol. @@ -302,11 +306,15 @@ ; ; -;; -(require 'cl) +;;; Code: +(require 'cl) +;; Thou shalt evaluate a defadvice only once, or thou shalt surely lose. -sb +(require 'advise-eval-region) + +;; load before compiling +;; This is ugly, but apparently the only way to do it :-( -sb (provide 'cl-read) -;; load before compiling (require 'cl-read) ;; bootstrapping with cl-packages @@ -1315,7 +1323,7 @@ (prin1 (car values) t)) (require 'eval-reg "eval-reg") -(require 'advice) +; (require 'advice) ;; installing/uninstalling the cl reader @@ -1345,14 +1353,6 @@ (cl-reader-install) (cl-reader-uninstall) -;; Advise the redefined eval-region -(defadvice eval-region (around cl-read activate) - "Use the reader::read instead of the original read if cl-read-active." - (with-elisp-eval-region (not cl-read-active) - (ad-do-it))) -;;(ad-unadvise 'eval-region) - - (add-hook 'emacs-lisp-mode-hook 'cl-reader-autoinstall-function) '(defvar read-syntax) @@ -1397,4 +1397,5 @@ (run-hooks 'cl-read-load-hooks) -;; end cl-read.el + +;; cl-read.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/cl-read.el-19.15-b1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/edebug/cl-read.el-19.15-b1 Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,1400 @@ +;; Customizable, Common Lisp like reader for Emacs Lisp. +;; +;; Copyright (C) 1993 by Guido Bosch + +;; This file is written in GNU Emacs Lisp, but not (yet) part of GNU Emacs. + +;; The software contained in this file 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. +;; +;; Please send bugs and comments to the author. +;; +;; +;; This program is still under development. Neither the author nor +;; his employer accepts responsibility to anyone for the consequences of +;; using it or for whether it serves any particular purpose or works +;; at all. + + +;; Introduction +;; ------------ +;; +;; This package replaces the standard Emacs Lisp reader (implemented +;; as a set of built-in Lisp function in C) by a flexible and +;; customizable Common Lisp like one (implemented entirely in Emacs +;; Lisp). During reading of Emacs Lisp source files, it is about 40% +;; slower than the built-in reader, but there is no difference in +;; loading byte compiled files - they dont contain any syntactic sugar +;; and are loaded with the built in subroutine `load'. +;; +;; The user level functions for defining read tables, character and +;; dispatch macros are implemented according to the Commom Lisp +;; specification by Steel's (2nd edition), but the read macro functions +;; themselves are implemented in a slightly different way, because the +;; basic character reading is done in an Emacs buffer, and not by +;; using the primitive functions `read-char' and `unread-char', as real +;; CL does. To get 100% compatibility with CL, the above functions +;; (or their equivalents) must be implemented as subroutines. +;; +;; Another difference with real CL reading is that basic tokens (symbols +;; numbers, strings, and a few more) are still read by the original +;; built-in reader. This is necessary to get reasonable performance. +;; As a consquence, the read syntax of basic tokens can't be +;; customized. + +;; Most of the built-in reader syntax has been replaced by lisp +;; character macros: parentheses and brackets, simple and double +;; quotes, semicolon comments and the dot. In addition to that, the +;; following new syntax features are provided: + +;; Backquote-Comma-Atsign Macro: `(,el ,@list) +;; +;; (the clumsy Emacs Lisp syntax (` ((, el) (,@ list))) is also +;; supported, but with one restriction: the blank behind the quote +;; characters is mandatory when using the old syntax. The cl reader +;; needs it as a landmark to distinguish between old and new syntax. +;; An example: +;; +;; With blanks, both readers read the same: +;; (` (, (head)) (,@ (tail))) -std-read-> (` (, (head)) (,@ (tail))) +;; (` (, (head)) (,@ (tail))) -cl-read-> (` (, (head)) (,@ (tail))) +;; +;; Without blanks, the form is interpreted differently by the two readers: +;; (`(,(head)) (,@(tail))) -std-read-> (` (, (head)) (,@ (tail))) +;; (`(,(head)) (,@(tail))) -cl-read-> ((` ((, ((head)))) ((,@ ((tail))))) +;; +;; +;; Dispatch Character Macro" `#' +;; +;; #' function quoting +;; #\ character syntax +;; #.
read time evaluation +;; #p, #P paths +;; #+, #- conditional reading +;; #=, ## tags for shared structure reading +;; +;; Other read macros can be added easily (see the definition of the +;; above ones in this file, using the functions `set-macro-character' +;; and `set-dispatch-macro-character') +;; +;; The Cl reader is mostly downward compatile, (exception: backquote +;; comma macro, see above). E.g., this file, which is written entirely +;; in the standard Emacs Lisp syntax, can be read and compiled with the +;; cl-reader activated (see Examples below). + +;; This also works with package.el for Common Lisp packages. + + +;; Requirements +;; ------------ +;; The package runs on Emacs 18 and Emacs 19 (FSF and Lucid) It is +;; built on top of Dave Gillespie's cl.el package (version 2.02 or +;; later). The old one (from Ceazar Quiroz, still shiped with some +;; Emacs 19 disributions) will not do. + +;; Usage +;; ----- +;; The package is implemented as a kind of minor mode to the +;; emacs-lisp-mode. As most of the Emacs Lisp files are still written +;; in the standard Emacs Lisp syntax, the cl reader is only activated +;; on elisp files whose property lines contain the following entry: +;; +;; -*- Read-Syntax: Common-Lisp -*- +;; +;; Note that both property name ("Read-Syntax") and value +;; ("Common-Lisp") are not case sensitive. There can also be other +;; properties in this line: +;; +;; -*- Mode: Emacs-Lisp; Read-Syntax: Common-Lisp -*- + +;; Installation +;; ------------ +;; Save this file in a directory where Emacs will find it, then +;; byte compile it (M-x byte-compile-file). +;; +;; A permanent installation of the package can be done in two ways: +;; +;; 1.) If you want to have the package always loaded, put this in your +;; .emacs, or in just the files that require it: +;; +;; (require 'cl-read) +;; +;; 2.) To load the cl-read package automatically when visiting an elisp +;; file that needs it, it has to be installed using the +;; emacs-lisp-mode-hook. In this case, put the following function +;; definition and add-hook form in your .emacs: +;; +;; (defun cl-reader-autoinstall-function () +;; "Activates the Common Lisp style reader for emacs-lisp-mode buffers, +;; if the property line has a local variable setting like this: +;; \;\; -*- Read-Syntax: Common-Lisp -*-" +;; +;; (or (boundp 'local-variable-hack-done) +;; (let (local-variable-hack-done +;; (case-fold-search t)) +;; (hack-local-variables-prop-line 't) +;; (cond +;; ((and (boundp 'read-syntax) +;; read-syntax +;; (string-match "^common-lisp$" (symbol-name read-syntax))) +;; (require 'cl-read) +;; (make-local-variable 'cl-read-active) +;; (setq cl-read-active 't)))))) +;; +;; (add-hook 'emacs-lisp-mode-hook 'cl-reader-autoinstall-function) +;; +;; The `cl-reader-autoinstall-function' function tests for the +;; presence of the correct Read-Syntax property in the first line of +;; the file and loads the cl-read package if necessary. cl-read +;; replaces the following standard elisp functions: +;; +;; - read +;; - read-from-string +;; - eval-current-buffer +;; - eval-buffer +;; - eval-region +;; - eval-expression (to call reader explicitly) +;; +;; There may be other built-in functions that need to be replaced +;; (e.g. load). The behavior of the new reader function depends on +;; the value of the buffer local variable `cl-read-active': if it is +;; nil, they just call the original functions, otherwise they call the +;; cl reader. If the cl reader is active in a buffer, this is +;; indicated in the modeline by the string "CL" (minor mode like). +;; + +;; Examples: +;; --------- +;; After having installed the package as described above, the +;; following forms can be evaluated (M-C-x) with the cl reader being +;; active. (make sure that the mode line displays "(Emacs-Lisp CL)") +;; +;; (setq whitespaces '(#\space #\newline #\tab)) +;; (setq more-whitespaces `(#\page ,@whitespaces #\linefeed)) +;; (setq whitespace-strings (mapcar #'char-to-string more-whitespaces)) +;; +;; (setq shared-struct '(#1=[hello world] #1# #1#)) +;; (progn (setq cirlist '#1=(a b . #1#)) 't) +;; +;; This file, though written in standard Emacs Lisp syntax, can also be +;; compiled with the cl reader active: Type M-x byte-compile-file + +;; TO DO List: +;; ----------- +;; - Provide a replacement for load so that uncompiled cl syntax +;; source file can be loaded, too. For now prohibit loading un-bytecompiled. +;; - Do we really need the (require 'cl) dependency? Yes. +;; - More read macros: #S for structs, #A for array, #X for hex, #nR for radix +;; - Refine the error signaling mechanism. +;; - invalid-cl-read-syntax is now defined. what else? + + +; Change History +; +; $Log: cl-read.el-19.15-b1,v $ +; Revision 1.1.1.1 1996/12/18 03:54:31 steve +; XEmacs 19.15-b3 +; +; Revision 1.19 94/03/21 19:59:24 liberte +; Add invalid-cl-read-syntax error symbol. +; Add reader::read-sexp and reader::read-sexp-func to allow customization +; based on the results of reading. +; Remove more dependencies on cl-package. +; Remove reader::eval-current-buffer, eval-buffer, and eval-region, +; and use elisp-eval-region package instead. +; +; Revision 1.18 94/03/04 23:42:24 liberte +; Fix typos in comments. +; +; Revision 1.17 93/11/24 12:04:09 bosch +; cl-packages dependency removed. `reader::read-constituent' and +; corresponding variables moved to cl-packages.el. +; Multi-line comment #| ... |# dispatch character read macro added. +; +; Revision 1.16 1993/11/23 10:21:02 bosch +; Patches from Daniel LaLiberte integrated. +; +; Revision 1.15 1993/11/18 21:21:10 bosch +; `reader::symbol-regexp1' modified. +; +; Revision 1.14 1993/11/17 19:06:32 bosch +; More characters added to `reader::symbol-characters'. +; `reader::read-constituent' modified. +; defpackage form added. +; +; Revision 1.13 1993/11/16 13:06:41 bosch +; - Symbol reading for CL package convention implemented. +; Variables `reader::symbol-characters', `reader::symbol-regexp1' and +; `reader::symbol-regexp2' and functions `reader::lookup-symbol' and +; `reader::read-constituent' added. +; - Prefix for internal symbols is now "reader::" (Common Lisp +; compatible). +; - Dispatch character macro #: for reading uninterned symbols added. +; +; Revision 1.12 1993/11/07 19:29:07 bosch +; Minor bug fix. +; +; Revision 1.11 1993/11/07 19:23:59 bosch +; Comment added. Character read macro #\ rewritten. Now reads +; e.g. #\meta-control-x. Needs to be checked. +; fix in `reader::restore-shared-structure'. `cl-reader-autoinstall-function' improved. +; +; Revision 1.10 1993/11/06 18:35:35 bosch +; Included Daniel LaLiberte's Patches. +; Efficiency of `reader::restore-shared-structure' improved. +; Implementation notes for shared structure reading added. +; +; Revision 1.9 1993/09/08 07:44:54 bosch +; Comment modified. +; +; Revision 1.8 1993/08/10 13:43:34 bosch +; Hook function `cl-reader-autoinstall-function' for automatic installation added. +; Buffer local variable `cl-read-active' added: together with the above +; hook it allows the file specific activation of the cl reader. +; +; Revision 1.7 1993/08/10 10:35:21 bosch +; Functions `read*' and `read-from-string*' renamed into `reader::read' +; and `reader::read-from-string'. Whitespace character skipping after +; recursive reader calls removed (Emacs 19 should not need this). +; Functions `cl-reader-install' and `cl-reader-uninstall' updated. +; Introduction text and function comments added. +; +; Revision 1.6 1993/08/09 15:36:05 bosch Function `read*' now nearly +; elisp compatible (no functions as streams, yet -- I don't think I +; will ever implement this, it would be far too slow). Elisp +; compatible function `read-from-string*' added. Replacements for +; `eval-current-buffer', `eval-buffer' and `eval-region' added. +; Renamed feature `cl-dg' in `cl', as Dave Gillespie's cl.el package +; is rather stable now. Function `cl-reader-install' and +; `cl-reader-uninstall' modified. +; +; Revision 1.5 1993/08/09 10:23:35 bosch +; Functions `copy-readtable' and `set-syntax-from-character' added. +; Variable `reader::internal-standard-readtable' added. Standard +; readtable initialization modified. Whitespace skipping placed back +; inside the read loop. +; +; Revision 1.4 1993/05/14 13:00:48 bosch +; Included patches from Daniel LaLiberte. +; +; Revision 1.3 1993/05/11 09:57:39 bosch +; `read*' renamed in `reader::read-from-buffer'. `read*' now can read +; from strings. +; +; Revision 1.2 1993/05/09 16:30:50 bosch +; (require 'cl-read) added. +; Calling of `{before,after}-read-hook' modified. +; +; Revision 1.1 1993/03/29 19:37:21 bosch +; Initial revision +; +; + +;; +(require 'cl) + +(provide 'cl-read) +;; load before compiling +(require 'cl-read) + +;; bootstrapping with cl-packages +;; defpackage and in-package are ignored until cl-read is installed. +'(defpackage reader + (:nicknames "rd") + (:use el) + (:export + cl-read-active + copy-readtable + set-macro-character + get-macro-character + set-syntax-from-character + make-dispatch-macro-character + set-dispatch-macro-character + get-dispatch-macro-character + before-read-hook + after-read-hook + cl-reader-install + cl-reader-uninstall + read-syntax + cl-reader-autoinstall-function)) + +'(in-package reader) + + +(autoload 'compiled-function-p "bytecomp") + +;; This makes cl-read behave as a kind of minor mode: + +(make-variable-buffer-local 'cl-read-active) +(defvar cl-read-active nil + "Buffer local variable that enables Common Lisp style syntax reading.") +(setq-default cl-read-active nil) + +(or (assq 'cl-read-active minor-mode-alist) + (setq minor-mode-alist + (cons '(cl-read-active " CL") minor-mode-alist))) + +;; Define a new error symbol: invalid-cl-read-syntax +;; XEmacs change +(define-error 'invalid-cl-read-syntax "Invalid CL read syntax" + 'invalid-read-syntax) + +(defun reader::error (msg &rest args) + (signal 'invalid-cl-read-syntax (list (apply 'format msg args)))) + + +;; The readtable + +(defvar reader::readtable-size 256 + "The size of a readtable." + ;; Actually, the readtable is a vector of size (1+ + ;; reader::readtable-size), because the last element contains the + ;; symbol `readtable', used for defining `readtablep. + ) + +;; An entry of the readtable must have one of the following forms: +;; +;; 1. A symbol, one of {illegal, constituent, whitespace}. It means +;; the character's reader class. +;; +;; 2. A function (i.e., a symbol with a function definition, a byte +;; compiled function or an uncompiled lambda expression). It means the +;; character is a macro character. +;; +;; 3. A vector of length `reader::readtable-size'. Elements of this vector +;; may be `nil' or a function (see 2.). It means the charater is a +;; dispatch character, and the vector its dispatch fucntion table. + +(defvar *readtable*) +(defvar reader::internal-standard-readtable) + +(defun* copy-readtable + (&optional (from-readtable *readtable*) + (to-readtable + (make-vector (1+ reader::readtable-size) 'illegal))) + "Return a copy of FROM-READTABLE \(default: *readtable*\). If the +FROM-READTABLE argument is provided as `nil', make a copy of a +standard \(CL-like\) readtable. If TO-READTABLE is provided, modify and +return it, otherwise create a new readtable object." + + (if (null from-readtable) + (setq from-readtable reader::internal-standard-readtable)) + + (loop for i to reader::readtable-size + as from-syntax = (aref from-readtable i) + do (setf (aref to-readtable i) + (if (vectorp from-syntax) + (copy-sequence from-syntax) + from-syntax)) + finally return to-readtable)) + + +(defmacro reader::get-readtable-entry (char readtable) + (` (aref (, readtable) (, char)))) + +(defun set-macro-character + (char function &optional readtable) + "Makes CHAR to be a macro character with FUNCTION as handler. +When CHAR is seen by reader::read-from-buffer, it calls FUNCTION. +Returns always t. Optional argument READTABLE is the readtable to set +the macro character in (default: *readtable*)." + (or readtable (setq readtable *readtable*)) + (or (reader::functionp function) + (reader::error "Not valid character macro function: %s" function)) + (setf (reader::get-readtable-entry char readtable) function) + t) + + +(put 'set-macro-character 'edebug-form-spec + '(&define sexp function-form &optional sexp)) +(put 'set-macro-character 'lisp-indent-function 1) + +(defun get-macro-character (char &optional readtable) + "Return the function associated with the character CHAR. +Optional READTABLE defaults to *readtable*. If char isn't a macro +character in READTABLE, return nil." + (or readtable (setq readtable *readtable*)) + (let ((entry (reader::get-readtable-entry char readtable))) + (if (reader::functionp entry) + entry))) + +(defun set-syntax-from-character + (to-char from-char &optional to-readtable from-readtable) + "Make the syntax of TO-CHAR be the same as the syntax of FROM-CHAR. +Optional TO-READTABLE and FROM-READTABLE are the corresponding tables +to use. TO-READTABLE defaults to the current readtable +\(*readtable*\), and FROM-READTABLE to nil, meaning to use the +syntaxes from the standard Lisp Readtable." + (or to-readtable (setq to-readtable *readtable*)) + (or from-readtable + (setq from-readtable reader::internal-standard-readtable)) + (let ((from-syntax + (reader::get-readtable-entry from-char from-readtable))) + (if (vectorp from-syntax) + ;; dispatch macro character table + (setq from-syntax (copy-sequence from-syntax))) + (setf (reader::get-readtable-entry to-char to-readtable) + from-syntax)) + t) + + +;; Dispatch macro character +(defun make-dispatch-macro-character (char &optional readtable) + "Let CHAR be a dispatch macro character in READTABLE (default: *readtable*)." + (or readtable (setq readtable *readtable*)) + (setf (reader::get-readtable-entry char readtable) + ;; create a dispatch character table + (make-vector reader::readtable-size nil))) + + +(defun set-dispatch-macro-character + (disp-char sub-char function &optional readtable) + "Make reading CHAR1 followed by CHAR2 be handled by FUNCTION. +Optional argument READTABLE (default: *readtable*). CHAR1 must first be +made a dispatch char with `make-dispatch-macro-character'." + (or readtable (setq readtable *readtable*)) + (let ((disp-table (reader::get-readtable-entry disp-char readtable))) + ;; check whether disp-char is a valid dispatch character + (or (vectorp disp-table) + (reader::error "`%c' not a dispatch macro character." disp-char)) + ;; check whether function is a valid function + (or (reader::functionp function) + (reader::error "Not valid dispatch character macro function: %s" + function)) + (setf (aref disp-table sub-char) function))) + +(put 'set-dispatch-macro-character 'edebug-form-spec + '(&define sexp sexp function-form &optional sexp)) +(put 'set-dispatch-macro-character 'lisp-indent-function 2) + + +(defun get-dispatch-macro-character + (disp-char sub-char &optional readtable) + "Return the macro character function for SUB-CHAR unser DISP-CHAR. +Optional READTABLE defaults to *readtable*. +Returns nil if there is no such function." + (or readtable (setq readtable *readtable*)) + (let ((disp-table (reader::get-readtable-entry disp-char readtable))) + (and (vectorp disp-table) + (reader::functionp (aref disp-table sub-char)) + (aref disp-table sub-char)))) + + +(defun reader::functionp (function) + ;; Check whether FUNCTION is a valid function object to be used + ;; as (dispatch) macro character function. + (or (and (symbolp function) (fboundp function)) + (compiled-function-p function) + (and (consp function) (eq (first function) 'lambda)))) + + +;; The basic reader loop + +;; shared and circular structure reading +(defvar reader::shared-structure-references nil) +(defvar reader::shared-structure-labels nil) + +(defun reader::read-sexp-func (point func) + ;; This function is called to read a sexp at POINT by calling FUNC. + ;; reader::read-sexp-func is here to be advised, e.g. by Edebug, + ;; to do something before or after reading. + (funcall func)) + +(defmacro reader::read-sexp (point &rest body) + ;; Called to return a sexp starting at POINT. BODY creates the sexp result + ;; and should leave point after the sexp. The body is wrapped in + ;; a lambda expression and passed to reader::read-sexp-func. + (` (reader::read-sexp-func (, point) (function (lambda () (,@ body)))))) + +(put 'reader::read-sexp 'edebug-form-spec '(form body)) +(put 'reader::read-sexp 'lisp-indent-function 2) +(put 'reader::read-sexp 'lisp-indent-hook 1) ;; Emacs 18 + + +(defconst before-read-hook nil) +(defconst after-read-hook nil) + +;; Set the hooks to `read-char' in order to step through the reader. e.g. +;; (add-hook 'before-read-hook '(lambda () (message "before") (read-char))) +;; (add-hook 'after-read-hook '(lambda () (message "after") (read-char))) + +(defmacro reader::encapsulate-recursive-call (reader-call) + ;; Encapsulate READER-CALL, a form that contains a recursive call to + ;; the reader, for usage inside the main reader loop. The macro + ;; wraps two hooks around READER-CALL: `before-read-hook' and + ;; `after-read-hook'. + ;; + ;; If READER-CALL returns normally, the macro exits immediately from + ;; the surrounding loop with the value of READER-CALL as result. If + ;; it exits non-locally (with tag `reader-ignore'), it just returns + ;; the value of READER-CALL, in which case the surrounding reader + ;; loop continues its execution. + ;; + ;; In both cases, `before-read-hook' and `after-read-hook' are + ;; called before and after executing READER-CALL. + ;; Are there any other uses for these hooks? Edebug doesn't need them. + (` (prog2 + (run-hooks 'before-read-hook) + ;; this catch allows to ignore the return, in the case that + ;; reader::read-from-buffer should continue looping (e.g. + ;; skipping over comments) + (catch 'reader-ignore + ;; this only works inside a block (e.g., in a loop): + ;; go outside + (return + (prog1 + (, reader-call) + ;; this occurrence of the after hook fires if the + ;; reader-call returns normally ... + (run-hooks 'after-read-hook)))) + ;; ... and that one if it was thrown to the tag 'reader-ignore + (run-hooks 'after-read-hook)))) + +(put 'reader::encapsulate-recursive-call 'edebug-form-spec '(form)) +(put 'reader::encapsulate-recursive-call 'lisp-indent-function 0) + +(defun reader::read-from-buffer (&optional stream reader::recursive-p) + (or (bufferp stream) + (reader::error "Sorry, can only read on buffers")) + (if (not reader::recursive-p) + ;; set up environment for shared structure reading + (let (reader::shared-structure-references + reader::shared-structure-labels + tmp-sexp) + ;; the reader returns an unshared sexpr, possibly containing + ;; symbolic references + (setq tmp-sexp (reader::read-from-buffer stream 't)) + (if ;; sexpr actually contained shared structures + reader::shared-structure-references + (reader::restore-shared-structure tmp-sexp) + ;; it did not, so don't bother about restoring + tmp-sexp)) + + (loop for char = (following-char) + for entry = (reader::get-readtable-entry char *readtable*) + if (eobp) do (reader::error "End of file during reading") + do + (cond + + ((eq entry 'illegal) + (reader::error "`%c' has illegal character syntax" char)) + + ;; skipping whitespace characters must be done inside this + ;; loop as character macro subroutines may return without + ;; leaving the loop using (throw 'reader-ignore ...) + ((eq entry 'whitespace) + (forward-char 1) + ;; skip all whitespace + (while (eq 'whitespace + (reader::get-readtable-entry + (following-char) *readtable*)) + (forward-char 1))) + + ;; for every token starting with a constituent character + ;; call the built-in reader (symbols, numbers, strings, + ;; characters with ? syntax) + ((eq entry 'constituent) + (reader::encapsulate-recursive-call + (reader::read-constituent stream))) + + ((vectorp entry) + ;; Dispatch macro character. The dispatch macro character + ;; function is contained in the vector `entry', at the + ;; place indicated by , the first non-digit + ;; character following the : + ;; * + (reader::encapsulate-recursive-call + (loop initially do (forward-char 1) + for sub-char = (prog1 (following-char) + (forward-char 1)) + while (memq sub-char + '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) + collect sub-char into digit-args + finally + (return + (funcall + ;; no test is done here whether a non-nil + ;; contents is a correct dispatch character + ;; function to apply. + (or (aref entry sub-char) + (reader::error + "Undefined subsequent dispatch character `%c'" + sub-char)) + stream + sub-char + (string-to-int + (apply 'concat + (mapcar + 'char-to-string digit-args)))))))) + + (t + ;; must be a macro character. In this case, `entry' is + ;; the function to be called + (reader::encapsulate-recursive-call + (progn + (forward-char 1) + (funcall entry stream char)))))))) + + +;; Constituent reader fix for Emacs 18 +(if (string-match "^19" emacs-version) + (defun reader::read-constituent (stream) + (reader::read-sexp (point) + (reader::original-read stream))) + + (defun reader::read-constituent (stream) + (reader::read-sexp (point) + (prog1 (reader::original-read stream) + ;; For Emacs 18, backing up is necessary because the `read' function + ;; reads one character too far after reading a symbol or number. + ;; This doesnt apply to reading chars (e.g. ?n). + ;; This still loses for escaped chars. + (if (not (eq (reader::get-readtable-entry + (preceding-char) *readtable*) 'constituent)) + (forward-char -1)))))) + + +;; Make the default current CL readtable + +(defconst *readtable* + (loop with raw-readtable = + (make-vector (1+ reader::readtable-size) 'illegal) + initially do (setf (aref raw-readtable reader::readtable-size) + 'readtable) + for entry in + '((constituent ?! ?@ ?$ ?% ?& ?* ?_ ?- ?+ ?= ?/ ?\\ ?0 ?1 ?2 + ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?: ?~ ?> ?< ?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 ?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) + (whitespace ? ?\t ?\n ?\r ?\f) + + ;; The following CL character classes are only useful for + ;; token parsing. We don't need them, as token parsing is + ;; left to the built-in reader. + ;; (single-escape ?\\) + ;; (multiple-escape ?|) + ) + do + (loop for char in (rest entry) + do (setf (reader::get-readtable-entry char raw-readtable) + (first entry))) + finally return raw-readtable) + "The current readtable.") + + +;; Variables used non-locally in the standard readmacros +(defvar reader::context) +(defvar reader::stack) +(defvar reader::recursive-p) + + +;;;; Read macro character definitions + +;;; Hint for modifying, testing and debugging new read macros: All the +;;; read macros and dispatch character macros below are defined in +;;; the `*readtable*'. Modifications or +;;; instrumenting with edebug are effective immediately without having to +;;; copy the internal readtable to the standard *readtable*. However, +;;; if you wish to modify reader::internal-standard-readtable, then +;;; you must recopy *readtable*. + +;; Chars and strings + +;; This is defined to distinguish chars from constituents +;; since chars are read by the standard reader without reading too far. +(set-macro-character ?\? + (function + (lambda (stream char) + (forward-char -1) + (reader::read-sexp (point) + (reader::original-read stream))))) + +;; ?\M-\C-a + +;; This is defined to distinguish strings from constituents +;; since backing up after reading a string is simpler. +(set-macro-character ?\" + (function + (lambda (stream char) + (forward-char -1) + (reader::read-sexp (point) + (prog1 (reader::original-read stream) + ;; This is not needed with Emacs 19, but it is OK. See above. + (if (/= (preceding-char) ?\") + (forward-char -1))))))) + +;; Lists and dotted pairs +(set-macro-character ?\( + (function + (lambda (stream char) + (reader::read-sexp (1- (point)) + (catch 'read-list + (let ((reader::context 'list) reader::stack ) + ;; read list elements up to a `.' + (catch 'dotted-pair + (while t + (setq reader::stack (cons (reader::read-from-buffer stream 't) + reader::stack)))) + ;; In dotted pair. Read one more element + (setq reader::stack (cons (reader::read-from-buffer stream 't) + reader::stack) + ;; signal it to the closing paren + reader::context 'dotted-pair) + ;; Next char *must* be the closing paren that throws read-list + (reader::read-from-buffer stream 't) + ;; otherwise an error is signalled + (reader::error "Illegal dotted pair read syntax"))))))) + +(set-macro-character ?\) + (function + (lambda (stream char) + (cond ((eq reader::context 'list) + (throw 'read-list (nreverse reader::stack))) + ((eq reader::context 'dotted-pair) + (throw 'read-list (nconc (nreverse (cdr reader::stack)) + (car reader::stack)))) + (t + (reader::error "`)' doesn't end a list")))))) + +(set-macro-character ?\. + (function + (lambda (stream char) + (and (eq reader::context 'dotted-pair) + (reader::error "No more than one `.' allowed in list")) + (throw 'dotted-pair nil)))) + +;; '(#\a . #\b) +;; '(a . (b . c)) + +;; Vectors: [a b] +(set-macro-character ?\[ + (function + (lambda (stream char) + (reader::read-sexp (1- (point)) + (let ((reader::context 'vector)) + (catch 'read-vector + (let ((reader::context 'vector) + reader::stack) + (while t (push (reader::read-from-buffer stream 't) + reader::stack))))))))) + +(set-macro-character ?\] + (function + (lambda (stream char) + (if (eq reader::context 'vector) + (throw 'read-vector (apply 'vector (nreverse reader::stack))) + (reader::error "`]' doesn't end a vector"))))) + +;; Quote and backquote/comma macro +(set-macro-character ?\' + (function + (lambda (stream char) + (reader::read-sexp (1- (point)) + (list (reader::read-sexp (point) 'quote) + (reader::read-from-buffer stream 't)))))) + +(set-macro-character ?\` + (function + (lambda (stream char) + (if (= (following-char) ?\ ) + ;; old backquote syntax. This is ambigous, because + ;; (`(sexp)) is a valid form in both syntaxes, but + ;; unfortunately not the same. + ;; old syntax: read -> (` (sexp)) + ;; new syntax: read -> ((` (sexp))) + (reader::read-sexp (1- (point)) '\`) + (reader::read-sexp (1- (point)) + (list (reader::read-sexp (point) '\`) + (reader::read-from-buffer stream 't))))))) + +(set-macro-character ?\, + (function + (lambda (stream char) + (cond ((eq (following-char) ?\ ) + ;; old syntax + (reader::read-sexp (point) '\,)) + ((eq (following-char) ?\@) + (forward-char 1) + (cond ((eq (following-char) ?\ ) + (reader::read-sexp (point) '\,\@)) + (t + (reader::read-sexp (- (point) 2) + (list + (reader::read-sexp (point) '\,\@) + (reader::read-from-buffer stream 't)))))) + (t + (reader::read-sexp (1- (point)) + (list + (reader::read-sexp (1- (point)) '\,) + (reader::read-from-buffer stream 't)))))))) + +;; 'a +;; '(a b c) +;; (let ((a 10) (b '(20 30))) `(,a ,@b c)) +;; the old syntax is also supported: +;; (let ((a 10) (b '(20 30))) (` ((, a) (,@ b) c))) + +;; Single line character comment: ; +(set-macro-character ?\; + (function + (lambda (stream char) + (skip-chars-forward "^\n\r") + (throw 'reader-ignore nil)))) + + + +;; Dispatch character character # +(make-dispatch-macro-character ?\#) + +(defsubst reader::check-0-infix (n) + (or (= n 0) + (reader::error "Numeric infix argument not allowed: %d" n))) + + +(defalias 'search-forward-regexp 're-search-forward) + +;; nested multi-line comments #| ... |# +(set-dispatch-macro-character ?\# ?\| + (function + (lambda (stream char n) + (reader::check-0-infix n) + (let ((counter 0)) + (while (search-forward-regexp "#|\\||#" nil t) + (if (string-equal + (buffer-substring + (match-beginning 0) (match-end 0)) + "|#") + (cond ((> counter 0) + (decf counter)) + ((= counter 0) + ;; stop here + (goto-char (match-end 0)) + (throw 'reader-ignore nil)) + ('t + (reader::error "Unmatching closing multicomment"))) + (incf counter))) + (reader::error "Unmatching opening multicomment"))))) + +;; From cl-packages.el +(defconst reader::symbol-characters "[A-Za-z0-9-_!@$%^&*+=|~{}<>/]") +(defconst reader::symbol-regexp2 + (format "\\(%s+\\)" reader::symbol-characters)) + +(set-dispatch-macro-character ?\# ?\: + (function + (lambda (stream char n) + (reader::check-0-infix n) + (or (looking-at reader::symbol-regexp2) + (reader::error "Invalid symbol read syntax")) + (goto-char (match-end 0)) + (make-symbol + (buffer-substring (match-beginning 0) (match-end 0)))))) + +;; Function quoting: #' +(set-dispatch-macro-character ?\# ?\' + (function + (lambda (stream char n) + (reader::check-0-infix n) + ;; Probably should test if cl is required by current buffer. + ;; Currently, cl will always be a feature because cl-read requires it. + (reader::read-sexp (- (point) 2) + (list + (reader::read-sexp (point) (if (featurep 'cl) 'function* 'function)) + (reader::read-from-buffer stream 't)))))) + +;; Character syntax: #\ +;; Not yet implemented: #\Control-a #\M-C-a etc. +;; This definition is not used - the next one is more general. +'(set-dispatch-macro-character ?# ?\\ + (function + (lambda (stream char n) + (reader::check-0-infix n) + (let ((next (following-char)) + name) + (if (not (and (<= ?a next) (<= next ?z))) + (progn (forward-char 1) next) + (setq next (reader::read-from-buffer stream t)) + (cond ((symbolp next) (setq name (symbol-name next))) + ((integerp next) (setq name (int-to-string next)))) + (if (= 1 (length name)) + (string-to-char name) + (case next + (linefeed ?\n) + (newline ?\r) + (space ?\ ) + (rubout ?\b) + (page ?\f) + (tab ?\t) + (return ?\C-m) + (t + (reader::error "Unknown character specification `%s'" + next)))))))) + ) + +(defvar reader::special-character-name-table + '(("linefeed" . ?\n) + ("newline" . ?\r) + ("space" . ?\ ) + ("rubout" . ?\b) + ("page" . ?\f) + ("tab" . ?\t) + ("return" . ?\C-m))) + +(set-dispatch-macro-character ?# ?\\ + (function + (lambda (stream char n) + (reader::check-0-infix n) + (forward-char -1) + ;; We should read in a special package to avoid creating symbols. + (let ((symbol (reader::read-from-buffer stream t)) + (case-fold-search t) + name modifier character char-base) + (setq name (symbol-name symbol)) + (if (string-match "^\\(meta-\\|m-\\|control-\\|c-\\)+" name) + (setq modifier (substring name + (match-beginning 1) + (match-end 1)) + character (substring name (match-end 1))) + (setq character name)) + (setq char-base + (cond ((= (length character) 1) + (string-to-char character)) + ('t + (cdr (assoc character + reader::special-character-name-table))))) + (or char-base + (reader::error + "Unknown character specification `%s'" character)) + + (and modifier + (progn + (and (string-match "control-\\|c-" modifier) + (decf char-base 32)) + (and (string-match "meta-\\|m-" modifier) + (incf char-base 128)))) + char-base)))) + +;; '(#\meta-space #\tab #\# #\> #\< #\a #\A #\return #\space) +;; (eq #\m-tab ?\M-\t) +;; (eq #\c-m-x #\m-c-x) +;; (eq #\Meta-Control-return #\M-C-return) +;; (eq #\m-m-c-c-x #\m-c-x) +;; #\C-space #\C-@ ?\C-@ + + + +;; Read and load time evaluation: #. +;; Not yet implemented: #, +(set-dispatch-macro-character ?\# ?\. + (function + (lambda (reader::stream reader::char reader::n) + (reader::check-0-infix reader::n) + ;; This eval will see all internal vars of reader, + ;; e.g. stream, reader::recursive-p. Anything that might be bound. + ;; We must use `read' here rather than read-from-buffer with 'recursive-p + ;; because the expression must not have unresolved #n#s in it anyway. + ;; Otherwise the top-level expression must be completely read before + ;; any embedded evaluation(s) occur(s). CLtL2 does not specify this. + ;; Also, call `read' so that it may be customized, by e.g. Edebug + (eval (read reader::stream))))) +;; '(#.(current-buffer) #.(get-buffer "*scratch*")) + +;; Path names (kind of): #p, #P, +(set-dispatch-macro-character ?\# ?\P + (function + (lambda (stream char n) + (reader::check-0-infix n) + (let ((string (reader::read-from-buffer stream 't))) + (or (stringp string) + (reader::error "Pathname must be a string: %s" string)) + (expand-file-name string))))) + +(set-dispatch-macro-character ?\# ?\p + (get-dispatch-macro-character ?\# ?\P)) + +;; #P"~/.emacs" +;; #p"~root/home" + +;; Feature reading: #+, #- +;; Not yet implemented: #+, #- + + +(defsubst reader::read-feature (stream char n flag) + (reader::check-0-infix n) + (let (;; Use the original reader to only read the feature. + ;; This is not exactly correct without *read-suppress*. + ;; Also Emacs 18 read goes one too far, + ;; so we assume there is a space after the feature. + (feature (reader::original-read stream)) + (object (reader::read-from-buffer stream 't))) + (if (eq (featurep feature) flag) + object + ;; Ignore it. + (throw 'reader-ignore nil)))) + +(set-dispatch-macro-character ?\# ?\+ + (function + (lambda (stream char n) + (reader::read-feature stream char n t)))) + +(set-dispatch-macro-character ?\# ?\- + (function + (lambda (stream char n) + (reader::read-feature stream char n nil)))) + +;; (#+cl loop #+cl do #-cl while #-cl t (body)) + + + + +;; Shared structure reading: #=, ## + +;; Reading of sexpression with shared and circular structure read +;; syntax is done in two steps: +;; +;; 1. Create an sexpr with unshared structures, just as the ordinary +;; read macros do, with two exceptions: +;; - each label (#=) creates, as a side effect, a symbolic +;; reference for the sexpr that follows it +;; - each reference (##) is replaced by the corresponding +;; symbolic reference. +;; +;; 2. This non-cyclic and unshared lisp structure is given to the +;; function `reader::restore-shared-structure' (see +;; `reader::read-from-buffer'), which simply replaces +;; destructively all symbolic references by the lisp structures the +;; references point at. +;; +;; A symbolic reference is an uninterned symbol whose name is obtained +;; from the label/reference number using the function `int-to-string': +;; +;; There are two non-locally used variables (bound in +;; `reader::read-from-buffer') which control shared structure reading: +;; `reader::shared-structure-labels': +;; A list of integers that correspond to the label numbers in +;; the string currently read. This is used to avoid multiple +;; definitions of the same label. +;; `reader::shared-structure-references': +;; The list of symbolic references that will be used as temporary +;; placeholders for the shared objects introduced by a reference +;; with the same number identification. + +(set-dispatch-macro-character ?\# ?\= + (function + (lambda (stream char n) + (and (= n 0) (reader::error "0 not allowed as label")) + ;; check for multiple definition of the same label + (if (memq n reader::shared-structure-labels) + (reader::error "Label defined twice") + (push n reader::shared-structure-labels)) + ;; create an uninterned symbol as symbolic reference for the label + (let* ((string (int-to-string n)) + (ref (or (find string reader::shared-structure-references + :test 'string=) + (first + (push (make-symbol string) + reader::shared-structure-references))))) + ;; the link between the symbolic reference and the lisp + ;; structure it points at is done using the symbol value cell + ;; of the reference symbol. + (setf (symbol-value ref) + ;; this is also the return value + (reader::read-from-buffer stream 't)))))) + + +(set-dispatch-macro-character ?\# ?\# + (function + (lambda (stream char n) + (and (= n 0) (reader::error "0 not allowed as label")) + ;; use the non-local variable `reader::recursive-p' (from the reader + ;; main loop) to detect labels at the top level of an sexpr. + (if (not reader::recursive-p) + (reader::error "References at top level not allowed")) + (let* ((string (int-to-string n)) + (ref (or (find string reader::shared-structure-references + :test 'string=) + (first + (push (make-symbol string) + reader::shared-structure-references))))) + ;; the value of reading a #n# form is a reference symbol + ;; whose symbol value is or will be the shared structure. + ;; `reader::restore-shared-structure' then replaces the symbol by + ;; its value. + ref)))) + +(defun reader::restore-shared-structure (obj) + ;; traverses recursively OBJ and replaces all symbolic references by + ;; the objects they point at. Remember that a symbolic reference is + ;; an uninterned symbol whose value is the object it points at. + (cond + ((consp obj) + (loop for rest on obj + as lastcdr = rest + do + (if;; substructure is a symbolic reference + (memq (car rest) reader::shared-structure-references) + ;; replace it by its symbol value, i.e. the associated object + (setf (car rest) (symbol-value (car rest))) + (reader::restore-shared-structure (car rest))) + finally + (if (memq (cdr lastcdr) reader::shared-structure-references) + (setf (cdr lastcdr) (symbol-value (cdr lastcdr))) + (reader::restore-shared-structure (cdr lastcdr))))) + ((vectorp obj) + (loop for i below (length obj) + do + (if;; substructure is a symbolic reference + (memq (aref obj i) reader::shared-structure-references) + ;; replace it by its symbol value, i.e. the associated object + (setf (aref obj i) (symbol-value (aref obj i))) + (reader::restore-shared-structure (aref obj i)))))) + obj) + + +;; #1=(a b #3=[#2=c]) +;; (#1=[#\return #\a] #1# #1#) +;; (#1=[a b c] #1# #1#) +;; #1=(a b . #1#) + +;; Creation and initialization of an internal standard readtable. +;; Do this after all the macros and dispatch chars above have been defined. + +(defconst reader::internal-standard-readtable (copy-readtable) + "The original (CL-like) standard readtable. If you ever modify this +readtable, you won't be able to recover a standard readtable using +\(copy-readtable nil\)") + + +;; Replace built-in functions that call the built-in reader +;; +;; The following functions are replaced here: +;; +;; read by reader::read +;; read-from-string by reader::read-from-string +;; +;; eval-expression by reader::eval-expression +;; Why replace eval-expression? Not needed for Lucid Emacs since the +;; reader for arguments is also written in Lisp, and so may be overridden. +;; +;; eval-current-buffer by reader::eval-current-buffer +;; eval-buffer by reader::eval-buffer +;; original-eval-region by reader::original-eval-region + + +;; Temporary read buffer used for reading from strings +(defconst reader::tmp-buffer + (get-buffer-create " *CL Read*")) + +;; Save a pointer to the original read function +(or (fboundp 'reader::original-read) + (fset 'reader::original-read (symbol-function 'read))) + +(defun reader::read (&optional stream reader::recursive-p) + "Read one Lisp expression as text from STREAM, return as Lisp object. +If STREAM is nil, use the value of `standard-input' \(which see\). +STREAM or the value of `standard-input' may be: + a buffer \(read from point and advance it\) + a marker \(read from where it points and advance it\) + a string \(takes text from string, starting at the beginning\) + t \(read text line using minibuffer and use it\). + +This is the cl-read replacement of the standard elisp function +`read'. The only incompatibility is that functions as stream arguments +are not supported." + (if (not cl-read-active) + (reader::original-read stream) + (if (null stream) ; read from standard-input + (setq stream standard-input)) + + (if (eq stream 't) ; read from minibuffer + (setq stream (read-from-minibuffer "Common Lisp Expression: "))) + + (cond + + ((bufferp stream) ; read from buffer + (reader::read-from-buffer stream reader::recursive-p)) + + ((markerp stream) ; read from marker + (save-excursion + (set-buffer (marker-buffer stream)) + (goto-char (marker-position stream)) + (reader::read-from-buffer (current-buffer) reader::recursive-p))) + + ((stringp stream) ; read from string + (save-excursion + (set-buffer reader::tmp-buffer) + (auto-save-mode -1) + (erase-buffer) + (insert stream) + (goto-char (point-min)) + (reader::read-from-buffer reader::tmp-buffer reader::recursive-p))) + (t + (reader::error "Not a valid stream: %s" stream))))) + +;; read-from-string +;; save a pointer to the original `read-from-string' function +(or (fboundp 'reader::original-read-from-string) + (fset 'reader::original-read-from-string + (symbol-function 'read-from-string))) + +(defun reader::read-from-string (string &optional start end) + "Read one Lisp expression which is represented as text by STRING. +Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX). +START and END optionally delimit a substring of STRING from which to read; +they default to 0 and (length STRING) respectively. + +This is the cl-read replacement of the standard elisp function +`read-from-string'. It uses the reader macros in *readtable* if +`cl-read-active' is non-nil in the current buffer." + + ;; Does it really make sense to have read-from-string depend on + ;; what the current buffer happens to be? Yes, so code that + ;; has nothing to do with cl-read uses original reader. + (if (not cl-read-active) + (reader::original-read-from-string string start end) + (or start (setq start 0)) + (or end (setq end (length string))) + (save-excursion + (set-buffer reader::tmp-buffer) + (auto-save-mode -1) + (erase-buffer) + (insert (substring string 0 end)) + (goto-char (1+ start)) + (cons + (reader::read-from-buffer reader::tmp-buffer nil) + (1- (point)))))) + +;; (read-from-string "abc (car 'a) bc" 4) +;; (reader::read-from-string "abc (car 'a) bc" 4) +;; (read-from-string "abc (car 'a) bc" 2 11) +;; (reader::read-from-string "abc (car 'a) bc" 2 11) +;; (reader::read-from-string "`(car ,first ,@rest)") +;; (read-from-string ";`(car ,first ,@rest)") +;; (reader::read-from-string ";`(car ,first ,@rest)") + +;; We should replace eval-expression, too, so that it reads (and +;; evals) in the current buffer. Alternatively, this could be fixed +;; in C. In Lemacs 19.6 and later, this function is already written +;; in lisp, and based on more primitive read functions we already +;; replaced. The reading happens during the interactive parameter +;; retrieval, which is written in lisp, too. So this replacement of +;; eval-expresssion is only required fro (FSF) Emacs 18 (and 19?). + +(or (fboundp 'reader::original-eval-expression) + (fset 'reader::original-eval-expression + (symbol-function 'eval-expression))) + +(defun reader::eval-expression (reader::expression) + "Evaluate EXPRESSION and print value in minibuffer. +Value is also consed on to front of variable `values'." + (interactive + (list + (car (read-from-string + (read-from-minibuffer + "Eval: " nil + ;;read-expression-map ;; not for emacs 18 + nil ;; use default map + nil ;; don't do read with minibuffer current. + ;; 'edebug-expression-history ;; not for emacs 18 + ))))) + (setq values (cons (eval reader::expression) values)) + (prin1 (car values) t)) + +(require 'eval-reg "eval-reg") +(require 'advice) + + +;; installing/uninstalling the cl reader +;; These two should always be used in pairs, or just install once and +;; never uninstall. +(defun cl-reader-install () + (interactive) + (fset 'read 'reader::read) + (fset 'read-from-string 'reader::read-from-string) + (fset 'eval-expression 'reader::eval-expression) + (elisp-eval-region-install)) + +(defun cl-reader-uninstall () + (interactive) + (fset 'read + (symbol-function 'reader::original-read)) + (fset 'read-from-string + (symbol-function 'reader::original-read-from-string)) + (fset 'eval-expression + (symbol-function 'reader::original-eval-expression)) + (elisp-eval-region-uninstall)) + +;; Globally installing the cl-read replacement functions is safe, even +;; for buffers without cl read syntax. The buffer local variable +;; `cl-read-active' controls whether the replacement funtions of this +;; package or the original ones are actually called. +(cl-reader-install) +(cl-reader-uninstall) + +;; Advise the redefined eval-region +(defadvice eval-region (around cl-read activate) + "Use the reader::read instead of the original read if cl-read-active." + (with-elisp-eval-region (not cl-read-active) + (ad-do-it))) +;;(ad-unadvise 'eval-region) + + +(add-hook 'emacs-lisp-mode-hook 'cl-reader-autoinstall-function) + +'(defvar read-syntax) + +'(defun cl-reader-autoinstall-function () + "Activates the Common Lisp style reader for emacs-lisp-mode buffers, +if the property line has a local variable setting like this: +\;\; -*- Read-Syntax: Common-Lisp -*-" + ;; this is a hack to avoid recursion in the case that the prop line + ;; containes "Mode: emacs-lisp" entry + (or (boundp 'local-variable-hack-done) + (let (local-variable-hack-done + (case-fold-search t)) + ;; Usually `hack-local-variables-prop-line' is called only after + ;; installation of the major mode. But we need to know about the + ;; local variables before that, so we call the local variable hack + ;; explicitly here: + (hack-local-variables-prop-line 't) + ;; But hack-local-variables-prop-line not defined in emacs 18. + (cond + ((and (boundp 'read-syntax) + read-syntax + (string-match "^common-lisp$" (symbol-name read-syntax))) + (require 'cl-read) + (make-local-variable 'cl-read-active) + (setq cl-read-active 't)))))) + +;; Emacs 18 doesnt have hack-local-variables-prop-line. So use this instead. +(defun cl-reader-autoinstall-function () + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (cond ((re-search-forward + "read-syntax: *common-lisp" + (save-excursion + (end-of-line) + (point)) + t) + (require 'cl-read) + (make-local-variable 'cl-read-active) + (setq cl-read-active t)))))) + + +(run-hooks 'cl-read-load-hooks) +;; end cl-read.el diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/cl-specs.el --- a/lisp/edebug/cl-specs.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/edebug/cl-specs.el Mon Aug 13 08:46:56 2007 +0200 @@ -4,33 +4,38 @@ ;; Author: Daniel LaLiberte ;; Keywords: lisp, tools, maint -;; LCD Archive Entry: -;; cl-specs.el|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |Edebug specs for cl.el -;; |$Date: 1996/12/18 03:33:26 $|$Revision: 1.1.1.1 $|~/modes/cl-specs.el| +;; This file is part of XEmacs. -;; 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 +;; 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, +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF -;;;; Commentary: +;;; Commentary: + +;; LCD Archive Entry: +;; cl-specs.el|Daniel LaLiberte|liberte@cs.uiuc.edu +;; |Edebug specs for cl.el +;; |$Date: 1996/12/18 03:54:29 $|$Revision: 1.1.1.2 $|~/modes/cl-specs.el| ;; These specs are to be used with edebug.el version 3.3 or later and ;; cl.el version 2.03 or later, by Dave Gillespie . -;; This file need not be byte-compiled, but it shouldnt hurt. +;; This file need not be byte-compiled, but it shouldn't hurt. + +;;; Code: (provide 'cl-specs) ;; Do the above provide before the following require. @@ -469,3 +474,4 @@ (def-edebug-spec loop-d-type-spec (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) +;; cl-specs.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/cust-print.el --- a/lisp/edebug/cust-print.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/edebug/cust-print.el Mon Aug 13 08:46:56 2007 +0200 @@ -6,66 +6,69 @@ ;; Adapted-By: ESR ;; Keywords: extensions -;; LCD Archive Entry: -;; cust-print|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |Handle print-level, print-circle and more. -;; |$Date: 1996/12/18 03:33:26 $|$Revision: 1.1.1.1 $| +;; This file is part of XEmacs. -;; 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 +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;; LCD Archive Entry: +;; cust-print|Daniel LaLiberte|liberte@cs.uiuc.edu +;; |Handle print-level, print-circle and more. +;; |$Date: 1996/12/18 03:54:29 $|$Revision: 1.1.1.2 $| -;;; =============================== -;;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs-19/lisp/edebug/cust-print.el,v 1.1.1.1 1996/12/18 03:33:26 steve Exp $ -;;; $Log: cust-print.el,v $ -;;; Revision 1.1.1.1 1996/12/18 03:33:26 steve -;;; XEmacs 19.14 -- Release -;;; -;;; Revision 1.4 1994/03/23 20:34:29 liberte -;;; * Change "emacs" to "original" - I just can't decide. -;;; -;;; Revision 1.3 1994/02/21 21:25:36 liberte -;;; * Make custom-prin1-to-string more robust when errors occur. -;;; * Change "internal" to "emacs". -;;; -;;; Revision 1.2 1993/11/22 22:36:36 liberte -;;; * Simplified and generalized printer customization. -;;; custom-printers is an alist of (PREDICATE . PRINTER) pairs -;;; for any data types. The PRINTER function should print to -;;; `standard-output' add-custom-printer and delete-custom-printer -;;; change custom-printers. -;;; -;;; * Installation function now called install-custom-print. The -;;; old name is still around for now. -;;; -;;; * New macro with-custom-print (added earlier) - executes like -;;; progn but with custom-print activated temporarily. -;;; -;;; * Cleaned up comments for replacements of standardard printers. -;;; -;;; * Changed custom-prin1-to-string to use a temporary buffer. -;;; -;;; * Internal symbols are prefixed with CP::. -;;; -;;; * Option custom-print-vectors (added earlier) - controls whether -;;; vectors should be printed according to print-length and -;;; print-length. Emacs doesnt do this, but cust-print would -;;; otherwise do it only if custom printing is required. -;;; -;;; * Uninterned symbols are treated as non-read-equivalent. -;;; +;; =============================== +;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs-19/lisp/edebug/cust-print.el,v 1.1.1.2 1996/12/18 03:54:29 steve Exp $ +;; $Log: cust-print.el,v $ +;; Revision 1.1.1.2 1996/12/18 03:54:29 steve +;; XEmacs 19.15-b3 +;; +;; Revision 1.4 1994/03/23 20:34:29 liberte +;; * Change "emacs" to "original" - I just can't decide. +;; +;; Revision 1.3 1994/02/21 21:25:36 liberte +;; * Make custom-prin1-to-string more robust when errors occur. +;; * Change "internal" to "emacs". +;; +;; Revision 1.2 1993/11/22 22:36:36 liberte +;; * Simplified and generalized printer customization. +;; custom-printers is an alist of (PREDICATE . PRINTER) pairs +;; for any data types. The PRINTER function should print to +;; `standard-output' add-custom-printer and delete-custom-printer +;; change custom-printers. +;; +;; * Installation function now called install-custom-print. The +;; old name is still around for now. +;; +;; * New macro with-custom-print (added earlier) - executes like +;; progn but with custom-print activated temporarily. +;; +;; * Cleaned up comments for replacements of standardard printers. +;; +;; * Changed custom-prin1-to-string to use a temporary buffer. +;; +;; * Internal symbols are prefixed with CP::. +;; +;; * Option custom-print-vectors (added earlier) - controls whether +;; vectors should be printed according to print-length and +;; print-length. Emacs doesnt do this, but cust-print would +;; otherwise do it only if custom printing is required. +;; +;; * Uninterned symbols are treated as non-read-equivalent. +;; ;;; Commentary: diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/edebug-cl-read.el --- a/lisp/edebug/edebug-cl-read.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/edebug/edebug-cl-read.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,31 +1,34 @@ -;; edebug-cl-read.el - Edebug reader macros for use with cl-read. +;;; edebug-cl-read.el --- Edebug reader macros for use with cl-read. ;; Copyright (C) 1993 Daniel LaLiberte ;; Author: Daniel LaLiberte ;; Keywords: lisp, tools, maint +;; 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: + ;; LCD Archive Entry: ;; edebug-cl-read.el|Daniel LaLiberte|liberte@cs.uiuc.edu ;; |Edebug reader macros for cl-read.el -;; |$Date: 1996/12/18 03:33:27 $|$Revision: 1.1.1.1 $|~/modes/edebug-cl-read.el| - -;; This file is not yet part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;;; Commentary: +;; |$Date: 1996/12/18 03:54:29 $|$Revision: 1.1.1.2 $|~/modes/edebug-cl-read.el| ;; If you use cl-read.el and want to use edebug with any code ;; in a file written with CL read syntax, then you need to use this @@ -41,6 +44,8 @@ ;; Need to mangle all local variable names that might be visible to ;; eval, e.g. stream, char. Alternatively, packages could hide them. +;;; Code: + (require 'cl) ;; For byte compiling cl-read is needed. ;; But edebug-cl-read should not even be loaded unless cl-read already is. diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/edebug.el --- a/lisp/edebug/edebug.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/edebug/edebug.el Mon Aug 13 08:46:56 2007 +0200 @@ -5,85 +5,90 @@ ;; Author: Daniel LaLiberte ;; Keywords: lisp, tools, maint +;; 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: + ;; LCD Archive Entry: ;; edebug|Daniel LaLiberte|liberte@cs.uiuc.edu ;; |A source level debugger for Emacs Lisp. -;; |$Date: 1996/12/18 03:33:28 $|$Revision: 1.1.1.1 $|~/modes/edebug.el| - -;; 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 minor mode allows programmers to step through Emacs Lisp -;;; source code while executing functions. You can also set -;;; breakpoints, trace (stopping at each expression), evaluate -;;; expressions as if outside Edebug, reevaluate and display a list of -;;; expressions, trap errors normally caught by debug, and display a -;;; debug style backtrace. - -;;;; Installation -;;; ============= - -;;; Put edebug.el in some directory in your load-path and -;;; byte-compile it. Also read the beginning of edebug-epoch.el, -;;; cl-specs.el, and edebug-cl-read.el if they apply to you. - -;;; Unless you are using Emacs 19 which is already set up to use Edebug, -;;; put the following forms in your .emacs file. -;;; (define-key emacs-lisp-mode-map "\C-xx" 'edebug-eval-top-level-form) -;;; (autoload 'edebug-eval-top-level-form "edebug") - -;;; If you wish to change the default edebug global command prefix, change: -;;; (setq edebug-global-prefix "\C-xX") - -;;; Other options, are described in the manual. - -;;; In previous versions of Edebug, users were directed to set -;;; `debugger' to `edebug-debug'. This is no longer necessary -;;; since Edebug automatically sets it whenever Edebug is active. - -;;;; Minimal Instructions -;;; ===================== - -;;; First evaluate a defun with C-xx, then run the function. Step -;;; through the code with SPC, mark breakpoints with b, go until a -;;; breakpoint is reached with g, and quit execution with q. Use the -;;; "?" command in edebug to describe other commands. See edebug.tex -;;; or the Emacs 19 Lisp Reference Manual for more instructions. - -;;; Send me your enhancements, ideas, bugs, or fixes. -;;; For bugs, you can call edebug-submit-bug-report if you have reporter.el. -;;; There is an edebug mailing list if you want to keep up -;;; with the latest developments. Requests to: edebug-request@cs.uiuc.edu - -;;; Daniel LaLiberte 217-398-4114 -;;; University of Illinois, Urbana-Champaign -;;; Department of Computer Science -;;; 1304 W Springfield -;;; Urbana, IL 61801 - -;;; uiucdcs!liberte -;;; liberte@cs.uiuc.edu - -;;; =============================== -;;; For the early revision history, see edebug-history. +;; |$Date: 1996/12/18 03:54:30 $|$Revision: 1.1.1.2 $|~/modes/edebug.el| + +;; This minor mode allows programmers to step through Emacs Lisp +;; source code while executing functions. You can also set +;; breakpoints, trace (stopping at each expression), evaluate +;; expressions as if outside Edebug, reevaluate and display a list of +;; expressions, trap errors normally caught by debug, and display a +;; debug style backtrace. + +;; Installation +;; ============= + +;; Put edebug.el in some directory in your load-path and +;; byte-compile it. Also read the beginning of edebug-epoch.el, +;; cl-specs.el, and edebug-cl-read.el if they apply to you. + +;; Unless you are using Emacs 19 which is already set up to use Edebug, +;; put the following forms in your .emacs file. +;; (define-key emacs-lisp-mode-map "\C-xx" 'edebug-eval-top-level-form) +;; (autoload 'edebug-eval-top-level-form "edebug") + +;; If you wish to change the default edebug global command prefix, change: +;; (setq edebug-global-prefix "\C-xX") + +;; Other options, are described in the manual. + +;; In previous versions of Edebug, users were directed to set +;; `debugger' to `edebug-debug'. This is no longer necessary +;; since Edebug automatically sets it whenever Edebug is active. + +;; Minimal Instructions +;; ===================== + +;; First evaluate a defun with C-xx, then run the function. Step +;; through the code with SPC, mark breakpoints with b, go until a +;; breakpoint is reached with g, and quit execution with q. Use the +;; "?" command in edebug to describe other commands. See edebug.tex +;; or the Emacs 19 Lisp Reference Manual for more instructions. + +;; Send me your enhancements, ideas, bugs, or fixes. +;; For bugs, you can call edebug-submit-bug-report if you have reporter.el. +;; There is an edebug mailing list if you want to keep up +;; with the latest developments. Requests to: edebug-request@cs.uiuc.edu + +;; Daniel LaLiberte 217-398-4114 +;; University of Illinois, Urbana-Champaign +;; Department of Computer Science +;; 1304 W Springfield +;; Urbana, IL 61801 + +;; uiucdcs!liberte +;; liberte@cs.uiuc.edu + +;; =============================== +;; For the early revision history, see edebug-history. + +;;; Code: (defconst edebug-version - (let ((raw-version "$Revision: 1.1.1.1 $")) + (let ((raw-version "$Revision: 1.1.1.2 $")) (substring raw-version (string-match "[0-9.]*" raw-version) (match-end 0)))) @@ -94,8 +99,8 @@ (or (fboundp 'defalias) (fset 'defalias 'fset))) -;;;; Bug reporting -;;; ============== +;; Bug reporting +;; ============== (defconst edebug-maintainer-address "liberte@cs.uiuc.edu") @@ -124,8 +129,8 @@ )))) -;;;; Options -;;; =============================== +;; Options +;; =============================== (defvar edebug-setup-hook nil "*Functions to call before edebug is used. @@ -248,8 +253,8 @@ If the result is non-nil, then break. Errors are ignored.") -;;;; Form spec utilities. -;;; =============================== +;; Form spec utilities. +;; =============================== ;;;###autoload (defmacro def-edebug-spec (symbol spec) @@ -275,8 +280,8 @@ )) -;;;; Utilities -;;; =============================== +;; Utilities +;; =============================== ;; Define edebug-gensym - from old cl.el (defvar edebug-gensym-index 0 @@ -367,7 +372,7 @@ "Returns the function named by OBJECT, or nil if it is not a function." (setq object (edebug-lookup-function object)) (if (or (subrp object) - (byte-code-function-p object) + (compiled-function-p object) (and (listp object) (eq (car object) 'lambda) (listp (car (cdr object))))) @@ -398,8 +403,8 @@ (set-buffer (marker-buffer edebug:s-r-beg)) (narrow-to-region edebug:s-r-beg edebug:s-r-end)))))) -;;;; Display -;;; ============ +;; Display +;; ============ (defconst edebug-trace-buffer "*edebug-trace*" "Name of the buffer to put trace info in.") @@ -493,12 +498,12 @@ (defalias 'edebug-input-pending-p 'input-pending-p) -;;;; Redefine read and eval functions -;;; ================================= -;;; read is redefined to maybe instrument forms. -;;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. - -;;; Use the Lisp version of eval-region. +;; Redefine read and eval functions +;; ================================= +;; read is redefined to maybe instrument forms. +;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. + +;; Use the Lisp version of eval-region. (require 'eval-reg "eval-reg") ;; Save the original read function @@ -611,11 +616,11 @@ (defalias 'eval-defun (symbol-function 'edebug-original-eval-defun))) -;;;; Edebug internal data -;;; =============================== - -;;; The internal data that is needed for edebugging is kept in the -;;; buffer-local variable `edebug-form-data'. +;; Edebug internal data +;; =============================== + +;; The internal data that is needed for edebugging is kept in the +;; buffer-local variable `edebug-form-data'. ;; XEmacs change? (defconst edebug-form-data nil) @@ -698,8 +703,8 @@ (setq edebug-form-data (delq entry edebug-form-data))))) -;;;; Parser utilities -;;; =============================== +;; Parser utilities +;; =============================== (defun edebug-syntax-error (&rest args) @@ -771,8 +776,8 @@ (edebug-original-read (current-buffer)))))) -;;;; Offsets for reader -;;; ============================== +;; Offsets for reader +;; ============================== ;; Define a structure to represent offset positions of expressions. ;; Each offset structure looks like: (before . after) for constituents, @@ -847,8 +852,8 @@ (edebug-store-after-offset (point))))) -;;;; Reader for Emacs Lisp. -;;; ========================================== +;; Reader for Emacs Lisp. +;; ========================================== ;; Uses edebug-next-token-class (and edebug-skip-whitespace) above. (defconst edebug-read-alist @@ -934,8 +939,8 @@ -;;;; Cursors for traversal of list and vector elements with offsets. -;;;==================================================================== +;; Cursors for traversal of list and vector elements with offsets. +;;==================================================================== (defvar edebug-dotted-spec nil) @@ -1012,29 +1017,29 @@ (setq offset (cdr offset))) offset)) -;;;; The Parser -;;; =============================== - -;;; The top level function for parsing forms is -;;; edebug-read-and-maybe-wrap-form; it calls all the rest. It checks the -;;; syntax a bit and leaves point at any error it finds, but otherwise -;;; should appear to work like eval-defun. - -;;; The basic plan is to surround each expression with a call to -;;; the edebug debugger together with indexes into a table of positions of -;;; all expressions. Thus an expression "exp" becomes: - -;;; (edebug-after (edebug-before 1) 2 exp) - -;;; When this is evaluated, first point is moved to the beginning of -;;; exp at offset 1 of the current function. The expression is -;;; evaluated, which may cause more edebug calls, and then point is -;;; moved to offset 2 after the end of exp. - -;;; The highest level expressions of the function are wrapped in a call to -;;; edebug-enter, which supplies the function name and the actual -;;; arguments to the function. See functions edebug-enter, edebug-before, -;;; and edebug-after for more details. +;; The Parser +;; =============================== + +;; The top level function for parsing forms is +;; edebug-read-and-maybe-wrap-form; it calls all the rest. It checks the +;; syntax a bit and leaves point at any error it finds, but otherwise +;; should appear to work like eval-defun. + +;; The basic plan is to surround each expression with a call to +;; the edebug debugger together with indexes into a table of positions of +;; all expressions. Thus an expression "exp" becomes: + +;; (edebug-after (edebug-before 1) 2 exp) + +;; When this is evaluated, first point is moved to the beginning of +;; exp at offset 1 of the current function. The expression is +;; evaluated, which may cause more edebug calls, and then point is +;; moved to offset 2 after the end of exp. + +;; The highest level expressions of the function are wrapped in a call to +;; edebug-enter, which supplies the function name and the actual +;; arguments to the function. See functions edebug-enter, edebug-before, +;; and edebug-after for more details. ;; Dynamically bound vars, left unbound, but globally declared. ;; This is to quiet the byte compiler. @@ -1108,7 +1113,7 @@ (eq 'name (car (cdr spec))) (eq 'symbol (edebug-next-token-class))) (edebug-original-read (current-buffer)))))) -;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) +;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) (cond (defining-form-p (if (or edebug-all-defs edebug-all-forms) @@ -1491,8 +1496,8 @@ )) -;;;; Matching of specs. -;;; =================== +;; Matching of specs. +;; =================== (defvar edebug-after-dotted-spec nil) @@ -1500,8 +1505,8 @@ (defconst edebug-max-depth 150) ;; maximum number of matching recursions. -;;;; Failure to match -;;; ================== +;; Failure to match +;; ================== ;; This throws to no-match, if there are higher alternatives. ;; Otherwise it signals an error. The place of the error is found ;; with the two before- and after-offset functions. @@ -1927,12 +1932,12 @@ (list (edebug-wrap-def-body (edebug-forms cursor))))) -;;;; Edebug Form Specs -;;; ========================================================== -;;; See cl-specs.el for common lisp specs. - -;;;;* Spec for def-edebug-spec -;;; Out of date. +;; Edebug Form Specs +;; ========================================================== +;; See cl-specs.el for common lisp specs. + +;;* Spec for def-edebug-spec +;; Out of date. (defun edebug-spec-p (object) "Return non-nil if OBJECT is a symbol with an edebug-form-spec property." @@ -1962,7 +1967,7 @@ )) -;;;;* Emacs special forms and some functions. +;;* Emacs special forms and some functions. ;; quote expects only one argument, although it allows any number. (def-edebug-spec quote sexp) @@ -2099,12 +2104,12 @@ def-body)) -;;;; The debugger itself -;;; =============================== +;; The debugger itself +;; =============================== (defvar edebug-active nil) ;; Non-nil when edebug is active -;;; add minor-mode-alist entry +;; add minor-mode-alist entry (or (assq 'edebug-active minor-mode-alist) (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*") minor-mode-alist))) @@ -2166,8 +2171,8 @@ (defvar cl-lexical-debug) ;; Defined in cl.el -;;; Handling signals -;;; ================= +;; Handling signals +;; ================= (if (not (fboundp 'edebug-original-signal)) (defalias 'edebug-original-signal (symbol-function 'signal))) @@ -2195,8 +2200,8 @@ (edebug-original-signal edebug-signal-name edebug-signal-data)) -;;; Entering Edebug -;;; ================== +;; Entering Edebug +;; ================== (defun edebug-enter (edebug-function edebug-args edebug-body) ;; Entering FUNC. The arguments are ARGS, and the body is BODY. @@ -2227,7 +2232,7 @@ (cl-lexical-debug t) ;; Save the outside value of executing macro. (here??) - (edebug-outside-executing-macro executing-macro) + (edebug-outside-executing-macro executing-kbd-macro) (edebug-outside-pre-command-hook pre-command-hook) (edebug-outside-post-command-hook post-command-hook) (edebug-outside-post-command-idle-hook post-command-idle-hook)) @@ -2235,8 +2240,8 @@ (let (;; Don't keep reading from an executing kbd macro ;; within edebug unless edebug-continue-kbd-macro is ;; non-nil. Again, local binding may not be best. - (executing-macro - (if edebug-continue-kbd-macro executing-macro)) + (executing-kbd-macro + (if edebug-continue-kbd-macro executing-kbd-macro)) ;; Disable command hooks. This is essential when ;; a hook function is instrumented - to avoid infinite loop. @@ -2254,7 +2259,7 @@ (edebug-enter edebug-function edebug-args edebug-body) (fset 'signal (symbol-function 'edebug-original-signal)))) ;; Reset global variables in case outside value was changed. - (setq executing-macro edebug-outside-executing-macro + (setq executing-kbd-macro edebug-outside-executing-macro pre-command-hook edebug-outside-pre-command-hook post-command-hook edebug-outside-post-command-hook post-command-idle-hook edebug-outside-post-command-idle-hook @@ -2899,13 +2904,13 @@ )) -;;; Display related functions -;;; =============================== +;; Display related functions +;; =============================== (defun edebug-adjust-window (old-start) ;; If pos is not visible, adjust current window to fit following context. -;;; (message "window: %s old-start: %s window-start: %s pos: %s" -;;; (selected-window) old-start (window-start) (point)) (sit-for 5) +;; (message "window: %s old-start: %s window-start: %s pos: %s" +;; (selected-window) old-start (window-start) (point)) (sit-for 5) (if (not (pos-visible-in-window-p)) (progn ;; First try old-start @@ -3074,8 +3079,8 @@ (if already-displaying "off" "on")))) -;;; Breakpoint related functions -;;; =============================== +;; Breakpoint related functions +;; =============================== (defun edebug-find-stop-point () ;; Return (function . index) of the nearest edebug stop point. @@ -3233,8 +3238,8 @@ (setq edebug-global-break-condition expression)) -;;; Mode switching functions -;;; =============================== +;; Mode switching functions +;; =============================== (defun edebug-set-mode (mode shortmsg msg) ;; Set the edebug mode to MODE. @@ -3459,8 +3464,8 @@ ;; (edebug-set-mode 'exiting "Exit...")) -;;; ----------------------------------------------------------------- -;;; The following initial mode setting definitions are not used yet. +;; ----------------------------------------------------------------- +;; The following initial mode setting definitions are not used yet. '(defconst edebug-initial-mode-alist '((edebug-Continue-fast . Continue-fast) @@ -3506,8 +3511,8 @@ ))) -;;; Evaluation of expressions -;;; =============================== +;; Evaluation of expressions +;; =============================== (def-edebug-spec edebug-outside-excursion t) @@ -3544,7 +3549,7 @@ (standard-output edebug-outside-standard-output) (standard-input edebug-outside-standard-input) - (executing-macro edebug-outside-executing-macro) + (executing-kbd-macro edebug-outside-executing-macro) (defining-kbd-macro edebug-outside-defining-kbd-macro) (pre-command-hook edebug-outside-pre-command-hook) (post-command-hook edebug-outside-post-command-hook) @@ -3586,7 +3591,7 @@ edebug-outside-standard-output standard-output edebug-outside-standard-input standard-input - edebug-outside-executing-macro executing-macro + edebug-outside-executing-macro executing-kbd-macro edebug-outside-defining-kbd-macro defining-kbd-macro edebug-outside-pre-command-hook pre-command-hook edebug-outside-post-command-hook post-command-hook @@ -3615,8 +3620,8 @@ (get (car edebug-err) 'error-message) (car (cdr edebug-err)))))) -;;;; Printing -;;; ========= +;; Printing +;; ========= ;; Replace printing functions. ;; obsolete names @@ -3698,8 +3703,8 @@ (interactive) (message "%s" edebug-previous-result)) -;;;; Read, Eval and Print -;;; ===================== +;; Read, Eval and Print +;; ===================== (defun edebug-eval-expression (edebug-expr) "Evaluate an expression in the outside environment. @@ -3733,8 +3738,8 @@ )) -;;;; Edebug Minor Mode -;;; =============================== +;; Edebug Minor Mode +;; =============================== ;; Global GUD bindings for all emacs-lisp-mode buffers. (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) @@ -3898,8 +3903,8 @@ (use-local-map edebug-mode-map)) -;;;; edebug eval list mode -;;; =============================================== +;; edebug eval list mode +;; =============================================== ;; A list of expressions and their evaluations is displayed in *edebug*. (defun edebug-eval-result-list () @@ -4035,8 +4040,8 @@ (use-local-map edebug-eval-mode-map)) -;;;; Interface with standard debugger. -;;; ======================================== +;; Interface with standard debugger. +;; ======================================== ;; (setq debugger 'edebug) ; to use the edebug debugger ;; (setq debugger 'debug) ; use the standard debugger @@ -4115,7 +4120,7 @@ ))))) -;;;; Trace display +;; Trace display ;; =============================== (defun edebug-trace-display (buf-name fmt &rest args) @@ -4151,8 +4156,8 @@ (apply 'edebug-trace-display edebug-trace-buffer fmt args)) -;;;; Frequency count and coverage -;;; ============================== +;; Frequency count and coverage +;; ============================== (defun edebug-display-freq-count () "Display the frequency count data for each line of the current @@ -4235,8 +4240,8 @@ (undo))) -;;;; Menus -;;;========= +;; Menus +;;========= (defun edebug-toggle (variable) (set variable (not (eval variable))) @@ -4303,11 +4308,11 @@ "XEmacs style menus for Edebug.") -;;;; Emacs version specific code -;;;============================= -;;; The default for all above is Emacs 18, because it is easier to compile -;;; Emacs 18 code in Emacs 19 than vice versa. This default will -;;; change once most people are using Emacs 19 or derivatives. +;; Emacs version specific code +;;============================= +;; The default for all above is Emacs 18, because it is easier to compile +;; Emacs 18 code in Emacs 19 than vice versa. This default will +;; change once most people are using Emacs 19 or derivatives. ;; Epoch specific code is in a separate file: edebug-epoch.el. @@ -4370,7 +4375,7 @@ (edebug-safe-prin1-to-string (car values))))) (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) - (if window-system + (if (eq (console-type) 'x) (x-popup-menu nil (lookup-key edebug-mode-map [menu-bar Edebug]))) ) @@ -4414,8 +4419,8 @@ (edebug-emacs-version-specific) -;;;; Byte-compiler -;;; ==================== +;; Byte-compiler +;; ==================== ;; Extension for bytecomp to resolve undefined function references. ;; Requires new byte compiler. @@ -4499,8 +4504,8 @@ ))) -;;;; Autoloading of Edebug accessories -;;;=================================== +;; Autoloading of Edebug accessories +;;=================================== (if (featurep 'cl) (add-hook 'edebug-setup-hook @@ -4518,11 +4523,11 @@ (function (lambda () (require 'edebug-cl-read))))) -;;;; Finalize Loading -;;;=================== - -;;; Finally, hook edebug into the rest of Emacs. -;;; There are probably some other things that could go here. +;; Finalize Loading +;;=================== + +;; Finally, hook edebug into the rest of Emacs. +;; There are probably some other things that could go here. ;; Install edebug read and eval functions. (edebug-install-read-eval-functions) @@ -4530,5 +4535,3 @@ (provide 'edebug) ;;; edebug.el ends here - - diff -r 30df88044ec6 -r b82b59fe008d lisp/edebug/eval-reg.el --- a/lisp/edebug/eval-reg.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/edebug/eval-reg.el Mon Aug 13 08:46:56 2007 +0200 @@ -5,42 +5,47 @@ ;; Author: Daniel LaLiberte ;; Keywords: lisp -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;;; Commentary: +;; 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. -;;; eval-region, eval-buffer, and eval-current-buffer are redefined in -;;; Lisp to allow customizations by Lisp code. eval-region calls -;;; `read', `eval', and `prin1', so Lisp replacements of these -;;; functions will affect eval-region and anything else that calls it. -;;; eval-buffer and eval-current-buffer are redefined in Lisp to call -;;; eval-region on the buffer. +;;; Synched up with: Not in FSF + +;;; Commentary: -;;; Because of dynamic binding, all local variables are protected from -;;; being seen by eval by giving them funky names. But variables in -;;; routines that call eval-region are similarly exposed. +;; eval-region, eval-buffer, and eval-current-buffer are redefined in +;; Lisp to allow customizations by Lisp code. eval-region calls +;; `read', `eval', and `prin1', so Lisp replacements of these +;; functions will affect eval-region and anything else that calls it. +;; eval-buffer and eval-current-buffer are redefined in Lisp to call +;; eval-region on the buffer. -;;; Perhaps this should be one of several files in an `elisp' package -;;; that replaces Emacs Lisp subroutines with Lisp versions of the -;;; same. +;; Because of dynamic binding, all local variables are protected from +;; being seen by eval by giving them funky names. But variables in +;; routines that call eval-region are similarly exposed. -;;; Eval-region may be installed, after loading, by calling: -;;; (elisp-eval-region-install). Installation can be undone with: -;;; (elisp-eval-region-uninstall). +;; Perhaps this should be one of several files in an `elisp' package +;; that replaces Emacs Lisp subroutines with Lisp versions of the +;; same. + +;; Eval-region may be installed, after loading, by calling: +;; (elisp-eval-region-install). Installation can be undone with: +;; (elisp-eval-region-uninstall). + +;;; Code: '(defpackage "elisp-eval-region" (:nicknames "elisp") @@ -210,7 +215,6 @@ (error "No such buffer: %s" elisp-bufname))) (eval-region (point-min) (point-max) elisp-printflag))) - (provide 'eval-reg) ;;; eval-reg.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/electric/ebuff-menu.el --- a/lisp/electric/ebuff-menu.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/electric/ebuff-menu.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,8 +1,9 @@ ;;; ebuff-menu.el --- electric-buffer-list mode -;; Copyright (C) 1985, 1986, 1992, 1993, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc. ;; Author: Richard Mlynarik +;; Keywords: frames ;; This file is part of XEmacs. @@ -18,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -31,6 +33,7 @@ ;;; Code: (require 'electric) +;; XEmacs change (require 'buff-menu) ;; this depends on the format of list-buffers (from src/buffer.c) and @@ -39,79 +42,71 @@ (defvar electric-buffer-menu-mode-map nil) ;;;###autoload -(defun electric-buffer-list (&optional files-only) +(defun electric-buffer-list (arg) "Pops up a buffer describing the set of Emacs buffers. Vaguely like ITS lunar select buffer; combining typeoutoid buffer listing with menuoid buffer selection. If the very next character typed is a space then the buffer list -window disappears. Otherwise, one may move around in the -buffer list window, marking buffers to be selected, saved or deleted. +window disappears. Otherwise, one may move around in the buffer list +window, marking buffers to be selected, saved or deleted. -To exit and select a new buffer, type a space when the cursor is on the -appropriate line of the buffer-list window. - -Other commands are much like those of buffer-menu-mode. +To exit and select a new buffer, type a space when the cursor is on +the appropriate line of the buffer-list window. Other commands are +much like those of buffer-menu-mode. Calls value of `electric-buffer-menu-mode-hook' on entry if non-nil. -Non-null optional arg FILES-ONLY means mention only file buffers. -When called from Lisp code, FILES-ONLY may be a regular expression, -in which case only buffers whose names match that expression are listed, -or an arbitrary predicate function. - \\{electric-buffer-menu-mode-map}" - (interactive (list (if current-prefix-arg t nil))) + (interactive "P") (let (select buffer) (save-window-excursion - (save-excursion - (save-window-excursion - (let ((temp-buffer-show-function 'ignore)) - (list-buffers files-only))) - (setq buffer (window-buffer (Electric-pop-up-window "*Buffer List*"))) - (unwind-protect - (progn - (set-buffer buffer) - (Electric-buffer-menu-mode) - (setq select - (catch 'electric-buffer-menu-select - (message "<<< Press Return to bury the buffer list >>>") - (let ((start-point (point)) - (first (progn (goto-char (point-min)) - (forward-line 2) - (point))) - (last (progn (goto-char (point-max)) - (forward-line -1) - (point))) - (goal-column 0)) - ;; Use start-point if it is meaningful. - (goto-char (if (or (< start-point first) - (> start-point last)) - first - start-point)) - (Electric-command-loop 'electric-buffer-menu-select - nil - t - 'electric-buffer-menu-looper - (cons first last)))))) - (save-excursion + (save-window-excursion (list-buffers arg)) + (setq buffer (window-buffer (Electric-pop-up-window "*Buffer List*"))) + (unwind-protect + (progn (set-buffer buffer) - (Buffer-menu-mode)) - (bury-buffer buffer) - (message nil)))) + (Electric-buffer-menu-mode) + (setq select + (catch 'electric-buffer-menu-select + (message "<<< Press Return to bury the buffer list >>>") + ;; XEmacs change + (if (eq (setq unread-command-events + (list (next-command-event))) + ?\ ) + (progn (setq unread-command-events nil) + (throw 'electric-buffer-menu-select nil))) + (let ((start-point (point)) + (first (progn (goto-char (point-min)) + (forward-line 2) + (point))) + (last (progn (goto-char (point-max)) + (forward-line -1) + (point))) + (goal-column 0)) + ;; Use start-point if it is meaningful. + (goto-char (if (or (< start-point first) + (> start-point last)) + first + start-point)) + (Electric-command-loop 'electric-buffer-menu-select + nil + t + 'electric-buffer-menu-looper + (cons first last)))))) + (set-buffer buffer) + (Buffer-menu-mode) + (bury-buffer buffer) + (message ""))) (if select - (progn - (set-buffer buffer) - (let ((opoint (point-marker))) - (Buffer-menu-execute) - (goto-char (point-min)) - (cond ((prog1 (search-forward "\n>" nil t) - (goto-char opoint) (set-marker opoint nil)) - (Buffer-menu-select)) - ((bufferp select) - (switch-to-buffer select)) - (t - (switch-to-buffer (Buffer-menu-buffer t))))))))) + (progn (set-buffer buffer) + (let ((opoint (point-marker))) + (Buffer-menu-execute) + (goto-char (point-min)) + (if (prog1 (search-forward "\n>" nil t) + (goto-char opoint) (set-marker opoint nil)) + (Buffer-menu-select) + (switch-to-buffer (Buffer-menu-buffer t)))))))) (defun electric-buffer-menu-looper (state condition) (cond ((and condition @@ -156,15 +151,18 @@ (use-local-map electric-buffer-menu-mode-map) (setq mode-name "Electric Buffer Menu") (setq mode-line-buffer-identification "Electric Buffer List") + ;; XEmacs (if (memq 'mode-name mode-line-format) (progn (setq mode-line-format (copy-sequence mode-line-format)) (setcar (memq 'mode-name mode-line-format) "Buffers"))) (make-local-variable 'Helper-return-blurb) (setq Helper-return-blurb "return to buffer editing") (setq truncate-lines t) + ;; XEmacs (setq buffer-scrollbar-height 0) (setq buffer-read-only t) (setq major-mode 'Electric-buffer-menu-mode) + ;; XEmacs (setq mode-motion-hook 'mode-motion-highlight-line) (goto-char (point-min)) (if (search-forward "\n." nil t) (forward-char -1)) @@ -175,30 +173,20 @@ (put 'Electric-buffer-menu-undefined 'suppress-keymap t) (if electric-buffer-menu-mode-map nil - (let ((map (make-keymap))) - (set-keymap-name map 'electric-buffer-menu-mode-map) - ;;#### Urk! There must be a buffer way in Lucid Emacs. - (let ((i 0)) - (while (< i 128) - (define-key map (make-string 1 i) 'Electric-buffer-menu-undefined) - (setq i (1+ i)))) - (define-key map "\e" (make-keymap)) - (let ((map2 (lookup-key map "\e")) - (i 0)) - (while (< i 128) - (define-key map2 (make-string 1 i) 'Electric-buffer-menu-undefined) - (setq i (1+ i)))) -;; (define-key map "\C-z" 'suspend-emacs) + (let ((map (make-keymap)) (submap (make-keymap))) + (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined) + (define-key map "\e" submap) + (fillarray (car (cdr submap)) 'Electric-buffer-menu-undefined) + (define-key map "\C-z" 'suspend-emacs) (define-key map "v" 'Electric-buffer-menu-mode-view-buffer) -;; (define-key map "\C-h" 'Helper-help) - (define-key map '(control h) 'Helper-help) + (define-key map (char-to-string help-char) 'Helper-help) (define-key map "?" 'Helper-describe-bindings) (define-key map "\C-c" nil) (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit) (define-key map "\C-]" 'Electric-buffer-menu-quit) (define-key map "q" 'Electric-buffer-menu-quit) - (define-key map " " 'Electric-buffer-menu-select) - (define-key map "\r" 'Electric-buffer-menu-select) ;; XEmacs change + (define-key map " " 'Electric-buffer-menu-select) + (define-key map "\C-m" 'Electric-buffer-menu-select) (define-key map "\C-l" 'recenter) (define-key map "s" 'Buffer-menu-save) (define-key map "d" 'Buffer-menu-delete) @@ -206,6 +194,7 @@ (define-key map "\C-d" 'Buffer-menu-delete-backwards) ;(define-key map "\C-k" 'Buffer-menu-delete) (define-key map "\177" 'Buffer-menu-backup-unmark) + ;; XEmacs (define-key map 'backspace 'Buffer-menu-backup-unmark) (define-key map "~" 'Buffer-menu-not-modified) (define-key map "u" 'Buffer-menu-unmark) @@ -232,6 +221,7 @@ (define-key map "\e<" 'beginning-of-buffer) (define-key map "\e\e" nil) (define-key map "\e\e\e" 'Electric-buffer-menu-quit) + ;; XEmacs (define-key map [home] 'beginning-of-buffer) (define-key map [down] 'next-line) (define-key map [up] 'previous-line) @@ -243,6 +233,7 @@ (defun Electric-buffer-menu-exit () (interactive) + ;; XEmacs (setq unread-command-event last-input-event) ;; for robustness (condition-case () @@ -253,13 +244,13 @@ (defun Electric-buffer-menu-select () "Leave Electric Buffer Menu, selecting buffers and executing changes. Saves buffers marked \"S\". Deletes buffers marked \"K\". -Selects buffer at point and displays buffers marked \">\" in other -windows." +Selects buffer at point and displays buffers marked \">\" in other windows." (interactive) (throw 'electric-buffer-menu-select (point))) (defun Electric-buffer-menu-mouse-select (event) (interactive "e") + ;; XEmacs is simpler (mouse-set-point event) (Electric-buffer-menu-select)) @@ -272,10 +263,15 @@ (defun Electric-buffer-menu-undefined () (interactive) (ding) - (message (substitute-command-keys "\ + (message "%s" + (if (and (eq (key-binding "\C-c\C-c") 'Electric-buffer-menu-quit) + (eq (key-binding " ") 'Electric-buffer-menu-select) + (eq (key-binding (char-to-string help-char)) 'Helper-help) + (eq (key-binding "?") 'Helper-describe-bindings)) + (substitute-command-keys "Type C-c C-c to exit, Space to select, Type \\[Electric-buffer-menu-quit] to exit, \ \\[Electric-buffer-menu-select] to select, \ -\\[Helper-help] for help, \\[Helper-describe-bindings] for commands.")) +\\[Helper-help] for help, \\[Helper-describe-bindings] for commands."))) (sit-for 4)) (defun Electric-buffer-menu-mode-view-buffer () diff -r 30df88044ec6 -r b82b59fe008d lisp/electric/echistory.el --- a/lisp/electric/echistory.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/electric/echistory.el Mon Aug 13 08:46:56 2007 +0200 @@ -4,6 +4,7 @@ ;; Author: K. Shane Hartman ;; Maintainer: FSF +;; Keywords: extensions ;; This file is part of XEmacs. @@ -19,9 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Code: @@ -31,7 +33,7 @@ ;;;###autoload (defun Electric-command-history-redo-expression (&optional noconfirm) "Edit current history line in minibuffer and execute result. -With prefix argument NOCONFIRM, execute current line as-is without editing." +With prefix arg NOCONFIRM, execute current line as-is without editing." (interactive "P") (let (todo) (save-excursion @@ -44,6 +46,7 @@ (defvar electric-history-map ()) (if electric-history-map () + ;; XEmacs (setq electric-history-map (make-keymap)) (set-keymap-name electric-history-map 'electric-history-map) (set-keymap-default-binding electric-history-map 'Electric-history-undefined) @@ -64,8 +67,8 @@ (define-key electric-history-map "\C-c\C-c" 'Electric-history-quit) (define-key electric-history-map "\C-]" 'Electric-history-quit) (define-key electric-history-map "\C-z" 'suspend-emacs) -;; (define-key electric-history-map "\C-h" 'Helper-help) - (define-key electric-history-map '(control h) 'Helper-help) + (define-key electric-history-map (char-to-string help-char) 'Helper-help) + ;; XEmacs (define-key electric-history-map 'backspace 'previous-line) (define-key electric-history-map "?" 'Helper-describe-bindings) (define-key electric-history-map "\e>" 'end-of-buffer) @@ -99,12 +102,6 @@ The history displayed is filtered by `list-command-history-filter' if non-nil. -This pops up a window with the Command History listing. If the very -next character typed is Space, the listing is killed and the previous -window configuration is restored. Otherwise, you can browse in the -Command History with Return moving down and Delete moving up, possibly -selecting an expression to be redone with Space or quitting with `Q'. - Like Emacs-Lisp mode except that characters do not insert themselves and Tab and Linefeed do not indent. Instead these commands are provided: \\{electric-history-map} @@ -153,7 +150,7 @@ "Quit Electric Command History, restoring previous window configuration." (interactive) (if (boundp 'electric-history-in-progress) - (progn (message nil) + (progn (message "") (throw 'electric-history-quit nil)))) ;;; echistory.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/electric/ehelp.el --- a/lisp/electric/ehelp.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/electric/ehelp.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,7 +3,6 @@ ;; Copyright (C) 1986, 1995 Free Software Foundation, Inc. ;; Author: Richard Mlynarik - ;; Maintainer: FSF ;; Keywords: help, extensions @@ -21,9 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -42,15 +42,15 @@ ;;; Code: (require 'electric) +(defvar electric-help-map () + "Keymap defining commands available in `electric-help-mode'.") -(defvar electric-help-map nil - "Keymap defining commands available in `electric-help-mode'.") +(defvar electric-help-form-to-execute nil) (put 'electric-help-undefined 'suppress-keymap t) (if electric-help-map () (let ((map (make-keymap))) - (set-keymap-name map 'electric-help-map) ;; allow all non-self-inserting keys - search, scroll, etc, but ;; let M-x and C-x exit ehelp mode and retain buffer: (suppress-keymap map) @@ -67,6 +67,7 @@ (define-key map [(control ?9)] 'electric-help-undefined) (define-key map (char-to-string help-char) 'electric-help-help) (define-key map "?" 'electric-help-help) + ;; XEmacs addition (define-key map 'help 'electric-help-help) (define-key map " " 'scroll-up) (define-key map "\^?" 'scroll-down) @@ -86,13 +87,14 @@ (defun electric-help-mode () "`with-electric-help' temporarily places its buffer in this mode. -\(On exit from `with-electric-help', the buffer is put in `default-major-mode'.\)" +\(On exit from `with-electric-help', the buffer is put in `default-major-mode'.)" (setq buffer-read-only t) (setq mode-name "Help") (setq major-mode 'help) (setq modeline-buffer-identification '(" Help: %b")) (use-local-map electric-help-map) - (setq mouse-leave-buffer-hook '(electric-help-retain)) + (add-hook 'mouse-leave-buffer-hook 'electric-help-retain) + (view-mode -1) ;; this is done below in with-electric-help ;(run-hooks 'electric-help-mode-hook) ) @@ -126,7 +128,7 @@ (let ((one (one-window-p t)) (config (current-window-configuration)) (bury nil) - (to-be-executed nil)) + (electric-help-form-to-execute nil)) (unwind-protect (save-excursion (if one (goto-char (window-start (selected-window)))) @@ -138,7 +140,8 @@ (enlarge-window (- minheight (window-height)))) (electric-help-mode) (setq buffer-read-only nil) - (or noerase (erase-buffer))) + (or noerase + (erase-buffer))) (let ((standard-output buffer)) (if (not (funcall thunk)) (progn @@ -148,14 +151,15 @@ (if one (shrink-window-if-larger-than-buffer (selected-window)))))) (set-buffer buffer) (run-hooks 'electric-help-mode-hook) + (setq buffer-read-only t) (if (eq (car-safe - ;; Don't be screwed by minor-modes (view-minor-mode) + ;; XEmacs: Don't be screwed by minor-modes (view-minor-mode) (let ((overriding-local-map electric-help-map)) (electric-help-command-loop))) 'retain) (setq config (current-window-configuration)) (setq bury t))) - (message nil) + (message "") (set-buffer buffer) (setq buffer-read-only nil) (condition-case () @@ -169,12 +173,13 @@ (replace-buffer-in-windows buffer) ;; must do this outside of save-window-excursion (bury-buffer buffer))) - (eval to-be-executed)))) + (eval electric-help-form-to-execute)))) (defun electric-help-command-loop () (catch 'exit (if (pos-visible-in-window-p (point-max)) - (progn (message (substitute-command-keys "<<< Press Space to bury the help buffer, Press \\[electric-help-retain] to retain it >>>")) + (progn (message "%s" (substitute-command-keys "<<< Press Space to bury the help buffer, Press \\[electric-help-retain] to retain it >>>")) + ;; XEmacs change (if (equal (setq unread-command-events (list (next-command-event))) '(?\ )) @@ -219,14 +224,14 @@ ;(defun electric-help-scroll-up (arg) -; "####Doc" +; ">>>Doc" ; (interactive "P") ; (if (and (null arg) (pos-visible-in-window-p (point-max))) ; (electric-help-exit) ; (scroll-up arg))) (defun electric-help-exit () - "####Doc" + ">>>Doc" (interactive) (throw 'exit t)) @@ -237,27 +242,11 @@ (interactive) ;; Make sure that we don't throw twice, even if two events cause ;; calling this function: - (if mouse-leave-buffer-hook - (progn - (setq mouse-leave-buffer-hook nil) - (throw 'exit '(retain))))) - + (if (memq 'electric-help-retain mouse-leave-buffer-hook) + (progn + (remove-hook 'mouse-leave-buffer-hook 'electric-help-retain) + (throw 'exit '(retain))))) -;(defun electric-help-undefined () -; (interactive) -; (let* ((keys (this-command-keys)) -; (n (length keys))) -; (if (or (= n 1) -; (and (= n 2) -; meta-flag -; (eq (aref keys 0) meta-prefix-char))) -; (setq unread-command-char last-input-char -; current-prefix-arg prefix-arg) -; ;;#### I don't care. -; ;;#### The emacs command-loop is too much pure pain to -; ;;#### duplicate -; )) -; (throw 'exit t)) (defun electric-help-undefined () (interactive) @@ -268,7 +257,7 @@ (substitute-command-keys "\\[electric-help-exit]")))) -;#### this needs to be hairified (recursive help, anybody?) +;>>> this needs to be hairified (recursive help, anybody?) (defun electric-help-help () (interactive) (if (and (eq (key-binding "q") 'electric-help-exit) @@ -281,35 +270,56 @@ ;;;###autoload -(defun electric-helpify (fun &optional buffer-name) - (or buffer-name (setq buffer-name "*Help*")) - (let* ((p (symbol-function 'print-help-return-message)) - (b (get-buffer buffer-name)) - (tick (and b (buffer-modified-tick b)))) - (and b (not (get-buffer-window b)) - (setq b nil)) - (if (unwind-protect - (save-window-excursion - (message "%s..." (capitalize (symbol-name fun))) - ;; kludge-o-rama - (fset 'print-help-return-message 'ignore) - (let ((a (call-interactively fun 'lambda))) - (let ((temp-buffer-show-function 'ignore)) - (apply fun a))) - (message nil) - ;; Was a non-empty help buffer created/modified? - (let ((r (get-buffer buffer-name))) - (and r - ;(get-buffer-window r) - (or (not b) - (not (eq b r)) - (not (eql tick (buffer-modified-tick b)))) - (save-excursion - (set-buffer r) - (> (buffer-size) 0))))) - (fset 'print-help-return-message p) - ) - (with-electric-help 'ignore buffer-name t)))) +(defun electric-helpify (fun &optional name) + (let ((name (or name "*Help*"))) + (if (save-window-excursion + ;; kludge-o-rama + (let* ((p (symbol-function 'print-help-return-message)) + (b (get-buffer name)) + (m (buffer-modified-p b))) + (and b (not (get-buffer-window b)) + (setq b nil)) + (unwind-protect + (progn + (message "%s..." (capitalize (symbol-name fun))) + ;; with-output-to-temp-buffer marks the buffer as unmodified. + ;; kludging excessively and relying on that as some sort + ;; of indication leads to the following abomination... + ;;>> This would be doable without such icky kludges if either + ;;>> (a) there were a function to read the interactive + ;;>> args for a command and return a list of those args. + ;;>> (To which one would then just apply the command) + ;;>> (The only problem with this is that interactive-p + ;;>> would break, but that is such a misfeature in + ;;>> any case that I don't care) + ;;>> It is easy to do this for emacs-lisp functions; + ;;>> the only problem is getting the interactive spec + ;;>> for subrs + ;;>> (b) there were a function which returned a + ;;>> modification-tick for a buffer. One could tell + ;;>> whether a buffer had changed by whether the + ;;>> modification-tick were different. + ;;>> (Presumably there would have to be a way to either + ;;>> restore the tick to some previous value, or to + ;;>> suspend updating of the tick in order to allow + ;;>> things like momentary-string-display) + (and b + (save-excursion + (set-buffer b) + (set-buffer-modified-p t))) + (fset 'print-help-return-message 'ignore) + (call-interactively fun) + (and (get-buffer name) + (get-buffer-window (get-buffer name)) + (or (not b) + (not (eq b (get-buffer name))) + (not (buffer-modified-p b))))) + (fset 'print-help-return-message p) + (and b (buffer-name b) + (save-excursion + (set-buffer b) + (set-buffer-modified-p m)))))) + (with-electric-help 'ignore name t)))) @@ -317,14 +327,14 @@ ;; continues with execute-extended-command. (defun electric-help-execute-extended (prefixarg) (interactive "p") - (setq to-be-executed '(execute-extended-command nil)) + (setq electric-help-form-to-execute '(execute-extended-command nil)) (electric-help-retain)) ;; This is to be buond to C-x in ehelp mode. Retains ehelp buffer and then ;; continues with ctrl-x prefix. (defun electric-help-ctrl-x-prefix (prefixarg) (interactive "p") - (setq to-be-executed '(progn (message nil) (setq unread-command-char ?\C-x))) + (setq electric-help-form-to-execute '(progn (message nil) (setq unread-command-char ?\C-x))) (electric-help-retain)) @@ -363,7 +373,7 @@ (defun electric-command-apropos () (interactive) - (electric-helpify 'command-apropos)) + (electric-helpify 'command-apropos "*Apropos*")) ;(define-key help-map "a" 'electric-command-apropos) @@ -371,11 +381,10 @@ (interactive) (electric-helpify 'apropos)) - ;;;; ehelp-map -(defvar ehelp-map nil) +(defvar ehelp-map ()) (if ehelp-map nil ;; #### WTF? Why don't we just use substitute-key-definition diff -r 30df88044ec6 -r b82b59fe008d lisp/electric/electric.el --- a/lisp/electric/electric.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/electric/electric.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,6 @@ ;;; electric.el --- window maker and Command loop for `electric' modes. -;; Copyright (C) 1985, 1986, 1992, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1995 Free Software Foundation, Inc. ;; Author: K. Shane Hartman ;; Maintainer: FSF @@ -20,9 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30.97. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -68,6 +69,7 @@ (setq prompt-string nil) (setq prompt-string "->"))) (setq cmd (read-key-sequence prompt-string)) + ;; XEmacs (or prefix-arg (setq last-command this-command)) (setq last-command-event (aref cmd (1- (length cmd))) current-mouse-event @@ -82,6 +84,7 @@ ;; This makes universal-argument-other-key work. (setq universal-argument-num-events 0) (if (or (prog1 quit-flag (setq quit-flag nil)) + ;; XEmacs (eq (event-to-character last-input-event) (quit-char))) (progn (setq unread-command-events nil prefix-arg nil) @@ -95,6 +98,7 @@ (setq current-prefix-arg prefix-arg) (if cmd (condition-case conditions + ;; XEmacs (progn (if (eventp cmd) (progn (let ((b (current-buffer))) @@ -104,27 +108,43 @@ (command-execute cmd)) (setq last-command this-command) (if (or (prog1 quit-flag (setq quit-flag nil)) + ;; XEmacs (eq (event-to-character last-input-event) (quit-char))) (progn (setq unread-command-events nil) (if (not inhibit-quit) + ;; XEmacs (progn (ding nil 'quit) (message "Quit") (throw return-tag nil)) (message "Quit inhibited") (ding))))) - (error (command-error conditions) ; XEmacs - (sit-for 2))) - (ding nil 'undefined-key)) - (and (not (eq (current-buffer) electrified-buffer)) ; XEmacs - - (not (eq (selected-window) (minibuffer-window))) - (progn (ding nil 'quit) - (message "Leaving electric command loop %s." - "because buffer has changed") - (sit-for 2) - (throw return-tag nil))) + (buffer-read-only (if loop-function + (setq err conditions) + (ding) + (message "Buffer is read-only") + (sit-for 2))) + (beginning-of-buffer (if loop-function + (setq err conditions) + (ding) + (message "Beginning of Buffer") + (sit-for 2))) + (end-of-buffer (if loop-function + (setq err conditions) + (ding) + (message "End of Buffer") + (sit-for 2))) + (error (if loop-function + (setq err conditions) + (ding) + (message "Error: %s" + (if (eq (car conditions) 'error) + (car (cdr conditions)) + (prin1-to-string conditions))) + (sit-for 2)))) + (ding)) (if loop-function (funcall loop-function loop-state err)))) - ;; ####> - huh? It should be impossible to ever get here... + ;; XEmacs - huh? It should be impossible to ever get here... (ding nil 'alarm) (throw return-tag nil)) @@ -178,6 +198,6 @@ (goto-char (point-min)) win))) -(provide 'electric) ; zaaaaaaap +(provide 'electric) ;;; electric.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/electric/helper.el --- a/lisp/electric/helper.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/electric/helper.el Mon Aug 13 08:46:56 2007 +0200 @@ -20,14 +20,15 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Code: -; hey, here's a helping hand. - +;; hey, here's a helping hand. + ;; Bind this to a string for in "... Other keys ". ;; Helper-help uses this to construct help string when scrolling. ;; Defaults to "return" diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/crisp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulators/crisp.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,209 @@ +;; @(#) crisp.el -- Crisp/Brief Emacs emulator + +;; Author: Gary D. Foster +;; $Revision: 1.1.1.1 $ +;; Keywords: emulations brief crisp + +;; 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: + +;; Keybindings and minor functions to duplicate the functionality and +;; finger-feel of the Crisp/Brief editor. This package is designed to +;; facilitate transitioning from Brief to (XE|E)macs with a minimum +;; amount of hassles. + +;; Enable this package by putting the following in your .emacs +;; (require 'crisp) +;; and use M-x crisp-mode to toggle it on or off. + +;; This package will automatically default to loading the scroll-lock.el +;; package unless you put (setq crisp-load-scroll-lock nil) in your +;; .emacs. If this feature is enabled, it will bind meta-f1 to the +;; scroll-lock mode toggle. + +;; Also, the default keybindings for brief override the meta-x key to +;; exit the editor. If you don't like this functionality, you can +;; prevent this key from being rebound with +;; (setq crisp-override-meta-x nil) in your .emacs. + +;; Finally, if you want to change the string displayed in the modeline +;; when this mode is in effect, override the definition of +;; `crisp-mode-modeline-string' in your .emacs. The default value is +;; " *Crisp*" which may be a bit lengthy if you have a lot of things +;; being displayed there. + +;; All these overrides should go *before* the (require 'crisp) statement. + +;; local variables + +(defvar crisp-mode-map (copy-keymap (current-global-map)) + "Local keymap for Crisp mode. +All the bindings are done here instead of globally to try and be +nice to the world.") + +(defvar crisp-mode-modeline-string " *Crisp*" + "String to display in the modeline when Crisp mode is enabled.") + +(defvar crisp-mode-original-keymap (copy-keymap (current-global-map)) + "The original keymap before Crisp mode remaps anything. +This keymap is restored when Crisp mode is disabled.") + +(defvar crisp-mode-enabled 'nil + "Track status of Crisp mode. +A value of nil means Crisp mode is not enabled. A value of t +indicates Crisp mode is enabled.") + +(defvar crisp-override-meta-x 't + "Controls overriding the normal Emacs M-x key binding. +The normal binding for M-x is `execute-extended-command', however +the normal Crisp keybinding for M-x is to exit the editor, while +the F10 key is used to execute extended commands. If you don't +want M-x to dump you out of emacs, set this to nil before loading +the package.") + +(defvar crisp-load-scroll-lock 't + "Controls loading of the Scroll Lock minor mode package. +Default behavior is to load the scroll lock minor mode +package when Crisp mode is enabled. Set to nil prior +to loading this package to prevent it.") + +(defvar crisp-load-hook nil + "Hooks to run after Crisp mode is enabled.") + +(defvar crisp-mode-running-xemacs (string-match "XEmacs\\Lucid" emacs-version)) + +(if crisp-mode-running-xemacs + (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) + +(define-key crisp-mode-map [(f2) (down)] 'enlarge-window) +(define-key crisp-mode-map [(f2) (left)] 'shrink-window-horizontally) +(define-key crisp-mode-map [(f2) (right)] 'enlarge-window-horizontally) +(define-key crisp-mode-map [(f2) (up)] 'shrink-window) +(define-key crisp-mode-map [(f3) (down)] 'split-window-vertically) +(define-key crisp-mode-map [(f3) (right)] 'split-window-horizontally) + +(define-key crisp-mode-map [(f4)] 'delete-window) +(define-key crisp-mode-map [(control f4)] 'delete-other-windows) + +(define-key crisp-mode-map [(f5)] 'search-forward-regexp) +(define-key crisp-mode-map [(f19)] 'search-forward-regexp) +(define-key crisp-mode-map [(meta f5)] 'search-backward-regexp) + +(define-key crisp-mode-map [(f6)] 'query-replace) + +(define-key crisp-mode-map [(f7)] 'start-kbd-macro) +(define-key crisp-mode-map [(meta f7)] 'end-kbd-macro) + +(define-key crisp-mode-map [(f8)] 'call-last-kbd-macro) +(define-key crisp-mode-map [(meta f8)] 'save-kbd-macro) + +(define-key crisp-mode-map [(f9)] 'find-file) +(define-key crisp-mode-map [(meta f9)] 'load-library) + +(define-key crisp-mode-map [(f10)] 'execute-extended-command) +(define-key crisp-mode-map [(meta f10)] 'compile) + +(define-key crisp-mode-map [(SunF37)] 'kill-buffer) +(define-key crisp-mode-map [(kp_add)] 'x-copy-primary-selection) +(define-key crisp-mode-map [(kp_subtract)] 'x-kill-primary-selection) +(define-key crisp-mode-map [(insert)] 'x-yank-clipboard-selection) +(define-key crisp-mode-map [(f16)] 'x-copy-primary-selection) ; copy on Sun5 kbd +(define-key crisp-mode-map [(f20)] 'x-kill-primary-selection) ; cut on Sun5 kbd +(define-key crisp-mode-map [(f18)] 'x-yank-clipboard-selection) ; paste on Sun5 kbd + +(define-key crisp-mode-map [(meta d)] (lambda () (interactive) (beginning-of-line) (kill-line))) +(define-key crisp-mode-map [(meta e)] 'find-file) +(define-key crisp-mode-map [(meta g)] 'goto-line) +(define-key crisp-mode-map [(meta h)] 'help) +(define-key crisp-mode-map [(meta i)] 'overwrite-mode) +(define-key crisp-mode-map [(meta u)] 'advertised-undo) +(define-key crisp-mode-map [(f14)] 'advertised-undo) +(define-key crisp-mode-map [(meta w)] 'save-buffer) +(if + (eq crisp-override-meta-x 't) + (define-key crisp-mode-map [(meta x)] 'save-buffers-kill-emacs)) + +(define-key crisp-mode-map [(shift right)] 'fkey-forward-word) +(define-key crisp-mode-map [(shift left)] 'fkey-backward-word) +(define-key crisp-mode-map [(shift delete)] 'kill-word) +(define-key crisp-mode-map [(shift backspace)] 'backward-kill-word) +(define-key crisp-mode-map [(control left)] 'backward-word) +(define-key crisp-mode-map [(control right)] 'forward-word) + +(define-key crisp-mode-map [(home)] 'crisp-home) +(define-key crisp-mode-map [(end)] 'crisp-end) + +(defun crisp-home () + "Home the point according to Crisp conventions. +First call to this moves point to beginning of the line. Second +consecutive call moves point to beginning of the screen. Third +consecutive call moves the point to the beginning of the buffer." + (interactive nil) + (cond + ((and (eq last-command 'crisp-home) (eq last-last-command 'crisp-home)) + (goto-char (point-min))) + ((eq last-command 'crisp-home) + (move-to-window-line 0)) + (t + (beginning-of-line))) + (setq last-last-command last-command)) + +(defun crisp-end () + "End the point according to Crisp conventions. +First call to this moves point to end of the line. Second +consecutive call moves point to the end of the screen. Third +consecutive call moves point to the end of the buffer." + (interactive nil) + (cond + ((and (eq last-command 'crisp-end) (eq last-last-command 'crisp-end)) + (goto-char (point-max))) + ((eq last-command 'crisp-end) + (move-to-window-line -1) + (end-of-line)) + (t + (end-of-line))) + (setq last-last-command last-command)) + +;; Now enable the mode + +(defun crisp-mode () + "Toggle Crisp minor mode." + (interactive nil) + (setq crisp-mode-enabled (not crisp-mode-enabled)) + (cond + ((eq crisp-mode-enabled 't) + (use-global-map crisp-mode-map) + (if crisp-load-scroll-lock + (require 'scroll-lock)) + (if (featurep 'scroll-lock) + (define-key crisp-mode-map [(meta f1)] 'scroll-lock-mode)) + (run-hooks 'crisp-load-hook)) + ((eq crisp-mode-enabled 'nil) + (use-global-map crisp-mode-original-keymap)))) + +(provide 'crisp) + +;;; crisp.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/edt-lk201.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulators/edt-lk201.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,57 @@ +;;; edt-lk201.el --- Enhanced EDT Keypad Mode Emulation for LK-201 Keyboards + +;; Copyright (C) 1986, 1992, 1993, 1995 Free Software Foundation, Inc. + +;; Author: Kevin Gallagher +;; Maintainer: Kevin Gallagher +;; Keywords: emulations + +;; 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 + +;;; Usage: + +;; See edt-user.doc in the Emacs etc directory. + +;; ==================================================================== + +;;;; +;;;; KEY TRANSLATIONS +;;;; + +;; Associate EDT keynames with Emacs terminal function vector names. +;; (Function key vector names for LK-201 are found in lisp/term/lk201.el.) +;; +;; F1 - F5 are not available on many DEC VT series terminals. +;; However, this is not always the case. So support for F1 - F5 is +;; provided here and in lisp/term/lk201.el. +(defconst *EDT-keys* + '(("KP0" . [kp-0]) ("KP1" . [kp-1]) ("KP2" . [kp-2]) ("KP3" . [kp-3]) + ("KP4" . [kp-4]) ("KP5" . [kp-5]) ("KP6" . [kp-6]) ("KP7" . [kp-7]) + ("KP8" . [kp-8]) ("KP9" . [kp-9]) ("KP," . [kp-separator]) + ("KP-" . [kp-subtract]) ("KPP" . [kp-decimal]) ("KPE" . [kp-enter]) + ("PF1" . [kp-f1]) ("PF2" . [kp-f2]) ("PF3" . [kp-f3]) ("PF4" . [kp-f4]) + ("UP" . [up]) ("DOWN" . [down]) ("RIGHT" . [right]) ("LEFT" . [left]) + ("FIND" . [find]) ("INSERT" . [insert]) ("REMOVE" . [delete]) + ("SELECT" . [select]) ("PREVIOUS" . [prior]) ("NEXT" . [next]) + ("F1" . [f1]) ("F2" . [f2]) ("F3" . [f3]) ("F4" . [f4]) ("F5" . [f5]) + ("F6" . [f6]) ("F7" . [f7]) ("F8" . [f8]) ("F9" . [f9]) ("F10" . [f10]) + ("F11" . [f11]) ("F12" . [f12]) ("F13" . [f13]) ("F14" . [f14]) + ("HELP" . [help]) ("DO" . [menu]) ("F17" . [f17]) ("F18" . [f18]) + ("F19" . [f19]) ("F20" . [f20]))) diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/edt-mapper.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulators/edt-mapper.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,407 @@ +;;; edt-mapper.el --- Create an EDT LK-201 Map File for X-Windows Emacs + +;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. + +;; Author: Kevin Gallagher +;; Maintainer: Kevin Gallagher +;; Keywords: emulations + +;; 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 emacs lisp program can be used to create an emacs lisp file +;; that defines the mapping of the user's keyboard under X-Windows to +;; the LK-201 keyboard function keys and keypad keys (around which +;; EDT has been designed). Please read the "Usage" AND "Known +;; Problems" sections before attempting to run this program. (The +;; design of this file, edt-mapper.el, was heavily influenced by +;; tpu-mapper.el.) + +;;; Usage: + +;; Simply load this file into the X-Windows version of emacs (version 19) +;; using the following command. + +;; emacs -q -l edt-mapper.el + +;; The "-q" option prevents loading of your .emacs file (commands therein +;; might confuse this program). + +;; An instruction screen showing the typical LK-201 terminal functions keys +;; will be displayed, and you will be prompted to press the keys on your +;; keyboard which you want to emulate the corresponding LK-201 keys. + +;; Finally, you will be prompted for the name of the file to store +;; the key definitions. If you chose the default, it will be found +;; and loaded automatically when the EDT emulation is started. If +;; you specify a different file name, you will need to set the +;; variable "edt-xkeys-file" before starting the EDT emulation. +;; Here's how you might go about doing that in your .emacs file. + +;; (setq edt-xkeys-file (expand-file-name "~/.my-emacs-x-keys")) + +;;; Known Problems: + +;; Sometimes, edt-mapper will ignore a key you press, and just continue to +;; prompt for the same key. This can happen when your window manager sucks +;; up the key and doesn't pass it on to emacs, or it could be an emacs bug. +;; Either way, there's nothing that edt-mapper can do about it. You must +;; press RETURN, to skip the current key and continue. Later, you and/or +;; your local X guru can try to figure out why the key is being ignored. + +;; ==================================================================== + +;;; +;;; Make sure we're running X-windows and Emacs version 19 +;;; +(cond + ((not (and window-system (not (string-lessp emacs-version "19")))) + (insert " + + Whoa! This isn't going to work... + + You must run edt-mapper.el under X-windows and Emacs version 19. + + Press any key to exit. ") + (sit-for 600) + (kill-emacs t))) + + +;;; +;;; 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.") + + +;;; +;;; Key variables +;;; +(defvar edt-key nil) +(defvar edt-enter nil) +(defvar edt-return nil) +(defvar edt-key-seq nil) +(defvar edt-enter-seq nil) +(defvar edt-return-seq nil) + + +;;; +;;; Make sure the window is big enough to display the instructions +;;; +(if edt-lucid-emacs19-p (set-screen-size nil 80 36) + (set-frame-size (selected-frame) 80 36)) + + +;;; +;;; Create buffers - Directions and Keys +;;; +(if (not (get-buffer "Directions")) (generate-new-buffer "Directions")) +(if (not (get-buffer "Keys")) (generate-new-buffer "Keys")) + +;;; +;;; Put header in the Keys buffer +;;; +(set-buffer "Keys") +(insert "\ +;; +;; Key definitions for the EDT emulation within GNU Emacs +;; + +(defconst *EDT-keys* + '( +") + +;;; +;;; Display directions +;;; +(switch-to-buffer "Directions") +(insert " + EDT MAPPER + + You will be asked to press keys to create a custom mapping (under + X-Windows) of your keypad keys and function keys so that they can emulate + the LK-201 keypad and function keys or the subset of keys found on a + VT-100 series terminal keyboard. (The LK-201 keyboard is the standard + keyboard attached to VT-200 series terminals, and above.) + + Sometimes, edt-mapper will ignore a key you press, and just continue to + prompt for the same key. This can happen when your window manager sucks + up the key and doesn't pass it on to emacs, or it could be an emacs bug. + Either way, there's nothing that edt-mapper can do about it. You must + press RETURN, to skip the current key and continue. Later, you and/or + your local X guru can try to figure out why the key is being ignored. + + Start by pressing the RETURN key, and continue by pressing the keys + specified in the mini-buffer. If you want to entirely omit a key, + because your keyboard does not have a corresponding key, for example, + just press RETURN at the prompt. + +") +(delete-other-windows) + +;;; +;;; Save for future reference +;;; +(cond + (edt-lucid-emacs19-p + (setq edt-return-seq (read-key-sequence "Hit carriage-return to continue ")) + (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq 0))) "]"))) + (t + (message "Hit carriage-return to continue ") + (setq edt-return-seq (read-event)) + (setq edt-return (concat "[" (format "%s" edt-return-seq) "]")))) + +;;; +;;; Display Keypad Diagram and Begin Prompting for Keys +;;; +(set-buffer "Directions") +(delete-region (point-min) (point-max)) +(insert " + + + + PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW. + + + + + Here's a picture of the standard LK-201 keypad for reference: + + _______________________ _______________________________ + | HELP | DO | | F17 | F18 | F19 | F20 | + | | | | | | | | + |_______|_______________| |_______|_______|_______|_______| + _______________________ _______________________________ + | FIND |INSERT |REMOVE | | PF1 | PF2 | PF3 | PF4 | + | | | | | | | | | + |_______|_______|_______| |_______|_______|_______|_______| + |SELECT |PREVIOU| NEXT | | KP7 | KP8 | KP9 | KP- | + | | | | | | | | | + |_______|_______|_______| |_______|_______|_______|_______| + | UP | | KP4 | KP5 | KP6 | KP, | + | | | | | | | + _______|_______|_______ |_______|_______|_______|_______| + | LEFT | DOWN | RIGHT | | KP1 | KP2 | KP3 | | + | | | | | | | | | + |_______|_______|_______| |_______|_______|_______| KPE | + | KP0 | KPP | | + | | | | + |_______________|_______|_______| + +") + +;;; +;;; Key mapping functions +;;; +(defun edt-lucid-map-key (ident descrip) + (interactive) + (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident descrip))) + (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq 0))) "]")) + (cond ((not (equal edt-key edt-return)) + (set-buffer "Keys") + (insert (format " (\"%s\" . %s)\n" ident edt-key)) + (set-buffer "Directions")) + ;; bogosity to get next prompt to come up, if the user hits ! + ;; check periodically to see if this is still needed... + (t + (format "%s" edt-key))) + edt-key) + +(defun edt-gnu-map-key (ident descrip) + (interactive) + (message "Press %s%s: " ident descrip) + (setq edt-key-seq (read-event)) + (setq edt-key (concat "[" (format "%s" edt-key-seq) "]")) + (cond ((not (equal edt-key edt-return)) + (set-buffer "Keys") + (insert (format " (\"%s\" . %s)\n" ident edt-key)) + (set-buffer "Directions")) + ;; bogosity to get next prompt to come up, if the user hits ! + ;; check periodically to see if this is still needed... + (t + (set-buffer "Keys") + (insert (format " (\"%s\" . \"\" )\n" ident)) + (set-buffer "Directions"))) + edt-key) + +(fset 'edt-map-key (if edt-lucid-emacs19-p 'edt-lucid-map-key 'edt-gnu-map-key)) +(set-buffer "Keys") +(insert " +;; +;; Arrows +;; +") +(set-buffer "Directions") + +(edt-map-key "UP" " - The Up Arrow Key") +(edt-map-key "DOWN" " - The Down Arrow Key") +(edt-map-key "LEFT" " - The Left Arrow Key") +(edt-map-key "RIGHT" " - The Right Arrow Key") + + +(set-buffer "Keys") +(insert " +;; +;; PF keys +;; +") +(set-buffer "Directions") + +(edt-map-key "PF1" " - The PF1 (GOLD) Key") +(edt-map-key "PF2" " - The Keypad PF2 Key") +(edt-map-key "PF3" " - The Keypad PF3 Key") +(edt-map-key "PF4" " - The Keypad PF4 Key") + +(set-buffer "Keys") +(insert " +;; +;; KP0-9 KP- KP, KPP and KPE +;; +") +(set-buffer "Directions") + +(edt-map-key "KP0" " - The Keypad 0 Key") +(edt-map-key "KP1" " - The Keypad 1 Key") +(edt-map-key "KP2" " - The Keypad 2 Key") +(edt-map-key "KP3" " - The Keypad 3 Key") +(edt-map-key "KP4" " - The Keypad 4 Key") +(edt-map-key "KP5" " - The Keypad 5 Key") +(edt-map-key "KP6" " - The Keypad 6 Key") +(edt-map-key "KP7" " - The Keypad 7 Key") +(edt-map-key "KP8" " - The Keypad 8 Key") +(edt-map-key "KP9" " - The Keypad 9 Key") +(edt-map-key "KP-" " - The Keypad - Key") +(edt-map-key "KP," " - The Keypad , Key") +(edt-map-key "KPP" " - The Keypad . Key") +(edt-map-key "KPE" " - The Keypad Enter Key") +;; Save the enter key +(setq edt-enter edt-key) +(setq edt-enter-seq edt-key-seq) + + +(set-buffer "Keys") +(insert " +;; +;; Editing keypad (FIND, INSERT, REMOVE) +;; (SELECT, PREVIOUS, NEXT) +;; +") +(set-buffer "Directions") + +(edt-map-key "FIND" " - The Find key on the editing keypad") +(edt-map-key "INSERT" " - The Insert key on the editing keypad") +(edt-map-key "REMOVE" " - The Remove key on the editing keypad") +(edt-map-key "SELECT" " - The Select key on the editing keypad") +(edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad") +(edt-map-key "NEXT" " - The Next Scr key on the editing keypad") + +(set-buffer "Keys") +(insert " +;; +;; F1-14 Help Do F17-F20 +;; +") +(set-buffer "Directions") + +(edt-map-key "F1" " - F1 Function Key") +(edt-map-key "F2" " - F2 Function Key") +(edt-map-key "F3" " - F3 Function Key") +(edt-map-key "F4" " - F4 Function Key") +(edt-map-key "F5" " - F5 Function Key") +(edt-map-key "F6" " - F6 Function Key") +(edt-map-key "F7" " - F7 Function Key") +(edt-map-key "F8" " - F8 Function Key") +(edt-map-key "F9" " - F9 Function Key") +(edt-map-key "F10" " - F10 Function Key") +(edt-map-key "F11" " - F11 Function Key") +(edt-map-key "F12" " - F12 Function Key") +(edt-map-key "F13" " - F13 Function Key") +(edt-map-key "F14" " - F14 Function Key") +(edt-map-key "HELP" " - HELP Function Key") +(edt-map-key "DO" " - DO Function Key") +(edt-map-key "F17" " - F17 Function Key") +(edt-map-key "F18" " - F18 Function Key") +(edt-map-key "F19" " - F19 Function Key") +(edt-map-key "F20" " - F20 Function Key") + +(set-buffer "Directions") +(delete-region (point-min) (point-max)) +(insert " + ADDITIONAL FUNCTION KEYS + + Your keyboard may have additional function keys which do not + correspond to any LK-201 keys. The EDT Emulation can be + configured to recognize those keys, since you may wish to add your + own key bindings to those keys. + + For example, suppose your keyboard has a keycap marked \"Line Del\" + and you wish to add it to the list of keys which can be customized + by the EDT Emulation. First, assign a unique single-word name to + the key for use by the EDT Emulation, let's say \"linedel\", in this + example. Then, at the \"EDT Key Name:\" prompt, enter \"linedel\", + followed by a press of the RETURN key. Finally, when prompted, + press the \"Line Del\" key. You now will be able to bind functions + to \"linedel\" and \"Gold-linedel\" in edt-user.el in just the same way + you can customize bindings of the standard LK-201 keys. + + When you have no additional function keys to specify, just press + RETURN at the \"EDT Key Name:\" prompt. (If you change your mind + AFTER you enter an EDT Key Name and before you press a key at the + \"Press\" prompt, you may omit the key by simply pressing RETURN at + the prompt.) +") +(switch-to-buffer "Directions") +;;; +;;; Add support for extras keys +;;; +(set-buffer "Keys") +(insert "\ +;; +;; Extra Keys +;; +") +(setq EDT-key-name "") +(while (not + (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) "")) + (edt-map-key EDT-key-name "")) + +; +; No more keys to add, so wrap up. +; +(set-buffer "Keys") +(insert "\ + ) + ) +") + +;;; +;;; Save the key mapping program and blow this pop stand +;;; +(let ((file (if edt-lucid-emacs19-p "~/.edt-lucid-keys" "~/.edt-gnu-keys"))) + (set-visited-file-name + (read-file-name (format "Save key mapping to file (default %s): " file) nil file))) +(save-buffer) + +(message "That's it! Press any key to exit") +(sit-for 600) +(kill-emacs t) + +;;; edt-mapper.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/edt-pc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulators/edt-pc.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,87 @@ +;;; edt-pc.el --- Enhanced EDT Keypad Mode Emulation for PC 101 Keyboards + +;; Copyright (C) 1986, 1994, 1995 Free Software Foundation, Inc. + +;; Author: Kevin Gallagher +;; Maintainer: Kevin Gallagher +;; Keywords: emulations + +;; 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 + +;;; Usage: + +;; See edt-user.doc in the Emacs etc directory. + +;; ==================================================================== + +;;;; +;;;; KEY TRANSLATIONS +;;;; + +;; Associate EDT keynames with Emacs terminal function vector names. +;; +;; To emulate the DEC LK-201 keypad keys on the PC 101 keyboard, +;; NumLock must be ON. +;; +;; The PC keypad keys are mapped to the corresponding DEC LK-201 +;; keypad keys according to the corresponding physical position on +;; the keyboard. Thus, the physical position of the PC keypad key +;; determines its function, not the PC keycap name. +;; +;; There are two LK-201 keypad keys needing special handling: PF1 and +;; the keypad comma key. +;; +;; PF1: +;; Most PC software does not see a press of the NumLock key. A TSR +;; program distributed with MS-Kermit to support its VT-100 emulation +;; solves this problem. The TSR, called GOLD, causes a press of the +;; keypad NumLock key to look as if the PC F1 key were pressed. So +;; the PC F1 key is mapped here to behave as the PF1 (GOLD) key. +;; Then with GOLD loaded, the NumLock key will behave as the GOLD key. +;; +;; By the way, with GOLD loaded, you can still toggle numlock on/off. +;; GOLD binds this to Shift-NumLock. +;; +;; Keypad Comma: +;; There is no physical PC keypad key to correspond to the LK-201 +;; keypad comma key. So, the EDT Emulation is configured below to +;; ignore attempts to bind functions to the keypad comma key. +;; +;; Finally, F2 through F12 are also available for making key bindings +;; in the EDT Emulation on the PC. F1 is reserved for the GOLD key, +;; so don't attempt to bind anything to it. Also, F13, F14, HELP, DO, +;; and F17 through F20 do not exist on the PC, so the EDT emulation is +;; configured below to ignore attempts to bind functions to those keys. +;; +(defconst *EDT-keys* + '(("KP0" . [kp-0]) ("KP1" . [kp-1]) ("KP2" . [kp-2]) ("KP3" . [kp-3]) + ("KP4" . [kp-4]) ("KP5" . [kp-5]) ("KP6" . [kp-6]) ("KP7" . [kp-7]) + ("KP8" . [kp-8]) ("KP9" . [kp-9]) ("KP," . "" ) + ("KP-" . [kp-add]) ("KPP" . [kp-decimal]) ("KPE" . [kp-enter]) + ("PF1" . [f1]) ("PF2" . [kp-divide]) ("PF3" . [kp-multiply]) + ("PF4" . [kp-subtract]) + ("UP" . [up]) ("DOWN" . [down]) ("RIGHT" . [right]) ("LEFT" . [left]) + ("FIND" . [insert]) ("INSERT" . [home]) ("REMOVE" . [prior]) + ("SELECT" . [delete]) ("PREVIOUS" . [end]) ("NEXT" . [next]) + ("F1" . "" ) ("F2" . [f2]) ("F3" . [f3]) ("F4" . [f4]) ("F5" . [f5]) + ("F6" . [f6]) ("F7" . [f7]) ("F8" . [f8]) ("F9" . [f9]) ("F10" . [f10]) + ("F11" . [f11]) ("F12" . [f12]) ("F13" . "" ) ("F14" . "" ) + ("HELP" . "" ) ("DO" . "" ) ("F17" . "" ) ("F18" . "" ) + ("F19" . "" ) ("F20" . "" ))) diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/edt-user.doc --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulators/edt-user.doc Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,782 @@ +File: edt-user.doc --- EDT Emulation User Instructions + + For GNU Emacs 19 + +Copyright (C) 1986, 1992, 1994, 1995 Free Software Foundation, Inc. + +Author: Kevin Gallagher +Maintainer: Kevin Gallagher +Keywords: emulations + +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. + +============================================================================ + +I. OVERVIEW: + +This version of the EDT emulation package for GNU Emacs is a substantially +enhanced version of the original. A large part of the original can still be +found here, of course, but much of it has been modified and quite a bit is +new. Many of the ideas found here are borrowed from others. In particular, +some of the code found here was drawn from an earlier re-write of the EDT +package done at DSC in 1989 by Matthew Frohman. + +Send bug fixes, suggestions for enhancements, and corrections to this +documentation to Kevin Gallagher (kgallagh@spd.dsccc.com). + +The EDT emulation consists of the following files: + +edt-user.doc - User instructions (which you are reading now) +edt.el - EDT Emulation Functions and Default Configuration +edt-lk201.el - Support for DEC LK-201 Keyboards +edt-vt100.el - Support for DEC VT-100 (and above) terminals +edt-mapper.el - Support for Keyboards used under X Windows +edt-pc.el - Support for the PC AT Keyboard under MS-DOS + +Several goals were kept in mind when making this version: + + 1. Emulate EDT Keypad Mode commands closely so that current + EDT users will find that it easy and comfortable to use + GNU Emacs with a small learning curve; + + 2. Make it easy for a user to customize EDT emulation key + bindings without knowing much about Emacs Lisp; + + 3. Make it easy to switch between the original EDT default bindings + and the user's customized bindings, without having to exit Emacs. + + 4. Provide support for some TPU/EVE functions not supported in + EDT. + + 5. Provide an easy way to restore ALL original Emacs key bindings, + just as they existed before the EDT emulation was first invoked. + + 6. Support GNU Emacs 19. (Support for GNU Emacs 18 has been dropped. + Also, although there is some code designed to support Xemacs 19 + (formerly Lucid Emacs), this is not fully implemented at this + time. + + 7. When running under X, support highlighting of marked text. + + 8. Handle terminal configuration under X interactively when the + emulation is invoked for the first time. + + 9. Support a PC AT keyboard under MS-DOS. + +II. TERMINALS/KEYBOARDS SUPPORTED: + +Keyboards used under X Windows are supported via the edt-mapper function. The +first time you invoke the emulation under X, the edt-mapper function is run +automatically and the user is prompted to identify which keys the emulation is +to use for the standard keypad and function keys EDT expects (e.g., PF1, PF2, +etc.). This configuration is saved to disk read each time the emulation is +invoked. + +In character oriented connections not running a window manager, the following +terminals/keyboards are supported. (1) DEC VT-100 series and higher. This +includes well behaved VT clones and emulators. If you are using a VT series +terminal, be sure that the term environment variable is set properly before +invoking emacs. (2) PC AT keyboard under MS-DOS. + +Be sure to read the SPECIAL NOTES FOR SOME PLATFORMS sections to see if those +notes apply to you. + + +III. STARTING THE EDT EMULATION: + +Start up GNU Emacs and enter "M-x edt-emulation-on" to begin the emulation. +After initialization is complete, the following message will appear below the +status line informing you that the emulation has been enabled: + + Default EDT keymap active + +You can have the EDT Emulation start up automatically, each time you initiate +a GNU Emacs session, by adding the following line to your .emacs file: + + (setq term-setup-hook 'edt-emulation-on) + +A reference sheet is included (later on) listing the default EDT Emulation key +bindings. This sheet is also accessible on line from within Emacs by pressing +PF2, GOLD H, or HELP (when in the EDT Default Mode). + +It is easy to customize key bindings in the EDT Emulation. (See CUSTOMIZING +section, below.) Customizations are placed in a file called edt-user.el. (A +sample edt-user.el file can be found in the CUSTOMIZING section.) If +edt-user.el is found in your GNU Emacs load path during EDT Emulation +initialization, then the following message will appear below the status line +indicating that the emulation has been enabled, enhanced by your own +customizations: + + User EDT custom keymap active + +Once enabled, it is easy to switch back and forth between your customized EDT +Emulation key bindings and the default EDT Emulation key bindings. It is also +easy to turn off the emulation. Doing so completely restores the original key +bindings in effect just prior to invoking the emulation. + +Where EDT key bindings and GNU Emacs key bindings conflict, the default GNU +Emacs key bindings are retained by the EDT emulation by default. If you are a +diehard EDT user you may not like this. The CUSTOMIZING section explains how +to change this default. + + +IV. SPECIAL NOTES FOR SOME PLATFORMS: + + Sun Workstations running X: + + Some earlier Sun keyboards do not have arrow keys separate from the + keypad keys. It is difficult to emulate the full EDT keypad and still + retain use of the arrow keys on such keyboards. + + The Sun Type 5 keyboard, however, does have separate arrow keys. This + makes it a candidate for setting up a reasonable EDT keypad emulation. + Unfortunately, Sun's default X keynames for the keypad keys don't permit + GNU Emacs to interpret the keypad 2, 4, 6, and 8 keys as something other + than arrow keys, nor use all the top row of keys for PF1 thru PF4 keys. + Here's the contents of an .xmodmaprc file which corrects this problem for + Sun Type 5 keyboards: + + ! File: .xmodmaprc + ! + ! Set up Sun Type 5 keypad for use with the GNU Emacs EDT Emulation + ! + keycode 53 = KP_Divide + keycode 54 = KP_Multiply + keycode 57 = KP_Decimal + keycode 75 = KP_7 + keycode 76 = KP_8 + keycode 77 = KP_9 + keycode 78 = KP_Subtract + keycode 97 = KP_Enter + keycode 98 = KP_4 + keycode 99 = KP_5 + keycode 100 = KP_6 + keycode 101 = KP_0 + keycode 105 = F24 + keycode 119 = KP_1 + keycode 120 = KP_2 + keycode 121 = KP_3 + keycode 132 = KP_Add + + Feed .xmodmaprc to the xmodmap command and all the Sun Type 5 keypad keys + will now be configurable for the emulation of an LK-201 keypad (less the + comma key). The line + + keycode 105 = F24 + + modifies the NumLock key to be the F24 key which can then be configured + to behave as the PF1 key. In doing so, you will no longer have a NumLock + key. If you are using other software under X which requires a NumLock + key, then examine your keyboard and look for one you don't use and + redefine it to be the NumLock key. (See the man page on xmodmap for for + further help on how to do this.) + + PC users running MS-DOS: + + By default, F1 is configured to emulate the PF1 (GOLD) key. But NumLock + can be used instead if you load a freeware TSR distributed with + MS-Kermit, call gold.com. It is distributed in a file called gold22.zip + and comes with the source code as well as a loadable binary image. + (See edt-pc.el for more information.) + + PC users running Linux: + + The default X server configuration of three keys PC AT keyboard keys + needs to be modified to permit the PC keyboard to emulate an LK-201 + keyboard properly. Here's the contents of an .xmodmaprc file which makes + these changes for your: + + ! File: .xmodmaprc + ! + ! Set up PC keypad under Linux for the GNU Emacs EDT Emulation + ! + keycode 22 = BackSpace + keycode 77 = F12 + keycode 96 = Num_Lock + + Feed the file to the xmodmap command and all the PC keypad keys will now + be configurable for the emulation of an LK-201 keypad (less the comma + key), the standard keyboard supplied with DEC terminals VT-200 and above. + This file switches the role of the F12 and NumLock keys. It also + modifies the definition of the Delete key above the arrow keys so that it + can be assigned a keybinding independently of the the BackSpace key. + + NOTE: It is necessary to have NumLock ON for the PC keypad to emulate the + LK-201 keypad properly. + + +V. HOW DOES THIS EDT EMULATION DIFFER FROM REAL EDT?: + +In general, you will find that this emulation of EDT replicates most, but not +all, of EDT's most used Keypad Mode editing functions and behavior. It is not +perfect, but most EDT users who have tried the emulation agree that it is +quite good enough to make it easy for die-hard EDT users to move over to using +GNU Emacs. + +Here's a list of the most important differences between EDT and this GNU Emacs +EDT Emulation. The list is short but you must be aware of these differences +if you are to use the EDT Emulation effectively. + +1. Entering repeat counts works a little differently than in EDT. + + EDT allows users to enter a repeat count before entering a command that + accepts repeat counts. For example, when in EDT, pressing these three + keys in sequence, GOLD 5 KP1, will move the cursor in the current + direction 5 words. + + Emacs provides two ways to enter repeat counts, though neither involves + using the GOLD key. In Emacs, repeat counts can be entered by using the + ESC key. For example, pressing these keys in sequence, ESC 1 0 KP1, will + move the cursor in the current direction 10 words. + + Emacs provides another command called universal-argument that can do the + same thing, plus a few other things. Normally, Emacs has this bound to + C-u. + +2. The EDT SUBS command, bound to GOLD ENTER, is NOT supported. The built-in + Emacs query-replace command has been bound to GOLD ENTER, instead. It is + much more convenient to use than SUBS. + +3. EDT's line mode commands and nokeypad mode commands are NOT supported + (with one important exception; see item 8 in the Highlights section + below). Although, at first, this may seem like a big omission, the set of + built-in Emacs commands provides a much richer set of capabilities which + more than make up for this omission. + + To enter Emacs commands not bound to keys, you can press GOLD KP7 or the + DO key. Emacs will display it's own command prompt called Meta-x (M-x). + You can also invoke this prompt the normal Emacs way by entering ESC x. + +4. Selected text is highlighted ONLY when running under X Windows. Gnu Emacs + 19 does not support highlighting of text on VT series terminals, at this + time. + +5. Just like TPU/EVE, The ENTER key is NOT used to terminate input when the + editor prompts you for input. The RETURN key is used, instead. (KP4 and + KP5 do terminate input for the FIND command, just like in EDT, however.) + + + + +VI. SOME HIGHLIGHTS IN THIS EDT EMULATION, AND SOME COMPARISONS TO THE + ORIGINAL GNU EMACS EDT EMULATION: + +1. The EDT define key command is supported (edt-define-key) and is bound to + C-k in the default EDT mode when EDT control sequence bindings are enabled + or one of the sample edt-user.el customization files is used. The TPU/EVE + learn command is supported but not bound to a key in the default EDT mode + but is bound in the sample edt-user.el files. + + Unlike the TPU/EVE learn command, which uses one key to begin the learn + sequence, C-l, and another command to remember the sequence, C-r, this + version of the learn command (edt-learn) serves as a toggle to both begin + and to remember the learn sequence. + + Many users who change the meaning of a key with the define key and the + learn commands, would like to be able to restore the original key binding + without having to quit and restart emacs. So a restore key command is + provided to do just that. When invoked, it prompts you to press the key + to which you wish the last replaced key definition restored. It is bound + to GOLD C-k in the default EDT mode when EDT control sequence bindings are + enabled or one of the sample edt-user.el customization files is used. + +2. Direction support is fully supported. It is no longer accomplished by + re-defining keys each time the direction is changed. Thus, commands + sensitive to the current direction setting may be bound easily to any key. + +3. All original emacs bindings are fully restored when EDT emulation is + turned off. + +4. User custom EDT bindings are kept separate from the default EDT bindings. + One can toggle back and forth between the custom EDT bindings and default + EDT bindings. + +5. The Emacs functions in edt.el attempt to emulate, where practical, the + exact behavior of the corresponding EDT keypad mode commands. In a few + cases, the emulation is not exact, but we hope you will agree it is close + enough. In a very few cases, we chose to use the Emacs way of handling + things. As mentioned earlier, we do not emulate the EDT SUBS command. + Instead, we chose to use the Emacs query-replace function, which we find + to be easier to use. + +6. Emacs uses the regexp assigned to page-delimiter to determine what marks a + page break. This is normally "^\f", which causes the edt-page command to + ignore form feeds not located at the beginning of a line. To emulate the + EDT PAGE command exactly, page-delimiter is set to "\f" when EDT emulation + is turned on, and restored to "^\f" when EDT emulation is turned off. + But, since some users prefer the Emacs definition of a page break, or may + wish to preserve a customized definition of page break, one can override + the EDT definition by placing + + (setq edt-keep-current-page-delimiter t) + + in your .emacs file. + +7. The EDT definition of a section of a terminal window is hardwired to be 16 + lines of its one-and-only 24-line window (the EDT SECT command bound to + KP8). That's two-thirds of the window at a time. Since Emacs, like + TPU/EVE, can handle multiple windows of sizes of other than 24 lines, the + definition of section used here has been modified to two-thirds of the + current window. (There is also an edt-scroll-window function which you + may prefer over the SECT emulation.) + +8. Cursor movement and deletion involving word entities is identical to EDT. + This, above all else, gives the die-hard EDT user a sense of being at + home. Also, an emulation of EDT's SET ENTITY WORD command is provided, + for those users who like to customize movement by a word at a time to + their own liking. + +9. EDT's FIND and FNDNXT are supported. + +10. EDT's APPEND and REPLACE commands are supported. + +11. CHNGCASE is supported. It works on individual characters or selected + text, if SELECT is active. In addition, two new commands are provided: + edt-lowercase and edt-uppercase. They work on individual WORDS or + selected text, if SELECT is active. + +12. Form feed and tab insert commands are supported. + +13. A new command, edt-duplicate-word, is provided. If you experiment with + it, you might find it to be surprisingly useful and may wonder how you + ever got along without it! It is assigned to C-j in the sample + edt-user.el customization files. + +14. TPU/EVE's Rectangular Cut and Paste functions (originally from the EVE-Plus + package) are supported. But unlike the TPU/EVE versions, these here + support both insert and overwrite modes. The seven rectangular functions + are bound to F7, F8, GOLD-F8, F9, GOLD-F9, F10, and GOLD-F10 in the + default EDT mode. + +15. The original EDT emulation package set up many default regular and GOLD + bindings. We tried to preserve most (but not all!) of these, so users of + the original emulation package will feel more at home. + + Nevertheless, there are still many GOLD key sequences which are not bound + to any functions. These are prime candidates to use for your own + customizations. + + Also, there are several commands in edt.el not bound to any key. So, you + will find it worthwhile to look through edt.el for functions you may wish + to add to your personal customized bindings. + +16. The VT200/VT300 series terminals steal the function keys F1 to F5 for + their own use. These do not generate signals which are sent to the host. + So, edt.el does not assign any default bindings to F1 through F5. + + In addition, our VT220 terminals generate an interrupt when the F6 key is + pressed (^C or ^Y, can't remember which) and not the character sequence + documented in the manual. So, binding emacs commands to F6 will not work + if your terminal behaves the same way. + +17. The VT220 terminal has no ESC, BS, nor LF keys, as does a VT100. So the + default EDT bindings adopt the standard DEC convention of having the F11, + F12, and F13 keys, on a VT200 series (and above) terminal, assigned to the + same EDT functions that are bound to ESC, BS, and LF on a VT100 terminal. + +18. Each user, through the use of a private edt-user.el file, can customize, + very easily, personal EDT emulation bindings. + +19. The EDT SELECT and RESET functions are supported. However, unlike EDT, + pressing RESET to cancel text selection does NOT reset the existing + setting of the current direction. + + We also provide a TPU/EVE like version of the single SELECT/RESET + function, called edt-toggle-select, which makes the EDT SELECT function + into a toggle on/off switch. That is, if selection is ON, pressing SELECT + again turns selection off (cancels selection). This function is used in + the sample edt-user.el customization files. + + +VII. CUSTOMIZING: + +Most EDT users, at one time or another, make some custom key bindings, or +use someone else's custom key bindings, which they come to depend upon just as +if they were built-in bindings. This EDT Emulation for GNU Emacs is designed +to make it easy to customize bindings. + +If you wish to customize the EDT Emulation to use some of your own key +bindings, you need to make a private version of edt-user.el in your own +private lisp directory. There are two sample files edt-user.el1 and +edt-user.el2 for you to use as templates and for ideas. Look at +edt-user.el1 first. Unless you will be using two or more very different +types of terminals on the same system, you need not look at edt-user.el2. + +First, you need to have your own private lisp directory, say ~/lisp, and +you should add it to the GNU Emacs load path. + +NOTE: A few sites have different load-path requirements, so the above + directions may need some modification if your site has such special + needs. + + +Creating your own edt-user.el file: + +A sample edt-user.el file is attached to the end of this user documentation. +You should use it as a guide to learn how you can customize EDT emulation +bindings to your own liking. Names used to identify the set of LK-201 +keypad and function keys are: + +Keypad Keys: + PF1 PF2 PF3 PF4 + KP7 KP8 KP9 KP- + KP4 KP5 KP6 KP, + KP1 KP2 KP3 + KP0 KPP KPE + +Arrow Keys: + LEFT RIGHT DOWN UP + +Function Keys: + F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 F11 F12 F13 F14 + HELP DO F17 F18 F19 F20 + + FIND INSERT REMOVE + SELECT PREVIOUS NEXT + +Note: + Many VT-200 terminals, and above, steal function keys F1 thru + F5 for terminal setup control and don't send anything to the + host if pressed. So customizing bindings to these keys may + not work for you. + +There are three basic functions that do the EDT emulation bindings: +edt-bind-standard-key, edt-bind-gold-key, and edt-bind-function-key. + +The first two are for binding functions to keys which are standard across most +keyboards. This makes them keyboard independent, making it possible to define +these key bindings for all terminals in the file edt.el. + +The first, edt-bind-standard-key, is used typically to bind emacs commands to +control keys, although some people use it to bind commands to other keys, as +well. (For example, some people use it to bind the VT200 seldom used +back-tick key (`) to the function "ESC-prefix" so it will behave like an ESC +key.) The second function, edt-bind-gold-key, is used to bind emacs commands +to gold key sequences involving alpha-numeric keys, special character keys, +and control keys. + +The third function, edt-bind-function-key, is terminal dependent and is +defined in a terminal specific file (see edt-vt100.el for example). It is +used to bind emacs commands to function keys, to keypad keys, and to gold +sequences of those keys. + +WARNING: Each of the three functions, edt-bind-function-key, + edt-bind-gold-key, and edt-bind-standard-key, has an optional + last argument. The optional argument should NOT be used in + edt-user.el! When the optional argument is missing, each + function knows to make the key binding part of the user's EDT + custom bindings, which is what you want to do in edt-user.el! + + The EDT default bindings are set up in edt.el by calling these + same functions with the optional last argument set to "t". So, if + you decide to copy such function calls from edt.el to edt-user.el + for subsequent modification, BE SURE TO DELETE THE "t" AT THE END + OF EACH PARAMETER LIST! + + +SPECIFYING WORD ENTITIES: + +The variable edt-word-entities is used to emulate EDT's SET ENTITY WORD +command. It contains a list of characters to be treated as words in +themselves. If the user does not define edt-word-entities in his/her .emacs +file, then it is set up with the EDT default containing only TAB. + +The characters are stored in the list by their numerical values, not as +strings. Emacs supports several ways to specify the numerical value of a +character. One method is to use the question mark: ?A means the numerical +value for A, ?/ means the numerical value for /, and so on. Several +unprintable characters have special representations: + + ?\b specifies BS, C-h + ?\t specifies TAB, C-i + ?\n specifies LFD, C-j + ?\v specifies VTAB, C-k + ?\f specifies FF, C-l + ?\r specifies CR, C-m + ?\e specifies ESC, C-[ + ?\\ specifies \ + +Here are some examples: + + (setq edt-word-entities '(?\t ?- ?/)) ;; Specifies TAB, - , and / + (setq edt-word-entities '(?\t) ;; Specifies TAB, the default + +You can also specify characters by their decimal ascii values: + + (setq edt-word-entities '(9 45 47)) ;; Specifies TAB, - , and / + + +ENABLING EDT CONTROL KEY SEQUENCE BINDINGS: + +Where EDT key bindings and GNU Emacs key bindings conflict, the default GNU +Emacs key bindings are retained by default. Some diehard EDT users may not +like this. So, if the variable edt-use-EDT-control-key-bindings is set to +true in a user's .emacs file, then the default EDT Emulation mode will enable +most of the original EDT control key sequence bindings. If you wish to do +this, add the following line to your .emacs file: + + (setq edt-use-EDT-control-key-bindings t) + + + DEFAULT EDT Keypad + + F7: Copy Rectangle +----------+----------+----------+----------+ + F8: Cut Rect Overstrike |Prev Line |Next Line |Bkwd Char |Frwd Char | + G-F8: Paste Rect Overstrike | (UP) | (DOWN) | (LEFT) | (RIGHT) | + F9: Cut Rect Insert |Window Top|Window Bot|Bkwd Sent |Frwd Sent | + G-F9: Paste Rect Insert +----------+----------+----------+----------+ + F10: Cut Rectangle +G-F10: Paste Rectangle + F11: ESC + F12: Begining of Line +----------+----------+----------+----------+ +G-F12: Delete Other Windows | GOLD | HELP | FNDNXT | DEL L | + F13: Delete to Begin of Word | (PF1) | (PF2) | (PF3) | (PF4) | + HELP: Keypad Help |Mark Wisel|Desc Funct| FIND | UND L | + DO: Execute extended command +----------+----------+----------+----------+ + | PAGE | SECT | APPEND | DEL W | + C-g: Keyboard Quit | (7) | (8) | (9) | (-) | +G-C-g: Keyboard Quit |Ex Ext Cmd|Fill Regio| REPLACE | UND W | + C-h: Beginning of Line +----------+----------+----------+----------+ +G-C-h: Emacs Help | ADVANCE | BACKUP | CUT | DEL C | + C-i: Tab Insert | (4) | (5) | (6) | (,) | + C-j: Delete to Begin of Word | BOTTOM | TOP | Yank | UND C | + C-k: Define Key +----------+----------+----------+----------+ +G-C-k: Restore Key | WORD | EOL | CHAR | Next | + C-l: Form Feed Insert | (1) | (2) | (3) | Window | + C-n: Set Screen Width 80 | CHNGCASE | DEL EOL |Quoted Ins| ! + C-r: Isearch Backward +---------------------+----------+ (ENTER) | + C-s: Isearch Forward | LINE | SELECT | ! + C-t: Display the Time | (0) | (.) | Query | + C-u: Delete to Begin of Line | Open Line | RESET | Replace | + C-v: Redraw Display +---------------------+----------+----------+ + C-w: Set Screen Width 132 + C-z: Suspend Emacs +----------+----------+----------+ +G-C-\: Split Window | FNDNXT | Yank | CUT | + | (FIND) | (INSERT) | (REMOVE) | + G-b: Buffer Menu | FIND | | COPY | + G-c: Compile +----------+----------+----------+ + G-d: Delete Window |SELECT/RES|SECT BACKW|SECT FORWA| + G-e: Exit | (SELECT) |(PREVIOUS)| (NEXT) | + G-f: Find File | | | | + G-g: Find File Other Window +----------+----------+----------+ + G-h: Keypad Help + G-i: Insert File + G-k: Toggle Capitalization Word + G-l: Lowercase Word or Region + G-m: Save Some Buffers + G-n: Next Error + G-o: Switch to Next Window + G-q: Quit + G-r: Revert File + G-s: Save Buffer + G-u: Uppercase Word or Region + G-v: Find File Other Window + G-w: Write file + G-y: EDT Emulation OFF + G-z: Switch to User EDT Key Bindings + G-1: Delete Other Windows + G-2: Split Window + G-%: Go to Percentage + G- : Undo (GOLD Spacebar) + G-=: Go to Line + G-`: What line + +;;; File: edt-user.el --- Sample User Customizations for the Enhanced +;;; EDT Keypad Mode Emulation +;;; +;;; For GNU Emacs 19 +;;; +;; Copyright (C) 1986, 1992, 1993 Free Software Foundation, Inc. + +;; Author: Kevin Gallagher +;; Maintainer: Kevin Gallagher +;; Keywords: emulations + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This file contains GNU Emacs User Custom EDT bindings and functions. In +;; this example file, there is no special test for the type of terminal being +;; used. The assumption is that all key bindings here apply to all terminals +;; that may be used. (In fact, it was written by an individual who uses only +;; VT series terminals when logging into a VAX.) +;; +;; WARNING: Each of the three functions, edt-bind-function-key, +;; edt-bind-gold-key, and edt-bind-standard-key, has an optional +;; last argument. The optional argument should NOT be used in +;; edt-user.el! When the optional argument is missing, each +;; function knows to make the key binding part of the user's EDT +;; custom bindings, which is what you want to do in edt-user.el! +;; +;; The EDT default bindings are set up in edt.el by calling these +;; same functions with the optional last argument set to "t". So, if +;; you decide to copy such function calls from edt.el to edt-user.el +;; for subsequent modification, BE SURE TO DELETE THE "t" AT THE END +;; OF EACH PARAMETER LIST! +;; + +;;; Usage: + +;; See edt-user.doc in the emacs etc directory. + +;; ==================================================================== + +;;;; +;;;; Setup user custom EDT key bindings. +;;;; + +(defun edt-setup-user-bindings () + "Assigns user custom EDT Emulation keyboard bindings." + + ;; PF1 (GOLD), PF2, PF3, PF4 + ;; + ;; This file MUST contain a binding of PF1 to edt-user-gold-map. So + ;; DON'T CHANGE OR DELETE THE REGULAR KEY BINDING OF PF1 BELOW! + ;; (However, you may change the GOLD-PF1 binding, if you wish.) + (edt-bind-function-key "PF1" 'edt-user-gold-map 'edt-mark-section-wisely) + (edt-bind-function-key "PF2" 'query-replace 'other-window) + (edt-bind-function-key "PF4" 'edt-delete-entire-line 'edt-undelete-line) + + ;; EDT Keypad Keys + (edt-bind-function-key "KP1" 'edt-word-forward 'edt-change-case) + (edt-bind-function-key "KP3" 'edt-word-backward 'edt-copy) + (edt-bind-function-key "KP6" 'edt-cut-or-copy 'yank) + (edt-bind-function-key "KP8" 'edt-scroll-window 'fill-paragraph) + (edt-bind-function-key "KP9" 'open-line 'edt-eliminate-all-tabs) + (edt-bind-function-key "KPP" + 'edt-toggle-select 'edt-line-to-middle-of-window) + (edt-bind-function-key "KPE" 'edt-change-direction 'overwrite-mode) + + ;; GOLD bindings for regular keys. + (edt-bind-gold-key "a" 'edt-append) + (edt-bind-gold-key "A" 'edt-append) + (edt-bind-gold-key "h" 'edt-electric-user-keypad-help) + (edt-bind-gold-key "H" 'edt-electric-user-keypad-help) + + ;; Control bindings for regular keys. + ;;; Leave binding of C-c as original prefix key. + (edt-bind-standard-key "\C-j" 'edt-duplicate-word) + (edt-bind-standard-key "\C-k" 'edt-define-key) + (edt-bind-gold-key "\C-k" 'edt-restore-key) + (edt-bind-standard-key "\C-l" 'edt-learn) + ;;; Leave binding of C-m to newline. + (edt-bind-standard-key "\C-n" 'edt-set-screen-width-80) + (edt-bind-standard-key "\C-o" 'open-line) + (edt-bind-standard-key "\C-p" 'fill-paragraph) + ;;; Leave binding of C-r to isearch-backward. + ;;; Leave binding of C-s to isearch-forward. + (edt-bind-standard-key "\C-t" 'edt-display-the-time) + (edt-bind-standard-key "\C-v" 'redraw-display) + (edt-bind-standard-key "\C-w" 'edt-set-screen-width-132) + ;;; Leave binding of C-x as original prefix key. +) + +;;; +;;; LK-201 KEYBOARD USER EDT KEYPAD HELP +;;; + +(defun edt-user-keypad-help () + " + USER EDT Keypad Active + + +----------+----------+----------+----------+ + F7: Copy Rectangle |Prev Line |Next Line |Bkwd Char |Frwd Char | + F8: Cut Rect Overstrike | (UP) | (DOWN) | (LEFT) | (RIGHT) | + G-F8: Paste Rect Overstrike |Window Top|Window Bot|Bkwd Sent |Frwd Sent | + F9: Cut Rect Insert +----------+----------+----------+----------+ + G-F9: Paste Rect Insert + F10: Cut Rectangle +G-F10: Paste Rectangle + F11: ESC +----------+----------+----------+----------+ + F12: Begining of Line | GOLD |Query Repl| FNDNXT |Del Ent L | +G-F12: Delete Other Windows | (PF1) | (PF2) | (PF3) | (PF4) | + F13: Delete to Begin of Word |Mark Wisel|Other Wind| FIND | UND L | + HELP: Keypad Help +----------+----------+----------+----------+ + DO: Execute extended command | PAGE |Scroll Win|Open Line | DEL W | + | (7) | (8) | (9) | (-) | + C-a: Beginning of Line |Ex Ext Cmd|Fill Parag|Elim Tabs | UND W | + C-b: Switch to Buffer +----------+----------+----------+----------+ + C-d: Delete Character | ADVANCE | BACKUP | CUT/COPY | DEL C | + C-e: End of Line | (4) | (5) | (6) | (,) | + C-f: Forward Character | BOTTOM | TOP | Yank | UND C | + C-g: Keyboard Quit +----------+----------+----------+----------+ +G-C-g: Keyboard Quit | Fwd Word | EOL | Bwd Word | Change | + C-h: Electric Emacs Help | (1) | (2) | (3) | Direction| +G-C-h: Emacs Help | CHNGCASE | DEL EOL | COPY | | + C-i: Indent for Tab +---------------------+----------+ (ENTER) | + C-j: Duplicate Word | LINE |SELECT/RES| | + C-k: Define Key | (0) | (.) | Toggle | +G-C-k: Restore Key | Open Line |Center Lin|Insrt/Over| + C-l: Learn +---------------------+----------+----------+ + C-n: Set Screen Width 80 + C-o: Open Line +----------+----------+----------+ + C-p: Fill Paragraph | FNDNXT | Yank | CUT | + C-q: Quoted Insert | (FIND)) | (INSERT) | (REMOVE) | + C-r: Isearch Backward | FIND | | COPY | + C-s: Isearch Forward +----------+----------+----------+ + C-t: Display the Time |SELECT/RES|SECT BACKW|SECT FORWA| + C-u: Universal Argument | (SELECT) |(PREVIOUS)| (NEXT) | + C-v: Redraw Display | | | | + C-w: Set Screen Width 132 +----------+----------+----------+ + C-z: Suspend Emacs +G-C-\\: Split Window + + G-a: Append to Kill Buffer + G-b: Buffer Menu + G-c: Compile + G-d: Delete Window + G-e: Exit + G-f: Find File + G-g: Find File Other Window + G-h: Keypad Help + G-i: Insert File + G-k: Toggle Capitalization Word + G-l: Lowercase Word or Region + G-m: Save Some Buffers + G-n: Next Error + G-o: Switch Windows + G-q: Quit + G-r: Revert File + G-s: Save Buffer + G-u: Uppercase Word or Region + G-v: Find File Other Window + G-w: Write file + G-y: EDT Emulation OFF + G-z: Switch to Default EDT Key Bindings + G-2: Split Window + G-%: Go to Percentage + G- : Undo (GOLD Spacebar) + G-=: Go to Line + G-`: What line" + + (interactive) + (describe-function 'edt-user-keypad-help)) diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/edt-vt100.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulators/edt-vt100.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,46 @@ +;;; edt-vt100.el --- Enhanced EDT Keypad Mode Emulation for VT Series Terminals + +;; Copyright (C) 1986, 1992, 1993, 1995 Free Software Foundation, Inc. + +;; Author: Kevin Gallagher +;; Maintainer: Kevin Gallagher +;; Keywords: emulations + +;; 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 + +;;; Usage: + +;; See edt-user.doc in the Emacs etc directory. + +;; ==================================================================== + +;; Get keyboard function key mapping to EDT keys. +(load "edt-lk201" nil t) + +;; The following functions are called by the EDT screen width commands defined +;; in edt.el. + +(defun edt-set-term-width-80 () + "Set terminal width to 80 columns." + (vt100-wide-mode -1)) + +(defun edt-set-term-width-132 () + "Set terminal width to 132 columns." + (vt100-wide-mode 1)) diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/edt.el --- a/lisp/emulators/edt.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/edt.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,9 +1,10 @@ -;;; edt.el --- EDT emulation in Emacs -;; Keywords: emulations +;;; edt.el --- Enhanced EDT Keypad Mode Emulation for GNU Emacs 19 + +;; Copyright (C) 1986, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. -;; Copyright (C) 1986 Free Software Foundation, Inc. -;; It started from public domain code by Mike Clarkson -;; but has been greatly altered. +;; Author: Kevin Gallagher +;; Maintainer: Kevin Gallagher +;; Keywords: emulations ;; This file is part of XEmacs. @@ -19,491 +20,2003 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34 + +;;; Usage: + +;; See edt-user.doc in the Emacs etc directory. + +;; Maintainer's note: There was a very old edt.el here that wouldn't even +;; load, so I replaced it completely with the newer one from 19.34. -sb +;; ==================================================================== + +;;; Electric Help functions are used for keypad help displays. A few +;;; picture functions are used in rectangular cut and paste commands. +(require 'ehelp) +(require 'picture) + +;;;; +;;;; VARIABLES and CONSTANTS +;;;; + +(defvar edt-last-deleted-lines "" + "Last text deleted by an EDT emulation line delete command.") + +(defvar edt-last-deleted-words "" + "Last text deleted by an EDT emulation word delete command.") + +(defvar edt-last-deleted-chars "" + "Last text deleted by an EDT emulation character delete command.") + +(defvar edt-last-replaced-key-definition "" + "Key definition replaced with edt-define-key or edt-learn command.") + +(defvar edt-direction-string "" + "String indicating current direction of movement.") + +(defvar edt-select-mode nil + "Non-nil means select mode is active.") + +(defvar edt-select-mode-text "" + "Text displayed in mode line when select mode is active.") + +(defconst edt-select-mode-string " Select" + "String to indicate select mode is active.") + +(defconst edt-forward-string " ADVANCE" + "Direction string in mode line to indicate forward movement.") + +(defconst edt-backward-string " BACKUP" + "Direction string in mode line to indicate backward movement.") + +(defvar edt-default-map-active nil + "Non-nil indicates that default EDT emulation key bindings are active. +Nil means user-defined custom bindings are active.") + +(defvar edt-user-map-configured nil + "Non-nil indicates that user custom EDT key bindings are configured. +This means that an edt-user.el file was found in the user's load-path.") + +(defvar edt-keep-current-page-delimiter nil + "Non-nil leaves current value of page-delimiter unchanged. +Nil causes the page-delimiter variable to be set to to \"\\f\" +when edt-emulation-on is first invoked. Original value is restored +when edt-emulation-off is called.") + +(defvar edt-use-EDT-control-key-bindings nil + "Non-nil causes the control key bindings to be replaced with EDT bindings. +Nil (the default) means EDT control key bindings are not used and the current +control key bindings are retained for use in the EDT emulation.") + +(defvar edt-word-entities '(?\t) + "*Specifies the list of EDT word entity characters.") + +;;; +;;; Emacs version identifiers - currently referenced by +;;; +;;; o edt-emulation-on o edt-load-xkeys +;;; +(defconst edt-emacs19-p (not (string-lessp emacs-version "19")) + "Non-nil if we are running Lucid or GNU Emacs version 19.") + +(defconst edt-lucid-emacs19-p + (and edt-emacs19-p (string-match "Lucid" emacs-version)) + "Non-nil if we are running Lucid Emacs version 19.") + +(defconst edt-gnu-emacs19-p (and edt-emacs19-p (not edt-lucid-emacs19-p)) + "Non-nil if we are running GNU Emacs version 19.") + +(defvar edt-xkeys-file nil + "File mapping X function keys to LK-201 keyboard function and keypad keys.") + +;;;; +;;;; EDT Emulation Commands +;;;; + +;;; Almost all of EDT's keypad mode commands have equivalent +;;; counterparts in Emacs. Some behave the same way in Emacs as they +;;; do in EDT, but most do not. +;;; +;;; The following Emacs functions emulate, where practical, the exact +;;; behavior of the corresponding EDT keypad mode commands. In a few +;;; cases, the emulation is not exact, but it is close enough for most +;;; EDT die-hards. +;;; +;;; In a very few cases, we chose to use the superior Emacs way of +;;; handling things. For example, we do not emulate the EDT SUBS +;;; command. Instead, we chose to use the superior Emacs +;;; query-replace function. +;;; + +;;; +;;; PAGE +;;; +;;; Emacs uses the regexp assigned to page-delimiter to determine what +;;; marks a page break. This is normally "^\f", which causes the +;;; edt-page command to ignore form feeds not located at the beginning +;;; of a line. To emulate the EDT PAGE command exactly, +;;; page-delimiter is set to "\f" when EDT emulation is turned on, and +;;; restored to its original value when EDT emulation is turned off. +;;; But this can be overridden if the EDT definition is not desired by +;;; placing +;;; +;;; (setq edt-keep-current-page-delimiter t) +;;; +;;; in your .emacs file. + +(defun edt-page-forward (num) + "Move forward to just after next page delimiter. +Accepts a positive prefix argument for the number of page delimiters to move." + (interactive "p") + (edt-check-prefix num) + (if (eobp) + (error "End of buffer") + (progn + (forward-page num) + (if (eobp) + (edt-line-to-bottom-of-window) + (edt-line-to-top-of-window))))) + +(defun edt-page-backward (num) + "Move backward to just after previous page delimiter. +Accepts a positive prefix argument for the number of page delimiters to move." + (interactive "p") + (edt-check-prefix num) + (if (bobp) + (error "Beginning of buffer") + (progn + (backward-page num) + (edt-line-to-top-of-window)))) + +(defun edt-page (num) + "Move in current direction to next page delimiter. +Accepts a positive prefix argument for the number of page delimiters to move." + (interactive "p") + (if (equal edt-direction-string edt-forward-string) + (edt-page-forward num) + (edt-page-backward num))) + +;;; +;;; SECT +;;; +;;; EDT defaults a section size to be 16 lines of its one and only +;;; 24-line window. That's two-thirds of the window at a time. The +;;; EDT SECT commands moves the cursor, not the window. +;;; +;;; This emulation of EDT's SECT moves the cursor approximately two-thirds +;;; of the current window at a time. + +(defun edt-sect-forward (num) + "Move cursor forward two-thirds of a window. +Accepts a positive prefix argument for the number of sections to move." + (interactive "p") + (edt-check-prefix num) + (edt-line-forward (* (* (/ (- (window-height) 1) 3) 2) num))) + +(defun edt-sect-backward (num) + "Move cursor backward two-thirds of a window. +Accepts a positive prefix argument for the number of sections to move." + (interactive "p") + (edt-check-prefix num) + (edt-line-backward (* (* (/ (- (window-height) 1) 3) 2) num))) + +(defun edt-sect (num) + "Move in current direction a full window. +Accepts a positive prefix argument for the number windows to move." + (interactive "p") + (if (equal edt-direction-string edt-forward-string) + (edt-sect-forward num) + (edt-sect-backward num))) + +;;; +;;; BEGINNING OF LINE +;;; +;;; EDT's beginning-of-line command is not affected by current +;;; direction, for some unknown reason. + +(defun edt-beginning-of-line (num) + "Move backward to next beginning of line mark. +Accepts a positive prefix argument for the number of BOL marks to move." + (interactive "p") + (edt-check-prefix num) + (if (bolp) + (forward-line (* -1 num)) + (progn + (setq num (1- num)) + (forward-line (* -1 num))))) + +;;; +;;; EOL (End of Line) +;;; + +(defun edt-end-of-line-forward (num) + "Move forward to next end of line mark. +Accepts a positive prefix argument for the number of EOL marks to move." + (interactive "p") + (edt-check-prefix num) + (forward-char) + (end-of-line num)) + +(defun edt-end-of-line-backward (num) + "Move backward to next end of line mark. +Accepts a positive prefix argument for the number of EOL marks to move." + (interactive "p") + (edt-check-prefix num) + (end-of-line (1- num))) + +(defun edt-end-of-line (num) + "Move in current direction to next end of line mark. +Accepts a positive prefix argument for the number of EOL marks to move." + (interactive "p") + (if (equal edt-direction-string edt-forward-string) + (edt-end-of-line-forward num) + (edt-end-of-line-backward num))) + +;;; +;;; WORD +;;; +;;; This one is a tad messy. To emulate EDT's behavior everywhere in +;;; the file (beginning of file, end of file, beginning of line, end +;;; of line, etc.) it takes a bit of special handling. +;;; +;;; The variable edt-word-entities contains a list of characters which +;;; are to be viewed as distinct words where ever they appear in the +;;; buffer. This emulates the EDT line mode command SET ENTITY WORD. -;; From mike@yetti.UUCP Fri Aug 29 12:49:28 1986 -;; Path: mit-prep!mit-hermes!mit-eddie!genrad!panda!husc6!seismo!mnetor!yetti!mike -;; From: mike@yetti.UUCP (Mike Clarkson ) -;; Newsgroups: net.sources -;; Subject: Gnu Emacs EDT Emulation - Introduction - 1/3 -;; Date: 27 Aug 86 23:30:33 GMT -;; Reply-To: mike@yetti.UUCP (Mike Clarkson ) -;; Organization: York University Computer Science -;; -;; Here's my EDT emulation for GNU Emacs that is based on the EDT emulation -;; for Gosling's Emacs sent out on the net a couple of years ago by Lynn Olson -;; at Tektronics. This emulation was widely distributed as the file edt.ml -;; in the maclib directory of most Emacs distributions. -;; -;; My emulation consists of two files: edt.el and edtdoc.el. The edtdoc.el file -;; is the documentation, that you can add to the beginning of edt.el if you -;; want. I have split them because I have been loading the edt.el file a lot -;; during debugging. -;; -;; I will gladly take all criticisms and complaints to heart, and will fix -;; what bugs I can find. As this is my first elisp hack, you may have to -;; root out a few nasties hidden in the code. Please let me know if you -;; find any (sorry, -;; no rewards :-). I would also be interested if there are better, -;; cleaner, faster ways of doing some of the things that I have done. -;; -;; You must understand some design considerations that I had in mind. -;; The intention was not really to "emulate" EDT, but rather to take advantage -;; of the years of EDT experience that had accumulated in my right hand, -;; while at the same time taking advantage of EMACS. -;; -;; Some major differences are: -;; -;; HELP is describe-key; -;; GOLD/HELP is describe-function; -;; FIND is isearch-forward/backward; -;; GOLD/HELP is occur-menu, which finds all occurrences of a search string; -;; ENTER is other-window; -;; SUBS is subprocess-command. Note that you will have to change this -;; yourself to shell if you are running Un*x; -;; PAGE is next-paragraph, because that's more useful than page. -;; SPECINS is copy-to-killring; -;; GOLD/GOLD is mark-section-wisely, which is my command to mark the -;; section in a manner consistent with the major-mode. It -;; uses mark-defun for emacs-lisp, lisp, mark-c-function for C, -;; and mark-paragraph for other modes. -;; -;; -;; Some subtle differences are: -;; -;; APPEND is append-to-buffer. One doesn't append to the kill ring much -;; and SPECINS is now copy-to-killring; -;; REPLACE is replace-regexp; -;; FILL is fill-region-wisely, which uses indent-region for C, lisp -;; emacs-lisp, and fill-region for others. It asks if you really -;; want to fill-region in TeX-mode, because I find this to be -;; very dangerous. -;; CHNGCASE is case-flip for the character under the cursor only. -;; I felt that case-flip region is unlikely, as usually you -;; upcase-region or downcase region. Also, unlike EDT it -;; is independent of the direction you are going, as that -;; drives me nuts. -;; -;; I use Emacs definition of what a word is. This is considerably different from -;; what EDT thinks a word is. This is not good for dyed-in-the-wool EDT fans, -;; but is probably preferable for experienced Emacs users. My assumption is that -;; the former are a dying breed now that GNU Emacs has made it to VMS, but let me -;; know how you feel. Also, when you undelete a word it leave the point at the -;; end of the undeleted text, rather than the beginning. I might change this -;; as I'm not sure if I like this or not. I'm also not sure if I want it to -;; set the mark each time you delete a character or word. -;; -;; Backspace does not invoke beginning-of-line, because ^H is the help prefix, -;; and I felt it should be left as such. You can change this if you like. -;; -;; The ADVANCE and BACKUP keys do not work as terminators for forward or -;; backward searches. In Emacs, all search strings are terminated by return. -;; The searches will however go forward or backward depending on your current -;; direction. Also, when you change directions, the mode line will not be -;; updated immediately, but only when you next execute an emacs function. -;; Personally, I consider this to be a bug, not a feature. -;; -;; This should also work with VT-2xx's, though I haven't tested it extensively -;; on those terminals. It assumes that the CSI-map of vt_200.el has been defined. -;; -;; There are also a whole bunch of GOLD letter, and GOLD character bindings: -;; look at edtdoc.el for them, or better still, look at the edt.el lisp code, -;; because after all, in the true Lisp tradition, the source code is *assumed* -;; to be self-documenting :-) -;; -;; Mike Clarkson, ...!allegra \ BITNET: mike@YUYETTI or -;; CRESS, York University, ...!decvax \ SYMALG@YUSOL -;; 4700 Keele Street, ...!ihnp4 > !utzoo!yetti!mike -;; North York, Ontario, ...!linus / -;; CANADA M3J 1P3. ...!watmath / Phone: +1 (416) 736-2100 x 7767 -;; -;; Note that I am not on ARPA, and must gateway any ARPA mail through BITNET or -;; UUCP. If you have a UUCP or BITNET address please use it for communication -;; so that I can reach you directly. If you have both, the BITNET address -;; is preferred. -;; -- -;; Mike Clarkson, ...!allegra \ BITNET: mike@YUYETTI or -;; CRESS, York University, ...!decvax \ SYMALG@YUSOL -;; 4700 Keele Street, ...!ihnp4 > !utzoo!yetti!mike -;; North York, Ontario, ...!linus / -;; CANADA M3J 1P3. ...!watmath / Phone: +1 (416) 737-2100 x 7767 +(defun edt-one-word-forward () + "Move forward to first character of next word." + (interactive) + (if (eobp) + (error "End of buffer")) + (if (eolp) + (forward-char) + (progn + (if (memq (following-char) edt-word-entities) + (forward-char) + (while (and + (not (eolp)) + (not (eobp)) + (not (eq ?\ (char-syntax (following-char)))) + (not (memq (following-char) edt-word-entities))) + (forward-char))) + (while (and + (not (eolp)) + (not (eobp)) + (eq ?\ (char-syntax (following-char))) + (not (memq (following-char) edt-word-entities))) + (forward-char))))) + +(defun edt-one-word-backward () + "Move backward to first character of previous word." + (interactive) + (if (bobp) + (error "Beginning of buffer")) + (if (bolp) + (backward-char) + (progn + (backward-char) + (while (and + (not (bolp)) + (not (bobp)) + (eq ?\ (char-syntax (following-char))) + (not (memq (following-char) edt-word-entities))) + (backward-char)) + (if (not (memq (following-char) edt-word-entities)) + (while (and + (not (bolp)) + (not (bobp)) + (not (eq ?\ (char-syntax (preceding-char)))) + (not (memq (preceding-char) edt-word-entities))) + (backward-char)))))) + +(defun edt-word-forward (num) + "Move forward to first character of next word. +Accepts a positive prefix argument for the number of words to move." + (interactive "p") + (edt-check-prefix num) + (while (> num 0) + (edt-one-word-forward) + (setq num (1- num)))) + +(defun edt-word-backward (num) + "Move backward to first character of previous word. +Accepts a positive prefix argument for the number of words to move." + (interactive "p") + (edt-check-prefix num) + (while (> num 0) + (edt-one-word-backward) + (setq num (1- num)))) + +(defun edt-word (num) + "Move in current direction to first character of next word. +Accepts a positive prefix argument for the number of words to move." + (interactive "p") + (if (equal edt-direction-string edt-forward-string) + (edt-word-forward num) + (edt-word-backward num))) + +;;; +;;; CHAR +;;; + +(defun edt-character (num) + "Move in current direction to next character. +Accepts a positive prefix argument for the number of characters to move." + (interactive "p") + (edt-check-prefix num) + (if (equal edt-direction-string edt-forward-string) + (forward-char num) + (backward-char num))) + +;;; +;;; LINE +;;; +;;; When direction is set to BACKUP, LINE behaves just like BEGINNING +;;; OF LINE in EDT. So edt-line-backward is not really needed as a +;;; separate function. + +(defun edt-line-backward (num) + "Move backward to next beginning of line mark. +Accepts a positive prefix argument for the number of BOL marks to move." + (interactive "p") + (edt-beginning-of-line num)) + +(defun edt-line-forward (num) + "Move forward to next beginning of line mark. +Accepts a positive prefix argument for the number of BOL marks to move." + (interactive "p") + (edt-check-prefix num) + (forward-line num)) +(defun edt-line (num) + "Move in current direction to next beginning of line mark. +Accepts a positive prefix argument for the number of BOL marks to move." + (interactive "p") + (if (equal edt-direction-string edt-forward-string) + (edt-line-forward num) + (edt-line-backward num))) -(require 'keypad) +;;; +;;; TOP +;;; + +(defun edt-top () + "Move cursor to the beginning of buffer." + (interactive) + (goto-char (point-min))) + +;;; +;;; BOTTOM +;;; + +(defun edt-bottom () + "Move cursor to the end of buffer." + (interactive) + (goto-char (point-max)) + (edt-line-to-bottom-of-window)) + +;;; +;;; FIND +;;; + +(defun edt-find-forward (&optional find) + "Find first occurrence of a string in forward direction and save it." + (interactive) + (if (not find) + (set 'search-last-string (read-string "Search forward: "))) + (if (search-forward search-last-string) + (search-backward search-last-string))) + +(defun edt-find-backward (&optional find) + "Find first occurrence of a string in the backward direction and save it." + (interactive) + (if (not find) + (set 'search-last-string (read-string "Search backward: "))) + (search-backward search-last-string)) -(defvar edt-last-deleted-lines "" - "Last text deleted by an EDT emulation line-delete command.") -(defvar edt-last-deleted-words "" - "Last text deleted by an EDT emulation word-delete command.") -(defvar edt-last-deleted-chars "" - "Last text deleted by an EDT emulation character-delete command.") +(defun edt-find () + "Find first occurrence of string in current direction and save it." + (interactive) + (set 'search-last-string (read-string "Search: ")) + (if (equal edt-direction-string edt-forward-string) + (edt-find-forward t) + (edt-find-backward t))) + + +;;; +;;; FNDNXT +;;; + +(defun edt-find-next-forward () + "Find next occurrence of a string in forward direction." + (interactive) + (forward-char 1) + (if (search-forward search-last-string nil t) + (search-backward search-last-string) + (progn + (backward-char 1) + (error "Search failed: \"%s\"." search-last-string)))) -(defun delete-current-line (num) - "Delete one or specified number of lines after point. -This includes the newline character at the end of each line. -They are saved for the EDT undelete-lines command." - (interactive "p") +(defun edt-find-next-backward () + "Find next occurrence of a string in backward direction." + (interactive) + (if (eq (search-backward search-last-string nil t) nil) + (progn + (error "Search failed: \"%s\"." search-last-string)))) + +(defun edt-find-next () + "Find next occurrence of a string in current direction." + (interactive) + (if (equal edt-direction-string edt-forward-string) + (edt-find-next-forward) + (edt-find-next-backward))) + +;;; +;;; APPEND +;;; + +(defun edt-append () + "Append this kill region to last killed region." + (interactive "*") + (edt-check-selection) + (append-next-kill) + (kill-region (mark) (point)) + (message "Selected text APPENDED to kill ring")) + +;;; +;;; DEL L +;;; + +(defun edt-delete-line (num) + "Delete from cursor up to and including the end of line mark. +Accepts a positive prefix argument for the number of lines to delete." + (interactive "*p") + (edt-check-prefix num) (let ((beg (point))) (forward-line num) (if (not (eq (preceding-char) ?\n)) - (insert "\n")) + (insert "\n")) (setq edt-last-deleted-lines - (buffer-substring beg (point))) + (buffer-substring beg (point))) (delete-region beg (point)))) -(defun delete-to-eol (num) - "Delete text up to end of line. -With argument, delete up to to Nth line-end past point. -They are saved for the EDT undelete-lines command." - (interactive "p") +;;; +;;; DEL EOL +;;; + +(defun edt-delete-to-end-of-line (num) + "Delete from cursor up to but excluding the end of line mark. +Accepts a positive prefix argument for the number of lines to delete." + (interactive "*p") + (edt-check-prefix num) (let ((beg (point))) (forward-char 1) (end-of-line num) (setq edt-last-deleted-lines - (buffer-substring beg (point))) - (delete-region beg (point)))) - -(defun delete-current-word (num) - "Delete one or specified number of words after point. -They are saved for the EDT undelete-words command." - (interactive "p") - (let ((beg (point))) - (forward-word num) - (setq edt-last-deleted-words - (buffer-substring beg (point))) + (buffer-substring beg (point))) (delete-region beg (point)))) -(defun edt-delete-previous-word (num) - "Delete one or specified number of words before point. -They are saved for the EDT undelete-words command." - (interactive "p") +;;; +;;; SELECT +;;; + +(defun edt-select-mode (arg) + "Turn EDT select mode off if ARG is nil; otherwise, turn EDT select mode on. +In select mode, selected text is highlighted." + (if arg + (progn + (make-local-variable 'edt-select-mode) + (setq edt-select-mode 'edt-select-mode-text) + (setq rect-start-point (window-point))) + (progn + (kill-local-variable 'edt-select-mode))) + (force-mode-line-update)) + +(defun edt-select () + "Set mark at cursor and start text selection." + (interactive) + (set-mark-command nil)) + +(defun edt-reset () + "Cancel text selection." + (interactive) + (deactivate-mark)) + +;;; +;;; CUT +;;; + +(defun edt-cut () + "Deletes selected text but copies to kill ring." + (interactive "*") + (edt-check-selection) + (kill-region (mark) (point)) + (message "Selected text CUT to kill ring")) + +;;; +;;; DELETE TO BEGINNING OF LINE +;;; + +(defun edt-delete-to-beginning-of-line (num) + "Delete from cursor to beginning of line. +Accepts a positive prefix argument for the number of lines to delete." + (interactive "*p") + (edt-check-prefix num) (let ((beg (point))) - (forward-word (- num)) - (setq edt-last-deleted-words - (buffer-substring (point) beg)) + (edt-beginning-of-line num) + (setq edt-last-deleted-lines + (buffer-substring (point) beg)) (delete-region beg (point)))) -(defun delete-current-char (num) - "Delete one or specified number of characters after point. -They are saved for the EDT undelete-chars command." - (interactive "p") +;;; +;;; DEL W +;;; + +(defun edt-delete-word (num) + "Delete from cursor up to but excluding first character of next word. +Accepts a positive prefix argument for the number of words to delete." + (interactive "*p") + (edt-check-prefix num) + (let ((beg (point))) + (edt-word-forward num) + (setq edt-last-deleted-words (buffer-substring beg (point))) + (delete-region beg (point)))) + +;;; +;;; DELETE TO BEGINNING OF WORD +;;; + +(defun edt-delete-to-beginning-of-word (num) + "Delete from cursor to beginning of word. +Accepts a positive prefix argument for the number of words to delete." + (interactive "*p") + (edt-check-prefix num) + (let ((beg (point))) + (edt-word-backward num) + (setq edt-last-deleted-words (buffer-substring (point) beg)) + (delete-region beg (point)))) + +;;; +;;; DEL C +;;; + +(defun edt-delete-character (num) + "Delete character under cursor. +Accepts a positive prefix argument for the number of characters to delete." + (interactive "*p") + (edt-check-prefix num) (setq edt-last-deleted-chars - (buffer-substring (point) (min (point-max) (+ (point) num)))) + (buffer-substring (point) (min (point-max) (+ (point) num)))) (delete-region (point) (min (point-max) (+ (point) num)))) -(defun delete-previous-char (num) - "Delete one or specified number of characters before point. -They are saved for the EDT undelete-chars command." - (interactive "p") +;;; +;;; DELETE CHAR +;;; + +(defun edt-delete-previous-character (num) + "Delete character in front of cursor. +Accepts a positive prefix argument for the number of characters to delete." + (interactive "*p") + (edt-check-prefix num) (setq edt-last-deleted-chars - (buffer-substring (max (point-min) (- (point) num)) (point))) + (buffer-substring (max (point-min) (- (point) num)) (point))) (delete-region (max (point-min) (- (point) num)) (point))) -(defun undelete-lines () - "Yank lines deleted by last EDT line-deletion command." - (interactive) - (insert edt-last-deleted-lines)) +;;; +;;; UND L +;;; + +(defun edt-undelete-line () + "Undelete previous deleted line(s)." + (interactive "*") + (point-to-register 1) + (insert edt-last-deleted-lines) + (register-to-point 1)) + +;;; +;;; UND W +;;; + +(defun edt-undelete-word () + "Undelete previous deleted word(s)." + (interactive "*") + (point-to-register 1) + (insert edt-last-deleted-words) + (register-to-point 1)) + +;;; +;;; UND C +;;; + +(defun edt-undelete-character () + "Undelete previous deleted character(s)." + (interactive "*") + (point-to-register 1) + (insert edt-last-deleted-chars) + (register-to-point 1)) + +;;; +;;; REPLACE +;;; -(defun undelete-words () - "Yank words deleted by last EDT word-deletion command." - (interactive) - (insert edt-last-deleted-words)) +(defun edt-replace () + "Replace marked section with last CUT (killed) text." + (interactive "*") + (exchange-point-and-mark) + (let ((beg (point))) + (exchange-point-and-mark) + (delete-region beg (point))) + (yank)) + +;;; +;;; ADVANCE +;;; -(defun undelete-chars () - "Yank characters deleted by last EDT character-deletion command." +(defun edt-advance () + "Set movement direction forward. +Also, execute command specified if in Minibuffer." (interactive) - (insert edt-last-deleted-chars)) + (setq edt-direction-string edt-forward-string) + (force-mode-line-update) + (if (string-equal " *Minibuf" + (substring (buffer-name) 0 (min (length (buffer-name)) 9))) + (exit-minibuffer))) + +;;; +;;; BACKUP +;;; + +(defun edt-backup () + "Set movement direction backward. +Also, execute command specified if in Minibuffer." + (interactive) + (setq edt-direction-string edt-backward-string) + (force-mode-line-update) + (if (string-equal " *Minibuf" + (substring (buffer-name) 0 (min (length (buffer-name)) 9))) + (exit-minibuffer))) + +;;; +;;; CHNGCASE +;;; +;; This function is based upon Jeff Kowalski's case-flip function in his +;; tpu.el. -(defun next-end-of-line (num) - "Move to end of line; if at end, move to end of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (forward-char) - (end-of-line num)) +(defun edt-change-case (num) + "Change the case of specified characters. +If text selection IS active, then characters between the cursor and mark are +changed. If text selection is NOT active, there are two cases. First, if the +current direction is ADVANCE, then the prefix number of character(s) under and +following cursor are changed. Second, if the current direction is BACKUP, then +the prefix number of character(s) before the cursor are changed. Accepts a +positive prefix for the number of characters to change, but the prefix is +ignored if text selection is active." + (interactive "*p") + (edt-check-prefix num) + (if edt-select-mode + (let ((end (max (mark) (point))) + (point-save (point))) + (goto-char (min (point) (mark))) + (while (not (eq (point) end)) + (funcall (if (<= ?a (following-char)) + 'upcase-region 'downcase-region) + (point) (1+ (point))) + (forward-char 1)) + (goto-char point-save)) + (progn + (if (string= edt-direction-string edt-backward-string) + (backward-char num)) + (while (> num 0) + (funcall (if (<= ?a (following-char)) + 'upcase-region 'downcase-region) + (point) (1+ (point))) + (forward-char 1) + (setq num (1- num)))))) + +;;; +;;; DEFINE KEY +;;; + +(defun edt-define-key () + "Assign an interactively-callable function to a specified key sequence. +The current key definition is saved in edt-last-replaced-key-definition. +Use edt-restore-key to restore last replaced key definition." + (interactive) + (let (edt-function + edt-key-definition-string) + (setq edt-key-definition-string + (read-key-sequence "Press the key to be defined: ")) + (if (string-equal "\C-m" edt-key-definition-string) + (message "Key not defined") + (progn + (setq edt-function (read-command "Enter command name: ")) + (if (string-equal "" edt-function) + (message "Key not defined") + (progn + (setq edt-last-replaced-key-definition + (lookup-key (current-global-map) edt-key-definition-string)) + (define-key (current-global-map) + edt-key-definition-string edt-function))))))) + +;;; +;;; FORM FEED INSERT +;;; + +(defun edt-form-feed-insert (num) + "Insert form feed character at cursor position. +Accepts a positive prefix argument for the number of form feeds to insert." + (interactive "*p") + (edt-check-prefix num) + (while (> num 0) + (insert ?\f) + (setq num (1- num)))) -(defun previous-end-of-line (num) - "Move EOL upward. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (end-of-line (- 1 num))) +;;; +;;; TAB INSERT +;;; + +(defun edt-tab-insert (num) + "Insert tab character at cursor position. +Accepts a positive prefix argument for the number of tabs to insert." + (interactive "*p") + (edt-check-prefix num) + (while (> num 0) + (insert ?\t) + (setq num (1- num)))) + +;;; +;;; Check Prefix +;;; + +(defun edt-check-prefix (num) + "Indicate error if prefix is not positive." + (if (<= num 0) + (error "Prefix must be positive"))) + +;;; +;;; Check Selection +;;; + +(defun edt-check-selection () + "Indicate error if EDT selection is not active." + (if (not edt-select-mode) + (error "Selection NOT active"))) + +;;;; +;;;; ENHANCEMENTS AND ADDITIONS FOR EDT KEYPAD MODE +;;;; -(defun forward-to-word (num) - "Move to next word-beginning, or to Nth following word-beginning." +;;; +;;; Several enhancements and additions to EDT keypad mode commands are +;;; provided here. Some of these have been motivated by similar +;;; TPU/EVE and EVE-Plus commands. Others are new. + +;;; +;;; CHANGE DIRECTION +;;; + +(defun edt-change-direction () + "Toggle movement direction." + (interactive) + (if (equal edt-direction-string edt-forward-string) + (edt-backup) + (edt-advance))) + +;;; +;;; TOGGLE SELECT +;;; + +(defun edt-toggle-select () + "Toggle to start (or cancel) text selection." + (interactive) + (if edt-select-mode + (edt-reset) + (edt-select))) + +;;; +;;; SENTENCE +;;; + +(defun edt-sentence-forward (num) + "Move forward to start of next sentence. +Accepts a positive prefix argument for the number of sentences to move." (interactive "p") - (forward-word (1+ num)) - (forward-word -1)) + (edt-check-prefix num) + (if (eobp) + (progn + (error "End of buffer")) + (progn + (forward-sentence num) + (edt-one-word-forward)))) -(defun backward-to-word (num) - "Move back to word-end, or to Nth word-end seen." +(defun edt-sentence-backward (num) + "Move backward to next sentence beginning. +Accepts a positive prefix argument for the number of sentences to move." (interactive "p") - (forward-word (- (1+ num))) - (forward-word 1)) - -(defun backward-line (num) - "Move point to start of previous line. -Prefix argument serves as repeat-count." - (interactive "p") - (forward-line (- num))) + (edt-check-prefix num) + (if (eobp) + (progn + (error "End of buffer")) + (backward-sentence num))) -(defun scroll-window-down (num) - "Scroll the display down a window-full. -Accepts a prefix argument for the number of window-fulls to scroll." +(defun edt-sentence (num) + "Move in current direction to next sentence. +Accepts a positive prefix argument for the number of sentences to move." (interactive "p") - (scroll-down (- (* (window-height) num) 2))) + (if (equal edt-direction-string edt-forward-string) + (edt-sentence-forward num) + (edt-sentence-backward num))) -(defun scroll-window-up (num) - "Scroll the display up a window-full. -Accepts a prefix argument for the number of window-fulls to scroll." +;;; +;;; PARAGRAPH +;;; + +(defun edt-paragraph-forward (num) + "Move forward to beginning of paragraph. +Accepts a positive prefix argument for the number of paragraphs to move." (interactive "p") - (scroll-up (- (* (window-height) num) 2))) - -(defun next-paragraph (num) - "Move to beginning of the next indented paragraph. -Accepts a prefix argument for the number of paragraphs." - (interactive "p") + (edt-check-prefix num) (while (> num 0) (next-line 1) (forward-paragraph) (previous-line 1) - (if (eolp) (next-line 1)) + (if (eolp) + (next-line 1)) (setq num (1- num)))) -(defun previous-paragraph (num) - "Move to beginning of previous indented paragraph. -Accepts a prefix argument for the number of paragraphs." +(defun edt-paragraph-backward (num) + "Move backward to beginning of paragraph. +Accepts a positive prefix argument for the number of paragraphs to move." (interactive "p") + (edt-check-prefix num) (while (> num 0) (backward-paragraph) (previous-line 1) (if (eolp) (next-line 1)) (setq num (1- num)))) -(defun move-to-beginning () - "Move cursor to the beginning of buffer, but don't set the mark." - (interactive) - (goto-char (point-min))) +(defun edt-paragraph (num) + "Move in current direction to next paragraph. +Accepts a positive prefix argument for the number of paragraph to move." + (interactive "p") + (if (equal edt-direction-string edt-forward-string) + (edt-paragraph-forward num) + (edt-paragraph-backward num))) -(defun move-to-end () - "Move cursor to the end of buffer, but don't set the mark." - (interactive) - (goto-char (point-max))) +;;; +;;; RESTORE KEY +;;; -(defun goto-percent (perc) - "Move point to ARG percentage of the buffer." - (interactive "NGoto-percentage: ") - (if (or (> perc 100) (< perc 0)) - (error "Percentage %d out of range 0 < percent < 100" perc) - (goto-char (/ (* (point-max) perc) 100)))) +(defun edt-restore-key () + "Restore last replaced key definition. +Definition is stored in edt-last-replaced-key-definition." + (interactive) + (if edt-last-replaced-key-definition + (progn + (let (edt-key-definition-string) + (set 'edt-key-definition-string + (read-key-sequence "Press the key to be restored: ")) + (if (string-equal "\C-m" edt-key-definition-string) + (message "Key not restored") + (define-key (current-global-map) + edt-key-definition-string edt-last-replaced-key-definition)))) + (error "No replaced key definition to restore!"))) -(defun update-mode-line () - "Make sure mode-line in the current buffer reflects all changes." - (set-buffer-modified-p (buffer-modified-p)) - (sit-for 0)) +;;; +;;; WINDOW TOP +;;; -(defun advance-direction () - "Set EDT Advance mode so keypad commands move forward." +(defun edt-window-top () + "Move the cursor to the top of the window." + (interactive) + (let ((start-column (current-column))) + (move-to-window-line 0) + (move-to-column start-column))) + +;;; +;;; WINDOW BOTTOM +;;; + +(defun edt-window-bottom () + "Move the cursor to the bottom of the window." (interactive) - (setq edt-direction-string " ADVANCE") - (define-key function-keymap "\C-c" 'isearch-forward) ; PF3 - (define-key function-keymap "8" 'scroll-window-up) ; "8" - (define-key function-keymap "7" 'next-paragraph) ; "7" - (define-key function-keymap "1" 'forward-to-word) ; "1" - (define-key function-keymap "2" 'next-end-of-line) ; "2" - (define-key function-keymap "3" 'forward-char) ; "3" - (define-key function-keymap "0" 'forward-line) ; "0" - (update-mode-line)) + (let ((start-column (current-column))) + (move-to-window-line (- (window-height) 2)) + (move-to-column start-column))) + +;;; +;;; SCROLL WINDOW LINE +;;; -(defun backup-direction () - "Set EDT Backup mode so keypad commands move backward." +(defun edt-scroll-window-forward-line () + "Move window forward one line leaving cursor at position in window." + (interactive) + (scroll-up 1)) + +(defun edt-scroll-window-backward-line () + "Move window backward one line leaving cursor at position in window." + (interactive) + (scroll-down 1)) + +(defun edt-scroll-line () + "Move window one line in current direction." (interactive) - (setq edt-direction-string " BACKUP") - (define-key function-keymap "\C-c" 'isearch-backward) ; PF3 - (define-key function-keymap "8" 'scroll-window-down) ; "8" - (define-key function-keymap "7" 'previous-paragraph) ; "7" - (define-key function-keymap "1" 'backward-to-word) ; "1" - (define-key function-keymap "2" 'previous-end-of-line) ; "2" - (define-key function-keymap "3" 'backward-char) ; "3" - (define-key function-keymap "0" 'backward-line) ; "0" - (update-mode-line)) + (if (equal edt-direction-string edt-forward-string) + (edt-scroll-window-forward-line) + (edt-scroll-window-backward-line))) + +;;; +;;; SCROLL WINDOW +;;; +;;; Scroll a window (less one line) at a time. Leave cursor in center of +;;; window. + +(defun edt-scroll-window-forward (num) + "Scroll forward one window in buffer, less one line. +Accepts a positive prefix argument for the number of windows to move." + (interactive "p") + (edt-check-prefix num) + (scroll-up (- (* (window-height) num) 2)) + (edt-line-forward (/ (- (window-height) 1) 2))) -(defun edt-beginning-of-window () - "Home cursor to top of window." - (interactive) - (move-to-window-line 0)) +(defun edt-scroll-window-backward (num) + "Scroll backward one window in buffer, less one line. +Accepts a positive prefix argument for the number of windows to move." + (interactive "p") + (edt-check-prefix num) + (scroll-down (- (* (window-height) num) 2)) + (edt-line-backward (/ (- (window-height) 1) 2))) + +(defun edt-scroll-window (num) + "Scroll one window in buffer, less one line, in current direction. +Accepts a positive prefix argument for the number windows to move." + (interactive "p") + (if (equal edt-direction-string edt-forward-string) + (edt-scroll-window-forward num) + (edt-scroll-window-backward num))) + +;;; +;;; LINE TO BOTTOM OF WINDOW +;;; (defun edt-line-to-bottom-of-window () - "Move the current line to the top of the window." + "Move the current line to the bottom of the window." (interactive) (recenter -1)) +;;; +;;; LINE TO TOP OF WINDOW +;;; + (defun edt-line-to-top-of-window () "Move the current line to the top of the window." (interactive) (recenter 0)) -(defun case-flip-character (num) - "Change the case of the character under the cursor. -Accepts a prefix argument of the number of characters to invert." - (interactive "p") - (while (> num 0) - (funcall (if (<= ?a (following-char)) - 'upcase-region 'downcase-region) - (point) (1+ (point))) - (forward-char 1) - (setq num (1- num)))) +;;; +;;; LINE TO MIDDLE OF WINDOW +;;; + +(defun edt-line-to-middle-of-window () + "Move window so line with cursor is in the middle of the window." + (interactive) + (recenter '(4))) + +;;; +;;; GOTO PERCENTAGE +;;; + +(defun edt-goto-percentage (num) + "Move to specified percentage in buffer from top of buffer." + (interactive "NGoto-percentage: ") + (if (or (> num 100) (< num 0)) + (error "Percentage %d out of range 0 < percent < 100" num) + (goto-char (/ (* (point-max) num) 100)))) + +;;; +;;; FILL REGION +;;; -(defun indent-or-fill-region () +(defun edt-fill-region () + "Fill selected text." + (interactive "*") + (edt-check-selection) + (fill-region (point) (mark))) + +;;; +;;; INDENT OR FILL REGION +;;; + +(defun edt-indent-or-fill-region () "Fill region in text modes, indent region in programming language modes." - (interactive) - (if (string= paragraph-start "^$\\|^ ") + (interactive "*") + (if (string= paragraph-start "$\\|\f") (indent-region (point) (mark) nil) - (fill-region (point) (mark)))) + (fill-region (point) (mark)))) + +;;; +;;; MARK SECTION WISELY +;;; -(defun mark-section-wisely () +(defun edt-mark-section-wisely () "Mark the section in a manner consistent with the major-mode. -Uses mark-defun for emacs-lisp, lisp, +Uses mark-defun for emacs-lisp and lisp, mark-c-function for C, +mark-fortran-subsystem for fortran, and mark-paragraph for other modes." (interactive) - (cond ((eq major-mode 'emacs-lisp-mode) - (mark-defun)) - ((eq major-mode 'lisp-mode) - (mark-defun)) - ((eq major-mode 'c-mode) - (mark-c-function)) - (t (mark-paragraph)))) + (if edt-select-mode + (progn + (edt-reset)) + (progn + (cond ((or (eq major-mode 'emacs-lisp-mode) + (eq major-mode 'lisp-mode)) + (mark-defun) + (message "Lisp defun selected")) + ((eq major-mode 'c-mode) + (mark-c-function) + (message "C function selected")) + ((eq major-mode 'fortran-mode) + (mark-fortran-subprogram) + (message "Fortran subprogram selected")) + (t (mark-paragraph) + (message "Paragraph selected")))))) + +;;; +;;; COPY +;;; + +(defun edt-copy () + "Copy selected region to kill ring, but don't delete it!" + (interactive) + (edt-check-selection) + (copy-region-as-kill (mark) (point)) + (edt-reset) + (message "Selected text COPIED to kill ring")) + +;;; +;;; CUT or COPY +;;; + +(defun edt-cut-or-copy () + "Cuts (or copies) selected text to kill ring. +Cuts selected text if buffer-read-only is nil. +Copies selected text if buffer-read-only is t." + (interactive) + (if buffer-read-only + (edt-copy) + (edt-cut))) + +;;; +;;; DELETE ENTIRE LINE +;;; + +(defun edt-delete-entire-line () + "Delete entire line regardless of cursor position in the line." + (interactive "*") + (beginning-of-line) + (edt-delete-line 1)) -;;; Key Bindings -(defun edt-emulation-on () - "Begin emulating DEC's EDT editor. -Certain keys are rebound; including nearly all keypad keys. -Use \\[edt-emulation-off] to undo all rebindings except the keypad keys. -Note that this function does not work if called directly from the .emacs file. -Instead, the .emacs file should do (setq term-setup-hook 'edt-emulation-on) -Then this function will be called at the time when it will work." +;;; +;;; DUPLICATE LINE +;;; + +(defun edt-duplicate-line (num) + "Duplicate a line of text. +Accepts a positive prefix argument for the number times to duplicate the line." + (interactive "*p") + (edt-check-prefix num) + (let ((old-column (current-column)) + (count num)) + (edt-delete-entire-line) + (edt-undelete-line) + (while (> count 0) + (edt-undelete-line) + (setq count (1- count))) + (edt-line-forward num) + (move-to-column old-column))) + +;;; +;;; DUPLICATE WORD +;;; + +(defun edt-duplicate-word() + "Duplicate word (or rest of word) found directly above cursor, if any." + (interactive "*") + (let ((start (point)) + (start-column (current-column))) + (forward-line -1) + (move-to-column start-column) + (if (and (not (equal start (point))) + (not (eolp))) + (progn + (if (and (equal ?\t (preceding-char)) + (< start-column (current-column))) + (backward-char)) + (let ((beg (point))) + (edt-one-word-forward) + (setq edt-last-copied-word (buffer-substring beg (point)))) + (forward-line) + (move-to-column start-column) + (insert edt-last-copied-word)) + (progn + (if (not (equal start (point))) + (forward-line)) + (move-to-column start-column) + (error "Nothing to duplicate!"))))) + +;;; +;;; KEY NOT ASSIGNED +;;; + +(defun edt-key-not-assigned () + "Displays message that key has not been assigned to a function." (interactive) - (advance-direction) - (edt-bind-gold-keypad) ;Must do this *after* $TERM.el is loaded - (setq edt-mode-old-c-\\ (lookup-key global-map "\C-\\")) - (global-set-key "\C-\\" 'quoted-insert) - (setq edt-mode-old-delete (lookup-key global-map "\177")) - (global-set-key "\177" 'delete-previous-char) ;"Delete" - (setq edt-mode-old-lisp-delete (lookup-key emacs-lisp-mode-map "\177")) - (define-key emacs-lisp-mode-map "\177" 'delete-previous-char) ;"Delete" - (define-key lisp-mode-map "\177" 'delete-previous-char) ;"Delete" - (setq edt-mode-old-linefeed (lookup-key global-map "\C-j")) - (global-set-key "\C-j" 'edt-delete-previous-word) ;"LineFeed" - (define-key esc-map "?" 'apropos)) ;"?" + (error "Key not assigned")) + +;;; +;;; TOGGLE CAPITALIZATION OF WORD +;;; + +(defun edt-toggle-capitalization-of-word () + "Toggle the capitalization of the current word and move forward to next." + (interactive "*") + (edt-one-word-forward) + (edt-one-word-backward) + (edt-change-case 1) + (edt-one-word-backward) + (edt-one-word-forward)) + +;;; +;;; ELIMINATE ALL TABS +;;; + +(defun edt-eliminate-all-tabs () + "Convert all tabs to spaces in the entire buffer." + (interactive "*") + (untabify (point-min) (point-max)) + (message "TABS converted to SPACES")) + +;;; +;;; DISPLAY THE TIME +;;; + +(defun edt-display-the-time () + "Display the current time." + (interactive) + (set 'time-string (current-time-string)) + (message "%s" time-string)) + +;;; +;;; LEARN +;;; + +(defun edt-learn () + "Learn a sequence of key strokes to bind to a key." + (interactive) + (if (eq defining-kbd-macro t) + (edt-remember) + (start-kbd-macro nil))) + +;;; +;;; REMEMBER +;;; -(defun edt-emulation-off () - "Return from EDT emulation to normal Emacs key bindings. -The keys redefined by \\[edt-emulation-on] are given their old definitions." +(defun edt-remember () + "Store the sequence of key strokes started by edt-learn to a key." + (interactive) + (if (eq defining-kbd-macro nil) + (error "Nothing to remember!") + (progn + (end-kbd-macro nil) + (let (edt-key-definition-string) + (set 'edt-key-definition-string + (read-key-sequence "Enter key for binding: ")) + (if (string-equal "\C-m" edt-key-definition-string) + (message "Key sequence not remembered") + (progn + (set 'edt-learn-macro-count (+ edt-learn-macro-count 1)) + (setq edt-last-replaced-key-definition + (lookup-key (current-global-map) + edt-key-definition-string)) + (define-key (current-global-map) edt-key-definition-string + (name-last-kbd-macro + (intern (concat "last-learned-sequence-" + (int-to-string edt-learn-macro-count))))))))))) + +;;; +;;; EXIT +;;; + +(defun edt-exit () + "Save current buffer, ask to save other buffers, and then exit Emacs." + (interactive) + (save-buffer) + (save-buffers-kill-emacs)) + +;;; +;;; QUIT +;;; + +(defun edt-quit () + "Quit Emacs without saving changes." + (interactive) + (kill-emacs)) + +;;; +;;; SPLIT WINDOW +;;; + +(defun edt-split-window () + "Split current window and place cursor in the new window." + (interactive) + (split-window) + (other-window 1)) + +;;; +;;; COPY RECTANGLE +;;; + +(defun edt-copy-rectangle () + "Copy a rectangle of text between mark and cursor to register." (interactive) - (setq edt-direction-string nil) - (global-set-key "\C-\\" edt-mode-old-c-\\) - (global-set-key "\177" edt-mode-old-delete) ;"Delete" - (define-key emacs-lisp-mode-map "\177" edt-mode-old-lisp-delete) ;"Delete" - (define-key lisp-mode-map "\177" edt-mode-old-lisp-delete) ;"Delete" - (global-set-key "\C-j" edt-mode-old-linefeed)) ;"LineFeed" + (edt-check-selection) + (copy-rectangle-to-register 3 (region-beginning) (region-end) nil) + (edt-reset) + (message "Selected rectangle COPIED to register")) + +;;; +;;; CUT RECTANGLE +;;; + +(defun edt-cut-rectangle-overstrike-mode () + "Cut a rectangle of text between mark and cursor to register. +Replace cut characters with spaces and moving cursor back to +upper left corner." + (interactive "*") + (edt-check-selection) + (setq edt-rect-start-point (region-beginning)) + (picture-clear-rectangle-to-register (region-beginning) (region-end) 3) + (set-window-point (get-buffer-window (window-buffer)) edt-rect-start-point) + (message "Selected rectangle CUT to register")) + +(defun edt-cut-rectangle-insert-mode () + "Cut a rectangle of text between mark and cursor to register. +Move cursor back to upper left corner." + (interactive "*") + (edt-check-selection) + (setq edt-rect-start-point (region-beginning)) + (picture-clear-rectangle-to-register (region-beginning) (region-end) 3 t) + (fixup-whitespace) + (set-window-point (get-buffer-window (window-buffer)) edt-rect-start-point) + (message "Selected rectangle CUT to register")) + +(defun edt-cut-rectangle () + "Cut a rectangular region of text to register. +If overwrite mode is active, cut text is replaced with whitespace." + (interactive "*") + (if overwrite-mode + (edt-cut-rectangle-overstrike-mode) + (edt-cut-rectangle-insert-mode))) + +;;; +;;; PASTE RECTANGLE +;;; + +(defun edt-paste-rectangle-overstrike-mode () + "Paste a rectangular region of text from register, replacing text at cursor." + (interactive "*") + (picture-yank-rectangle-from-register 3)) + +(defun edt-paste-rectangle-insert-mode () + "Paste previously deleted rectangular region, inserting text at cursor." + (interactive "*") + (picture-yank-rectangle-from-register 3 t)) + +(defun edt-paste-rectangle () + "Paste a rectangular region of text. +If overwrite mode is active, existing text is replace with text from register." + (interactive) + (if overwrite-mode + (edt-paste-rectangle-overstrike-mode) + (edt-paste-rectangle-insert-mode))) + +;;; +;;; DOWNCASE REGION +;;; + +(defun edt-lowercase () + "Change specified characters to lower case. +If text selection IS active, then characters between the cursor and +mark are changed. If text selection is NOT active, there are two +situations. If the current direction is ADVANCE, then the word under +the cursor is changed to lower case and the cursor is moved to rest at +the beginning of the next word. If the current direction is BACKUP, +the word prior to the word under the cursor is changed to lower case +and the cursor is left to rest at the beginning of that word." + (interactive "*") + (if edt-select-mode + (progn + (downcase-region (mark) (point))) + (progn + ;; Move to beginning of current word. + (if (and + (not (bobp)) + (not (eobp)) + (not (bolp)) + (not (eolp)) + (not (eq ?\ (char-syntax (preceding-char)))) + (not (memq (preceding-char) edt-word-entities)) + (not (memq (following-char) edt-word-entities))) + (edt-one-word-backward)) + (if (equal edt-direction-string edt-backward-string) + (edt-one-word-backward)) + (let ((beg (point))) + (edt-one-word-forward) + (downcase-region beg (point))) + (if (equal edt-direction-string edt-backward-string) + (edt-one-word-backward))))) + +;;; +;;; UPCASE REGION +;;; + +(defun edt-uppercase () + "Change specified characters to upper case. +If text selection IS active, then characters between the cursor and +mark are changed. If text selection is NOT active, there are two +situations. If the current direction is ADVANCE, then the word under +the cursor is changed to upper case and the cursor is moved to rest at +the beginning of the next word. If the current direction is BACKUP, +the word prior to the word under the cursor is changed to upper case +and the cursor is left to rest at the beginning of that word." + (interactive "*") + (if edt-select-mode + (progn + (upcase-region (mark) (point))) + (progn + ;; Move to beginning of current word. + (if (and + (not (bobp)) + (not (eobp)) + (not (bolp)) + (not (eolp)) + (not (eq ?\ (char-syntax (preceding-char)))) + (not (memq (preceding-char) edt-word-entities)) + (not (memq (following-char) edt-word-entities))) + (edt-one-word-backward)) + (if (equal edt-direction-string edt-backward-string) + (edt-one-word-backward)) + (let ((beg (point))) + (edt-one-word-forward) + (upcase-region beg (point))) + (if (equal edt-direction-string edt-backward-string) + (edt-one-word-backward))))) -(define-key function-keymap "u" 'previous-line) ;Up arrow -(define-key function-keymap "d" 'next-line) ;down arrow -(define-key function-keymap "l" 'backward-char) ;right arrow -(define-key function-keymap "r" 'forward-char) ;left arrow -(define-key function-keymap "h" 'edt-beginning-of-window) ;home -(define-key function-keymap "\C-b" 'describe-key) ;PF2 -(define-key function-keymap "\C-d" 'delete-current-line);PF4 -(define-key function-keymap "9" 'append-to-buffer) ;9 keypad key, etc. -(define-key function-keymap "-" 'delete-current-word) -(define-key function-keymap "4" 'advance-direction) -(define-key function-keymap "5" 'backup-direction) -(define-key function-keymap "6" 'kill-region) -(define-key function-keymap "," 'delete-current-char) -(define-key function-keymap "." 'set-mark-command) -(define-key function-keymap "e" 'other-window) ;enter key -(define-key function-keymap "\C-a" 'GOLD-prefix) ;PF1 ("gold") + +;;; +;;; INITIALIZATION COMMANDS. +;;; + +;;; +;;; Emacs version 19 X-windows key definition support +;;; +(defvar edt-last-answer nil + "Most recent response to edt-y-or-n-p.") + +(defun edt-y-or-n-p (prompt &optional not-yes) + "Prompt for a y or n answer with positive default. +Optional second argument NOT-YES changes default to negative. +Like emacs y-or-n-p, also accepts space as y and DEL as n." + (message "%s[%s]" prompt (if not-yes "n" "y")) + (let ((doit t)) + (while doit + (setq doit nil) + (let ((ans (read-char))) + (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\ )) + (setq edt-last-answer t)) + ((or (= ans ?n) (= ans ?N) (= ans ?\C-?)) + (setq edt-last-answer nil)) + ((= ans ?\r) (setq edt-last-answer (not not-yes))) + (t + (setq doit t) (beep) + (message "Please answer y or n. %s[%s]" + prompt (if not-yes "n" "y"))))))) + edt-last-answer) + +(defun edt-load-xkeys (file) + "Load the EDT X-windows key definitions FILE. +If FILE is nil, try to load a default file. The default file names are +~/.edt-xemacs-keys for XEmacs, and ~/.edt-gnu-keys for GNU emacs." + (interactive "fX key definition file: ") + (cond (file + (setq file (expand-file-name file))) + (edt-xkeys-file + (setq file (expand-file-name edt-xkeys-file))) + (edt-gnu-emacs19-p + (setq file (expand-file-name "~/.edt-gnu-keys"))) + (edt-lucid-emacs19-p + (setq file (expand-file-name "~/.edt-xemacs-keys")))) + (cond ((file-readable-p file) + (load-file file)) + (t + (switch-to-buffer "*scratch*") + (erase-buffer) + (insert " + + Ack!! You're running the Enhanced EDT Emulation under X-windows + without loading an EDT X key definition file. To create an EDT X + key definition file, run the edt-mapper.el program. But ONLY run + it from an XEmacs loaded without any of your own customizations + found in your .emacs file, etc. Some user customization confuse + the edt-mapper function. To do this, you need to invoke XEmacs + as follows: -(fset 'GOLD-prefix GOLD-map) - -(defvar GOLD-map (make-keymap) - "GOLD-map maps the function keys on the VT100 keyboard preceeded -by the PF1 key. GOLD is the ASCII the 7-bit escape sequence OP.") + xemacs -q -l edt-mapper.el + + The file edt-mapper.el includes these same directions on how to + use it! Perhaps it's laying around here someplace. \n ") + (let ((file "edt-mapper.el") + (found nil) + (path nil) + (search-list (append (list (expand-file-name ".")) load-path))) + (while (and (not found) search-list) + (setq path (concat (car search-list) + (if (string-match "/$" (car search-list)) "" "/") + file)) + (if (and (file-exists-p path) (not (file-directory-p path))) + (setq found t)) + (setq search-list (cdr search-list))) + (cond (found + (insert (format + "Ah yes, there it is, in \n\n %s \n\n" path)) + (if (edt-y-or-n-p "Do you want to run it now? ") + (load-file path) + (error "EDT Emulation not configured."))) + (t + (insert "Nope, I can't seem to find it. :-(\n\n") + (sit-for 20) + (error "EDT Emulation not configured."))))))) -(defun define-keypad-key (keymap function-keymap-slot definition) - (let ((function-key-sequence (function-key-sequence function-keymap-slot))) - (if function-key-sequence - (define-key keymap function-key-sequence definition)))) +;;;###autoload +(defun edt-emulation-on () + "Turn on EDT Emulation." + (interactive) + ;; If using MS-DOS, need to load edt-pc.el + (if (eq system-type 'ms-dos) + (setq edt-term "pc") + (setq edt-term (getenv "TERM"))) + ;; All DEC VT series terminals are supported by loading edt-vt100.el + (if (string-equal "vt" (substring edt-term 0 (min (length edt-term) 2))) + (setq edt-term "vt100")) + ;; Load EDT terminal specific configuration file. + (let ((term edt-term) + hyphend) + (while (and term + (not (load (concat "edt-" term) t t))) + ;; Strip off last hyphen and what follows, then try again + (if (setq hyphend (string-match "[-_][^-_]+$" term)) + (setq term (substring term 0 hyphend)) + (setq term nil))) + ;; Override terminal-specific file if running X Windows. X Windows support + ;; is handled differently in edt-load-xkeys + (if (eq window-system 'x) + (edt-load-xkeys nil) + (if (null term) + (error "Unable to load EDT terminal specific file for %s" edt-term))) + (setq edt-term term)) + (setq edt-orig-transient-mark-mode transient-mark-mode) + (add-hook 'activate-mark-hook + (function + (lambda () + (edt-select-mode t)))) + (add-hook 'deactivate-mark-hook + (function + (lambda () + (edt-select-mode nil)))) + (if (load "edt-user" t t) + (edt-user-emulation-setup) + (edt-default-emulation-setup))) -;;Bind GOLD/Keyboard keys +(defun edt-emulation-off() + "Select original global key bindings, disabling EDT Emulation." + (interactive) + (use-global-map global-map) + (if (not edt-keep-current-page-delimiter) + (setq page-delimiter edt-orig-page-delimiter)) + (setq edt-direction-string "") + (setq edt-select-mode-text nil) + (edt-reset) + (force-mode-line-update t) + (setq transient-mark-mode edt-orig-transient-mark-mode) + (message "Original key bindings restored; EDT Emulation disabled")) -(define-key GOLD-map "\C-g" 'keyboard-quit) ; just for safety -(define-key GOLD-map "\177" 'delete-window) ;"Delete" -(define-key GOLD-map "\C-h" 'delete-other-windows) ;"BackSpace" -(define-key GOLD-map "\C-m" 'newline-and-indent) ;"Return" -(define-key GOLD-map " " 'undo) ;"Spacebar" -(define-key GOLD-map "%" 'goto-percent) ; "%" -(define-key GOLD-map "=" 'goto-line) ; "=" -(define-key GOLD-map "`" 'what-line) ; "`" -(define-key GOLD-map "\C-\\" 'split-window-vertically) ; "Control-\" +(defun edt-default-emulation-setup (&optional user-setup) + "Setup emulation of DEC's EDT editor." + ;; Setup default EDT global map by copying global map bindings. + ;; This preserves ESC and C-x prefix bindings and other bindings we + ;; wish to retain in EDT emulation mode keymaps. It also permits + ;; customization of these bindings in the EDT global maps without + ;; disturbing the original bindings in global-map. + (fset 'edt-default-ESC-prefix (copy-keymap 'ESC-prefix)) + (setq edt-default-global-map (copy-keymap (current-global-map))) + (define-key edt-default-global-map "\e" 'edt-default-ESC-prefix) + (define-prefix-command 'edt-default-gold-map) + (edt-setup-default-bindings) + ;; If terminal has additional function keys, the terminal-specific + ;; initialization file can assign bindings to them via the optional + ;; function edt-setup-extra-default-bindings. + (if (fboundp 'edt-setup-extra-default-bindings) + (edt-setup-extra-default-bindings)) + ;; Variable needed by edt-learn. + (setq edt-learn-macro-count 0) + ;; Display EDT text selection active within the mode line + (or (assq 'edt-select-mode minor-mode-alist) + (setq minor-mode-alist + (cons '(edt-select-mode edt-select-mode) minor-mode-alist))) + ;; Display EDT direction of motion within the mode line + (or (assq 'edt-direction-string minor-mode-alist) + (setq minor-mode-alist + (cons + '(edt-direction-string edt-direction-string) minor-mode-alist))) + (if user-setup + (progn + (setq edt-user-map-configured t) + (fset 'edt-emulation-on (symbol-function 'edt-select-user-global-map))) + (progn + (fset 'edt-emulation-on (symbol-function 'edt-select-default-global-map)) + (edt-select-default-global-map)))) + +(defun edt-user-emulation-setup () + "Setup user custom emulation of DEC's EDT editor." + ;; Initialize EDT default bindings. + (edt-default-emulation-setup t) + ;; Setup user EDT global map by copying default EDT global map bindings. + (fset 'edt-user-ESC-prefix (copy-keymap 'edt-default-ESC-prefix)) + (setq edt-user-global-map (copy-keymap edt-default-global-map)) + (define-key edt-user-global-map "\e" 'edt-user-ESC-prefix) + ;; If terminal has additional function keys, the user's initialization + ;; file can assign bindings to them via the optional + ;; function edt-setup-extra-default-bindings. + (define-prefix-command 'edt-user-gold-map) + (fset 'edt-user-gold-map (copy-keymap 'edt-default-gold-map)) + (edt-setup-user-bindings) + (edt-select-user-global-map)) + +(defun edt-select-default-global-map() + "Select default EDT emulation key bindings." + (interactive) + (transient-mark-mode 1) + (use-global-map edt-default-global-map) + (if (not edt-keep-current-page-delimiter) + (progn + (setq edt-orig-page-delimiter page-delimiter) + (setq page-delimiter "\f"))) + (setq edt-default-map-active t) + (edt-advance) + (setq edt-select-mode-text 'edt-select-mode-string) + (edt-reset) + (message "Default EDT keymap active")) + +(defun edt-select-user-global-map() + "Select user EDT emulation custom key bindings." + (interactive) + (if edt-user-map-configured + (progn + (transient-mark-mode 1) + (use-global-map edt-user-global-map) + (if (not edt-keep-current-page-delimiter) + (progn + (setq edt-orig-page-delimiter page-delimiter) + (setq page-delimiter "\f"))) + (setq edt-default-map-active nil) + (edt-advance) + (setq edt-select-mode-text 'edt-select-mode-string) + (edt-reset) + (message "User EDT custom keymap active")) + (error "User EDT custom keymap NOT configured!"))) + +(defun edt-switch-global-maps () + "Toggle between default EDT keymap and user EDT keymap." + (interactive) + (if edt-default-map-active + (edt-select-user-global-map) + (edt-select-default-global-map))) + +;; There are three key binding functions needed: one for standard keys +;; (used to bind control keys, primarily), one for Gold sequences of +;; standard keys, and one for function keys. + +(defun edt-bind-gold-key (key gold-binding &optional default) + "Binds commands to a gold key sequence in the EDT Emulator." + (if default + (define-key 'edt-default-gold-map key gold-binding) + (define-key 'edt-user-gold-map key gold-binding))) + +(defun edt-bind-standard-key (key gold-binding &optional default) + "Bind commands to a gold key sequence in the default EDT keymap." + (if default + (define-key edt-default-global-map key gold-binding) + (define-key edt-user-global-map key gold-binding))) + +(defun edt-bind-function-key + (function-key binding gold-binding &optional default) + "Binds function keys in the EDT Emulator." + (catch 'edt-key-not-supported + (let ((key-vector (cdr (assoc function-key *EDT-keys*)))) + (if (stringp key-vector) + (throw 'edt-key-not-supported t)) + (if (not (null key-vector)) + (progn + (if default + (progn + (define-key edt-default-global-map key-vector binding) + (define-key 'edt-default-gold-map key-vector gold-binding)) + (progn + (define-key edt-user-global-map key-vector binding) + (define-key 'edt-user-gold-map key-vector gold-binding)))) + (error "%s is not a legal function key name" function-key))))) + +(defun edt-setup-default-bindings () + "Assigns default EDT Emulation keyboard bindings." + + ;; Function Key Bindings: Regular and GOLD. + + ;; VT100/VT200/VT300 PF1 (GOLD), PF2, PF3, PF4 Keys + (edt-bind-function-key "PF1" 'edt-default-gold-map 'edt-mark-section-wisely t) + (edt-bind-function-key "PF2" 'edt-electric-keypad-help 'describe-function t) + (edt-bind-function-key "PF3" 'edt-find-next 'edt-find t) + (edt-bind-function-key "PF4" 'edt-delete-line 'edt-undelete-line t) + + ;; VT100/VT200/VT300 Arrow Keys + (edt-bind-function-key "UP" 'previous-line 'edt-window-top t) + (edt-bind-function-key "DOWN" 'next-line 'edt-window-bottom t) + (edt-bind-function-key "LEFT" 'backward-char 'edt-sentence-backward t) + (edt-bind-function-key "RIGHT" 'forward-char 'edt-sentence-forward t) + + ;; VT100/VT200/VT300 Keypad Keys + (edt-bind-function-key "KP0" 'edt-line 'open-line t) + (edt-bind-function-key "KP1" 'edt-word 'edt-change-case t) + (edt-bind-function-key "KP2" 'edt-end-of-line 'edt-delete-to-end-of-line t) + (edt-bind-function-key "KP3" 'edt-character 'quoted-insert t) + (edt-bind-function-key "KP4" 'edt-advance 'edt-bottom t) + (edt-bind-function-key "KP5" 'edt-backup 'edt-top t) + (edt-bind-function-key "KP6" 'edt-cut 'yank t) + (edt-bind-function-key "KP7" 'edt-page 'execute-extended-command t) + (edt-bind-function-key "KP8" 'edt-sect 'edt-fill-region t) + (edt-bind-function-key "KP9" 'edt-append 'edt-replace t) + (edt-bind-function-key "KP-" 'edt-delete-word 'edt-undelete-word t) + (edt-bind-function-key "KP," 'edt-delete-character 'edt-undelete-character t) + (edt-bind-function-key "KPP" 'edt-select 'edt-reset t) + (edt-bind-function-key "KPE" 'other-window 'query-replace t) + + ;; VT200/VT300 Function Keys + ;; (F1 through F5, on the VT220, are not programmable, so we skip + ;; making default bindings to those keys. + (edt-bind-function-key "FIND" 'edt-find-next 'edt-find t) + (edt-bind-function-key "INSERT" 'yank 'edt-key-not-assigned t) + (edt-bind-function-key "REMOVE" 'edt-cut 'edt-copy t) + (edt-bind-function-key "SELECT" 'edt-toggle-select 'edt-key-not-assigned t) + (edt-bind-function-key "NEXT" 'edt-sect-forward 'edt-key-not-assigned t) + (edt-bind-function-key "PREVIOUS" 'edt-sect-backward 'edt-key-not-assigned t) + (edt-bind-function-key "F6" 'edt-key-not-assigned 'edt-key-not-assigned t) + (edt-bind-function-key "F7" 'edt-copy-rectangle 'edt-key-not-assigned t) + (edt-bind-function-key "F8" + 'edt-cut-rectangle-overstrike-mode 'edt-paste-rectangle-overstrike-mode t) + (edt-bind-function-key "F9" + 'edt-cut-rectangle-insert-mode 'edt-paste-rectangle-insert-mode t) + (edt-bind-function-key "F10" 'edt-cut-rectangle 'edt-paste-rectangle t) + ;; Under X, the F11 key can be bound. If using a VT-200 or higher terminal, + ;; the default emacs terminal support causes the VT F11 key to seem as if it + ;; is an ESC key when in emacs. + (edt-bind-function-key "F11" + 'edt-key-not-assigned 'edt-key-not-assigned t) + (edt-bind-function-key "F12" + 'edt-beginning-of-line 'delete-other-windows t) ;BS + (edt-bind-function-key "F13" + 'edt-delete-to-beginning-of-word 'edt-key-not-assigned t) ;LF + (edt-bind-function-key "F14" 'edt-key-not-assigned 'edt-key-not-assigned t) + (edt-bind-function-key "HELP" 'edt-electric-keypad-help 'edt-key-not-assigned t) + (edt-bind-function-key "DO" 'execute-extended-command 'edt-key-not-assigned t) + (edt-bind-function-key "F17" 'edt-key-not-assigned 'edt-key-not-assigned t) + (edt-bind-function-key "F18" 'edt-key-not-assigned 'edt-key-not-assigned t) + (edt-bind-function-key "F19" 'edt-key-not-assigned 'edt-key-not-assigned t) + (edt-bind-function-key "F20" 'edt-key-not-assigned 'edt-key-not-assigned t) + + ;; Control key bindings: Regular and GOLD + ;; + ;; Standard EDT control key bindings conflict with standard Emacs + ;; control key bindings. Normally, the standard Emacs control key + ;; bindings are left unchanged in the default EDT mode. However, if + ;; the variable edt-use-EDT-control-key-bindings is set to true + ;; before invoking edt-emulation-on for the first time, then the + ;; standard EDT bindings (with some enhancements) as defined here are + ;; used, instead. + (if edt-use-EDT-control-key-bindings + (progn + (edt-bind-standard-key "\C-a" 'edt-key-not-assigned t) + (edt-bind-standard-key "\C-b" 'edt-key-not-assigned t) + ;; Leave binding of C-c as original prefix key. + (edt-bind-standard-key "\C-d" 'edt-key-not-assigned t) + (edt-bind-standard-key "\C-e" 'edt-key-not-assigned t) + (edt-bind-standard-key "\C-f" 'edt-key-not-assigned t) + ;; Leave binding of C-g to keyboard-quit +; (edt-bind-standard-key "\C-g" 'keyboard-quit t) + ;; Standard EDT binding of C-h. To invoke Emacs help, use + ;; GOLD-C-h instead. + (edt-bind-standard-key "\C-h" 'edt-beginning-of-line t) + (edt-bind-standard-key "\C-i" 'edt-tab-insert t) + (edt-bind-standard-key "\C-j" 'edt-delete-to-beginning-of-word t) + (edt-bind-standard-key "\C-k" 'edt-define-key t) + (edt-bind-gold-key "\C-k" 'edt-restore-key t) + (edt-bind-standard-key "\C-l" 'edt-form-feed-insert t) + ;; Leave binding of C-m to newline. + (edt-bind-standard-key "\C-n" 'edt-set-screen-width-80 t) + (edt-bind-standard-key "\C-o" 'edt-key-not-assigned t) + (edt-bind-standard-key "\C-p" 'edt-key-not-assigned t) + (edt-bind-standard-key "\C-q" 'edt-key-not-assigned t) + ;; Leave binding of C-r to isearch-backward. + ;; Leave binding of C-s to isearch-forward. + (edt-bind-standard-key "\C-t" 'edt-display-the-time t) + (edt-bind-standard-key "\C-u" 'edt-delete-to-beginning-of-line t) + (edt-bind-standard-key "\C-v" 'redraw-display t) + (edt-bind-standard-key "\C-w" 'edt-set-screen-width-132 t) + ;; Leave binding of C-x as original prefix key. + (edt-bind-standard-key "\C-y" 'edt-key-not-assigned t) +; (edt-bind-standard-key "\C-z" 'suspend-emacs t) + ) + ) + + ;; GOLD bindings for a few Control keys. + (edt-bind-gold-key "\C-g" 'keyboard-quit t); Just in case. + (edt-bind-gold-key "\C-h" 'help-for-help t) + (edt-bind-gold-key [f1] 'help-for-help t) + (edt-bind-gold-key [help] 'help-for-help t) + (edt-bind-gold-key "\C-\\" 'split-window-vertically t) -; GOLD letter combinations: -(define-key GOLD-map "b" 'buffer-menu) ; "b" -(define-key GOLD-map "B" 'buffer-menu) ; "B" -(define-key GOLD-map "d" 'delete-window) ; "d" -(define-key GOLD-map "D" 'delete-window) ; "D" -(define-key GOLD-map "e" 'compile) ; "e" -(define-key GOLD-map "E" 'compile) ; "E" -(define-key GOLD-map "i" 'insert-file) ; "i" -(define-key GOLD-map "I" 'insert-file) ; "I" -(define-key GOLD-map "l" 'goto-line) ; "l" -(define-key GOLD-map "L" 'goto-line) ; "L" -(define-key GOLD-map "m" 'save-some-buffers) ; "m" -(define-key GOLD-map "M" 'save-some-buffers) ; "m" -(define-key GOLD-map "n" 'next-error) ; "n" -(define-key GOLD-map "N" 'next-error) ; "N" -(define-key GOLD-map "o" 'switch-to-buffer-other-window) ; "o" -(define-key GOLD-map "O" 'switch-to-buffer-other-window) ; "O" -(define-key GOLD-map "r" 'revert-file) ; "r" -(define-key GOLD-map "r" 'revert-file) ; "R" -(define-key GOLD-map "s" 'save-buffer) ; "s" -(define-key GOLD-map "S" 'save-buffer) ; "S" -(define-key GOLD-map "v" 'find-file-other-window) ; "v" -(define-key GOLD-map "V" 'find-file-other-window) ; "V" -(define-key GOLD-map "w" 'write-file) ; "w" -(define-key GOLD-map "w" 'write-file) ; "W" -;(define-key GOLD-map "z" 'shrink-window) ; "z" -;(define-key GOLD-map "Z" 'shrink-window) ; "z" + ;; GOLD bindings for regular keys. + (edt-bind-gold-key "a" 'edt-key-not-assigned t) + (edt-bind-gold-key "A" 'edt-key-not-assigned t) + (edt-bind-gold-key "b" 'buffer-menu t) + (edt-bind-gold-key "B" 'buffer-menu t) + (edt-bind-gold-key "c" 'compile t) + (edt-bind-gold-key "C" 'compile t) + (edt-bind-gold-key "d" 'delete-window t) + (edt-bind-gold-key "D" 'delete-window t) + (edt-bind-gold-key "e" 'edt-exit t) + (edt-bind-gold-key "E" 'edt-exit t) + (edt-bind-gold-key "f" 'find-file t) + (edt-bind-gold-key "F" 'find-file t) + (edt-bind-gold-key "g" 'find-file-other-window t) + (edt-bind-gold-key "G" 'find-file-other-window t) + (edt-bind-gold-key "h" 'edt-electric-keypad-help t) + (edt-bind-gold-key "H" 'edt-electric-keypad-help t) + (edt-bind-gold-key "i" 'insert-file t) + (edt-bind-gold-key "I" 'insert-file t) + (edt-bind-gold-key "j" 'edt-key-not-assigned t) + (edt-bind-gold-key "J" 'edt-key-not-assigned t) + (edt-bind-gold-key "k" 'edt-toggle-capitalization-of-word t) + (edt-bind-gold-key "K" 'edt-toggle-capitalization-of-word t) + (edt-bind-gold-key "l" 'edt-lowercase t) + (edt-bind-gold-key "L" 'edt-lowercase t) + (edt-bind-gold-key "m" 'save-some-buffers t) + (edt-bind-gold-key "M" 'save-some-buffers t) + (edt-bind-gold-key "n" 'next-error t) + (edt-bind-gold-key "N" 'next-error t) + (edt-bind-gold-key "o" 'switch-to-buffer-other-window t) + (edt-bind-gold-key "O" 'switch-to-buffer-other-window t) + (edt-bind-gold-key "p" 'edt-key-not-assigned t) + (edt-bind-gold-key "P" 'edt-key-not-assigned t) + (edt-bind-gold-key "q" 'edt-quit t) + (edt-bind-gold-key "Q" 'edt-quit t) + (edt-bind-gold-key "r" 'revert-buffer t) + (edt-bind-gold-key "R" 'revert-buffer t) + (edt-bind-gold-key "s" 'save-buffer t) + (edt-bind-gold-key "S" 'save-buffer t) + (edt-bind-gold-key "t" 'edt-key-not-assigned t) + (edt-bind-gold-key "T" 'edt-key-not-assigned t) + (edt-bind-gold-key "u" 'edt-uppercase t) + (edt-bind-gold-key "U" 'edt-uppercase t) + (edt-bind-gold-key "v" 'find-file-other-window t) + (edt-bind-gold-key "V" 'find-file-other-window t) + (edt-bind-gold-key "w" 'write-file t) + (edt-bind-gold-key "W" 'write-file t) + (edt-bind-gold-key "x" 'edt-key-not-assigned t) + (edt-bind-gold-key "X" 'edt-key-not-assigned t) + (edt-bind-gold-key "y" 'edt-emulation-off t) + (edt-bind-gold-key "Y" 'edt-emulation-off t) + (edt-bind-gold-key "z" 'edt-switch-global-maps t) + (edt-bind-gold-key "Z" 'edt-switch-global-maps t) + (edt-bind-gold-key "1" 'delete-other-windows t) + (edt-bind-gold-key "!" 'edt-key-not-assigned t) + (edt-bind-gold-key "2" 'edt-split-window t) + (edt-bind-gold-key "@" 'edt-key-not-assigned t) + (edt-bind-gold-key "3" 'edt-key-not-assigned t) + (edt-bind-gold-key "#" 'edt-key-not-assigned t) + (edt-bind-gold-key "4" 'edt-key-not-assigned t) + (edt-bind-gold-key "$" 'edt-key-not-assigned t) + (edt-bind-gold-key "5" 'edt-key-not-assigned t) + (edt-bind-gold-key "%" 'edt-goto-percentage t) + (edt-bind-gold-key "6" 'edt-key-not-assigned t) + (edt-bind-gold-key "^" 'edt-key-not-assigned t) + (edt-bind-gold-key "7" 'edt-key-not-assigned t) + (edt-bind-gold-key "&" 'edt-key-not-assigned t) + (edt-bind-gold-key "8" 'edt-key-not-assigned t) + (edt-bind-gold-key "*" 'edt-key-not-assigned t) + (edt-bind-gold-key "9" 'edt-key-not-assigned t) + (edt-bind-gold-key "(" 'edt-key-not-assigned t) + (edt-bind-gold-key "0" 'edt-key-not-assigned t) + (edt-bind-gold-key ")" 'edt-key-not-assigned t) + (edt-bind-gold-key " " 'undo t) + (edt-bind-gold-key "," 'edt-key-not-assigned t) + (edt-bind-gold-key "<" 'edt-key-not-assigned t) + (edt-bind-gold-key "." 'edt-key-not-assigned t) + (edt-bind-gold-key ">" 'edt-key-not-assigned t) + (edt-bind-gold-key "/" 'edt-key-not-assigned t) + (edt-bind-gold-key "?" 'edt-key-not-assigned t) + (edt-bind-gold-key "\\" 'edt-key-not-assigned t) + (edt-bind-gold-key "|" 'edt-key-not-assigned t) + (edt-bind-gold-key ";" 'edt-key-not-assigned t) + (edt-bind-gold-key ":" 'edt-key-not-assigned t) + (edt-bind-gold-key "'" 'edt-key-not-assigned t) + (edt-bind-gold-key "\"" 'edt-key-not-assigned t) + (edt-bind-gold-key "-" 'edt-key-not-assigned t) + (edt-bind-gold-key "_" 'edt-key-not-assigned t) + (edt-bind-gold-key "=" 'goto-line t) + (edt-bind-gold-key "+" 'edt-key-not-assigned t) + (edt-bind-gold-key "[" 'edt-key-not-assigned t) + (edt-bind-gold-key "{" 'edt-key-not-assigned t) + (edt-bind-gold-key "]" 'edt-key-not-assigned t) + (edt-bind-gold-key "}" 'edt-key-not-assigned t) + (edt-bind-gold-key "`" 'what-line t) + (edt-bind-gold-key "~" 'edt-key-not-assigned t) +) + +;;; +;;; DEFAULT EDT KEYPAD HELP +;;; + +;;; +;;; Upper case commands in the keypad diagram below indicate that the +;;; emulation should look and feel very much like EDT. Lower case +;;; commands are enhancements and/or additions to the EDT keypad +;;; commands or are native Emacs commands. +;;; + +(defun edt-keypad-help () + " + DEFAULT EDT Keypad Active -;Bind GOLD/Keypad keys -(defun edt-bind-gold-keypad () - (define-keypad-key GOLD-map ?u 'edt-line-to-top-of-window) ;"up-arrow" - (define-keypad-key GOLD-map ?d 'edt-line-to-bottom-of-window) ;"down-arrow" - (define-keypad-key GOLD-map ?l 'backward-sentence) ;"left-arrow" - (define-keypad-key GOLD-map ?r 'forward-sentence) ;"right-arrow" - (define-keypad-key GOLD-map ?\C-a 'mark-section-wisely) ;Gold "PF1" - (define-keypad-key GOLD-map ?\C-b 'describe-function) ;Help "PF2" - (define-keypad-key GOLD-map ?\C-c 'occur) ;Find "PF3" - (define-keypad-key GOLD-map ?\C-d 'undelete-lines) ;Und Line "PF4" - (define-keypad-key GOLD-map ?0 'open-line) ;Open L "0" - (define-keypad-key GOLD-map ?1 'case-flip-character) ;Chgcase "1" - (define-keypad-key GOLD-map ?2 'delete-to-eol) ;Del EOL "2" - (define-keypad-key GOLD-map ?3 'copy-region-as-kill) ;Copy "3" - (define-keypad-key GOLD-map ?4 'move-to-end) ;Bottom "4" - (define-keypad-key GOLD-map ?5 'move-to-beginning) ;Top "5" - (define-keypad-key GOLD-map ?6 'yank) ;Paste "6" - (define-keypad-key GOLD-map ?7 'execute-extended-command) ;Command "7" - (define-keypad-key GOLD-map ?8 'indent-or-fill-region) ;Fill "8" - (define-keypad-key GOLD-map ?9 'replace-regexp) ;Replace "9" - (define-keypad-key GOLD-map ?- 'undelete-words) ;UND word "-" - (define-keypad-key GOLD-map ?, 'undelete-chars) ;UND Char "," - (define-keypad-key GOLD-map ?. 'redraw-display) ;Reset Window "." - (define-keypad-key GOLD-map ?e 'shell-command)) ;"ENTER" + F7: Copy Rectangle +----------+----------+----------+----------+ + F8: Cut Rect Overstrike |Prev Line |Next Line |Bkwd Char |Frwd Char | + G-F8: Paste Rect Overstrike | (UP) | (DOWN) | (LEFT) | (RIGHT) | + F9: Cut Rect Insert |Window Top|Window Bot|Bkwd Sent |Frwd Sent | + G-F9: Paste Rect Insert +----------+----------+----------+----------+ + F10: Cut Rectangle +G-F10: Paste Rectangle + F11: ESC + F12: Begining of Line +----------+----------+----------+----------+ +G-F12: Delete Other Windows | GOLD | HELP | FNDNXT | DEL L | + F13: Delete to Begin of Word | (PF1) | (PF2) | (PF3) | (PF4) | + HELP: Keypad Help |Mark Wisel|Desc Funct| FIND | UND L | + DO: Execute extended command +----------+----------+----------+----------+ + | PAGE | SECT | APPEND | DEL W | + C-g: Keyboard Quit | (7) | (8) | (9) | (-) | +G-C-g: Keyboard Quit |Ex Ext Cmd|Fill Regio| REPLACE | UND W | + C-h: Beginning of Line +----------+----------+----------+----------+ +G-C-h: Emacs Help | ADVANCE | BACKUP | CUT | DEL C | + C-i: Tab Insert | (4) | (5) | (6) | (,) | + C-j: Delete to Begin of Word | BOTTOM | TOP | Yank | UND C | + C-k: Define Key +----------+----------+----------+----------+ +G-C-k: Restore Key | WORD | EOL | CHAR | Next | + C-l: Form Feed Insert | (1) | (2) | (3) | Window | + C-n: Set Screen Width 80 | CHNGCASE | DEL EOL |Quoted Ins| ! + C-r: Isearch Backward +---------------------+----------+ (ENTER) | + C-s: Isearch Forward | LINE | SELECT | ! + C-t: Display the Time | (0) | (.) | Query | + C-u: Delete to Begin of Line | Open Line | RESET | Replace | + C-v: Redraw Display +---------------------+----------+----------+ + C-w: Set Screen Width 132 + C-z: Suspend Emacs +----------+----------+----------+ +G-C-\\: Split Window | FNDNXT | Yank | CUT | + | (FIND) | (INSERT) | (REMOVE) | + G-b: Buffer Menu | FIND | | COPY | + G-c: Compile +----------+----------+----------+ + G-d: Delete Window |SELECT/RES|SECT BACKW|SECT FORWA| + G-e: Exit | (SELECT) |(PREVIOUS)| (NEXT) | + G-f: Find File | | | | + G-g: Find File Other Window +----------+----------+----------+ + G-h: Keypad Help + G-i: Insert File + G-k: Toggle Capitalization Word + G-l: Downcase Region + G-m: Save Some Buffers + G-n: Next Error + G-o: Switch to Next Window + G-q: Quit + G-r: Revert File + G-s: Save Buffer + G-u: Upcase Region + G-v: Find File Other Window + G-w: Write file + G-y: EDT Emulation OFF + G-z: Switch to User EDT Key Bindings + G-1: Delete Other Windows + G-2: Split Window + G-%: Go to Percentage + G- : Undo (GOLD Spacebar) + G-=: Go to Line + G-`: What line" + + (interactive) + (describe-function 'edt-keypad-help)) -;; Make direction of motion show in mode line -;; while EDT emulation is turned on. -;; Note that the keypad is always turned on when in Emacs. +(defun edt-electric-helpify (fun) + (let ((name "*Help*")) + (if (save-window-excursion + (let* ((p (symbol-function 'print-help-return-message)) + (b (get-buffer name)) + (m (buffer-modified-p b))) + (and b (not (get-buffer-window b)) + (setq b nil)) + (unwind-protect + (progn + (message "%s..." (capitalize (symbol-name fun))) + (and b + (save-excursion + (set-buffer b) + (set-buffer-modified-p t))) + (fset 'print-help-return-message 'ignore) + (call-interactively fun) + (and (get-buffer name) + (get-buffer-window (get-buffer name)) + (or (not b) + (not (eq b (get-buffer name))) + (not (buffer-modified-p b))))) + (fset 'print-help-return-message p) + (and b (buffer-name b) + (save-excursion + (set-buffer b) + (set-buffer-modified-p m)))))) + (with-electric-help 'delete-other-windows name t)))) -(or (assq 'edt-direction-string minor-mode-alist) - (setq minor-mode-alist (cons '(edt-direction-string edt-direction-string) - minor-mode-alist))) +(defun edt-electric-keypad-help () + "Display default EDT bindings." + (interactive) + (edt-electric-helpify 'edt-keypad-help)) + +(defun edt-electric-user-keypad-help () + "Display user custom EDT bindings." + (interactive) + (edt-electric-helpify 'edt-user-keypad-help)) + +;;; +;;; EDT emulation screen width commands. +;;; +;; Some terminals require modification of terminal attributes when changing the +;; number of columns displayed, hence the fboundp tests below. These functions +;; are defined in the corresponding terminal specific file, if needed. + +(defun edt-set-screen-width-80 () + "Set screen width to 80 columns." + (interactive) + (if (fboundp 'edt-set-term-width-80) + (edt-set-term-width-80)) + (set-screen-width 80) + (message "Screen width 80")) + +(defun edt-set-screen-width-132 () + "Set screen width to 132 columns." + (interactive) + (if (fboundp 'edt-set-term-width-132) + (edt-set-term-width-132)) + (set-screen-width 132) + (message "Screen width 132")) + +(provide 'edt) + +;;; edt.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/mlconvert.el --- a/lisp/emulators/mlconvert.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/mlconvert.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,8 +1,10 @@ ;;; mlconvert.el --- convert buffer of Mocklisp code to real lisp. -;; Keywords: emulations ;; Copyright (C) 1985 Free Software Foundation, Inc. +;; Maintainer: FSF +;; Keywords: emulations + ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify it @@ -17,7 +19,18 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34 + +;;; Commentary: + +;; This package converts Mocklisp code written under a Gosling or UniPress +;; Emacs for use with GNU Emacs. The translated code will require runtime +;; support from the mlsupport.el equivalent. + +;;; Code: ;;;###autoload (defun convert-mocklisp-buffer () @@ -100,19 +113,19 @@ (if (looking-at "setq[ \t\n]+buffer-modified-p") (replace-match "set-buffer-modified-p")))) -(ml-expansion 'while '(lambda () - (let ((end (progn (forward-sexp 2) (point-marker))) - (start (progn (forward-sexp -1) (point)))) - (let ((cond (buffer-substring start end))) - (cond ((equal cond "1") - (delete-region (point) end) - (insert "t")) - (t - (insert "(not (zerop ") - (goto-char end) - (insert "))"))) - (set-marker end nil) - (goto-char start))))) +;;(ml-expansion 'while '(lambda () +;; (let ((end (progn (forward-sexp 2) (point-marker))) +;; (start (progn (forward-sexp -1) (point)))) +;; (let ((cond (buffer-substring start end))) +;; (cond ((equal cond "1") +;; (delete-region (point) end) +;; (insert "t")) +;; (t +;; (insert "(not (zerop ") +;; (goto-char end) +;; (insert "))"))) +;; (set-marker end nil) +;; (goto-char start))))) (ml-expansion 'arg "ml-arg") (ml-expansion 'nargs "ml-nargs") @@ -184,6 +197,7 @@ (ml-expansion 'get-tty-no-blanks-input "read-no-blanks-input") (ml-expansion 'get-tty-key "read-key") +(ml-expansion 'concat "ml-concat") (ml-expansion 'c= "char-equal") (ml-expansion 'goto-character "goto-char") (ml-expansion 'substr "ml-substr") @@ -273,3 +287,4 @@ ;Variable pause-writes-files +;;; mlconvert.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/mlsupport.el --- a/lisp/emulators/mlsupport.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/mlsupport.el Mon Aug 13 08:46:56 2007 +0200 @@ -19,16 +19,17 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: ;; This package provides equivalents of certain primitives from Gosling ;; Emacs (including the commercial UniPress versions). These have an ;; ml- prefix to distinguish them from native GNU Emacs functions with -;; similar names. The oackage mlconvert.el translates Mocklisp code +;; similar names. The package mlconvert.el translates Mocklisp code ;; to use these names. ;;; Code: @@ -70,6 +71,10 @@ (defun define-keymap (name) (fset (intern name) (make-keymap))) +;; Make it work to use ml-use-...-map on "esc" and such. +(fset 'esc-map esc-map) +(fset 'ctl-x-map ctl-x-map) + (defun ml-use-local-map (name) (use-local-map (intern (concat name "-map")))) @@ -238,12 +243,14 @@ (define-abbrev-table symbol nil)) (symbol-value symbol))) +;; XEmacs (defun define-hooked-local-abbrev (name exp hook) (define-abbrev (or local-abbrev-table (error "Major mode has no abbrev table")) (downcase name) exp (intern hook))) +;; XEmacs (defun define-hooked-global-abbrev (name exp hook) (define-abbrev global-abbrev-table (downcase name) exp (intern hook))) @@ -336,6 +343,7 @@ (defvar use-csh-option-f 1 "Mocklisp compatibility variable; 1 means pass -f when calling csh.") +;; XEmacs (FSF bugfix? -sb) (defun filter-region (command) (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh")) (csh (equal (file-name-nondirectory shell) "csh"))) @@ -343,6 +351,7 @@ (if (and csh use-csh-option-f) "-cf" "-c") (concat "exec " command)))) +;; XEmacs (FSF bugfix? -sb) (defun execute-monitor-command (command) (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh")) (csh (equal (file-name-nondirectory shell) "csh"))) @@ -436,7 +445,7 @@ (if (< to 0) (setq to (+ to length))) (substring string from (+ from to)))) - +;; XEmacs (defun ml-nargs () "Number of arguments to currently executing mocklisp function." (if (eq mocklisp-arguments 'interactive) diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/teco.el --- a/lisp/emulators/teco.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/teco.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,29 @@ ;;; teco.el --- Teco interpreter for Gnu Emacs, version 1. -(require 'backquote) +;; Author: Dale R. Worley. +;; Keywords: emulators + +;; 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: + ;; This code has been tested some, but no doubt contains a zillion bugs. ;; You have been warned. @@ -168,6 +191,9 @@ ;; DEL Delete last character typed in +;;; Code: +(require 'backquote) + ;; set a range of elements of an array to a value (defun teco-set-elements (array start end value) (let ((i start)) diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/tpu-edt.el --- a/lisp/emulators/tpu-edt.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/tpu-edt.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,36 +1,281 @@ -;; Copyright (C) 1993 Free Software Foundation, Inc. +;;; tpu-edt.el --- Emacs emulating TPU emulating EDT + +;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. ;; Author: Rob Riepel ;; Maintainer: Rob Riepel -;; Version: 3.2 +;; Version: 4.2 ;; Keywords: emulations -;; Patched for XEmacs support of zmacs regions by: -;; R. Kevin Oberman +;; This file is part of XEmacs. -;; 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 +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34 + +;; TPU-edt is based on tpu.el by Jeff Kowalski and Bob Covey. + +;;; Commentary: + +;; %% TPU-edt -- Emacs emulating TPU emulating EDT + +;; %% Contents + +;; % Introduction +;; % Differences Between TPU-edt and DEC TPU/edt +;; % Starting TPU-edt +;; % Customizing TPU-edt using the Emacs Initialization File +;; % Regular Expressions in TPU-edt + + +;; %% Introduction + +;; TPU-edt emulates the popular DEC VMS editor EDT (actually, it emulates +;; DEC TPU's EDT emulation, hence the name TPU-edt). TPU-edt features the +;; following TPU/edt functionality: + +;; . EDT keypad +;; . On-line help +;; . Repeat counts +;; . Scroll margins +;; . Learn sequences +;; . Free cursor mode +;; . Rectangular cut and paste +;; . Multiple windows and buffers +;; . TPU line-mode REPLACE command +;; . Wild card search and substitution +;; . Configurable through an initialization file +;; . History recall of search strings, file names, and commands + +;; Please note that TPU-edt does NOT emulate TPU. It emulates TPU's EDT +;; emulation. Very few TPU line-mode commands are supported. + +;; TPU-edt, like it's VMS cousin, works on VT-series terminals with DEC +;; style keyboards. VT terminal emulators, including xterm with the +;; appropriate key translations, work just fine too. + +;; TPU-edt works with X-windows. This is accomplished through a TPU-edt X +;; key map. The TPU-edt module tpu-mapper creates this map and stores it +;; in a file. Tpu-mapper will be run automatically the first time you +;; invoke the X-windows version of emacs, or you can run it by hand. See +;; the commentary in tpu-mapper.el for details. + + +;; %% Differences Between TPU-edt and DEC TPU/edt + +;; In some cases, Emacs doesn't support text highlighting, so selected +;; regions are not shown in inverse video. Emacs uses the concept of "the +;; mark". The mark is set at one end of a selected region; the cursor is +;; at the other. The letter "M" appears in the mode line when the mark is +;; set. The native emacs command ^X^X (Control-X twice) exchanges the +;; cursor with the mark; this provides a handy way to find the location of +;; the mark. + +;; In TPU the cursor can be either bound or free. Bound means the cursor +;; cannot wander outside the text of the file being edited. Free means +;; the arrow keys can move the cursor past the ends of lines. Free is the +;; default mode in TPU; bound is the only mode in EDT. Bound is the only +;; mode in the base version of TPU-edt; optional extensions add an +;; approximation of free mode, see the commentary in tpu-extras.el for +;; details. + +;; Like TPU, emacs uses multiple buffers. Some buffers are used to hold +;; files you are editing; other "internal" buffers are used for emacs' own +;; purposes (like showing you help). Here are some commands for dealing +;; with buffers. + +;; Gold-B moves to next buffer, including internal buffers +;; Gold-N moves to next buffer containing a file +;; Gold-M brings up a buffer menu (like TPU "show buffers") + +;; Emacs is very fond of throwing up new windows. Dealing with all these +;; windows can be a little confusing at first, so here are a few commands +;; to that may help: + +;; Gold-Next_Scr moves to the next window on the screen +;; Gold-Prev_Scr moves to the previous window on the screen +;; Gold-TAB also moves to the next window on the screen + +;; Control-x 1 deletes all but the current window +;; Control-x 0 deletes the current window + +;; Note that the buffers associated with deleted windows still exist! + +;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or +;; Do. Most of the commands available are emacs commands. Some TPU +;; commands are available, they are: replace, exit, quit, include, and +;; Get (unfortunately, "get" is an internal emacs function, so we are +;; stuck with "Get" - to make life easier, Get is available as Gold-g). + +;; TPU-edt supports the recall of commands, file names, and search +;; strings. The history of strings recalled differs slightly from +;; TPU/edt, but it is still very convenient. + +;; Help is available! The traditional help keys (Help and PF2) display +;; a small help file showing the default keypad layout, control key +;; functions, and Gold key functions. Pressing any key inside of help +;; splits the screen and prints a description of the function of the +;; pressed key. Gold-PF2 invokes the native emacs help, with it's +;; zillions of options. + +;; Thanks to emacs, TPU-edt has some extensions that may make your life +;; easier, or at least more interesting. For example, Gold-r toggles +;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work +;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression +;; mode. In regular expression mode Find, Find Next, and the line-mode +;; replace command work with regular expressions. [A regular expression +;; is a pattern that denotes a set of strings; like VMS wildcards.] + +;; Emacs also gives TPU-edt the undo and occur functions. Undo does +;; what it says; it undoes the last change. Multiple undos in a row +;; undo multiple changes. For your convenience, undo is available on +;; Gold-u. Occur shows all the lines containing a specific string in +;; another window. Moving to that window, and typing ^C^C (Control-C +;; twice) on a particular line moves you back to the original window +;; at that line. Occur is on Gold-o. + +;; Finally, as you edit, remember that all the power of emacs is at +;; your disposal. It really is a fantastic tool. You may even want to +;; take some time and read the emacs tutorial; perhaps not to learn the +;; native emacs key bindings, but to get a feel for all the things +;; emacs can do for you. The emacs tutorial is available from the +;; emacs help function: "Gold-PF2 t" + + +;; %% Starting TPU-edt + +;; All you have to do to start TPU-edt, is turn it on. This can be +;; done from the command line when running emacs. + +;; prompt> emacs -f tpu-edt + +;; If you've already started emacs, turn on TPU-edt using the tpu-edt +;; command. First press `M-x' (that's usually `ESC' followed by `x') +;; and type `tpu-edt' followed by a carriage return. + +;; If you like TPU-edt and want to use it all the time, you can start +;; TPU-edt using the emacs initialization file, .emacs. Simply create +;; a .emacs file in your home directory containing the line: + +;; (tpu-edt) + +;; That's all you need to do to start TPU-edt. + + +;; %% Customizing TPU-edt using the Emacs Initialization File + +;; The following is a sample emacs initialization file. It shows how to +;; invoke TPU-edt, and how to customize it. + +;; ; .emacs - a sample emacs initialization file + +;; ; Turn on TPU-edt +;; (tpu-edt) + +;; ; Set scroll margins 10% (top) and 15% (bottom). +;; (tpu-set-scroll-margins "10%" "15%") + +;; ; Load the vtxxx terminal control functions. +;; (load "vt-control" t) + +;; ; TPU-edt treats words like EDT; here's how to add word separators. +;; ; Note that backslash (\) and double quote (") are quoted with '\'. +;; (tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$") + +;; ; Emacs is happy to save files without a final newline; other Unix +;; ; programs hate that! Here we make sure that files end with newlines. +;; (setq require-final-newline t) + +;; ; Emacs uses Control-s and Control-q. Problems can occur when using +;; ; emacs on terminals that use these codes for flow control (Xon/Xoff +;; ; flow control). These lines disable emacs' use of these characters. +;; (global-unset-key "\C-s") +;; (global-unset-key "\C-q") + +;; ; The emacs universal-argument function is very useful. +;; ; This line maps universal-argument to Gold-PF1. +;; (define-key GOLD-SS3-map "P" 'universal-argument) ; Gold-PF1 + +;; ; Make KP7 move by paragraphs, instead of pages. +;; (define-key SS3-map "w" 'tpu-paragraph) ; KP7 + +;; ; Repeat the preceding mappings for X-windows. +;; (cond +;; (window-system +;; (global-set-key [kp_7] 'tpu-paragraph) ; KP7 +;; (define-key GOLD-map [kp_f1] 'universal-argument))) ; GOLD-PF1 + +;; ; Display the TPU-edt version. +;; (tpu-version) + + +;; %% Regular Expressions in TPU-edt + +;; Gold-* toggles TPU-edt regular expression mode. In regular expression +;; mode, find, find next, replace, and substitute accept emacs regular +;; expressions. A complete list of emacs regular expressions can be found +;; using the emacs "info" command (it's somewhat like the VMS help +;; command). Try the following sequence of commands: + +;; DO info +;; m emacs + +;; Type "q" to quit out of info mode. + +;; There is a problem in regular expression mode when searching for empty +;; strings, like beginning-of-line (^) and end-of-line ($). When searching +;; for these strings, find-next may find the current string, instead of the +;; next one. This can cause global replace and substitute commands to loop +;; forever in the same location. For this reason, commands like + +;; replace "^" "> " " to beginning of line> +;; replace "$" "00711" + +;; may not work properly. + +;; Commands like those above are very useful for adding text to the +;; beginning or end of lines. They might work on a line-by-line basis, but +;; go into an infinite loop if the "all" response is specified. If the +;; goal is to add a string to the beginning or end of a particular set of +;; lines TPU-edt provides functions to do this. + +;; Gold-^ Add a string at BOL in region or buffer +;; Gold-$ Add a string at EOL in region or buffer + +;; There is also a TPU-edt interface to the native emacs string replacement +;; commands. Gold-/ invokes this command. It accepts regular expressions +;; if TPU-edt is in regular expression mode. Given a repeat count, it will +;; perform the replacement without prompting for confirmation. + +;; This command replaces empty strings correctly, however, it has its +;; drawbacks. As a native emacs command, it has a different interface +;; than the emulated TPU commands. Also, it works only in the forward +;; direction, regardless of the current TPU-edt direction. + +;; NOTE: There was a very old tpu-edt in XEmacs 19.14 so I deleted it and +;; replaced it with the one in Emacs 19.34. -sb ;;; Code: ;;; -;;; Revision and Version Information +;;; Version Information ;;; -(defconst tpu-version "3.2" "TPU-edt version number.") +(defconst tpu-version "4.2" "TPU-edt version number.") ;;; @@ -58,17 +303,11 @@ ;;; o tpu-update-mode-line o mode line section ;;; (defconst tpu-emacs19-p (not (string-lessp emacs-version "19")) - "Non-NIL if we are running XEmacs or GNU Emacs version 19.") - -(defconst tpu-gnu-emacs18-p (not tpu-emacs19-p) - "Non-NIL if we are running GNU Emacs version 18.") + "Non-nil if we are running Lucid Emacs or version 19.") -(defconst tpu-xemacs-emacs19-p - (and tpu-emacs19-p (string-match "XEmacs" emacs-version)) - "Non-NIL if we are running XEmacs version 19.") - -(defconst tpu-gnu-emacs19-p (and tpu-emacs19-p (not tpu-xemacs-emacs19-p)) - "Non-NIL if we are running GNU Emacs version 19.") +(defconst tpu-lucid-emacs19-p + (and tpu-emacs19-p (string-match "Lucid" emacs-version)) + "Non-nil if we are running Lucid Emacs version 19.") ;;; @@ -83,22 +322,22 @@ SS3 is DEC's name for the sequence O.") (defvar GOLD-map (make-keymap) - "Maps the function keys on the VT100 keyboard preceeded by PF1. + "Maps the function keys on the VT100 keyboard preceded by PF1. GOLD is the ASCII 7-bit escape sequence OP.") (defvar GOLD-CSI-map (make-sparse-keymap) - "Maps the function keys on the VT100 keyboard preceeded by GOLD-CSI.") + "Maps the function keys on the VT100 keyboard preceded by GOLD-CSI.") (defvar GOLD-SS3-map (make-sparse-keymap) - "Maps the function keys on the VT100 keyboard preceeded by GOLD-SS3.") + "Maps the function keys on the VT100 keyboard preceded by GOLD-SS3.") (defvar tpu-global-map nil "TPU-edt global keymap.") (defvar tpu-original-global-map (copy-keymap global-map) "Original global keymap.") -(and tpu-xemacs-emacs19-p +(and tpu-lucid-emacs19-p (defvar minibuffer-local-ns-map (make-sparse-keymap) - "Hack to give XEmacs the same maps as GNU emacs.")) + "Hack to give Lucid Emacs the same maps as ordinary Emacs.")) ;;; @@ -131,7 +370,7 @@ "True when TPU-edt is operating in the forward direction.") (defvar tpu-reverse nil "True when TPU-edt is operating in the backward direction.") -(defvar tpu-control-keys t +(defvar tpu-control-keys nil "If non-nil, control keys are set to perform TPU functions.") (defvar tpu-xkeys-file nil "File containing TPU-edt X key map.") @@ -197,8 +436,11 @@ (purecopy " ") 'tpu-mark-flag (purecopy " %[(") - 'mode-name 'minor-mode-alist "%n" 'mode-line-process - (purecopy ")%]----") + 'mode-name 'mode-line-process 'minor-mode-alist + (purecopy "%n") + (purecopy ")%]--") + (purecopy '(line-number-mode "L%l--")) + (purecopy '(column-number-mode "C%c--")) (purecopy '(-3 . "%p")) (purecopy "-%-"))) (or (assq 'tpu-newline-and-indent-p minor-mode-alist) @@ -221,12 +463,12 @@ (cond (tpu-emacs19-p (force-mode-line-update)) (t (set-buffer-modified-p (buffer-modified-p)) (sit-for 0)))) -(cond (tpu-gnu-emacs19-p +(cond (tpu-lucid-emacs19-p + (add-hook 'zmacs-deactivate-region-hook 'tpu-update-mode-line) + (add-hook 'zmacs-activate-region-hook 'tpu-update-mode-line)) + (tpu-emacs19-p (add-hook 'activate-mark-hook 'tpu-update-mode-line) - (add-hook 'deactivate-mark-hook 'tpu-update-mode-line)) - (tpu-xemacs-emacs19-p - (add-hook 'zmacs-deactivate-region-hook 'tpu-update-mode-line) - (add-hook 'zmacs-activate-region-hook 'tpu-update-mode-line))) + (add-hook 'deactivate-mark-hook 'tpu-update-mode-line))) ;;; @@ -281,7 +523,7 @@ (defun tpu-show-match-markers nil "Show the values of the match markers." - (interactive "_") + (interactive) (if (markerp tpu-match-beginning-mark) (let ((beg (marker-position tpu-match-beginning-mark))) (message "(%s, %s) in %s -- current %s in %s" @@ -300,17 +542,17 @@ (defun tpu-mark nil "TPU-edt version of the mark function. Return the appropriate value of the mark for the current -version of emacs." - (cond (tpu-xemacs-emacs19-p (mark (not zmacs-regions))) - (tpu-gnu-emacs19-p (and mark-active (mark (not transient-mark-mode)))) +version of Emacs." + (cond (tpu-lucid-emacs19-p (mark (not zmacs-regions))) + (tpu-emacs19-p (and mark-active (mark (not transient-mark-mode)))) (t (mark)))) (defun tpu-set-mark (pos) - "TPU-edt verion of the set-mark function. -Sets the mark at POS and activates the region acording to the -current version of emacs." + "TPU-edt verion of the `set-mark' function. +Sets the mark at POS and activates the region according to the +current version of Emacs." (set-mark pos) - (and tpu-xemacs-emacs19-p pos (zmacs-activate-region))) + (and tpu-lucid-emacs19-p pos (zmacs-activate-region))) (defun tpu-string-prompt (prompt history-symbol) "Read a string with PROMPT." @@ -323,8 +565,8 @@ (defun tpu-y-or-n-p (prompt &optional not-yes) "Prompt for a y or n answer with positive default. Optional second argument NOT-YES changes default to negative. -Like emacs y-or-n-p, also accepts space as y and DEL as n." - (message (format "%s[%s]" prompt (if not-yes "n" "y"))) +Like Emacs `y-or-n-p', but also accepts space as y and DEL as n." + (message "%s[%s]" prompt (if not-yes "n" "y")) (let ((doit t)) (while doit (setq doit nil) @@ -336,8 +578,8 @@ ((= ans ?\r) (setq tpu-last-answer (not not-yes))) (t (setq doit t) (beep) - (message (format "Please answer y or n. %s[%s]" - prompt (if not-yes "n" "y")))))))) + (message "Please answer y or n. %s[%s]" + prompt (if not-yes "n" "y"))))))) tpu-last-answer) (defun tpu-local-set-key (key func) @@ -364,13 +606,13 @@ (defun tpu-drop-breadcrumb (num) "Drops a breadcrumb that can be returned to later with goto-breadcrumb." - (interactive "_p") + (interactive "p") (put tpu-breadcrumb-plist num (list (current-buffer) (point))) (message "Mark %d set." num)) (defun tpu-goto-breadcrumb (num) "Returns to a breadcrumb set with drop-breadcrumb." - (interactive "_p") + (interactive "p") (cond ((get tpu-breadcrumb-plist num) (switch-to-buffer (car (get tpu-breadcrumb-plist num))) (goto-char (tpu-cadr (get tpu-breadcrumb-plist num))) @@ -385,7 +627,7 @@ (defun tpu-change-case (num) "Change the case of the character under the cursor or region. Accepts a prefix argument of the number of characters to invert." - (interactive "_p") + (interactive "p") (cond ((tpu-mark) (let ((beg (region-beginning)) (end (region-end))) (while (> end beg) @@ -413,7 +655,7 @@ (defun tpu-fill (num) "Fill paragraph or marked region. With argument, fill and justify." - (interactive "_P") + (interactive "P") (cond ((tpu-mark) (fill-region (point) (tpu-mark) num) (tpu-unselect t)) @@ -422,20 +664,20 @@ (defun tpu-version nil "Print the TPU-edt version number." - (interactive "_") + (interactive) (message "TPU-edt version %s by Rob Riepel (riepel@networking.stanford.edu)" tpu-version)) (defun tpu-reset-screen-size (height width) "Sets the screen size." - (interactive "_nnew screen height: \nnnew screen width: ") - (set-screen-height (selected-screen) height) - (set-screen-width (selected-screen) width)) + (interactive "nnew screen height: \nnnew screen width: ") + (set-screen-height height) + (set-screen-width width)) (defun tpu-toggle-newline-and-indent nil "Toggle between 'newline and indent' and 'simple newline'." - (interactive "_") + (interactive) (cond (tpu-newline-and-indent-p (setq tpu-newline-and-indent-string "") (setq tpu-newline-and-indent-p nil) @@ -452,7 +694,7 @@ (defun tpu-spell-check nil "Checks the spelling of the region, or of the entire buffer if no region is selected." - (interactive "_") + (interactive) (cond (tpu-have-ispell (if (tpu-mark) (ispell-region (tpu-mark) (point)) (ispell-buffer))) (t @@ -461,7 +703,7 @@ (defun tpu-toggle-overwrite-mode nil "Switches in and out of overwrite mode" - (interactive "_") + (interactive) (cond (overwrite-mode (tpu-local-set-key "\177" tpu-saved-delete-func) (overwrite-mode 0)) @@ -473,14 +715,14 @@ (defun tpu-special-insert (num) "Insert a character or control code according to its ASCII decimal value." - (interactive "_P") + (interactive "P") (if overwrite-mode (delete-char 1)) (insert (if num num 0))) (defun tpu-quoted-insert (num) "Read next input character and insert it. This is useful for inserting control characters." - (interactive "_*p") + (interactive "*p") (let ((char (read-char)) ) (if overwrite-mode (delete-char num)) (insert-char char num))) @@ -491,20 +733,20 @@ ;;; (defun tpu-include (file) "TPU-like include file" - (interactive "_fInclude file: ") + (interactive "fInclude file: ") (save-excursion (insert-file file) (message ""))) (defun tpu-get (file) "TPU-like get file" - (interactive "_FFile to get: ") + (interactive "FFile to get: ") (find-file file)) (defun tpu-what-line nil "Tells what line the point is on, and the total number of lines in the buffer." - (interactive "_") + (interactive) (if (eobp) (message "You are at the End of Buffer. The last line is %d." (count-lines 1 (point-max))) @@ -514,14 +756,14 @@ (defun tpu-exit nil "Exit the way TPU does, save current buffer and ask about others." - (interactive "_") + (interactive) (if (not (eq (recursion-depth) 0)) (exit-recursive-edit) (progn (save-buffer) (save-buffers-kill-emacs)))) (defun tpu-quit nil "Quit the way TPU does, ask to make sure changes should be abandoned." - (interactive "_") + (interactive) (let ((list (buffer-list)) (working t)) (while (and list working) @@ -642,25 +884,45 @@ B Next Buffer - display the next buffer (all buffers) C Recall - edit and possibly repeat previous commands E Exit - save current buffer and ask about others + G Get - load a file into a new edit buffer - G Get - load a file into a new edit buffer I Include - include a file in this buffer K Kill Buffer - abandon edits and delete buffer - M Buffer Menu - display a list of all buffers N Next File Buffer - display next buffer containing a file + O Occur - show following lines containing REGEXP - Q Quit - exit without saving anything R Toggle rectangular mode for remove and insert S Search and substitute - line mode REPLACE command + ^T Toggle control key bindings between TPU and emacs U Undo - undo the last edit W Write - save current buffer X Exit - save all modified buffers and exit \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f + More extensive documentation on TPU-edt can be found in the `Commentary' + section of tpu-edt.el. This section can be accessed through the standard + Emacs help facility using the `p' option. Once you exit TPU-edt Help, one + of the following key sequences is sure to get you there. + + ^h p if you're not yet using TPU-edt + Gold-PF2 p if you're using TPU-edt + + Alternatively, fire up Emacs help from the command prompt, with + + M-x help-for-help p + + Where `M-x' might be any of `Gold-KP7', 'Do', or 'ESC-x'. + + When you successfully invoke this part of the Emacs help facility, you + will see a buffer named `*Finder*' listing a number of topics. Look for + tpu-edt under `emulations'. + +\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f + *** No more help, use P to view previous screen") (defvar tpu-help-enter (format "%s" "\eOM")) ; tpu-help enter key symbol @@ -672,7 +934,7 @@ (defun tpu-help nil "Display TPU-edt help." - (interactive "_") + (interactive) ;; Save current window configuration (save-window-excursion ;; Create and fill help buffer if necessary @@ -696,12 +958,10 @@ (if split (setq key (read-key-sequence - "Press the key you want help on (RET=exit, ENTER=redisplay, N=next, -P=prev): ")) + "Press the key you want help on (RET=exit, ENTER=redisplay, N=next, P=prev): ")) (setq key (read-key-sequence - "Press the key you want help on (RET to exit, N next screen, P prev -screen): "))) + "Press the key you want help on (RET to exit, N next screen, P prev screen): "))) ;; Process the read key ;; @@ -730,7 +990,7 @@ (scroll-other-window -8) (error nil))) (t - (backward-page 2) + (backward-page) (forward-line 1) (tpu-line-to-top-of-window)))) ((not (equal tpu-help-return fkey)) @@ -746,12 +1006,12 @@ ;;; (defun tpu-insert-escape nil "Inserts an escape character, and so becomes the escape-key alias." - (interactive "_") + (interactive) (insert "\e")) (defun tpu-insert-formfeed nil "Inserts a formfeed character." - (interactive "_") + (interactive) (insert "\C-L")) @@ -762,14 +1022,14 @@ (defun tpu-end-define-macro-key (key) "Ends the current macro definition" - (interactive "_kPress the key you want to use to do what was just learned: ") + (interactive "kPress the key you want to use to do what was just learned: ") (end-kbd-macro nil) (global-set-key key last-kbd-macro) (global-set-key "\C-r" tpu-saved-control-r)) (defun tpu-define-macro-key nil "Bind a set of keystrokes to a single key, or key combination." - (interactive "_") + (interactive) (setq tpu-saved-control-r (global-key-binding "\C-r")) (global-set-key "\C-r" 'tpu-end-define-macro-key) (start-kbd-macro nil)) @@ -788,12 +1048,12 @@ (defun tpu-save-all-buffers-kill-emacs nil "Save all buffers and exit emacs." (interactive) - (setq trim-versions-without-asking t) - (save-buffers-kill-emacs t)) + (let ((delete-old-versions t)) + (save-buffers-kill-emacs t))) (defun tpu-write-current-buffers nil "Save all modified buffers without exiting." - (interactive "_") + (interactive) (save-some-buffers t)) (defun tpu-next-buffer nil @@ -802,14 +1062,19 @@ (switch-to-buffer (car (reverse (buffer-list))))) (defun tpu-next-file-buffer nil - "Go to next buffer in ring that is visiting a file." + "Go to next buffer in ring that is visiting a file or directory." (interactive) - (let ((starting-buffer (buffer-name))) - (switch-to-buffer (car (reverse (buffer-list)))) - (while (and (not (equal (buffer-name) starting-buffer)) - (not (buffer-file-name))) - (switch-to-buffer (car (reverse (buffer-list))))) - (if (equal (buffer-name) starting-buffer) (error "No other buffers.")))) + (let ((list (tpu-make-file-buffer-list (buffer-list)))) + (setq list (delq (current-buffer) list)) + (if (not list) (error "No other buffers.")) + (switch-to-buffer (car (reverse list))))) + +(defun tpu-make-file-buffer-list (buffer-list) + "Returns names from BUFFER-LIST excluding those beginning with a space or star." + (delq nil (mapcar '(lambda (b) + (if (or (= (aref (buffer-name b) 0) ? ) + (= (aref (buffer-name b) 0) ?*)) nil b)) + buffer-list))) (defun tpu-next-window nil "Move to the next window." @@ -829,7 +1094,7 @@ ;;; (defun tpu-toggle-regexp nil "Switches in and out of regular expression search and replace mode." - (interactive "_") + (interactive) (setq tpu-regexp-p (not tpu-regexp-p)) (tpu-set-search) (and (interactive-p) @@ -846,14 +1111,14 @@ (defun tpu-search nil "Search for a string or regular expression. The search is performed in the current direction." - (interactive "_") + (interactive) (tpu-set-search) (tpu-search-internal "")) (defun tpu-search-forward nil "Search for a string or regular expression. The search is begins in the forward direction." - (interactive "_") + (interactive) (setq tpu-searching-forward t) (tpu-set-search t) (tpu-search-internal "")) @@ -861,7 +1126,7 @@ (defun tpu-search-reverse nil "Search for a string or regular expression. The search is begins in the reverse direction." - (interactive "_") + (interactive) (setq tpu-searching-forward nil) (tpu-set-search t) (tpu-search-internal "")) @@ -869,7 +1134,7 @@ (defun tpu-search-again nil "Search for the same string or regular expression as last time. The search is performed in the current direction." - (interactive "_") + (interactive) (tpu-search-internal tpu-search-last-string)) ;; tpu-set-search defines the search functions used by the TPU-edt internal @@ -878,10 +1143,11 @@ ;; to ensure that the next search will be in the current direction. It is ;; called from: -;; tpu-advance tpu-backup -;; tpu-toggle-regexp tpu-toggle-search-direction (t) -;; tpu-search tpu-lm-replace -;; tpu-search-forward (t) tpu-search-reverse (t) +;; tpu-advance tpu-backup +;; tpu-toggle-regexp tpu-toggle-search-direction (t) +;; tpu-search tpu-lm-replace +;; tpu-search-forward (t) tpu-search-reverse (t) +;; tpu-search-forward-exit (t) tpu-search-backward-exit (t) (defun tpu-set-search (&optional arg) "Set the search functions and set the search direction to the current @@ -910,33 +1176,50 @@ (tpu-unset-match) (tpu-adjust-search) - (cond ((tpu-emacs-search tpu-search-last-string nil t) - (tpu-set-match) (goto-char (tpu-match-beginning))) + (let ((case-fold-search + (and case-fold-search (tpu-check-search-case tpu-search-last-string)))) - (t - (tpu-adjust-search t) - (let ((found nil) (pos nil)) - (save-excursion - (let ((tpu-searching-forward (not tpu-searching-forward))) - (tpu-adjust-search) - (setq found (tpu-emacs-rev-search tpu-search-last-string nil t)) - (setq pos (match-beginning 0)))) + (cond ((tpu-emacs-search tpu-search-last-string nil t) + (tpu-set-match) (goto-char (tpu-match-beginning))) - (cond (found - (cond ((tpu-y-or-n-p - (format "Found in %s direction. Go there? " - (if tpu-searching-forward "reverse" "forward"))) - (goto-char pos) (tpu-set-match) - (tpu-toggle-search-direction)))) + (t + (tpu-adjust-search t) + (let ((found nil) (pos nil)) + (save-excursion + (let ((tpu-searching-forward (not tpu-searching-forward))) + (tpu-adjust-search) + (setq found (tpu-emacs-rev-search tpu-search-last-string nil t)) + (setq pos (match-beginning 0)))) - (t - (if (not quiet) - (message - "%sSearch failed: \"%s\"" - (if tpu-regexp-p "RE " "") tpu-search-last-string)))))))) + (cond + (found + (cond ((tpu-y-or-n-p + (format "Found in %s direction. Go there? " + (if tpu-searching-forward "reverse" "forward"))) + (goto-char pos) (tpu-set-match) + (tpu-toggle-search-direction)))) + + (t + (if (not quiet) + (message + "%sSearch failed: \"%s\"" + (if tpu-regexp-p "RE " "") tpu-search-last-string))))))))) (fset 'tpu-search-internal-core (symbol-function 'tpu-search-internal)) +(defun tpu-check-search-case (string) + "Returns t if string contains upper case." + ;; if using regexp, eliminate upper case forms (\B \W \S.) + (if tpu-regexp-p + (let ((pat (copy-sequence string)) (case-fold-search nil) (pos 0)) + (while (setq pos (string-match "\\\\\\\\" pat)) (aset pat (+ 1 pos) ?.)) + (while (setq pos (string-match "\\\\B" pat)) (aset pat (+ 1 pos) ?.)) + (while (setq pos (string-match "\\\\W" pat)) (aset pat (+ 1 pos) ?.)) + (while (setq pos (string-match "\\\\S." pat)) + (aset pat (+ 1 pos) ?.) (aset pat (+ 2 pos) ?.)) + (string-equal pat (downcase pat))) + (string-equal string (downcase string)))) + (defun tpu-adjust-search (&optional arg) "For forward searches, move forward a character before searching, and backward a character after a failed search. Arg means end of search." @@ -947,20 +1230,34 @@ (defun tpu-toggle-search-direction nil "Toggle the TPU-edt search direction. Used for reversing a search in progress." - (interactive "_") + (interactive) (setq tpu-searching-forward (not tpu-searching-forward)) (tpu-set-search t) (and (interactive-p) (message "Searching %sward." (if tpu-searching-forward "for" "back")))) +(defun tpu-search-forward-exit nil + "Set search direction forward and exit minibuffer." + (interactive) + (setq tpu-searching-forward t) + (tpu-set-search t) + (exit-minibuffer)) + +(defun tpu-search-backward-exit nil + "Set search direction backward and exit minibuffer." + (interactive) + (setq tpu-searching-forward nil) + (tpu-set-search t) + (exit-minibuffer)) + ;;; ;;; Select / Unselect ;;; (defun tpu-select (&optional quiet) "Sets the mark to define one end of a region." - (interactive "_P") + (interactive "P") (cond ((tpu-mark) (tpu-unselect quiet)) (t @@ -974,7 +1271,6 @@ (setq mark-ring nil) (tpu-set-mark nil) (tpu-update-mode-line) - (zmacs-deactivate-region) (if (not quiet) (message "Selection canceled."))) @@ -983,7 +1279,7 @@ ;;; (defun tpu-toggle-rectangle nil "Toggle rectangular mode for remove and insert." - (interactive "_") + (interactive) (setq tpu-rectangular-p (not tpu-rectangular-p)) (setq tpu-rectangle-string (if tpu-rectangular-p " Rect" "")) (tpu-update-mode-line) @@ -997,7 +1293,7 @@ (let ((mc (current-column)) (pc (progn (exchange-point-and-mark) (current-column)))) - (cond ((> (point) (tpu-mark)) ; point on lower line + (cond ((> (point) (tpu-mark)) ; point on lower line (cond ((> pc mc) ; point @ lower-right (exchange-point-and-mark)) ; point -> upper-left @@ -1066,7 +1362,7 @@ (defun tpu-append-region (arg) "Append selected region to the tpu-cut buffer. In the absence of an argument, delete the selected region too." - (interactive "_P") + (interactive "P") (cond ((tpu-mark) (let ((beg (region-beginning)) (end (region-end))) (setq tpu-last-deleted-region @@ -1088,7 +1384,7 @@ "Delete one or specified number of lines after point. This includes the newline character at the end of each line. They are saved for the TPU-edt undelete-lines command." - (interactive "_p") + (interactive "p") (let ((beg (point))) (forward-line num) (if (not (eq (preceding-char) ?\n)) @@ -1101,7 +1397,7 @@ "Delete text up to end of line. With argument, delete up to to Nth line-end past point. They are saved for the TPU-edt undelete-lines command." - (interactive "_p") + (interactive "p") (let ((beg (point))) (forward-char 1) (end-of-line num) @@ -1113,7 +1409,7 @@ "Delete text back to beginning of line. With argument, delete up to to Nth line-end past point. They are saved for the TPU-edt undelete-lines command." - (interactive "_p") + (interactive "p") (let ((beg (point))) (tpu-next-beginning-of-line num) (setq tpu-last-deleted-lines @@ -1123,7 +1419,7 @@ (defun tpu-delete-current-word (num) "Delete one or specified number of words after point. They are saved for the TPU-edt undelete-words command." - (interactive "_p") + (interactive "p") (let ((beg (point))) (tpu-forward-to-word num) (setq tpu-last-deleted-words @@ -1133,7 +1429,7 @@ (defun tpu-delete-previous-word (num) "Delete one or specified number of words before point. They are saved for the TPU-edt undelete-words command." - (interactive "_p") + (interactive "p") (let ((beg (point))) (tpu-backward-to-word num) (setq tpu-last-deleted-words @@ -1143,7 +1439,7 @@ (defun tpu-delete-current-char (num) "Delete one or specified number of characters after point. The last character deleted is saved for the TPU-edt undelete-char command." - (interactive "_p") + (interactive "p") (while (and (> num 0) (not (eobp))) (setq tpu-last-deleted-char (char-after (point))) (cond (overwrite-mode @@ -1160,7 +1456,7 @@ (defun tpu-paste (num) "Insert the last region or rectangle of killed text. With argument reinserts the text that many times." - (interactive "_p") + (interactive "p") (while (> num 0) (cond (tpu-rectangular-p (let ((beg (point))) @@ -1175,7 +1471,7 @@ (defun tpu-undelete-lines (num) "Insert lines deleted by last TPU-edt line-deletion command. With argument reinserts lines that many times." - (interactive "_p") + (interactive "p") (let ((beg (point))) (while (> num 0) (insert tpu-last-deleted-lines) @@ -1185,7 +1481,7 @@ (defun tpu-undelete-words (num) "Insert words deleted by last TPU-edt word-deletion command. With argument reinserts words that many times." - (interactive "_p") + (interactive "p") (let ((beg (point))) (while (> num 0) (insert tpu-last-deleted-words) @@ -1195,7 +1491,7 @@ (defun tpu-undelete-char (num) "Insert character deleted by last TPU-edt character-deletion command. With argument reinserts the character that many times." - (interactive "_p") + (interactive "p") (while (> num 0) (if overwrite-mode (prog1 (forward-char -1) (delete-char 1))) (insert tpu-last-deleted-char) @@ -1228,7 +1524,7 @@ "Replace the selected region with the contents of the cut buffer, and repeat most recent search. A numeric argument serves as a repeat count. A negative argument means replace all occurrences of the search string." - (interactive "_p") + (interactive "p") (cond ((or (tpu-mark) (tpu-check-match)) (while (and (not (= num 0)) (or (tpu-mark) (tpu-check-match))) (let ((beg (point))) @@ -1303,7 +1599,7 @@ currently in regular expression mode, the emacs regular expression replace functions are used. If an argument is supplied, replacements are performed without asking. Only works in forward direction." - (interactive "_P") + (interactive "P") (cond (dont-ask (setq current-prefix-arg nil) (call-interactively @@ -1362,17 +1658,17 @@ (defun tpu-char (num) "Move to the next character in the current direction. A repeat count means move that many characters." - (interactive "_p") + (interactive "p") (if tpu-advance (tpu-forward-char num) (tpu-backward-char num))) (defun tpu-forward-char (num) "Move right ARG characters (left if ARG is negative)." - (interactive "_p") + (interactive "p") (forward-char num)) (defun tpu-backward-char (num) "Move left ARG characters (right if ARG is negative)." - (interactive "_p") + (interactive "p") (backward-char num)) @@ -1388,13 +1684,13 @@ (defun tpu-word (num) "Move to the beginning of the next word in the current direction. A repeat count means move that many words." - (interactive "_p") + (interactive "p") (if tpu-advance (tpu-forward-to-word num) (tpu-backward-to-word num))) (defun tpu-forward-to-word (num) "Move forward until encountering the beginning of a word. With argument, do this that many times." - (interactive "_p") + (interactive "p") (while (and (> num 0) (not (eobp))) (let* ((beg (point)) (end (prog2 (end-of-line) (point) (goto-char beg)))) @@ -1411,7 +1707,7 @@ (defun tpu-backward-to-word (num) "Move backward until encountering the beginning of a word. With argument, do this that many times." - (interactive "_p") + (interactive "p") (while (and (> num 0) (not (bobp))) (let* ((beg (point)) (end (prog2 (beginning-of-line) (point) (goto-char beg)))) @@ -1428,7 +1724,7 @@ (defun tpu-add-word-separators (separators) "Add new word separators for TPU-edt word commands." - (interactive "_sSeparators: ") + (interactive "sSeparators: ") (let* ((n 0) (length (length separators))) (while (< n length) (let ((char (aref separators n)) @@ -1448,13 +1744,13 @@ (defun tpu-reset-word-separators nil "Reset word separators to default value." - (interactive "_") + (interactive) (setq tpu-word-separator-list nil) (setq tpu-skip-chars "^ \t")) (defun tpu-set-word-separators (separators) "Set new word separators for TPU-edt word commands." - (interactive "_sSeparators: ") + (interactive "sSeparators: ") (tpu-reset-word-separators) (tpu-add-word-separators separators)) @@ -1465,46 +1761,46 @@ (defun tpu-next-line (num) "Move to next line. Prefix argument serves as a repeat count." - (interactive "_p") + (interactive "p") (next-line-internal num) (setq this-command 'next-line)) (defun tpu-previous-line (num) "Move to previous line. Prefix argument serves as a repeat count." - (interactive "_p") + (interactive "p") (next-line-internal (- num)) (setq this-command 'previous-line)) (defun tpu-next-beginning-of-line (num) "Move to beginning of line; if at beginning, move to beginning of next line. Accepts a prefix argument for the number of lines to move." - (interactive "_p") + (interactive "p") (backward-char 1) (forward-line (- 1 num))) (defun tpu-end-of-line (num) "Move to the next end of line in the current direction. A repeat count means move that many lines." - (interactive "_p") + (interactive "p") (if tpu-advance (tpu-next-end-of-line num) (tpu-previous-end-of-line num))) (defun tpu-next-end-of-line (num) "Move to end of line; if at end, move to end of next line. Accepts a prefix argument for the number of lines to move." - (interactive "_p") + (interactive "p") (forward-char 1) (end-of-line num)) (defun tpu-previous-end-of-line (num) "Move EOL upward. Accepts a prefix argument for the number of lines to move." - (interactive "_p") + (interactive "p") (end-of-line (- 1 num))) (defun tpu-current-end-of-line nil "Move point to end of current line." - (interactive "_") + (interactive) (let ((beg (point))) (end-of-line) (if (= beg (point)) (message "You are already at the end of a line.")))) @@ -1512,19 +1808,20 @@ (defun tpu-line (num) "Move to the beginning of the next line in the current direction. A repeat count means move that many lines." - (interactive "_p") + (interactive "p") (if tpu-advance (tpu-forward-line num) (tpu-backward-line num))) (defun tpu-forward-line (num) "Move to beginning of next line. Prefix argument serves as a repeat count." - (interactive "_p") + (interactive "p") (forward-line num)) (defun tpu-backward-line (num) "Move to beginning of previous line. Prefix argument serves as repeat count." - (interactive "_p") + (interactive "p") + (or (bolp) (>= 0 num) (setq num (- num 1))) (forward-line (- num))) @@ -1534,14 +1831,14 @@ (defun tpu-paragraph (num) "Move to the next paragraph in the current direction. A repeat count means move that many paragraphs." - (interactive "_p") + (interactive "p") (if tpu-advance (tpu-next-paragraph num) (tpu-previous-paragraph num))) (defun tpu-next-paragraph (num) "Move to beginning of the next paragraph. Accepts a prefix argument for the number of paragraphs." - (interactive "_p") + (interactive "p") (beginning-of-line) (while (and (not (eobp)) (> num 0)) (if (re-search-forward "^[ \t]*$" nil t) @@ -1555,7 +1852,7 @@ (defun tpu-previous-paragraph (num) "Move to beginning of previous paragraph. Accepts a prefix argument for the number of paragraphs." - (interactive "_p") + (interactive "p") (end-of-line) (while (and (not (bobp)) (> num 0)) (if (not (and (re-search-backward "^[ \t]*$" nil t) @@ -1574,7 +1871,7 @@ (defun tpu-page (num) "Move to the next page in the current direction. A repeat count means move that many pages." - (interactive "_p") + (interactive "p") (if tpu-advance (forward-page num) (backward-page num)) (if (eobp) (recenter -1))) @@ -1585,13 +1882,13 @@ (defun tpu-scroll-window (num) "Scroll the display to the next section in the current direction. A repeat count means scroll that many sections." - (interactive "_p") + (interactive "p") (if tpu-advance (tpu-scroll-window-up num) (tpu-scroll-window-down num))) (defun tpu-scroll-window-down (num) "Scroll the display down to the next section. A repeat count means scroll that many sections." - (interactive "_p") + (interactive "p") (let* ((beg (tpu-current-line)) (height (1- (window-height))) (lines (* num (/ (* height tpu-percent-scroll) 100)))) @@ -1601,7 +1898,7 @@ (defun tpu-scroll-window-up (num) "Scroll the display up to the next section. A repeat count means scroll that many sections." - (interactive "_p") + (interactive "p") (let* ((beg (tpu-current-line)) (height (1- (window-height))) (lines (* num (/ (* height tpu-percent-scroll) 100)))) @@ -1611,51 +1908,51 @@ (defun tpu-pan-right (num) "Pan right tpu-pan-columns (16 by default). Accepts a prefix argument for the number of tpu-pan-columns to scroll." - (interactive "_p") + (interactive "p") (scroll-left (* tpu-pan-columns num))) (defun tpu-pan-left (num) "Pan left tpu-pan-columns (16 by default). Accepts a prefix argument for the number of tpu-pan-columns to scroll." - (interactive "_p") + (interactive "p") (scroll-right (* tpu-pan-columns num))) (defun tpu-move-to-beginning nil "Move cursor to the beginning of buffer, but don't set the mark." - (interactive "_") + (interactive) (goto-char (point-min))) (defun tpu-move-to-end nil "Move cursor to the end of buffer, but don't set the mark." - (interactive "_") + (interactive) (goto-char (point-max)) (recenter -1)) (defun tpu-goto-percent (perc) "Move point to ARG percentage of the buffer." - (interactive "_NGoto-percentage: ") + (interactive "NGoto-percentage: ") (if (or (> perc 100) (< perc 0)) (error "Percentage %d out of range 0 < percent < 100" perc) (goto-char (/ (* (point-max) perc) 100)))) (defun tpu-beginning-of-window nil "Move cursor to top of window." - (interactive "_") + (interactive) (move-to-window-line 0)) (defun tpu-end-of-window nil "Move cursor to bottom of window." - (interactive "_") + (interactive) (move-to-window-line -1)) (defun tpu-line-to-bottom-of-window nil "Move the current line to the bottom of the window." - (interactive "_") + (interactive) (recenter -1)) (defun tpu-line-to-top-of-window nil "Move the current line to the top of the window." - (interactive "_") + (interactive) (recenter 0)) @@ -1664,7 +1961,7 @@ ;;; (defun tpu-advance-direction nil "Set TPU Advance mode so keypad commands move forward." - (interactive "_") + (interactive) (setq tpu-direction-string " Advance") (setq tpu-advance t) (setq tpu-reverse nil) @@ -1673,7 +1970,7 @@ (defun tpu-backup-direction nil "Set TPU Backup mode so keypad commands move backward." - (interactive "_") + (interactive) (setq tpu-direction-string " Reverse") (setq tpu-advance nil) (setq tpu-reverse t) @@ -1958,33 +2255,38 @@ (define-key minibuffer-local-map "\eOM" 'exit-minibuffer) (define-key minibuffer-local-ns-map "\eOM" 'exit-minibuffer) (define-key minibuffer-local-completion-map "\eOM" 'exit-minibuffer) -(define-key minibuffer-local-must-match-map "\eOM" -'minibuffer-complete-and-exit) +(define-key minibuffer-local-must-match-map "\eOM" 'minibuffer-complete-and-exit) (and (boundp 'repeat-complex-command-map) (define-key repeat-complex-command-map "\eOM" 'exit-minibuffer)) ;;; -;;; Map control keys +;;; Minibuffer map additions to set search direction ;;; -(define-key global-map "\C-\\" 'quoted-insert) ; ^\ -(define-key global-map "\C-a" 'tpu-toggle-overwrite-mode) ; ^A -(define-key global-map "\C-b" 'repeat-complex-command) ; ^B -(define-key global-map "\C-e" 'tpu-current-end-of-line) ; ^E -(define-key global-map "\C-h" 'tpu-next-beginning-of-line) ; ^H (BS) -(define-key global-map "\C-j" 'tpu-delete-previous-word) ; ^J (LF) -(define-key global-map "\C-k" 'tpu-define-macro-key) ; ^K -(define-key global-map "\C-l" 'tpu-insert-formfeed) ; ^L (FF) -(define-key global-map "\C-r" 'recenter) ; ^R -(define-key global-map "\C-u" 'tpu-delete-to-bol) ; ^U -(define-key global-map "\C-v" 'tpu-quoted-insert) ; ^V -(define-key global-map "\C-w" 'redraw-display) ; ^W -(define-key global-map "\C-z" 'tpu-exit) ; ^Z +(define-key minibuffer-local-map "\eOt" 'tpu-search-forward-exit) +(define-key minibuffer-local-map "\eOu" 'tpu-search-backward-exit) ;;; -;;; Functions to reset and toggle the control key bindings +;;; Functions to set, reset, and toggle the control key bindings ;;; +(defun tpu-set-control-keys nil + "Set control keys to TPU style functions." + (define-key global-map "\C-\\" 'quoted-insert) ; ^\ + (define-key global-map "\C-a" 'tpu-toggle-overwrite-mode) ; ^A + (define-key global-map "\C-b" 'repeat-complex-command) ; ^B + (define-key global-map "\C-e" 'tpu-current-end-of-line) ; ^E + (define-key global-map "\C-h" 'tpu-next-beginning-of-line) ; ^H (BS) + (define-key global-map "\C-j" 'tpu-delete-previous-word) ; ^J (LF) + (define-key global-map "\C-k" 'tpu-define-macro-key) ; ^K + (define-key global-map "\C-l" 'tpu-insert-formfeed) ; ^L (FF) + (define-key global-map "\C-r" 'recenter) ; ^R + (define-key global-map "\C-u" 'tpu-delete-to-bol) ; ^U + (define-key global-map "\C-v" 'tpu-quoted-insert) ; ^V + (define-key global-map "\C-w" 'redraw-display) ; ^W + (define-key global-map "\C-z" 'tpu-exit) ; ^Z + (setq tpu-control-keys t)) + (defun tpu-reset-control-keys (tpu-style) "Set control keys to TPU or emacs style functions." (let* ((tpu (and tpu-style (not tpu-control-keys))) @@ -2013,7 +2315,7 @@ (defun tpu-toggle-control-keys nil "Toggles control key bindings between TPU-edt and Emacs." - (interactive "_") + (interactive) (tpu-reset-control-keys (not tpu-control-keys)) (and (interactive-p) (message "Control keys function with %s bindings." @@ -2025,28 +2327,26 @@ ;;; (defun tpu-next-history-element (n) "Insert the next element of the minibuffer history into the minibuffer." - (interactive "_p") + (interactive "p") (next-history-element n) (goto-char (point-max))) (defun tpu-previous-history-element (n) "Insert the previous element of the minibuffer history into the minibuffer." - (interactive "_p") + (interactive "p") (previous-history-element n) (goto-char (point-max))) (defun tpu-arrow-history nil "Modify minibuffer maps to use arrows for history recall." - (interactive "_") + (interactive) (let ((loc (where-is-internal 'tpu-previous-line)) (cur nil)) (while (setq cur (car loc)) (define-key read-expression-map cur 'tpu-previous-history-element) (define-key minibuffer-local-map cur 'tpu-previous-history-element) (define-key minibuffer-local-ns-map cur 'tpu-previous-history-element) - (define-key minibuffer-local-completion-map cur -'tpu-previous-history-element) - (define-key minibuffer-local-must-match-map cur -'tpu-previous-history-element) + (define-key minibuffer-local-completion-map cur 'tpu-previous-history-element) + (define-key minibuffer-local-must-match-map cur 'tpu-previous-history-element) (setq loc (cdr loc))) (setq loc (where-is-internal 'tpu-next-line)) @@ -2054,10 +2354,8 @@ (define-key read-expression-map cur 'tpu-next-history-element) (define-key minibuffer-local-map cur 'tpu-next-history-element) (define-key minibuffer-local-ns-map cur 'tpu-next-history-element) - (define-key minibuffer-local-completion-map cur -'tpu-next-history-element) - (define-key minibuffer-local-must-match-map cur -'tpu-next-history-element) + (define-key minibuffer-local-completion-map cur 'tpu-next-history-element) + (define-key minibuffer-local-must-match-map cur 'tpu-next-history-element) (setq loc (cdr loc))))) @@ -2067,16 +2365,25 @@ (defun tpu-load-xkeys (file) "Load the TPU-edt X-windows key definitions FILE. If FILE is nil, try to load a default file. The default file names are -~/.tpu-xemacs-keys for XEmacs emacs, and ~/.tpu-gnu-keys for GNU emacs." - (interactive "_fX key definition file: ") +`~/.tpu-lucid-keys' for Lucid emacs, and `~/.tpu-keys' for Emacs." + (interactive "fX key definition file: ") (cond (file (setq file (expand-file-name file))) (tpu-xkeys-file (setq file (expand-file-name tpu-xkeys-file))) - (tpu-gnu-emacs19-p - (setq file (expand-file-name "~/.tpu-gnu-keys"))) - (tpu-xemacs-emacs19-p - (setq file (expand-file-name "~/.tpu-xemacs-keys")))) + (tpu-lucid-emacs19-p + (setq file (convert-standard-filename + (expand-file-name "~/.tpu-lucid-keys")))) + (tpu-emacs19-p + (setq file (convert-standard-filename + (expand-file-name "~/.tpu-keys"))) + (and (not (file-exists-p file)) + (file-exists-p + (convert-standard-filename + (expand-file-name "~/.tpu-gnu-keys"))) + (tpu-copy-keyfile + (convert-standard-filename + (expand-file-name "~/.tpu-gnu-keys")) file)))) (cond ((file-readable-p file) (load-file file)) (t @@ -2109,6 +2416,34 @@ (insert "Nope, I can't seem to find it. :-(\n\n") (sit-for 120))))))) +(defun tpu-copy-keyfile (oldname newname) + "Copy the TPU-edt X key definitions file to the new default name." + (interactive "fOld name: \nFNew name: ") + (if (not (get-buffer "*TPU-Notice*")) (generate-new-buffer "*TPU-Notice*")) + (set-buffer "*TPU-Notice*") + (erase-buffer) + (insert " + NOTICE -- + + The default name of the TPU-edt key definition file has changed + from `~/.tpu-gnu-keys' to `~/.tpu-keys'. With your permission, + your key definitions will be copied to the new file. If you'll + never use older versions of Emacs, you can remove the old file. + If the copy fails, you'll be asked if you want to create a new + key definitions file. Do you want to copy your key definition + file now? + ") + (save-window-excursion + (switch-to-buffer-other-window "*TPU-Notice*") + (shrink-window-if-larger-than-buffer) + (goto-char (point-min)) + (beep) + (and (tpu-y-or-n-p "Copy key definitions to the new file now? ") + (condition-case conditions + (copy-file oldname newname) + (error (message "Sorry, couldn't copy - %s" (cdr conditions))))) + (kill-buffer "*TPU-Notice*"))) + ;;; ;;; Start and Stop TPU-edt @@ -2121,16 +2456,14 @@ ((not tpu-edt-mode) ;; we use picture-mode functions (require 'picture) - (tpu-reset-control-keys t) + (tpu-set-control-keys) (cond (tpu-emacs19-p (and window-system (tpu-load-xkeys nil)) (tpu-arrow-history)) (t ;; define ispell functions - (autoload 'ispell-word "ispell" "Check spelling of word at or before -point" t) - (autoload 'ispell-complete-word "ispell" "Complete word at or before -point" t) + (autoload 'ispell-word "ispell" "Check spelling of word at or before point" t) + (autoload 'ispell-complete-word "ispell" "Complete word at or before point" t) (autoload 'ispell-buffer "ispell" "Check spelling of entire buffer" t) (autoload 'ispell-region "ispell" "Check spelling of region" t))) (tpu-set-mode-line t) @@ -2151,15 +2484,10 @@ (setq-default page-delimiter "^\f") (setq-default truncate-lines nil) (setq scroll-step 0) + (setq global-map (copy-keymap tpu-original-global-map)) (use-global-map global-map) (setq tpu-edt-mode nil)))) - -;;; -;;; Turn on TPU-edt and announce it as a feature -;;; -(tpu-edt-mode) - (provide 'tpu-edt) ;;; tpu-edt.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/tpu-extras.el --- a/lisp/emulators/tpu-extras.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/tpu-extras.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,6 @@ ;;; tpu-extras.el --- Scroll margins and free cursor mode for TPU-edt -;; Copyright (C) 1993 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. ;; Author: Rob Riepel ;; Maintainer: Rob Riepel @@ -20,10 +20,35 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34 ;;; Commentary: +;; Use the functions defined here to customize TPU-edt to your tastes by +;; setting scroll margins and/or turning on free cursor mode. Here's an +;; example for your .emacs file. + +;; (tpu-set-cursor-free) ; Set cursor free. +;; (tpu-set-scroll-margins "10%" "15%") ; Set scroll margins. + +;; Scroll margins and cursor binding can be changed from within emacs using +;; the following commands: + +;; tpu-set-scroll-margins or set scroll margins +;; tpu-set-cursor-bound or set cursor bound +;; tpu-set-cursor-free or set cursor free + +;; Additionally, Gold-F toggles between bound and free cursor modes. + +;; Note that switching out of free cursor mode or exiting TPU-edt while in +;; free cursor mode strips trailing whitespace from every line in the file. + + +;;; Details: + ;; The functions contained in this file implement scroll margins and free ;; cursor mode. The following keys and commands are affected. @@ -67,8 +92,8 @@ ;; performance of TPU-edt on slower computers. In order to support the ;; widest range of computers, scroll margin support is optional. -;; I don't know for a fact that the overhead associated with scroll -;; margin support is significant. If you find that it is, please send me +;; It's actually not known whether the overhead associated with scroll +;; margin support is significant. If you find that it is, please send ;; a note describing the extent of the performance degradation. Be sure ;; to include a description of the platform where you're running TPU-edt. ;; Send your note to the address provided by Gold-V. @@ -77,35 +102,15 @@ ;; important aspects of the real TPU/edt. Those who miss free cursor mode ;; and/or scroll margins will appreciate these implementations. -;;; Usage: - -;; To use this file, simply load it after loading TPU-edt. After that, -;; customize TPU-edt to your tastes by setting scroll margins and/or -;; turning on free cursor mode. Here's an example for your .emacs file. - -;; (load "tpu-edt") ; Load the base TPU-edt -;; (load "tpu-extras") ; and the extras. -;; (tpu-set-scroll-margins "10%" "15%") ; Set scroll margins. - -;; Once the extras are loaded, scroll margins and cursor binding can be -;; changed with the following commands: - -;; tpu-set-scroll-margins or set scroll margins -;; tpu-set-cursor-bound or set cursor bound -;; tpu-set-cursor-free or set cursor free - -;; Additionally, Gold-F toggles between bound and free cursor modes. - -;; Note that switching out of free cursor mode or exiting TPU-edt while in -;; free cursor mode strips trailing whitespace from every line in the file. +;; NOTE: There was a very old tpu-edt in XEmacs 19.14 so I deleted it and +;; replaced it with the one in Emacs 19.34. -sb ;;; Code: -;;; Revision Information +;;; Gotta have tpu-edt -(defconst tpu-extras-revision "!Revision: 1.6 !" - "Revision number of the TPU-edt extras.") +(require 'tpu-edt) ;;; Customization variables @@ -132,11 +137,7 @@ ;;; Hooks -- Set cursor free in picture mode. ;;; Clean up when writing a file from cursor free mode. -(if tpu-gnu-emacs18-p - (or (memq 'tpu-set-cursor-free edit-picture-hook) - (setq edit-picture-hook - (cons 'tpu-set-cursor-free edit-picture-hook))) - (add-hook 'picture-mode-hook 'tpu-set-cursor-free)) +(add-hook 'picture-mode-hook 'tpu-set-cursor-free) (defun tpu-write-file-hook nil "Eliminate whitespace at ends of lines, if the cursor is free." @@ -264,6 +265,7 @@ Prefix argument serves as repeat count." (interactive "p") (let ((beg (tpu-current-line))) + (or (bolp) (>= 0 num) (setq num (- num 1))) (next-line-internal (- num)) (tpu-top-check beg num) (beginning-of-line))) @@ -428,7 +430,7 @@ ;;; Function to set scroll margins -;;;jwz: don't autoload this by default ###autoload +;;;###autoload (defun tpu-set-scroll-margins (top bottom) "Set scroll margins." (interactive @@ -456,7 +458,7 @@ ;;; Functions to set cursor bound or free -;;;jwz: don't autoload this by default ###autoload +;;;###autoload (defun tpu-set-cursor-free nil "Allow the cursor to move freely about the screen." (interactive) @@ -466,7 +468,7 @@ GOLD-map) (message "The cursor will now move freely about the screen.")) -;;;jwz: don't autoload this by default ###autoload +;;;###autoload (defun tpu-set-cursor-bound nil "Constrain the cursor to the flow of the text." (interactive) diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/tpu-mapper.el --- a/lisp/emulators/tpu-mapper.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/tpu-mapper.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,6 @@ -;;; tpu-mapper.el --- Create a TPU-edt keymap file for x-windows emacs. +;;; tpu-mapper.el --- Create a TPU-edt X-windows keymap file -;; Copyright (C) 1993 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. ;; Author: Rob Riepel ;; Maintainer: Rob Riepel @@ -20,7 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34 ;;; Commentary: @@ -31,17 +34,17 @@ ;;; Usage: -;; Simply load this file into the X-windows version of emacs (version 19) -;; using the following command. +;; Simply load this file into the X-windows version of XEmacs using the +;; following command. -;; emacs -q -l tpu-mapper.el +;; xemacs -q -l tpu-mapper ;; The "-q" option prevents loading of your .emacs file (commands therein ;; might confuse this program). ;; An instruction screen showing the TPU-edt keypad will be displayed, and ;; you will be prompted to press the TPU-edt editing keys. Tpu-mapper uses -;; the keys you press to create an emacs lisp file that will define a +;; the keys you press to create an Emacs Lisp file that will define a ;; TPU-edt keypad for your X server. You can even re-arrange the standard ;; EDT keypad to suit your tastes (or to cope with those silly Sun and PC ;; keypads). @@ -49,28 +52,25 @@ ;; Finally, you will be prompted for the name of the file to store the key ;; definitions. If you chose the default, TPU-edt will find it and load it ;; automatically. If you specify a different file name, you will need to -;; set the variable "tpu-xkeys-file" before loading TPU-edt. Here's how +;; set the variable "tpu-xkeys-file" before starting TPU-edt. Here's how ;; you might go about doing that in your .emacs file. ;; (setq tpu-xkeys-file (expand-file-name "~/.my-emacs-x-keys")) -;; (load "tpu-edt") +;; (tpu-edt) ;;; Known Problems: ;; Sometimes, tpu-mapper will ignore a key you press, and just continue to ;; prompt for the same key. This can happen when your window manager sucks -;; up the key and doesn't pass it on to emacs, or it could be an emacs bug. +;; up the key and doesn't pass it on to Emacs, or it could be an Emacs bug. ;; Either way, there's nothing that tpu-mapper can do about it. You must ;; press RETURN, to skip the current key and continue. Later, you and/or ;; your local X guru can try to figure out why the key is being ignored. -;;; Code: +;; NOTE: There was a very old tpu-edt in XEmacs 19.14 so I deleted it and +;; replaced it with the one in Emacs 19.34. -sb -;;; -;;; Revision Information -;;; -(defconst tpu-mapper-revision "!Revision: 1.5 !" - "Revision number of TPU-edt x-windows emacs key mapper.") +;;; Code: ;;; @@ -78,27 +78,21 @@ ;;; (cond ((not (and window-system (not (string-lessp emacs-version "19")))) - (insert " - - Whoa! This isn't going to work... - - You must run tpu-mapper.el under X-windows and Emacs version 19. - - Press any key to exit. ") - (sit-for 600) - (kill-emacs t))) + (error "tpu-mapper requires running in Emacs 19, with an X display"))) ;;; -;;; Decide whether we're running GNU Emacs or XEmacs. +;;; Decide whether we're running Lucid Emacs or Emacs itself. ;;; -(defconst tpu-xemacs-emacs19-p (string-match "XEmacs" emacs-version) - "Non-NIL if we are running XEmacs version 19.") +(defconst tpu-lucid-emacs19-p (string-match "Lucid" emacs-version) + "Non-NIL if we are running Lucid Emacs version 19.") ;;; ;;; Key variables ;;; +(defvar tpu-kp4 nil) +(defvar tpu-kp5 nil) (defvar tpu-key nil) (defvar tpu-enter nil) (defvar tpu-return nil) @@ -110,7 +104,7 @@ ;;; ;;; Make sure the window is big enough to display the instructions ;;; -(if tpu-xemacs-emacs19-p (set-screen-size nil 80 36) +(if tpu-lucid-emacs19-p (set-screen-size (selected-screen) 80 36) (set-frame-size (selected-frame) 80 36)) @@ -138,7 +132,7 @@ (switch-to-buffer "Directions") (insert " This program prompts you to press keys to create a custom keymap file - for use with the x-windows version of emacs and TPU-edt. + for use with the x-windows version of Emacs and TPU-edt. Start by pressing the RETURN key, and continue by pressing the keys specified in the mini-buffer. You can re-arrange the TPU-edt keypad @@ -171,24 +165,25 @@ ") (delete-other-windows) +(goto-char (point-min)) ;;; ;;; Save for future reference ;;; (cond - (tpu-xemacs-emacs19-p + (tpu-lucid-emacs19-p (setq tpu-return-seq (read-key-sequence "Hit carriage-return to continue ")) (setq tpu-return (concat "[" (format "%s" (event-key (aref tpu-return-seq 0))) "]"))) (t (message "Hit carriage-return to continue ") (setq tpu-return-seq (read-event)) - (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")))) + (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")))) ;;; ;;; Key mapping functions ;;; -(defun tpu-xemacs-map-key (ident descrip func gold-func) +(defun tpu-lucid-map-key (ident descrip func gold-func) (interactive) (setq tpu-key-seq (read-key-sequence (format "Press %s%s: " ident descrip))) (setq tpu-key (concat "[" (format "%s" (event-key (aref tpu-key-seq 0))) "]")) @@ -204,7 +199,7 @@ (format "%s" tpu-key))) tpu-key) -(defun tpu-gnu-map-key (ident descrip func gold-func) +(defun tpu-emacs-map-key (ident descrip func gold-func) (interactive) (message "Press %s%s: " ident descrip) (setq tpu-key-seq (read-event)) @@ -221,7 +216,7 @@ (format "%s" tpu-key))) tpu-key) -(fset 'tpu-map-key (if tpu-xemacs-emacs19-p 'tpu-xemacs-map-key 'tpu-gnu-map-key)) +(fset 'tpu-map-key (if tpu-lucid-emacs19-p 'tpu-lucid-map-key 'tpu-emacs-map-key)) (set-buffer "Keys") @@ -275,8 +270,8 @@ (tpu-map-key "KP-1" " - The Word/Change-Case key" "'tpu-word" "'tpu-change-case") (tpu-map-key "KP-2" " - The EOL/Delete-EOL key" "'tpu-end-of-line" "'tpu-delete-to-eol") (tpu-map-key "KP-3" " - The Character/Special-Insert key" "'tpu-char" "'tpu-special-insert") -(tpu-map-key "KP-4" " - The Forward/Bottom key" "'tpu-advance-direction" "'tpu-move-to-end") -(tpu-map-key "KP-5" " - The Reverse/Top key" "'tpu-backup-direction" "'tpu-move-to-beginning") +(setq tpu-kp4 (tpu-map-key "KP-4" " - The Forward/Bottom key" "'tpu-advance-direction" "'tpu-move-to-end")) +(setq tpu-kp5 (tpu-map-key "KP-5" " - The Reverse/Top key" "'tpu-backup-direction" "'tpu-move-to-beginning")) (tpu-map-key "KP-6" " - The Remove/Insert key" "'tpu-cut" "'tpu-paste") (tpu-map-key "KP-7" " - The Page/Do key" "'tpu-page" "'execute-extended-command") (tpu-map-key "KP-8" " - The Section/Fill key" "'tpu-scroll-window" "'tpu-fill") @@ -344,12 +339,22 @@ (insert (format "(define-key minibuffer-local-completion-map %s 'exit-minibuffer)\n" tpu-enter)) (insert (format "(define-key minibuffer-local-must-match-map %s 'minibuffer-complete-and-exit)\n" tpu-enter)))) +(cond + ((not (or (equal tpu-kp4 tpu-return) (equal tpu-kp5 tpu-return))) + (insert " +;; Minibuffer map additions to allow KP-4/5 termination of search strings. +;; +") + + (insert (format "(define-key minibuffer-local-map %s 'tpu-search-forward-exit)\n" tpu-kp4)) + (insert (format "(define-key minibuffer-local-map %s 'tpu-search-backward-exit)\n" tpu-kp5)))) + (insert " ;; Define the tpu-help-enter/return symbols ;; ") -(cond (tpu-xemacs-emacs19-p +(cond (tpu-lucid-emacs19-p (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter-seq)) (insert (format "(setq tpu-help-return \"%s\")\n" tpu-return-seq)) (insert "(setq tpu-help-N \"[#]\")\n") @@ -363,15 +368,33 @@ (set-buffer "Keys") ;;; -;;; Save the key mapping program and blow this pop stand +;;; Save the key mapping program ;;; -(let ((file (if tpu-xemacs-emacs19-p "~/.tpu-xemacs-keys" "~/.tpu-gnu-keys"))) +(let ((file + (convert-standard-filename + (if tpu-lucid-emacs19-p "~/.tpu-lucid-keys" "~/.tpu-keys")))) (set-visited-file-name - (read-file-name (format "Save key mapping to file (default %s): " file) nil file))) + (read-file-name (format "Save key mapping to file (default %s): " file) "" file))) (save-buffer) -(message "That's it! Press any key to exit") -(sit-for 600) -(kill-emacs t) +;;; +;;; Load the newly defined keys and clean up +;;; +(eval-current-buffer) +(kill-buffer (current-buffer)) +(kill-buffer "*scratch*") +(kill-buffer "Gold-Keys") + +;;; +;;; Let them know it worked. +;;; +(switch-to-buffer "Directions") +(erase-buffer) +(insert " + A custom TPU-edt keymap file has been created. + + Press GOLD-k to remove this buffer and continue editing. +") +(goto-char (point-min)) ;;; tpu-mapper.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/emulators/ws-mode.el --- a/lisp/emulators/ws-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/emulators/ws-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,169 +1,35 @@ ;;; ws-mode.el --- WordStar emulation mode for GNU Emacs -;; Author: Juergen Nickelsen -;; Created: 13 Feb 1991 -;; Version: 0.7 - ;; Copyright (C) 1991 Free Software Foundation, Inc. -;; 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 works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; this file, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - +;; Author: Juergen Nickelsen +;; Version: 0.7 +;; Keywords: emulations -;; How to install ws-mode.el: -;; -;; either you -;; put the following line into your default.el (usually -;; /usr/local/emacs/lisp/default.el): -;; (autoload 'wordstar-mode "ws-mode.el" "WordStar emulation mode." t) -;; put ws-mode.el into a directory in your Emacs load-path (usually -;; /usr/local/emacs/local/lisp). -;; -;; or you -;; put ws-mode.el into your directory $HOME/lib/emacs (or something -;; like that) -;; put the following two lines into your file $HOME/.emacs -;; (autoload 'wordstar-mode (expand-file-name "~/lib/emacs/ws-mode.el") -;; "WordStar emulation mode." t) -;; -;; You can then invoke wordstar-mode for a buffer by typing -;; M-x wordstar-mode -;; -;; If you want to use Emacs in wordstar-mode by default, put the -;; following line in addition into your file $HOME/.emacs : -;; (setq default-major-mode 'wordstar-mode) -;; -;; If you want to use Emacs *always* in wordstar-mode, even when the -;; file type would indicate another mode, put the follwoing line in -;; addition into your file $HOME/.emacs : -;; (setq auto-mode-alist nil) -;; -;; Enjoy! +;; This file is part of XEmacs. - - -(defun wordstar-mode () - "Major mode with WordStar-like key bindings. - -BUGS: - - Help menus with WordStar commands (C-j just calls help-for-help) - are not implemented - - Options for search and replace - - Show markers (C-k h) is somewhat strange - - Search and replace (C-q a) is only available in forward direction - -No key bindings beginning with ESC are installed, they will work -Emacs-like. - -The key bindings are: +;; 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. - C-a backward-word - C-b fill-paragraph - C-c scroll-up-line - C-d forward-char - C-e previous-line - C-f forward-word - C-g delete-char - C-h backward-char - C-i indent-for-tab-command - C-j help-for-help - C-k ordstar-C-k-map - C-l ws-repeat-search - C-n open-line - C-p quoted-insert - C-r scroll-down-line - C-s backward-char - C-t kill-word - C-u keyboard-quit - C-v overwrite-mode - C-w scroll-down - C-x next-line - C-y kill-complete-line - C-z scroll-up +;; 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. - C-k 0 ws-set-marker-0 - C-k 1 ws-set-marker-1 - C-k 2 ws-set-marker-2 - C-k 3 ws-set-marker-3 - C-k 4 ws-set-marker-4 - C-k 5 ws-set-marker-5 - C-k 6 ws-set-marker-6 - C-k 7 ws-set-marker-7 - C-k 8 ws-set-marker-8 - C-k 9 ws-set-marker-9 - C-k b ws-begin-block - C-k c ws-copy-block - C-k d save-buffers-kill-emacs - C-k f find-file - C-k h ws-show-markers - C-k i ws-indent-block - C-k k ws-end-block - C-k p ws-print-block - C-k q kill-emacs - C-k r insert-file - C-k s save-some-buffers - C-k t ws-mark-word - C-k u ws-exdent-block - C-k C-u keyboard-quit - C-k v ws-move-block - C-k w ws-write-block - C-k x kill-emacs - C-k y ws-delete-block +;; 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. - C-o c center-line - C-o b switch-to-buffer - C-o j justify-current-line - C-o k kill-buffer - C-o l list-buffers - C-o m auto-fill-mode - C-o r set-fill-column - C-o C-u keyboard-quit - C-o wd delete-other-windows - C-o wh split-window-horizontally - C-o wo other-window - C-o wv split-window-vertically +;;; Synched up with: FSF 19.34 + +;;; Commentary: - C-q 0 ws-find-marker-0 - C-q 1 ws-find-marker-1 - C-q 2 ws-find-marker-2 - C-q 3 ws-find-marker-3 - C-q 4 ws-find-marker-4 - C-q 5 ws-find-marker-5 - C-q 6 ws-find-marker-6 - C-q 7 ws-find-marker-7 - C-q 8 ws-find-marker-8 - C-q 9 ws-find-marker-9 - C-q a ws-query-replace - C-q b ws-to-block-begin - C-q c end-of-buffer - C-q d end-of-line - C-q f ws-search - C-q k ws-to-block-end - C-q l ws-undo - C-q p ws-last-cursorp - C-q r beginning-of-buffer - C-q C-u keyboard-quit - C-q w ws-last-error - C-q y ws-kill-eol - C-q DEL ws-kill-bol -" - (interactive) - (kill-all-local-variables) - (use-local-map wordstar-mode-map) - (setq mode-name "WordStar") - (setq major-mode 'wordstar-mode)) +;; This emulates WordStar, with a major mode. + +;;; Code: (defvar wordstar-mode-map nil "") (defvar wordstar-C-j-map nil "") @@ -258,8 +124,8 @@ ;; wordstar-C-o-map (define-key wordstar-C-o-map " " ()) - (define-key wordstar-C-o-map "c" 'center-line) - (define-key wordstar-C-o-map "\C-c" 'center-line) + (define-key wordstar-C-o-map "c" 'wordstar-center-line) + (define-key wordstar-C-o-map "\C-c" 'wordstar-center-line) (define-key wordstar-C-o-map "b" 'switch-to-buffer) (define-key wordstar-C-o-map "\C-b" 'switch-to-buffer) (define-key wordstar-C-o-map "j" 'justify-current-line) @@ -317,21 +183,133 @@ (define-key wordstar-C-q-map "\C-y" 'ws-kill-eol) (define-key wordstar-C-q-map "\177" 'ws-kill-bol)) +;;;###autoload +(defun wordstar-mode () + "Major mode with WordStar-like key bindings. -(defun center-paragraph () +BUGS: + - Help menus with WordStar commands (C-j just calls help-for-help) + are not implemented + - Options for search and replace + - Show markers (C-k h) is somewhat strange + - Search and replace (C-q a) is only available in forward direction + +No key bindings beginning with ESC are installed, they will work +Emacs-like. + +The key bindings are: + + C-a backward-word + C-b fill-paragraph + C-c scroll-up-line + C-d forward-char + C-e previous-line + C-f forward-word + C-g delete-char + C-h backward-char + C-i indent-for-tab-command + C-j help-for-help + C-k ordstar-C-k-map + C-l ws-repeat-search + C-n open-line + C-p quoted-insert + C-r scroll-down-line + C-s backward-char + C-t kill-word + C-u keyboard-quit + C-v overwrite-mode + C-w scroll-down + C-x next-line + C-y kill-complete-line + C-z scroll-up + + C-k 0 ws-set-marker-0 + C-k 1 ws-set-marker-1 + C-k 2 ws-set-marker-2 + C-k 3 ws-set-marker-3 + C-k 4 ws-set-marker-4 + C-k 5 ws-set-marker-5 + C-k 6 ws-set-marker-6 + C-k 7 ws-set-marker-7 + C-k 8 ws-set-marker-8 + C-k 9 ws-set-marker-9 + C-k b ws-begin-block + C-k c ws-copy-block + C-k d save-buffers-kill-emacs + C-k f find-file + C-k h ws-show-markers + C-k i ws-indent-block + C-k k ws-end-block + C-k p ws-print-block + C-k q kill-emacs + C-k r insert-file + C-k s save-some-buffers + C-k t ws-mark-word + C-k u ws-exdent-block + C-k C-u keyboard-quit + C-k v ws-move-block + C-k w ws-write-block + C-k x kill-emacs + C-k y ws-delete-block + + C-o c wordstar-center-line + C-o b switch-to-buffer + C-o j justify-current-line + C-o k kill-buffer + C-o l list-buffers + C-o m auto-fill-mode + C-o r set-fill-column + C-o C-u keyboard-quit + C-o wd delete-other-windows + C-o wh split-window-horizontally + C-o wo other-window + C-o wv split-window-vertically + + C-q 0 ws-find-marker-0 + C-q 1 ws-find-marker-1 + C-q 2 ws-find-marker-2 + C-q 3 ws-find-marker-3 + C-q 4 ws-find-marker-4 + C-q 5 ws-find-marker-5 + C-q 6 ws-find-marker-6 + C-q 7 ws-find-marker-7 + C-q 8 ws-find-marker-8 + C-q 9 ws-find-marker-9 + C-q a ws-query-replace + C-q b ws-to-block-begin + C-q c end-of-buffer + C-q d end-of-line + C-q f ws-search + C-q k ws-to-block-end + C-q l ws-undo + C-q p ws-last-cursorp + C-q r beginning-of-buffer + C-q C-u keyboard-quit + C-q w ws-last-error + C-q y ws-kill-eol + C-q DEL ws-kill-bol +" + (interactive) + (kill-all-local-variables) + (use-local-map wordstar-mode-map) + (setq mode-name "WordStar") + (setq major-mode 'wordstar-mode)) + + +(defun wordstar-center-paragraph () "Center each line in the paragraph at or after point. -See center-line for more info." +See `wordstar-center-line' for more info." (interactive) (save-excursion (forward-paragraph) (or (bolp) (newline 1)) (let ((end (point))) (backward-paragraph) - (center-region (point) end)))) + (wordstar-center-region (point) end)))) -(defun center-region (from to) +(defun wordstar-center-region (from to) "Center each line starting in the region. -See center-line for more info." +See `wordstar-center-line' for more info." (interactive "r") (if (> from to) (let ((tem to)) @@ -341,10 +319,10 @@ (narrow-to-region from to) (goto-char from) (while (not (eobp)) - (center-line) + (wordstar-center-line) (forward-line 1))))) -(defun center-line () +(defun wordstar-center-line () "Center the line point is on, within the width specified by `fill-column'. This means adjusting the indentation to match the distance between the end of the text and `fill-column'." @@ -496,7 +474,7 @@ (defun ws-indent-block () - "In WordStar mode: Indent block (not yet implemeted)." + "In WordStar mode: Indent block (not yet implemented)." (interactive) (ws-error "Indent block not yet implemented")) @@ -515,10 +493,10 @@ "In WordStar mode: Mark current word as block." (interactive) (save-excursion - (forward-word) + (forward-word 1) (sit-for 1) (ws-end-block) - (backward-word) + (forward-word -1) (sit-for 1) (ws-begin-block))) @@ -531,7 +509,8 @@ "In WordStar mode: Move block to current cursor position." (interactive) (if (and ws-block-begin-marker ws-block-end-marker) - (let () + (let () + ;; XEmacs (kill-region ws-block-begin-marker ws-block-end-marker 'silent) (yank) (save-excursion @@ -724,7 +703,7 @@ (defun ws-kill-bol () "In WordStar mode: Kill to beginning of line -(like WordStar, not like Emacs)." +\(like WordStar, not like Emacs)." (interactive) (let ((p (point))) (beginning-of-line) diff -r 30df88044ec6 -r b82b59fe008d lisp/eterm/term.el --- a/lisp/eterm/term.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/eterm/term.el Mon Aug 13 08:46:56 2007 +0200 @@ -3197,7 +3197,7 @@ (set-window-configuration conf)) (if (eq first ?\ ) (set-window-configuration conf) - (setq unread-command-events (listify-key-sequence key))))))) + (setq unread-command-events (append key nil))))))) ;;; Converting process modes to use term mode ;;; =========================================================================== diff -r 30df88044ec6 -r b82b59fe008d lisp/eterm/tgud.el --- a/lisp/eterm/tgud.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/eterm/tgud.el Mon Aug 13 08:46:56 2007 +0200 @@ -285,7 +285,7 @@ ;; output of GDB up to the next prompt and build the completion list. (defun tgud-gdb-complete-filter (string) (setq string (concat tgud-gdb-complete-string string)) - (while (string-match "\n" string) + (while (string-match "\r?\n" string) (setq tgud-gdb-complete-list (cons (substring string tgud-gdb-complete-break (match-beginning 0)) tgud-gdb-complete-list)) diff -r 30df88044ec6 -r b82b59fe008d lisp/games/NeXTify.el --- a/lisp/games/NeXTify.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/NeXTify.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,3 +1,32 @@ +;;; NeXTify.el --- Character insertion variation + +;; Copyright status unknown + +;; Author: Unknown +;; 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." @@ -25,3 +54,5 @@ (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 30df88044ec6 -r b82b59fe008d lisp/games/blackbox.el --- a/lisp/games/blackbox.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/blackbox.el Mon Aug 13 08:46:56 2007 +0200 @@ -20,52 +20,53 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.28. +;;; 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. +;; 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 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. +;; 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: @@ -235,6 +236,7 @@ (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) @@ -433,5 +435,3 @@ (t (cons (car list) (bb-delete item (cdr list)))))) ;;; blackbox.el ends here - - diff -r 30df88044ec6 -r b82b59fe008d lisp/games/conx.el --- a/lisp/games/conx.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/conx.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,11 +1,34 @@ -;;; -*- Mode:Emacs-Lisp; Blat:Foop -*- +;;; 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. -;;; -(defconst conx-version "1.6, 6-may-94.") -;;; +;;; 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 @@ -46,6 +69,9 @@ ;;; ;;; 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) @@ -53,7 +79,7 @@ (defconst conx-words-vector-fp 0) (defconst conx-last-word nil) - +p (defvar conx-files nil "FYI") (defun conx-init () @@ -777,3 +803,4 @@ conx-words-hashtable) (sort-numeric-fields -1 (point-min) (point-max))) +;;; conx.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/games/cookie1.el --- a/lisp/games/cookie1.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/cookie1.el Mon Aug 13 08:46:56 2007 +0200 @@ -21,9 +21,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.28. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -105,7 +106,7 @@ (if sym (symbol-value sym) (setq sym (intern phrase-file cookie-cache)) - (message startmsg) + (message "%s" startmsg) (save-excursion (let ((buf (generate-new-buffer "*cookie*")) (result nil)) @@ -116,6 +117,7 @@ (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 @@ -124,7 +126,7 @@ (match-beginning 0)) result)))) (kill-buffer buf) - (message endmsg) + (message "%s" endmsg) (set sym (apply 'vector result))))))) (defun read-cookie (prompt phrase-file startmsg endmsg &optional require-match) diff -r 30df88044ec6 -r b82b59fe008d lisp/games/dissociate.el --- a/lisp/games/dissociate.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/dissociate.el Mon Aug 13 08:46:56 2007 +0200 @@ -19,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.28. +;;; Synched up with: FSF 19.34. ;;; Commentary: diff -r 30df88044ec6 -r b82b59fe008d lisp/games/doctor.el --- a/lisp/games/doctor.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/doctor.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,7 @@ ;;; doctor.el --- psychological help for frustrated users. +;;; (uncensored version--see below) -;; Copyright (C) 1985, 1987, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1987, 1994, 1996 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: games @@ -19,9 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.28. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -29,6 +31,17 @@ ;; 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))) @@ -225,7 +238,7 @@ (make-local-variable 'feelings-about) (setq feelings-about '((feelings about) - (aprehensions toward) + (apprehensions toward) (thoughts on) (emotions toward))) (make-local-variable 'random-adjective) @@ -604,7 +617,7 @@ (doctor-put-meaning ibm 'mach) (doctor-put-meaning pc 'mach) (doctor-put-meaning bitching 'foul) -(doctor-put-meaning shit 'foul) +(doctor-put-meaning shit 'foul) ; Censored (doctor-put-meaning bastard 'foul) (doctor-put-meaning damn 'foul) (doctor-put-meaning damned 'foul) @@ -679,7 +692,7 @@ (doctor-put-meaning lonely 'mood) (doctor-put-meaning angry 'mood) (doctor-put-meaning mad 'mood) -(doctor-put-meaning pissed 'mood) +(doctor-put-meaning pissed 'mood) ; censored (doctor-put-meaning jealous 'mood) (doctor-put-meaning afraid 'fear) (doctor-put-meaning terrified 'fear) @@ -693,8 +706,8 @@ (doctor-put-meaning cocks 'sexnoun) (doctor-put-meaning dick 'sexnoun) (doctor-put-meaning dicks 'sexnoun) -(doctor-put-meaning cunt 'sexnoun) -(doctor-put-meaning cunts '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) @@ -752,18 +765,18 @@ (doctor-put-meaning wine 'alcohol) (doctor-put-meaning whiskey 'alcohol) (doctor-put-meaning scotch 'alcohol) -(doctor-put-meaning fuck 'sexverb) -(doctor-put-meaning fucked 'sexverb) +(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) +(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) +(doctor-put-meaning fucks 'sexverb) ; censored (doctor-put-meaning because 'conj) (doctor-put-meaning but 'conj) (doctor-put-meaning however 'conj) @@ -861,7 +874,7 @@ (setq bak sent))) (defun doctor-readin nil - "Read a sentence. Return it as a list of words." + "Read a sentence. Return it as a list of words." (let (sentence) (backward-sentence 1) (while (not (eobp)) @@ -881,11 +894,11 @@ (defun doctor-doc (sent) (cond ((equal sent '(foo)) - (doctor-type '(bar! ($ please)($ continue)))) + (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))) + (go away) (get lost))) (memq (car sent) '(bye halt break quit done exit goodbye bye\, stop pause goodbye\, stop pause))) @@ -1001,8 +1014,8 @@ (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." + "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 \? ")) @@ -1025,9 +1038,9 @@ 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." + "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))) @@ -1077,8 +1090,8 @@ 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 - fucking fucks + 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 @@ -1219,7 +1232,7 @@ (memq x '(all also always amusing any anyway associated awesome bad beautiful best better but certain clear ever every fantastic fun funny - good great gross growdy however if ignorant + 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 @@ -1309,8 +1322,8 @@ (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." + "Replace any element of SENT that is the car of a replacement +element pair in RLIST." (apply 'append (mapcar (function @@ -1331,9 +1344,9 @@ (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 is in global variables `subj', `verb' and `object'." +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 @@ -1347,8 +1360,8 @@ (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 possibly correct result." + "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)))) @@ -1622,7 +1635,7 @@ (defun doctor-strangelove () (interactive) - (insert "Mein fuhrer!!\n") + (insert "Mein fuehrer!!\n") (doctor-read-print)) ;;; doctor.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/games/dunnet.el --- a/lisp/games/dunnet.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/dunnet.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,10 +1,11 @@ ;;; 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 -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. ;; This file is part of XEmacs. @@ -20,9 +21,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.28. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -31,7 +33,7 @@ ;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ;;; The log file should be set for your system, and it must -;;; be writeable by all. +;;; be writable by all. (defvar dun-log-file "/usr/local/dunnet.score" @@ -40,7 +42,8 @@ (if nil (eval-and-compile (setq byte-compile-warnings nil))) -(require 'cl) +(eval-when-compile + (require 'cl)) ;;;; Mode definitions for interactive mode @@ -48,6 +51,8 @@ "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")) @@ -424,19 +429,22 @@ (defun dun-climb (obj) (let (objnum) (setq objnum (dun-objnum-from-args obj)) - (if (and (not (= 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.") - (if (and (= objnum obj-special) - (not (member obj-tree (nth dun-current-room dun-room-silents)))) - (dun-mprincl "There is nothing here to climb.") - (if (and (not (= objnum obj-tree)) (not (= objnum obj-special))) - (dun-mprincl "You can't climb that.") - (dun-mprincl -"You manage to get about two feet up the tree and fall back down. You -notice that the tree is very unsteady.")))))) + (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) @@ -789,7 +797,7 @@ (defun dun-sauna-heat () (if (= dun-sauna-level 0) (dun-mprincl - "The termperature has returned to normal room termperature.")) + "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) @@ -1341,6 +1349,7 @@ (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)) @@ -1919,7 +1928,7 @@ (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) + (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) @@ -2094,7 +2103,7 @@ (floppy . 27) (disk . 27) (boulder . -1) - (tree . -2) (trees . -2) + (tree . -2) (trees . -2) (palm . -2) (bear . -3) (bin . -4) (bins . -4) (cabinet . -5) (computer . -5) (vax . -5) (ibm . -5) @@ -2415,8 +2424,6 @@ 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 scroll-step 2) - (setq dun-room-shorts nil) (dolist (x dun-rooms) (setq dun-room-shorts @@ -2582,7 +2589,7 @@ (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 flakey, but seems to work. +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. @@ -2870,7 +2877,7 @@ (dun-uexit nil)))))))) (defun dun-cd (args) - (let (tcdpath tcdroom path-elemants room-check) + (let (tcdpath tcdroom path-elements room-check) (if (not (car args)) (dun-mprincl "Usage: cd ") (setq tcdpath dun-cdpath) @@ -3329,3 +3336,5 @@ (dun-mprinc "\n") (setq dun-batch-mode t) (dun-batch-loop)) + +;;; dunnet.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/games/flame.el --- a/lisp/games/flame.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/flame.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,3 +1,32 @@ +;;; 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, @@ -10,6 +39,7 @@ ;;; Ian G. Batten, Batten@uk.ac.bham.multics ;;; +;;; Code: (random t) (defvar sentence @@ -308,3 +338,5 @@ (flame2 (if (= (random 2) 0) 2 1)) (sit-for 0) (doctor-ret-or-read 1))) + +;;; flame.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/games/gomoku.el --- a/lisp/games/gomoku.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/gomoku.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,7 +3,7 @@ ;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. ;; Author: Philippe Schnoebelen -;; Adapted-By: ESR +;; Adapted-By: ESR, Daniel.Pfeiffer@Informatik.START.dbp.de ;; Keywords: games ;; This file is part of XEmacs. @@ -20,18 +20,13 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; 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 @@ -76,66 +71,117 @@ ;;; ;;; GOMOKU MODE AND KEYMAP. ;;; +(require 'facemenu) + (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 +(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 cursor motion. + (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" 'backward-char) ; h + (define-key gomoku-mode-map "l" 'forward-char) ; 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 [kp-7] 'gomoku-move-nw) + (define-key gomoku-mode-map [kp-9] 'gomoku-move-ne) + (define-key gomoku-mode-map [kp-1] 'gomoku-move-sw) + (define-key gomoku-mode-map [kp-3] 'gomoku-move-se) + (define-key gomoku-mode-map [kp-4] 'backward-char) + (define-key gomoku-mode-map [kp-6] 'forward-char) + (define-key gomoku-mode-map [kp-2] 'gomoku-move-down) + (define-key gomoku-mode-map [kp-8] 'gomoku-move-up) + + (define-key gomoku-mode-map "\C-n" 'gomoku-move-down) ; C-n + (define-key gomoku-mode-map "\C-p" 'gomoku-move-up) ; C-p ;; 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 " " 'gomoku-human-plays) ; SPC (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 "\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 [kp-enter] 'gomoku-human-plays) + (define-key gomoku-mode-map [insert] 'gomoku-human-plays) + (define-key gomoku-mode-map [down-mouse-1] 'gomoku-click) + (define-key gomoku-mode-map [drag-mouse-1] 'gomoku-click) + (define-key gomoku-mode-map [mouse-1] 'gomoku-click) + (define-key gomoku-mode-map [down-mouse-2] 'gomoku-click) + (define-key gomoku-mode-map [mouse-2] 'gomoku-mouse-play) + (define-key gomoku-mode-map [drag-mouse-2] 'gomoku-mouse-play) - (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)) + (substitute-key-definition 'previous-line 'gomoku-move-up + gomoku-mode-map (current-global-map)) + (substitute-key-definition 'next-line 'gomoku-move-down + gomoku-mode-map (current-global-map)) + (substitute-key-definition 'beginning-of-line 'gomoku-beginning-of-line + gomoku-mode-map (current-global-map)) + (substitute-key-definition 'end-of-line 'gomoku-end-of-line + gomoku-mode-map (current-global-map)) + (substitute-key-definition 'undo 'gomoku-human-takes-back + gomoku-mode-map (current-global-map)) + (substitute-key-definition 'advertised-undo 'gomoku-human-takes-back + gomoku-mode-map (current-global-map))) + +(defvar gomoku-emacs-won () + "*For making font-lock use the winner's face for the line.") +(defvar gomoku-font-lock-O-face + (if window-system + (list (facemenu-get-face 'fg:red) 'bold)) + "*Face to use for Emacs' O.") + +(defvar gomoku-font-lock-X-face + (if window-system + (list (facemenu-get-face 'fg:green) 'bold)) + "*Face to use for your X.") + +(defvar gomoku-font-lock-keywords + '(("O" . gomoku-font-lock-O-face) + ("X" . gomoku-font-lock-X-face) + ("[-|/\\]" 0 (if gomoku-emacs-won + gomoku-font-lock-O-face + gomoku-font-lock-X-face))) + "*Font lock rules for Gomoku.") + +(put 'gomoku-mode 'front-sticky + (put 'gomoku-mode 'rear-nonsticky '(intangible))) +(put 'gomoku-mode 'intangible 1) (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 +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." +is non-nil. One interesting value is `turn-on-font-lock'." (interactive) (setq major-mode 'gomoku-mode mode-name "Gomoku") (gomoku-display-statistics) (use-local-map gomoku-mode-map) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(gomoku-font-lock-keywords t)) + (toggle-read-only t) (run-hooks 'gomoku-mode-hook)) ;;; @@ -269,8 +315,8 @@ ;; 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 +;; As we chose values 0, 1 and 6 to denote empty, X and O squares, the +;; contents of a qtuple are uniquely determined by the sum of its elements and ;; we just have to set up a translation table. (defconst gomoku-score-trans-table @@ -533,7 +579,8 @@ gomoku-board-height m gomoku-vector-length (1+ (* (+ m 2) (1+ n))) gomoku-draw-limit (/ (* 7 n m) 10)) - (setq gomoku-game-history nil + (setq gomuku emacs-won nil + gomoku-game-history nil gomoku-number-of-moves 0 gomoku-number-of-human-moves 0 gomoku-emacs-played-first nil @@ -594,66 +641,58 @@ (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))) + (message + (cond + ((eq result 'emacs-won) + (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) + (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...") + ("I won."))) + ((eq result 'human-won) + (setq gomoku-number-of-human-wins (1+ gomoku-number-of-human-wins)) + (concat "OK, you won this one." + (cond + (gomoku-human-took-back + " I, for one, never take my moves back...") + (gomoku-emacs-played-first + ".. so what ?") + (" Now, let me play first just once.")))) + ((eq result 'human-resigned) + (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) + "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)) + (concat "This is a draw. " + (cond + (gomoku-human-took-back + "I, for one, never take my moves back...") + (gomoku-emacs-played-first + "Just chance, I guess.") + ("Now, let me play first just once.")))) + ((eq result 'draw-agreed) + (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) + (concat "Draw agreed. " + (cond + (gomoku-human-took-back + "I, for one, never take my moves back...") + (gomoku-emacs-played-first + "You were lucky.") + ("Now, let me play first just once.")))) + ((eq result 'crash-game) + "Sorry, I have been interrupted and cannot resume that game..."))) + (gomoku-display-statistics) + ;;(ding) + (setq gomoku-game-in-progress nil)) (defun gomoku-crash-game () "What to do when Emacs detects it has been interrupted." @@ -671,19 +710,24 @@ "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. +If prefix arg is given for N, M is prompted for. -You and Emacs play in turn by marking a free square. You mark it with X +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) + (interactive (if current-prefix-arg + (list (prefix-numeric-value current-prefix-arg) + (eval (read-minibuffer "Height: "))))) (gomoku-switch-to-window) (cond (gomoku-emacs-is-computing (gomoku-crash-game)) - ((not gomoku-game-in-progress) + ((or (not gomoku-game-in-progress) + (<= gomoku-number-of-moves 2)) (let ((max-width (gomoku-max-width)) (max-height (gomoku-max-height))) (or n (setq n max-width)) @@ -695,8 +739,8 @@ ((> 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 (eq m gomoku-saved-board-height)) + ;; Use EQ 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...") @@ -728,8 +772,8 @@ (setq score (aref gomoku-score-table square)) (gomoku-play-move square 6) (cond ((>= score gomoku-winning-threshold) + (setq gomoku-emacs-won t) ; for font-lock (gomoku-find-filled-qtuple square 6) - (gomoku-cross-winning-qtuple) (gomoku-terminate-game 'emacs-won)) ((zerop score) (gomoku-terminate-game 'nobody-won)) @@ -740,11 +784,43 @@ (t (gomoku-prompt-for-move))))))))) +;; For small square dimensions this is approximate, since though measured in +;; pixels, event's (X . Y) is a character's top-left corner. (defun gomoku-click (click) + "Position at the square where you click." + (interactive "e") + (and (windowp (posn-window (setq click (event-end click)))) + (numberp (posn-point click)) + (select-window (posn-window click)) + (setq click (posn-col-row click)) + (gomoku-goto-xy + (min (max (/ (+ (- (car click) + gomoku-x-offset + 1) + (window-hscroll) + gomoku-square-width + (% gomoku-square-width 2) + (/ gomoku-square-width 2)) + gomoku-square-width) + 1) + gomoku-board-width) + (min (max (/ (+ (- (cdr click) + gomoku-y-offset + 1) + (let ((inhibit-point-motion-hooks t)) + (count-lines 1 (window-start))) + gomoku-square-height + (% gomoku-square-height 2) + (/ gomoku-square-height 2)) + gomoku-square-height) + 1) + gomoku-board-height)))) + +(defun gomoku-mouse-play (click) "Play at the square where you click." (interactive "e") - (mouse-set-point click) - (gomoku-human-plays)) + (if (gomoku-click click) + (gomoku-human-plays))) (defun gomoku-human-plays () "Signal to the Gomoku program that you have played. @@ -772,7 +848,6 @@ ;; 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))))))))) @@ -834,13 +909,12 @@ "Ask for another game, and start it." (if (y-or-n-p "Another game ") (gomoku gomoku-board-width gomoku-board-height) - (message "Chicken !"))) + (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))) + (not (setq gomoku-human-refused-draw t)))) ;;; ;;; DISPLAYING THE BOARD. @@ -875,30 +949,18 @@ ;; 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))) + "Return the board row where point is." + (let ((inhibit-point-motion-hooks t)) + (1+ (/ (- (count-lines 1 (point)) gomoku-y-offset (if (bolp) 0 1)) + gomoku-square-height)))) (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)))) + "Return the index of the square point is on." + (let ((inhibit-point-motion-hooks t)) + (gomoku-xy-to-index (1+ (/ (- (current-column) gomoku-x-offset) + gomoku-square-width)) + (gomoku-point-y)))) (defun gomoku-goto-square (index) "Move point to square number INDEX." @@ -906,70 +968,89 @@ (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)))) + (let ((inhibit-point-motion-hooks t)) + (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) + "Draw 'X', 'O' or '.' on SQUARE depending on VALUE, leave point there." + (or (= value 1) + (gomoku-goto-square square)) + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (insert-and-inherit (cond ((= value 1) ?X) + ((= value 6) ?O) + (?.))) + (and window-system + (zerop value) + (put-text-property (1- (point)) (point) 'mouse-face 'highlight)) (delete-char 1) - (backward-char 1))) + (backward-char 1)) + (sit-for 0)) ; Display NOW (defun gomoku-init-display (n m) "Display an N by M Gomoku board." (buffer-disable-undo (current-buffer)) - (let ((inhibit-read-only t)) + (let ((inhibit-read-only t) + (point 1) opoint + (intangible t) + (i m) j x) + ;; Try to minimize number of chars (because of text properties) + (setq tab-width + (if (zerop (% gomoku-x-offset gomoku-square-width)) + gomoku-square-width + (max (/ (+ (% gomoku-x-offset gomoku-square-width) + gomoku-square-width 1) 2) 2))) (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 + (newline gomoku-y-offset) + (while (progn + (setq j n + x (- gomoku-x-offset gomoku-square-width)) + (while (>= (setq j (1- j)) 0) + (insert-char ?\t (/ (- (setq x (+ x gomoku-square-width)) + (current-column)) + tab-width)) + (insert-char ? (- x (current-column))) + (if (setq intangible (not intangible)) + (put-text-property point (point) 'intangible 2)) + (and (zerop j) + (= i (- m 2)) + (progn + (while (>= i 3) + (append-to-buffer (current-buffer) opoint (point)) + (setq i (- i 2))) + (goto-char (point-max)))) + (setq point (point)) + (insert ?.) + (if window-system + (put-text-property point (point) + 'mouse-face 'highlight))) + (> (setq i (1- i)) 0)) + (if (= i (1- m)) + (setq opoint point)) + (insert-char ?\n gomoku-square-height)) + (or (eq (char-after 1) ?.) + (put-text-property 1 2 'point-entered + (lambda (x x) (if (bobp) (forward-char))))) + (or intangible + (put-text-property point (point) 'intangible 2)) + (put-text-property point (point) 'point-entered + (lambda (x x) (if (eobp) (backward-char)))) + (put-text-property (point-min) (point) 'category 'gomoku-mode)) + (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)))) + (format ": Won %d, lost %d%s" + gomoku-number-of-human-wins + gomoku-number-of-emacs-wins + (if (zerop gomoku-number-of-draws) + "" + (format ", drew %d" gomoku-number-of-draws)))) (force-mode-line-update)) (defun gomoku-switch-to-window () @@ -977,11 +1058,11 @@ (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)))) + (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. @@ -992,19 +1073,6 @@ ;; 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) @@ -1014,121 +1082,105 @@ (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) + (depl (gomoku-xy-to-index dx dy))) (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 + (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) + (cond ((= b (+ a 4)) ; tuple length = 5 ? + (gomoku-cross-qtuple (+ square (* a depl)) (+ square (* b depl)) + dx 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))) + (let ((depl (gomoku-xy-to-index dx dy)) + (inhibit-read-only t) + (inhibit-point-motion-hooks t)) ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1 - (while (not (= square1 square2)) + (while (/= 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)) + ((= dy 0) ; Horizontal + (forward-char 1) + (insert-char ?- (1- gomoku-square-width) t) + (delete-region (point) (progn + (skip-chars-forward " \t") + (point)))) + ((= dx 0) ; Vertical + (let ((n 1) + (column (current-column))) (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 ?\\)))))) + (forward-line 1) + (indent-to column) + (insert-and-inherit ?|)))) + ((= dx -1) ; 1st Diagonal + (indent-to (prog1 (- (current-column) (/ gomoku-square-width 2)) + (forward-line (/ gomoku-square-height 2)))) + (insert-and-inherit ?/)) + (t ; 2nd Diagonal + (indent-to (prog1 (+ (current-column) (/ gomoku-square-width 2)) + (forward-line (/ gomoku-square-height 2)))) + (insert-and-inherit ?\\)))))) (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))))) - +;; previous-line and next-line don't work right with intangible newlines (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))))) + (if (< (gomoku-point-y) gomoku-board-height) + (next-line gomoku-square-height))) (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))))) + (if (> (gomoku-point-y) 1) + (previous-line gomoku-square-height))) (defun gomoku-move-ne () "Move point North East on the Gomoku board." (interactive) (gomoku-move-up) - (gomoku-move-right)) + (forward-char)) (defun gomoku-move-se () "Move point South East on the Gomoku board." (interactive) (gomoku-move-down) - (gomoku-move-right)) + (forward-char)) (defun gomoku-move-nw () "Move point North West on the Gomoku board." (interactive) (gomoku-move-up) - (gomoku-move-left)) + (backward-char)) (defun gomoku-move-sw () "Move point South West on the Gomoku board." (interactive) (gomoku-move-down) - (gomoku-move-left)) + (backward-char)) + +(defun gomoku-beginning-of-line () + "Move point to first square on the Gomoku board row." + (interactive) + (move-to-column gomoku-x-offset)) + +(defun gomoku-end-of-line () + "Move point to last square on the Gomoku board row." + (interactive) + (move-to-column (+ gomoku-x-offset + (* gomoku-square-width (1- gomoku-board-width))))) (provide 'gomoku) diff -r 30df88044ec6 -r b82b59fe008d lisp/games/hanoi.el --- a/lisp/games/hanoi.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/hanoi.el Mon Aug 13 08:46:56 2007 +0200 @@ -8,7 +8,24 @@ ; This is in the public domain ; since he distributed it without copyright notice in 1985. -;;; Synched up with: FSF 19.30. +;; 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: @@ -57,57 +74,41 @@ "Towers of Hanoi diversion. Argument is number of rings." (interactive (list (if (null current-prefix-arg) - 3 - (prefix-numeric-value 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 (window-height (selected-window))) + (window-height (1- (window-height (selected-window)))) (window-width (window-width (selected-window))) - ;; This is the unit of spacing to use between poles. It - ;; must be even. We round down, since rounding up might - ;; cause us to draw off the edge of the window. - (pole-spacing (logand (/ window-width 6) (lognot 1)))) - (let ( - ;; The poles are (1+ NRINGS) rows high; we also want an - ;; empty row at the top for the flying rings, a base, and a - ;; blank line underneath that. - (h (+ nrings 4)) - - ;; If we have NRINGS rings, we label them with the numbers 0 - ;; through NRINGS-1. The width of ring i is 2i+3; it pokes - ;; out i spaces on either side of the pole. Rather than - ;; checking if the window is wide enough to accommodate this, - ;; we make sure pole-spacing is large enough, since that - ;; works even when we have decremented pole-spacing to make - ;; it even. - (w (1+ nrings))) - (if (not (and (>= window-height h) - (> pole-spacing w))) - (progn - (delete-other-windows) - (if (not (and (>= (setq window-height - (window-height (selected-window))) - h) - (> (setq pole-spacing - (logand (/ window-width 6) (lognot 1))) - w))) - (error "Screen is too small (need at least %dx%d)" w h)))) - (setq floor-row (if (> (- window-height 3) h) - (- window-height 3) window-height))) + ;; 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 pole-spacing floor-row)) - (pole-2 (cons (* 3 pole-spacing) floor-row)) - (pole-3 (cons (* 5 pole-spacing) floor-row)) + (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)) + (make-string (+ i i 3) (+ ?0 (% i 10))) (make-string (+ i i 3) ?\ ))) (setq i (1+ i)))) ;; @@ -126,7 +127,7 @@ (let ((n 1)) (while (< n 6) - (hanoi-topos fly-row (* n pole-spacing)) + (hanoi-topos fly-row (1- (* n pole-spacing))) (setq n (+ n 2)) (let ((i fly-row)) (while (< i floor-row) @@ -151,10 +152,11 @@ (setq i (1+ i)))) (setq buffer-read-only t) (sit-for 0) - ;; - ;; do it! - ;; - (hanoi0 (1- nrings) pole-1 pole-2 pole-3) + ;; 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) diff -r 30df88044ec6 -r b82b59fe008d lisp/games/life.el --- a/lisp/games/life.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/life.el Mon Aug 13 08:46:56 2007 +0200 @@ -2,7 +2,7 @@ ;; Copyright (C) 1988 Free Software Foundation, Inc. -;; Author: Kyle Jones +;; Author: Kyle Jones ;; Keywords: games ;; This file is part of XEmacs. @@ -19,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: diff -r 30df88044ec6 -r b82b59fe008d lisp/games/mpuz.el --- a/lisp/games/mpuz.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/mpuz.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,6 @@ ;;; mpuz.el --- multiplication puzzle for XEmacs -;;; Copyright (C) 1990 Free Software Foundation, Inc. +;; Copyright (C) 1990 Free Software Foundation, Inc. ;; Author: Philippe Schnoebelen ;; Keywords: games @@ -19,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -187,7 +188,7 @@ 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 respectives squares. + ;; 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)) diff -r 30df88044ec6 -r b82b59fe008d lisp/games/spook.el --- a/lisp/games/spook.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/spook.el Mon Aug 13 08:46:56 2007 +0200 @@ -22,20 +22,19 @@ ;; 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. +;;; 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. -; May 1987 - -; 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. +;; 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: diff -r 30df88044ec6 -r b82b59fe008d lisp/games/studly.el --- a/lisp/games/studly.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/studly.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,10 +1,29 @@ ;;; 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. +;; 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 diff -r 30df88044ec6 -r b82b59fe008d lisp/games/yow.el --- a/lisp/games/yow.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/games/yow.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,6 @@ ;;; yow.el --- quote random zippyisms -;; Copyright (C) 1985, 1993, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Author: Richard Mlynarik @@ -22,7 +22,7 @@ ;; 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. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -37,15 +37,16 @@ (require 'cookie1) (defvar yow-file (concat data-directory "yow.lines") - "File containing Pertinent Pinhead Phrases.") + "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 - "Am I CONSING yet?..." "I have SEEN the CONSING!!"))) + (let ((yow (cookie yow-file yow-load-message yow-after-load-message))) (cond (insert (insert yow)) ((not (interactive-p)) @@ -64,30 +65,63 @@ (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 - "Am I CONSING yet?..." "I have SEEN the CONSING!!" + (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 +;; 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 nil) + (message "") (switch-to-buffer "*doctor*") (sit-for 0) (while (not (input-pending-p)) - (insert (yow)) + (insert-string (yow)) (sit-for 0) (doctor-ret-or-read 1) (doctor-ret-or-read 1))) diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ACKNOWLEDGMENTS --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/ACKNOWLEDGMENTS Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,14 @@ +Thanks to Guido Bosch, David Braunegg, Tim Bradshaw, Thomas M. Breuel, +Hans Chalupsky, Kimball Collins, Brian Dennis, David Duff, Tom +Emerson, Michael Ernst, Scott Fahlman, David Gadbois, Robert +P. Goldman, Marty Hall, Richard Harris, Jim Healy, Christopher Hoover, +Larry Hunter, Ben Hyde, Chuck Irvine, Michael Kashket, Mark +Kantrowitz, Qiegang Long, Erik Naggum, Dan Pierson, Yusuf Pisan, Frank +Ritter, Jeffrey Mark Siskind, Neil Smithline, Richard Stallman, Larry +Stead, Jason Trenouth, Christof Ullwer, Bjorn Victor, Fred White, Ben +Wing, Matsuo Yoshihiro, Jamie Zawinski, Paul Fuqua (for the CMU-CL GC +display code) and Marco Antoniotti for bug reports, suggestions and +code. Our apologies to anyone we may have forgotten. + +Special thanks to Todd Kaufmann for the texinfo file, work on bridge, +epoch-pop and for really exercising everything. diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/COPYING --- a/lisp/ilisp/COPYING Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/COPYING Mon Aug 13 08:46:56 2007 +0200 @@ -2,18 +2,19 @@ ------------------------------------------------------------------------------- This file is part of ILISP. -Version: 5.7 -Date: January 4th, 1995 +Version: 5.8 +Date: 15 July 1996 Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell 1993, 1994 Ivan Vasquez - 1994, 1995 Marco Antoniotti and Rick Busdiecker + 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker + 1996 Marco Antoniotti and Rick Campbell Other authors' names for which this Copyright notice also holds may appear later in this file. -Send mail to 'ilisp-request@lehman.com' to be included in the -ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +Send mail to 'ilisp-request@naggum.no' to be included in the +ILISP mailing list. 'ilisp@naggum.no' is the general ILISP mailing list were bugs and improvements are discussed. ------------------------------------------------------------------------------- diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/GETTING-ILISP --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/GETTING-ILISP Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,59 @@ +FTP directions +============== + +You can get the distribution file, `ilisp-5.8.tar.gz' via anonymous +FTP from `FTP.CS.CMU.EDU' (128.2.206.173) in +`/afs/cs/user/campbell/http/ilisp/'. + +% ftp ftp.cs.cmu.edu +Name (ftp.cs.cmu.edu:rickc): anonymous +331 Guest login ok, send username@node as password. +Password: YOUR-USER-ID@YOUR-HOSTNAME +ftp> cd /afs/cs/user/campbell/http/ilisp +250 Directory path set to /afs/cs/user/campbell/http/ilisp. +ftp> type binary +200 Type set to I. +ftp> get ilisp-5.8.tar.gz +200 PORT command successful. +150 Opening data connection for ilisp-5.8.tar.gz. +226 Transfer complete. +local: ilisp-5.8.tar.gz remote: ilisp-5.8.tar.gz +168801 bytes received. +ftp> quit +221 Goodbye. + +Or get whatever single files you need from the `untarred' +subdirectory. + +You can also get `ilisp-5.8.tar.gz' via anonymous FTP from +`FTP.ICSI.BERKELEY.EDU' in either `/pub/software/elisp/' or +`/pub/theory/marcoxa/elisp/'. + + + + +WWW directions +============== + +You can use the World Wide Web (WWW) to get the distribution file from +the anonymous FTP locations using one of the following URLs: + * ftp://ftp.cs.cmu.edu/afs/cs/user/campbell/http/ilisp/ilisp-5.8.tar.gz + + * ftp://ftp.icsi.berkeley.edu/pub/software/elisp/ilisp-5.8.tar.gz + + * ftp://ftp.icsi.berkeley.edu/pub/theory/marcoxa/ilisp-5.8.tar.gz + + You can also use the CMU Artificial Intelligence Repository: + + http://www.cs.cmu.edu/Web/Groups/AI/html/repository.html + +From there follow: `LISP', `UTIL', `EMACS' and finally `ILISP'. Use +your browser capabilities to download what you need. + +The complete URL for the distribution file in the CMU AI Repository is +http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/util/emacs/ilisp/v57/ilisp57.tgz + +Other URLs for the distribution file include: + * http://www.c2.net/~campbell/ilisp/ilisp-5.8.tar.gz + + * http://www.cs.cmu.edu/~campbell/ilisp/ilisp-5.8.tar.gz diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/HISTORY --- a/lisp/ilisp/HISTORY Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/HISTORY Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,53 @@ +# -*- Mode: Text -*- + ILISP HISTORY =============================================================================== +Version 5.8 alpha + +Fixes and enhancements since 5.7 + +-- XLISP and XLISPSTAT support has been added on an experimental way. + Please give us feedback on their behavior. + +-- There is now a way to disable the DEFPACKAGE feature for GCL. But + it is not turned on. You have to fix it manually by transforming two + '#+(and nil gcl)' into '#+(and t gcl)' + +-- A few fixes were made to realign ILISP to Xemacs 19.14 + +-- The file 'clisp.lisp' has been renamed to 'cl-ilisp.lisp', in order + to avoid confusion with the CLISP implementation of Common Lisp. + +-- The file ILISP.prj (if present) can be safely ignored unless you + want to use the PRCS project control system + (http://http.cs.berkeley.edu/~jmacd/prcs-home.html) + +-- Changed 'comint-ipc' and 'bridge'. They now use + 'process-send-string' instead of defining specialized versions of + it. (This was done because it appears that the newer versions of + 'comint' have a 'process-send-string' that does what these specialized + versions used to do.) + +-- Added constant '+ilisp-emacs-minor-version-number+' (in 'ilcompat'). + +-- Conditionalized loading of 'bridge.el' (in 'ilisp'). + +-- Fixed the annoying ECL/GCL glitch in 'ilisp-kcl' and the error + regexps for KCL and IBCL in the same file + +-- Patched 'comint-ipc' according to suggestion by Kazuhiro Fujieda. + +-- Patched 'ilisp-out' according to suggestion by Kazuhiro Fujieda. + + +Known Bugs + +-- Allegro multiprocessing output handling is still broken. This is a + though one and the maintaners cannot fix it. + +------------------------------------------------------------------------------- + Version 5.7 Fixes and enhancements since 5.6: diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/INSTALLATION --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/INSTALLATION Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,73 @@ +-*- Mode: Text -*- + +WELCOME TO ILISP. + +FIRST INSTALLATION STEP: UNPACKING AND COMPILING. + +SECOND INSTALLATION STEP: DIALECT REQUIREMENTS. + +ILISP assumes a minimum of CLtL2 compliance. This requirements +immediately clashes with the problems of some KCL-derivativs, +including GCL. Here is a list of known problems for several CL +implementations (we do not know whether there are problems with +Scheme's - please let us know). + +o All dialects + + Be sure that the variables: + + ilisp-binary-extension + ilisp-init-binary-extension + ilisp-binary-command + + Have the appropriate value. Older versions of ILISP (< 5.8) + assumed a single CL installation and suggested a change to the + hook 'ilisp-site-hook' in the 'ilisp.emacs' file. + + This should not be so anymore. + + +o KCL, AKCL, Ibuki, GCL, and ECL + + - DEFPACKAGE + You need to have your system configured with a + DEFPACKAGE. You can either generate an image which contains + it or you can arrange the init file to load it for you. + + You can find a DEFPACKAGE in the AI.Repository of CMU. + + - LOOP + Most likely the DEFPACKAGE will require a full fledged LOOP. + The same instructions apply. + + +o CMUCL + + Try to set the variables: + + cmulisp-source-directory-regexp + cmulisp-local-source-directory + + To sensible values. + + +o Harlequin + + No known extra installation glitches + + +o Lucid + + No known extra installation glitches + + +o Allegro + + No known extra installation glitches + + +o CLISP + + No known extra installation glitches + + diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/Makefile --- a/lisp/ilisp/Makefile Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/Makefile Mon Aug 13 08:46:56 2007 +0200 @@ -2,56 +2,65 @@ # Makefile -- # This file is part of ILISP. -# Version: 5.7 +# Version: 5.8 # # Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell # 1993, 1994 Ivan Vasquez -# 1994, 1995 Marco Antoniotti and Rick Busdiecker +# 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +# 1996 Marco Antoniotti and Rick Campbell # -# Send mail to 'ilisp-request@lehman.com' to be included in the +# Send mail to 'ilisp-request@naggum.no' to be included in the # ILISP mailing list. -#------------------------------------------------------------------------------ +# Note: this makefile assumes GNU make + +#============================================================================== # Various Variables -#EMACS=xemacs -EMACS=emacs +Version = 5.8 -OtherFiles=README HISTORY Makefile ilisp.emacs +# Use whichever you like most +#EMACS = xemacs +#EMACS = /usr/local/bin/emacs +EMACS = emacs + +# The SHELL variable is used only for making the distribution. +SHELL = /bin/csh -DocFiles=ilisp.texi ilisp.ps.gz ilisp.info ilisp.info-1 ilisp.info-2 +# These are used mostly for packaging the distribution +Ilisp_src_dir = $(shell pwd) +Ilisp_tar_dir = ilisp-$(Version) -Version=5.7 +OtherFiles = README \ + HISTORY \ + Makefile \ + ilisp.emacs \ + INSTALLATION \ + COPYING \ + GETTING-ILISP \ + Welcome -LoadFiles=ilisp-def.elc ilisp-el.elc ilisp-sym.elc \ +DocFiles = ilisp.texi + +LoadFiles = ilisp-def.elc ilisp-el.elc ilisp-sym.elc \ ilisp-inp.elc ilisp-ind.elc ilisp-prc.elc ilisp-val.elc ilisp-out.elc \ ilisp-mov.elc ilisp-key.elc ilisp-prn.elc ilisp-low.elc ilisp-doc.elc \ ilisp-ext.elc ilisp-mod.elc ilisp-dia.elc ilisp-cmt.elc ilisp-rng.elc \ ilisp-hnd.elc ilisp-utl.elc ilisp-cmp.elc ilisp-kil.elc ilisp-snd.elc \ ilisp-xfr.elc ilisp-hi.elc ilisp-aut.elc ilisp-cl.elc ilisp-cmu.elc \ - ilisp-acl.elc ilisp-kcl.elc ilisp-luc.elc ilisp-sch.elc ilisp-hlw.elc + ilisp-acl.elc ilisp-kcl.elc ilisp-luc.elc ilisp-sch.elc ilisp-hlw.elc \ + ilisp-xls.elc -#------------------------------------------------------------------------------ +#============================================================================== # Rules compile: $(EMACS) -batch -l ilisp-mak.el -id: - mkid -S.el=lisp *.el - tags: etags *.el -dist: tarring compressing - -tarring: - tar cvf ilisp-$(Version).tar $(OtherFiles) *.el *.lisp *.lcd $(DocFiles) *.mail - -compressing: - gzip ilisp-$(Version).tar - clean: $(RM) *.elc @@ -61,4 +70,31 @@ rm $(LoadFiles) # Note that the redirection is done by a Bourne Shell. +compress: + gzip *.el $(OtherFiles) $(DocFiles) + +#============================================================================== +# The following targets are used only to create a distribution file. + +dist: tarring dist_compressing + +tarring: + (cd $(Ilisp_src_dir)/..; \ + if ( $(notdir $(Ilisp_src_dir)) != $(Ilisp_tar_dir) ) \ + ln -s $(notdir $(Ilisp_src_dir)) $(Ilisp_tar_dir) ; \ + tar cvf $(Ilisp_tar_dir).tar \ + $(patsubst %,$(Ilisp_tar_dir)/%,$(OtherFiles)) \ + $(Ilisp_tar_dir)/*.el \ + $(Ilisp_tar_dir)/*.lisp \ + $(patsubst %,$(Ilisp_tar_dir)/%,$(DocFiles)) \ + $(Ilisp_tar_dir)/*.mail) + +dist_compressing: + (cd $(Ilisp_src_dir)/.. ; gzip $(Ilisp_tar_dir).tar) + +uuencoding: ../$(Ilisp_tar_dir).tar.gz + (cd $(Ilisp_src_dir)/.. ; \ + uuencode $(Ilisp_tar_dir).tar.gz $(Ilisp_tar_dir).tar.gz > il.uue) + + # end of file -- Makefile -- diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/README --- a/lisp/ilisp/README Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/README Mon Aug 13 08:46:56 2007 +0200 @@ -1,54 +1,25 @@ --*- Mode: Text -*- +ILISP is a powerful GNU Emacs interface to many dialects of Lisp, +including Lucid, Allegro, Harlequin LispWorks, GCL, KCL, AKCL, ECL, IBCL, +and CMUCL. -ILISP is a powerful GNU Emacs interface to many dialects of Lisp, -including Lucid, Allegro, Harlequin LispWorks, KCL, AKCL, ECL, IBCL, -and CMUCL. Written by Chris McConnell and now maintained by -Marco Antoniotti and Rick Busdiecker . +Marco Antoniotti and +Rick Campbell . Please refer to the following files in this directory: - HISTORY - A detailed summary of changes over the course of ILISP's - existence. - GETTING-ILISP - Directions for obtaining this collection using - anonymous FTP. + HISTORY: A detailed summary of changes over the course of ILISP's + existence. + GETTING-ILISP: Directions for obtaining this collection using + anonymous FTP. + INSTALLATION: Directions about how to install ILISP and specific + dialect needs. Please send bug reports, questions, suggestions, etc. to: - ILISP Discussion + ILISP Discussion Please address all list administration messages, such as requests to -subscribe or unsubscribe from ilisp@lehman.com, to: - ILISP Administrivia - -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Future developments: - -ILISP might become part of the standard FSF distribution in the -future. There are numerous little things that need to be done in that -direction in order to conform to FSF coding and interface standards -(e.g. the behavior of C-a is not acceptable by the FSF interface -standard and numerous doc strings in ILISP need to be rewritten). -This will happen slowly over the next(s) releases. - -Thanks go to the following people (and to many others who need our -apologies for having let them out of the list): +subscribe or unsubscribe from ilisp@naggum.no, to: + ILISP Administrivia - Tim Bradshaw - Kimball Collins - David Gadbois - Robert P. Goldman - Marty Hall - Richard Harris - Christopher Hoover - Larry Hunter - Todd Kaufmann - Mark Kantrowitz - Qiegang Long - Christopher McConnell - Yusuf Pisan - Jeffrey Mark Siskind - Richard Stallman - Jason Trenouth - Christof Ullwer - Ivan Vazquez - Matsuo Yoshihiro +See http://www.c2.net/~campbell/ilisp/ or +http://www.cs.cmu.edu/~campbell/ilisp/ for more information. diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/Welcome --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/Welcome Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,39 @@ +Welcome to the ILISP Discussion mailing list. + +ILISP is a GNU Emacs package for controlling an inferior process +running a lisp dialect. You can get ILISP by anonymous ftp at +FTP.CS.CMU.EDU in the directory /afs/cs/user/campbell/http/ilisp/. +Also you can find ILISP by getting to the AI.Repository via the WWW. + +http://www.cs.cmu.edu/Web/Groups/AI/html/repository.html + +From there follow: LISP, UTIL, EMACS and finally ILISP + +Other archive sites include: + ftp://ftp.icsi.berkeley.edu/pub/software/elisp/ + http://www.c2.net/~campbell/ilisp/ + http://www.cs.cmu.edu/~campbell/ilisp/ + +ILISP is currently being maintained by Marco Antoniotti + and Rick Campbell . +The mailing list is maintained by Erik Naggum . + +Please address all list administration messages, such as requests to +subscribe or unsubscribe, to: + + ILISP Administrivia + +Please allow a little time; +there's no list server programming running, the list is maintained by +hand. + +To send a message to everyone on the list, address it to: + + ILISP Discussion + +The list has had a very low volume lately, so you may not see messages +for a while after subscribing. + +Please note that there is no "bug" list like ilisp-bugs@naggum.no. +The primary list serves the purpose of a general bug fix and +discussion area. diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/allegro.lisp --- a/lisp/ilisp/allegro.lisp Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/allegro.lisp Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; allegro.lisp -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/bridge.el --- a/lisp/ilisp/bridge.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/bridge.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,9 +3,9 @@ ;;; Bridge process filter, V1.0 ;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu ;;; -;;; Send mail to ilisp@lehman.com if you have problems. +;;; Send mail to ilisp@naggum.no if you have problems. ;;; -;;; Send mail to ilisp-request@lehman.com if you want to be on the +;;; Send mail to ilisp-request@naggum.no if you want to be on the ;;; ilisp mailing list. ;;; This file is part of GNU Emacs. @@ -149,20 +149,20 @@ (select-window original))))))))) ;;; -(defun bridge-send-string (process string) - "Send PROCESS the contents of STRING as input. -This is equivalent to process-send-string, except that long input strings -are broken up into chunks of size comint-input-chunk-size. Processes -are given a chance to output between chunks. This can help prevent processes -from hanging when you send them long inputs on some OS's." - (let* ((len (length string)) - (i (min len bridge-chunk-size))) - (process-send-string process (substring string 0 i)) - (while (< i len) - (let ((next-i (+ i bridge-chunk-size))) - (accept-process-output) - (process-send-string process (substring string i (min len next-i))) - (setq i next-i))))) +;(defun bridge-send-string (process string) +; "Send PROCESS the contents of STRING as input. +;This is equivalent to process-send-string, except that long input strings +;are broken up into chunks of size comint-input-chunk-size. Processes +;are given a chance to output between chunks. This can help prevent processes +;from hanging when you send them long inputs on some OS's." +; (let* ((len (length string)) +; (i (min len bridge-chunk-size))) +; (process-send-string process (substring string 0 i)) +; (while (< i len) +; (let ((next-i (+ i bridge-chunk-size))) +; (accept-process-output) +; (process-send-string process (substring string i (min len next-i))) +; (setq i next-i))))) ;;; (defun bridge-call-handler (handler proc string) @@ -218,7 +218,10 @@ (goto-char (point-max)) (insert input))) (set-buffer buffer))) - (if to (bridge-send-string to input))) + (if to + ;; (bridge-send-string to input) + (process-send-string to input) + )) (error "%s is not a buffer" buffer-name))))) ;;;%Filter diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/cl-ilisp.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/cl-ilisp.lisp Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,617 @@ +;;; -*- Mode: Lisp -*- + +;;; cl-ilisp.lisp -- + +;;; This file is part of ILISP. +;;; Version: 5.8 +;;; +;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell +;;; 1993, 1994 Ivan Vasquez +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell +;;; +;;; Other authors' names for which this Copyright notice also holds +;;; may appear later in this file. +;;; +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP +;;; mailing list were bugs and improvements are discussed. +;;; +;;; ILISP is freely redistributable under the terms found in the file +;;; COPYING. + + + +;;; Common Lisp initializations +;;; Author: Chris McConnell, ccm@cs.cmu.edu + +;;; +;;; ange-ftp hack added by ivan Wed Mar 10 12:30:15 1993 +;;; ilisp-errors *gc-verbose* addition ivan Tue Mar 16 03:21:51 1993 +;;; +;;; Rcs_Info: clisp.lisp,v 1.26 1993/09/03 02:05:07 ivan Rel $ +;;; +;;; Revision 1.19 1993/08/24 22:01:52 ivan +;;; Use defpackage instead of just IN-PACKAGE. +;;; Renamed FUNCTION to FUN in ilisp-arglist to get around CMUCL 17b bug. +;;; +;;; Revision 1.16 1993/06/29 05:51:35 ivan +;;; Added Ed Gamble's #'readtable-case fix and Hans Chalupsky's +;;; allegro-4.1 addition. +;;; +;;; Revision 1.8 1993/06/28 00:57:42 ivan +;;; Stopped using 'COMPILED-FUNCTION-P for compiled check. +;;; +;;; Revision 1.3 1993/03/16 23:22:10 ivan +;;; Added breakp arg to ilisp-trace. +;;; +;;; + + +#+(or allegro-v4.0 allegro-v4.1) +(eval-when (compile load eval) + (setq excl:*cltl1-in-package-compatibility-p* t)) + + +(in-package "ILISP") + +;;; +;;; GCL 2.2 doesn't have defpackage (yet) so we need to put the export +;;; here. (toy@rtp.ericsson.se) +;;; +;;; Please note that while the comment and the fix posted by Richard +;;; Toy are correct, they are deprecated by at least one of the ILISP +;;; maintainers. :) By removing the 'nil' in the following #+, you +;;; will fix the problem but will not do a good service to the CL +;;; community. The right thing to do is to install DEFPACKAGE in your +;;; GCL and to write the GCL maintainers and to ask them to +;;; incorporate DEFPACKAGE in their standard builds. +;;; Marco Antoniotti 19960715 +;;; + +#+(and nil gcl) +(export '(ilisp-errors + ilisp-save + ilisp-restore + ilisp-symbol-name + ilisp-find-symbol + ilisp-find-package + ilisp-eval + ilisp-compile + ilisp-describe + ilisp-inspect + ilisp-arglist + ilisp-documentation + ilisp-macroexpand + ilisp-macroexpand-1 + ilisp-trace + ilisp-untrace + ilisp-compile-file + ilisp-casify + ilisp-matching-symbols)) + + +;;; +(defvar *ilisp-old-result* nil "Used for save/restore of top level values.") + +#+:ANSI-CL +(defun special-form-p (symbol) + "Backward compatibility for non ANSI CL's." + (special-operator-p symbol)) + +;;; +(defmacro ilisp-handler-case (expression &rest handlers) + "Evaluate EXPRESSION using HANDLERS to handle errors." + handlers + (if (macro-function 'handler-case) + `(handler-case ,expression ,@handlers) + #+allegro `(excl::handler-case ,expression ,@handlers) + #+lucid `(lucid::handler-case ,expression ,@handlers) + #-(or allegro lucid) expression)) + +;;; +(defun ilisp-readtable-case (readtable) + (if (fboundp 'readtable-case) + (funcall #'readtable-case readtable) + #+allegro (case excl:*current-case-mode* + (:case-insensitive-upper :upcase) + (:case-insensitive-lower :downcase) + (otherwise :preserve)) + #-allegro :upcase)) + +;;; +(defmacro ilisp-errors (form) + "Handle errors when evaluating FORM." + `(let ((*standard-output* *terminal-io*) + (*error-output* *terminal-io*) + #+cmu + (ext:*gc-verbose* nil) ; cmulisp outputs "[GC ...]" which + ; doesn't read well... + #+ecl + (sys:*gc-verbose* nil) ; ecolisp also outputs "[GC ...]" + ) + (princ " ") ;Make sure we have output + (ilisp-handler-case + ,form + (error (error) + (with-output-to-string (string) + (format string "ILISP: ~A" error)))))) + + +;;; +(defun ilisp-save () + "Save the current state of the result history." + (declare (special / // /// + ++ +++)) + (unless *ilisp-old-result* + (setq *ilisp-old-result* (list /// // +++ ++ + /)))) + +;;; +(defun ilisp-restore () + "Restore the old result history." + (declare (special / // /// + ++ +++ * ** -)) + (setq // (pop *ilisp-old-result*) + ** (first //) + / (pop *ilisp-old-result*) + * (first /) + ++ (pop *ilisp-old-result*) + + (pop *ilisp-old-result*) + - (pop *ilisp-old-result*)) + (values-list (pop *ilisp-old-result*))) + +;;; ilisp-symbol-name -- +;;; +;;; ':capitalize' case added under suggestion by Rich Mallory. +(defun ilisp-symbol-name (symbol-name) + "Return SYMBOL-NAME with the appropriate case as a symbol." + (case (ilisp-readtable-case *readtable*) + (:upcase (string-upcase symbol-name)) + (:downcase (string-downcase symbol-name)) + (:capitalize (string-capitalize symbol-name)) + (:preserve symbol-name))) + +;;; +(defun ilisp-find-package (package-name) + "Return package PACKAGE-NAME or the current package." + (if (string-equal package-name "nil") + *package* + (or (find-package (ilisp-symbol-name package-name)) + (error "Package ~A not found" package-name)))) + +;;; +(defun ilisp-find-symbol (symbol-name package-name) + "Return the symbol associated with SYMBOL-NAME in PACKAGE-NAME trying to +handle case issues intelligently." + (find-symbol (ilisp-symbol-name symbol-name) + (ilisp-find-package package-name))) + + +;;; The following two functions were in version 5.5. +;;; They disappeared in version 5.6. I am putting them back in the +;;; distribution in order to make use of them later if the need +;;; arises. +;;; Marco Antoniotti: Jan 2 1995 +#| +(defun ilisp-filename-hack (filename) + "Strip `/user@machine:' prefix from filename." + ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz + ;; filenames... + (let ((at-location (position #\@ filename)) + (colon-location (position #\: filename))) + (if (and at-location colon-location) + (subseq filename (1+ colon-location)) + filename))) + + +(defun ilisp-read-form (form package) + "Read string FORM in PACKAGE and return the resulting form." + (let ((*package* (ilisp-find-package package))) + (read-from-string form))) +|# + +;;; +(defun ilisp-eval (form package filename) + "Evaluate FORM in PACKAGE recording FILENAME as the source file." + (princ " ") + ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz + ;; filenames... + (let* ((at-location (position #\@ filename)) + (colon-location (position #\: filename)) + (filename + (if (and at-location colon-location) + (subseq filename (1+ colon-location)) + filename)) + (*package* (ilisp-find-package package)) + #+allegro (excl::*source-pathname* filename) + #+allegro (excl::*redefinition-warnings* nil) + #+lucid (lucid::*source-pathname* + (if (probe-file filename) + (truename filename) + (merge-pathnames filename))) + #+lucid (lucid::*redefinition-action* nil) + #+lispworks (compiler::*input-pathname* (merge-pathnames filename)) + #+lispworks (compiler::*warn-on-non-top-level-defun* nil) + ;; The LW entries are a mix of Rich Mallory and Jason + ;; Trenouth suggestions + ;; Marco Antoniotti: Jan 2 1995. + ) + filename + (eval (read-from-string form)))) + +;;; +(defun ilisp-compile (form package filename) + "Compile FORM in PACKAGE recording FILENAME as the source file." + (princ " ") + ;; This makes sure that function forms are compiled + ;; NOTE: Rich Mallory proposed a variation of the next piece of + ;; code. for the time being we stick to the following simpler code. + ;; Marco Antoniotti: Jan 2 1995. + #-lucid + (ilisp-eval + (format nil "(funcall (compile nil '(lisp:lambda () ~A)))" + form) + package + filename) + + ;; The following piece of conditional code is left in the + ;; distribution just for historical purposes. + ;; It will disappear in the next release. + ;; Marco Antoniotti: Jan 2 1995. + #+lucid-ilisp-5.6 + (labels ((compiler (form env) + (if (and (consp form) + (eq (first form) 'function) + (consp (second form))) + #-LCL3.0 + (evalhook `(compile nil ,form) nil nil env) + #+LCL3.0 + ;; If we have just compiled a named-lambda, and the + ;; name didn't make it in to the procedure object, + ;; then stuff the appropriate symbol in to the + ;; procedure object. + (let* ((proc (evalhook `(compile nil ,form) + nil nil env)) + (old-name (and proc (sys:procedure-ref proc 1))) + (lambda (second form)) + (name (and (eq (first lambda) + 'lucid::named-lambda) + (second lambda)))) + (when (or (null old-name) + (and (listp old-name) + (eq :internal (car old-name)))) + (setf (sys:procedure-ref proc 1) name)) + proc) + (evalhook form #'compiler nil env)))) + (let ((*evalhook* #'compiler)) + (ilisp-eval form package filename))) + #+lucid + ;; Following form is a patch provided by Christopher Hoover + ;; + (let ((*package* (ilisp-find-package package)) + (lcl:*source-pathname* (if (probe-file filename) + (truename filename) + (merge-pathnames filename))) + (lcl:*redefinition-action* nil)) + (with-input-from-string (s form) + (lucid::compile-in-core-from-stream s) + (values))) + ) + +;;; +(defun ilisp-describe (sexp package) + "Describe SEXP in PACKAGE." + (ilisp-errors + (let ((*package* (ilisp-find-package package))) + (describe (eval (read-from-string sexp)))))) + +;;; +(defun ilisp-inspect (sexp package) + "Inspect SEXP in PACKAGE." + (ilisp-errors + (let ((*package* (ilisp-find-package package))) + (inspect (eval (read-from-string sexp)))))) + +;;; +(defun ilisp-arglist (symbol package) + (ilisp-errors + (let ((fn (ilisp-find-symbol symbol package)) + (*print-length* nil) + (*print-pretty* t) + (*package* (ilisp-find-package package))) + (cond ((null fn) + (format t "Symbol ~s not present in ~s." symbol package)) + ((not (fboundp fn)) + (format t "~s: undefined~%" fn)) + (t + (print-function-arglist fn))))) + (values)) + + +(defun print-function-arglist (fn) + "Pretty arglist printer" + (let* ((a (get-function-arglist fn)) + (arglist (ldiff a (member '&aux a))) + (desc (ilisp-function-short-description fn))) + (format t "~&~s~a" fn (or desc "")) + (write-string ": ") + (if arglist + (write arglist :case :downcase :escape nil) + (write-string "()")) + (terpri))) + + + +(defun ilisp-generic-function-p (symbol) + (let ((generic-p + (find-symbol "GENERIC-FUNCTION-P" + (or (find-package "PCL") + *package*)))) + (and generic-p + (fboundp generic-p) + (funcall generic-p symbol)))) + + + +(defun ilisp-function-short-description (symbol) + (cond ((macro-function symbol) + " (Macro)") + ((special-form-p symbol) + " (Special Form)") + ((ilisp-generic-function-p symbol) + " (Generic)"))) + + + +(defun get-function-arglist (symbol) + (let ((fun (symbol-function symbol))) + (cond ((ilisp-generic-function-p symbol) + (funcall + (find-symbol "GENERIC-FUNCTION-PRETTY-ARGLIST" + (or (find-package "PCL") *package*)) + fun)) + (t + #+allegro + (excl::arglist symbol) + + #+(or ibcl kcl ecl gcl) + (help symbol) + + #+lucid + (lucid::arglist symbol) + + #+lispworks + (system::function-lambda-list symbol) + + #-(or allegro lucid kcl ibcl ecl) + (documentation symbol 'function))))) + +;;; +(defun ilisp-documentation (symbol package type) + "Return the TYPE documentation for SYMBOL in PACKAGE. If TYPE is +\(qualifiers* (class ...)), the appropriate method will be found." + (ilisp-errors + (let* ((real-symbol (ilisp-find-symbol symbol package)) + (type (if (and (not (zerop (length type))) + (eq (elt type 0) #\()) + (let ((*package* (ilisp-find-package package))) + (read-from-string type)) + (ilisp-find-symbol type package)))) + (when (listp type) + (setq real-symbol + (funcall + (find-symbol "FIND-METHOD" (or (find-package "CLOS") + (find-package "PCL") + *package*)) + (symbol-function real-symbol) + (reverse + (let ((quals nil)) + (dolist (entry type quals) + (if (listp entry) + (return quals) + (setq quals (cons entry quals)))))) + (reverse + (let ((types nil)) + (dolist (class (first (last type)) types) + (setq types + (cons (funcall + (find-symbol "FIND-CLASS" + (or (find-package "CLOS") + (find-package "PCL") + *package*)) + class) types)))))))) + (if real-symbol + (if (symbolp real-symbol) + (documentation real-symbol type) + ;; Prevent compiler complaints + (eval `(documentation ,real-symbol))) + (format nil "~A has no ~A documentation" symbol type))))) + +;;; +(defun ilisp-macroexpand (expression package) + "Macroexpand EXPRESSION as long as the top level function is still a +macro." + (ilisp-errors + (let ((*print-length* nil) + (*print-level* nil) + (*package* (ilisp-find-package package))) + (pprint (#-allegro macroexpand #+allegro excl::walk + (read-from-string expression)))))) + +;;; +(defun ilisp-macroexpand-1 (expression package) + "Macroexpand EXPRESSION once." + (ilisp-errors + (let ((*print-length* nil) + (*print-level* nil) + (*package* (ilisp-find-package package))) + (pprint (macroexpand-1 (read-from-string expression)))))) + +;;; +#-lispworks +(defun ilisp-trace (symbol package breakp) + "Trace SYMBOL in PACKAGE." + (declare (ignore breakp)) ; No way to do this in CL. + (ilisp-errors + (let ((real-symbol (ilisp-find-symbol symbol package))) + (when real-symbol (eval `(trace ,real-symbol)))))) + +;;; Jason Trenouth: SEP 6 94 -- LispWorks can trace-break +#+lispworks +(defun ilisp-trace (symbol package breakp) + "Trace SYMBOL in PACKAGE." + (ilisp-errors + (let ((real-symbol (ilisp-find-symbol symbol package))) + breakp ;; idiom for (declare (ignorable breakp)) + (when real-symbol (eval `(trace (,real-symbol :break breakp))))))) + + + +(defun ilisp-untrace (symbol package) + "Untrace SYMBOL in PACKAGE." + (ilisp-errors + (let ((real-symbol (ilisp-find-symbol symbol package))) + (when real-symbol (eval `(untrace ,real-symbol)))))) + +;;; +(defun ilisp-compile-file (file extension) + "Compile FILE putting the result in FILE+EXTENSION." + (ilisp-errors + (compile-file file + :output-file + (merge-pathnames (make-pathname :type extension) file)))) + +;;; +(defun ilisp-casify (pattern string lower-p upper-p) + "Return STRING with its characters converted to the case of PATTERN, +continuing with the last case beyond the end." + (cond (lower-p (string-downcase string)) + (upper-p (string-upcase string)) + (t + (let (case) + (concatenate + 'string + (map 'string + #'(lambda (p s) + (setq case (if (upper-case-p p) + #'char-upcase + #'char-downcase)) + (funcall case s)) + pattern string) + (map 'string case (subseq string (length pattern)))))))) + +;;; +(defun ilisp-words (string) + "Return STRING broken up into words. Each word is (start end +delimiter)." + (do* ((length (length string)) + (start 0) + (end t) + (words nil)) + ((null end) (nreverse words)) + (if (setq end (position-if-not #'alphanumericp string :start start)) + (setq words (cons (list end (1+ end) t) + (if (= start end) + words + (cons (list start end nil) words))) + start (1+ end)) + (setq words (cons (list start length nil) words))))) + +;;; +(defun ilisp-match-words (string pattern words) + "Match STRING to PATTERN using WORDS." + (do* ((strlen (length string)) + (words words (cdr words)) + (word (first words) (first words)) + (start1 (first word) (first word)) + (end1 (second word) (second word)) + (delimiter (third word) (third word)) + (len (- end1 start1) (and word (- end1 start1))) + (start2 0) + (end2 len)) + ((or (null word) (null start2)) start2) + (setq end2 (+ start2 len) + start2 + (if delimiter + (position (elt pattern start1) string :start start2) + (when (and (<= end2 strlen) + (string= pattern string + :start1 start1 :end1 end1 + :start2 start2 :end2 end2)) + (1- end2)))) + (when start2 (incf start2)))) + +;;; +(defun ilisp-matching-symbols (string package &optional (function-p nil) + (external-p nil) + (prefix-p nil)) + "Return a list of the symbols that have STRING as a prefix in +PACKAGE. FUNCTION-P indicates that only symbols with a function value +should be considered. EXTERNAL-P indicates that only external symbols +should be considered. PREFIX-P means that partial matches should not +be considered. The returned strings have the same case as the +original string." + (ilisp-errors + (let* ((lower-p (notany #'upper-case-p string)) + (upper-p (notany #'lower-case-p string)) + (no-casify (eq (ilisp-readtable-case *readtable*) :preserve)) + (symbol-string (ilisp-symbol-name string)) + (length (length string)) + (results nil) + (*print-length* nil) + (*package* (ilisp-find-package package))) + (labels + ( + ;; Check SYMBOL against PATTERN + (check-symbol (symbol pattern) + (let ((name (symbol-name symbol))) + (when (and (or (not function-p) (fboundp symbol)) + (>= (length name) length) + (string= pattern name :end2 length)) + (push (list (if no-casify + name + (ilisp-casify pattern name lower-p upper-p))) + results)))) + ;; Check SYMBOL against PATTERN using WORDS + (check-symbol2 (symbol pattern words) + (let ((name (symbol-name symbol))) + (when (and (or (not function-p) (fboundp symbol)) + (ilisp-match-words name pattern words)) + (push (list (if no-casify + name + (ilisp-casify pattern name lower-p upper-p))) + results))))) + (if external-p + (do-external-symbols (symbol *package*) + (check-symbol symbol symbol-string)) + (progn + ;; KCL does not go over used symbols. + #+(or kcl ibcl ecl) + (dolist (used-package (package-use-list *package*)) + (do-external-symbols (symbol used-package) + (check-symbol symbol symbol-string))) + (do-symbols (symbol *package*) + (check-symbol symbol symbol-string)))) + (unless (or results prefix-p) + (let ((words (ilisp-words symbol-string))) + (if external-p + (do-external-symbols (symbol *package*) + (check-symbol2 symbol symbol-string words)) + (progn + ;; KCL does not go over used symbols. + #+(or kcl ibcl ecl) + (dolist (used-package (package-use-list *package*)) + (do-external-symbols (symbol used-package) + (check-symbol2 symbol symbol-string words))) + (do-symbols (symbol *package*) + (check-symbol2 symbol symbol-string words)))))) + (prin1 results) + nil)))) + + +(eval-when (load eval) + (when + #+cmu (eval:interpreted-function-p #'ilisp-matching-symbols) + #-cmu (not (compiled-function-p #'ilisp-matching-symbols)) + (format *standard-output* + "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))) + +;;; end of file -- cl-ilisp.lisp -- diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/clisp.lisp --- a/lisp/ilisp/clisp.lisp Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,657 +0,0 @@ -;;; -*- Mode: Lisp -*- - -;;; clisp.lisp -- - -;;; This file is part of ILISP. -;;; Version: 5.7 -;;; -;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell -;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker -;;; -;;; Other authors' names for which this Copyright notice also holds -;;; may appear later in this file. -;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP -;;; mailing list were bugs and improvements are discussed. -;;; -;;; ILISP is freely redistributable under the terms found in the file -;;; COPYING. - - - -;;; Common Lisp initializations -;;; Author: Chris McConnell, ccm@cs.cmu.edu - -;;; -;;; ange-ftp hack added by ivan Wed Mar 10 12:30:15 1993 -;;; ilisp-errors *gc-verbose* addition ivan Tue Mar 16 03:21:51 1993 -;;; -;;; Rcs_Info: clisp.lisp,v 1.26 1993/09/03 02:05:07 ivan Rel $ -;;; -;;; Revision 1.19 1993/08/24 22:01:52 ivan -;;; Use defpackage instead of just IN-PACKAGE. -;;; Renamed FUNCTION to FUN in ilisp-arglist to get around CMUCL 17b bug. -;;; -;;; Revision 1.16 1993/06/29 05:51:35 ivan -;;; Added Ed Gamble's #'readtable-case fix and Hans Chalupsky's -;;; allegro-4.1 addition. -;;; -;;; Revision 1.8 1993/06/28 00:57:42 ivan -;;; Stopped using 'COMPILED-FUNCTION-P for compiled check. -;;; -;;; Revision 1.3 1993/03/16 23:22:10 ivan -;;; Added breakp arg to ilisp-trace. -;;; -;;; - - -#+(or allegro-v4.0 allegro-v4.1) -(eval-when (compile load eval) - (setq excl:*cltl1-in-package-compatibility-p* t)) - - -;;; The following is really a kludge! The defpackage should be in a -;;; separate file, but it looks like it is really hard to change ILISP -;;; behavior on the subject. -;;; Marco Antoniotti 11/22/94 - -;;; I am commenting it out to see whether I can actually load the -;;; package file with the kludge in the definition of the dialect. -;;; -;;; Result: it works! This will disappear in the next release. - -#| -(eval-when (compile load eval) - (defpackage "ILISP" (:use "LISP" #+:CMU "CONDITIONS") - (:export "ILISP-ERRORS" - "ILISP-SAVE" - "ILISP-RESTORE" - "ILISP-SYMBOL-NAME" - "ILISP-FIND-SYMBOL" - "ILISP-FIND-PACKAGE" - "ILISP-EVAL" - "ILISP-COMPILE" - "ILISP-DESCRIBE" - "ILISP-INSPECT" - "ILISP-ARGLIST" - "ILISP-DOCUMENTATION" - "ILISP-MACROEXPAND" - "ILISP-MACROEXPAND-1" - "ILISP-TRACE" - "ILISP-UNTRACE" - "ILISP-COMPILE-FILE" - "ILISP-CASIFY" - "ILISP-MATCHING-SYMBOLS") - )) -|# - - -(in-package "ILISP") - -;;; -;;; GCL 2.2 doesn't have defpackage (yet) so we need to put the export -;;; here. (toy@rtp.ericsson.se) - -#+gcl -(export '(ilisp-errors - ilisp-save - ilisp-restore - ilisp-symbol-name - ilisp-find-symbol - ilisp-find-package - ilisp-eval - ilisp-compile - ilisp-describe - ilisp-inspect - ilisp-arglist - ilisp-documentation - ilisp-macroexpand - ilisp-macroexpand-1 - ilisp-trace - ilisp-untrace - ilisp-compile-file - ilisp-casify - ilisp-matching-symbols)) - - -;;; -(defvar *ilisp-old-result* nil "Used for save/restore of top level values.") - -#+:ANSI-CL -(defun special-form-p (symbol) - "Backward compatibility for non ANSI CL's." - (special-operator-p symbol)) - -;;; -(defmacro ilisp-handler-case (expression &rest handlers) - "Evaluate EXPRESSION using HANDLERS to handle errors." - handlers - (if (macro-function 'handler-case) - `(handler-case ,expression ,@handlers) - #+allegro `(excl::handler-case ,expression ,@handlers) - #+lucid `(lucid::handler-case ,expression ,@handlers) - #-(or allegro lucid) expression)) - -;;; -(defun ilisp-readtable-case (readtable) - (if (fboundp 'readtable-case) - (funcall #'readtable-case readtable) - #+allegro (case excl:*current-case-mode* - (:case-insensitive-upper :upcase) - (:case-insensitive-lower :downcase) - (otherwise :preserve)) - #-allegro :upcase)) - -;;; -(defmacro ilisp-errors (form) - "Handle errors when evaluating FORM." - `(let ((*standard-output* *terminal-io*) - (*error-output* *terminal-io*) - #+cmu - (ext:*gc-verbose* nil) ; cmulisp outputs "[GC ...]" which - ; doesn't read well... - #+ecl - (sys:*gc-verbose* nil) ; ecolisp also outputs "[GC ...]" - ) - (princ " ") ;Make sure we have output - (ilisp-handler-case - ,form - (error (error) - (with-output-to-string (string) - (format string "ILISP: ~A" error)))))) - - -;;; -(defun ilisp-save () - "Save the current state of the result history." - (declare (special / // /// + ++ +++)) - (unless *ilisp-old-result* - (setq *ilisp-old-result* (list /// // +++ ++ + /)))) - -;;; -(defun ilisp-restore () - "Restore the old result history." - (declare (special / // /// + ++ +++ * ** -)) - (setq // (pop *ilisp-old-result*) - ** (first //) - / (pop *ilisp-old-result*) - * (first /) - ++ (pop *ilisp-old-result*) - + (pop *ilisp-old-result*) - - (pop *ilisp-old-result*)) - (values-list (pop *ilisp-old-result*))) - -;;; ilisp-symbol-name -- -;;; -;;; ':capitalize' case added under suggestion by Rich Mallory. -(defun ilisp-symbol-name (symbol-name) - "Return SYMBOL-NAME with the appropriate case as a symbol." - (case (ilisp-readtable-case *readtable*) - (:upcase (string-upcase symbol-name)) - (:downcase (string-downcase symbol-name)) - (:capitalize (string-capitalize symbol-name)) - (:preserve symbol-name))) - -;;; -(defun ilisp-find-package (package-name) - "Return package PACKAGE-NAME or the current package." - (if (string-equal package-name "nil") - *package* - (or (find-package (ilisp-symbol-name package-name)) - (error "Package ~A not found" package-name)))) - -;;; -(defun ilisp-find-symbol (symbol-name package-name) - "Return the symbol associated with SYMBOL-NAME in PACKAGE-NAME trying to -handle case issues intelligently." - (find-symbol (ilisp-symbol-name symbol-name) - (ilisp-find-package package-name))) - - -;;; The following two functions were in version 5.5. -;;; They disappeared in version 5.6. I am putting them back in the -;;; distribution in order to make use of them later if the need -;;; arises. -;;; Marco Antoniotti: Jan 2 1995 -#| -(defun ilisp-filename-hack (filename) - "Strip `/user@machine:' prefix from filename." - ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz - ;; filenames... - (let ((at-location (position #\@ filename)) - (colon-location (position #\: filename))) - (if (and at-location colon-location) - (subseq filename (1+ colon-location)) - filename))) - - -(defun ilisp-read-form (form package) - "Read string FORM in PACKAGE and return the resulting form." - (let ((*package* (ilisp-find-package package))) - (read-from-string form))) -|# - -;;; -(defun ilisp-eval (form package filename) - "Evaluate FORM in PACKAGE recording FILENAME as the source file." - (princ " ") - ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz - ;; filenames... - (let* ((at-location (position #\@ filename)) - (colon-location (position #\: filename)) - (filename - (if (and at-location colon-location) - (subseq filename (1+ colon-location)) - filename)) - (*package* (ilisp-find-package package)) - #+allegro (excl::*source-pathname* filename) - #+allegro (excl::*redefinition-warnings* nil) - #+lucid (lucid::*source-pathname* - (if (probe-file filename) - (truename filename) - (merge-pathnames filename))) - #+lucid (lucid::*redefinition-action* nil) - #+lispworks (compiler::*input-pathname* (merge-pathnames filename)) - #+lispworks (compiler::*warn-on-non-top-level-defun* nil) - ;; The LW entries are a mix of Rich Mallory and Jason - ;; Trenouth suggestions - ;; Marco Antoniotti: Jan 2 1995. - ) - filename - (eval (read-from-string form)))) - -;;; -(defun ilisp-compile (form package filename) - "Compile FORM in PACKAGE recording FILENAME as the source file." - (princ " ") - ;; This makes sure that function forms are compiled - ;; NOTE: Rich Mallory proposed a variation of the next piece of - ;; code. for the time being we stick to the following simpler code. - ;; Marco Antoniotti: Jan 2 1995. - #-lucid - (ilisp-eval - (format nil "(funcall (compile nil '(lisp:lambda () ~A)))" - form) - package - filename) - - ;; The following piece of conditional code is left in the - ;; distribution just for historical purposes. - ;; It will disappear in the next release. - ;; Marco Antoniotti: Jan 2 1995. - #+lucid-ilisp-5.6 - (labels ((compiler (form env) - (if (and (consp form) - (eq (first form) 'function) - (consp (second form))) - #-LCL3.0 - (evalhook `(compile nil ,form) nil nil env) - #+LCL3.0 - ;; If we have just compiled a named-lambda, and the - ;; name didn't make it in to the procedure object, - ;; then stuff the appropriate symbol in to the - ;; procedure object. - (let* ((proc (evalhook `(compile nil ,form) - nil nil env)) - (old-name (and proc (sys:procedure-ref proc 1))) - (lambda (second form)) - (name (and (eq (first lambda) - 'lucid::named-lambda) - (second lambda)))) - (when (or (null old-name) - (and (listp old-name) - (eq :internal (car old-name)))) - (setf (sys:procedure-ref proc 1) name)) - proc) - (evalhook form #'compiler nil env)))) - (let ((*evalhook* #'compiler)) - (ilisp-eval form package filename))) - #+lucid - ;; Following form is a patch provided by Christopher Hoover - ;; - (let ((*package* (ilisp-find-package package)) - (lcl:*source-pathname* (if (probe-file filename) - (truename filename) - (merge-pathnames filename))) - (lcl:*redefinition-action* nil)) - (with-input-from-string (s form) - (lucid::compile-in-core-from-stream s) - (values))) - ) - -;;; -(defun ilisp-describe (sexp package) - "Describe SEXP in PACKAGE." - (ilisp-errors - (let ((*package* (ilisp-find-package package))) - (describe (eval (read-from-string sexp)))))) - -;;; -(defun ilisp-inspect (sexp package) - "Inspect SEXP in PACKAGE." - (ilisp-errors - (let ((*package* (ilisp-find-package package))) - (inspect (eval (read-from-string sexp)))))) - -;;; -(defun ilisp-arglist (symbol package) - (ilisp-errors - (let ((fn (ilisp-find-symbol symbol package)) - (*print-length* nil) - (*print-pretty* t) - (*package* (ilisp-find-package package))) - (cond ((null fn) - (format t "Symbol ~s not present in ~s." symbol package)) - ((not (fboundp fn)) - (format t "~s: undefined~%" fn)) - (t - (print-function-arglist fn))))) - (values)) - - -(defun print-function-arglist (fn) - "Pretty arglist printer" - (let* ((a (get-function-arglist fn)) - (arglist (ldiff a (member '&aux a))) - (desc (ilisp-function-short-description fn))) - (format t "~&~s~a" fn (or desc "")) - (write-string ": ") - (if arglist - (write arglist :case :downcase :escape nil) - (write-string "()")) - (terpri))) - - - -(defun ilisp-generic-function-p (symbol) - (let ((generic-p - (find-symbol "GENERIC-FUNCTION-P" - (or (find-package "PCL") - *package*)))) - (and generic-p - (fboundp generic-p) - (funcall generic-p symbol)))) - - - -(defun ilisp-function-short-description (symbol) - (cond ((macro-function symbol) - " (Macro)") - ((special-form-p symbol) - " (Special Form)") - ((ilisp-generic-function-p symbol) - " (Generic)"))) - - - -(defun get-function-arglist (symbol) - (let ((fun (symbol-function symbol))) - (cond ((ilisp-generic-function-p symbol) - (funcall - (find-symbol "GENERIC-FUNCTION-PRETTY-ARGLIST" - (or (find-package "PCL") *package*)) - fun)) - (t - #+allegro - (excl::arglist symbol) - - #+(or ibcl kcl ecl gcl) - (help symbol) - - #+lucid - (lucid::arglist symbol) - - #+lispworks - (system::function-lambda-list symbol) - - #-(or allegro lucid kcl ibcl ecl) - (documentation symbol 'function))))) - -;;; -(defun ilisp-documentation (symbol package type) - "Return the TYPE documentation for SYMBOL in PACKAGE. If TYPE is -\(qualifiers* (class ...)), the appropriate method will be found." - (ilisp-errors - (let* ((real-symbol (ilisp-find-symbol symbol package)) - (type (if (and (not (zerop (length type))) - (eq (elt type 0) #\()) - (let ((*package* (ilisp-find-package package))) - (read-from-string type)) - (ilisp-find-symbol type package)))) - (when (listp type) - (setq real-symbol - (funcall - (find-symbol "FIND-METHOD" (or (find-package "CLOS") - (find-package "PCL") - *package*)) - (symbol-function real-symbol) - (reverse - (let ((quals nil)) - (dolist (entry type quals) - (if (listp entry) - (return quals) - (setq quals (cons entry quals)))))) - (reverse - (let ((types nil)) - (dolist (class (first (last type)) types) - (setq types - (cons (funcall - (find-symbol "FIND-CLASS" - (or (find-package "CLOS") - (find-package "PCL") - *package*)) - class) types)))))))) - (if real-symbol - (if (symbolp real-symbol) - (documentation real-symbol type) - ;; Prevent compiler complaints - (eval `(documentation ,real-symbol))) - (format nil "~A has no ~A documentation" symbol type))))) - -;;; -(defun ilisp-macroexpand (expression package) - "Macroexpand EXPRESSION as long as the top level function is still a -macro." - (ilisp-errors - (let ((*print-length* nil) - (*print-level* nil) - (*package* (ilisp-find-package package))) - (pprint (#-allegro macroexpand #+allegro excl::walk - (read-from-string expression)))))) - -;;; -(defun ilisp-macroexpand-1 (expression package) - "Macroexpand EXPRESSION once." - (ilisp-errors - (let ((*print-length* nil) - (*print-level* nil) - (*package* (ilisp-find-package package))) - (pprint (macroexpand-1 (read-from-string expression)))))) - -;;; -#-lispworks -(defun ilisp-trace (symbol package breakp) - "Trace SYMBOL in PACKAGE." - (declare (ignore breakp)) ; No way to do this in CL. - (ilisp-errors - (let ((real-symbol (ilisp-find-symbol symbol package))) - (when real-symbol (eval `(trace ,real-symbol)))))) - -;;; Jason Trenouth: SEP 6 94 -- LispWorks can trace-break -#+lispworks -(defun ilisp-trace (symbol package breakp) - "Trace SYMBOL in PACKAGE." - (ilisp-errors - (let ((real-symbol (ilisp-find-symbol symbol package))) - breakp ;; idiom for (declare (ignorable breakp)) - (when real-symbol (eval `(trace (,real-symbol :break breakp))))))) - - - -(defun ilisp-untrace (symbol package) - "Untrace SYMBOL in PACKAGE." - (ilisp-errors - (let ((real-symbol (ilisp-find-symbol symbol package))) - (when real-symbol (eval `(untrace ,real-symbol)))))) - -;;; -(defun ilisp-compile-file (file extension) - "Compile FILE putting the result in FILE+EXTENSION." - (ilisp-errors - (compile-file file - :output-file - (merge-pathnames (make-pathname :type extension) file)))) - -;;; -(defun ilisp-casify (pattern string lower-p upper-p) - "Return STRING with its characters converted to the case of PATTERN, -continuing with the last case beyond the end." - (cond (lower-p (string-downcase string)) - (upper-p (string-upcase string)) - (t - (let (case) - (concatenate - 'string - (map 'string - #'(lambda (p s) - (setq case (if (upper-case-p p) - #'char-upcase - #'char-downcase)) - (funcall case s)) - pattern string) - (map 'string case (subseq string (length pattern)))))))) - -;;; -(defun ilisp-words (string) - "Return STRING broken up into words. Each word is (start end -delimiter)." - (do* ((length (length string)) - (start 0) - (end t) - (words nil)) - ((null end) (nreverse words)) - (if (setq end (position-if-not #'alphanumericp string :start start)) - (setq words (cons (list end (1+ end) t) - (if (= start end) - words - (cons (list start end nil) words))) - start (1+ end)) - (setq words (cons (list start length nil) words))))) - -;;; -(defun ilisp-match-words (string pattern words) - "Match STRING to PATTERN using WORDS." - (do* ((strlen (length string)) - (words words (cdr words)) - (word (first words) (first words)) - (start1 (first word) (first word)) - (end1 (second word) (second word)) - (delimiter (third word) (third word)) - (len (- end1 start1) (and word (- end1 start1))) - (start2 0) - (end2 len)) - ((or (null word) (null start2)) start2) - (setq end2 (+ start2 len) - start2 - (if delimiter - (position (elt pattern start1) string :start start2) - (when (and (<= end2 strlen) - (string= pattern string - :start1 start1 :end1 end1 - :start2 start2 :end2 end2)) - (1- end2)))) - (when start2 (incf start2)))) - -;;; -(defun ilisp-matching-symbols (string package &optional (function-p nil) - (external-p nil) - (prefix-p nil)) - "Return a list of the symbols that have STRING as a prefix in -PACKAGE. FUNCTION-P indicates that only symbols with a function value -should be considered. EXTERNAL-P indicates that only external symbols -should be considered. PREFIX-P means that partial matches should not -be considered. The returned strings have the same case as the -original string." - (ilisp-errors - (let* ((lower-p (notany #'upper-case-p string)) - (upper-p (notany #'lower-case-p string)) - (no-casify (eq (ilisp-readtable-case *readtable*) :preserve)) - (symbol-string (ilisp-symbol-name string)) - (length (length string)) - (results nil) - (*print-length* nil) - (*package* (ilisp-find-package package))) - (labels - ( - ;; Check SYMBOL against PATTERN - (check-symbol (symbol pattern) - (let ((name (symbol-name symbol))) - (when (and (or (not function-p) (fboundp symbol)) - (>= (length name) length) - (string= pattern name :end2 length)) - (push (list (if no-casify - name - (ilisp-casify pattern name lower-p upper-p))) - results)))) - ;; Check SYMBOL against PATTERN using WORDS - (check-symbol2 (symbol pattern words) - (let ((name (symbol-name symbol))) - (when (and (or (not function-p) (fboundp symbol)) - (ilisp-match-words name pattern words)) - (push (list (if no-casify - name - (ilisp-casify pattern name lower-p upper-p))) - results))))) - (if external-p - (do-external-symbols (symbol *package*) - (check-symbol symbol symbol-string)) - (progn - ;; KCL does not go over used symbols. - #+(or kcl ibcl ecl) - (dolist (used-package (package-use-list *package*)) - (do-external-symbols (symbol used-package) - (check-symbol symbol symbol-string))) - (do-symbols (symbol *package*) - (check-symbol symbol symbol-string)))) - (unless (or results prefix-p) - (let ((words (ilisp-words symbol-string))) - (if external-p - (do-external-symbols (symbol *package*) - (check-symbol2 symbol symbol-string words)) - (progn - ;; KCL does not go over used symbols. - #+(or kcl ibcl ecl) - (dolist (used-package (package-use-list *package*)) - (do-external-symbols (symbol used-package) - (check-symbol2 symbol symbol-string words))) - (do-symbols (symbol *package*) - (check-symbol2 symbol symbol-string words)))))) - (prin1 results) - nil)))) - - -;;; Make sure that functions are exported -;;; Now this could go away. I just leave commented it for backup reasons. - -#| -(dolist (symbol '(ilisp-errors ilisp-save ilisp-restore - ilisp-symbol-name ilisp-find-symbol ilisp-find-package - ilisp-eval ilisp-compile - ilisp-describe ilisp-inspect - ilisp-arglist ilisp-documentation - ilisp-macroexpand ilisp-macroexpand-1 - ilisp-trace ilisp-untrace - ilisp-compile-file ilisp-casify - ilisp-matching-symbols)) - (export symbol)) -|# - - -(when - #+cmu (eval:interpreted-function-p #'ilisp-matching-symbols) - #-cmu (not (compiled-function-p #'ilisp-matching-symbols)) - (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\"")) - -;;; end of file -- clisp.lisp -- diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/cmulisp.lisp --- a/lisp/ilisp/cmulisp.lisp Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/cmulisp.lisp Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; cmulisp.lisp -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/comint-ipc.el --- a/lisp/ilisp/comint-ipc.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/comint-ipc.el Mon Aug 13 08:46:56 2007 +0200 @@ -8,9 +8,9 @@ ;;; IPC extensions for comint ;;; Copyright (C) 1990 Chris McConnell, ccm@cs.cmu.edu. ;;; -;;; Send mail to ilisp@lehman.com if you have problems. +;;; Send mail to ilisp@naggum.no if you have problems. ;;; -;;; Send mail to ilisp-request@lehman.com if you want to be on the +;;; Send mail to ilisp-request@naggum.no if you want to be on the ;;; ilisp mailing list. ;;; This file is part of GNU Emacs. @@ -186,27 +186,29 @@ (insert "{") (insert string) (insert "}")) (insert string))))) -;;; -(defun comint-send-string (proc str) - "Send PROCESS the contents of STRING as input. -This is equivalent to process-send-string, except that long input strings -are broken up into chunks of size comint-input-chunk-size. Processes -are given a chance to output between chunks. This can help prevent processes -from hanging when you send them long inputs on some OS's." - (comint-log proc str) - (let* ((len (length str)) - (i (min len comint-input-chunk-size))) - (process-send-string proc (substring str 0 i)) - (while (< i len) - (let ((next-i (+ i comint-input-chunk-size))) - (accept-process-output) - (process-send-string proc (substring str i (min len next-i))) - (setq i next-i))))) +;;; v5.7b Removed by suggestion of erik@naggum.no (Erik Naggum). -;;; +;;; (defun comint-send-string (proc str) +;;; "Send PROCESS the contents of STRING as input. +;;; This is equivalent to process-send-string, except that long input strings +;;; are broken up into chunks of size comint-input-chunk-size. Processes +;;; are given a chance to output between chunks. This can help prevent +;;; processes from hanging when you send them long inputs on some OS's." +;;; (comint-log proc str) +;;; (let* ((len (length str)) +;;; (i (min len comint-input-chunk-size))) +;;; (process-send-string proc (substring str 0 i)) +;;; (while (< i len) +;;; (let ((next-i (+ i comint-input-chunk-size))) +;;; (accept-process-output) +;;; (process-send-string proc (substring str i (min len next-i))) +;;; (setq i next-i))))) + +;;; v5.7b See above (defun comint-sender (process string) "Send to PROCESS STRING with newline if comint-send-newline." - (comint-send-string process string) + ;; (comint-send-string process string) + (process-send-string process string) (if comint-send-newline (progn (comint-log process "\n") @@ -455,10 +457,31 @@ (string-match comint-error-regexp comint-output)))) (unwind-protect + ;; (if handler + ;; (setq handler + ;; (funcall handler comint-errorp wait-p + ;; message output last))) + + ;; v5.7b Patch suggested by fujieda@jaist.ac.jp + ;; (Kazuhiro Fujieda). Here is his comment. + + ;; "When the 'handler' is called, the current + ;; buffer may be changed. 'comint-process-filter' + ;; accesses some buffer-local variables, for + ;; example 'comint-send-queue' and + ;; 'comint-end-queue'. If the current buffer is + ;; changed in the 'handler', the entities of + ;; these buffer-local variables is replaced, and + ;; corrupt successive behaviors." + + ;; The code hereafter fixes the problem. + (if handler - (setq handler - (funcall handler comint-errorp wait-p - message output last))) + (save-excursion + (setq handler + (funcall handler comint-errorp wait-p + message output last)))) + (if (and error handler no-insert comint-fix-error) (setq comint-send-queue (cons (list comint-fix-error t nil 'fix diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/comint-v18.el --- a/lisp/ilisp/comint-v18.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/comint-v18.el Mon Aug 13 08:46:56 2007 +0200 @@ -718,7 +718,7 @@ ;;; Typically, (lisp-mode) or (scheme-mode). ;;; ;;; If the command is given in a file buffer whose major modes is in -;;; SOURCE-MODES, then the filename is the default file, and the +;;; SOURCE-MODES, then the the filename is the default file, and the ;;; file's directory is the default directory. ;;; ;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/completer.el --- a/lisp/ilisp/completer.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/completer.el Mon Aug 13 08:46:56 2007 +0200 @@ -70,6 +70,9 @@ ;;; /u/mi/ /usr/misc/ ;;; + +(require 'cl) + ;;;%Globals ;;;%%Switches (defvar completer-load-hook nil @@ -124,6 +127,12 @@ (defvar completer-mode nil "Last completer mode.") (defvar completer-result nil "Last completer result.") +(eval-when (eval load compile) + (if (not (fboundp 'completion-display-completion-list-function)) + (setf completion-display-completion-list-function + 'display-completion-list))) + + ;;;%Utilities (defun completer-message (message &optional point) "Display MESSAGE at optional POINT for two seconds." @@ -738,7 +747,7 @@ ;;; (defun completer-new-cmd (cmd) - "Return t if we can't execute the old minibuffer version of CMD." + "Return T if we can't execute the old minibuffer version of CMD." (if (or completer-disable (let ((string (completer-minibuf-string))) (or diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/completer.lcd --- a/lisp/ilisp/completer.lcd Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2 +0,0 @@ -completer|Chris McConnell|ccm@cs.cmu.edu|Partial completion for commands -and pathname components.|92-03-17|3.03|katmandu.mt.cs.cmu.edu:/pub/ilisp/completer.el diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/completer.new.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/completer.new.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,1013 @@ +;;; -*-Emacs-Lisp-*- +;;;%Header +;;; +;;; Rcs_Info: completer.el,v 3.23 1993/09/03 02:05:07 ivan Rel $ +;;; +;;; Partial completion mechanism for GNU Emacs. Version 3.03 +;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu. +;;; Thanks to Bjorn Victor for suggestions, testing, and patches for +;;; file completion. + +;;; This file is part of GNU Emacs. + +;;; GNU Emacs 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 works at all, +;;; unless he says so in writing. Refer to the GNU Emacs General Public +;;; License for full details. +;;; Everyone is granted permission to copy, modify and redistribute +;;; GNU Emacs, but only under the conditions described in the +;;; GNU Emacs General Public License. A copy of this license is +;;; supposed to have been given to you along with GNU Emacs so you +;;; can know your rights and responsibilities. It should be in a +;;; file named COPYING. Among other things, the copyright notice +;;; and this notice must be preserved on all copies. + +;;; When loaded, this file extends the standard completion mechanisms +;;; so that they perform pattern matching completions. There is also +;;; an interface that allows it to be used by other programs. The +;;; completion rules are: +;;; +;;; 1) If what has been typed matches any possibility, do normal +;;; completion. +;;; +;;; 2) Otherwise, generate a regular expression such that +;;; completer-words delimit words and generate all possible matches. +;;; The variable completer-any-delimiter can be set to a character +;;; that matches any delimiter. If it were " ", then "by d" would be +;;; byte-recompile-directory. If completer-use-words is T, a match is +;;; unique if it is the only one with the same number of words. If +;;; completer-use-words is NIL, a match is unique if it is the only +;;; possibility. If you ask the completer to use its best guess, it +;;; will be the shortest match of the possibilities unless +;;; completer-exact is T. +;;; +;;; 3) For filenames, if completer-complete-filenames is T, each +;;; pathname component will be individually completed, otherwise only +;;; the final component will be completed. If you are using a +;;; distributed file system like afs, you may want to set up a +;;; symbolic link in your home directory or add pathname components to +;;; completer-file-skip so that the pathname components that go across +;;; machines do not get expanded. +;;; +;;; SPACE, TAB, LFD, RET, and ? do normal completion if possible +;;; otherwise they do partial completion. In addition, C-DEL will +;;; undo the last partial expansion or contraction. M-RET will always +;;; complete to the current match before returning. This is useful +;;; when any string is possible, but you want to complete to a string +;;; as when calling find-file. The bindings can be changed by using +;;; completer-load-hook. +;;; +;;; Modes that use comint-dynamic-complete (like cmushell and ilisp) +;;; will also do partial completion as will M-tab in Emacs LISP. +;;; +;;; Examples: +;;; a-f auto-fill-mode +;;; b--d *beginning-of-defun or byte-recompile-directory +;;; by d *byte-recompile-directory if completer-any-delimiter is " " +;;; ~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc +;;; /u/mi/ /usr/misc/ +;;; + +;;;%Globals +;;;%%Switches +(defvar completer-load-hook nil + "Hook called when minibuffer partial completion is loaded.") + +(defvar completer-disable nil + "*If T, turn off partial completion. Use the command +\\[completer-toggle] to set this.") + +(defvar completer-complete-filenames t + "*If T, then each component of a filename will be completed, +otherwise just the final component will be completed.") + +(defvar completer-use-words nil ; jwz: this is HATEFUL! + "*If T, then prefer completions with the same number of words as the +pattern.") + +(defvar completer-words "---. <" + "*Delimiters used in partial completions. It should be a set of +characters suitable for inclusion in a [] regular expression.") + +(defvar completer-any-delimiter nil + "*If a character, then a delimiter in the pattern that matches the +character will match any delimiter in completer-words.") + +(defvar completer-file-skip "^cs/$\\|@sys\\|.edu/$\\|.gov/$\\|.com/$\\|:/$" + "*Regular expression for pathname components to not complete.") + +(defvar completer-exact nil + "*If T, then you must have an exact match. Otherwise, the shortest +string that matches the pattern will be used.") + +(defvar completer-cache-size 100 + "*Size of cache to use for partially completed pathnames.") + +(defvar completer-use-cache t + "*Set to nil to disable the partially completed pathname cache.") + +;;;%%Internal +(defvar completer-last-pattern "" + "The last pattern expanded.") + +(defvar completer-message nil + "T if temporary message was just displayed.") + +(defvar completer-path-cache nil + "Cache of (path . choices) for completer.") + +(defvar completer-string nil "Last completer string.") +(defvar completer-table nil "Last completer table.") +(defvar completer-pred nil "Last completer pred.") +(defvar completer-mode nil "Last completer mode.") +(defvar completer-result nil "Last completer result.") + +;;;%Utilities +(defun completer-message (message &optional point) + "Display MESSAGE at optional POINT for two seconds." + (setq point (or point (point-max)) + completer-message t) + (let ((end + (save-excursion + (goto-char point) + (insert message) + (point))) + (inhibit-quit t)) + (sit-for 2) + (delete-region point end) + (if (and quit-flag + ;;(not (eq 'lucid-19 ilisp-emacs-version-id)) + (not (string-match "Lucid" emacs-version)) + ) + (setq quit-flag nil + unread-command-char 7)))) + +;;; +(defun completer-deleter (regexp choices &optional keep) + "Destructively remove strings that match REGEXP in CHOICES and +return the modified list. If optional KEEP, then keep entries that +match regexp." + (let* ((choiceb choices) + choicep) + (if keep + (progn + (while (and choiceb (not (string-match regexp (car choiceb)))) + (setq choiceb (cdr choiceb))) + (setq choicep choiceb) + (while (cdr choicep) + (if (string-match regexp (car (cdr choicep))) + (setq choicep (cdr choicep)) + (rplacd choicep (cdr (cdr choicep)))))) + (while (and choiceb (string-match regexp (car choiceb))) + (setq choiceb (cdr choiceb))) + (setq choicep choiceb) + (while (cdr choicep) + (if (string-match regexp (car (cdr choicep))) + (rplacd choicep (cdr (cdr choicep))) + (setq choicep (cdr choicep))))) + choiceb)) + +;;;%%Regexp +(defun completer-regexp (string delimiters any) + "Convert STRING into a regexp with words delimited by characters in +DELIMITERS. Any delimiter in STRING that is the same as ANY will +match any delimiter." + (let* ((delimiter-reg (concat "[" delimiters "]")) + (limit (length string)) + (pos 0) + (regexp "^")) + (while (and (< pos limit) (string-match delimiter-reg string pos)) + (let* ((begin (match-beginning 0)) + (end (match-end 0)) + (delimiter (substring string begin end)) + (anyp (eq (elt string begin) any))) + (setq regexp + (format "%s%s[^%s]*%s" + regexp + (regexp-quote (substring string pos begin)) + (if anyp delimiters delimiter) + (if anyp delimiter-reg delimiter)) + pos end))) + (if (<= pos limit) + (setq regexp (concat regexp + (regexp-quote (substring string pos limit))))))) + +;;; +(defun completer-words (regexp string &optional limit) + "Return the number of words matching REGEXP in STRING up to LIMIT." + (setq limit (or limit 1000)) + (let ((count 1) + (pos 0)) + (while (and (string-match regexp string pos) (<= count limit)) + (setq count (1+ count) + pos (match-end 0))) + count)) + +;;;%Matcher +(defun completer-matches (string choices delimiters any) + "Return STRING's matches in CHOICES using DELIMITERS and wildcard +ANY to segment the strings." + (let* ((regexp (concat "[" delimiters "]")) + (from nil) + (to 0) + (pattern nil) + (len (length string)) + (matches nil) + sub sublen choice word wordlen pat) + ;; Segment pattern + (while (< (or from 0) len) + (setq to (or (string-match regexp string (if from (1+ from))) len)) + (if (eq (elt string (or from 0)) completer-any-delimiter) + (setq sub (substring string (if from (1+ from) 0) to) + sublen (- (length sub))) + (setq sub (substring string (or from 0) to) + sublen (length sub))) + (setq pattern (cons (cons sub sublen) pattern) + from to)) + (setq pattern (reverse pattern)) + ;; Find choices that match patterns + (setq regexp (concat "[" delimiters "]")) + (while choices + (setq choice (car choices) + word pattern + from 0) + (while (and word from + (let* (begin end) + (if (< (setq wordlen (cdr (setq pat (car word)))) 0) + (setq begin (1+ from) + end (+ begin (- wordlen))) + (setq begin from + end (+ begin wordlen))) + (and (<= end (length choice)) + (or (zerop wordlen) + (string-equal + (car pat) + (substring choice begin end)))))) + (setq from (string-match regexp choice + (if (and (zerop from) (zerop wordlen)) + from + (1+ from))) + word (cdr word))) + (if (not word) (setq matches (cons choice matches))) + (setq choices (cdr choices))) + matches)) + +;;; +(defun completer-choice (string choices delimiters use-words) + "Return the best match of STRING in CHOICES with DELIMITERS between +words and T if it is unique. A match is unique if it is the only +possibility or when USE-WORDS the only possibility with the same +number of words. The shortest string of multiple possiblities will be +the best match." + (or (if (null (cdr choices)) (cons (car choices) t)) + (let* ((regexp (concat "[^" delimiters "]*[" delimiters "]")) + (words (if use-words (completer-words regexp string))) + (choice choices) + (unique-p nil) + (match nil) + (match-count nil) + (match-len 1000)) + (while choice + (let* ((current (car choice)) + (length (length current))) + (if match-count + (if (= (completer-words regexp current words) words) + (progn + (setq unique-p nil) + (if (< length match-len) + (setq match current + match-len length)))) + (if (and use-words + (= (completer-words regexp current words) words)) + (setq match current + match-len length + match-count t + unique-p t) + (if (< length match-len) + (setq match current + match-len length))))) + (setq choice (cdr choice))) + (cons match unique-p)))) + +;;;%Completer +;;;%%Utilities +(defun completer-region (delimiters) + "Return the completion region bounded by characters in DELIMITERS +for the current buffer assuming that point is in it." + (cons (save-excursion (skip-chars-backward delimiters) (point)) + (save-excursion (skip-chars-forward delimiters) (point)))) + +;;; +(defun completer-last-component (string) + "Return the start of the last filename component in STRING." + (let ((last (1- (length string)) ) + (match 0) + (end 0)) + (while (and (setq match (string-match "/" string end)) (< match last)) + (setq end (1+ match))) + end)) + +;;; +(defun completer-match-record (string matches delimiters any dir mode) + "Return (match lcs choices unique) for STRING in MATCHES with +DELIMITERS or ANY wildcards and DIR if a filename when in MODE." + (let ((pattern (if dir + (substring string (completer-last-component string)) + string))) + (setq matches (completer-matches pattern matches delimiters any)) + (if (cdr matches) + (let ((match + (if (not completer-exact) + (completer-choice + pattern matches delimiters completer-use-words))) + (lcs (concat dir (try-completion "" (mapcar 'list matches))))) + (list (if match (concat dir (car match))) + lcs + matches (cdr match))) + (if matches + (let ((match (concat dir (car matches)))) + (list match match matches t)) + (list nil nil nil nil))))) + +;;;%%Complete file +(defun completer-extension-regexp (extensions) + "Return a regexp that matches any of EXTENSIONS." + (let ((regexp "\\(")) + (while extensions + (setq regexp (concat regexp (car extensions) + (if (cdr extensions) "\\|")) + extensions (cdr extensions))) + (concat regexp "\\)$"))) + +;;; +(defun completer-flush () + "Flush completer's pathname cache." + (interactive) + (setq completer-path-cache nil)) + +;;; +(defun completer-cache (path pred words any mode) + "Check to see if PATH is in path cache with PRED, WORDS, ANY and +MODE." + (let* ((last nil) + (ptr completer-path-cache) + (size 0) + (result nil)) + (if completer-use-cache + (while ptr + (let ((current (car (car ptr)))) + (if (string-equal current path) + (progn + (if last + (progn + (rplacd last (cdr ptr)) + (rplacd ptr completer-path-cache) + (setq completer-path-cache ptr))) + (setq result (cdr (car ptr)) + ptr nil)) + (if (cdr ptr) (setq last ptr)) + (setq size (1+ size) + ptr (cdr ptr)))))) + (or result + (let* ((choices + (completer path 'read-file-name-internal pred words any + mode t))) + (if (and (or (car (cdr (cdr (cdr choices)))) + (string= path (car choices))) + (eq (elt (car choices) (1- (length (car choices)))) ?/)) + (progn + (if (>= size completer-cache-size) (rplacd last nil)) + (setq completer-path-cache + (cons (cons path choices) completer-path-cache)))) + choices)))) + +;;; +(defun completer-file (string pred words any mode) + "Return (match common-substring matches unique-p) for STRING using +read-file-name-internal for choices that pass PRED using WORDS to +delimit words. Optional ANY is a delimiter that matches any of the +delimiters in WORD. If optional MODE is nil or 'help then possible +matches will always be returned." + (let* ((case-fold-search completion-ignore-case) + (last (and (eq mode 'exit-ok) (completer-last-component string))) + (position + ;; Special hack for CMU RFS filenames + (if (string-match "^/\\.\\./[^/]*/" string) + (match-end 0) + (string-match "[^~/]" string))) + (new (substring string 0 position)) + (user (if (string= new "~") + (setq new (file-name-directory (expand-file-name new))))) + (words (concat words "/")) + (len (length string)) + (choices nil) + end + (old-choices (list nil nil nil nil))) + (while position + (let* ((begin (string-match "/" string position)) + (exact-p nil)) + (setq end (if begin (match-end 0)) + choices + ;; Ends with a /, so check files in directory + (if (and (memq mode '(nil help)) (= position len)) + (completer-match-record + "" + ;; This assumes that .. and . come at the end + (let* ((choices + (all-completions new 'read-file-name-internal)) + (choicep choices)) + (if (string= (car choicep) "../") + (cdr (cdr choicep)) + (while (cdr choicep) + (if (string= (car (cdr choicep)) "../") + (rplacd choicep nil)) + (setq choicep (cdr choicep))) + choices)) + words any new mode) + (if (eq position last) + (let ((new (concat new (substring string position)))) + (list new new nil t)) + (let ((component (substring string position end))) + (if (and end + (string-match completer-file-skip component)) + ;; Assume component is complete + (list (concat new component) + (concat new component) + nil t) + (completer-cache + (concat new component) + pred words any mode)))))) + ;; Keep going if unique or we match exactly + (if (or (car (cdr (cdr (cdr choices)))) + (setq exact-p + (string= (concat new (substring string position end)) + (car choices)))) + (setq old-choices + (let* ((lcs (car (cdr choices))) + (matches (car (cdr (cdr choices)))) + (slash (and lcs (string-match "/$" lcs)))) + (list nil + (if slash (substring lcs 0 slash) lcs) + (if (and (cdr matches) + (or (eq mode 'help) (not exact-p))) + matches) + nil)) + new (car choices) + position end) + ;; Its ok to not match user names because they may be in + ;; different root directories + (if (and (= position 1) (= (elt string 0) ?~)) + (setq new (substring string 0 end) + choices (list new new (list new) t) + user nil + position end) + (setq position nil))))) + (if (not (car choices)) + (setq choices old-choices)) + (if (and (car choices) + (not (eq mode 'help)) + (not (car (cdr (cdr (cdr choices)))))) + ;; Try removing completion ignored extensions + (let* ((extensions + (completer-extension-regexp completion-ignored-extensions)) + (choiceb (car (cdr (cdr choices)))) + (choicep choiceb) + (isext nil) + (noext nil)) + (while choicep + (if (string-match extensions (car choicep)) + (setq isext t) + (setq noext t)) + (if (and isext noext) + ;; There are matches besides extensions + (setq choiceb (completer-deleter extensions choiceb) + choicep nil) + (setq choicep (cdr choicep)))) + (if (and isext noext) + (setq choices + (completer-match-record + (if end (substring string end) "") + choiceb words any + (file-name-directory (car (cdr choices))) + mode))))) + (if user + (let ((match (car choices)) + (lcs (car (cdr choices))) + (len (length user))) + (setq choices + (cons (if match (concat "~" (substring match len))) + (cons (if lcs (concat "~" (substring lcs len))) + (cdr (cdr choices))))))) + choices)) + +;;;%Exported program interface +;;;%%Completer +(defun completer (string table pred words + &optional any mode file-p) + "Return (match common-substring matches unique-p) for STRING in +TABLE for choices that pass PRED using WORDS to delimit words. If the +flag completer-complete-filenames is T and the table is +read-file-name-internal, then filename components will be individually +expanded. Optional ANY is a delimiter that can match any delimiter in +WORDS. Optional MODE is nil for complete, 'help for help and 'exit +for exit." + (if (and (stringp completer-string) + (string= string completer-string) + (eq table completer-table) + (eq pred completer-pred) + (not file-p) + (or (eq mode completer-mode) + (not (memq table '(read-file-name-internal + read-directory-name-internal))))) + completer-result + (setq + completer-string "" + completer-table table + completer-pred pred + completer-mode mode + completer-result + (if (and completer-complete-filenames + (not file-p) (eq table 'read-file-name-internal)) + (completer-file string pred words any mode) + (let* ((file-p (or file-p (eq table 'read-file-name-internal))) + (case-fold-search completion-ignore-case) + (pattern (concat "[" words "]")) + (component (if file-p (completer-last-component string))) + (dir (if component (substring string 0 component))) + (string (if dir (substring string component) string)) + (has-words (or (string-match pattern string) + (length string)))) + (if (and file-p (string-match "^\\$" string)) + ;; Handle environment variables + (let ((match + (getenv (substring string 1 + (string-match "/" string))))) + (if match (setq match (concat match "/"))) + (list match match (list match) match)) + (let* ((choices + (all-completions + (concat dir (substring string 0 has-words)) + table pred)) + (regexp (completer-regexp string words any))) + (if choices + (completer-match-record + string + (completer-deleter regexp choices t) + words any dir mode) + (list nil nil nil nil)))))) + completer-string string) + completer-result)) + +;;;%%Display choices +(defun completer-display-choices (choices &optional match message end + display) + "Display the list of possible CHOICES with optional MATCH, MESSAGE, +END and DISPLAY. If MATCH is non-nil, it will be flagged as the best +guess. If there are no choices, display MESSAGE. END is where to put +temporary messages. If DISPLAY is present then it will be called on +each possible completion and should return a string." + (if choices + (with-output-to-temp-buffer " *Completions*" + (if (cdr choices) + (display-completion-list + (sort + (if display + (let ((old choices) + (new nil)) + (while old + (setq new (cons (funcall display (car old)) new) + old (cdr old))) + new) + (copy-sequence choices)) + (function (lambda (x y) + (string-lessp (or (car-safe x) x) + (or (car-safe y) y))))))) + (if match + (save-excursion + (set-buffer " *Completions*") + (goto-char (point-min)) + (insert "Guess = " match (if (cdr choices) ", " ""))))) + (beep) + (completer-message (or message " (No completions)") end))) + +;;;%%Goto +(defun completer-goto (match lcs choices unique delimiters words + &optional mode display) + "MATCH is the best match, LCS is the longest common substring of all +of the matches. CHOICES is a list of the possibilities, UNIQUE +indicates if MATCH is unique. DELIMITERS are possible bounding +characters for the completion region. WORDS are the characters that +delimit the words for partial matches. Replace the region bounded by +delimiters with the match if unique and the lcs otherwise unless +optional MODE is 'help. Then go to the part of the string that +disambiguates choices using WORDS to separate words and display the +possibilities if the string was not extended. If optional DISPLAY is +present then it will be called on each possible completion and should +return a string." + (setq completer-message nil) + (let* ((region (completer-region delimiters)) + (start (car region)) + (end (cdr region)) + (string (buffer-substring start end)) + (file-p (string-match "[^ ]*\\(~\\|/\\|$\\)" string)) + (no-insert (eq mode 'help)) + (message t) + (new (not (string= (buffer-substring start (point)) lcs)))) + (if unique + (if no-insert + (progn + (goto-char end) + (completer-display-choices choices match nil end display)) + (if (string= string match) + (if (not file-p) + (progn (goto-char end) + (completer-message " (Sole completion)" end))) + (completer-insert match delimiters))) + ;;Not unique + (if lcs + (let* ((regexp + (concat "[" words (if file-p "/") "]")) + (words (completer-words regexp lcs)) + point) + ;; Go to where its ambiguous + (goto-char start) + (if (not no-insert) + (progn + (insert lcs) + (setq completer-last-pattern + (list string delimiters (current-buffer) start) + start (point) + end (+ end (length lcs))))) + ;; Skip to the first delimiter in the original string + ;; beyond the ambiguous point and keep from there on + (if (re-search-forward regexp end 'move words) + (progn + (if (and (not no-insert) match) + (let ((delimiter + (progn + (string-match lcs match) + (substring match (match-end 0) + (1+ (match-end 0)))))) + (if (string-match regexp delimiter) + (insert delimiter)))) + (forward-char -1))) + (if (not no-insert) + (progn + (setq end (- end (- (point) start))) + (delete-region start (point)))))) + (if choices + (if (or no-insert (not new)) + (completer-display-choices choices match nil end display)) + (if file-p + (progn + (if (not (= (point) end)) (forward-char 1)) + (if (not (save-excursion (re-search-forward "/" end t))) + (goto-char end)))) + (if message + (progn + (beep) + (completer-message (if no-insert + " (No completions)" + " (No match)") + end))))))) + +;;;%Exported buffer interface +;;;%%Complete and go +(defun completer-complete-goto (delimiters words table pred + &optional no-insert display) + "Complete the string bound by DELIMITERS using WORDS to bound words +for partial matches in TABLE with PRED and then insert the longest +common substring unless optional NO-INSERT and go to the point of +ambiguity. If optional DISPLAY, it will be called on each match when +possible completions are shown and should return a string." + (let* ((region (completer-region delimiters))) + (apply 'completer-goto + (append (completer (buffer-substring (car region) (cdr region)) + table pred words completer-any-delimiter + no-insert) + (list delimiters words no-insert display))))) + +;;;%%Undo +(defun completer-insert (match delimiters &optional buffer undo) + "Replace the region bounded with characters in DELIMITERS by MATCH +and save it so that it can be restored by completer-undo." + (let* ((region (completer-region delimiters)) + (start (car region)) + (end (cdr region))) + (if (and undo (or (not (= start undo)) + (not (eq (current-buffer) buffer)))) + (error "No previous pattern") + (setq completer-last-pattern (list (buffer-substring start end) + delimiters + (current-buffer) + start)) + (delete-region start end) + (goto-char start) + (insert match)))) + +;;; +(defun completer-undo () + "Swap the last expansion and the last match pattern." + (interactive) + (if completer-last-pattern + (apply 'completer-insert completer-last-pattern) + (error "No previous pattern"))) + +;;;%Minibuffer specific code +;;;%%Utilities +(defun completer-minibuf-string () + "Remove dead filename specs from the minibuffer as delimited by // +or ~ or $ and return the resulting string." + (save-excursion + (goto-char (point-max)) + (if (and (eq minibuffer-completion-table 'read-file-name-internal) + (re-search-backward "//\\|/~\\|.\\$" nil t)) + (delete-region (point-min) (1+ (point)))) + (buffer-substring (point-min) (point-max)))) + +;;; +(defun completer-minibuf-exit () + "Exit and clear pattern." + (interactive) + (setq completer-last-pattern nil) + (exit-minibuffer)) + +;;; +(defun completer-new-cmd (cmd) + "Return T if we can't execute the old minibuffer version of CMD." + (if (or completer-disable + (let ((string (completer-minibuf-string))) + (or + (not (string-match + (concat "[" completer-words "/~]") + string)) + (condition-case () + (let ((completion + (try-completion string + minibuffer-completion-table + minibuffer-completion-predicate))) + (if (eq minibuffer-completion-table + 'read-file-name-internal) + ;; Directories complete as themselves + (and completion + (or (not (string= string completion)) + (file-exists-p completion))) + completion)) + (error nil))))) + (progn + (funcall cmd) + nil) + t)) + +;;; +(defun completer-minibuf (&optional mode) + "Partial completion of minibuffer expressions. Optional MODE is +'help for help and 'exit for exit. + +If what has been typed so far matches any possibility normal +completion will be done. Otherwise, the string is considered to be a +pattern with words delimited by the characters in +completer-words. If completer-exact is T, the best match will be +the shortest one with the same number of words as the pattern if +possible and otherwise the shortest matching expression. If called +with a prefix, caching will be temporarily disabled. + +Examples: +a-f auto-fill-mode +r-e rmail-expunge +b--d *begining-of-defun or byte-recompile-directory +by d *byte-recompile-directory if completer-any-delimiter is \" \" +~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc +/u/mi/ /usr/misc/" + (interactive) + (append + (let ((completer-use-cache (not (or (not completer-use-cache) + current-prefix-arg)))) + (completer (completer-minibuf-string) + minibuffer-completion-table + minibuffer-completion-predicate + completer-words + completer-any-delimiter + mode)) + (list "^" completer-words mode))) + +;;;%%Commands +(defun completer-toggle () + "Turn partial completion on or off." + (interactive) + (setq completer-disable (not completer-disable)) + (message (if completer-disable + "Partial completion OFF" + "Partial completion ON"))) + +;;; +(defvar completer-old-help + (lookup-key minibuffer-local-must-match-map "?") + "Old binding of ? in minibuffer completion map.") +(defun completer-help () + "Partial completion minibuffer-completion-help. +See completer-minibuf for more information." + (interactive) + (if (completer-new-cmd completer-old-help) + (apply 'completer-goto (completer-minibuf 'help)))) + +;;; +(defvar completer-old-completer + (lookup-key minibuffer-local-must-match-map "\t") + "Old binding of TAB in minibuffer completion map.") +(defun completer-complete () + "Partial completion minibuffer-complete. +See completer-minibuf for more information." + (interactive) + (if (completer-new-cmd completer-old-completer) + (apply 'completer-goto (completer-minibuf)))) + +;;; +(defvar completer-old-word + (lookup-key minibuffer-local-must-match-map " ") + "Old binding of SPACE in minibuffer completion map.") +(defun completer-word () + "Partial completion minibuffer-complete. +See completer-minibuf for more information." + (interactive) + (if (eq completer-any-delimiter ?\ ) + (insert ?\ ) + (if (completer-new-cmd completer-old-word) + (apply 'completer-goto (completer-minibuf))))) + +;;; +(defvar completer-old-exit + (lookup-key minibuffer-local-must-match-map "\n") + "Old binding of RET in minibuffer completion map.") +(defun completer-exit () + "Partial completion minibuffer-complete-and-exit. +See completer-minibuf for more information." + (interactive) + (if (completer-new-cmd completer-old-exit) + (let* ((completions (completer-minibuf 'exit)) + (match (car completions)) + (unique-p (car (cdr (cdr (cdr completions)))))) + (apply 'completer-goto completions) + (if unique-p + (completer-minibuf-exit) + (if match + (progn (completer-insert match "^") + (if minibuffer-completion-confirm + (completer-message " (Confirm)") + (completer-minibuf-exit))) + (if (not completer-message) (beep))))))) + +;;; +(defun completer-match-exit () + "Exit the minibuffer with the current best match." + (interactive) + (let* ((completions (completer-minibuf 'exit)) + (guess (car completions))) + (if (not guess) + ;; OK if last filename component doesn't match + (setq completions (completer-minibuf 'exit-ok) + guess (car completions))) + (if guess + (progn + (goto-char (point-min)) + (insert guess) + (delete-region (point) (point-max)) + (exit-minibuffer)) + (apply 'completer-goto completions)))) + +;;;%%Keymaps +(define-key minibuffer-local-completion-map "\C-_" 'completer-undo) +(define-key minibuffer-local-completion-map "\t" 'completer-complete) +(define-key minibuffer-local-completion-map " " 'completer-word) +(define-key minibuffer-local-completion-map "?" 'completer-help) +(define-key minibuffer-local-completion-map "\n" 'completer-minibuf-exit) +(define-key minibuffer-local-completion-map "\r" 'completer-minibuf-exit) +(define-key minibuffer-local-completion-map "\M-\n" 'completer-match-exit) +(define-key minibuffer-local-completion-map "\M-\r" 'completer-match-exit) + +(define-key minibuffer-local-must-match-map "\C-_" 'completer-undo) +(define-key minibuffer-local-must-match-map "\t" 'completer-complete) +(define-key minibuffer-local-must-match-map " " 'completer-word) +(define-key minibuffer-local-must-match-map "\n" 'completer-exit) +(define-key minibuffer-local-must-match-map "\r" 'completer-exit) +(define-key minibuffer-local-must-match-map "?" 'completer-help) +(define-key minibuffer-local-must-match-map "\M-\n" 'completer-match-exit) +(define-key minibuffer-local-must-match-map "\M-\r" 'completer-match-exit) + +;;;%comint +(defun completer-comint-dynamic-list-completions (completions) + "List in help buffer sorted COMPLETIONS. +Typing SPC flushes the help buffer." + (completer-comint-dynamic-complete-1 nil 'help)) + +(defun completer-comint-dynamic-complete-filename () + "Dynamically complete the filename at point." + (completer-comint-dynamic-complete-1 nil t)) + +;;; +(defun completer-comint-dynamic-complete-1 (&optional undo mode) + "Complete the previous filename or display possibilities if done +twice in a row. If called with a prefix, undo the last completion." + (interactive "P") + (if undo + (completer-undo) + ;; added by jwz: don't cache completions in shell buffer! + (setq completer-string nil) + (let ((conf (current-window-configuration)));; lemacs change + (completer-complete-goto + "^ \t\n\"" + completer-words + 'read-file-name-internal + default-directory + mode) + ;; lemacs change + (if (eq mode 'help) (comint-restore-window-config conf)) + ))) +;(fset 'comint-dynamic-complete 'completer-comint-dynamic-complete) +(fset 'comint-dynamic-complete-filename + 'completer-comint-dynamic-complete-filename) +(fset 'comint-dynamic-list-completions + 'completer-comint-dynamic-list-completions) + +;;; Set the functions again if comint is loaded +(setq comint-load-hook + (cons (function (lambda () +;; (fset 'comint-dynamic-complete +;; 'completer-comint-dynamic-complete) + (fset 'comint-dynamic-complete-filename + 'completer-comint-dynamic-complete-filename) + (fset 'comint-dynamic-list-completions + 'completer-comint-dynamic-list-completions))) + (if (and (boundp 'comint-load-hook) comint-load-hook) + (if (consp comint-load-hook) + (if (eq (car comint-load-hook) 'lambda) + (list comint-load-hook) + comint-load-hook) + (list comint-load-hook))))) + +;;;%lisp-complete-symbol +(defun lisp-complete-symbol (&optional mode) + "Perform partial completion on Lisp symbol preceding point. That +symbol is compared against the symbols that exist and any additional +characters determined by what is there are inserted. If the symbol +starts just after an open-parenthesis, only symbols with function +definitions are considered. Otherwise, all symbols with function +definitions, values or properties are considered. If called with a +negative prefix, the last completion will be undone." + (interactive "P") + (if (< (prefix-numeric-value mode) 0) + (completer-undo) + (let* ((end (save-excursion (skip-chars-forward "^ \t\n)]}\"") (point))) + (beg (save-excursion + (backward-sexp 1) + (while (= (char-syntax (following-char)) ?\') + (forward-char 1)) + (point))) + (pattern (buffer-substring beg end)) + (predicate + (if (eq (char-after (1- beg)) ?\() + 'fboundp + (function (lambda (sym) + (or (boundp sym) (fboundp sym) + (symbol-plist sym)))))) + (completion (try-completion pattern obarray predicate))) + (cond ((eq completion t)) + ((null completion) + (completer-complete-goto + "^ \t\n\(\)[]{}'`" completer-words + obarray predicate + nil + (if (not (eq predicate 'fboundp)) + (function (lambda (choice) + (if (fboundp (intern choice)) + (list choice " ") + choice)))))) + ((not (string= pattern completion)) + (delete-region beg end) + (insert completion)) + (t + (message "Making completion list...") + (let ((list (all-completions pattern obarray predicate))) + (or (eq predicate 'fboundp) + (let (new) + (while list + (setq new (cons (if (fboundp (intern (car list))) + (list (car list) " ") + (car list)) + new)) + (setq list (cdr list))) + (setq list (nreverse new)))) + (with-output-to-temp-buffer "*Help*" + (display-completion-list + (sort list (function (lambda (x y) + (string-lessp + (or (car-safe x) x) + (or (car-safe y) y)))))))) + (message "Making completion list...%s" "done")))))) + +;;;%Hooks +(provide 'completer) +(run-hooks 'completer-load-hook) + diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/completer.no-fun.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/completer.no-fun.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,1013 @@ +;;; -*-Emacs-Lisp-*- +;;;%Header +;;; +;;; Rcs_Info: completer.el,v 3.23 1993/09/03 02:05:07 ivan Rel $ +;;; +;;; Partial completion mechanism for GNU Emacs. Version 3.03 +;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu. +;;; Thanks to Bjorn Victor for suggestions, testing, and patches for +;;; file completion. + +;;; This file is part of GNU Emacs. + +;;; GNU Emacs 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 works at all, +;;; unless he says so in writing. Refer to the GNU Emacs General Public +;;; License for full details. +;;; Everyone is granted permission to copy, modify and redistribute +;;; GNU Emacs, but only under the conditions described in the +;;; GNU Emacs General Public License. A copy of this license is +;;; supposed to have been given to you along with GNU Emacs so you +;;; can know your rights and responsibilities. It should be in a +;;; file named COPYING. Among other things, the copyright notice +;;; and this notice must be preserved on all copies. + +;;; When loaded, this file extends the standard completion mechanisms +;;; so that they perform pattern matching completions. There is also +;;; an interface that allows it to be used by other programs. The +;;; completion rules are: +;;; +;;; 1) If what has been typed matches any possibility, do normal +;;; completion. +;;; +;;; 2) Otherwise, generate a regular expression such that +;;; completer-words delimit words and generate all possible matches. +;;; The variable completer-any-delimiter can be set to a character +;;; that matches any delimiter. If it were " ", then "by d" would be +;;; byte-recompile-directory. If completer-use-words is T, a match is +;;; unique if it is the only one with the same number of words. If +;;; completer-use-words is NIL, a match is unique if it is the only +;;; possibility. If you ask the completer to use its best guess, it +;;; will be the shortest match of the possibilities unless +;;; completer-exact is T. +;;; +;;; 3) For filenames, if completer-complete-filenames is T, each +;;; pathname component will be individually completed, otherwise only +;;; the final component will be completed. If you are using a +;;; distributed file system like afs, you may want to set up a +;;; symbolic link in your home directory or add pathname components to +;;; completer-file-skip so that the pathname components that go across +;;; machines do not get expanded. +;;; +;;; SPACE, TAB, LFD, RET, and ? do normal completion if possible +;;; otherwise they do partial completion. In addition, C-DEL will +;;; undo the last partial expansion or contraction. M-RET will always +;;; complete to the current match before returning. This is useful +;;; when any string is possible, but you want to complete to a string +;;; as when calling find-file. The bindings can be changed by using +;;; completer-load-hook. +;;; +;;; Modes that use comint-dynamic-complete (like cmushell and ilisp) +;;; will also do partial completion as will M-tab in Emacs LISP. +;;; +;;; Examples: +;;; a-f auto-fill-mode +;;; b--d *beginning-of-defun or byte-recompile-directory +;;; by d *byte-recompile-directory if completer-any-delimiter is " " +;;; ~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc +;;; /u/mi/ /usr/misc/ +;;; + +;;;%Globals +;;;%%Switches +(defvar completer-load-hook nil + "Hook called when minibuffer partial completion is loaded.") + +(defvar completer-disable nil + "*If T, turn off partial completion. Use the command +\\[completer-toggle] to set this.") + +(defvar completer-complete-filenames t + "*If T, then each component of a filename will be completed, +otherwise just the final component will be completed.") + +(defvar completer-use-words nil ; jwz: this is HATEFUL! + "*If T, then prefer completions with the same number of words as the +pattern.") + +(defvar completer-words "---. <" + "*Delimiters used in partial completions. It should be a set of +characters suitable for inclusion in a [] regular expression.") + +(defvar completer-any-delimiter nil + "*If a character, then a delimiter in the pattern that matches the +character will match any delimiter in completer-words.") + +(defvar completer-file-skip "^cs/$\\|@sys\\|.edu/$\\|.gov/$\\|.com/$\\|:/$" + "*Regular expression for pathname components to not complete.") + +(defvar completer-exact nil + "*If T, then you must have an exact match. Otherwise, the shortest +string that matches the pattern will be used.") + +(defvar completer-cache-size 100 + "*Size of cache to use for partially completed pathnames.") + +(defvar completer-use-cache t + "*Set to nil to disable the partially completed pathname cache.") + +;;;%%Internal +(defvar completer-last-pattern "" + "The last pattern expanded.") + +(defvar completer-message nil + "T if temporary message was just displayed.") + +(defvar completer-path-cache nil + "Cache of (path . choices) for completer.") + +(defvar completer-string nil "Last completer string.") +(defvar completer-table nil "Last completer table.") +(defvar completer-pred nil "Last completer pred.") +(defvar completer-mode nil "Last completer mode.") +(defvar completer-result nil "Last completer result.") + +;;;%Utilities +(defun completer-message (message &optional point) + "Display MESSAGE at optional POINT for two seconds." + (setq point (or point (point-max)) + completer-message t) + (let ((end + (save-excursion + (goto-char point) + (insert message) + (point))) + (inhibit-quit t)) + (sit-for 2) + (delete-region point end) + (if (and quit-flag + ;;(not (eq 'lucid-19 ilisp-emacs-version-id)) + (not (string-match "Lucid" emacs-version)) + ) + (setq quit-flag nil + unread-command-char 7)))) + +;;; +(defun completer-deleter (regexp choices &optional keep) + "Destructively remove strings that match REGEXP in CHOICES and +return the modified list. If optional KEEP, then keep entries that +match regexp." + (let* ((choiceb choices) + choicep) + (if keep + (progn + (while (and choiceb (not (string-match regexp (car choiceb)))) + (setq choiceb (cdr choiceb))) + (setq choicep choiceb) + (while (cdr choicep) + (if (string-match regexp (car (cdr choicep))) + (setq choicep (cdr choicep)) + (rplacd choicep (cdr (cdr choicep)))))) + (while (and choiceb (string-match regexp (car choiceb))) + (setq choiceb (cdr choiceb))) + (setq choicep choiceb) + (while (cdr choicep) + (if (string-match regexp (car (cdr choicep))) + (rplacd choicep (cdr (cdr choicep))) + (setq choicep (cdr choicep))))) + choiceb)) + +;;;%%Regexp +(defun completer-regexp (string delimiters any) + "Convert STRING into a regexp with words delimited by characters in +DELIMITERS. Any delimiter in STRING that is the same as ANY will +match any delimiter." + (let* ((delimiter-reg (concat "[" delimiters "]")) + (limit (length string)) + (pos 0) + (regexp "^")) + (while (and (< pos limit) (string-match delimiter-reg string pos)) + (let* ((begin (match-beginning 0)) + (end (match-end 0)) + (delimiter (substring string begin end)) + (anyp (eq (elt string begin) any))) + (setq regexp + (format "%s%s[^%s]*%s" + regexp + (regexp-quote (substring string pos begin)) + (if anyp delimiters delimiter) + (if anyp delimiter-reg delimiter)) + pos end))) + (if (<= pos limit) + (setq regexp (concat regexp + (regexp-quote (substring string pos limit))))))) + +;;; +(defun completer-words (regexp string &optional limit) + "Return the number of words matching REGEXP in STRING up to LIMIT." + (setq limit (or limit 1000)) + (let ((count 1) + (pos 0)) + (while (and (string-match regexp string pos) (<= count limit)) + (setq count (1+ count) + pos (match-end 0))) + count)) + +;;;%Matcher +(defun completer-matches (string choices delimiters any) + "Return STRING's matches in CHOICES using DELIMITERS and wildcard +ANY to segment the strings." + (let* ((regexp (concat "[" delimiters "]")) + (from nil) + (to 0) + (pattern nil) + (len (length string)) + (matches nil) + sub sublen choice word wordlen pat) + ;; Segment pattern + (while (< (or from 0) len) + (setq to (or (string-match regexp string (if from (1+ from))) len)) + (if (eq (elt string (or from 0)) completer-any-delimiter) + (setq sub (substring string (if from (1+ from) 0) to) + sublen (- (length sub))) + (setq sub (substring string (or from 0) to) + sublen (length sub))) + (setq pattern (cons (cons sub sublen) pattern) + from to)) + (setq pattern (reverse pattern)) + ;; Find choices that match patterns + (setq regexp (concat "[" delimiters "]")) + (while choices + (setq choice (car choices) + word pattern + from 0) + (while (and word from + (let* (begin end) + (if (< (setq wordlen (cdr (setq pat (car word)))) 0) + (setq begin (1+ from) + end (+ begin (- wordlen))) + (setq begin from + end (+ begin wordlen))) + (and (<= end (length choice)) + (or (zerop wordlen) + (string-equal + (car pat) + (substring choice begin end)))))) + (setq from (string-match regexp choice + (if (and (zerop from) (zerop wordlen)) + from + (1+ from))) + word (cdr word))) + (if (not word) (setq matches (cons choice matches))) + (setq choices (cdr choices))) + matches)) + +;;; +(defun completer-choice (string choices delimiters use-words) + "Return the best match of STRING in CHOICES with DELIMITERS between +words and T if it is unique. A match is unique if it is the only +possibility or when USE-WORDS the only possibility with the same +number of words. The shortest string of multiple possiblities will be +the best match." + (or (if (null (cdr choices)) (cons (car choices) t)) + (let* ((regexp (concat "[^" delimiters "]*[" delimiters "]")) + (words (if use-words (completer-words regexp string))) + (choice choices) + (unique-p nil) + (match nil) + (match-count nil) + (match-len 1000)) + (while choice + (let* ((current (car choice)) + (length (length current))) + (if match-count + (if (= (completer-words regexp current words) words) + (progn + (setq unique-p nil) + (if (< length match-len) + (setq match current + match-len length)))) + (if (and use-words + (= (completer-words regexp current words) words)) + (setq match current + match-len length + match-count t + unique-p t) + (if (< length match-len) + (setq match current + match-len length))))) + (setq choice (cdr choice))) + (cons match unique-p)))) + +;;;%Completer +;;;%%Utilities +(defun completer-region (delimiters) + "Return the completion region bounded by characters in DELIMITERS +for the current buffer assuming that point is in it." + (cons (save-excursion (skip-chars-backward delimiters) (point)) + (save-excursion (skip-chars-forward delimiters) (point)))) + +;;; +(defun completer-last-component (string) + "Return the start of the last filename component in STRING." + (let ((last (1- (length string)) ) + (match 0) + (end 0)) + (while (and (setq match (string-match "/" string end)) (< match last)) + (setq end (1+ match))) + end)) + +;;; +(defun completer-match-record (string matches delimiters any dir mode) + "Return (match lcs choices unique) for STRING in MATCHES with +DELIMITERS or ANY wildcards and DIR if a filename when in MODE." + (let ((pattern (if dir + (substring string (completer-last-component string)) + string))) + (setq matches (completer-matches pattern matches delimiters any)) + (if (cdr matches) + (let ((match + (if (not completer-exact) + (completer-choice + pattern matches delimiters completer-use-words))) + (lcs (concat dir (try-completion "" (mapcar 'list matches))))) + (list (if match (concat dir (car match))) + lcs + matches (cdr match))) + (if matches + (let ((match (concat dir (car matches)))) + (list match match matches t)) + (list nil nil nil nil))))) + +;;;%%Complete file +(defun completer-extension-regexp (extensions) + "Return a regexp that matches any of EXTENSIONS." + (let ((regexp "\\(")) + (while extensions + (setq regexp (concat regexp (car extensions) + (if (cdr extensions) "\\|")) + extensions (cdr extensions))) + (concat regexp "\\)$"))) + +;;; +(defun completer-flush () + "Flush completer's pathname cache." + (interactive) + (setq completer-path-cache nil)) + +;;; +(defun completer-cache (path pred words any mode) + "Check to see if PATH is in path cache with PRED, WORDS, ANY and +MODE." + (let* ((last nil) + (ptr completer-path-cache) + (size 0) + (result nil)) + (if completer-use-cache + (while ptr + (let ((current (car (car ptr)))) + (if (string-equal current path) + (progn + (if last + (progn + (rplacd last (cdr ptr)) + (rplacd ptr completer-path-cache) + (setq completer-path-cache ptr))) + (setq result (cdr (car ptr)) + ptr nil)) + (if (cdr ptr) (setq last ptr)) + (setq size (1+ size) + ptr (cdr ptr)))))) + (or result + (let* ((choices + (completer path 'read-file-name-internal pred words any + mode t))) + (if (and (or (car (cdr (cdr (cdr choices)))) + (string= path (car choices))) + (eq (elt (car choices) (1- (length (car choices)))) ?/)) + (progn + (if (>= size completer-cache-size) (rplacd last nil)) + (setq completer-path-cache + (cons (cons path choices) completer-path-cache)))) + choices)))) + +;;; +(defun completer-file (string pred words any mode) + "Return (match common-substring matches unique-p) for STRING using +read-file-name-internal for choices that pass PRED using WORDS to +delimit words. Optional ANY is a delimiter that matches any of the +delimiters in WORD. If optional MODE is nil or 'help then possible +matches will always be returned." + (let* ((case-fold-search completion-ignore-case) + (last (and (eq mode 'exit-ok) (completer-last-component string))) + (position + ;; Special hack for CMU RFS filenames + (if (string-match "^/\\.\\./[^/]*/" string) + (match-end 0) + (string-match "[^~/]" string))) + (new (substring string 0 position)) + (user (if (string= new "~") + (setq new (file-name-directory (expand-file-name new))))) + (words (concat words "/")) + (len (length string)) + (choices nil) + end + (old-choices (list nil nil nil nil))) + (while position + (let* ((begin (string-match "/" string position)) + (exact-p nil)) + (setq end (if begin (match-end 0)) + choices + ;; Ends with a /, so check files in directory + (if (and (memq mode '(nil help)) (= position len)) + (completer-match-record + "" + ;; This assumes that .. and . come at the end + (let* ((choices + (all-completions new 'read-file-name-internal)) + (choicep choices)) + (if (string= (car choicep) "../") + (cdr (cdr choicep)) + (while (cdr choicep) + (if (string= (car (cdr choicep)) "../") + (rplacd choicep nil)) + (setq choicep (cdr choicep))) + choices)) + words any new mode) + (if (eq position last) + (let ((new (concat new (substring string position)))) + (list new new nil t)) + (let ((component (substring string position end))) + (if (and end + (string-match completer-file-skip component)) + ;; Assume component is complete + (list (concat new component) + (concat new component) + nil t) + (completer-cache + (concat new component) + pred words any mode)))))) + ;; Keep going if unique or we match exactly + (if (or (car (cdr (cdr (cdr choices)))) + (setq exact-p + (string= (concat new (substring string position end)) + (car choices)))) + (setq old-choices + (let* ((lcs (car (cdr choices))) + (matches (car (cdr (cdr choices)))) + (slash (and lcs (string-match "/$" lcs)))) + (list nil + (if slash (substring lcs 0 slash) lcs) + (if (and (cdr matches) + (or (eq mode 'help) (not exact-p))) + matches) + nil)) + new (car choices) + position end) + ;; Its ok to not match user names because they may be in + ;; different root directories + (if (and (= position 1) (= (elt string 0) ?~)) + (setq new (substring string 0 end) + choices (list new new (list new) t) + user nil + position end) + (setq position nil))))) + (if (not (car choices)) + (setq choices old-choices)) + (if (and (car choices) + (not (eq mode 'help)) + (not (car (cdr (cdr (cdr choices)))))) + ;; Try removing completion ignored extensions + (let* ((extensions + (completer-extension-regexp completion-ignored-extensions)) + (choiceb (car (cdr (cdr choices)))) + (choicep choiceb) + (isext nil) + (noext nil)) + (while choicep + (if (string-match extensions (car choicep)) + (setq isext t) + (setq noext t)) + (if (and isext noext) + ;; There are matches besides extensions + (setq choiceb (completer-deleter extensions choiceb) + choicep nil) + (setq choicep (cdr choicep)))) + (if (and isext noext) + (setq choices + (completer-match-record + (if end (substring string end) "") + choiceb words any + (file-name-directory (car (cdr choices))) + mode))))) + (if user + (let ((match (car choices)) + (lcs (car (cdr choices))) + (len (length user))) + (setq choices + (cons (if match (concat "~" (substring match len))) + (cons (if lcs (concat "~" (substring lcs len))) + (cdr (cdr choices))))))) + choices)) + +;;;%Exported program interface +;;;%%Completer +(defun completer (string table pred words + &optional any mode file-p) + "Return (match common-substring matches unique-p) for STRING in +TABLE for choices that pass PRED using WORDS to delimit words. If the +flag completer-complete-filenames is T and the table is +read-file-name-internal, then filename components will be individually +expanded. Optional ANY is a delimiter that can match any delimiter in +WORDS. Optional MODE is nil for complete, 'help for help and 'exit +for exit." + (if (and (stringp completer-string) + (string= string completer-string) + (eq table completer-table) + (eq pred completer-pred) + (not file-p) + (or (eq mode completer-mode) + (not (memq table '(read-file-name-internal + read-directory-name-internal))))) + completer-result + (setq + completer-string "" + completer-table table + completer-pred pred + completer-mode mode + completer-result + (if (and completer-complete-filenames + (not file-p) (eq table 'read-file-name-internal)) + (completer-file string pred words any mode) + (let* ((file-p (or file-p (eq table 'read-file-name-internal))) + (case-fold-search completion-ignore-case) + (pattern (concat "[" words "]")) + (component (if file-p (completer-last-component string))) + (dir (if component (substring string 0 component))) + (string (if dir (substring string component) string)) + (has-words (or (string-match pattern string) + (length string)))) + (if (and file-p (string-match "^\\$" string)) + ;; Handle environment variables + (let ((match + (getenv (substring string 1 + (string-match "/" string))))) + (if match (setq match (concat match "/"))) + (list match match (list match) match)) + (let* ((choices + (all-completions + (concat dir (substring string 0 has-words)) + table pred)) + (regexp (completer-regexp string words any))) + (if choices + (completer-match-record + string + (completer-deleter regexp choices t) + words any dir mode) + (list nil nil nil nil)))))) + completer-string string) + completer-result)) + +;;;%%Display choices +(defun completer-display-choices (choices &optional match message end + display) + "Display the list of possible CHOICES with optional MATCH, MESSAGE, +END and DISPLAY. If MATCH is non-nil, it will be flagged as the best +guess. If there are no choices, display MESSAGE. END is where to put +temporary messages. If DISPLAY is present then it will be called on +each possible completion and should return a string." + (if choices + (with-output-to-temp-buffer " *Completions*" + (if (cdr choices) + (display-completion-list + (sort + (if display + (let ((old choices) + (new nil)) + (while old + (setq new (cons (funcall display (car old)) new) + old (cdr old))) + new) + (copy-sequence choices)) + (function (lambda (x y) + (string-lessp (or (car-safe x) x) + (or (car-safe y) y))))))) + (if match + (save-excursion + (set-buffer " *Completions*") + (goto-char (point-min)) + (insert "Guess = " match (if (cdr choices) ", " ""))))) + (beep) + (completer-message (or message " (No completions)") end))) + +;;;%%Goto +(defun completer-goto (match lcs choices unique delimiters words + &optional mode display) + "MATCH is the best match, LCS is the longest common substring of all +of the matches. CHOICES is a list of the possibilities, UNIQUE +indicates if MATCH is unique. DELIMITERS are possible bounding +characters for the completion region. WORDS are the characters that +delimit the words for partial matches. Replace the region bounded by +delimiters with the match if unique and the lcs otherwise unless +optional MODE is 'help. Then go to the part of the string that +disambiguates choices using WORDS to separate words and display the +possibilities if the string was not extended. If optional DISPLAY is +present then it will be called on each possible completion and should +return a string." + (setq completer-message nil) + (let* ((region (completer-region delimiters)) + (start (car region)) + (end (cdr region)) + (string (buffer-substring start end)) + (file-p (string-match "[^ ]*\\(~\\|/\\|$\\)" string)) + (no-insert (eq mode 'help)) + (message t) + (new (not (string= (buffer-substring start (point)) lcs)))) + (if unique + (if no-insert + (progn + (goto-char end) + (completer-display-choices choices match nil end display)) + (if (string= string match) + (if (not file-p) + (progn (goto-char end) + (completer-message " (Sole completion)" end))) + (completer-insert match delimiters))) + ;;Not unique + (if lcs + (let* ((regexp + (concat "[" words (if file-p "/") "]")) + (words (completer-words regexp lcs)) + point) + ;; Go to where its ambiguous + (goto-char start) + (if (not no-insert) + (progn + (insert lcs) + (setq completer-last-pattern + (list string delimiters (current-buffer) start) + start (point) + end (+ end (length lcs))))) + ;; Skip to the first delimiter in the original string + ;; beyond the ambiguous point and keep from there on + (if (re-search-forward regexp end 'move words) + (progn + (if (and (not no-insert) match) + (let ((delimiter + (progn + (string-match lcs match) + (substring match (match-end 0) + (1+ (match-end 0)))))) + (if (string-match regexp delimiter) + (insert delimiter)))) + (forward-char -1))) + (if (not no-insert) + (progn + (setq end (- end (- (point) start))) + (delete-region start (point)))))) + (if choices + (if (or no-insert (not new)) + (completer-display-choices choices match nil end display)) + (if file-p + (progn + (if (not (= (point) end)) (forward-char 1)) + (if (not (save-excursion (re-search-forward "/" end t))) + (goto-char end)))) + (if message + (progn + (beep) + (completer-message (if no-insert + " (No completions)" + " (No match)") + end))))))) + +;;;%Exported buffer interface +;;;%%Complete and go +(defun completer-complete-goto (delimiters words table pred + &optional no-insert display) + "Complete the string bound by DELIMITERS using WORDS to bound words +for partial matches in TABLE with PRED and then insert the longest +common substring unless optional NO-INSERT and go to the point of +ambiguity. If optional DISPLAY, it will be called on each match when +possible completions are shown and should return a string." + (let* ((region (completer-region delimiters))) + (apply 'completer-goto + (append (completer (buffer-substring (car region) (cdr region)) + table pred words completer-any-delimiter + no-insert) + (list delimiters words no-insert display))))) + +;;;%%Undo +(defun completer-insert (match delimiters &optional buffer undo) + "Replace the region bounded with characters in DELIMITERS by MATCH +and save it so that it can be restored by completer-undo." + (let* ((region (completer-region delimiters)) + (start (car region)) + (end (cdr region))) + (if (and undo (or (not (= start undo)) + (not (eq (current-buffer) buffer)))) + (error "No previous pattern") + (setq completer-last-pattern (list (buffer-substring start end) + delimiters + (current-buffer) + start)) + (delete-region start end) + (goto-char start) + (insert match)))) + +;;; +(defun completer-undo () + "Swap the last expansion and the last match pattern." + (interactive) + (if completer-last-pattern + (apply 'completer-insert completer-last-pattern) + (error "No previous pattern"))) + +;;;%Minibuffer specific code +;;;%%Utilities +(defun completer-minibuf-string () + "Remove dead filename specs from the minibuffer as delimited by // +or ~ or $ and return the resulting string." + (save-excursion + (goto-char (point-max)) + (if (and (eq minibuffer-completion-table 'read-file-name-internal) + (re-search-backward "//\\|/~\\|.\\$" nil t)) + (delete-region (point-min) (1+ (point)))) + (buffer-substring (point-min) (point-max)))) + +;;; +(defun completer-minibuf-exit () + "Exit and clear pattern." + (interactive) + (setq completer-last-pattern nil) + (exit-minibuffer)) + +;;; +(defun completer-new-cmd (cmd) + "Return T if we can't execute the old minibuffer version of CMD." + (if (or completer-disable + (let ((string (completer-minibuf-string))) + (or + (not (string-match + (concat "[" completer-words "/~]") + string)) + (condition-case () + (let ((completion + (try-completion string + minibuffer-completion-table + minibuffer-completion-predicate))) + (if (eq minibuffer-completion-table + 'read-file-name-internal) + ;; Directories complete as themselves + (and completion + (or (not (string= string completion)) + (file-exists-p completion))) + completion)) + (error nil))))) + (progn + (funcall cmd) + nil) + t)) + +;;; +(defun completer-minibuf (&optional mode) + "Partial completion of minibuffer expressions. Optional MODE is +'help for help and 'exit for exit. + +If what has been typed so far matches any possibility normal +completion will be done. Otherwise, the string is considered to be a +pattern with words delimited by the characters in +completer-words. If completer-exact is T, the best match will be +the shortest one with the same number of words as the pattern if +possible and otherwise the shortest matching expression. If called +with a prefix, caching will be temporarily disabled. + +Examples: +a-f auto-fill-mode +r-e rmail-expunge +b--d *begining-of-defun or byte-recompile-directory +by d *byte-recompile-directory if completer-any-delimiter is \" \" +~/i.e *~/ilisp.el or ~/il-el.el or ~/ilisp.elc +/u/mi/ /usr/misc/" + (interactive) + (append + (let ((completer-use-cache (not (or (not completer-use-cache) + current-prefix-arg)))) + (completer (completer-minibuf-string) + minibuffer-completion-table + minibuffer-completion-predicate + completer-words + completer-any-delimiter + mode)) + (list "^" completer-words mode))) + +;;;%%Commands +(defun completer-toggle () + "Turn partial completion on or off." + (interactive) + (setq completer-disable (not completer-disable)) + (message (if completer-disable + "Partial completion OFF" + "Partial completion ON"))) + +;;; +(defvar completer-old-help + (lookup-key minibuffer-local-must-match-map "?") + "Old binding of ? in minibuffer completion map.") +(defun completer-help () + "Partial completion minibuffer-completion-help. +See completer-minibuf for more information." + (interactive) + (if (completer-new-cmd completer-old-help) + (apply 'completer-goto (completer-minibuf 'help)))) + +;;; +(defvar completer-old-completer + (lookup-key minibuffer-local-must-match-map "\t") + "Old binding of TAB in minibuffer completion map.") +(defun completer-complete () + "Partial completion minibuffer-complete. +See completer-minibuf for more information." + (interactive) + (if (completer-new-cmd completer-old-completer) + (apply 'completer-goto (completer-minibuf)))) + +;;; +(defvar completer-old-word + (lookup-key minibuffer-local-must-match-map " ") + "Old binding of SPACE in minibuffer completion map.") +(defun completer-word () + "Partial completion minibuffer-complete. +See completer-minibuf for more information." + (interactive) + (if (eq completer-any-delimiter ?\ ) + (insert ?\ ) + (if (completer-new-cmd completer-old-word) + (apply 'completer-goto (completer-minibuf))))) + +;;; +(defvar completer-old-exit + (lookup-key minibuffer-local-must-match-map "\n") + "Old binding of RET in minibuffer completion map.") +(defun completer-exit () + "Partial completion minibuffer-complete-and-exit. +See completer-minibuf for more information." + (interactive) + (if (completer-new-cmd completer-old-exit) + (let* ((completions (completer-minibuf 'exit)) + (match (car completions)) + (unique-p (car (cdr (cdr (cdr completions)))))) + (apply 'completer-goto completions) + (if unique-p + (completer-minibuf-exit) + (if match + (progn (completer-insert match "^") + (if minibuffer-completion-confirm + (completer-message " (Confirm)") + (completer-minibuf-exit))) + (if (not completer-message) (beep))))))) + +;;; +(defun completer-match-exit () + "Exit the minibuffer with the current best match." + (interactive) + (let* ((completions (completer-minibuf 'exit)) + (guess (car completions))) + (if (not guess) + ;; OK if last filename component doesn't match + (setq completions (completer-minibuf 'exit-ok) + guess (car completions))) + (if guess + (progn + (goto-char (point-min)) + (insert guess) + (delete-region (point) (point-max)) + (exit-minibuffer)) + (apply 'completer-goto completions)))) + +;;;%%Keymaps +(define-key minibuffer-local-completion-map "\C-_" 'completer-undo) +(define-key minibuffer-local-completion-map "\t" 'completer-complete) +(define-key minibuffer-local-completion-map " " 'completer-word) +(define-key minibuffer-local-completion-map "?" 'completer-help) +(define-key minibuffer-local-completion-map "\n" 'completer-minibuf-exit) +(define-key minibuffer-local-completion-map "\r" 'completer-minibuf-exit) +(define-key minibuffer-local-completion-map "\M-\n" 'completer-match-exit) +(define-key minibuffer-local-completion-map "\M-\r" 'completer-match-exit) + +(define-key minibuffer-local-must-match-map "\C-_" 'completer-undo) +(define-key minibuffer-local-must-match-map "\t" 'completer-complete) +(define-key minibuffer-local-must-match-map " " 'completer-word) +(define-key minibuffer-local-must-match-map "\n" 'completer-exit) +(define-key minibuffer-local-must-match-map "\r" 'completer-exit) +(define-key minibuffer-local-must-match-map "?" 'completer-help) +(define-key minibuffer-local-must-match-map "\M-\n" 'completer-match-exit) +(define-key minibuffer-local-must-match-map "\M-\r" 'completer-match-exit) + +;;;%comint +(defun completer-comint-dynamic-list-completions (completions) + "List in help buffer sorted COMPLETIONS. +Typing SPC flushes the help buffer." + (completer-comint-dynamic-complete-1 nil 'help)) + +(defun completer-comint-dynamic-complete-filename () + "Dynamically complete the filename at point." + (completer-comint-dynamic-complete-1 nil t)) + +;;; +(defun completer-comint-dynamic-complete-1 (&optional undo mode) + "Complete the previous filename or display possibilities if done +twice in a row. If called with a prefix, undo the last completion." + (interactive "P") + (if undo + (completer-undo) + ;; added by jwz: don't cache completions in shell buffer! + (setq completer-string nil) + (let ((conf (current-window-configuration)));; lemacs change + (completer-complete-goto + "^ \t\n\"" + completer-words + 'read-file-name-internal + default-directory + mode) + ;; lemacs change + (if (eq mode 'help) (comint-restore-window-config conf)) + ))) +;(fset 'comint-dynamic-complete 'completer-comint-dynamic-complete) +(fset 'comint-dynamic-complete-filename + 'completer-comint-dynamic-complete-filename) +(fset 'comint-dynamic-list-completions + 'completer-comint-dynamic-list-completions) + +;;; Set the functions again if comint is loaded +(setq comint-load-hook + (cons (function (lambda () +;; (fset 'comint-dynamic-complete +;; 'completer-comint-dynamic-complete) + (fset 'comint-dynamic-complete-filename + 'completer-comint-dynamic-complete-filename) + (fset 'comint-dynamic-list-completions + 'completer-comint-dynamic-list-completions))) + (if (and (boundp 'comint-load-hook) comint-load-hook) + (if (consp comint-load-hook) + (if (eq (car comint-load-hook) 'lambda) + (list comint-load-hook) + comint-load-hook) + (list comint-load-hook))))) + +;;;%lisp-complete-symbol +(defun lisp-complete-symbol (&optional mode) + "Perform partial completion on Lisp symbol preceding point. That +symbol is compared against the symbols that exist and any additional +characters determined by what is there are inserted. If the symbol +starts just after an open-parenthesis, only symbols with function +definitions are considered. Otherwise, all symbols with function +definitions, values or properties are considered. If called with a +negative prefix, the last completion will be undone." + (interactive "P") + (if (< (prefix-numeric-value mode) 0) + (completer-undo) + (let* ((end (save-excursion (skip-chars-forward "^ \t\n)]}\"") (point))) + (beg (save-excursion + (backward-sexp 1) + (while (= (char-syntax (following-char)) ?\') + (forward-char 1)) + (point))) + (pattern (buffer-substring beg end)) + (predicate + (if (eq (char-after (1- beg)) ?\() + 'fboundp + (function (lambda (sym) + (or (boundp sym) (fboundp sym) + (symbol-plist sym)))))) + (completion (try-completion pattern obarray predicate))) + (cond ((eq completion t)) + ((null completion) + (completer-complete-goto + "^ \t\n\(\)[]{}'`" completer-words + obarray predicate + nil + (if (not (eq predicate 'fboundp)) + (function (lambda (choice) + (if (fboundp (intern choice)) + (list choice " ") + choice)))))) + ((not (string= pattern completion)) + (delete-region beg end) + (insert completion)) + (t + (message "Making completion list...") + (let ((list (all-completions pattern obarray predicate))) + (or (eq predicate 'fboundp) + (let (new) + (while list + (setq new (cons (if (fboundp (intern (car list))) + (list (car list) " ") + (car list)) + new)) + (setq list (cdr list))) + (setq list (nreverse new)))) + (with-output-to-temp-buffer "*Help*" + (display-completion-list + (sort list (function (lambda (x y) + (string-lessp + (or (car-safe x) x) + (or (car-safe y) y)))))))) + (message "Making completion list...%s" "done")))))) + +;;;%Hooks +(provide 'completer) +(run-hooks 'completer-load-hook) + diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilcompat.el --- a/lisp/ilisp/ilcompat.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilcompat.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilcompat.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -24,19 +25,28 @@ ;;; Global definitions/declarations (defconst +ilisp-emacs-version-id+ - (cond ((string-match "XEmacs" emacs-version) - 'xemacs) - ((string-match "Lucid" emacs-version) - (if (string-match "^19.[0-7][^0-9]" emacs-version) - 'lucid-19 - 'lucid-19-new)) - ((string-match "^19" emacs-version) - 'fsf-19) - (t 'fsf-18)) + (cond ((string-match "XEmacs" emacs-version) + 'xemacs) + ((string-match "Lucid" emacs-version) + (if (string-match "^19.[0-7][^0-9]" emacs-version) + 'lucid-19 + 'lucid-19-new)) + ((string-match "^19" emacs-version) + 'fsf-19) + (t 'fsf-18)) "The version of Emacs ILISP is running in. -Declared as '(member fsf-19 fsf-19 lucid-19 lucid-19-new xemacs. +Declared as '(member fsf-19 fsf-19 lucid-19 lucid-19-new xemacs). Set in ilcompat.el.") +(defconst +ilisp-emacs-minor-version-number+ + (cond ((eq +ilisp-emacs-version-id+ 'fsf-18) 59) + ((or (eq +ilisp-emacs-version-id+ 'lucid-19) + (eq +ilisp-emacs-version-id+ 'lucid-19-new) + ) + 12) ; Does emacs-minor-version work? + ((eq +ilisp-emacs-version-id+ 'xemacs) 14) + (t emacs-minor-version))) + ;;;============================================================================ ;;; Code diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ild.mail --- a/lisp/ilisp/ild.mail Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ild.mail Mon Aug 13 08:46:56 2007 +0200 @@ -1,8 +1,8 @@ From @yonge.csri.toronto.edu:qobi@csri.toronto.edu Sun Jul 3 00:43:43 1994 From: Jeffrey Mark Siskind -To: rfb@lehman.com (Rick Busdiecker) +To: campbell@c2.net (Rick Campbell) Cc: marcoxa@cs.NYU.EDU -In-Reply-To: rfb@lehman.com's message of Wed, 29 Jun 1994 19:21:41 GMT +In-Reply-To: campbell@c2.net's message of Wed, 29 Jun 1994 19:21:41 GMT Subject: ILISP Reply-To: Qobi@CS.Toronto.EDU Date: Sun, 3 Jul 1994 00:43:19 -0400 diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilfsf18.el --- a/lisp/ilisp/ilfsf18.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilfsf18.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilfsf18.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilfsf19.el --- a/lisp/ilisp/ilfsf19.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilfsf19.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilfsf19.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-acl.el --- a/lisp/ilisp/ilisp-acl.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-acl.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-acl.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-aut.el --- a/lisp/ilisp/ilisp-aut.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-aut.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-aut.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-bat.el --- a/lisp/ilisp/ilisp-bat.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-bat.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-bat.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-bug.el --- a/lisp/ilisp/ilisp-bug.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-bug.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-bug.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-chs.el --- a/lisp/ilisp/ilisp-chs.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-chs.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-chs.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -24,7 +25,6 @@ ;;; CLISP Common Lisp by Bruno Haible and XX Stoll dialect definition ;;; -;;;%%%KCL--these dialects by Tom Emerson ;;; clisp-hs-check-prompt doesn't after the first break because the ;;; number of ">" characters doesn't increase. diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-cl.el --- a/lisp/ilisp/ilisp-cl.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-cl.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-cl.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -29,7 +30,7 @@ (defvar ilisp-cl-ilisp-package-file "ilisp-pkg.lisp") -(defvar ilisp-clisp-init-file "clisp.lisp") +(defvar ilisp-clisp-init-file "cl-ilisp.lisp") (defdialect clisp "Common LISP" ilisp diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-cmp.el --- a/lisp/ilisp/ilisp-cmp.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-cmp.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-cmp.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-cmt.el --- a/lisp/ilisp/ilisp-cmt.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-cmt.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-cmt.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-cmu.el --- a/lisp/ilisp/ilisp-cmu.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-cmu.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-cmu.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -83,4 +84,7 @@ comint-interrupt-regexp "Interrupted at" - ilisp-binary-extension "sparcf")) + ilisp-binary-extension "sparcf" + ilisp-init-binary-extension "sparcf" + ilisp-binary-command "\"sparcf\"" + )) diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-cpat.el --- a/lisp/ilisp/ilisp-cpat.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-cpat.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-cpat.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-def.el --- a/lisp/ilisp/ilisp-def.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-def.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-def.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -262,7 +263,7 @@ ;;;%%%Misc (deflocal ilisp-use-map nil "Keymap to use in ILISP mode.") -(defvar ilisp-bugs-to "ilisp@lehman.com" "Who to send bug reports to.") +(defvar ilisp-bugs-to "ilisp@naggum.no" "Who to send bug reports to.") (defvar ilisp-modes '(ilisp-mode) "List of all inferior ilisp modes.") (defvar lisp-source-modes '(lisp-mode scheme-mode) @@ -285,7 +286,7 @@ (defvar ilisp-epoch-running (and (boundp 'epoch::version) epoch::version) "Non-nil if epoch is running.") (defvar ilisp-version - "5.7" ;; ILISP-VERSION marker + "5.8" ;; ILISP-VERSION marker "Interface version.") (defvar ilisp-directory nil "The directory that ilisp is found in.") (defvar ilisp-mode-map nil "Key map for ILISP.") diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-dia.el --- a/lisp/ilisp/ilisp-dia.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-dia.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-dia.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-doc.el --- a/lisp/ilisp/ilisp-doc.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-doc.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-doc.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -45,8 +46,12 @@ lucid kcl akcl + gcl + ecl ibcl cmulisp + clisp-hs + lispworks scheme oaklisp diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-el.el --- a/lisp/ilisp/ilisp-el.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-el.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-el.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-ext.el --- a/lisp/ilisp/ilisp-ext.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-ext.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-ext.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-hi.el --- a/lisp/ilisp/ilisp-hi.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-hi.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-hi.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-hlw.el --- a/lisp/ilisp/ilisp-hlw.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-hlw.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-hlw.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-hnd.el --- a/lisp/ilisp/ilisp-hnd.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-hnd.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-hnd.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-ind.el --- a/lisp/ilisp/ilisp-ind.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-ind.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-ind.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-inp.el --- a/lisp/ilisp/ilisp-inp.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-inp.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-inp.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-kcl.el --- a/lisp/ilisp/ilisp-kcl.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-kcl.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-kcl.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -43,8 +44,10 @@ ;;; (defdialect kcl "Kyoto Common LISP" clisp (setq comint-prompt-regexp "^>+" - ilisp-error-regexp "Error: " + ilisp-error-regexp "Error: [^\n]*" ilisp-binary-extension "o" + ilisp-init-binary-extension "o" + ilisp-binary-command "\"o\"" comint-fix-error ":q" comint-continue ":r" comint-prompt-status @@ -64,19 +67,36 @@ comint-interrupt-regexp ">>Condition: Terminal Interrupt" comint-continue ":q" ilisp-reset ":q!" - ilisp-error-regexp ">>Error:")) + ilisp-error-regexp ">>Error:[^\n]*")) (if (not ibcl-program) (setq ibcl-program "ibcl")) +;;; GCL and ECL (at least) have slightly different compilers and +;;; runtimes, hence we need to provide different extensions for their +;;; init files. +;;; Marco Antoniotti 19951028. + ;;; GCL -- I assume it is exactly as AKCL. ;;; Should check whether it is similar to IBUKI. -(defdialect gcl "GNU Common LISP" akcl) +(defdialect gcl "GNU Common LISP" akcl + (setq comint-prompt-regexp "^>+" + ilisp-binary-extension "o" + ilisp-init-binary-extension "gcl.o" + ilisp-binary-command "\"o\"" + ilisp-init-binary-command "\"gcl.o\"" + )) (if (not gcl-program) (setq gcl-program "gcl")) ;;; ECL -- Beppe Attardi's developments over AKCL -(defdialect ecl "EcoLisp Common LISP" akcl) -(if (not ecl-program) (setq gcl-program "ecl")) +(defdialect ecl "EcoLisp Common LISP" akcl + (setq comint-prompt-regexp "^>+" + ilisp-binary-extension "o" + ilisp-init-binary-extension "ecl.o" + ilisp-binary-command "\"o\"" + ilisp-init-binary-command "\"ecl.o\"" + )) +(if (not ecl-program) (setq ecl-program "ecl")) ;;; end of file -- ilisp-kcl.el -- diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-key.el --- a/lisp/ilisp/ilisp-key.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-key.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-key.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-kil.el --- a/lisp/ilisp/ilisp-kil.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-kil.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-kil.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-low.el --- a/lisp/ilisp/ilisp-low.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-low.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-low.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-luc.el --- a/lisp/ilisp/ilisp-luc.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-luc.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-luc.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-mak.el --- a/lisp/ilisp/ilisp-mak.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-mak.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-mak.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -29,7 +30,7 @@ (message "ILISP Compilation: starting.") -;;(require 'bytecomp) +;;(require 'byte-compile) (if (not (file-exists-p "ilcompat.el")) (error "ILISP Compilation: compatibility file 'ilcompat.el' non existent.") @@ -48,9 +49,9 @@ ;; Try to generate bytecodes for emacs 19. - ;; I am no expert on the Byte Compiler. ANyone who is please send + ;; I am no expert on the Byte Compiler. Anyone who is please send ;; me mail. - ;; Marco Antoniotti + ;; Marco Antoniotti (if (eq +ilisp-emacs-version-id+ 'fsf-18) (setq byte-compile-emacs18-compatibility t) @@ -114,10 +115,11 @@ ilisp-kcl ilisp-hlw ilisp-luc + ilisp-xls ilisp-sch ))) (while files - (byte-recompile-file (format "%s.el" (car files)) 0) + (byte-compile-file (format "%s.el" (car files)) 0) (load (format "%s" (car files))) (setq files (cdr files)))) diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-menu.el --- a/lisp/ilisp/ilisp-menu.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-menu.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-menu.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -21,39 +22,44 @@ -(require 'simple-menu) -(setplist 'lisp-command-menu nil) -(def-menu 'lisp-command-menu - "Lisp" - "These ILISP commands are available on the menu:" - '( - ("Break Interupt current lisp." - (progn (switch-to-lisp t) - (interrupt-subjob-ilisp))) - ("Doc Menu of commands to get help on variables, etc." - documentation-lisp-command-menu) - ("Xpand macroexpand-lisp." macroexpand-lisp) - ("Eval Eval the surrounding defun." eval-defun-lisp) - ("1E&G Eval defun and goto Inferior LISP." eval-defun-and-go-lisp) - ("; Comment the region." comment-region-lisp) - (") find-unbalanced-lisp parens." find-unbalanced-lisp) - ("] close-all-lisp parens that are open." close-all-lisp) - ("Trace Traces the previous function symbol." trace-lisp) - ) - ) +(cond ((or (string-match "XEmacs" emacs-version) + (string-match "Lucid" emacs-version))) + (t + -(setplist 'documentation-lisp-command-menu nil) -(def-menu 'documentation-lisp-command-menu - "Lisp help" - "These commands are available for examining Lisp structures:" - '( - ("UDoc Get user's documentation string." documentation-lisp) - ("Rglist Get the arglist for function." arglist-lisp) - ("Insp Inspect the current sexp." inspect-lisp) - ("1Insp Prompts for something to inspect." (inspect-lisp -4)) - ("Descr Describe the current sexp." describe-lisp) - ("1Descr Prompts for something to describe." (describe-lisp -4)) - ) - ) + (require 'simple-menu) + (setplist 'lisp-command-menu nil) + (def-menu 'lisp-command-menu + "Lisp" + "These ILISP commands are available on the menu:" + '( + ("Break Interupt current lisp." + (progn (switch-to-lisp t) + (interrupt-subjob-ilisp))) + ("Doc Menu of commands to get help on variables, etc." + documentation-lisp-command-menu) + ("Xpand macroexpand-lisp." macroexpand-lisp) + ("Eval Eval the surrounding defun." eval-defun-lisp) + ("1E&G Eval defun and goto Inferior LISP." eval-defun-and-go-lisp) + ("; Comment the region." comment-region-lisp) + (") find-unbalanced-lisp parens." find-unbalanced-lisp) + ("] close-all-lisp parens that are open." close-all-lisp) + ("Trace Traces the previous function symbol." trace-lisp) + ) + ) + + (setplist 'documentation-lisp-command-menu nil) + (def-menu 'documentation-lisp-command-menu + "Lisp help" + "These commands are available for examining Lisp structures:" + '( + ("UDoc Get user's documentation string." documentation-lisp) + ("Rglist Get the arglist for function." arglist-lisp) + ("Insp Inspect the current sexp." inspect-lisp) + ("1Insp Prompts for something to inspect." (inspect-lisp -4)) + ("Descr Describe the current sexp." describe-lisp) + ("1Descr Prompts for something to describe." (describe-lisp -4)) + ) + ))) (provide 'ilisp-menu) diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-mnb.el --- a/lisp/ilisp/ilisp-mnb.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-mnb.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-mnb.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -51,7 +52,10 @@ '("Macroexpand 1" . macroexpand-1-lisp)) (defkey-ilisp [menu-bar lisp set-package] - '("Set Buffer Package" . set-package-lisp)) + '("Set Lisp Package" . set-package-lisp)) + +(defkey-ilisp [menu-bar lisp set-buffer-package] + '("Set Buffer Package" . set-buffer-package-lisp)) (defkey-ilisp [menu-bar lisp arglist] '("Arglist" . arglist-lisp)) diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-mod.el --- a/lisp/ilisp/ilisp-mod.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-mod.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-mod.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -134,6 +135,7 @@ (funcall comint-update-status 'start) (if ilisp-motd (progn (lisp-display-output (format ilisp-motd ilisp-version)) + (sleep-for 3) (set-window-start (selected-window) start))) (if (not ilisp-prefix-match) (require 'completer))) (lisp-pop-to-buffer ilisp-buffer)) diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-mov.el --- a/lisp/ilisp/ilisp-mov.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-mov.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-mov.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-out.el --- a/lisp/ilisp/ilisp-out.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-out.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-out.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -260,7 +261,8 @@ (defun ilisp-find-lower-window (window) "Find the window directly below us, if any. This is probably the window from which enlarge-window would steal lines." - (if (< emacs-minor-version 12) + (if (or (not (string-match "XEmacs" emacs-version)) + (< emacs-minor-version 12)) (let* ((bottom (nth 3 (window-edges window))) (window* nil) (win window)) @@ -276,7 +278,8 @@ ;; XEmacs change -- There is now a primitive to do this. (defun ilisp-find-top-left-most-window () "Return the leftmost topmost window on the current screen." - (if (< emacs-minor-version 12) + (if (or (not (string-match "XEmacs" emacs-version)) + (< emacs-minor-version 12)) (let* ((window* (selected-window)) (edges* (window-edges window*)) (win nil) @@ -391,12 +394,17 @@ ;; First clear any existing typeout so as to not confuse the user. (or (eq (selected-window) (ilisp-output-window)) (ilisp-bury-output)) - ;; Patch suggested by hunter@work.nlm.nih.gov (Larry Hunter) + + ;; v5.7: Patch suggested by hunter@work.nlm.nih.gov (Larry Hunter) ;; If output contains '%', 'message' loses. ;; (message (ilisp-quote-%s output)) ;; An alternative here could be '(princ output)', as suggested by ;; Christopher Hoover - (princ output) + ;; (princ output) + + ;; v5.7b: Patch suggested by fujieda@jaist.ac.jp (Kazuhiro Fujieda) + ;; Best one for FSF Emacs 19.2[89]. + (message "%s" output) ) diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-pkg.lisp --- a/lisp/ilisp/ilisp-pkg.lisp Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-pkg.lisp Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-pkg.lisp -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -40,7 +41,21 @@ ;;; ILISP package -- -#-gcl +;;; +;;; GCL 2.2 doesn't have defpackage (yet) so we need to put the export +;;; here. (toy@rtp.ericsson.se) +;;; +;;; Please note that while the comment and the fix posted by Richard +;;; Toy are correct, they are deprecated by at least one of the ILISP +;;; maintainers. :) By removing the 'nil' in the following #+, you +;;; will fix the problem but will not do a good service to the CL +;;; community. The right thing to do is to install DEFPACKAGE in your +;;; GCL and to write the GCL maintainers and to ask them to +;;; incorporate DEFPACKAGE in their standard builds. +;;; Marco Antoniotti 19960715 +;;; + +#-(and nil gcl) (defpackage "ILISP" (:use "LISP" #+:CMU "CONDITIONS") ;; The following symbols should properly 'shadow' the inherited ;; ones. diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-prc.el --- a/lisp/ilisp/ilisp-prc.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-prc.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-prc.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-prn.el --- a/lisp/ilisp/ilisp-prn.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-prn.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-prn.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-rng.el --- a/lisp/ilisp/ilisp-rng.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-rng.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-rng.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-s2c.el --- a/lisp/ilisp/ilisp-s2c.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-s2c.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-s2c.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -21,7 +22,7 @@ ;From: Jeffrey Mark Siskind -;To: ilisp@lehman.com +;To: ilisp@naggum.no ;Subject: ILisp 5.5 and Scheme->C ;Reply-To: Qobi@cs.toronto.edu ;Date: Thu, 15 Dec 1994 22:55:05 -0500 diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-sch.el --- a/lisp/ilisp/ilisp-sch.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-sch.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-sch.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-snd.el --- a/lisp/ilisp/ilisp-snd.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-snd.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-snd.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-src.el --- a/lisp/ilisp/ilisp-src.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-src.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-src.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-sym.el --- a/lisp/ilisp/ilisp-sym.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-sym.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-sym.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-utl.el --- a/lisp/ilisp/ilisp-utl.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-utl.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-utl.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-val.el --- a/lisp/ilisp/ilisp-val.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-val.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-val.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-xfr.el --- a/lisp/ilisp/ilisp-xfr.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp-xfr.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp-xfr.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp-xls.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ilisp/ilisp-xls.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,46 @@ +;;; -*-Mode: Emacs-Lisp-*- + +;;; ilisp-xls.el -- + +;;; This file is part of ILISP. +;;; Version: 5.8 +;;; +;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell +;;; 1993, 1994 Ivan Vasquez +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell +;;; +;;; Other authors' names for which this Copyright notice also holds +;;; may appear later in this file. +;;; +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP +;;; mailing list were bugs and improvements are discussed. +;;; +;;; ILISP is freely redistributable under the terms found in the file +;;; COPYING. + +;;; +;;; ILISP Xlisp and Xlisp-Stat dialect definition +;;; + +;;; Thanks to John Walker for supplying this file. + + +(defdialect xlisp "Xlisp" ilisp + (setq ilisp-load-command "(load \"%s\")" + ilisp-last-command "*") + ) + +(if (not xlisp-program) (setq xlisp-program "xlisp")) + +;;;%%Xlisp-Stat + +(defdialect xlispstat "Xlisp-Stat" xlisp + (setq ilisp-binary-extension "fsl" + ;; ilisp-describe-command "(help %s)")) + )) + +(if (not xlispstat-program) (setq xlispstat-program "xlispstat")) + +;;; endo of file -- ilisp-xls.el -- diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp.el --- a/lisp/ilisp/ilisp.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; ilisp.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file @@ -22,9 +23,9 @@ ;;; Author: Chris McConnell -;;; Maintainer: The Net +;;; Maintainer: The Net ;;; Created: 14 Jun 1994 -;;; Version: 5.7 +;;; Version: 5.8 ;;; Keywords: lisp common-lisp scheme comint ;;; This file may become part of GNU Emacs in the near future. @@ -116,7 +117,9 @@ (load "comint-ipc") ;; This is optional -- used only by io-bridge-ilisp -(load "bridge") +(if (not (and (eq +ilisp-emacs-version-id+ 'fsf-19) + (>= +ilisp-emacs-minor-version-number+ 29))) + (load "bridge")) (if (load "ilisp-all.elc" t) t diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp.emacs --- a/lisp/ilisp/ilisp.emacs Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilisp.emacs Mon Aug 13 08:46:56 2007 +0200 @@ -3,13 +3,14 @@ ;;; ilisp.emacs -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the +;;; Send mail to 'ilisp-request@naggum.no' to be included in the ;;; ILISP mailing list. ;;; This file shows examples of some of the things you might want to @@ -79,6 +80,10 @@ (autoload 'gcl "ilisp" "Inferior GNU Common LISP." t) (autoload 'ecl "ilisp" "Inferior EcoLisp." t) +;;; Xlisp +(autoload 'xlisp "ilisp" "Inferior xlisp." t) +(autoload 'xlispstat "ilisp" "Inferior xlispstat." t) + ;;; Scheme's ;(autoload 'scheme "ilisp" "Inferior generic Scheme." t) ;(autoload 'oaklisp "ilisp" "Inferior Oaklisp Scheme." t) @@ -86,16 +91,24 @@ ;;; Define where LISP programs are found. (This may already be done ;;; at your site.) + ;(setq allegro-program "/usr/misc/.allegro/bin/cl") + ;(setq lucid-program "/usr/misc/.lucid/bin/lisp") -;(setq cmulisp-program "/usr/misc/.cmucl/bin/lisp") + ;(setq clisp-hs-program "clisp") + ;(setq lispworks-program "/somewhere/in/the/directory/tree/lispworks") + (setq cmulisp-program "/usr/robotics/shared/lang/cmu-cl/17e/bin/lisp") + (setq akcl-program "kcl") ;(setq gcl-program "gcl") ;(setq ecl-program "ecl") +;(setq xlisp-program "xlisp") +;(setq xlisp-program "xlispstat") + ;;; If you run cmu-cl then set this to where your source files are. (setq cmulisp-local-source-directory "/usr/robotics/shared/cmu-cl/17e/") diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilisp.lcd --- a/lisp/ilisp/ilisp.lcd Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -;;; LCD Archive Entry: -;;; ilisp|Chris McConnell| ilisp-request@lehman.com| -;;; Fancy LISP interface that supports multiple dialects.| -;;; 94-12-??|Version 5.7|ftp.cs.cmu.edu:/user/ai/lang/lisp/util/emacs/ilisp/v57/ilisp.tgz| diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/illuc19.el --- a/lisp/ilisp/illuc19.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/illuc19.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; illuc19.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/ilxemacs.el --- a/lisp/ilisp/ilxemacs.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/ilxemacs.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; illuc19.el -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/lispworks.lisp --- a/lisp/ilisp/lispworks.lisp Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/lispworks.lisp Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; lispworks.lisp -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/lucid.lisp --- a/lisp/ilisp/lucid.lisp Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/lucid.lisp Mon Aug 13 08:46:56 2007 +0200 @@ -3,17 +3,18 @@ ;;; lucid.lisp -- ;;; This file is part of ILISP. -;;; Version: 5.7 +;;; Version: 5.8 ;;; ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell ;;; 1993, 1994 Ivan Vasquez -;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker +;;; 1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker +;;; 1996 Marco Antoniotti and Rick Campbell ;;; ;;; Other authors' names for which this Copyright notice also holds ;;; may appear later in this file. ;;; -;;; Send mail to 'ilisp-request@lehman.com' to be included in the -;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP +;;; Send mail to 'ilisp-request@naggum.no' to be included in the +;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP ;;; mailing list were bugs and improvements are discussed. ;;; ;;; ILISP is freely redistributable under the terms found in the file diff -r 30df88044ec6 -r b82b59fe008d lisp/ilisp/scheme2c.mail --- a/lisp/ilisp/scheme2c.mail Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/ilisp/scheme2c.mail Mon Aug 13 08:46:56 2007 +0200 @@ -1,7 +1,7 @@ From @yonge.cs.toronto.edu:qobi@cs.toronto.edu Tue Nov 1 18:50:53 1994 From: Jeffrey Mark Siskind To: ebg@hip.atr.co.jp -Cc: ilisp@lehman.com +Cc: ilisp@naggum.no In-Reply-To: <9411012332.AA23484@hoshi> (message from Ed Gamble on Tue, 1 Nov 1994 18:32:03 -0500) Subject: Re: Scheme dialect init-files Reply-To: Qobi@cs.toronto.edu diff -r 30df88044ec6 -r b82b59fe008d lisp/iso/iso-acc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/iso/iso-acc.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,404 @@ +;;; iso-acc.el --- minor mode providing electric accent keys + +;; Copyright (C) 1993, 1994, 1996 Free Software Foundation, Inc. + +;; Author: Johan Vromans +;; Version: 1.7 (modified) +;; Maintainer: FSF +;; Keywords: i18n +;; Adapted for XEmacs 19.14 by Alexandre Oliva +;; Last update: Oct 10, 1996 + +;; 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: + +;; Function `iso-accents-mode' activates a minor mode in which +;; typewriter "dead keys" are emulated. The purpose of this emulation +;; is to provide a simple means for inserting accented characters +;; according to the ISO-8859-1 character set. +;; +;; In `iso-accents-mode', pseudo accent characters are used to +;; introduce accented keys. The pseudo-accent characters are: +;; +;; ' (minute) -> grave accent +;; ` (backtick) -> acute accent +;; " (second) -> diaeresis +;; ^ (caret) -> circumflex +;; ~ (tilde) -> tilde over the character +;; / (slash) -> slash through the character. +;; , (cedilla) -> cedilla under the character (except on default mode). +;; Also: /A is A-with-ring and /E is AE ligature. +;; +;; The action taken depends on the key that follows the pseudo accent. +;; In general: +;; +;; pseudo-accent + appropriate letter -> accented letter +;; pseudo-accent + space -> pseudo-accent (except for comma) +;; pseudo-accent + pseudo-accent -> accent (if available) +;; pseudo-accent + other -> pseudo-accent + other +;; +;; If the pseudo-accent is followed by anything else than a +;; self-insert-command, the dead-key code is terminated, the +;; pseudo-accent inserted 'as is' and the bell is rung to signal this. +;; +;; Function `iso-accents-mode' can be used to enable the iso accents +;; minor mode, or disable it. + +;; If you want only some of these characters to serve as accents, +;; add a language to `iso-languages' which specifies the accent characters +;; that you want, then select the language with `iso-accents-customize'. + +;;; Code: + +(provide 'iso-acc) + +;; needed for compatibility with XEmacs 19.14 +(if (fboundp 'read-event) () + (defun read-event () (event-key (next-command-event)))) + +;; needed to work on GNU Emacs (had to use this function on XEmacs) +(if (fboundp 'character-to-event) () + (defun character-to-event (ch &optional event console meta) ch)) + +;; needed for compatibility with XEmacs 19.14 and GNU Emacs 19.30 +(if (fboundp 'this-single-command-keys) () + (if (string-match "Lucid" (version)) + (defun this-single-command-keys () + (setq this-command (not (this-command-keys))) + (this-command-keys)) + (defun this-single-command-keys () (this-command-keys)))) + +(if (string-match "Lucid" (version)) + (progn + (global-set-key [quoted-insert-for-iso-acc] 'quoted-insert) + (defun iso-generate-char (char) + "inserts the octal representation of char into unread-command-events,\nand then returns the pseudo-key quoted-insert-for-iso-acc (which should be mapped to quoted-insert).\n\nCan be used in keymaps to generate characters from 128 to 255." + (setq unread-command-events + (append + (mapcar 'character-to-event (list + (+ 48 (/ char 64)) + (+ 48 (% (/ char 8) 8)) + (+ 48 (% char 8)))) + unread-command-events)) + [quoted-insert-for-iso-acc]) + ) + (defun iso-generate-char (char) + "Just returns a vector with the given character.\n\nNot necessary in the GNU Emacs implementation" + (vector char)) + ) + + +(defvar iso-languages + '(("portuguese" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?C . ?\307) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) + (?u . ?\372) (?c . ?\347) (?\ . ?') (space . ?')) + (?` (?A . ?\300) (?a . ?\340) (?\ . ?`) (space . ?`)) + (?^ (?A . ?\302) (?E . ?\312) (?O . ?\324) (?a . ?\342) (?e . ?\352) + (?o . ?\364) (?\ . ?^) (space . ?^)) + (?\" (?U . ?\334) (?u . ?\374) (?\ . ?\") (space . ?\")) + (?\~ (?A . ?\303) (?O . ?\325) (?a . ?\343) (?o . ?\365) (?\ . ?\~) (space . ?\~)) + (?, (?c . ?\347) (?C . ?\307))) + + ("irish" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) + (?\ . ?') (space . ?'))) + + ("french" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?C . ?\307) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) + (?u . ?\372) (?c . ?\347) (?\ . ?') (space . ?')) + (?` (?A . ?\300) (?E . ?\310) (?a . ?\340) (?e . ?\350) (?\ . ?`) (space . ?`)) + (?^ (?A . ?\302) (?E . ?\312) (?I . ?\316) (?O . ?\324) (?U . ?\333) + (?a . ?\342) (?e . ?\352) (?i . ?\356) (?o . ?\364) (?u . ?\373) + (?\ . ?^) (space . ?^)) + (?\" (?U . ?\334) (?u . ?\374) (?\ . ?\") (space . ?\")) + (?\~ (?A . ?\303) (?O . ?\325) (?a . ?\343) (?o . ?\365) (?\ . ?\~) (space . ?\~)) + (?, (?c . ?\347) (?C . ?\307))) + + ("latin-2" + (?' (?A . ?\301) (?C . ?\306) (?D . ?\320) (?E . ?\311) (?I . ?\315) + (?L . ?\305) (?N . ?\321) (?O . ?\323) (?R . ?\300) (?S . ?\246) + (?U . ?\332) (?Y . ?\335) (?Z . ?\254) (?a . ?\341) (?c . ?\346) + (?d . ?\360) (?e . ?\351) (?i . ?\355) (?l . ?\345) (?n . ?\361) + (?o . ?\363) (?r . ?\340) (?s . ?\266) (?u . ?\372) (?y . ?\375) + (?z . ?\274) (?' . ?\264) (?\ . ?') (space . ?')) + (?` (?A . ?\241) (?C . ?\307) (?E . ?\312) (?L . ?\243) (?S . ?\252) + (?T . ?\336) (?Z . ?\257) (?a . ?\261) (?l . ?\263) (?c . ?\347) + (?e . ?\352) (?s . ?\272) (?t . ?\376) (?z . ?\277) (?` . ?\252) + (?. . ?\377) (?\ . ?`) (space . ?`)) + (?^ (?A . ?\302) (?O . ?\324) (?a . ?\342) (?o . ?\364) + (?^ . ?^) ; no special code? + (?\ . ?^) (space . ?^)) + (?\" (?A . ?\304) (?E . ?\313) (?O . ?\326) (?U . ?\334) (?a . ?\344) + (?e . ?\353) (?o . ?\366) (?s . ?\337) (?u . ?\374) (?\" . ?\250) + (?\ . ?\") (space . ?\")) + (?\~ (?A . ?\303) (?C . ?\310) (?D . ?\317) (?L . ?\245) (?N . ?\322) + (?O . ?\325) (?R . ?\330) (?S . ?\251) (?T . ?\253) (?U . ?\333) + (?Z . ?\256) (?a . ?\323) (?c . ?\350) (?d . ?\357) (?l . ?\265) + (?n . ?\362) (?o . ?\365) (?r . ?\370) (?s . ?\271) (?t . ?\273) + (?u . ?\373) (?z . ?\276) + (?v . ?\242) ; v accent + (?\~ . ?\242) ; v accent + (?\. . ?\270) ; cedilla accent + (?\ . ?\~) (space . ?\~))) + + ("latin-1" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?Y . ?\335) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) + (?u . ?\372) (?y . ?\375) (?' . ?\264) (?\ . ?') (space . ?')) + (?` (?A . ?\300) (?E . ?\310) (?I . ?\314) (?O . ?\322) (?U . ?\331) + (?a . ?\340) (?e . ?\350) (?i . ?\354) (?o . ?\362) (?u . ?\371) + (?` . ?`) (?\ . ?`) (space . ?`)) + (?^ (?A . ?\302) (?E . ?\312) (?I . ?\316) (?O . ?\324) (?U . ?\333) + (?a . ?\342) (?e . ?\352) (?i . ?\356) (?o . ?\364) (?u . ?\373) + (?^ . ?^) (?\ . ?^) (space . ?^)) + (?\" (?A . ?\304) (?E . ?\313) (?I . ?\317) (?O . ?\326) (?U . ?\334) + (?a . ?\344) (?e . ?\353) (?i . ?\357) (?o . ?\366) (?s . ?\337) + (?u . ?\374) (?y . ?\377) (?\" . ?\250) (?\ . ?\") (space . ?\")) + (?\~ (?A . ?\303) (?C . ?\307) (?D . ?\320) (?N . ?\321) (?O . ?\325) + (?T . ?\336) (?a . ?\343) (?c . ?\347) (?d . ?\360) (?n . ?\361) + (?o . ?\365) (?t . ?\376) (?> . ?\273) (?< . ?\253) (?\~ . ?\270) + (?! . ?\241) (?? . ?\277) + (?\ . ?\~) (space . ?\~)) + (?\/ (?A . ?\305) (?E . ?\306) (?O . ?\330) (?a . ?\345) (?e . ?\346) + (?o . ?\370) (?\/ . ?\260) (?\ . ?\/) (space . ?\/)))) + "List of language-specific customizations for the ISO Accents mode. + +Each element of the list is of the form + + (LANGUAGE + (PSEUDO-ACCENT MAPPINGS) + (PSEUDO-ACCENT MAPPINGS) + ...) + +LANGUAGE is a string naming the language. +PSEUDO-ACCENT is a char specifying an accent key. +MAPPINGS are cons cells of the form (CHAR . ISO-CHAR). + +The net effect is that the key sequence PSEUDO-ACCENT CHAR is mapped +to ISO-CHAR on input.") + +(defvar iso-language nil + "Language for which ISO Accents mode is currently customized. +Change it with the `iso-accents-customize' function.") + +(defvar iso-accents-list nil + "Association list for ISO accent combinations, for the chosen language.") + +(defvar iso-accents-mode nil + "*Non-nil enables ISO Accents mode. +Setting this variable makes it local to the current buffer. +See the function `iso-accents-mode'.") +(make-variable-buffer-local 'iso-accents-mode) + +(defvar iso-accents-enable '(?' ?` ?^ ?\" ?~ ?/ ?,) + "*List of accent keys that become prefixes in ISO Accents mode. +The default is (?' ?` ?^ ?\" ?~ ?/ ?,), which contains all the supported +accent keys. If you set this variable to a list in which some of those +characters are missing, the missing ones do not act as accents. + +Note that if you specify a language with `iso-accents-customize', +that can also turn off certain prefixes (whichever ones are not needed in +the language you choose).") + +(defun iso-accents-accent-key (prompt) + "Modify the following character by adding an accent to it." + ;; Pick up the accent character. + (if (and iso-accents-mode + (memq last-input-char iso-accents-enable)) + (iso-accents-compose prompt) + (char-to-string last-input-char))) + +(defun iso-accents-compose (prompt) + (let* ((first-char last-input-char) + (list (assq first-char iso-accents-list)) + ;; Wait for the second key and look up the combination. + (second-char (if (or prompt + (not (eq (key-binding "a") + 'self-insert-command)) + ;; Not at start of a key sequence. + (> (length (this-single-command-keys)) 1) + ;; Called from anything but the command loop. + this-command) + (progn + (message "%s%c" + (or prompt "Compose with ") + first-char) + (read-event)) + (insert first-char) + (prog1 (read-event) + (delete-region (1- (point)) (point))))) + (entry (cdr (assq second-char list)))) + (if entry + ;; Found it: return the mapped char + (iso-generate-char entry) + ;; Otherwise, advance and schedule the second key for execution. + (setq unread-command-events (list (character-to-event second-char))) + (vector first-char)))) + +;; It is a matter of taste if you want the minor mode indicated +;; in the mode line... +;; If so, uncomment the next four lines. +;; (or (assq 'iso-accents-mode minor-mode-alist) +;; (setq minor-mode-alist +;; (append minor-mode-alist +;; '((iso-accents-mode " ISO-Acc"))))) + +;;;###autoload +(defun iso-accents-mode (&optional arg) + "Toggle ISO Accents mode, in which accents modify the following letter. +This permits easy insertion of accented characters according to ISO-8859-1. +When Iso-accents mode is enabled, accent character keys +\(`, ', \", ^, / and ~) do not self-insert; instead, they modify the following +letter key so that it inserts an ISO accented letter. + +You can customize ISO Accents mode to a particular language +with the command `iso-accents-customize'. + +Special combinations: ~c gives a c with cedilla, +~d gives an Icelandic eth (d with dash). +~t gives an Icelandic thorn. +\"s gives German sharp s. +/a gives a with ring. +/e gives an a-e ligature. +~< and ~> give guillemots. +~! gives an inverted exclamation mark. +~? gives an inverted question mark. + +With an argument, a positive argument enables ISO Accents mode, +and a negative argument disables it." + + (interactive "P") + + (if (if arg + ;; Negative arg means switch it off. + (<= (prefix-numeric-value arg) 0) + ;; No arg means toggle. + iso-accents-mode) + (setq iso-accents-mode nil) + + ;; Enable electric accents. + (setq iso-accents-mode t))) + +(defun iso-accents-customize (language) + "Customize the ISO accents machinery for a particular language. +It selects the customization based on the specifications in the +`iso-languages' variable." + (interactive (list (completing-read "Language: " iso-languages nil t))) + (let ((table (assoc language iso-languages)) tail) + (if (not table) + (error "Unknown language '%s'" language) + (setq iso-language language + iso-accents-list (cdr table)) + (if key-translation-map + (substitute-key-definition + 'iso-accents-accent-key nil key-translation-map) + (setq key-translation-map (make-sparse-keymap))) + ;; Set up translations for all the characters that are used as + ;; accent prefixes in this language. + (setq tail iso-accents-list) + (while tail + (define-key key-translation-map (vector (car (car tail))) + 'iso-accents-accent-key) + (setq tail (cdr tail)))))) + +(defun iso-accentuate (start end) + "Convert two-character sequences in region into accented characters. +Noninteractively, this operates on text from START to END. +This uses the same conversion that ISO Accents mode uses for type-in." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (forward-char 1) + (let (entry) + (while (< (point) end) + (if (and (memq (preceding-char) iso-accents-enable) + (setq entry (cdr (assq (following-char) (assq (preceding-char) iso-accents-list))))) + (progn + (forward-char -1) + (delete-char 2) + (insert entry) + (setq end (1- end))) + (forward-char 1))))))) + +(defun iso-accent-rassoc-unit (value alist) + (let (elt acc) + (while (and alist (not elt)) + (setq acc (car (car alist)) + elt (car (rassq value (cdr (car alist)))) + alist (cdr alist))) + (if elt + (cons acc elt)))) + +(defun iso-unaccentuate (start end) + "Convert accented characters in the region into two-character sequences. +Noninteractively, this operates on text from START to END. +This uses the opposite of the conversion done by ISO Accents mode for type-in." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (let (entry) + (while (< (point) end) + (if (and (> (following-char) 127) + (setq entry (iso-accent-rassoc-unit (following-char) + iso-accents-list))) + (progn + (delete-char 1) + (insert (car entry) (cdr entry)) + (setq end (1+ end))) + (forward-char 1))))))) + +(defun iso-deaccentuate (start end) + "Convert accented characters in the region into unaccented characters. +Noninteractively, this operates on text from START to END." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (let (entry) + (while (< (point) end) + (if (and (> (following-char) 127) + (setq entry (iso-accent-rassoc-unit (following-char) + iso-accents-list))) + (progn + (delete-char 1) + (insert (cdr entry))) + (forward-char 1))))))) + +;; Set up the default settings. +(iso-accents-customize "latin-1") + +;; Use Iso-Accents mode in the minibuffer +;; if it was in use in the previous buffer. +(defun iso-acc-minibuf-setup () + (setq iso-accents-mode + (save-excursion + (set-buffer (window-buffer minibuffer-scroll-window)) + iso-accents-mode))) + +(add-hook 'minibuf-setup-hook 'iso-acc-minibuf-setup) + +;;; iso-acc.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/mel/mel-b.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mel/mel-b.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,292 @@ +;;; +;;; mel-b.el: Base64 encoder/decoder for GNU Emacs +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1992 ENAMI Tsugutomo +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: ENAMI Tsugutomo +;;; MORIOKA Tomohiko +;;; Maintainer: MORIOKA Tomohiko +;;; Created: 1995/6/24 +;;; Version: +;;; $Id: mel-b.el,v 1.1.1.1 1996/12/18 03:55:30 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 This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, 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) + (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) + (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 (beg end) + (interactive "r") + (if (and base64-internal-encoding-limit + (> (- end beg) base64-internal-encoding-limit)) + (base64-external-encode-region beg end) + (base64-internal-encode-region beg end) + )) + +(defun base64-decode-region (beg end) + (interactive "r") + (if (and base64-internal-decoding-limit + (> (- end beg) base64-internal-decoding-limit)) + (base64-external-decode-region beg end) + (base64-internal-decode-region beg end) + )) + + +;;; @ base64 encoder/decoder for file +;;; + +(defun base64-insert-encoded-file (filename) + (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 30df88044ec6 -r b82b59fe008d lisp/mel/mel-g.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mel/mel-g.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,93 @@ +;;; +;;; mel-g.el: Gzip64 encoder/decoder for GNU Emacs +;;; +;;; Copyright (C) 1995,1996 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.1.1.1 1996/12/18 03:55:30 steve Exp $ +;;; Keywords: MIME, base64, gzip +;;; +;;; 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 This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'emu) + + +;;; @ variables +;;; + +(defvar gzip64-external-encoder '("sh" "-c" "gzip -c | mmencode") + "*list of gzip64 encoder program name and its arguments.") + +(defvar gzip64-external-decoder '("sh" "-c" "mmencode -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 30df88044ec6 -r b82b59fe008d lisp/mel/mel-q.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mel/mel-q.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,311 @@ +;;; mel-q.el: Quoted-Printable and Q-encoding encoder/decoder for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/6/25 +;; Version: $Id: mel-q.el,v 1.1.1.1 1996/12/18 03:55:30 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) + + +;;; @ constants +;;; + +(defconst quoted-printable-hex-chars "0123456789ABCDEF") +(defconst quoted-printable-octet-regexp + (concat "=[" quoted-printable-hex-chars + "][" quoted-printable-hex-chars "]")) + + +;;; @ variables +;;; + +(defvar quoted-printable-external-encoder '("mmencode" "-q") + "*list of quoted-printable encoder program name and its arguments.") + +(defvar quoted-printable-external-decoder '("mmencode" "-q" "-u") + "*list of quoted-printable decoder program name and its arguments.") + +(defvar quoted-printable-internal-encoding-limit 10000 + "*limit size to use internal quoted-printable encoder. +If size of input to encode is larger than this limit, +external encoder is called.") + +(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.") + + +;;; @ Quoted-Printable (Q-encode) encoder/decoder +;;; + +(defun byte-to-hex-string (num) + (concat (char-to-string (elt quoted-printable-hex-chars (ash num -4))) + (char-to-string (elt quoted-printable-hex-chars (logand num 15))) + )) + +(defun quoted-printable-quote-char (chr) + (concat "=" + (char-to-string (elt quoted-printable-hex-chars (ash chr -4))) + (char-to-string (elt quoted-printable-hex-chars (logand chr 15))) + )) + + +;;; @@ Quoted-Printable encoder/decoder for string +;;; + +(defun quoted-printable-encode-string (str) + (let ((i 0)) + (mapconcat (function + (lambda (chr) + (cond ((eq chr ?\n) + (setq i 0) + "\n") + ((or (< chr 32) (< 126 chr) (eq chr ?=)) + (if (>= i 73) + (progn + (setq i 3) + (concat "=\n" (quoted-printable-quote-char chr)) + ) + (progn + (setq i (+ i 3)) + (quoted-printable-quote-char chr) + ))) + (t (if (>= i 75) + (progn + (setq i 1) + (concat "=\n" (char-to-string chr)) + ) + (progn + (setq i (1+ i)) + (char-to-string chr) + ))) + ))) + str ""))) + +(defun quoted-printable-decode-string (str) + (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)) + ))) + str ""))) + + +;;; @@ Quoted-Printable encoder/decoder for region +;;; + +(defun quoted-printable-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 (quoted-printable-encode-string str)) + ) + (or (bolp) + (insert "=\n") + ) + ))) + +(defun quoted-printable-internal-decode-region (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg 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)) + )) + ))) + +(defun quoted-printable-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 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 "") + ) + ))) + +(defun quoted-printable-external-decode-region (beg end) + (save-excursion + (as-binary-process + (apply (function call-process-region) + beg end (car quoted-printable-external-decoder) + t t nil (cdr quoted-printable-external-decoder)) + ))) + +(defun quoted-printable-encode-region (beg end) + (interactive "r") + (if (and quoted-printable-internal-encoding-limit + (> (- end beg) quoted-printable-internal-encoding-limit)) + (quoted-printable-external-encode-region beg end) + (quoted-printable-internal-encode-region beg end) + )) + +(defun quoted-printable-decode-region (beg end) + (interactive "r") + (if (and quoted-printable-internal-decoding-limit + (> (- end beg) quoted-printable-internal-decoding-limit)) + (quoted-printable-external-decode-region beg end) + (quoted-printable-internal-decode-region beg end) + )) + + +;;; @@ Quoted-Printable encoder/decoder for file +;;; + +(defun quoted-printable-insert-encoded-file (filename) + (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)) + ) + + +;;; @ Q-encoding encode/decode string +;;; + +(defconst q-encoding-special-chars-alist + '((text ?= ?? ?_) + (comment ?= ?? ?_ ?\( ?\) ?\\) + (phrase ?= ?? ?_ ?\( ?\) ?\\ ?\" ?# ?$ ?% ?& ?' ?, ?. ?/ + ?: ?\; ?< ?> ?@ ?\[ ?\] ?^ ?` ?{ ?| ?} ?~) + )) + +(defun q-encoding-encode-string (str &optional mode) + (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 32) "_") + ((or (< chr 32) (< 126 chr) + (memq chr specials) + ) + (quoted-printable-quote-char chr) + ) + (t + (char-to-string chr) + )) + )) + str "") + )) + +(defun q-encoding-decode-string (str) + (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)) + ))) + str ""))) + + +;;; @@ 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 30df88044ec6 -r b82b59fe008d lisp/mel/mel-u.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mel/mel-u.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,115 @@ +;;; +;;; mel-u.el: uuencode encoder/decoder for GNU Emacs +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Maintainer: MORIOKA Tomohiko +;;; Created: 1995/10/25 +;;; Version: +;;; $Id: mel-u.el,v 1.1.1.1 1996/12/18 03:55:30 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 This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'emu) + + +;;; @ variables +;;; + +(defvar mime/tmp-dir (or (getenv "TM_TMP_DIR") "/tmp/")) + +(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/tmp-dir)) + "*list of uuencode decoder program name and its arguments.") + + +;;; @ uuencode encoder/decoder for region +;;; + +(defun uuencode-external-encode-region (beg end) + (interactive "*r") + (save-excursion + (as-binary-process (apply (function call-process-region) + beg 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 (beg end) + (interactive "*r") + (save-excursion + (let ((filename (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (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) + beg end (car uuencode-external-decoder) + t nil nil (cdr uuencode-external-decoder)) + (setq filename (expand-file-name filename mime/tmp-dir)) + (let ((file-coding-system-for-read *noconv*) ; for Mule + kanji-fileio-code ; for NEmacs + (emx-binary-mode t) ; for OS/2 + jka-compr-compression-info-list ; for jka-compr + jam-zcat-filename-list ; for jam-zcat + require-final-newline) + (insert-file-contents filename) + ) + (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) + (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 30df88044ec6 -r b82b59fe008d lisp/mel/mel.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mel/mel.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,140 @@ +;;; mel.el : a MIME encoding/decoding library + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; modified by Shuhei KOBAYASHI +;; Created: 1995/6/25 +;; Version: $Id: mel.el,v 1.1.1.1 1996/12/18 03:55:30 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: + +;;; @ region +;;; + +(autoload 'base64-encode-region "mel-b" nil t) +(autoload 'quoted-printable-encode-region "mel-q" nil t) +(autoload 'uuencode-encode-region "mel-u" nil t) +(autoload 'gzip64-encode-region "mel-g" nil 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") + )) + +(autoload 'base64-decode-region "mel-b" nil t) +(autoload 'quoted-printable-decode-region "mel-q" nil t) +(autoload 'uuencode-decode-region "mel-u" nil t) +(autoload 'gzip64-decode-region "mel-g" nil t) + +(defvar mime-decoding-method-alist + '(("base64" . base64-decode-region) + ("quoted-printable" . quoted-printable-decode-region) + ("x-uue" . uuencode-decode-region) + ("x-gzip64" . gzip64-decode-region) + )) + +(defun mime-encode-region (beg end encoding) + "Encode region BEG to END of current buffer using ENCODING. [mel.el]" + (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 beg end) + ))) + +(defun mime-decode-region (beg end encoding) + "Decode region BEG to END of current buffer using ENCODING. [mel.el]" + (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 beg end) + ))) + + +;;; @ file +;;; + +(autoload 'base64-insert-encoded-file "mel-b" nil t) +(autoload 'quoted-printable-insert-encoded-file "mel-q" nil t) +(autoload 'uuencode-insert-encoded-file "mel-u" nil t) +(autoload 'gzip64-insert-encoded-file "mel-g" nil 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) + )) + +(defun mime-insert-encoded-file (filename encoding) + "Encode region BEG to END of current buffer using ENCODING. [mel.el]" + (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") +(autoload 'base64-decode-string "mel-b") + +(autoload 'q-encoding-encode-string-for-text "mel-q") +(autoload 'q-encoding-encode-string-for-comment "mel-q") +(autoload 'q-encoding-encode-string-for-phrase "mel-q") +(autoload 'q-encoding-encode-string "mel-q") +(autoload 'q-encoding-decode-string "mel-q") + +(autoload 'base64-encoded-length "mel-b") +(autoload 'q-encoding-encoded-length "mel-q") + + +;;; @ end +;;; + +(provide 'mel) + +;;; mel.el ends here. diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/c-style.el --- a/lisp/modes/c-style.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/c-style.el Mon Aug 13 08:46:56 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; ;; LCD Archive Entry: ;; c-style|Daniel LaLiberte|liberte@cs.uiuc.edu diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/cc-compat.el --- a/lisp/modes/cc-compat.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/cc-compat.el Mon Aug 13 08:46:56 2007 +0200 @@ -25,8 +25,6 @@ ;; along with GNU Emacs; 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. - ;;; Commentary: ;; ;; Boring old c-mode.el (BOCM) is confusion and brain melt. cc-mode.el diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/cc-guess.el --- a/lisp/modes/cc-guess.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/cc-guess.el Mon Aug 13 08:46:56 2007 +0200 @@ -25,8 +25,6 @@ ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; Synched up with: Not in FSF. - ;;; Commentary: ;; ;; This file contains routines that help guess the cc-mode style in a diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/cc-lobotomy.el --- a/lisp/modes/cc-lobotomy.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/cc-lobotomy.el Mon Aug 13 08:46:56 2007 +0200 @@ -25,8 +25,6 @@ ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; Synched up with: Not in FSF. - ;;; Commentary: ;; ;; Every effort has been made to improve the performance of diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/cc-mode.el --- a/lisp/modes/cc-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/cc-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -6,8 +6,8 @@ ;; 1987 Dave Detlefs and Stewart Clamen ;; 1985 Richard M. Stallman ;; Created: a long, long, time ago. adapted from the original c-mode.el -;; Version: 4.315 -;; Last Modified: 1996/08/20 21:08:13 +;; Version: 4.322 +;; Last Modified: 1996/10/04 20:28:14 ;; Keywords: c languages oop ;; NOTE: Read the commentary below for the right way to submit bug reports! @@ -533,6 +533,20 @@ (inline-open . 0) )) ) + ("linux" + (c-basic-offset . 8) + (c-comment-only-line-offset . 0) + (c-hanging-braces-alist . ((brace-list-open) + (substatement-open after) + (block-close . c-snug-do-while))) + (c-cleanup-list . (brace-else-brace)) + (c-offsets-alist . ((statement-block-intro . +) + (knr-argdecl-intro . 0) + (substatement-open . 0) + (label . 0) + (statement-cont . +) + )) + ) ("java" (c-basic-offset . 2) (c-comment-only-line-offset . (0 . 0)) @@ -623,7 +637,7 @@ ["Backward Statement" c-beginning-of-statement t] ["Forward Statement" c-end-of-statement t] ) - "XEmacs 19 menu for C/C++/ObjC modes.") + "XEmacs 19 menu for C/C++/ObjC/Java modes.") ;; Sadly we need this for a macro in Emacs 19. (eval-when-compile @@ -851,10 +865,11 @@ (define-key map [menu-bar c forward-stmt] '("Forward Statement" . c-end-of-statement)) - ;; RMS: mouse-3 should not select this menu. mouse-3's global - ;; definition is useful in C mode and we should not interfere - ;; with that. The menu is mainly for beginners, and for them, - ;; the menubar requires less memory than a special click. + ;; RMS says: mouse-3 should not select this menu. mouse-3's + ;; global definition is useful in C mode and we should not + ;; interfere with that. The menu is mainly for beginners, and + ;; for them, the menubar requires less memory than a special + ;; click. t) (error nil))) @@ -910,7 +925,7 @@ ;; ;; Emacs 19 defines menus in the mode map. This call will return ;; t on Emacs 19, otherwise no-op and return nil. - (if (and (not (c-mode-fsf-menu "C" c-mode-map)) + (if (and (not (c-mode-fsf-menu "CC-Mode" c-mode-map)) ;; in XEmacs 19, we want the menu to popup when the 3rd ;; button is hit. In Lucid Emacs 19.10 and beyond this is ;; done automatically if we put the menu on mode-popup-menu @@ -947,7 +962,8 @@ (define-key c++-mode-map ">" 'c-electric-lt-gt) ;; Emacs 19 defines menus in the mode map. This call will return ;; t on Emacs 19, otherwise no-op and return nil. - (c-mode-fsf-menu "C++" c++-mode-map)) +; (c-mode-fsf-menu "C++" c++-mode-map) + ) (defvar objc-mode-map () "Keymap used in objc-mode buffers.") @@ -971,7 +987,8 @@ (define-key objc-mode-map "/" 'c-electric-slash) ;; Emacs 19 defines menus in the mode map. This call will return ;; t on Emacs 19, otherwise no-op and return nil. - (c-mode-fsf-menu "ObjC" objc-mode-map)) +; (c-mode-fsf-menu "ObjC" objc-mode-map) + ) (defvar java-mode-map () "Keymap used in java-mode buffers.") @@ -996,7 +1013,8 @@ (define-key java-mode-map "/" 'c-electric-slash) ;; Emacs 19 defines menus in the mode map. This call will return t ;; on Emacs 19, otherwise no-op and return nil. - (c-mode-fsf-menu "Java" java-mode-map)) +; (c-mode-fsf-menu "Java" java-mode-map) + ) (defun c-populate-syntax-table (table) ;; Populate the syntax TABLE @@ -1139,10 +1157,10 @@ ;; cmacexp is lame because it uses no preprocessor symbols. ;; It isn't very extensible either -- hardcodes /lib/cpp. ;; [I add it here only because c-mode has it -- BAW] -;;(autoload 'c-macro-expand "cmacexp" -;; "Display the result of expanding all C macros occurring in the region. -;;The expansion is entirely correct because it uses the C preprocessor." -;; t) +;(autoload 'c-macro-expand "cmacexp" +; "Display the result of expanding all C macros occurring in the region. +;The expansion is entirely correct because it uses the C preprocessor." +; t) ;; constant regular expressions for looking at various constructs @@ -2359,6 +2377,7 @@ (setq c-style-alist (cons (cons style descrip) c-style-alist)))) (and set-p (c-set-style style))) + (defun c-fill-paragraph (&optional arg) "Like \\[fill-paragraph] but handles C and C++ style comments. If any of the current line is a comment or within a comment, @@ -2865,18 +2884,26 @@ ;; commands to indent lines, regions, defuns, and expressions (defun c-indent-command (&optional whole-exp) - "Indent current line as C++ code, or in some cases insert a tab character. + "Indent current line as C code, and/or insert some whitespace. If `c-tab-always-indent' is t, always just indent the current line. If nil, indent the current line only if point is at the left margin or -in the line's indentation; otherwise insert a tab. If other than nil -or t, then tab is inserted only within literals (comments and strings) -and inside preprocessor directives, but line is always reindented. +in the line's indentation; otherwise insert some whitespace[*]. If +other than nil or t, then some whitespace[*] is inserted only within +literals (comments and strings) and inside preprocessor directives, +but the line is always reindented. A numeric argument, regardless of its value, means indent rigidly all the lines of the expression starting after point so that this line becomes properly indented. The relative indentation among the lines -of the expression are preserved." +of the expression are preserved. + + [*] The amount and kind of whitespace inserted is controlled by the + variable `c-insert-tab-function', which is called to do the actual + insertion of whitespace. Normally the function in this variable + just inserts a tab character, or the equivalent number of spaces, + depending on the variable `indent-tabs-mode'." + (interactive "P") (let ((bod (c-point 'bod))) (if whole-exp @@ -4911,10 +4938,12 @@ With no argument, inserts backslashes and aligns existing backslashes. With an argument, deletes the backslashes. -This function does not modify the last line of the region if the region ends -right at the start of the following line; it does not modify blank lines -at the start of the region. So you can put the region around an entire macro -definition and conveniently use this command." +This function does not modify blank lines at the start of the region. +If the region ends at the start of a line, it always deletes the +backslash (if any) at the end of the previous line. + +You can put the region around an entire macro definition and use this +command to conveniently insert and align the necessary backslashes." (interactive "r\nP") (save-excursion (goto-char from) @@ -4940,17 +4969,18 @@ (while (and (< (point) endmark) (eolp)) (forward-line 1)) ;; Add or remove backslashes on all the lines. - (while (and (< (point) endmark) - ;; Don't backslashify the last line - ;; if the region ends right at the start of the next line. - (save-excursion - (forward-line 1) - (< (point) endmark))) - (if (not delete-flag) + (while (< (point) endmark) + (if (and (not delete-flag) + ;; Un-backslashify the last line + ;; if the region ends right at the start of the next line. + (save-excursion + (forward-line 1) + (< (point) endmark))) (c-append-backslash column) (c-delete-backslash)) (forward-line 1)) - (move-marker endmark nil)))) + (move-marker endmark nil))) + (c-keep-region-active)) (defun c-append-backslash (column) (end-of-line) @@ -4974,7 +5004,7 @@ ;; defuns for submitting bug reports -(defconst c-version "4.315" +(defconst c-version "4.322" "cc-mode version number.") (defconst c-mode-help-address "bug-gnu-emacs@prep.ai.mit.edu, cc-mode-help@python.org" @@ -5110,15 +5140,11 @@ c-block-comments-indent-p c-cleanup-list c-comment-only-line-offset - c-echo-syntactic-information-p c-electric-pound-behavior c-hanging-braces-alist c-hanging-colons-alist c-hanging-comment-ender-p c-offsets-alist - c-strict-syntax-p - c-tab-always-indent - c-inhibit-startup-warnings-p ))) ;; the default style is now GNU. This can be overridden in ;; c-mode-common-hook or {c,c++,objc,java}-mode-hook. @@ -5147,7 +5173,7 @@ ;; there is no cc-mode equivalent for electric-c-terminator (fset 'mark-c-function 'c-mark-function) (fset 'indent-c-exp 'c-indent-exp) -(fset 'set-c-style 'c-set-style) +;;;###autoload (fset 'set-c-style 'c-set-style) ;; Lucid Emacs 19.9 + font-lock + cc-mode - c++-mode lossage (fset 'c++-beginning-of-defun 'beginning-of-defun) (fset 'c++-end-of-defun 'end-of-defun) diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/cperl-mode.el --- a/lisp/modes/cperl-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/cperl-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -6,9 +6,12 @@ ;;; Date: 14 Aug 91 15:20:01 GMT ;; Perl code editing commands for Emacs -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; This file is not (yet) part of GNU Emacs. +;; Copyright (C) 1985-1996 Bob Olson, Ilya Zakharevich + +;; This file is not (yet) part of GNU Emacs. It may be distributed +;; either under the same terms as GNU Emacs, or under the same terms +;; as Perl. You should have received a copy of Perl Artistic license +;; along with the Perl distribution. ;; 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 @@ -21,15 +24,15 @@ ;; 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. - -;;; Synched up with: Not in FSF. +;; 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. + ;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu ;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de -;; $Id: cperl-mode.el,v 1.1.1.2 1996/12/18 03:44:44 steve Exp $ +;; $Id: cperl-mode.el,v 1.1.1.3 1996/12/18 03:53:13 steve Exp $ ;;; To use this mode put the following into your .emacs file: @@ -52,7 +55,7 @@ ;;; The mode information (on C-h m) provides customization help. ;;; If you use font-lock feature of this mode, it is advisable to use -;;; eather lazy-lock-mode or fast-lock-mode (available on ELisp +;;; either lazy-lock-mode or fast-lock-mode (available on ELisp ;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock. ;;; Faces used now: three faces for first-class and second-class keywords @@ -62,12 +65,12 @@ ;;; not define them, so you need to define them manually. Maybe you have ;;; an obsolete font-lock from 19.28 or earlier. Upgrade. -;;; If you have grayscale monitor, and do not have the variable +;;; If you have a grayscale monitor, and do not have the variable ;;; font-lock-display-type bound to 'grayscale, insert ;;; (setq font-lock-display-type 'grayscale) -;;; to your .emacs file. +;;; into your .emacs file. ;;;; This mode supports font-lock, imenu and mode-compile. In the ;;;; hairy version font-lock is on, but you should activate imenu @@ -266,7 +269,64 @@ ;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed ;;; after ")". ;;; {} is recognized as expression after `tr' and friends. -;;; Works with XEmacs again. + +;;;; After 1.22 +;;; Entry Hierarchy added to imenu. Very primitive so far. +;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well. +;;; Writes its own TAGS files. +;;; Class viewer based on TAGS files. Does not trace @ISA so far. +;;; 19.31: Problems with scan for PODs corrected. +;;; First POD header correctly fontified. +;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31. +;;; Apparently it makes a lot of hierarchy code obsolete... + +;;;; After 1.23 +;;; Tags filler now scans *.xs as well. +;;; The info from *.xs scan is used by the hierarchy viewer. +;;; Hierarchy viewer documented. +;;; Bug in 19.31 imenu documented. + +;;;; After 1.24 +;;; New location for info-files mentioned, +;;; Electric-; should work better. +;;; Minor bugs with POD marking. + +;;;; After 1.25 (probably not...) +;;; `cperl-info-page' introduced. +;;; To make `uncomment-region' working, `comment-region' would +;;; not insert extra space. +;;; Here documents delimiters better recognized +;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14? +;;; `cperl-db' added, used in menu. +;;; imenu scan removes text-properties, for better debugging +;;; - but the bug is in 19.31 imenu. +;;; formats highlighted by font-lock and prescan, embedded comments +;;; are not treated. +;;; POD/friends scan merged in one pass. +;;; Syntax class is not used for analyzing the code, only char-syntax +;;; may be checked against _ or'ed with w. +;;; Syntax class of `:' changed to be _. +;;; `cperl-find-bad-style' added. + +;;;; After 1.25 +;;; When search for here-documents, we ignore commented << in simplest cases. +;;; `cperl-get-help' added, available on C-h v and from menu. +;;; Auto-help added. Default with `cperl-hairy', switchable on/off +;;; with startup variable `cperl-lazy-help-time' and from +;;; menu. Requires `run-with-idle-timer'. +;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps. + +;;;; After 1.27 +;;; Indentation: At toplevel after a label - fixed. +;;; 1.27 was put to archives in binary mode ===> DOSish :-( + +;;;; After 1.28 +;;; Thanks to Martin Buchholz : misprints in +;;; comments and docstrings corrected, XEmacs support cleaned up. +;;; The closing parenths would enclose the region into matching +;;; parens under the same conditions as the opening ones. +;;; Minor updates to `cperl-short-docs'. +;;; Will not consider <<= as start of here-doc. (defvar cperl-extra-newline-before-brace nil "*Non-nil means that if, elsif, while, until, else, for, foreach @@ -334,14 +394,16 @@ (defvar cperl-electric-parens nil "*Non-nil (and non-null) means parentheses should be electric in CPerl. Can be overwritten by `cperl-hairy' if nil.") - -(defvar cperl-electric-parens-mark (and window-system - (or (and ; Emacs - (boundp 'transient-mark-mode) - transient-mark-mode) - (and ; XEmacs - (boundp 'zmacs-regions) - zmacs-regions))) +(defvar cperl-electric-parens-mark + (and window-system + (or (and (boundp 'transient-mark-mode) ; For Emacs + transient-mark-mode) + (and (boundp 'zmacs-regions) ; For XEmacs + zmacs-regions))) + "*Not-nil means that electric parens look for active mark. +Default is yes if there is visual feedback on mark.") + +(defvar cperl-electric-parens-mark (and window-system transient-mark-mode) "*Not-nil means that electric parens look for active mark. Default is yes if there is visual feedback on mark.") @@ -369,6 +431,9 @@ The opposite behaviour is always available if prefixed with C-c. Can be overwritten by `cperl-hairy' if nil.") +(defvar cperl-lazy-help-time nil + "*Not-nil (and non-null) means to show lazy help after given idle time.") + (defvar cperl-pod-face 'font-lock-comment-face "*The result of evaluation of this expression is used for pod highlighting.") @@ -386,6 +451,14 @@ "*Not-nil means look for pod and here-docs sections during startup. You can always make lookup from menu or using \\[cperl-find-pods-heres].") +(defvar cperl-imenu-addback nil + "*Not-nil means add backreferences to generated `imenu's. +May require patched `imenu' and `imenu-go'.") + +(defvar cperl-info-page "perl" + "Name of the info page containing perl docs. +Older version of this page was called `perl5', newer `perl'.") + ;;; Short extra-docs. @@ -396,20 +469,32 @@ and/or ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl -Get support packages font-lock-extra.el, imenu-go.el from the same place. -\(Look for other files there too... ;-) Get a patch for imenu.el in 19.29. -Note that for 19.30 you should use choose-color.el *instead* of -font-lock-extra.el (and you will not get smart highlighting in C :-(). +Get support packages choose-color.el (or font-lock-extra.el before +19.30), imenu-go.el from the same place. \(Look for other files there +too... ;-) Get a patch for imenu.el in 19.29. Note that for 19.30 and +later you should use choose-color.el *instead* of font-lock-extra.el +\(and you will not get smart highlighting in C :-(). Note that to enable Compile choices in the menu you need to install mode-compile.el. Get perl5-info from + $CPAN/doc/manual/info/perl-info.tar.gz +older version was on http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz -\(may be quite obsolete, but still useful). - -If you use imenu-go, run imenu on perl5-info buffer (you can do it from -CPerl menu). + +If you use imenu-go, run imenu on perl5-info buffer (you can do it +from CPerl menu). If many files are related, generate TAGS files from +Tools/Tags submenu in CPerl menu. + +If some class structure is too complicated, use Tools/Hierarchy-view +from CPerl menu, or hierarchic view of imenu. The second one uses the +current buffer only, the first one requires generation of TAGS from +CPerl/Tools/Tags menu beforehand. + +Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing. + +Switch auto-help on/off with CPerl/Tools/Auto-help. Before reporting (non-)problems look in the problem section on what I know about them.") @@ -421,26 +506,26 @@ `non-problems' section if you want to volunteer. CPerl mode tries to corrects some Emacs misunderstandings, however, -for effeciency reasons the degree of correction is different for +for efficiency reasons the degree of correction is different for different operations. The partially corrected problems are: POD sections, here-documents, regexps. The operations are: highlighting, indentation, electric keywords, electric braces. This may be confusing, since the regexp s#//#/#\; may be highlighted -as a comment, but it will recognized as a regexp by the indentation +as a comment, but it will be recognized as a regexp by the indentation code. Or the opposite case, when a pod section is highlighted, but breaks the indentation of the following code. The main trick (to make $ a \"backslash\") makes constructions like -${aaa} look like unbalanced braces. The only trick I can think out is +${aaa} look like unbalanced braces. The only trick I can think of is to insert it as $ {aaa} (legal in perl5, not in perl4). Similar problems arise in regexps, when /(\\s|$)/ should be rewritten -as /($|\\s)/. Note that such a transpositinon is not always possible +as /($|\\s)/. Note that such a transposition is not always possible :-(. " ) (defvar cperl-non-problems 'please-ignore-this-line -"As you know from `problems' section, Perl syntax too hard for CPerl. +"As you know from `problems' section, Perl syntax is too hard for CPerl. Most the time, if you write your own code, you may find an equivalent \(and almost as readable) expression. @@ -472,20 +557,29 @@ Pods are treated _very_ rudimentally. Here-documents are not treated at all (except highlighting and inhibiting indentation). (This may change some time. RMS approved making syntax lookup recognize text -attributes, but volonteers are needed to change Emacs C code.) +attributes, but volunteers are needed to change Emacs C code.) To speed up coloring the following compromises exist: a) sub in $mypackage::sub may be highlighted. b) -z in [a-z] may be highlighted. c) if your regexp contains a keyword (like \"s\"), it may be highlighted. + + +Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove +`car' before `imenu-choose-buffer-index' in `imenu'. ") ;;; Portability stuff: -(defsubst cperl-xemacs-p () - (string-match "XEmacs\\|Lucid" emacs-version)) +(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) +(defmacro cperl-define-key (fsf-key definition &optional xemacs-key) + `(define-key cperl-mode-map + ,(if xemacs-key + `(if cperl-xemacs-p ,xemacs-key ,fsf-key) + fsf-key) + ,definition)) (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) (where-is-internal 'backward-delete-char-untabify))) @@ -494,7 +588,7 @@ (and (vectorp del-back-ch) (= (length del-back-ch) 1) (setq del-back-ch (aref del-back-ch 0))) -(if (cperl-xemacs-p) +(if cperl-xemacs-p (progn ;; "Active regions" are on: use region only if active ;; "Active regions" are off: use region unconditionally @@ -506,10 +600,10 @@ (defun cperl-mark-active () mark-active)) (defsubst cperl-enable-font-lock () - (or (cperl-xemacs-p) window-system)) + (or cperl-xemacs-p window-system)) (if (boundp 'unread-command-events) - (if (cperl-xemacs-p) + (if cperl-xemacs-p (defun cperl-putback-char (c) ; XEmacs >= 19.12 (setq unread-command-events (list (character-to-event c)))) (defun cperl-putback-char (c) ; Emacs 19 @@ -528,6 +622,10 @@ 'lazy-lock) "Text property which inhibits refontification.") +(defsubst cperl-put-do-not-fontify (from to) + (put-text-property (max (point-min) (1- from)) + to cperl-do-not-fontify t)) + ;;; Probably it is too late to set these guys already, but it can help later: @@ -562,39 +660,37 @@ (if cperl-mode-map nil (setq cperl-mode-map (make-sparse-keymap)) - (define-key cperl-mode-map "{" 'cperl-electric-lbrace) - (define-key cperl-mode-map "[" 'cperl-electric-paren) - (define-key cperl-mode-map "(" 'cperl-electric-paren) - (define-key cperl-mode-map "<" 'cperl-electric-paren) - (define-key cperl-mode-map "}" 'cperl-electric-brace) - (define-key cperl-mode-map ";" 'cperl-electric-semi) - (define-key cperl-mode-map ":" 'cperl-electric-terminator) - (define-key cperl-mode-map "\C-j" 'newline-and-indent) - (define-key cperl-mode-map "\C-c\C-j" 'cperl-linefeed) - (define-key cperl-mode-map "\C-c\C-a" 'cperl-toggle-auto-newline) - (define-key cperl-mode-map "\C-c\C-k" 'cperl-toggle-abbrev) - (define-key cperl-mode-map "\C-c\C-e" 'cperl-toggle-electric) - (define-key cperl-mode-map "\e\C-q" 'cperl-indent-exp) ; Usually not bound - ;;(define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) - ;;(define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) - (define-key cperl-mode-map "\177" 'cperl-electric-backspace) - (define-key cperl-mode-map "\t" 'cperl-indent-command) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (define-key cperl-mode-map [(control h) f] 'cperl-info-on-command) - (define-key cperl-mode-map "\C-hf" 'cperl-info-on-command)) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (define-key cperl-mode-map [(control c) (control h) f] - 'cperl-info-on-current-command) - (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-current-command)) - (if (and (cperl-xemacs-p) + (cperl-define-key "{" 'cperl-electric-lbrace) + (cperl-define-key "[" 'cperl-electric-paren) + (cperl-define-key "(" 'cperl-electric-paren) + (cperl-define-key "<" 'cperl-electric-paren) + (cperl-define-key "}" 'cperl-electric-brace) + (cperl-define-key "]" 'cperl-electric-rparen) + (cperl-define-key ")" 'cperl-electric-rparen) + (cperl-define-key ";" 'cperl-electric-semi) + (cperl-define-key ":" 'cperl-electric-terminator) + (cperl-define-key "\C-j" 'newline-and-indent) + (cperl-define-key "\C-c\C-j" 'cperl-linefeed) + (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) + (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) + (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) + (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound + ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) + ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\177" 'cperl-electric-backspace) + (cperl-define-key "\t" 'cperl-indent-command) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command + [(control c) (control h) f]) + (cperl-define-key "\C-hv" 'cperl-get-help [(control h) v]) + (if (and cperl-xemacs-p (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn ;; substitute-key-definition is usefulness-deenhanced... - (define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) - (define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) - (define-key cperl-mode-map "\e\C-\\" 'cperl-indent-region)) + (cperl-define-key "\M-q" 'cperl-fill-paragraph) + (cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\e\C-\\" 'cperl-indent-region)) (substitute-key-definition 'indent-sexp 'cperl-indent-exp cperl-mode-map global-map) @@ -621,8 +717,8 @@ ["Line up a construction" cperl-lineup (cperl-use-region-p)] "----" ["Indent region" cperl-indent-region (cperl-use-region-p)] - ["Comment region" comment-region (cperl-use-region-p)] - ["Uncomment region" uncomment-region (cperl-use-region-p)] + ["Comment region" cperl-comment-region (cperl-use-region-p)] + ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] "----" ["Run" mode-compile (fboundp 'mode-compile)] ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) @@ -630,25 +726,43 @@ ["Next error" next-error (get-buffer "*compilation*")] ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] "----" - ["Debugger" perldb t] + ["Debugger" cperl-db t] "----" ("Tools" ["Imenu" imenu (fboundp 'imenu)] + ["Insert spaces if needed" cperl-find-bad-style t] + ["Class Hierarchy from TAGS" cperl-tags-hier-init t] + ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] ("Tags" - ["Create tags for current file" cperl-etags t] - ["Add tags for current file" (cperl-etags t) t] - ["Create tags for Perl files in directory" (cperl-etags nil t) t] - ["Add tags for Perl files in directory" (cperl-etags t t) t] +;;; ["Create tags for current file" cperl-etags t] +;;; ["Add tags for current file" (cperl-etags t) t] +;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] +;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] +;;; ["Create tags for Perl files in (sub)directories" +;;; (cperl-etags nil 'recursive) t] +;;; ["Add tags for Perl files in (sub)directories" +;;; (cperl-etags t 'recursive) t]) +;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) + ["Create tags for current file" (cperl-write-tags nil t) t] + ["Add tags for current file" (cperl-write-tags) t] + ["Create tags for Perl files in directory" + (cperl-write-tags nil t nil t) t] + ["Add tags for Perl files in directory" + (cperl-write-tags nil nil nil t) t] ["Create tags for Perl files in (sub)directories" - (cperl-etags nil 'recursive) t] + (cperl-write-tags nil t t t) t] ["Add tags for Perl files in (sub)directories" - (cperl-etags t 'recursive) t]) - ["Recalculate PODs" cperl-find-pods-heres t] + (cperl-write-tags nil nil t t) t]) + ["Recalculate PODs and HEREs" cperl-find-pods-heres t] ["Define word at point" imenu-go-find-at-position (fboundp 'imenu-go-find-at-position)] ["Help on function" cperl-info-on-command t] - ["Help on function at point" cperl-info-on-current-command t]) + ["Help on function at point" cperl-info-on-current-command t] + ["Help on symbol at point" cperl-get-help t] + ["Auto-help on" cperl-lazy-install (fboundp 'run-with-idle-timer)] + ["Auto-help off" cperl-lazy-unstall + (fboundp 'run-with-idle-timer)]) ("Toggle..." ["Auto newline" cperl-toggle-auto-newline t] ["Electric parens" cperl-toggle-electric t] @@ -693,6 +807,7 @@ (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) (modify-syntax-entry ?_ "w" cperl-mode-syntax-table) + (modify-syntax-entry ?: "_" cperl-mode-syntax-table) (modify-syntax-entry ?| "." cperl-mode-syntax-table)) @@ -749,13 +864,13 @@ it will not do any expansion. See also help on variable `cperl-extra-newline-before-brace'. -\\[cperl-linefeed] is a convinience replacement for typing carriage +\\[cperl-linefeed] is a convenience replacement for typing carriage return. It places you in the next line with proper indentation, or if you type it inside the inline block of control construct, like foreach (@lines) {print; print} and you are on a boundary of a statement inside braces, it will transform the construct into a multiline and will place you into an -apporpriately indented blank line. If you need a usual +appropriately indented blank line. If you need a usual `newline-and-indent' behaviour, it is on \\[newline-and-indent], see documentation on `cperl-electric-linefeed'. @@ -781,6 +896,15 @@ `cperl-info-on-command', which one is which is controlled by variable `cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). +Even if you have no info-format documentation, short one-liner-style +help is available on \\[cperl-get-help]. + +It is possible to show this help automatically after some idle +time. This is regulated by variable `cperl-lazy-help-time'. Default +with `cperl-hairy' is 5 secs idle time if the value of this variable +is nil. It is also possible to switch this on/off from the +menu. Requires `run-with-idle-timer'. + Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', `cperl-pod-face', `cperl-pod-head-face' control processing of pod and here-docs sections. In a future version results of scan may be used @@ -845,15 +969,10 @@ (local-set-key "\C-C\C-J" 'newline-and-indent))) (if (cperl-val 'cperl-info-on-command-no-prompt) (progn - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (local-set-key [(control h) f] 'cperl-info-on-current-command) - (local-set-key "\C-hf" 'cperl-info-on-current-command)) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (local-set-key [(control c) (control h) f] - 'cperl-info-on-command) - (local-set-key "\C-c\C-hf" 'cperl-info-on-command)))) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command + [(control c) (control h) f]))) (setq major-mode 'perl-mode) (setq mode-name "CPerl") (if (not cperl-mode-abbrev-table) @@ -891,7 +1010,7 @@ (make-local-variable 'comment-start-skip) (setq comment-start-skip "#+ *") (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp "^[ \t]*sub\\s +\\([^ \t\n{;]+\\)\\s *") + (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{;]+\\)[ \t]*") (make-local-variable 'comment-indent-function) (setq comment-indent-function 'cperl-comment-indent) (make-local-variable 'parse-sexp-ignore-comments) @@ -928,10 +1047,27 @@ (and (boundp 'msb-menu-cond) (not cperl-msb-fixed) (cperl-msb-fix)) + (if (featurep 'easymenu) + (easy-menu-add cperl-menu)) ; A NOP under FSF Emacs. (run-hooks 'cperl-mode-hook) ;; After hooks since fontification will break this (if cperl-pod-here-scan (cperl-find-pods-heres))) +;; Fix for perldb - make default reasonable +(defun cperl-db () + (interactive) + (require 'gud) + (perldb (read-from-minibuffer "Run perldb (like this): " + (if (consp gud-perldb-history) + (car gud-perldb-history) + (concat "perl " ;;(file-name-nondirectory + ;; I have problems + ;; in OS/2 + ;; otherwise + (buffer-file-name))) + nil nil + '(gud-perldb-history . 1)))) + ;; Fix for msb.el (defvar cperl-msb-fixed nil) @@ -993,7 +1129,7 @@ ;;; (setq prevc (current-column))))))) (defun cperl-indent-for-comment () - "Substite for `indent-for-comment' in CPerl." + "Substitute for `indent-for-comment' in CPerl." (interactive) (let (cperl-wrong-comment) (indent-for-comment) @@ -1001,6 +1137,22 @@ (progn (cperl-to-comment-or-eol) (forward-char (length comment-start)))))) +(defun cperl-comment-region (b e arg) + "Comment or uncomment each line in the region in CPerl mode. +See `comment-region'." + (interactive "r\np") + (let ((comment-start "#")) + (comment-region b e arg))) + +(defun cperl-uncomment-region (b e arg) + "Uncomment or comment each line in the region in CPerl mode. +See `comment-region'." + (interactive "r\np") + (let ((comment-start "#")) + (comment-region b e (- arg)))) + +(defvar cperl-brace-recursing nil) + (defun cperl-electric-brace (arg &optional only-before) "Insert character and correct line's indentation. If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the @@ -1008,55 +1160,74 @@ char is \"{\", insert extra newline before only if `cperl-extra-newline-before-brace'." (interactive "P") - (let (insertpos) - (if (and (not arg) ; No args, end (of empty line or auto) - (eolp) - (or (and (null only-before) - (save-excursion - (skip-chars-backward " \t") - (bolp))) - (and (eq last-command-char ?\{) ; Do not insert newline - ;; if after ")" and `cperl-extra-newline-before-brace' - ;; is nil, do not insert extra newline. - (not cperl-extra-newline-before-brace) - (save-excursion - (skip-chars-backward " \t") - (eq (preceding-char) ?\)))) - (if cperl-auto-newline - (progn (cperl-indent-line) (newline) t) nil))) + (let (insertpos + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil))) + (if (and other-end + (not cperl-brace-recursing) + (cperl-val 'cperl-electric-parens) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) + ;; Need to insert a matching pair (progn - (if cperl-auto-newline - (setq insertpos (point))) - (insert last-command-char) - (cperl-indent-line) - (if (and cperl-auto-newline (null only-before)) - (progn - (newline) - (cperl-indent-line))) (save-excursion - (if insertpos (progn (goto-char insertpos) - (search-forward (make-string - 1 last-command-char)) - (setq insertpos (1- (point))))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun cperl-electric-lbrace (arg) + (setq insertpos (point-marker)) + (goto-char other-end) + (setq last-command-char ?\{) + (cperl-electric-lbrace arg insertpos)) + (forward-char 1)) + (if (and (not arg) ; No args, end (of empty line or auto) + (eolp) + (or (and (null only-before) + (save-excursion + (skip-chars-backward " \t") + (bolp))) + (and (eq last-command-char ?\{) ; Do not insert newline + ;; if after ")" and `cperl-extra-newline-before-brace' + ;; is nil, do not insert extra newline. + (not cperl-extra-newline-before-brace) + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) + (if cperl-auto-newline + (progn (cperl-indent-line) (newline) t) nil))) + (progn + (if cperl-auto-newline + (setq insertpos (point))) + (insert last-command-char) + (cperl-indent-line) + (if (and cperl-auto-newline (null only-before)) + (progn + (newline) + (cperl-indent-line))) + (save-excursion + (if insertpos (progn (goto-char insertpos) + (search-forward (make-string + 1 last-command-char)) + (setq insertpos (1- (point))))) + (delete-char -1)))) + (if insertpos + (save-excursion + (goto-char insertpos) + (self-insert-command (prefix-numeric-value arg))) + (self-insert-command (prefix-numeric-value arg)))))) + +(defun cperl-electric-lbrace (arg &optional end) "Insert character, correct line's indentation, correct quoting by space." (interactive "P") (let (pos after + (cperl-brace-recursing t) (cperl-auto-newline cperl-auto-newline) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil))) + (other-end (or end + (if (and cperl-electric-parens-mark + (cperl-mark-active) + (> (mark) (point))) + (save-excursion + (goto-char (mark)) + (point-marker)) + nil)))) (and (cperl-val 'cperl-electric-lbrace-space) (eq (preceding-char) ?$) (save-excursion @@ -1105,10 +1276,39 @@ (insert last-command-char) ))) +(defun cperl-electric-rparen (arg) + "Insert a matching pair of parentheses if marking is active. +If not, or if we are not at the end of marking range, would self-insert." + (interactive "P") + (let ((beg (save-excursion (beginning-of-line) (point))) + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil)) + p) + (if (and other-end + (cperl-val 'cperl-electric-parens) + (memq last-command-char '( ?\) ?\] ?\} ?\> )) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + ) + (progn + (insert last-command-char) + (setq p (point)) + (if other-end (goto-char other-end)) + (insert (cdr (assoc last-command-char '((?\} . ?\{) + (?\] . ?\[) + (?\) . ?\() + (?\> . ?\<))))) + (goto-char (1+ p))) + (call-interactively 'self-insert-command) + ))) + (defun cperl-electric-keyword () "Insert a construction appropriate after a keyword." (let ((beg (save-excursion (beginning-of-line) (point))) - (dollar (eq (preceding-char) ?$))) + (dollar (eq last-command-char ?$))) (and (save-excursion (backward-sexp 1) (cperl-after-expr-p nil "{};:")) @@ -1181,21 +1381,24 @@ (if (and ; Check if we need to split: ; i.e., on a boundary and inside "{...}" (save-excursion (cperl-to-comment-or-eol) - (>= (point) pos)) + (>= (point) pos)) ; Not in a comment (or (save-excursion (skip-chars-backward " \t" beg) (forward-char -1) - (looking-at "[;{]")) - (looking-at "[ \t]*}") - (re-search-forward "\\=[ \t]*;" end t)) + (looking-at "[;{]")) ; After { or ; + spaces + (looking-at "[ \t]*}") ; Before } + (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; (save-excursion (and - (eq (car (parse-partial-sexp pos end -1)) -1) + (eq (car (parse-partial-sexp pos end -1)) -1) + ; Leave the level of parens (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr + ; Are at end (progn (backward-sexp 1) (setq start (point-marker)) - (<= start pos))))) + (<= start pos))))) ; Redundant? Are after the + ; start of parens group. (progn (skip-chars-backward " \t") (or (memq (preceding-char) (append ";{" nil)) @@ -1228,10 +1431,19 @@ (end-of-line) (newline-and-indent)) (end-of-line) ; else - (if (not (looking-at "\n[ \t]*$")) - (newline-and-indent) - (forward-line 1) - (cperl-indent-line))))) + (cond + ((and (looking-at "\n[ \t]*{$") + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) ; Probably if () {} group + ; with an extra newline. + (forward-line 2) + (cperl-indent-line)) + ((looking-at "\n[ \t]*$") ; Next line is empty - use it. + (forward-line 1) + (cperl-indent-line)) + (t + (newline-and-indent)))))) (defun cperl-electric-semi (arg) "Insert character and correct line's indentation." @@ -1247,7 +1459,8 @@ (auto (and cperl-auto-newline (or (not (eq last-command-char ?:)) cperl-auto-newline-after-colon)))) - (if (and (not arg) (eolp) + (if (and ;;(not arg) + (eolp) (not (save-excursion (beginning-of-line) (skip-chars-forward " \t") @@ -1270,9 +1483,9 @@ (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) (progn (insert last-command-char) - (forward-char -1) + ;;(forward-char -1) (if auto (setq insertpos (point-marker))) - (forward-char 1) + ;;(forward-char 1) (cperl-indent-line) (if auto (progn @@ -1285,7 +1498,7 @@ ;; (setq insertpos (1- (point))))) ;; (delete-char -1)))) (save-excursion - (if insertpos (goto-char (marker-position insertpos)) + (if insertpos (goto-char (1- (marker-position insertpos))) (forward-char -1)) (delete-char 1)))) (if insertpos @@ -1321,7 +1534,6 @@ (error nil))) (defun cperl-indent-command (&optional whole-exp) - (interactive "P") "Indent current line as Perl code, or in some cases insert a tab character. If `cperl-tab-always-indent' is non-nil (the default), always indent current line. Otherwise, indent the current line only if point is at the left margin @@ -1331,6 +1543,7 @@ means indent rigidly all the lines of the expression starting after point so that this line becomes properly indented. The relative indentation among the lines of the expression are preserved." + (interactive "P") (if whole-exp ;; If arg, always indent this line as Perl ;; and shift remaining lines of expression the same amount. @@ -1403,7 +1616,7 @@ '(?w ?_)) (progn (backward-sexp) - (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:")))) + (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) (defun cperl-get-state (&optional parse-start start-state) ;; returns list (START STATE DEPTH PRESTART), START is a good place @@ -1441,19 +1654,19 @@ (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp ; Label may be mixed up with `$blah :' (save-excursion (cperl-after-label)) - (and (eq (char-syntax (preceding-char)) ?w) + (and (memq (char-syntax (preceding-char)) '(?w ?_)) (progn (backward-sexp) ;; Need take into account `bless', `return', `tr',... - (or (and (looking-at "\\sw+[ \t\n\f]*[{#]") ; Method call syntax + (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>"))) (progn (skip-chars-backward " \t\n\f") - (and (eq (char-syntax (preceding-char)) ?w) + (and (memq (char-syntax (preceding-char)) '(?w ?_)) (progn (backward-sexp) (looking-at - "sub[ \t]+\\sw+[ \t\n\f]*[#{]"))))))))) + "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*[#{]"))))))))) (defun cperl-calculate-indent (&optional parse-start symbol) "Return appropriate indentation for current line as Perl code. @@ -1536,7 +1749,12 @@ ;; Now add a little if this is a continuation line. (if (or (bobp) (memq (preceding-char) (append " ;}" nil)) ; Was ?\) - (memq char-after (append ")]}" nil))) + (memq char-after (append ")]}" nil)) + (and (eq (preceding-char) ?\:) ; label + (progn + (forward-sexp -1) + (skip-chars-backward " \t") + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) 0 cperl-continued-statement-offset)))) ((/= (char-after containing-sexp) ?{) @@ -1598,7 +1816,7 @@ (or ;; If no, find that first statement and indent like ;; it. If the first statement begins with label, do - ;; not belive when the indentation of the label is too + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1621,7 +1839,7 @@ (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (+ old-indent cperl-indent-level)) (current-column))))) ;; If no previous statement, @@ -1648,7 +1866,7 @@ (if (eq (preceding-char) ?\)) (forward-sexp -1)) ;; In the case it starts a subroutine, indent with - ;; respect to `sub', not with respect to the + ;; respect to `sub', not with respect to the the ;; first thing on the line, say in the case of ;; anonymous sub in a hash. ;; @@ -1771,7 +1989,7 @@ (or ;; If no, find that first statement and indent like ;; it. If the first statement begins with label, do - ;; not belive when the indentation of the label is too + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1797,7 +2015,7 @@ (if (> (current-indentation) cperl-min-label-indent) (list (list 'label-in-block (point))) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (list (list 'label-in-block-min-indent (point)))) ;; Before statement @@ -1909,84 +2127,263 @@ (interactive) (or min (setq min (point-min))) (or max (setq max (point-max))) - (let (face head-face here-face b e bb tag err + (let (face head-face here-face b e bb tag qtag err b1 e1 argument (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) - (modified (buffer-modified-p))) + (modified (buffer-modified-p)) + (after-change-functions nil) + (search + (concat + "\\(\\`\n?\\|\n\n\\)=" + "\\|" + ;; One extra () before this: + "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)[^=]\\)" ; [^=] to avoid <<=. + "\\|" + ;; 1+5 extra () before this: + "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) (unwind-protect (progn (save-excursion - (message "Scanning for pods and here-docs...") + (message "Scanning for pods, formats and here-docs...") (if cperl-pod-here-fontify - (setq face (eval cperl-pod-face) - head-face (eval cperl-pod-head-face) - here-face (eval cperl-here-face))) + ;; We had evals here, do not know why... + (setq face cperl-pod-face + head-face cperl-pod-head-face + here-face cperl-here-face)) (remove-text-properties min max '(syntax-type t)) ;; Need to remove face as well... (goto-char min) - (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) - (if (looking-at "\n*cut\\>") - (progn - (message "=cut is not preceeded by a pod section") - (setq err (point))) - (beginning-of-line) - (setq b (point) bb b) - (or (re-search-forward "\n\n=cut\\>" max 'toend) - (message "Cannot find the end of a pod section")) - (beginning-of-line 4) - (setq e (point)) - (put-text-property b e 'in-pod t) - (goto-char b) - (while (re-search-forward "\n\n[ \t]" e t) + (while (re-search-forward search max t) + (cond + ((match-beginning 1) ; POD section + ;; "\\(\\`\n?\\|\n\n\\)=" + (if (looking-at "\n*cut\\>") + (progn + (message "=cut is not preceeded by a pod section") + (setq err (point))) (beginning-of-line) - (put-text-property b (point) 'syntax-type 'pod) - (put-text-property (max (point-min) (1- b)) - (point) cperl-do-not-fontify t) - (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) - (re-search-forward "\n\n[^ \t\f]" e 'toend) - (beginning-of-line) - (setq b (point))) - (put-text-property (point) e 'syntax-type 'pod) - (put-text-property (max (point-min) (1- (point))) - e cperl-do-not-fontify t) + + (setq b (point) bb b) + (or (re-search-forward "\n\n=cut\\>" max 'toend) + (message "Cannot find the end of a pod section")) + (beginning-of-line 3) + (setq e (point)) + (put-text-property b e 'in-pod t) + (goto-char b) + (while (re-search-forward "\n\n[ \t]" e t) + (beginning-of-line) + (put-text-property b (point) 'syntax-type 'pod) + (cperl-put-do-not-fontify b (point)) + ;;(put-text-property (max (point-min) (1- b)) + ;; (point) cperl-do-not-fontify t) + (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) + (re-search-forward "\n\n[^ \t\f\n]" e 'toend) + (beginning-of-line) + (setq b (point))) + (put-text-property (point) e 'syntax-type 'pod) + (cperl-put-do-not-fontify (point) e) + ;;(put-text-property (max (point-min) (1- (point))) + ;; e cperl-do-not-fontify t) + (if cperl-pod-here-fontify + (progn (put-text-property (point) e 'face face) + (goto-char bb) + (if (looking-at + "=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") + (put-text-property + (match-beginning 1) (match-end 1) + 'face head-face)) + (while (re-search-forward + ;; One paragraph + "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" + e 'toend) + (put-text-property + (match-beginning 1) (match-end 1) + 'face head-face)))) + (goto-char e))) + ;; Here document + ;; 1 () ahead + ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" + ((match-beginning 2) ; 1 + 1 + ;; Abort in comment (_extremely_ simplified): + (setq b (point)) + (if (save-excursion + (beginning-of-line) + (search-forward "#" b t)) + nil + (if (match-beginning 5) ;4 + 1 + (setq b1 (match-beginning 5) ; 4 + 1 + e1 (match-end 5)) ; 4 + 1 + (setq b1 (match-beginning 4) ; 3 + 1 + e1 (match-end 4))) ; 3 + 1 + (setq tag (buffer-substring b1 e1) + qtag (regexp-quote tag)) + (cond (cperl-pod-here-fontify + (put-text-property b1 e1 'face font-lock-reference-face) + (cperl-put-do-not-fontify b1 e1))) + (forward-line) + (setq b (point)) + (cond ((re-search-forward (concat "^" qtag "$") max 'toend) + (if cperl-pod-here-fontify + (progn + (put-text-property (match-beginning 0) (match-end 0) + 'face font-lock-reference-face) + (cperl-put-do-not-fontify b (match-end 0)) + ;;(put-text-property (max (point-min) (1- b)) + ;; (min (point-max) + ;; (1+ (match-end 0))) + ;; cperl-do-not-fontify t) + (put-text-property b (match-beginning 0) + 'face here-face))) + (put-text-property b (match-beginning 0) + 'syntax-type 'here-doc) + (cperl-put-do-not-fontify b (match-beginning 0))) + (t (message "End of here-document `%s' not found." tag))))) + ;; format + (t + ;; 1+5=6 extra () before this: + ;; "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) + (setq b (point) + name (if (match-beginning 7) ; 6 + 1 + (buffer-substring (match-beginning 7) ; 6 + 1 + (match-end 7)) ; 6 + 1 + "")) + (setq argument nil) (if cperl-pod-here-fontify - (progn (put-text-property (point) e 'face face) - (goto-char bb) - (while (re-search-forward - ;; One paragraph - "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" - e 'toend) - (put-text-property - (match-beginning 1) (match-end 1) - 'face head-face)))) - (goto-char e))) - (goto-char min) - (while (re-search-forward - "<<\\(\\([\"'`]\\)?\\)\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\1" - max t) - (setq tag (buffer-substring (match-beginning 3) - (match-end 3))) - (if cperl-pod-here-fontify - (put-text-property (match-beginning 3) (match-end 3) - 'face font-lock-reference-face)) - (forward-line) - (setq b (point)) - (and (re-search-forward (concat "^" tag "$") max 'toend) - (progn - (if cperl-pod-here-fontify - (progn - (put-text-property (match-beginning 0) (match-end 0) - 'face font-lock-reference-face) - (put-text-property (max (point-min) (1- b)) - (min (point-max) - (1+ (match-end 0))) - cperl-do-not-fontify t) - (put-text-property b (match-beginning 0) - 'face here-face))) - (put-text-property b (match-beginning 0) - 'syntax-type 'here-doc))))) + (while (and (eq (forward-line) 0) + (not (looking-at "^[.;]$"))) + (cond + ((looking-at "^#")) ; Skip comments + ((and argument ; Skip argument multi-lines + (looking-at "^[ \t]*{")) + (forward-sexp 1) + (setq argument nil)) + (argument ; Skip argument lines + (setq argument nil)) + (t ; Format line + (setq b1 (point)) + (setq argument (looking-at "^[^\n]*[@^]")) + (end-of-line) + (put-text-property b1 (point) + 'face font-lock-string-face) + (cperl-put-do-not-fontify b1 (point))))) + (re-search-forward (concat "^[.;]$") max 'toend)) + (beginning-of-line) + (if (looking-at "^[.;]$") + (progn + (put-text-property (point) (+ (point) 2) + 'face font-lock-string-face) + (cperl-put-do-not-fontify (point) (+ (point) 2))) + (message "End of format `%s' not found." name)) + (forward-line) + (put-text-property b (point) 'syntax-type 'format) +;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) +;;; (if cperl-pod-here-fontify +;;; (progn +;;; (put-text-property b (match-end 0) +;;; 'face font-lock-string-face) +;;; (cperl-put-do-not-fontify b (match-end 0)))) +;;; (put-text-property b (match-end 0) +;;; 'syntax-type 'format) +;;; (cperl-put-do-not-fontify b (match-beginning 0))) +;;; (t (message "End of format `%s' not found." name))) + ))) +;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) +;;; (if (looking-at "\n*cut\\>") +;;; (progn +;;; (message "=cut is not preceeded by a pod section") +;;; (setq err (point))) +;;; (beginning-of-line) + +;;; (setq b (point) bb b) +;;; (or (re-search-forward "\n\n=cut\\>" max 'toend) +;;; (message "Cannot find the end of a pod section")) +;;; (beginning-of-line 3) +;;; (setq e (point)) +;;; (put-text-property b e 'in-pod t) +;;; (goto-char b) +;;; (while (re-search-forward "\n\n[ \t]" e t) +;;; (beginning-of-line) +;;; (put-text-property b (point) 'syntax-type 'pod) +;;; (cperl-put-do-not-fontify b (point)) +;;; ;;(put-text-property (max (point-min) (1- b)) +;;; ;; (point) cperl-do-not-fontify t) +;;; (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) +;;; (re-search-forward "\n\n[^ \t\f\n]" e 'toend) +;;; (beginning-of-line) +;;; (setq b (point))) +;;; (put-text-property (point) e 'syntax-type 'pod) +;;; (cperl-put-do-not-fontify (point) e) +;;; ;;(put-text-property (max (point-min) (1- (point))) +;;; ;; e cperl-do-not-fontify t) +;;; (if cperl-pod-here-fontify +;;; (progn (put-text-property (point) e 'face face) +;;; (goto-char bb) +;;; (if (looking-at +;;; "=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") +;;; (put-text-property +;;; (match-beginning 1) (match-end 1) +;;; 'face head-face)) +;;; (while (re-search-forward +;;; ;; One paragraph +;;; "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" +;;; e 'toend) +;;; (put-text-property +;;; (match-beginning 1) (match-end 1) +;;; 'face head-face)))) +;;; (goto-char e))) +;;; (goto-char min) +;;; (while (re-search-forward +;;; ;; We exclude \n to avoid misrecognition inside quotes. +;;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\2\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" +;;; max t) +;;; (if (match-beginning 4) +;;; (setq b1 (match-beginning 4) +;;; e1 (match-end 4)) +;;; (setq b1 (match-beginning 3) +;;; e1 (match-end 3))) +;;; (setq tag (buffer-substring b1 e1) +;;; qtag (regexp-quote tag)) +;;; (cond (cperl-pod-here-fontify +;;; (put-text-property b1 e1 'face font-lock-reference-face) +;;; (cperl-put-do-not-fontify b1 e1))) +;;; (forward-line) +;;; (setq b (point)) +;;; (cond ((re-search-forward (concat "^" qtag "$") max 'toend) +;;; (if cperl-pod-here-fontify +;;; (progn +;;; (put-text-property (match-beginning 0) (match-end 0) +;;; 'face font-lock-reference-face) +;;; (cperl-put-do-not-fontify b (match-end 0)) +;;; ;;(put-text-property (max (point-min) (1- b)) +;;; ;; (min (point-max) +;;; ;; (1+ (match-end 0))) +;;; ;; cperl-do-not-fontify t) +;;; (put-text-property b (match-beginning 0) +;;; 'face here-face))) +;;; (put-text-property b (match-beginning 0) +;;; 'syntax-type 'here-doc) +;;; (cperl-put-do-not-fontify b (match-beginning 0))) +;;; (t (message "End of here-document `%s' not found." tag)))) +;;; (goto-char min) +;;; (while (re-search-forward +;;; "^[ \t]*format[ \t]*\\(\\([a-zA-Z0-9_]+[ \t]*\\)?\\)=[ \t]*$" +;;; max t) +;;; (setq b (point) +;;; name (buffer-substring (match-beginning 1) +;;; (match-end 1))) +;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) +;;; (if cperl-pod-here-fontify +;;; (progn +;;; (put-text-property b (match-end 0) +;;; 'face font-lock-string-face) +;;; (cperl-put-do-not-fontify b (match-end 0)))) +;;; (put-text-property b (match-end 0) +;;; 'syntax-type 'format) +;;; (cperl-put-do-not-fontify b (match-beginning 0))) +;;; (t (message "End of format `%s' not found." name)))) +) (if err (goto-char err) - (message "Scan for pods and here-docs completed."))) + (message "Scan for pods, formats and here-docs completed."))) (and (buffer-modified-p) (not modified) (set-buffer-modified-p nil))))) @@ -2234,16 +2631,37 @@ (defvar imenu-example--function-name-regexp-perl "^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\|=head\\([12]\\)[ \t]+\\([^\n]+\\)$\\)") +(defun cperl-imenu-addback (lst &optional isback name) + ;; We suppose that the lst is a DAG, unless the first element only + ;; loops back, and ISBACK is set. Thus this function cannot be + ;; applied twice without ISBACK set. + (cond ((not cperl-imenu-addback) lst) + (t + (or name + (setq name "+++BACK+++")) + (mapcar (function (lambda (elt) + (if (and (listp elt) (listp (cdr elt))) + (progn + ;; In the other order it goes up + ;; one level only ;-( + (setcdr elt (cons (cons name lst) + (cdr elt))) + (cperl-imenu-addback (cdr elt) t name) + )))) + (if isback (cdr lst) lst)) + lst))) + (defun imenu-example--create-perl-index (&optional regexp) (require 'cl) (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) + (index-meth-alist '()) meth packages ends-ranges p (prev-pos 0) char fchar index index1 name (end-range 0) package) (goto-char (point-min)) (imenu-progress-message prev-pos 0) ;; Search for the function - (save-match-data + (progn ;;save-match-data (while (re-search-forward (or regexp imenu-example--function-name-regexp-perl) nil t) @@ -2255,7 +2673,7 @@ (goto-char (match-beginning 2)) (setq fchar (following-char)) ) - (setq char (following-char)) + (setq char (following-char) meth nil) (setq p (point)) (while (and ends-ranges (>= p (car ends-ranges))) ;; delete obsolete entries @@ -2263,32 +2681,40 @@ (setq package (or (car packages) "") end-range (or (car ends-ranges) 0)) (if (eq fchar ?p) - (progn - (setq name (buffer-substring (match-beginning 3) (match-end 3)) - package (concat name "::") - name (concat "package " name) - end-range - (save-excursion - (parse-partial-sexp (point) (point-max) -1) (point)) - ends-ranges (cons end-range ends-ranges) - packages (cons package packages)))) + (setq name (buffer-substring (match-beginning 3) (match-end 3)) + name (progn + (set-text-properties 0 (length name) nil name) + name) + package (concat name "::") + name (concat "package " name) + end-range + (save-excursion + (parse-partial-sexp (point) (point-max) -1) (point)) + ends-ranges (cons end-range ends-ranges) + packages (cons package packages))) ;; ) ;; Skip this function name if it is a prototype declaration. (if (and (eq fchar ?s) (eq char ?\;)) nil + (setq index (imenu-example--name-and-position)) (if (eq fchar ?p) nil (setq name (buffer-substring (match-beginning 3) (match-end 3))) - (if (or (> p end-range) (string-match "[:']" name)) nil - (setq name (concat package name)))) - (setq index (imenu-example--name-and-position)) + (set-text-properties 0 (length name) nil name) + (cond ((string-match "[:']" name) + (setq meth t)) + ((> p end-range) nil) + (t + (setq name (concat package name) meth t)))) (setcar index name) (if (eq fchar ?p) (push index index-pack-alist) (push index index-alist)) + (if meth (push index index-meth-alist)) (push index index-unsorted-alist))) (t ; Pod section ;; (beginning-of-line) (setq index (imenu-example--name-and-position) name (buffer-substring (match-beginning 5) (match-end 5))) + (set-text-properties 0 (length name) nil name) (if (eq (char-after (match-beginning 4)) ?2) (setq name (concat " " name))) (setcar index name) @@ -2301,20 +2727,55 @@ (sort index-alist (default-value 'imenu-sort-function)) (nreverse index-alist))) (and index-pod-alist - (push (cons (imenu-create-submenu-name "+POD headers+") + (push (cons "+POD headers+..." (nreverse index-pod-alist)) index-alist)) + (and (or index-pack-alist index-meth-alist) + (let ((lst index-pack-alist) hier-list pack elt group name) + ;; Remove "package ", reverse and uniquify. + (while lst + (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8)) + (if (assoc name hier-list) nil + (setq hier-list (cons (cons name (cdr elt)) hier-list)))) + (setq lst index-meth-alist) + (while lst + (setq elt (car lst) lst (cdr lst)) + (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) + (setq pack (substring (car elt) 0 (match-beginning 0))) + (if (setq group (assoc pack hier-list)) + (if (listp (cdr group)) + ;; Have some functions already + (setcdr group + (cons (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt)) + (cdr group))) + (setcdr group (list (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt))))) + (setq hier-list + (cons (cons pack + (list (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt)))) + hier-list)))))) + (push (cons "+Hierarchy+..." + hier-list) + index-alist))) (and index-pack-alist - (push (cons (imenu-create-submenu-name "+Packages+") + (push (cons "+Packages+..." (nreverse index-pack-alist)) index-alist)) (and (or index-pack-alist index-pod-alist (default-value 'imenu-sort-function)) index-unsorted-alist - (push (cons (imenu-create-submenu-name "+Unsorted List+") + (push (cons "+Unsorted List+..." (nreverse index-unsorted-alist)) index-alist)) - index-alist)) + (cperl-imenu-addback index-alist))) (defvar cperl-compilation-error-regexp-alist ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). @@ -2376,36 +2837,43 @@ "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" ; In what follows we use `type' style - ; for overwritable buildins + ; for overwritable builtins (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" "and" "atan2" - ;; "bind" "binmode" "bless" "caller" "chdir" "chmod" "chown" "chr" - ;; "chroot" "close" "closedir" "cmp" "connect" "continue" "cos" - ;; "crypt" "dbmclose" "dbmopen" "die" "dump" "endgrent" "endhostent" - ;; "endnetent" "endprotoent" "endpwent" "endservent" "eof" "eq" "exec" - ;; "exit" "exp" "fcntl" "fileno" "flock" "fork" "formline" "ge" "getc" - ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" "gethostbyname" - ;; "gethostent" "getlogin" "getnetbyaddr" "getnetbyname" "getnetent" - ;; "getpeername" "getpgrp" "getppid" "getpriority" "getprotobyname" - ;; "getprotobynumber" "getprotoent" "getpwent" "getpwnam" "getpwuid" - ;; "getservbyname" "getservbyport" "getservent" "getsockname" - ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" "ioctl" - ;; "join" "kill" "lc" "lcfirst" "le" "length" "link" "listen" - ;; "localtime" "log" "lstat" "lt" "mkdir" "msgctl" "msgget" "msgrcv" - ;; "msgsnd" "ne" "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" - ;; "quotemeta" "rand" "read" "readdir" "readline" "readlink" - ;; "readpipe" "recv" "ref" "rename" "require" "reset" "reverse" - ;; "rewinddir" "rindex" "rmdir" "seek" "seekdir" "select" "semctl" - ;; "semget" "semop" "send" "setgrent" "sethostent" "setnetent" - ;; "setpgrp" "setpriority" "setprotoent" "setpwent" "setservent" - ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" "shutdown" - ;; "sin" "sleep" "socket" "socketpair" "sprintf" "sqrt" "srand" "stat" - ;; "substr" "symlink" "syscall" "sysread" "system" "syswrite" "tell" - ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" "umask" "unlink" - ;; "unpack" "utime" "values" "vec" "wait" "waitpid" "wantarray" "warn" - ;; "write" "x" "xor" + ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" + ;; "and" "atan2" "bind" "binmode" "bless" "caller" + ;; "chdir" "chmod" "chown" "chr" "chroot" "close" + ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" + ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" + ;; "endhostent" "endnetent" "endprotoent" "endpwent" + ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" + ;; "fileno" "flock" "fork" "formline" "ge" "getc" + ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" + ;; "gethostbyname" "gethostent" "getlogin" + ;; "getnetbyaddr" "getnetbyname" "getnetent" + ;; "getpeername" "getpgrp" "getppid" "getpriority" + ;; "getprotobyname" "getprotobynumber" "getprotoent" + ;; "getpwent" "getpwnam" "getpwuid" "getservbyname" + ;; "getservbyport" "getservent" "getsockname" + ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" + ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" + ;; "link" "listen" "localtime" "log" "lstat" "lt" + ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" + ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" + ;; "quotemeta" "rand" "read" "readdir" "readline" + ;; "readlink" "readpipe" "recv" "ref" "rename" "require" + ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" + ;; "seekdir" "select" "semctl" "semget" "semop" "send" + ;; "setgrent" "sethostent" "setnetent" "setpgrp" + ;; "setpriority" "setprotoent" "setpwent" "setservent" + ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" + ;; "shutdown" "sin" "sleep" "socket" "socketpair" + ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" + ;; "syscall" "sysread" "system" "syswrite" "tell" + ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" + ;; "umask" "unlink" "unpack" "utime" "values" "vec" + ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" "b\\(in\\(d\\|mode\\)\\|less\\)\\|" "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" @@ -2439,18 +2907,20 @@ "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)" "\\)\\>") 2 'font-lock-type-face) ;; In what follows we use `other' style - ;; for nonoverwritable buildins - ;; Somehow 's', 'm' are not autogenerated??? + ;; for nonoverwritable builtins + ;; Somehow 's', 'm' are not auto-generated??? (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" "chop" - ;; "defined" "delete" "do" "each" "else" "elsif" "eval" "exists" "for" - ;; "foreach" "format" "goto" "grep" "if" "keys" "last" "local" "map" - ;; "my" "next" "no" "package" "pop" "pos" "print" "printf" "push" "q" - ;; "qq" "qw" "qx" "redo" "return" "scalar" "shift" "sort" "splice" - ;; "split" "study" "sub" "tie" "tr" "undef" "unless" "unshift" "untie" - ;; "until" "use" "while" "y" + ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" + ;; "chop" "defined" "delete" "do" "each" "else" "elsif" + ;; "eval" "exists" "for" "foreach" "format" "goto" + ;; "grep" "if" "keys" "last" "local" "map" "my" "next" + ;; "no" "package" "pop" "pos" "print" "printf" "push" + ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" + ;; "sort" "splice" "split" "study" "sub" "tie" "tr" + ;; "undef" "unless" "unshift" "untie" "until" "use" + ;; "while" "y" "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" @@ -2467,11 +2937,13 @@ ;; "#include" "#define" "#undef") ;; "\\|") '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 - font-lock-function-name-face) ; Not very good, triggers at "[a-z]" + font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" '("\\*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (2 font-lock-string-face t) @@ -2511,8 +2983,14 @@ (setq t-font-lock-keywords-1 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock - (not (cperl-xemacs-p)) ; not yet as of XEmacs 19.12 - '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + (not cperl-xemacs-p) ; not yet as of XEmacs 19.12 + '( + ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 + (if (eq (char-after (match-beginning 2)) ?%) + font-lock-other-emphasized-face + font-lock-emphasized-face) + t) ; arrays and hashes + ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) (if (eq (char-after (match-beginning 3)) ?{) @@ -2520,11 +2998,6 @@ font-lock-emphasized-face) ; arrays and hashes font-lock-variable-name-face) ; Just to put something t) - ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 - (if (eq (char-after (match-beginning 2)) ?%) - font-lock-other-emphasized-face - font-lock-emphasized-face) - t) ; arrays and hashes ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") ;;; Too much noise from \s* @s[ and friends ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" @@ -2636,7 +3109,7 @@ 'font-lock-other-type-face "Face to use for data types from another group.") ) - (if (not (cperl-xemacs-p)) nil + (if (not cperl-xemacs-p) nil (or (boundp 'font-lock-comment-face) (defconst font-lock-comment-face 'font-lock-comment-face @@ -2823,7 +3296,7 @@ (mode-compile))) (defun cperl-info-buffer () - ;; Returns buffer with documentation. Creats if missing + ;; Returns buffer with documentation. Creates if missing (let ((info (get-buffer "*info-perl*"))) (if info info (save-window-excursion @@ -2831,7 +3304,7 @@ (require 'info) (save-window-excursion (info)) - (Info-find-node "perl5" "perlfunc") + (Info-find-node cperl-info-page "perlfunc") (set-buffer "*info*") (rename-buffer "*info-perl*") (current-buffer))))) @@ -2923,7 +3396,7 @@ (defun cperl-lineup (beg end &optional step minshift) "Lineup construction in a region. Beginning of region should be at the start of a construction. -All first occurences of this construction in the lines that are +All first occurrences of this construction in the lines that are partially contained in the region are lined up at the same column. MINSHIFT is the minimal amount of space to insert before the construction. @@ -2943,8 +3416,8 @@ (indent-region beg end nil) (goto-char beg) (setq col (current-column)) - (if (looking-at "\\sw") - (if (looking-at "\\<\\sw+\\>") + (if (looking-at "[a-zA-Z0-9_]") + (if (looking-at "\\<[a-zA-Z0-9_]+\\>") (setq search (concat "\\<" (regexp-quote @@ -2964,7 +3437,7 @@ (setq tcol (current-column) seen t) (if (> tcol col) (setq col tcol))) (or seen - (error "The construction to line up occured only once")) + (error "The construction to line up occurred only once")) (goto-char beg) (setq col (+ col minshift)) (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) @@ -3034,3 +3507,1022 @@ (message "Parentheses will %sbe auto-doubled now." (if (cperl-val 'cperl-electric-parens) "" "not "))) +;;;; Tags file creation. + +(defvar cperl-tmp-buffer " *cperl-tmp*") + +(defun cperl-setup-tmp-buf () + (set-buffer (get-buffer-create cperl-tmp-buffer)) + (set-syntax-table cperl-mode-syntax-table) + (buffer-disable-undo) + (auto-fill-mode 0)) + +(defun cperl-xsub-scan () + (require 'cl) + (require 'imenu) + (let ((index-alist '()) + (prev-pos 0) index index1 name package prefix) + (goto-char (point-min)) + (imenu-progress-message prev-pos 0) + ;; Search for the function + (progn ;;save-match-data + (while (re-search-forward + "^\\([ \t]*MODULE\\>[^\n]*\\\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" + nil t) + (imenu-progress-message prev-pos) + (cond + ((match-beginning 2) ; SECTION + (setq package (buffer-substring (match-beginning 2) (match-end 2))) + (goto-char (match-beginning 0)) + (skip-chars-forward " \t") + (forward-char 1) + (if (looking-at "[^\n]*\\") + (setq prefix (buffer-substring (match-beginning 1) (match-end 1))) + (setq prefix nil))) + ((not package) nil) ; C language section + ((match-beginning 3) ; XSUB + (goto-char (1+ (match-beginning 3))) + (setq index (imenu-example--name-and-position)) + (setq name (buffer-substring (match-beginning 3) (match-end 3))) + (if (and prefix (string-match (concat "^" prefix) name)) + (setq name (substring name (length prefix)))) + (cond ((string-match "::" name) nil) + (t + (setq index1 (cons (concat package "::" name) (cdr index))) + (push index1 index-alist))) + (setcar index name) + (push index index-alist)) + (t ; BOOT: section + ;; (beginning-of-line) + (setq index (imenu-example--name-and-position)) + (setcar index (concat package "::BOOT:")) + (push index index-alist))))) + (imenu-progress-message prev-pos 100) + ;;(setq index-alist + ;; (if (default-value 'imenu-sort-function) + ;; (sort index-alist (default-value 'imenu-sort-function)) + ;; (nreverse index-alist))) + index-alist)) + +(defun cperl-find-tags (file xs) + (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret) + (save-excursion + (if b (set-buffer b) + (cperl-setup-tmp-buf)) + (erase-buffer) + (setq file (car (insert-file-contents file))) + (message "Scanning file %s..." file) + (if xs + (setq lst (cperl-xsub-scan)) + (setq ind (imenu-example--create-perl-index)) + (setq lst (cdr (assoc "+Unsorted List+..." ind)))) + (setq lst + (mapcar + (function + (lambda (elt) + (cond ((string-match "^[_a-zA-Z]" (car elt)) + (goto-char (cdr elt)) + (list (car elt) + (point) (count-lines 1 (point)) + (buffer-substring (progn + (skip-chars-forward + ":_a-zA-Z0-9") + (or (eolp) (forward-char 1)) + (point)) + (progn + (beginning-of-line) + (point)))))))) + lst)) + (erase-buffer) + (while lst + (setq elt (car lst) lst (cdr lst)) + (if elt + (progn + (insert (elt elt 3) + 127 + (if (string-match "^package " (car elt)) + (substring (car elt) 8) + (car elt) ) + 1 + (number-to-string (elt elt 1)) + "," + (number-to-string (elt elt 2)) + "\n") + (if (and (string-match "^[_a-zA-Z]+::" (car elt)) + (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" + (elt elt 3))) + ;; Need to insert the name without package as well + (setq lst (cons (cons (substring (elt elt 3) + (match-beginning 1) + (match-end 1)) + (cdr elt)) + lst)))))) + (setq pos (point)) + (goto-char 1) + (insert "\f\n" file "," (number-to-string (1- pos)) "\n") + (setq ret (buffer-substring 1 (point-max))) + (erase-buffer) + (message "Scanning file %s finished" file) + ret))) + +(defun cperl-write-tags (&optional file erase recurse dir inbuffer) + ;; If INBUFFER, do not select buffer, and do not save + ;; If ERASE is `ignore', do not erase, and do not try to delete old info. + (require 'etags) + (if file nil + (setq file (if dir default-directory (buffer-file-name))) + (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!"))) + (let ((tags-file-name "TAGS") + (case-fold-search (eq system-type 'emx)) + xs) + (save-excursion + (cond (inbuffer nil) ; Already there + ((file-exists-p tags-file-name) + (visit-tags-table-buffer tags-file-name)) + (t (set-buffer (find-file-noselect tags-file-name)))) + (cond + (dir + (cond ((eq erase 'ignore)) + (erase + (erase-buffer) + (setq erase 'ignore))) + (let ((files + (directory-files file t (if recurse nil "\\.[Pp][Llm]$") t))) + (mapcar (function (lambda (file) + (cond + ((string-match "/\\.\\.?$" file) nil) + ((not (file-directory-p file)) + (if (string-match "\\.\\([Pp][Llm]\\|xs\\)$" file) + (cperl-write-tags file erase recurse nil t))) + ((not recurse) nil) + (t (cperl-write-tags file erase recurse t t))))) + files)) + ) + (t + (setq xs (string-match "\\.xs$" file)) + (cond ((eq erase 'ignore) nil) + (erase (erase-buffer)) + (t + (goto-char 1) + (if (search-forward (concat "\f\n" file ",") nil t) + (progn + (search-backward "\f\n") + (delete-region (point) + (progn + (forward-char 1) + (search-forward "\f\n" nil 'toend) + (point))) + (goto-char 1))))) + (insert (cperl-find-tags file xs)))) + (if inbuffer nil ; Delegate to the caller + (save-buffer 0) ; No backup + (initialize-new-tags-table))))) + +(defvar cperl-tags-hier-regexp-list + "^\\(\\(package\\)\\>\\|sub\\>[^\n]+::\\|[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::\\|[ \t]*BOOT:\C-?[^\n]+::\\)") + +(defvar cperl-hierarchy '(() ()) + "Global hierarchy of classes") + +(defun cperl-tags-hier-fill () + ;; Suppose we are in a tag table cooked by cperl. + (goto-char 1) + (let (type pack name pos line chunk ord cons1 file str info fileind) + (while (re-search-forward cperl-tags-hier-regexp-list nil t) + (setq pos (match-beginning 0) + pack (match-beginning 2)) + (beginning-of-line) + (if (looking-at "\\([^\n]+\\)\C-?\\([^\n]+\\)\C-a\\([0-9]+\\),\\([0-9]+\\)") + (progn + (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) + name (buffer-substring (match-beginning 2) (match-end 2)) + ;;pos (buffer-substring (match-beginning 3) (match-end 3)) + line (buffer-substring (match-beginning 4) (match-end 4)) + ord (if pack 1 0) + info (etags-snarf-tag) ; Moves to beginning of the next line + file (file-of-tag) + fileind (format "%s:%s" file line)) + ;; Move back + (forward-char -1) + ;; Make new member of hierarchy name ==> file ==> pos if needed + (if (setq cons1 (assoc name (nth ord cperl-hierarchy))) + ;; Name known + (setcdr cons1 (cons (cons fileind (vector file info)) + (cdr cons1))) + ;; First occurrence of the name, start alist + (setq cons1 (cons name (list (cons fileind (vector file info))))) + (if pack + (setcar (cdr cperl-hierarchy) + (cons cons1 (nth 1 cperl-hierarchy))) + (setcar cperl-hierarchy + (cons cons1 (car cperl-hierarchy))))))) + (end-of-line)))) + +(defun cperl-tags-hier-init (&optional update) + "Show hierarchical menu of classes and methods. +Finds info about classes by a scan of loaded TAGS files. +Supposes that the TAGS files contain fully qualified function names. +One may build such TAGS files from CPerl mode menu." + (interactive) + (require 'etags) + (require 'imenu) + (if (or update (null (nth 2 cperl-hierarchy))) + (let (pack name cons1 to l1 l2 l3 l4 + (remover (function (lambda (elt) ; (name (file1...) (file2..)) + (or (nthcdr 2 elt) + ;; Only in one file + (setcdr elt (cdr (nth 1 elt)))))))) + ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! + (setq cperl-hierarchy (list l1 l2 l3)) + (or tags-table-list + (call-interactively 'visit-tags-table)) + (message "Updating list of classes...") + (mapcar + (function + (lambda (tagsfile) + (set-buffer (get-file-buffer tagsfile)) + (cperl-tags-hier-fill))) + tags-table-list) + (mapcar remover (car cperl-hierarchy)) + (mapcar remover (nth 1 cperl-hierarchy)) + (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) + (cons "Methods: " (car cperl-hierarchy)))) + (cperl-tags-treeify to 1) + (setcar (nthcdr 2 cperl-hierarchy) + (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) + (message "Updating list of classes: done, requesting display...") + ;;(cperl-imenu-addback (nth 2 cperl-hierarchy)) + )) + (or (nth 2 cperl-hierarchy) + (error "No items found")) + (setq update +;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) + (if window-system + (x-popup-menu t (nth 2 cperl-hierarchy)) + (require 'tmm) + (tmm-prompt t (nth 2 cperl-hierarchy)))) + (if (and update (listp update)) + (progn (while (cdr update) (setq update (cdr update))) + (setq update (car update)))) ; Get the last from the list + (if (vectorp update) + (progn + (find-file (elt update 0)) + (etags-goto-tag-location (elt update 1)))) + (if (eq update -999) (cperl-tags-hier-init t))) + +(defun cperl-tags-treeify (to level) + ;; cadr of to is read-write. On start it is a cons + (let* ((regexp (concat "^\\(" (mapconcat + 'identity + (make-list level "[_a-zA-Z0-9]+") + "::") + "\\)\\(::\\)?")) + (packages (cdr (nth 1 to))) + (methods (cdr (nth 2 to))) + l1 head tail cons1 cons2 ord writeto packs recurse + root-packages root-functions ms many_ms same_name ps + (move-deeper + (function + (lambda (elt) + (cond ((and (string-match regexp (car elt)) + (or (eq ord 1) (match-end 2))) + (setq head (substring (car elt) 0 (match-end 1)) + tail (if (match-end 2) (substring (car elt) + (match-end 2))) + recurse t) + (if (setq cons1 (assoc head writeto)) nil + ;; Need to init new head + (setcdr writeto (cons (list head (list "Packages: ") + (list "Methods: ")) + (cdr writeto))) + (setq cons1 (nth 1 writeto))) + (setq cons2 (nth ord cons1)) ; Either packs or meths + (setcdr cons2 (cons elt (cdr cons2)))) + ((eq ord 2) + (setq root-functions (cons elt root-functions))) + (t + (setq root-packages (cons elt root-packages)))))))) + (setcdr to l1) ; Init to dynamic space + (setq writeto to) + (setq ord 1) + (mapcar move-deeper packages) + (setq ord 2) + (mapcar move-deeper methods) + (if recurse + (mapcar (function (lambda (elt) + (cperl-tags-treeify elt (1+ level)))) + (cdr to))) + ;; Now add back functions removed from display + (mapcar (function (lambda (elt) + (setcdr to (cons elt (cdr to))))) + root-functions) + ;; Now add back packages removed from display + (mapcar (function (lambda (elt) + (setcdr to (cons (cons (concat "package " (car elt)) + (cdr elt)) + (cdr to))))) + root-packages) + ;;Now clean up leaders with one child only + (mapcar (function (lambda (elt) + (if (not (and (listp (cdr elt)) + (eq (length elt) 2))) nil + (setcar elt (car (nth 1 elt))) + (setcdr elt (cdr (nth 1 elt)))))) + (cdr to)) + )) + +;;;(x-popup-menu t +;;; '(keymap "Name1" +;;; ("Ret1" "aa") +;;; ("Head1" "ab" +;;; keymap "Name2" +;;; ("Tail1" "x") ("Tail2" "y")))) + +(defun cperl-list-fold (list name limit) + (let (list1 list2 elt1 (num 0)) + (if (<= (length list) limit) list + (setq list1 nil list2 nil) + (while list + (setq num (1+ num) + elt1 (car list) + list (cdr list)) + (if (<= num imenu-max-items) + (setq list2 (cons elt1 list2)) + (setq list1 (cons (cons name + (nreverse list2)) + list1) + list2 (list elt1) + num 1))) + (nreverse (cons (cons name + (nreverse list2)) + list1))))) + +(defun cperl-menu-to-keymap (menu &optional name) + (let (list) + (cons 'keymap + (mapcar + (function + (lambda (elt) + (cond ((listp (cdr elt)) + (setq list (cperl-list-fold + (cdr elt) (car elt) imenu-max-items)) + (cons nil + (cons (car elt) + (cperl-menu-to-keymap list)))) + (t + (list (cdr elt) (car elt)))))) + (cperl-list-fold menu "Root" imenu-max-items))))) + + +(defvar cperl-bad-style-regexp + (mapconcat 'identity + '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign + "[-<>=+^&|]+[^- \t\n=+<>~]" ; sign+ char + ) + "\\|") + "Finds places such that insertion of a whitespace may help a lot.") + +(defvar cperl-not-bad-style-regexp + (mapconcat 'identity + '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ + "[a-zA-Z0-9][|&][a-zA-Z0-9$]" ; abc|def abc&def are often used. + "&[(a-zA-Z0-9$]" ; &subroutine &(var->field) + "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; + "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file + "-[0-9]" ; -5 + "\\+\\+" ; ++var + "--" ; --var + ".->" ; a->b + "->" ; a SPACE ->b + "\\[-" ; a[-1] + "^=" ; =head + "||" + "&&" + "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C + "-[a-zA-Z0-9]+[ \t]*=>" ; -option => value + ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below + ;;"[*/+-|&<.]+=" + ) + "\\|") + "If matches at the start of match found by `my-bad-c-style-regexp', +insertion of a whitespace will not help.") + +(defvar found-bad) + +(defun cperl-find-bad-style () + "Find places in the buffer where insertion of a whitespace may help. +Prompts user for insertion of spaces. +Currently it is tuned to C and Perl syntax." + (interactive) + (let (found-bad (p (point))) + (setq last-nonmenu-event 13) ; To disable popup + (beginning-of-buffer) + (map-y-or-n-p "Insert space here? " + (function (lambda (arg) (insert " "))) + 'cperl-next-bad-style + '("location" "locations" "insert a space into") + '((?\C-r (lambda (arg) + (let ((buffer-quit-function + 'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon + "edit, exit with Esc Esc") + (?e (lambda (arg) + (let ((buffer-quit-function + 'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon + "edit, exit with Esc Esc")) + t) + (if found-bad (goto-char found-bad) + (goto-char p) + (message "No appropriate place found")))) + +(defun cperl-next-bad-style () + (let (p (not-found t) (point (point)) found) + (while (and not-found + (re-search-forward cperl-bad-style-regexp nil 'to-end)) + (setq p (point)) + (goto-char (match-beginning 0)) + (if (or + (looking-at cperl-not-bad-style-regexp) + ;; Check for a < -b and friends + (and (eq (following-char) ?\-) + (save-excursion + (skip-chars-backward " \t\n") + (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\(, ?\[, ?\{)))) + ;; Now check for syntax type + (save-match-data + (setq found (point)) + (beginning-of-defun) + (let ((pps (parse-partial-sexp (point) found))) + (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))) + (goto-char (match-end 0)) + (goto-char (1- p)) + (setq not-found nil + found-bad found))) + (not not-found))) + + +;;; Getting help +(defvar cperl-have-help-regexp + ;;(concat "\\(" + (mapconcat + 'identity + '("[$@%*&][0-9a-zA-Z_:]+" ; Usual variable + "[$@]\\^[a-zA-Z]" ; Special variable + "[$@][^ \n\t]" ; Special variable + "-[a-zA-Z]" ; File test + "\\\\[a-zA-Z0]" ; Special chars + "[-!&*+,-./<=>?\\\\^|~]+" ; Operator + "[a-zA-Z_0-9:]+" ; symbol or number + "x=" + "#!" + ) + ;;"\\)\\|\\(" + "\\|" + ) + ;;"\\)" + ;;) + "Matches places in the buffer we can find help for.") + +(defvar cperl-message-on-help-error t) + +(defun cperl-get-help () + "Get one-line docs on the symbol at the point. +The data for these docs is a little bit obsolete and may be in fact longer +than a line. Your contribution to update/shorten it is appreciated." + (interactive) + (save-excursion + ;; Get to the something meaningful + (or (eobp) (eolp) (forward-char 1)) + (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" + (save-excursion (beginning-of-line) (point)) + 'to-beg) + ;; (cond + ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol + ;; (skip-chars-backward " \n\t\r({[]});,") + ;; (or (bobp) (backward-char 1)))) + ;; Try to backtrace + (cond + ((looking-at "[a-zA-Z0-9_:]") ; symbol + (skip-chars-backward "[a-zA-Z0-9_:]") + (cond + ((and (eq (preceding-char) ?^) ; $^I + (eq (char-after (- (point) 2)) ?\$)) + (forward-char -2)) + ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob + (forward-char -1))) + (if (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; + (forward-char -1))) + ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= + (forward-char -1)) + ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I + (forward-char -1)) + ((looking-at "[-!&*+,-./<=>?\\\\^|~]") + (skip-chars-backward "[-!&*+,-./<=>?\\\\^|~]") + (cond + ((and (eq (preceding-char) ?\$) + (not (eq (char-after (- (point) 2)) ?\$))) ; $- + (forward-char -1)) + ((and (eq (following-char) ?\>) + (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) + (save-excursion + (forward-sexp -1) + (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; + (search-backward "<")))) + ((and (eq (following-char) ?\$) + (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> + (forward-char -1))) + ;;(or (eobp) (forward-char 1)) + (if (looking-at cperl-have-help-regexp) + (cperl-describe-perl-symbol + (buffer-substring (match-beginning 0) (match-end 0))) + (if cperl-message-on-help-error + (message "Nothing found for %s..." + (buffer-substring (point) (+ 5 (point)))))))) + +;;; Stolen from perl-descr.el by Johan Vromans: + +(defvar cperl-doc-buffer " *perl-doc*" + "Where the documentation can be found.") + +(defun cperl-describe-perl-symbol (val) + "Display the documentation of symbol at point, a Perl operator." + ;; We suppose that the current position is at the start of the symbol + ;; when we convert $_[5] to @_ + (let (;;(fn (perl-symbol-at-point)) + (enable-recursive-minibuffers t) + ;;val + args-file regexp) + ;; (interactive + ;; (let ((fn (perl-symbol-at-point)) + ;; (enable-recursive-minibuffers t) + ;; val args-file regexp) + ;; (setq val (read-from-minibuffer + ;; (if fn + ;; (format "Symbol (default %s): " fn) + ;; "Symbol: "))) + ;; (if (string= val "") + ;; (setq val fn)) + (cond + ((string-match "^[&*][a-zA-Z_]" val) + (setq val (concat (substring val 0 1) "NAME"))) + ((looking-at "[$@][a-zA-Z_:0-9]+\\([[{]\\)") + (if (= ?\[ (char-after (match-beginning 1))) + (setq val (concat "@" (substring val 1))) + (setq val (concat "%" (substring val 1))))) + ((and (string= val "x") (looking-at "x=")) + (setq val "x=")) + ((string-match "^\\$[\C-a-\C-z]" val) + (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) + ((and (string= "<" val) (looking-at "<\\$?[a-zA-Z0-9_:]+>")) + (setq val ""))) +;;; (if (string-match "^[&*][a-zA-Z_]" val) +;;; (setq val (concat (substring val 0 1) "NAME")) +;;; (if (looking-at "[$@][a-zA-Z_:0-9]+\\([[{]\\)") +;;; (if (= ?\[ (char-after (match-beginning 1))) +;;; (setq val (concat "@" (substring val 1))) +;;; (setq val (concat "%" (substring val 1)))) +;;; (if (and (string= val "x") (looking-at "x=")) +;;; (setq val "x=") +;;; (if (looking-at "[$@][a-zA-Z_:0-9]") +;;; )))) + (setq regexp (concat "^" "\\([^a-zA-Z0-9_:]+[ \t]\\)?" + (regexp-quote val) + "\\([ \t([/]\\|$\\)")) + + ;; get the buffer with the documentation text + (cperl-switch-to-doc-buffer) + + ;; lookup in the doc + (goto-char (point-min)) + (let ((case-fold-search nil)) + (list + (if (re-search-forward regexp (point-max) t) + (save-excursion + (beginning-of-line 1) + (let ((lnstart (point))) + (end-of-line) + (message "%s" (buffer-substring lnstart (point))))) + (if cperl-message-on-help-error + (message "No definition for %s" val))))))) + +(defvar cperl-short-docs "Ignore my value" + "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] +! Logical negation. +!= Numeric inequality. +!~ Search pattern, substitution, or translation (negated). +$! In numeric context: errno. In a string context: error string. +$\" The separator which joins elements of arrays interpolated in strings. +$# The output format for printed numbers. Initial value is %.20g. +$$ The process number of the perl running this script. Altered (in the child process) by fork(). +$% The current page number of the currently selected output channel. + + The following variables are always local to the current block: + +$1 Match of the 1st set of parentheses in the last match (auto-local). +$2 Match of the 2nd set of parentheses in the last match (auto-local). +$3 Match of the 3rd set of parentheses in the last match (auto-local). +$4 Match of the 4th set of parentheses in the last match (auto-local). +$5 Match of the 5th set of parentheses in the last match (auto-local). +$6 Match of the 6th set of parentheses in the last match (auto-local). +$7 Match of the 7th set of parentheses in the last match (auto-local). +$8 Match of the 8th set of parentheses in the last match (auto-local). +$9 Match of the 9th set of parentheses in the last match (auto-local). +$& The string matched by the last pattern match (auto-local). +$' The string after what was matched by the last match (auto-local). +$` The string before what was matched by the last match (auto-local). + +$( The real gid of this process. +$) The effective gid of this process. +$* Deprecated: Set to 1 to do multiline matching within a string. +$+ The last bracket matched by the last search pattern. +$, The output field separator for the print operator. +$- The number of lines left on the page. +$. The current input line number of the last filehandle that was read. +$/ The input record separator, newline by default. +$0 The name of the file containing the perl script being executed. May be set +$: The set of characters after which a string may be broken to fill continuation fields (starting with ^) in a format. +$; The subscript separator for multi-dimensional array emulation. Default is \"\\034\". +$< The real uid of this process. +$= The page length of the current output channel. Default is 60 lines. +$> The effective uid of this process. +$? The status returned by the last ``, pipe close or `system'. +$@ The perl error message from the last eval or do @var{EXPR} command. +$ARGV The name of the current file used with <> . +$[ Deprecated: The index of the first element/char in an array/string. +$\\ The output record separator for the print operator. +$] The perl version string as displayed with perl -v. +$^ The name of the current top-of-page format. +$^A The current value of the write() accumulator for format() lines. +$^D The value of the perl debug (-D) flags. +$^E Information about the last system error other than that provided by $!. +$^F The highest system file descriptor, ordinarily 2. +$^H The current set of syntax checks enabled by `use strict'. +$^I The value of the in-place edit extension (perl -i option). +$^L What formats output to perform a formfeed. Default is \f. +$^O The operating system name under which this copy of Perl was built. +$^P Internal debugging flag. +$^T The time the script was started. Used by -A/-M/-C file tests. +$^W True if warnings are requested (perl -w flag). +$^X The name under which perl was invoked (argv[0] in C-speech). +$_ The default input and pattern-searching space. +$| Flag for auto-flush after write/print on the currently selected output channel. Default is 0. +$~ The name of the current report format. +% Modulo division. +%= Modulo division assignment. +%ENV Contains the current environment. +%INC List of files that have been require-d or do-ne. +%SIG Used to set signal handlers for various signals. +& Bitwise and. +&& Logical and. +&&= Logical and assignment. +&= Bitwise and assignment. +* Multiplication. +** Exponentiation. +*NAME Refers to all objects represented by NAME. *NAM1 = *NAM2 makes NAM1 a reference to NAM2. +&NAME(arg0, ...) Subroutine call. Arguments go to @_. ++ Addition. +++ Auto-increment (magical on strings). ++= Addition assignment. +, Comma operator. +- Subtraction. +-- Auto-decrement. +-= Subtraction assignment. +-A Access time in days since script started. +-B File is a non-text (binary) file. +-C Inode change time in days since script started. +-M Age in days since script started. +-O File is owned by real uid. +-R File is readable by real uid. +-S File is a socket . +-T File is a text file. +-W File is writable by real uid. +-X File is executable by real uid. +-b File is a block special file. +-c File is a character special file. +-d File is a directory. +-e File exists . +-f File is a plain file. +-g File has setgid bit set. +-k File has sticky bit set. +-l File is a symbolic link. +-o File is owned by effective uid. +-p File is a named pipe (FIFO). +-r File is readable by effective uid. +-s File has non-zero size. +-t Tests if filehandle (STDIN by default) is opened to a tty. +-u File has setuid bit set. +-w File is writable by effective uid. +-x File is executable by effective uid. +-z File has zero size. +. Concatenate strings. +.. Alternation, also range operator. +.= Concatenate assignment strings +/ Division. /PATTERN/ioxsmg Pattern match +/= Division assignment. +/PATTERN/ioxsmg Pattern match. +< Numeric less than. Glob. See , <> as well. + Reads line from filehandle NAME. NAME must be bareword/dollar-bareword. + Glob. (Unless pattern is bareword/dollar-bareword - see ) +<> Reads line from union of files in @ARGV (= command line) and STDIN. +<< Bitwise shift left. << start of HERE-DOCUMENT. +<= Numeric less than or equal to. +<=> Numeric compare. += Assignment. +== Numeric equality. +=~ Search pattern, substitution, or translation +> Numeric greater than. +>= Numeric greater than or equal to. +>> Bitwise shift right. +>>= Bitwise shift right assignment. +? : Alternation (if-then-else) operator. ?PAT? Backwards pattern match. +?PATTERN? Backwards pattern match. +@ARGV Command line arguments (not including the command name - see $0). +@INC List of places to look for perl scripts during do/include/use. +@_ Parameter array for subroutines. Also used by split unless in array context. +\\ Creates a reference to whatever follows, like \$var. +\\0 Octal char, e.g. \\033. +\\E Case modification terminator. See \\Q, \\L, and \\U. +\\L Lowercase until \\E . +\\U Upcase until \\E . +\\Q Quote metacharacters until \\E . +\\a Alarm character (octal 007). +\\b Backspace character (octal 010). +\\c Control character, e.g. \\c[ . +\\e Escape character (octal 033). +\\f Formfeed character (octal 014). +\\l Lowercase of next character. See also \\L and \\u, +\\n Newline character (octal 012). +\\r Return character (octal 015). +\\t Tab character (octal 011). +\\u Upcase of next character. See also \\U and \\l, +\\x Hex character, e.g. \\x1b. +^ Bitwise exclusive or. +__END__ End of program source. +__DATA__ End of program source. +__FILE__ Current (source) filename. +__LINE__ Current line in current source. +ARGV Default multi-file input filehandle. is a synonym for <>. +ARGVOUT Output filehandle with -i flag. +BEGIN { block } Immediately executed (during compilation) piece of code. +END { block } Pseudo-subroutine executed after the script finishes. +DATA Input filehandle for what follows after __END__ or __DATA__. +accept(NEWSOCKET,GENERICSOCKET) +alarm(SECONDS) +atan2(X,Y) +bind(SOCKET,NAME) +binmode(FILEHANDLE) +caller[(LEVEL)] +chdir(EXPR) +chmod(LIST) +chop[(LIST|VAR)] +chown(LIST) +chroot(FILENAME) +close(FILEHANDLE) +closedir(DIRHANDLE) +cmp String compare. +connect(SOCKET,NAME) +continue of { block } continue { block }. Is executed after `next' or at end. +cos(EXPR) +crypt(PLAINTEXT,SALT) +dbmclose(ASSOC_ARRAY) +dbmopen(ASSOC,DBNAME,MODE) +defined(EXPR) +delete($ASSOC{KEY}) +die(LIST) +do { ... }|SUBR while|until EXPR executes at least once +do(EXPR|SUBR([LIST])) +dump LABEL +each(ASSOC_ARRAY) +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof[([FILEHANDLE])] +eq String equality. +eval(EXPR) or eval { BLOCK } +exec(LIST) +exit(EXPR) +exp(EXPR) +fcntl(FILEHANDLE,FUNCTION,SCALAR) +fileno(FILEHANDLE) +flock(FILEHANDLE,OPERATION) +for (EXPR;EXPR;EXPR) { ... } +foreach [VAR] (@ARRAY) { ... } +fork +ge String greater than or equal. +getc[(FILEHANDLE)] +getgrent +getgrgid(GID) +getgrnam(NAME) +gethostbyaddr(ADDR,ADDRTYPE) +gethostbyname(NAME) +gethostent +getlogin +getnetbyaddr(ADDR,ADDRTYPE) +getnetbyname(NAME) +getnetent +getpeername(SOCKET) +getpgrp(PID) +getppid +getpriority(WHICH,WHO) +getprotobyname(NAME) +getprotobynumber(NUMBER) +getprotoent +getpwent +getpwnam(NAME) +getpwuid(UID) +getservbyname(NAME,PROTO) +getservbyport(PORT,PROTO) +getservent +getsockname(SOCKET) +getsockopt(SOCKET,LEVEL,OPTNAME) +gmtime(EXPR) +goto LABEL +grep(EXPR,LIST) +gt String greater than. +hex(EXPR) +if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR +index(STR,SUBSTR[,OFFSET]) +int(EXPR) +ioctl(FILEHANDLE,FUNCTION,SCALAR) +join(EXPR,LIST) +keys(ASSOC_ARRAY) +kill(LIST) +last [LABEL] +le String less than or equal. +length(EXPR) +link(OLDFILE,NEWFILE) +listen(SOCKET,QUEUESIZE) +local(LIST) +localtime(EXPR) +log(EXPR) +lstat(EXPR|FILEHANDLE|VAR) +lt String less than. +m/PATTERN/iogsmx +mkdir(FILENAME,MODE) +msgctl(ID,CMD,ARG) +msgget(KEY,FLAGS) +msgrcv(ID,VAR,SIZE,TYPE.FLAGS) +msgsnd(ID,MSG,FLAGS) +my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). +ne String inequality. +next [LABEL] +oct(EXPR) +open(FILEHANDLE[,EXPR]) +opendir(DIRHANDLE,EXPR) +ord(EXPR) +pack(TEMPLATE,LIST) +package Introduces package context. +pipe(READHANDLE,WRITEHANDLE) +pop(ARRAY) +print [FILEHANDLE] [(LIST)] +printf [FILEHANDLE] (FORMAT,LIST) +push(ARRAY,LIST) +q/STRING/ Synonym for 'STRING' +qq/STRING/ Synonym for \"STRING\" +qx/STRING/ Synonym for `STRING` +rand[(EXPR)] +read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +readdir(DIRHANDLE) +readlink(EXPR) +recv(SOCKET,SCALAR,LEN,FLAGS) +redo [LABEL] +rename(OLDNAME,NEWNAME) +require [FILENAME | PERL_VERSION] +reset[(EXPR)] +return(LIST) +reverse(LIST) +rewinddir(DIRHANDLE) +rindex(STR,SUBSTR[,OFFSET]) +rmdir(FILENAME) +s/PATTERN/REPLACEMENT/gieoxsm +scalar(EXPR) +seek(FILEHANDLE,POSITION,WHENCE) +seekdir(DIRHANDLE,POS) +select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) +semctl(ID,SEMNUM,CMD,ARG) +semget(KEY,NSEMS,SIZE,FLAGS) +semop(KEY,...) +send(SOCKET,MSG,FLAGS[,TO]) +setgrent +sethostent(STAYOPEN) +setnetent(STAYOPEN) +setpgrp(PID,PGRP) +setpriority(WHICH,WHO,PRIORITY) +setprotoent(STAYOPEN) +setpwent +setservent(STAYOPEN) +setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) +shift[(ARRAY)] +shmctl(ID,CMD,ARG) +shmget(KEY,SIZE,FLAGS) +shmread(ID,VAR,POS,SIZE) +shmwrite(ID,STRING,POS,SIZE) +shutdown(SOCKET,HOW) +sin(EXPR) +sleep[(EXPR)] +socket(SOCKET,DOMAIN,TYPE,PROTOCOL) +socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) +sort [SUBROUTINE] (LIST) +splice(ARRAY,OFFSET[,LENGTH[,LIST]]) +split[(/PATTERN/[,EXPR[,LIMIT]])] +sprintf(FORMAT,LIST) +sqrt(EXPR) +srand(EXPR) +stat(EXPR|FILEHANDLE|VAR) +study[(SCALAR)] +sub [NAME [(format)]] { BODY } or sub [NAME [(format)]]; +substr(EXPR,OFFSET[,LEN]) +symlink(OLDFILE,NEWFILE) +syscall(LIST) +sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +system(LIST) +syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +tell[(FILEHANDLE)] +telldir(DIRHANDLE) +time +times +tr/SEARCHLIST/REPLACEMENTLIST/cds +truncate(FILE|EXPR,LENGTH) +umask[(EXPR)] +undef[(EXPR)] +unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR +unlink(LIST) +unpack(TEMPLATE,EXPR) +unshift(ARRAY,LIST) +until (EXPR) { ... } or EXPR until EXPR +utime(LIST) +values(ASSOC_ARRAY) +vec(EXPR,OFFSET,BITS) +wait +waitpid(PID,FLAGS) +wantarray +warn(LIST) +while (EXPR) { ... } or EXPR while EXPR +write[(EXPR|FILEHANDLE)] +x Repeat string or array. +x= Repetition assignment. +y/SEARCHLIST/REPLACEMENTLIST/ +| Bitwise or. +|| Logical or. +~ Unary bitwise complement. +#! OS interpreter indicator. If contains `perl', used for options, and -x. +") + +(defun cperl-switch-to-doc-buffer () + "Go to the perl documentation buffer and insert the documentation." + (interactive) + (let ((buf (get-buffer-create cperl-doc-buffer))) + (if (interactive-p) + (switch-to-buffer-other-window buf) + (set-buffer buf)) + (if (= (buffer-size) 0) + (progn + (insert (documentation-property 'cperl-short-docs + 'variable-documentation)) + (setq buffer-read-only t))))) + +(if (fboundp 'run-with-idle-timer) + (progn + (defvar cperl-help-shown nil + "Non-nil means that the help was already shown now.") + + (defvar cperl-help-timer nil + "Non-nil means that the help was already shown now.") + + (defun cperl-lazy-install () + (interactive) + (make-variable-buffer-local 'cperl-help-shown) + (if (cperl-val cperl-lazy-help-time) + (progn + (add-hook 'post-command-hook 'cperl-lazy-hook) + (setq cperl-help-timer + (run-with-idle-timer + (cperl-val cperl-lazy-help-time 1000000 5) + t + 'cperl-get-help-defer))))) + + (defun cperl-lazy-unstall () + (interactive) + (remove-hook 'post-command-hook 'cperl-lazy-hook) + (cancel-timer cperl-help-timer)) + + (defun cperl-lazy-hook () + (setq cperl-help-shown nil)) + + (defun cperl-get-help-defer () + (if (not (eq major-mode 'perl-mode)) nil + (let ((cperl-message-on-help-error nil)) + (cperl-get-help) + (setq cperl-help-shown t)))) + (cperl-lazy-install))) diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/imenu.el --- a/lisp/modes/imenu.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/imenu.el Mon Aug 13 08:46:56 2007 +0200 @@ -713,7 +713,20 @@ (if (< 1 (length (cdr menu))) (cdr menu) (cdr (cadr menu))))) - (setq position (x-popup-menu event menu)) + (if (fboundp 'x-popup-menu) + (setq position (x-popup-menu event menu)) + (setq position (let ((val (get-popup-menu-response + (cons "" + (mapcar + (function + (lambda (x) + (vector (car x) (list (car x)) t))) + menu))))) + (setq val (and val + (listp (event-object val)) + (stringp (car-safe (event-object val))) + (car (event-object val)))) + (cdr (assoc val choices))))) (cond ((and (listp position) (numberp (car position)) (stringp (nth (1- (length position)) position))) @@ -758,21 +771,26 @@ The returned value is on the form (INDEX-NAME . INDEX-POSITION)." (let (index-alist - (mouse-triggered (listp last-nonmenu-event)) + ;; XEmacs + (mouse-triggered (or (button-press-event-p last-command-event) + (button-release-event-p last-command-event) + (menu-event-p last-command-event))) + ;;(mouse-triggered (listp last-nonmenu-event)) (result t) ) ;; If selected by mouse, see to that the window where the mouse is ;; really is selected. - (and mouse-triggered - (not (equal last-nonmenu-event '(menu-bar))) - (let ((window (posn-window (event-start last-nonmenu-event)))) - (or (framep window) (null window) (select-window window)))) + ;(and mouse-triggered + ;(not (equal last-nonmenu-event '(menu-bar))) + ;(let ((window (posn-window (event-start last-nonmenu-event)))) + ;(or (framep window) (null window) (select-window window)))) ;; Create a list for this buffer only when needed. (while (eq result t) (setq index-alist (if alist alist (imenu--make-index-alist))) (setq result (if (and mouse-triggered (not imenu-always-use-completion-buffer-p)) - (imenu--mouse-menu index-alist last-nonmenu-event) + ;(imenu--mouse-menu index-alist last-nonmenu-event) + (imenu--mouse-menu index-alist last-command-event) (imenu--completion-buffer index-alist prompt))) (and (eq result t) (imenu--cleanup) diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/lisp-mode.el --- a/lisp/modes/lisp-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/lisp-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -367,10 +367,7 @@ (if (and (consp expr) (eq (car expr) 'defvar) (> (length expr) 2)) - (progn (eval (cons 'defconst (cdr expr))) - (message "defvar treated as defconst") - (sit-for 1) - (message "")) + (eval (cons 'defconst (cdr expr))) (eval expr))) (defun eval-last-sexp (eval-last-sexp-arg-internal) diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/m4-mode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/modes/m4-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,170 @@ +;;; m4-mode.el --- m4 code editing commands for Emacs + +;; Author: Andrew Csillag (drew@staff.prodigy.com) +;; Maintainer: Andrew Csillag (drew@staff.prodigy.com) +;; Keywords: languages, faces + +;; This file is (not yet) part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; A smart editing mode for m4 macro definitions. It seems to have most of the +;; syntax right (sexp motion commands work, but function motion commands don't). +;; It also sets the font-lock syntax stuff for colorization + +;; By Drew Csillag (drew@staff.prodigy.com) +;; $Id: m4-mode.el,v 1.1.1.1 1996/12/18 03:53:17 steve Exp $ + +;; History: + +;; Date Version Who Action +;; -------- ------- --- ---- +;; 09/13/96 1.0 DC Created +;; 09/26/96 1.1 DC added syntax table stuff so now matches `'s +;; now can use C-c C-b to m4 on buffer,C-c C-r for region +;; added m4-comment-region (C-c C-c) +;; 09/27/96 1.2 DC Redid header comment +;; 1.3 DC more cosmetic fixes +;; 1.4 DC removed m4-comment-region, using comment-region instead +;; 10/03/96 DC added provide line +;; 10/24/96 1.5 DC fixed keyword regexp +;; 10/29/96 1.6 DC added m4_keywords for --prefix-builtins +;; fixed syntax table so _define_ isn't keywordified +;; 10/29/96 1.8 DC fixed a problem where comments go fontified incorrectly +;; if they had quotes in them +;; To Do's: + +;; * want to make m4-m4-(buffer|region) look sorta like M-x compile look&feel ? +;; * sexp motion commands don't seem to work right + +;; to autoload m4 lisp code: +;; (autoload 'm4-mode "m4-mode" nil t) +;; +;; or can use (load "m4-mode") or (require 'm4-mode) to just load it +;; +;; to try to "auto-detect" m4 files: +;; (setq auto-mode-alist +;; (cons '(".*\\.m4$" . m4-mode) +;; auto-mode-alist)) + + +;;; Thanks: +;;; to Akim Demaille and Terry Jones for the bug reports + +;;; Code: + +;;path to the m4 program +(defvar m4-program "/usr/local/bin/m4") + +;;thank god for make-regexp.el! +(defvar m4-font-lock-keywords + `( + ("^\\\#.*" . font-lock-comment-face) + ("\\\$\\\*" . font-lock-variable-name-face) + ("\\\$[0-9]" . font-lock-variable-name-face) + ("\\\$\\\#" . font-lock-variable-name-face) + ("\\\$\\\@" . font-lock-variable-name-face) + ("\\\$\\\*" . font-lock-variable-name-face) + ("\\b\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\b" . font-lock-keyword-face) + ("\\b\\(m4_\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(_undefine\\|exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|undivert\\)\\)\\b" . font-lock-keyword-face) + "default font-lock-keywords") +) + +;;this may still need some work +(defvar m4-mode-syntax-table nil + "syntax table used in m4 mode") +(setq m4-mode-syntax-table (make-syntax-table)) +(modify-syntax-entry ?` "('" m4-mode-syntax-table) +(modify-syntax-entry ?' ")`" m4-mode-syntax-table) +(modify-syntax-entry ?# "<\n" m4-mode-syntax-table) +(modify-syntax-entry ?\n ">#" m4-mode-syntax-table) +(modify-syntax-entry ?{ "_" m4-mode-syntax-table) +(modify-syntax-entry ?} "_" m4-mode-syntax-table) +(modify-syntax-entry ?* "w" m4-mode-syntax-table) +(modify-syntax-entry ?_ "w" m4-mode-syntax-table) +(modify-syntax-entry ?\" "w" m4-mode-syntax-table) + +(defvar m4-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-b" 'm4-m4-buffer) + (define-key map "\C-c\C-r" 'm4-m4-region) + (define-key map "\C-c\C-c" 'comment-region) + map)) + +(defun m4-m4-buffer () + "send contents of the current buffer to m4" + (interactive) + (start-process "m4process" "*m4 output*" m4-program "-e") + (process-send-region "m4process" (point-min) (point-max)) + (process-send-eof "m4process") + (switch-to-buffer "*m4 output*") +) + +(defun m4-m4-region () + "send contents of the current region to m4" + (interactive) + (start-process "m4process" "*m4 output*" m4-program "-e") + (process-send-region "m4process" (point) (mark)) + (process-send-eof "m4process") + (switch-to-buffer "*m4 output*") +) + +;;;###autoload +(defun m4-mode () + "A major-mode to edit m4 macro files +\\{m4-mode-map} +" + (interactive) + (kill-all-local-variables) + (use-local-map m4-mode-map) + + (make-local-variable 'comment-start) + (setq comment-start "#") + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + + + (make-local-variable 'font-lock-defaults) + (setq major-mode 'm4-mode + mode-name "m4" + font-lock-defaults `(m4-font-lock-keywords nil) + ) + (set-syntax-table m4-mode-syntax-table) + (run-hooks 'm4-mode-hook)) + +(provide 'm4-mode) +;;stuff to play with for debugging +;(char-to-string (char-syntax ?`)) + +;;;how I generate the nasty looking regexps at the top +;;;(make-regexp '("builtin" "changecom" "changequote" "changeword" "debugfile" +;;; "debugmode" "decr" "define" "defn" "divert" "divnum" "dnl" +;;; "dumpdef" "errprint" "esyscmd" "eval" "file" "format" "gnu" +;;; "ifdef" "ifelse" "include" "incr" "index" "indir" "len" "line" +;;; "m4exit" "m4wrap" "maketemp" "patsubst" "popdef" "pushdef" "regexp" +;;; "shift" "sinclude" "substr" "syscmd" "sysval" "traceoff" "traceon" +;;; "translit" "undefine" "undivert" "unix")) +;;;(make-regexp '("m4_builtin" "m4_changecom" "m4_changequote" "m4_changeword" +;;; "m4_debugfile" "m4_debugmode" "m4_decr" "m4_define" "m4_defn" +;;; "m4_divert" "m4_divnum" "m4_dnl" "m4_dumpdef" "m4_errprint" +;;; "m4_esyscmd" "m4_eval" "m4_file" "m4_format" "m4_ifdef" "m4_ifelse" +;;; "m4_include" "m4_incr" "m4_index" "m4_indir" "m4_len" "m4_line" +;;; "m4_m4exit" "m4_m4wrap" "m4_maketemp" "m4_patsubst" "m4_popdef" +;;; "m4_pushdef" "m4_regexp" "m4_shift" "m4_sinclude" "m4_substr" +;;; "m4_syscmd" "m4_sysval" "m4_traceoff" "m4_traceon" "m4_translit" +;;; "m4_m4_undefine" "m4_undivert")) diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/mail-abbrevs.el --- a/lisp/modes/mail-abbrevs.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/mail-abbrevs.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,6 +1,6 @@ ;;; Abbrev-expansion of mail aliases. ;;; Copyright (C) 1985-1994 Free Software Foundation, Inc. -;;; Created: 19 oct 90, Jamie Zawinski +;;; Created: 19 oct 90, Jamie Zawinski ;;; Modified: 5 apr 92, Roland McGrath ;;; Last change 4-may-94. jwz @@ -404,14 +404,30 @@ non-address headers.") (defvar mail-abbrev-syntax-table - (let* ((tab (copy-syntax-table mail-mode-header-syntax-table)) - (i (1- (length tab))) - (_ (aref (standard-syntax-table) ?_)) - (w (aref (standard-syntax-table) ?w))) - (while (>= i 0) - (if (= (aref tab i) _) (aset tab i w)) - (setq i (1- i))) - tab) + (if (fboundp 'map-syntax-table) + (let ((tab (copy-syntax-table mail-mode-header-syntax-table))) + (if (vectorp tab) + (let ((i (1- (length tab))) + (_ (aref (standard-syntax-table) ?_)) + (w (aref (standard-syntax-table) ?w))) + (while (>= i 0) + (if (= (aref tab i) _) (aset tab i w)) + (setq i (1- i)))) + (map-syntax-table + #'(lambda (key val) + (if (eq (char-syntax-from-code val) ?_) + (put-char-table key (set-char-syntax-in-code val ?w) tab) + )) + tab)) + tab) + (let* ((tab (copy-syntax-table mail-mode-header-syntax-table)) + (i (1- (length tab))) + (_ (aref (standard-syntax-table) ?_)) + (w (aref (standard-syntax-table) ?w))) + (while (>= i 0) + (if (= (aref tab i) _) (aset tab i w)) + (setq i (1- i))) + tab)) "The syntax-table used for abbrev-expansion purposes; this is not actually made the current syntax table of the buffer, but simply controls the set of characters which may be a part of the name of a mail-alias.") diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/python-mode.el --- a/lisp/modes/python-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/python-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -6,8 +6,8 @@ ;; 1992-1994 Tim Peters ;; Maintainer: python-mode@python.org ;; Created: Feb 1992 -;; Version: 2.67 -;; Last Modified: 1996/08/01 20:11:51 +;; Version: 2.83 +;; Last Modified: 1996/10/23 20:44:59 ;; Keywords: python languages oop ;; This software is provided as-is, without express or implied @@ -17,12 +17,11 @@ ;; notice and this paragraph appear in all copies. ;;; Commentary: -;; ;; This is a major mode for editing Python programs. It was developed ;; by Tim Peters after an original idea by Michael A. Guravage. Tim -;; left the net for a while and in the interim, Barry Warsaw has -;; undertaken maintenance of the mode. +;; subsequently left the net; in 1995, Barry Warsaw inherited the +;; mode and is the current maintainer. ;; At some point this mode will undergo a rewrite to bring it more in ;; line with GNU Emacs Lisp coding standards, and to wax all the Emacs @@ -59,7 +58,8 @@ ;; - proper interaction with pending-del and del-sel modes. ;; - Better support for outdenting: py-electric-colon (:) and ;; py-indent-line (TAB) improvements; one level of outdentation -;; added after a return, raise, break, or continue statement +;; added after a return, raise, break, pass, or continue statement. +;; Defeated by prefixing command with C-u. ;; - New py-electric-colon (:) command for improved outdenting Also ;; py-indent-line (TAB) should handle outdented lines better ;; - improved (I think) C-c > and C-c < @@ -84,6 +84,8 @@ ;; hasn't been a problem... yet. ;; - have py-execute-region on indented code act as if the region is ;; left justified. Avoids syntax errors. +;; - Add a py-goto-error or some such that would scan an exception in +;; the py-shell buffer, and pop you to that line in the file. ;; If you can think of more things you'd like to see, drop me a line. ;; If you want to report bugs, use py-submit-bug-report (C-c C-b). @@ -207,7 +209,7 @@ the Emacs bell is also rung as a warning.") (defconst python-font-lock-keywords - (let* ((keywords '("access" "and" "break" "class" + (let* ((keywords '("and" "break" "class" "continue" "def" "del" "elif" "else:" "except" "except:" "exec" "finally:" "for" "from" "global" @@ -385,14 +387,37 @@ "while\\s +.*:" "for\\s +.*:" "if\\s +.*:" - "elif\\s +.*:") + "elif\\s +.*:" + "\\(return\\|break\\|raise\\|continue\\)[ \t\n]" + ) "\\|") "\\)") "Regexp matching lines to not outdent after.") +(defvar py-defun-start-re + "^\\([ \t]*\\)def[ \t]+\\([a-zA-Z_0-9]+\\)\\|\\(^[a-zA-Z_0-9]+\\)[ \t]*=" + "Regexp matching a function, method or variable assignment. + +If you change this, you probably have to change `py-current-defun' as well. +This is only used by `py-current-defun' to find the name for add-log.el.") + +(defvar py-class-start-re "^class[ \t]*\\([a-zA-Z_0-9]+\\)" + "Regexp for finding a class name. + +If you change this, you probably have to change `py-current-defun' as well. +This is only used by `py-current-defun' to find the name for add-log.el.") + + ;; Menu definitions, only relevent if you have the easymenu.el package ;; (standard in the latest Emacs 19 and XEmacs 19 distributions). +(defvar py-menu nil + "Menu for Python Mode. + +This menu will get created automatically if you have the easymenu +package. Note that the latest XEmacs 19 and Emacs 19 versions contain +this package.") + (if (condition-case nil (require 'easymenu) (error nil)) @@ -489,8 +514,8 @@ ;; These next two variables are used when searching for the python ;; class/definitions. Just saving some time in accessing the ;; generic-python-expression, really. -(defvar imenu-example--python-generic-regexp) -(defvar imenu-example--python-generic-parens) +(defvar imenu-example--python-generic-regexp nil) +(defvar imenu-example--python-generic-parens nil) ;;;###autoload @@ -650,11 +675,35 @@ py-temp-directory\t\tdirectory used for temp files (if needed) py-beep-if-tab-change\t\tring the bell if tab-width is changed" (interactive) + ;; set up local variables (kill-all-local-variables) + (make-local-variable 'font-lock-defaults) + (make-local-variable 'paragraph-separate) + (make-local-variable 'paragraph-start) + (make-local-variable 'require-final-newline) + (make-local-variable 'comment-start) + (make-local-variable 'comment-start-skip) + (make-local-variable 'comment-column) + (make-local-variable 'indent-region-function) + (make-local-variable 'indent-line-function) + (make-local-variable 'add-log-current-defun-function) + ;; (set-syntax-table py-mode-syntax-table) - (setq major-mode 'python-mode - mode-name "Python" - local-abbrev-table python-mode-abbrev-table) + (setq major-mode 'python-mode + mode-name "Python" + local-abbrev-table python-mode-abbrev-table + font-lock-defaults '(python-font-lock-keywords) + paragraph-separate "^[ \t]*$" + paragraph-start "^[ \t]*$" + require-final-newline t + comment-start "# " + comment-start-skip "# *" + comment-column 40 + indent-region-function 'py-indent-region + indent-line-function 'py-indent-line + ;; tell add-log.el how to find the current function/method/variable + add-log-current-defun-function 'py-current-defun + ) (use-local-map py-mode-map) ;; add the menu (if py-menu @@ -662,18 +711,6 @@ ;; Emacs 19 requires this (if (or py-this-is-lucid-emacs-p py-this-is-emacs-19-p) (setq comment-multi-line nil)) - ;; BAW -- style... - (mapcar (function (lambda (x) - (make-local-variable (car x)) - (set (car x) (cdr x)))) - '((paragraph-separate . "^[ \t]*$") - (paragraph-start . "^[ \t]*$") - (require-final-newline . t) - (comment-start . "# ") - (comment-start-skip . "# *") - (comment-column . 40) - (indent-region-function . py-indent-region) - (indent-line-function . py-indent-line))) ;; hack to allow overriding the tabsize in the file (see tokenizer.c) ;; ;; not sure where the magic comment has to be; to save time @@ -752,12 +789,12 @@ (save-excursion (let ((here (point)) (outdent 0) - (indent (py-compute-indentation))) + (indent (py-compute-indentation t))) (if (and (not arg) (py-outdent-p) (= indent (save-excursion - (forward-line -1) - (py-compute-indentation))) + (py-next-statement -1) + (py-compute-indentation t))) ) (setq outdent py-indent-offset)) ;; Don't indent, only outdent. This assumes that any lines that @@ -774,6 +811,7 @@ ;;; Functions that execute Python commands in a subprocess +;;;###autoload (defun py-shell () "Start an interactive Python interpreter in another window. This is like Shell mode, except that Python is running in the window @@ -895,42 +933,47 @@ ;; read_process_output has update_mode_lines++ for a similar ;; reason? beats me ... - ;; BAW - we want to check to see if this still applies - (if (eq curbuf pbuf) ; mysterious ugly hack - (set-buffer (get-buffer-create "*scratch*"))) + (unwind-protect + ;; make sure current buffer is restored + ;; BAW - we want to check to see if this still applies + (progn + ;; mysterious ugly hack + (if (eq curbuf pbuf) + (set-buffer (get-buffer-create "*scratch*"))) - (set-buffer pbuf) - (let* ((start (point)) - (goback (< start pmark)) - (goend (and (not goback) (= start (point-max)))) - (buffer-read-only nil)) - (goto-char pmark) - (insert string) - (move-marker pmark (point)) - (setq file-finished - (and py-file-queue - (equal ">>> " - (buffer-substring - (prog2 (beginning-of-line) (point) - (goto-char pmark)) - (point))))) - (if goback (goto-char start) - ;; else - (if py-scroll-process-buffer - (let* ((pop-up-windows t) - (pwin (display-buffer pbuf))) - (set-window-point pwin (point))))) - (set-buffer curbuf) - (if file-finished - (progn - (py-delete-file-silently (car py-file-queue)) - (setq py-file-queue (cdr py-file-queue)) - (if py-file-queue - (py-execute-file pyproc (car py-file-queue))))) - (and goend - (progn (set-buffer pbuf) - (goto-char (point-max)))) - ))) + (set-buffer pbuf) + (let* ((start (point)) + (goback (< start pmark)) + (goend (and (not goback) (= start (point-max)))) + (buffer-read-only nil)) + (goto-char pmark) + (insert string) + (move-marker pmark (point)) + (setq file-finished + (and py-file-queue + (equal ">>> " + (buffer-substring + (prog2 (beginning-of-line) (point) + (goto-char pmark)) + (point))))) + (if goback (goto-char start) + ;; else + (if py-scroll-process-buffer + (let* ((pop-up-windows t) + (pwin (display-buffer pbuf))) + (set-window-point pwin (point))))) + (set-buffer curbuf) + (if file-finished + (progn + (py-delete-file-silently (car py-file-queue)) + (setq py-file-queue (cdr py-file-queue)) + (if py-file-queue + (py-execute-file pyproc (car py-file-queue))))) + (and goend + (progn (set-buffer pbuf) + (goto-char (point-max)))) + )) + (set-buffer curbuf)))) (defun py-execute-buffer () "Send the contents of the buffer to a Python interpreter. @@ -995,12 +1038,17 @@ (put 'py-delete-char 'delete-selection 'supersede) (put 'py-delete-char 'pending-delete 'supersede) -(defun py-indent-line () - "Fix the indentation of the current line according to Python rules." - (interactive) +(defun py-indent-line (&optional arg) + "Fix the indentation of the current line according to Python rules. +With \\[universal-argument], ignore outdenting rules for block +closing statements (e.g. return, raise, break, continue, pass) + +This function is normally bound to `indent-line-function' so +\\[indent-for-tab-command] will call it." + (interactive "P") (let* ((ci (current-indentation)) (move-to-indentation-p (<= (current-column) ci)) - (need (py-compute-indentation))) + (need (py-compute-indentation (not arg)))) ;; see if we need to outdent (if (py-outdent-p) (setq need (- need py-indent-offset))) @@ -1026,7 +1074,10 @@ (insert-char ?\n 1) (move-to-column ci)))) -(defun py-compute-indentation () +(defun py-compute-indentation (honor-block-close-p) + ;; implements all the rules for indentation computation. when + ;; honor-block-close-p is non-nil, statements such as return, raise, + ;; break, continue, and pass force one level of outdenting. (save-excursion (let ((pps (parse-partial-sexp (save-excursion (beginning-of-python-def-or-class) @@ -1172,7 +1223,7 @@ (+ (current-indentation) (if (py-statement-opens-block-p) py-indent-offset - (if (py-statement-closes-block-p) + (if (and honor-block-close-p (py-statement-closes-block-p)) (- py-indent-offset) 0))) ))))) @@ -1332,7 +1383,7 @@ (target-column 0) ; column to which to indent (base-shifted-by 0) ; amount last base line was shifted (indent-base (if (looking-at "[ \t\n]") - (py-compute-indentation) + (py-compute-indentation t) 0)) ci) (while (< (point) end) @@ -1728,10 +1779,12 @@ (interactive "p") (let ((case-fold-search nil)) (if (> arg 0) - (re-search-forward "\\W*\\([A-Z_]*[a-z0-9]*\\)" (point-max) t arg) + (re-search-forward + "\\(\\W\\|[_]\\)*\\([A-Z]*[a-z0-9]*\\)" + (point-max) t arg) (while (and (< arg 0) (re-search-backward - "\\(\\(\\W\\|[a-z0-9]\\)[A-Z]+\\|\\W\\w+\\)" + "\\(\\W\\|[a-z0-9]\\)[A-Z]+\\|\\(\\W\\|[_]\\)\\w+" (point-min) 0)) (forward-char 1) (setq arg (1+ arg))))) @@ -1776,8 +1829,7 @@ (where-is-internal func py-mode-map) ", ")))) ((equal funckind "v") ; variable - (setq funcdoc (substitute-command-keys - (get func 'variable-documentation)) + (setq funcdoc (documentation-property func 'variable-documentation) keys (if (assq func locals) (concat "Local/Global values: " @@ -2180,12 +2232,12 @@ (defun py-statement-closes-block-p () ;; true iff the current statement `closes' a block == the line - ;; starts with `return', `raise', `break' or `continue'. doesn't - ;; catch embedded statements + ;; starts with `return', `raise', `break', `continue', and `pass'. + ;; doesn't catch embedded statements (let ((here (point))) (back-to-indentation) (prog1 - (looking-at "\\(return\\|raise\\|break\\|continue\\)\\>") + (looking-at "\\(return\\|raise\\|break\\|continue\\|pass\\)\\>") (goto-char here)))) ;; go to point right beyond final line of block begun by the current @@ -2309,9 +2361,20 @@ (set-buffer cbuf)) (sit-for 0)) +(defun py-current-defun () + ;; tell add-log.el how to find the current function/method/variable + (save-excursion + (if (re-search-backward py-defun-start-re nil t) + (or (match-string 3) + (let ((method (match-string 2))) + (if (and (not (zerop (length (match-string 1)))) + (re-search-backward py-class-start-re nil t)) + (concat (match-string 1) "." method) + method))) + nil))) -(defconst py-version "2.67" +(defconst py-version "2.83" "`python-mode' version number.") (defconst py-help-address "python-mode@python.org" "Address accepting submission of bug reports.") diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/tex-mode.el --- a/lisp/modes/tex-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/tex-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -807,9 +807,11 @@ (let ((print-file-name-dvi (tex-append tex-print-file ".dvi")) test-name) (if (and (not (equal (current-buffer) tex-last-buffer-texed)) + (buffer-file-name) + ;; Check that this buffer's printed file is up to date. (file-newer-than-file-p (setq test-name (tex-append (buffer-file-name) ".dvi")) - print-file-name-dvi)) + (buffer-file-name))) (setq print-file-name-dvi test-name)) (if (not (file-exists-p print-file-name-dvi)) (error "No appropriate `.dvi' file could be found") diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/two-column.el --- a/lisp/modes/two-column.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/two-column.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,415 +1,421 @@ ;;; two-column.el --- minor mode for editing of two-column text -;; Copyright (C) 1992, 1994 Free Software Foundation, Inc. - -;; Author: Daniel Pfeiffer -;; Adapted-By: ESR - -;; This file is part of GNU Emacs. +;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. -;; 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. +;; Author: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 +;; Adapted-By: ESR, Daniel Pfeiffer -;; 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. +;; Esperanto: English: -;; 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: +;; ^Ci dosiero estas ero de GNU Emacs. This file is part of GNU Emacs. -;; This package gives you the ability to edit text in a two-column format. - -;; --8<---- two-column.el ----8<--------8<--------8<--------8<--------8<------- -;; Esperanto: English: - -;; Minora modalo por samtempa dukolumna Minor mode for simultaneous -;; tajpado two-column editing +;; GNU Emacs estas libera programaro; GNU Emacs is free software; you can +;; vi povas disdoni ^gin kaj/a^u modifi redistribute it and/or modify it +;; ^gin sub la kondi^coj de la GNU under the terms of the GNU General +;; ^Generala Publika Licenco kiel pub- Public License as published by the +;; likigita far la Liberprogramara Fon- Free Software Foundation; either +;; da^jo; a^u eldono 2a, a^u (la^u via version 2, or (at your option) any +;; elekto) ajna posta eldono. later version. -;; Tiu minora modalo ebligas al vi This minor mode allows you to -;; tajpi sendepende en du apudaj independently edit two adjacent -;; bufroj. Vi havas tri eblecojn por buffers. You have three ways to -;; eki ^gin. ^Ciu donas al vi start it up. Each gives you a -;; horizontale disigatan fenestron, horizontally split window similar to -;; simila al fina apareco de via the final outcome of your text: -;; teksto: - -;; C-x 6 2 asocias novan bufron nomatan associates a new buffer called -;; same, sed kun 2C/ anta^u. the same, but with 2C/ -;; prepended. - -;; C-x 6 b asocias alian bufron. Vi povas associates another buffer. -;; anka^u asocii dataron, se vi This can be used to associate a -;; ^jus anta^ue faris C-x C-f. file if you just did C-x C-f. +;; GNU Emacs estas disdonata en la GNU Emacs is distributed in the hope +;; espero ke ^gi estos utila, sed SEN that it will be useful, but WITHOUT +;; IA GARANTIO; sen e^c la implicita ANY WARRANTY; without even the +;; garantio de VENDEBLECO a^u PRETECO implied warranty of MERCHANTABILITY +;; POR DETERMINITA CELO. Vidu la GNU or FITNESS FOR A PARTICULAR PURPOSE. +;; ^Generala Publika Licenco por plenaj See the GNU General Public License +;; detaloj. for more details. -;; C-x 6 u disigas jam dukolumnan tekston unmerges a two-column text into -;; en du bufroj ekde la nuna two buffers from the current -;; linio, kaj je la nuna kolumno. line and at the current column. -;; La anta^uaj signoj (ofte The preceding characters (often -;; tabeligilo a^u |) estas la tab or |) are the column -;; kolumna disiganto. Linioj kiuj separator. Lines that don't -;; ne enhavas ilin ne estas have them won't be separated. -;; disigitaj. Kiel la kvara kaj Like the fourth and fifth line -;; la kvina linio se vi disigas if you unmerge this file from -;; ^ci dataron ekde la unua angla the first english word. -;; vorto. +;; Vi devus ricevinti kopion de la GNU You should have received a copy of +;; ^Generala Publika Licenco kune kun the GNU General Public License along +;; GNU Emacs; vidu la dosieron COPYING. with GNU Emacs; see the file +;; Alikaze skribu al la COPYING. If not, write to the + +;; Free Software Foundation, 59 Temple Place - Suite 330 +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Komentario: Commentary: -;; Je ^cia flanko estas bufro, kiu On each side is a buffer that knows -;; konas la alian. Kun la ordonoj C-x about the other. With the commands -;; 6 SPC, C-x 6 DEL kaj C-x 6 RET oni C-x 6 SPC, C-x 6 DEL and C-x 6 RET -;; povas suben- a^u supreniri unu you can simultaneously scroll up or -;; ekranon, kaj subeniri linion, down by a screenfull and by a line -;; samtempe en la du bufroj. Al la alia in both buffers. Empty lines are -;; bufro estas aldonataj linioj se added to the other buffer if -;; necesas, por ke vi vidu la saman necessary, so that you see the same -;; parton. Per C-x 6 C-l vi povas part. With C-x 6 C-l you can -;; recentrigi la linion. Kiam vi nur recenter the line. When you only -;; plu havas unu el la du bufroj have one of the two buffers onscreen -;; surekrane vi revidos la alian per you can get the other back with C-x -;; denove C-x 6 2. 6 2 once more. +;; Adapter's note: Don't even think of using this package. The version +;; of this file in 19.14 didn't work, so I replaced it with the one in GNU +;; Emacs 19.34, which didn't work either. However, from tests done with +;; 19.34, it doesn't appear to run there either. At least this file is +;; synched with FSF in case someone decides to fix it. -sb -;; Se vi volas meti longajn liniojn If you include long lines, i.e which -;; (ekz. programerojn) en la kunigotan will span both columns (eg. source -;; tekston, ili devas esti en la code), they should be in what will -;; estonte unua kolumno. La alia devas be the first column, with the -;; havi malplenajn linion apud ili. associated buffer having empty lines -;; next to them. +;; Tiu programaro ebligas vin redakti This package gives you the ability +;; dukolumnan tekston. to edit text in a two-column format. + -;; Averto: en Emacs kiam vi ^san^gas la Attention: in Emacs when you change -;; ma^joran modalon, la minoraj modaloj the major mode, the minor modes are -;; estas anka^u elmemorigitaj. Tiu- also purged from memory. In that -;; okaze vi devas religi la du bufrojn case you must reassociate the two -;; per iu C-x 6-ordono, ekz. C-x 6 b. buffers with any C-x 6-command, e.g. -;; C-x 6 b. - -;; Kiam vi estos kontenta de la When you have edited both buffers to -;; rezulto, vi kunmetos la du kolumnojn your content, you merge them with -;; per C-x 6 1. Se vi poste vidas C-x 6 1. If you then see a problem, -;; problemon, vi neniigu la kunmeton you undo the merge with C-x u and -;; per C-x u kaj plue modifu la du continue to edit the two buffers. -;; bufrojn. Kiam vi ne plu volas tajpi When you no longer want to edit in -;; dukolumne, vi eliru el la minora two columns, you turn off the minor -;; modalo per C-x 6 k. mode with C-x 6 k. +;; Vi havas tri eblecojn por eki tiun You have three ways to start up this +;; mal^cefan modalon. ^Ciu donas al vi minor mode. Each gives you a +;; horizontale disigatan fenestron, si- horizontally split window similar to +;; milan al fina apareco de via teksto: the final outcome of your text: -;; An^stata^u tri `autoload' kaj tri | Instead of three `autoload' and -;; `global-set-key' vi povas uzi la | three `global-set-key' you can use -;; jenon en via dataro ~/.emacs, por | the following in your file -;; memstare ^sar^gi la modalon: | ~/.emacs, to automatically load -;; | the mode: +;; f2 2 asocias novan bufron nomatan associates a new buffer called +;; C-x 6 2 same, sed kun 2C/ anta^u. the same, but with 2C/ +;; prepended. -;; (global-set-key "\C-x6" -;; '(lambda () (interactive) -;; (load-library "two-column") -;; (call-interactively -;; (cdr (assq (read-char) tc-mode-map))))) +;; f2 b asocias alian bufron. Vi povas associates another buffer. +;; C-x 6 b anka^u asocii dataron, se vi This can be used to associate a +;; ^jus anta^ue faris C-x C-f. file if you just did C-x C-f. -;; Se vi ^satus havi la dukolumnajn | If you'd like to have the -;; ordonojn je funkciklavo , vi | two-column commands on function -;; povas uzi la jenon en via dataro | key , you can use the -;; ~/.emacs: | following in your file ~/.emacs: +;; f2 s disigas jam dukolumnan tekston splits a two-column text into +;; C-x 6 s en du bufroj ekde la nuna two buffers from the current +;; linio, kaj je la nuna kolumno. line and at the current column. +;; La anta^uaj signoj (ofte The preceding characters (often +;; tabeligilo a^u |) estas la tab or |) are the column +;; kolumna disiganto. Linioj kiuj separator. Lines that don't +;; ne enhavas ilin ne estas have them won't be separated. +;; disigitaj. Kiel la kvara kaj Like the fourth and fifth line +;; la kvina linio se vi disigas if you split this file from +;; ^ci dataron ekde la unua angla the first english word. +;; vorto. -;; (global-set-key [f2] (function -;; (lambda () -;; (interactive) -;; (load-library "two-column") -;; (global-set-key [f2] tc-mode-map) -;; (call-interactively -;; (cdr (assq (read-char) tc-mode-map)))))) +;; Se vi volas meti longajn liniojn If you include long lines, i.e which +;; (ekz. programerojn) en la kunigotan will span both columns (eg. source +;; tekston, ili devas esti en la code), they should be in what will +;; estonte unua kolumno. La alia devas be the first column, with the +;; havi vakajn linion apud ili. associated buffer having empty lines +;; next to them. + +;; Averto: en Emacs kiam vi ^san^gas la Attention: in Emacs when you change +;; ^cefan modalon, la mal^cefaj modaloj the major mode, the minor modes are +;; estas anka^u elmemorigitaj. Tiu- also purged from memory. In that +;; okaze vi devas religi la du bufrojn case you must reassociate the two +;; per iu C-x 6-ordono, ekz. C-x 6 b. buffers with any C-x 6-command, e.g. +;; C-x 6 b. -;; In addition to two-column editing of text, for example for writing a -;; bilingual text side-by-side as shown below in the file's prolog, other -;; interesting uses have been found for this minor mode: -;; -;; -;; You can separate the columns with {+} C-x 6 u or u if you prefer -;; any string that pleases you, by {+} handles these with a prefix argument -;; setting tc-separator. For {+} that enables you to declare the -;; example "{+} " if you like to {+} desired length of such a string. -;; amuse yourself. -;; -;; -;; keyword You can write any text corresponding to a -;; given keyword in a filled paragraph next to -;; it. Note that the width of the first column -;; may be less than window-min-width in the -;; result, but will be displayed at that width. -;; -;; another This is not a three- or multi-column mode. -;; The example in the file's prolog required -;; working on two columns and then treating the -;; result as one column in order to add the -;; third. -;; -;; -;; Programmers might like the ability to split off the comment column of -;; a file that looks like the following. The advantage is that with -;; (setq fill-prefix "-- ") you can run M-q (fill-paragraph) on the -;; comment. The problem is, code quickly gets rather wide, so you need -;; to use a narrower comment column, which is less interesting, unless -;; you have a 132-column screen. Code lines that reach beyond -;; comment-column are no problem, except that you won't always see their -;; end during editing. -;; +;; Kiam vi estos kontenta de la When you have edited both buffers to +;; rezulto, vi kunmetos la du kolumnojn your content, you merge them with +;; per C-x 6 1. Se vi poste vidas C-x 6 1. If you then see a problem, +;; problemon, vi neniigu la kunmeton you undo the merge with C-x u and +;; per C-x u kaj plue modifu la du continue to edit the two buffers. +;; bufrojn. Kiam vi ne plu volas tajpi When you no longer want to edit in +;; dukolumne, vi eliru el la mal^cefa two columns, you turn off the minor +;; modalo per C-x 6 d. mode with C-x 6 d. + + +;; Aldone al dukolumna redaktado, ek- In addition to two-column editing of +;; zemple por skribi dulingvan tekston text, for example for writing a +;; flank-al-flanke kiel ^ci tiu, aliaj bilingual text side-by-side as shown +;; interesaj uzoj trovitas por tiu mal- here, other interesting uses have +;; ^cefa modalo: been found for this minor mode: + +;; Vi povas disigi la kolumnojn per {+} You can separate the columns with +;; ajna pla^ca ^ceno starigante {+} any string that pleases you, by +;; `2C-separator'. Ekzemple "{+} " {+} setting `2C-separator'. For example +;; por amuzi^gi. f2 s a^u C-x 6 s {+} "{+} " if you'd like to have fun. +;; traktas tiujn kun prefiksa {+} f2 s or C-x 6 s handles these with a +;; argumento kiu signifas la longon {+} prefix argument that means the +;; de tia ^ceno. {+} desired length of such a string. + + +;; Programistoj eble ^satus la eblecon Programmers might like the ability +;; forspliti la komentarian kolumnon de to split off the comment column of a +;; dosiero kiel la sekvanta. Vi povas file that looks like the following. +;; rearan^gigi la paragrafon. La pro- You can fill-paragraph the comment. +;; blemo estas ke koda^jo tuj lar- The problem is, code quickly gets +;; ^gi^gas, tiel ke vi bezonas pli rather wide, so you need to use a +;; mallar^gan komentarian kolumnon. narrower comment column. Code lines +;; Koda^jaj linioj tra `comment-column' that reach beyond `comment-column' +;; ne problemas, krom ke vi ne vidos are no problem, except that you +;; iliajn finojn dum redaktado. won't see their end during editing. + + ;; BEGIN -- This is just some meaningless ;; FOR i IN 1..10 LOOP -- code in Ada, that runs foobar -;; foobar( i ); -- once for each argument from one +;; foobar( i ); -- once for each argument from one ;; END LOOP; -- to ten, and then we're already ;; END; -- through with it. -;; -;; Better yet, you can put the point before "This", type M-3 C-x 6 u -;; which makes "-- " the separator between a no-comments Ada buffer, and -;; a plain text comment buffer. When you put them back together, every -;; non-empty line of the 2nd column will again be preceded by "-- ". -;; -;; -;; The function key hack (which is one of the rare times when -;; function keys are mnemonic) at the end of the file's prolog requires -;; that the lisp/term/*.el for your terminal use the standard -;; conventions. Too bad that some don't (at least not in version 18.55). -;; The Sun one is hopelessly non-standard, and vt2[024]0 somehow forgot -;; to define thru . (It defines thru instead, but -;; that is not what we need on an X terminal.) If you want to use those, -;; you'll need another hack something like: -;; -;; (if (string= (system-name) "cix") -;; (progn -;; (load-library "term/vt200.el") -;; (define-key CSI-map "12~" (cons function-keymap ?\^b))) -;; (global-unset-key "\e[") -;; (define-key esc-map "[225z" (cons function-keymap ?\^b))) -;; -;; where "cix" is the non-sun machine I use. Actually I use the same X -;; terminal to connect to both machines, and I want to keep my ~/.emacs -;; identical on both. Bother, the two Emacses don't recognize the same -;; keys and assign different sequences to those they do! I sure hope all -;; this nonsense will stop with version 19 (or preferably soon) where I'd -;; like to be able to say (define-key some-map ' some-cmd), and see -;; rather than some unintelligible ESC-sequence in command key -;; sequences. + +;; Pli bone ankora^u, vi povas pozici- Better yet, you can put the point +;; i^gi anta^u "This", tajpi M-3 f2 s before "This", type M-3 f2 s +;; kiu igas "-- " la separigilon inter which makes "-- " the separator +;; senkomentaria Ada bufro kaj nur- between a no-comments Ada buffer, +;; teksta komentaria bufro. Kiam vi and a plain text comment buffer. +;; denove kuni^gos ilin, ^ciu nevaka When you put them back together, +;; linio de l' dua kolumno denove every non-empty line of the 2nd +;; anta^uhavos "-- ". column will again be preceded by +;; "-- ". + ;;; Code: + +;; Lucid patch +(or (fboundp 'frame-width) + (fset 'frame-width 'screen-width)) + + ;;;;; Set up keymap ;;;;; -;;;###autoload -(defvar tc-mode-map nil - "Keymap for commands for two-column mode.") +(defvar 2C-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "2" '2C-two-columns) + (define-key map [f2] '2C-two-columns) + (define-key map "b" '2C-associate-buffer) + (define-key map "s" '2C-split) + map) + "Keymap for commands for setting up two-column mode.") + + + +;;;###autoload (autoload '2C-command "two-column" () t 'keymap) +(fset '2C-command 2C-mode-map) + +;; Urgh. Autoloading list this keybinding causes two-column.elc to get +;; dumped with XEmacs. + +;; This one is for historical reasons and simple keyboards, it is not +;; at all mnemonic. All usual sequences containing 2 were used, and +;; f2 could not be set up in a standard way under Emacs 18. +(global-set-key "\C-x6" '2C-command) + + +;; Urgh. Autoloading list this keybinding causes two-column.elc to get +;; dumped with XEmacs. + +(global-set-key [f2] '2C-command) -;;;###autoload -(if tc-mode-map - () - (setq tc-mode-map (make-sparse-keymap)) - (define-key tc-mode-map "1" 'tc-merge) - (define-key tc-mode-map "2" 'tc-two-columns) - (define-key tc-mode-map "b" 'tc-associate-buffer) - (define-key tc-mode-map "d" 'tc-dissociate) - (define-key tc-mode-map "\C-l" 'tc-recenter) - (define-key tc-mode-map "o" 'tc-associated-buffer) - (define-key tc-mode-map "s" 'tc-split) - (define-key tc-mode-map "{" 'shrink-window-horizontally) - (define-key tc-mode-map "}" 'enlarge-window-horizontally) - (define-key tc-mode-map " " 'tc-scroll-up) - (define-key tc-mode-map "\^?" 'tc-scroll-down) - (define-key tc-mode-map "\C-m" 'tc-scroll-line)) + +(defvar 2C-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "1" '2C-merge) + (define-key map "d" '2C-dissociate) + (define-key map "o" '2C-associated-buffer) + (define-key map "\^m" '2C-newline) + (define-key map "|" '2C-toggle-autoscroll) + (define-key map "{" '2C-shrink-window-horizontally) + (define-key map "}" '2C-enlarge-window-horizontally) + map) + "Keymap for commands for use in two-column mode.") + -;;;###autoload -(global-set-key "\C-x6" tc-mode-map) +(setq minor-mode-map-alist + (cons (cons '2C-mode + (let ((map (make-sparse-keymap))) + (substitute-key-definition '2C-command 2C-minor-mode-map + map (current-global-map)) + (substitute-key-definition 'enlarge-window-horizontally + '2C-enlarge-window-horizontally + map (current-global-map)) + (substitute-key-definition 'shrink-window-horizontally + '2C-shrink-window-horizontally + map (current-global-map)) + map)) + minor-mode-map-alist)) ;;;;; variable declarations ;;;;; -;; markers seem to be the only buffer-id not affected by renaming -;; a buffer. This nevertheless loses when a buffer is killed. -;;;###autoload -(defvar tc-other nil +;; Markers seem to be the only buffer-id not affected by renaming a buffer. +;; This nevertheless loses when a buffer is killed. The variable-name is +;; required by `describe-mode'. +(defvar 2C-mode nil "Marker to the associated buffer, if non-nil.") -;;;###autoload -(make-variable-buffer-local 'tc-other) -;;;###autoload -(put 'tc-other 'permanent-local t) +(make-variable-buffer-local '2C-mode) +(put '2C-mode 'permanent-local t) + -;(setq minor-mode-alist (cons '(tc-other " 2C") minor-mode-alist)) -;; XEmacs: moved after def of tc-two-columns. + +(setq minor-mode-alist (cons '(2C-mode " 2C") minor-mode-alist)) +(add-minor-mode '2C-other " 2C" nil nil '2C-two-columns) + ;; rearranged, so that the pertinent info will show in 40 columns -(defvar tc-mode-line-format +(defvar 2C-mode-line-format '("-%*- %15b --" (-3 . "%p") "--%[(" mode-name - minor-mode-alist mode-line-process "%n" ")%]%-") + minor-mode-alist "%n" mode-line-process ")%]%-") "*Value of mode-line-format for a buffer in two-column minor mode.") -(defvar tc-separator "" + +(defvar 2C-other-buffer-hook 'text-mode + "*Hook run in new buffer when it is associated with current one.") + + +(defvar 2C-separator "" "*A string inserted between the two columns when merging. -This gets set locally by \\[tc-split].") -(put 'tc-separator 'permanent-local t) +This gets set locally by \\[2C-split].") +(put '2C-separator 'permanent-local t) -(defvar tc-window-width 40 + + +(defvar 2C-window-width 40 "*The width of the first column. (Must be at least `window-min-width') This value is local for every buffer that sets it.") -(make-variable-buffer-local 'tc-window-width) -(put 'tc-window-width 'permanent-local t) +(make-variable-buffer-local '2C-window-width) +(put '2C-window-width 'permanent-local t) + -(defvar tc-beyond-fill-column 4 + +(defvar 2C-beyond-fill-column 4 "*Base for calculating `fill-column' for a buffer in two-column minor mode. -The value of `fill-column' becomes `tc-window-width' for this buffer +The value of `fill-column' becomes `2C-window-width' for this buffer minus this value.") -(defvar tc-mode-hook nil - "Function called, if non-nil, whenever turning on two-column minor mode. -It can get called by \\[tc-two-columns] (tc-two-columns), \\[tc-split] (tc-split) -and \\[tc-associate-buffer] (tc-associate-buffer), on both buffers.") + + +(defvar 2C-autoscroll t + "If non-nil, Emacs attempts to keep the two column's buffers aligned.") + + + +(defvar 2C-autoscroll-start nil) +(make-variable-buffer-local '2C-autoscroll-start) ;;;;; base functions ;;;;; -;; the access method for the other buffer. this tries to remedy against +;; The access method for the other buffer. This tries to remedy against ;; lost local variables and lost buffers. -(defun tc-other () - (if tc-other - (or (prog1 - (marker-buffer tc-other) - (setq mode-line-format tc-mode-line-format )) - ; The associated buffer somehow got killed. - (progn - ; The other variables may later be useful if the user - ; reestablishes the association. - (kill-local-variable 'tc-other) - (kill-local-variable 'mode-line-format) - nil)))) +(defun 2C-other (&optional req) + (or (if 2C-mode + (or (prog1 + (marker-buffer 2C-mode) + (setq mode-line-format 2C-mode-line-format)) + ;; The associated buffer somehow got killed. + (progn + ;; The other variables may later be useful if the user + ;; reestablishes the association. + (kill-local-variable '2C-mode) + (kill-local-variable 'mode-line-format) + nil))) + (if req (error "You must first set two-column minor mode.")))) -;;;###autoload -(defun tc-two-columns (&optional buffer) - "Split current window vertically for two-column editing. + -When called the first time, associates a buffer with the current -buffer. Both buffers are put in two-column minor mode and -tc-mode-hook gets called on both. These buffers remember -about one another, even when renamed. +;; function for setting up two-column minor mode in a buffer associated +;; with the buffer pointed to by the marker other. +(defun 2C-mode (other) + "Minor mode for independently editing two columns. +This is set up for two associated buffers by the three commands bound +to \\[2C-two-columns] , \\[2C-associate-buffer] and \\[2C-split]. +Turning on two-column mode calls the value of the variable `2C-mode-hook', +if that value is non-nil. -When called again, restores the screen layout with the current buffer -first and the associated buffer to it's right. +These buffers can be edited separately, for example with `fill-paragraph'. +If you want to disable parallel scrolling temporarily, use \\[2C-toggle-autoscroll] . If you include long lines, i.e which will span both columns (eg. source code), they should be in what will be the first column, with the associated buffer having empty lines next to them. +Potential uses are writing bilingual texts, or editing the comments of a +source code. See the file lisp/two-column.el for detailed examples. + You have the following commands at your disposal: -\\[tc-two-columns] Rearrange screen -\\[tc-associate-buffer] Reassociate buffer after changing major mode -\\[tc-scroll-up] Scroll both buffers up by a screenfull -\\[tc-scroll-down] Scroll both buffers down by a screenful -\\[tc-scroll-line] Scroll both buffers up by one or more lines -\\[tc-recenter] Recenter and realign other buffer +\\[2C-two-columns] Rearrange screen with current buffer first +\\[2C-associate-buffer] Reassociate buffer after changing major mode \\[shrink-window-horizontally], \\[enlarge-window-horizontally] Shrink, enlarge current column -\\[tc-associated-buffer] Switch to associated buffer -\\[tc-merge] Merge both buffers +\\[2C-associated-buffer] Switch to associated buffer at same point +\\[2C-newline] Insert newline(s) in both buffers at same point +\\[2C-merge] Merge both buffers +\\[2C-dissociate] Dissociate the two buffers -These keybindings can be customized in your ~/.emacs by `tc-prefix' -and `tc-mode-map'. +These keybindings can be customized in your ~/.emacs by `2C-mode-map', +`2C-minor-mode-map' and by binding `2C-command' to some prefix. The appearance of the screen can be customized by the variables -`tc-window-width', `tc-beyond-fill-column', -`tc-mode-line-format' and `truncate-partial-width-windows'." +`2C-window-width', `2C-beyond-fill-column', `2C-mode-line-format' and +`truncate-partial-width-windows'." + (make-local-hook 'post-command-hook) + (add-hook 'post-command-hook '2C-autoscroll nil t) + (setq fill-column (- 2C-window-width + 2C-beyond-fill-column) + mode-line-format 2C-mode-line-format + 2C-mode other) + (run-hooks '2C-mode-hook)) + + +;;;###autoload +(defun 2C-two-columns (&optional buffer) + "Split current window vertically for two-column editing. +When called the first time, associates a buffer with the current +buffer in two-column minor mode (see \\[describe-mode] ). +Runs `2C-other-buffer-hook' in the new buffer. +When called again, restores the screen layout with the current buffer +first and the associated buffer to it's right." (interactive "P") - ; first go to full width, so that we can certainly split into - ; two windows + ;; first go to full width, so that we can certainly split into two windows (if (< (window-width) (frame-width)) (enlarge-window 99999 t)) (split-window-horizontally - (max window-min-width (min tc-window-width + (max window-min-width (min 2C-window-width (- (frame-width) window-min-width)))) - (if (tc-other) + (if (2C-other) (progn (other-window 1) - (switch-to-buffer (tc-other)) + (switch-to-buffer (2C-other)) (other-window -1) - ; align buffers if necessary - (tc-scroll-line 0)) + (if 2C-autoscroll + (2C-toggle-autoscroll t))) - ; set up minor mode linking two buffers - (setq fill-column (- tc-window-width - tc-beyond-fill-column) - mode-line-format tc-mode-line-format) - (run-hooks tc-mode-hook) - (let ((other (point-marker))) - (other-window 1) - (switch-to-buffer - (or buffer - (generate-new-buffer - (concat "2C/" (buffer-name))))) - (or buffer - (text-mode)) - (setq fill-column (- tc-window-width - tc-beyond-fill-column) - mode-line-format tc-mode-line-format - tc-other other - other (point-marker)) - (run-hooks tc-mode-hook) - (other-window -1) - (setq tc-other other)))) + (2C-mode (prog1 (point-marker) + (other-window 1) + (switch-to-buffer + (or buffer + (generate-new-buffer (concat "2C/" (buffer-name))))) + (or buffer + (run-hooks '2C-other-buffer-hook)))) + + (2C-mode (prog1 (point-marker) + (other-window -1))))) -;; XEmacs: do it right. -;;;###autoload -(add-minor-mode 'tc-other " 2C" nil nil 'tc-two-columns) -(defalias 'tc-mode 'tc-two-columns) ;;;###autoload -(defun tc-associate-buffer () +(defun 2C-associate-buffer () "Associate another buffer with this one in two-column minor mode. Can also be used to associate a just previously visited file, by accepting the proposed default buffer. -See \\[tc-two-columns] and `lisp/two-column.el' for further details." +\(See \\[describe-mode] .)" (interactive) (let ((b1 (current-buffer)) - (b2 (or (tc-other) + (b2 (or (2C-other) (read-buffer "Associate buffer: " (other-buffer))))) (save-excursion - (setq tc-other nil) + (setq 2C-mode nil) (set-buffer b2) - (and (tc-other) - (not (eq b1 (tc-other))) + (and (2C-other) + (not (eq b1 (2C-other))) (error "Buffer already associated with buffer `%s'." - (buffer-name (tc-other)))) - (setq b1 (and (assq 'tc-window-width (buffer-local-variables)) - tc-window-width))) + (buffer-name (2C-other)))) + (setq b1 (and (assq '2C-window-width (buffer-local-variables)) + 2C-window-width))) ; if other buffer has a local width, adjust here too - (if b1 (setq tc-window-width (- (frame-width) b1))) - (tc-two-columns b2))) + (if b1 (setq 2C-window-width (- (frame-width) b1))) + (2C-two-columns b2))) + + ;;;###autoload -(defun tc-split (arg) - "Unmerge a two-column text into two buffers in two-column minor mode. -The text is unmerged at the cursor's column which becomes the local -value of `tc-window-width'. Only lines that have the ARG same -preceding characters at that column get split. The ARG preceding -characters without any leading whitespace become the local value for -`tc-separator'. This way lines that continue across both +(defun 2C-split (arg) + "Split a two-column text at point, into two buffers in two-column minor mode. +Point becomes the local value of `2C-window-width'. Only lines that +have the ARG same preceding characters at that column get split. The +ARG preceding characters without any leading whitespace become the local +value for `2C-separator'. This way lines that continue across both columns remain untouched in the first buffer. -This function can be used with a prototype line, to set up things as -you like them. You write the first line of each column with the -separator you like and then unmerge that line. E.g.: +This function can be used with a prototype line, to set up things. You +write the first line of each column and then split that line. E.g.: -First column's text sSs Second columns text +First column's text sSs Second column's text \\___/\\ / \\ - 5 character Separator You type M-5 \\[tc-split] with the point here + 5 character Separator You type M-5 \\[2C-split] with the point here. -See \\[tc-two-columns] and `lisp/two-column.el' for further details." - (interactive "p") - (and (tc-other) +\(See \\[describe-mode] .)" + (interactive "*p") + (and (2C-other) (if (y-or-n-p (concat "Overwrite associated buffer `" - (buffer-name (tc-other)) + (buffer-name (2C-other)) "'? ")) (save-excursion - (set-buffer (tc-other)) + (set-buffer (2C-other)) (erase-buffer)) (signal 'quit nil))) (let ((point (point)) @@ -422,12 +428,12 @@ (backward-char arg) (setq chars (buffer-substring (point) point)) (skip-chars-forward " \t" point) - (make-local-variable 'tc-separator) - (setq tc-separator (buffer-substring (point) point) - tc-window-width (current-column))) - (tc-two-columns) - (setq other (tc-other)) - ; now we're ready to actually unmerge + (make-local-variable '2C-separator) + (setq 2C-separator (buffer-substring (point) point) + 2C-window-width (current-column))) + (2C-two-columns) + (setq other (2C-other)) + ; now we're ready to actually split (save-excursion (while (not (eobp)) (if (not (and (= (current-column) goal-column) @@ -451,59 +457,57 @@ (setq n 0)) (next-line 1))))) -;;;###autoload -(defun tc-dissociate () + + + +(defun 2C-dissociate () "Turn off two-column minor mode in current and associated buffer. If the associated buffer is unmodified and empty, it is killed." (interactive) (let ((buffer (current-buffer))) (save-excursion - (and (tc-other) - (set-buffer (tc-other)) - (or (not (tc-other)) - (eq buffer (tc-other))) + (and (2C-other) + (set-buffer (2C-other)) + (or (not (2C-other)) + (eq buffer (2C-other))) (if (and (not (buffer-modified-p)) (eobp) (bobp)) (kill-buffer nil) - (kill-local-variable 'tc-other) - (kill-local-variable 'tc-window-width) - (kill-local-variable 'tc-separator) + (kill-local-variable '2C-mode) + (kill-local-variable '2C-window-width) + (kill-local-variable '2C-separator) (kill-local-variable 'mode-line-format) (kill-local-variable 'fill-column)))) - (kill-local-variable 'tc-other) - (kill-local-variable 'tc-window-width) - (kill-local-variable 'tc-separator) + (kill-local-variable '2C-mode) + (kill-local-variable '2C-window-width) + (kill-local-variable '2C-separator) (kill-local-variable 'mode-line-format) (kill-local-variable 'fill-column))) + ;; this doesn't use yank-rectangle, so that the first column can ;; contain long lines -;;;###autoload -(defun tc-merge () +(defun 2C-merge () "Merges the associated buffer with the current buffer. -They get merged at the column, which is the value of -`tc-window-width', i.e. usually at the vertical window -separator. This separator gets replaced with white space. Beyond -that the value of gets inserted on merged lines. The two columns are -thus pasted side by side, in a single text. If the other buffer is -not displayed to the left of this one, then this one becomes the left -column. +They get merged at the column, which is the value of `2C-window-width', +i.e. usually at the vertical window separator. This separator gets +replaced with white space. Beyond that the value of `2C-separator' gets +inserted on merged lines. The two columns are thus pasted side by side, +in a single text. If the other buffer is not displayed to the left of +this one, then this one becomes the left column. -If you want `tc-separator' on empty lines in the second column, +If you want `2C-separator' on empty lines in the second column, you should put just one space in them. In the final result, you can strip off trailing spaces with \\[beginning-of-buffer] \\[replace-regexp] [ SPC TAB ] + $ RET RET" - (interactive) - (or (tc-other) - (error "You must first set two-column minor mode.")) - (and (> (car (window-pixel-edges)) 0) ; not touching left edge of screen + (and (> (car (window-edges)) 0) ; not touching left edge of screen (eq (window-buffer (previous-window)) - (tc-other)) + (2C-other t)) (other-window -1)) (save-excursion (let ((b1 (current-buffer)) - (b2 (tc-other)) + (b2 (2C-other t)) string) (goto-char (point-min)) (set-buffer b2) @@ -517,8 +521,8 @@ (if (string= string "") () (end-of-line) - (indent-to-column tc-window-width) - (insert tc-separator string)) + (indent-to-column 2C-window-width) + (insert 2C-separator string)) (next-line 1) ; add one if necessary (set-buffer b2)))) (if (< (window-width) (frame-width)) @@ -526,85 +530,105 @@ ;;;;; utility functions ;;;;; -;;;###autoload -(defun tc-associated-buffer () +(defun 2C-associated-buffer () "Switch to associated buffer." (interactive) - (or (tc-other) - (error "You must set two-column minor mode.")) - (if (get-buffer-window (tc-other)) - (select-window (get-buffer-window (tc-other))) - (switch-to-buffer (tc-other)))) + (let ((line (+ (count-lines (point-min) (point)) + (if (bolp) 1 0))) + (col (if (eolp) (if (bolp) 0) (current-column)))) + (if (get-buffer-window (2C-other t)) + (select-window (get-buffer-window (2C-other))) + (switch-to-buffer (2C-other))) + (newline (goto-line line)) + (if col + (move-to-column col) + (end-of-line 1)))) + +(defun 2C-newline (arg) + "Insert ARG newlines in both buffers." + (interactive "P") + (save-window-excursion + (2C-associated-buffer) + (newline arg)) + (newline arg)) -;; It would be desirable to intercept anything that causes the current -;; window to scroll. Maybe a `scroll-hook'? -;;;###autoload -(defun tc-scroll-line (arg) - "Scroll current window upward by ARG lines. -The associated window gets scrolled to the same line." - (interactive "p") - (or (tc-other) - (error "You must set two-column minor mode.")) - ; scroll-up has a bug on arg 0 at end of buffer - (or (zerop arg) - (scroll-up arg)) - (setq arg (count-lines (point-min) (window-start))) - ; too bad that pre 18.57 Emacs makes save-window-excursion restore - ; the point. When it becomes extinct, we can simplify this. - (if (get-buffer-window (tc-other)) - (let ((window (selected-window))) - (select-window (get-buffer-window (tc-other))) - (setq arg (- arg (count-lines (point-min) (window-start)))) - ; make sure that other buffer has enough lines - (save-excursion - (goto-char (point-max)) - (insert-char ?\n - (- arg (count-lines (window-start) (point-max)) -1))) - (or (zerop arg) - (scroll-up arg)) - (select-window window)))) +(defun 2C-toggle-autoscroll (arg) + "Toggle autoscrolling, or set it iff prefix ARG is non-nil and positive. +When autoscrolling is turned on, this also realigns the two buffers." + (interactive "P") + ;(sit-for 0) + (setq 2C-autoscroll-start (window-start)) + (if (setq 2C-autoscroll (if arg + (>= (prefix-numeric-value arg) 0) + (not 2C-autoscroll))) + (select-window + (prog1 (selected-window) + (message "Autoscrolling is on.") + (setq arg (count-lines (point-min) (window-start))) + (if (get-buffer-window (2C-other t)) + (progn + (select-window (get-buffer-window (2C-other))) + (setq arg (- arg (count-lines (point-min) (window-start)))) + ;; make sure that other buffer has enough lines + (save-excursion + (insert-char ?\n + (- arg (count-lines (window-start) + (goto-char (point-max))) + -1))) + (scroll-up arg))))) + (message "Autoscrolling is off."))) + + -;;;###autoload -(defun tc-scroll-up (arg) - "Scroll current window upward by ARG screens. -The associated window gets scrolled to the same line." - (interactive "p") - (tc-scroll-line (* arg (- (window-height) - next-screen-context-lines 1)))) +(defun 2C-autoscroll () + (if 2C-autoscroll + ;; catch a mouse scroll on non-selected scrollbar + (select-window + (prog1 (selected-window) + (and (consp last-command-char) + (not (eq (selected-window) + (car (car (cdr last-command-char))))) + (select-window (car (car (cdr last-command-char))))) + ;; In some cases scrolling causes an error, but post-command-hook + ;; shouldn't, and should always stay in the original window + (condition-case () + (and (or 2C-autoscroll-start (2C-toggle-autoscroll t) nil) + (/= (window-start) 2C-autoscroll-start) + (2C-other) + (get-buffer-window (2C-other)) + (let ((lines (count-lines (window-start) + 2C-autoscroll-start))) + (if (< (window-start) 2C-autoscroll-start) + (setq lines (- lines))) + (setq 2C-autoscroll-start (window-start)) + (select-window (get-buffer-window (2C-other))) + ;; make sure that other buffer has enough lines + (save-excursion + (insert-char + ?\n (- lines (count-lines (window-start) + (goto-char (point-max))) + -1))) + (scroll-up lines) + (setq 2C-autoscroll-start (window-start)))) + (error)))))) -;;;###autoload -(defun tc-scroll-down (arg) - "Scroll current window downward by ARG screens. -The associated window gets scrolled to the same line." - (interactive "p") - (tc-scroll-line (* arg (- next-screen-context-lines - (window-height) -1)))) + -;;;###autoload -(defun tc-recenter (arg) - "Center point in window. With ARG, put point on line ARG. -This counts from bottom if ARG is negative. The associated window -gets scrolled to the same line." - (interactive "P") - (setq arg (and arg (prefix-numeric-value arg))) - (tc-scroll-line (- (count-lines (window-start) (point)) - (cond ((null arg) (/ (window-height) 2)) - ((< arg 0) (+ (window-height) arg)) - ( arg))))) - -(defun enlarge-window-horizontally (arg) +(defun 2C-enlarge-window-horizontally (arg) "Make current window ARG columns wider." (interactive "p") (enlarge-window arg t) - (and (tc-other) - (setq tc-window-width (+ tc-window-width arg)) - (set-buffer (tc-other)) - (setq tc-window-width (- tc-window-width arg)))) + (and (2C-other) + (setq 2C-window-width (+ 2C-window-width arg)) + (set-buffer (2C-other)) + (setq 2C-window-width (- 2C-window-width arg)))) -(defun shrink-window-horizontally (arg) +(defun 2C-shrink-window-horizontally (arg) "Make current window ARG columns narrower." (interactive "p") - (enlarge-window-horizontally (- arg))) + (2C-enlarge-window-horizontally (- arg))) + + (provide 'two-column) diff -r 30df88044ec6 -r b82b59fe008d lisp/modes/xpm-mode.el --- a/lisp/modes/xpm-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/xpm-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -109,6 +109,14 @@ (next-line 1) (while (not (looking-at "\\s-*\"")) (next-line 1)) + + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*" + (point-max) t) + (setq xpm-chars-per-pixel (string-to-int (match-string 4))))) + (let ((co 0)) (while (< co (xpm-num-colors)) (progn @@ -144,7 +152,8 @@ (let (ext pixel-chars pixel-color) - (while (< (point) (point-max)) + (while (and (< (point) (point-max)) + (< (+ (point) xpm-chars-per-pixel) (point-max))) (setq pixel-chars (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) pixel-color (assoc pixel-chars xpm-pixel-values) diff -r 30df88044ec6 -r b82b59fe008d lisp/mu/mu-bbdb.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mu/mu-bbdb.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,135 @@ +;;; 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.1 1996/12/18 03:55:30 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 (not (fboundp 'eval-when)) + (require 'bbdb) + (eval-when (compile) + (ignore-errors + (require 'bbdb))) + (eval-when (load eval) + (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 30df88044ec6 -r b82b59fe008d lisp/mu/mu-cite.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mu/mu-cite.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,502 @@ +;;; mu-cite.el --- yet another citation tool for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; MINOURA Makoto +;; Shuhei KOBAYASHI +;; Maintainer: Shuhei KOBAYASHI +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: mail, news, citation + +;; 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 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.1.1.1 1996/12/18 03:55:31 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 + (list (cons 'mh-letter-mode + (function + (lambda (name) + (if (and (stringp mh-sent-from-folder) + (numberp mh-sent-from-msg)) + (save-excursion + (set-buffer mh-sent-from-folder) + (set-buffer mh-show-buffer) + (and (boundp 'mime::preview/article-buffer) + (bufferp mime::preview/article-buffer) + (set-buffer mime::preview/article-buffer)) + (std11-field-body name) + )) + ))))) + +(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) +(load mu-cite/registration-file t t t) +(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-to-file) + ) + +;; save to file +(defun mu-cite/save-to-file () + (let* ((filename mu-cite/registration-file) + (buffer (get-buffer-create " *mu-register*"))) + (save-excursion + (set-buffer buffer) + (setq buffer-file-name filename) + (erase-buffer) + (insert + (format ";;; %s\n" (file-name-nondirectory filename))) + (insert + (format ";;; This file is generated automatically by mu-cite %s.\n\n" + mu-cite/version)) + (insert (format "(setq %s\n '(" mu-cite/registration-symbol)) + (insert (mapconcat + (function prin1-to-string) + mu-cite/citation-name-alist "\n ")) + (insert "\n ))\n\n") + (insert + (format ";;; %s ends here.\n" (file-name-nondirectory filename))) + (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 cited-prefix-regexp "^[^ \t>]*[>|]+[ \t#]*" + "*Regexp to match the citation prefix.") + +(defun fill-cited-region (beg end) + (interactive "*r") + (save-excursion + (save-restriction + (goto-char end) + (while (not (eolp)) + (backward-char) + ) + (setq end (point)) + (narrow-to-region beg end) + (goto-char (point-min)) + (let* ((fill-prefix + (let* ((str1 (buffer-substring + (progn (beginning-of-line)(point)) + (progn (end-of-line)(point)) + )) + (str2 (let ((p0 (point))) + (forward-line) + (if (> (count-lines p0 (point)) 0) + (buffer-substring + (progn (beginning-of-line)(point)) + (progn (end-of-line)(point)) + )))) + (ret (string-compare-from-top str1 str2)) + ) + (if ret + (let ((prefix (nth 1 ret))) + (if (string-match cited-prefix-regexp prefix) + (substring prefix 0 (match-end 0)) + prefix)) + (goto-char (point-min)) + (if (re-search-forward cited-prefix-regexp nil t) + (buffer-substring (match-beginning 0) (match-end 0)) + )))) + (pat (concat "\n" fill-prefix)) + ) + (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)) + )))) + +(defvar citation-mark-chars ">}|") + +(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 30df88044ec6 -r b82b59fe008d lisp/mu/std11-parse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mu/std11-parse.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,442 @@ +;;; std11-parse.el --- STD 11 parser for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, RFC 822, STD 11 +;; Version: +;; $Id: std11-parse.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ + +;; 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. + +;;; Code: + +(require 'std11) +(require 'emu) + + +;;; @ lexical analyze +;;; + +(defconst std11-space-chars " \t\n") +(defconst std11-spaces-regexp (concat "[" std11-space-chars "]+")) +(defconst std11-special-chars "][()<>@,;:\\<>.\"") +(defconst std11-atom-regexp + (concat "^[^" std11-special-chars std11-space-chars "]+")) + +(defun std11-analyze-spaces (string) + (if (and (string-match std11-spaces-regexp string) + (= (match-beginning 0) 0)) + (let ((end (match-end 0))) + (cons (cons 'spaces (substring string 0 end)) + (substring string end) + )))) + +(defun std11-analyze-special (str) + (if (and (> (length str) 0) + (find (aref str 0) std11-special-chars) + ) + (cons (cons 'specials (substring str 0 1)) + (substring str 1) + ))) + +(defun std11-analyze-atom (str) + (if (string-match std11-atom-regexp str) + (let ((end (match-end 0))) + (cons (cons 'atom (substring str 0 end)) + (substring str end) + )))) + +(defun std11-check-enclosure (str open close &optional recursive from) + (let ((len (length str)) + (i (or from 0)) + ) + (if (and (> len i) + (eq (aref str i) open)) + (let (p chr) + (setq i (1+ i)) + (catch 'tag + (while (< i len) + (setq chr (aref str i)) + (cond ((eq chr ?\\) + (setq i (1+ i)) + (if (>= i len) + (throw 'tag nil) + ) + (setq i (1+ i)) + ) + ((eq chr close) + (throw 'tag (1+ i)) + ) + ((eq chr open) + (if (and recursive + (setq p (std11-check-enclosure + str open close recursive i)) + ) + (setq i p) + (throw 'tag nil) + )) + (t + (setq i (1+ i)) + )) + )))))) + +(defun std11-analyze-quoted-string (str) + (let ((p (std11-check-enclosure str ?\" ?\"))) + (if p + (cons (cons 'quoted-string (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-analyze-domain-literal (str) + (let ((p (std11-check-enclosure str ?\[ ?\]))) + (if p + (cons (cons 'domain-literal (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-analyze-comment (str) + (let ((p (std11-check-enclosure str ?\( ?\) t))) + (if p + (cons (cons 'comment (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-lexical-analyze (str) + (let (dest ret) + (while (not (string-equal str "")) + (setq ret + (or (std11-analyze-quoted-string str) + (std11-analyze-domain-literal str) + (std11-analyze-comment str) + (std11-analyze-spaces str) + (std11-analyze-special str) + (std11-analyze-atom str) + '((error) . "") + )) + (setq dest (cons (car ret) dest)) + (setq str (cdr ret)) + ) + (nreverse dest) + )) + + +;;; @ parser +;;; + +(defun std11-ignored-token-p (token) + (let ((type (car token))) + (or (eq type 'spaces)(eq type 'comment)) + )) + +(defun std11-parse-token (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-ascii-token (lal) + (let (token itl parsed token-value) + (while (and lal + (setq token (car lal)) + (if (and (setq token-value (cdr token)) + (find-non-ascii-charset-string token-value) + ) + (setq token nil) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (if (and token + (setq parsed (nreverse (cons token itl))) + ) + (cons parsed (cdr lal)) + ))) + +(defun std11-parse-token-or-comment (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (eq (car token) 'spaces) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-word (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (if (or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ))))) + +(defun std11-parse-word-or-comment (lal) + (let ((ret (std11-parse-token-or-comment lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (cond ((or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ) + ((assq 'comment elt) + (cons (cons 'comment-word elt) rest) + )) + )))) + +(defun std11-parse-phrase (lal) + (let (ret phrase) + (while (setq ret (std11-parse-word-or-comment lal)) + (setq phrase (append phrase (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (if phrase + (cons (cons 'phrase phrase) lal) + ))) + +(defun std11-parse-local-part (lal) + (let ((ret (std11-parse-word lal))) + (if ret + (let ((local-part (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-word (cdr ret))) + (setq local-part + (append local-part dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'local-part local-part) lal) + )))) + +(defun std11-parse-sub-domain (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((sub-domain (car ret))) + (if (or (assq 'atom sub-domain) + (assq 'domain-literal sub-domain) + ) + (cons (cons 'sub-domain sub-domain) + (cdr ret) + ) + ))))) + +(defun std11-parse-domain (lal) + (let ((ret (std11-parse-sub-domain lal))) + (if ret + (let ((domain (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-sub-domain (cdr ret))) + (setq domain + (append domain dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'domain domain) lal) + )))) + +(defun std11-parse-at-domain (lal) + (let ((ret (std11-parse-ascii-token lal)) at-sign) + (if (and ret + (setq at-sign (car ret)) + (string-equal (cdr (assq 'specials at-sign)) "@") + (setq ret (std11-parse-domain (cdr ret))) + ) + (cons (cons 'at-domain (append at-sign (cdr (car ret)))) + (cdr ret)) + ))) + +(defun std11-parse-addr-spec (lal) + (let ((ret (std11-parse-local-part lal)) + addr) + (if (and ret + (prog1 + (setq addr (cdr (car ret))) + (setq lal (cdr ret)) + (and (setq ret (std11-parse-at-domain lal)) + (setq addr (append addr (cdr (car ret)))) + (setq lal (cdr ret)) + ))) + (cons (cons 'addr-spec addr) lal) + ))) + +(defun std11-parse-route (lal) + (let ((ret (std11-parse-at-domain lal)) + route comma colon) + (if (and ret + (progn + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal (cdr (assq 'specials comma)) ",") + (setq ret (std11-parse-at-domain (cdr ret))) + ) + (setq route (append route comma (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (and (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq route (append route colon)) + ) + )) + (cons (cons 'route route) + (cdr ret) + ) + ))) + +(defun std11-parse-route-addr (lal) + (let ((ret (std11-parse-ascii-token lal)) + < route addr-spec >) + (if (and ret + (setq < (car ret)) + (string-equal (cdr (assq 'specials <)) "<") + (setq lal (cdr ret)) + (progn (and (setq ret (std11-parse-route lal)) + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + ) + (setq ret (std11-parse-addr-spec lal)) + ) + (setq addr-spec (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq > (car ret)) + (string-equal (cdr (assq 'specials >)) ">") + ) + (cons (cons 'route-addr (append route addr-spec)) + (cdr ret) + ) + ))) + +(defun std11-parse-phrase-route-addr (lal) + (let ((ret (std11-parse-phrase lal)) phrase) + (if ret + (progn + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + )) + (if (setq ret (std11-parse-route-addr lal)) + (cons (list 'phrase-route-addr + phrase + (cdr (car ret))) + (cdr ret)) + ))) + +(defun std11-parse-mailbox (lal) + (let ((ret (or (std11-parse-phrase-route-addr lal) + (std11-parse-addr-spec lal))) + mbox comment) + (if (and ret + (prog1 + (setq mbox (car ret)) + (setq lal (cdr ret)) + (if (and (setq ret (std11-parse-token-or-comment lal)) + (setq comment (cdr (assq 'comment (car ret)))) + ) + (setq lal (cdr ret)) + ))) + (cons (list 'mailbox mbox comment) + lal) + ))) + +(defun std11-parse-group (lal) + (let ((ret (std11-parse-phrase lal)) + phrase colon comma mbox semicolon) + (if (and ret + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq lal (cdr ret)) + (progn + (and (setq ret (std11-parse-mailbox lal)) + (setq mbox (list (car ret))) + (setq lal (cdr ret)) + (progn + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal + (cdr (assq 'specials comma)) ",") + (setq lal (cdr ret)) + (setq ret (std11-parse-mailbox lal)) + (setq mbox (cons (car ret) mbox)) + (setq lal (cdr ret)) + ) + ))) + (and (setq ret (std11-parse-ascii-token lal)) + (setq semicolon (car ret)) + (string-equal (cdr (assq 'specials semicolon)) ";") + ))) + (cons (list 'group phrase (nreverse mbox)) + (cdr ret) + ) + ))) + +(defun std11-parse-address (lal) + (or (std11-parse-group lal) + (std11-parse-mailbox lal) + )) + +(defun std11-parse-addresses (lal) + (let ((ret (std11-parse-address lal))) + (if ret + (let ((dest (list (car ret)))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (string-equal (cdr (assq 'specials (car ret))) ",") + (setq ret (std11-parse-address (cdr ret))) + ) + (setq dest (cons (car ret) dest)) + (setq lal (cdr ret)) + ) + (nreverse dest) + )))) + + +;;; @ end +;;; + +(provide 'std11-parse) + +;;; std11-parse.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/mu/std11.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mu/std11.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,346 @@ +;;; std11.el --- STD 11 functions for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, RFC 822, STD 11 +;; Version: $Id: std11.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ + +;; 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. + +;;; Code: + +(autoload 'buffer-substring-no-properties "emu") +(autoload 'member "emu") + + +;;; @ field +;;; + +(defconst std11-field-name-regexp "[!-9;-~]+") +(defconst std11-field-head-regexp + (concat "^" std11-field-name-regexp ":")) +(defconst std11-next-field-head-regexp + (concat "\n" std11-field-name-regexp ":")) + +(defun std11-field-end () + "Move to end of field and return this point. [std11.el]" + (if (re-search-forward std11-next-field-head-regexp nil t) + (goto-char (match-beginning 0)) + (if (re-search-forward "^$" nil t) + (goto-char (1- (match-beginning 0))) + (end-of-line) + )) + (point) + ) + +(defun std11-field-body (name &optional boundary) + "Return body of field NAME. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (re-search-forward (concat "^" name ":[ \t]*") nil t) + (buffer-substring-no-properties (match-end 0) (std11-field-end)) + ))))) + +(defun std11-find-field-body (field-names &optional boundary) + "Return the first found field-body specified by FIELD-NAMES +of the message header in current buffer. If BOUNDARY is not nil, it is +used as message header separator. [std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (let ((case-fold-search t) + field-name) + (catch 'tag + (while (setq field-name (car field-names)) + (goto-char (point-min)) + (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) + (throw 'tag + (buffer-substring-no-properties + (match-end 0) (std11-field-end))) + ) + (setq field-names (cdr field-names)) + )))))) + +(defun std11-field-bodies (field-names &optional default-value boundary) + "Return list of each field-bodies of FIELD-NAMES of the message header +in current buffer. If BOUNDARY is not nil, it is used as message +header separator. [std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (let* ((case-fold-search t) + (dest (make-list (length field-names) default-value)) + (s-rest field-names) + (d-rest dest) + field-name) + (while (setq field-name (car s-rest)) + (goto-char (point-min)) + (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) + (setcar d-rest + (buffer-substring-no-properties + (match-end 0) (std11-field-end))) + ) + (setq s-rest (cdr s-rest) + d-rest (cdr d-rest)) + ) + dest)))) + + +;;; @ unfolding +;;; + +(defun std11-unfold-string (string) + "Unfold STRING as message header field. [std11.el]" + (let ((dest "")) + (while (string-match "\n\\([ \t]\\)" string) + (setq dest (concat dest + (substring string 0 (match-beginning 0)) + (match-string 1 string) + )) + (setq string (substring string (match-end 0))) + ) + (concat dest string) + )) + + +;;; @ header +;;; + +(defun std11-narrow-to-header (&optional boundary) + "Narrow to the message header. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward + (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$") + nil t) + (match-beginning 0) + (point-max) + ))) + +(defun std11-header-string (regexp &optional boundary) + "Return string of message header fields matched by REGEXP. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (let ((case-fold-search t)) + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (field header) + (while (re-search-forward std11-field-head-regexp nil t) + (setq field + (buffer-substring (match-beginning 0) (std11-field-end))) + (if (string-match regexp field) + (setq header (concat header field "\n")) + )) + header) + )))) + +(defun std11-header-string-except (regexp &optional boundary) + "Return string of message header fields not matched by REGEXP. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (let ((case-fold-search t)) + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (field header) + (while (re-search-forward std11-field-head-regexp nil t) + (setq field + (buffer-substring (match-beginning 0) (std11-field-end))) + (if (not (string-match regexp field)) + (setq header (concat header field "\n")) + )) + header) + )))) + +(defun std11-collect-field-names (&optional boundary) + "Return list of all field-names of the message header in current buffer. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (dest name) + (while (re-search-forward std11-field-head-regexp nil t) + (setq name (buffer-substring-no-properties + (match-beginning 0)(1- (match-end 0)))) + (or (member name dest) + (setq dest (cons name dest)) + ) + ) + dest)))) + + +;;; @ quoted-string +;;; + +(defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n)) + +(defun std11-wrap-as-quoted-string (string) + "Wrap STRING as RFC 822 quoted-string. [std11.el]" + (concat "\"" + (mapconcat (function + (lambda (chr) + (if (memq chr std11-non-qtext-char-list) + (concat "\\" (char-to-string chr)) + (char-to-string chr) + ) + )) string "") + "\"")) + +(defun std11-strip-quoted-pair (str) + (let ((dest "") + (i 0) + (len (length str)) + chr flag) + (while (< i len) + (setq chr (aref str i)) + (if (or flag (not (eq chr ?\\))) + (progn + (setq dest (concat dest (char-to-string chr))) + (setq flag nil) + ) + (setq flag t) + ) + (setq i (+ i 1)) + ) + dest)) + +(defun std11-strip-quoted-string (string) + "Strip quoted-string STRING. [std11.el]" + (let ((len (length string))) + (or (and (>= len 2) + (let ((max (1- len))) + (and (eq (aref string 0) ?\") + (eq (aref string max) ?\") + (std11-strip-quoted-pair (substring string 1 max)) + ))) + string))) + + +;;; @ composer +;;; + +(defun std11-addr-to-string (seq) + "Return string from lexical analyzed list SEQ +represents addr-spec of RFC 822. [std11.el]" + (mapconcat (function + (lambda (token) + (if (let ((name (car token))) + (or (eq name 'spaces) + (eq name 'comment) + )) + "" + (cdr token) + ))) + seq "") + ) + +(defun std11-address-string (address) + "Return string of address part from parsed ADDRESS of RFC 822. +\[std11.el]" + (cond ((eq (car address) 'group) + (mapconcat (function std11-address-string) + (car (cdr address)) + ", ") + ) + ((eq (car address) 'mailbox) + (let ((addr (nth 1 address))) + (std11-addr-to-string + (if (eq (car addr) 'phrase-route-addr) + (nth 2 addr) + (cdr addr) + ) + ))))) + +(defun std11-full-name-string (address) + "Return string of full-name part from parsed ADDRESS of RFC 822. +\[std11.el]" + (cond ((eq (car address) 'group) + (mapconcat (function + (lambda (token) + (cdr token) + )) + (nth 1 address) "") + ) + ((eq (car address) 'mailbox) + (let ((addr (nth 1 address)) + (comment (nth 2 address)) + phrase) + (if (eq (car addr) 'phrase-route-addr) + (setq phrase (mapconcat (function + (lambda (token) + (cdr token) + )) + (nth 1 addr) "")) + ) + (or phrase comment) + )))) + + +;;; @ parser +;;; + +(defun std11-parse-address-string (string) + "Parse STRING as mail address. [std11.el]" + (std11-parse-address (std11-lexical-analyze string)) + ) + +(defun std11-parse-addresses-string (string) + "Parse STRING as mail address list. [std11.el]" + (std11-parse-addresses (std11-lexical-analyze string)) + ) + +(defun std11-extract-address-components (string) + "Extract full name and canonical address from STRING. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). +If no name can be extracted, FULL-NAME will be nil. [std11.el]" + (let* ((structure (car (std11-parse-address-string + (std11-unfold-string string)))) + (phrase (std11-full-name-string structure)) + (address (std11-address-string structure)) + ) + (list phrase address) + )) + +(provide 'std11) + +(mapcar (function + (lambda (func) + (autoload func "std11-parse") + )) + '(std11-lexical-analyze + std11-parse-address std11-parse-addresses + std11-parse-address-string)) + + +;;; @ end +;;; + +;;; std11.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/mu/tl-822.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mu/tl-822.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,99 @@ +;;; tl-822.el --- RFC 822 parser for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, RFC 822 + +;; 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 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. + +;;; Code: + +(require 'tl-seq) +(require 'tl-str) +(require 'std11) + + +(defconst rfc822/RCS-ID + "$Id: tl-822.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $") +(defconst rfc822/version (get-version-string rfc822/RCS-ID)) + + +;;; @ header +;;; + +(defalias 'rfc822/narrow-to-header 'std11-narrow-to-header) +(defalias 'rfc822/get-header-string 'std11-header-string) +(defalias 'rfc822/get-header-string-except 'std11-header-string-except) +(defalias 'rfc822/get-field-names 'std11-collect-field-names) + + +;;; @ field +;;; + +(defalias 'rfc822/field-end 'std11-field-end) +(defalias 'rfc822/get-field-body 'std11-field-body) +(defalias 'rfc822/get-field-bodies 'std11-field-bodies) + + +;;; @ quoting +;;; + +(defconst rfc822/quoted-pair-regexp "\\\\.") +(defconst rfc822/qtext-regexp + (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]")) +(defconst rfc822/quoted-string-regexp + (concat "\"" + (regexp-* + (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp) + ) + "\"")) + +(defalias 'rfc822/wrap-as-quoted-string 'std11-wrap-as-quoted-string) +(defalias 'rfc822/strip-quoted-string 'std11-strip-quoted-string) + + +;;; @ unfolding +;;; + +(defalias 'rfc822/unfolding-string 'std11-unfold-string) + + +;;; @ lexical analyze +;;; + +(defalias 'rfc822/lexical-analyze 'std11-lexical-analyze) + + +;;; @ parser +;;; + +(defalias 'rfc822/parse-address 'std11-parse-address) +(defalias 'rfc822/parse-addresses 'std11-parse-addresses) +(defalias 'rfc822/address-string 'std11-address-string) +(defalias 'rfc822/full-name-string 'std11-full-name-string) +(defalias 'rfc822/extract-address-components + 'std11-extract-address-components) + + +;;; @ end +;;; + +(provide 'tl-822) + +;;; tl-822.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/apropos.el --- a/lisp/packages/apropos.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/apropos.el Mon Aug 13 08:46:56 2007 +0200 @@ -66,22 +66,34 @@ "*Whether the apropos commands should do more. Slows them down more or less. Set this non-nil if you have a fast machine.") -(defvar apropos-symbol-face 'bold +;; XEmacs addition +(defvar apropos-symbol-face (if (boundp 'font-lock-keyword-face) + font-lock-keyword-face + 'bold) "*Face for symbol name in apropos output or `nil'. This looks good, but slows down the commands several times.") -(defvar apropos-keybinding-face 'underline +;; XEmacs addition +(defvar apropos-keybinding-face (if (boundp 'font-lock-string-face) + font-lock-string-face + 'underline) "*Face for keybinding display in apropos output or `nil'. This looks good, but slows down the commands several times.") -(defvar apropos-label-face 'italic +;; XEmacs addition +(defvar apropos-label-face (if (boundp 'font-lock-comment-face) + font-lock-comment-face + 'italic) "*Face for label (Command, Variable ...) in apropos output or `nil'. If this is `nil' no mouse highlighting occurs. This looks good, but slows down the commands several times. When this is a face name, as it is initially, it gets transformed to a text-property list for efficiency.") -(defvar apropos-property-face 'bold-italic +;; XEmacs addition +(defvar apropos-property-face (if (boundp 'font-lock-variable-name-face) + font-lock-variable-name-face + 'bold-italic) "*Face for property name in apropos output or `nil'. This looks good, but slows down the commands several times.") @@ -94,7 +106,7 @@ (let ((map (make-sparse-keymap))) (define-key map [(control m)] 'apropos-follow) (define-key map [(button2up)] 'apropos-mouse-follow) - (define-key map [(button2down)] 'undefined) + (define-key map [(button2)] 'undefined) map) "Keymap used in Apropos mode.") @@ -111,6 +123,8 @@ (defvar apropos-item () "Current item in or for apropos-accumulator.") +(defvar apropos-mode-hook nil) ; XEmacs + (defun apropos-mode () "Major mode for following hyperlinks in output of apropos commands. @@ -119,7 +133,8 @@ (kill-all-local-variables) (use-local-map apropos-mode-map) (setq major-mode 'apropos-mode - mode-name "Apropos")) + mode-name "Apropos") + (run-hooks 'apropos-mode-hook)) ; XEmacs ;; For auld lang syne: @@ -461,7 +476,8 @@ (sort apropos-accumulator (lambda (a b) (string-lessp (car a) (car b))))) (and apropos-label-face - (symbolp apropos-label-face) + (or (symbolp apropos-label-face) + (facep apropos-label-face)) ; XEMacs (setq apropos-label-face `(face ,apropos-label-face mouse-face highlight))) (with-output-to-temp-buffer "*Apropos*" @@ -629,4 +645,6 @@ (princ ")") (print-help-return-message))) +(provide 'apropos) ; XEmacs + ;;; apropos.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/autoinsert.el --- a/lisp/packages/autoinsert.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/autoinsert.el Mon Aug 13 08:46:56 2007 +0200 @@ -18,7 +18,8 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. ;;; Synched up with: FSF 19.34. @@ -134,19 +135,22 @@ ;; 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 +;; 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. +;; 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. +;; 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: @@ -155,6 +159,7 @@ ;;; Code: +(provide ' " (file-name-nondirectory (buffer-file-name)) ") ;;; " (file-name-nondirectory (buffer-file-name)) " ends here")) "A list specifying text to insert by default into a new file. @@ -251,4 +256,6 @@ (setq auto-insert-alist (cons (cons key action) auto-insert-alist)))))) +(provide 'autoinsert) + ;;; autoinsert.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/buff-menu.el --- a/lisp/packages/buff-menu.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/buff-menu.el Mon Aug 13 08:46:56 2007 +0200 @@ -3,6 +3,7 @@ ;; Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. ;; Maintainer: FSF +;; Keywords: extensions ;; This file is part of XEmacs. @@ -18,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30 except as noted. +;;; Synched up with: FSF 19.34 except as noted. ;;; Commentary: @@ -68,7 +70,7 @@ () (setq Buffer-menu-mode-map (make-keymap)) (suppress-keymap Buffer-menu-mode-map t) - (set-keymap-name Buffer-menu-mode-map 'Buffer-menu-mode-map) + (set-keymap-name Buffer-menu-mode-map 'Buffer-menu-mode-map) ; XEmacs (define-key Buffer-menu-mode-map "q" 'Buffer-menu-quit) (define-key Buffer-menu-mode-map "v" 'Buffer-menu-select) (define-key Buffer-menu-mode-map "2" 'Buffer-menu-2-window) @@ -94,8 +96,8 @@ (define-key Buffer-menu-mode-map "t" 'Buffer-menu-visit-tags-table) (define-key Buffer-menu-mode-map "%" 'Buffer-menu-toggle-read-only) (define-key Buffer-menu-mode-map "g" 'revert-buffer) - (define-key Buffer-menu-mode-map 'button2 'Buffer-menu-mouse-select) - (define-key Buffer-menu-mode-map 'button3 'Buffer-menu-popup-menu) + (define-key Buffer-menu-mode-map [mouse-2] 'Buffer-menu-mouse-select) + (define-key Buffer-menu-mode-map [mouse-3] 'Buffer-menu-popup-menu) ) ;; Buffer Menu mode is suitable only for specially formatted data. @@ -135,8 +137,8 @@ (setq revert-buffer-function 'Buffer-menu-revert-function) (setq truncate-lines t) (setq buffer-read-only t) - (make-local-variable 'mouse-track-click-hook) - (add-hook 'mouse-track-click-hook 'Buffer-menu-maybe-mouse-select) + (make-local-variable 'mouse-track-click-hook) ; XEmacs + (add-hook 'mouse-track-click-hook 'Buffer-menu-maybe-mouse-select) ; XEmacs (run-hooks 'buffer-menu-mode-hook)) (defun Buffer-menu-revert-function (ignore1 ignore2) @@ -252,7 +254,7 @@ (forward-line 1))) (defun Buffer-menu-save () - "Mark buffer on this line to be saved by \\[Buffer-menu-execute] command." + "Mark buffer on this line to be saved by \\\\[Buffer-menu-execute] command." (interactive) (beginning-of-line) (if (looking-at " [-M]") ;header lines @@ -365,6 +367,7 @@ (switch-to-buffer (Buffer-menu-buffer t)) (bury-buffer (other-buffer)) (delete-other-windows) + ;; XEmacs: ;; This is to get w->force_start set to nil. Don't ask me, I only work here. (set-window-buffer (selected-window) (current-buffer))) @@ -373,16 +376,17 @@ (interactive "e") (let (buffer) (save-excursion - (set-buffer (event-buffer event)) + (set-buffer (event-buffer event)) ; XEmacs (save-excursion - (goto-char (event-point event)) + (goto-char (event-point event)) ; XEmacs (setq buffer (Buffer-menu-buffer t)))) - (select-window (event-window event)) + (select-window (event-window event)) ; XEmacs (if (and (window-dedicated-p (selected-window)) (eq (selected-window) (frame-root-window))) (switch-to-buffer-other-frame buffer) (switch-to-buffer buffer)))) +;; XEmacs (defun Buffer-menu-maybe-mouse-select (event &optional click-count) (interactive "e") (and (>= click-count 2) @@ -442,6 +446,7 @@ (delete-char 1) (insert char)))))) +;; XEmacs (defvar Buffer-menu-popup-menu '("Buffer Commands" ["Select Buffer" Buffer-menu-select t] @@ -456,6 +461,7 @@ ["Delete/Save Marked Buffers" Buffer-menu-execute t] )) +;; XEmacs (defun Buffer-menu-popup-menu (event) (interactive "e") (mouse-set-point event) @@ -471,15 +477,18 @@ (error "no buffer on this line")))) +;; XEmacs (defvar list-buffers-header-line (purecopy (concat " MR Buffer Size Mode File\n" " -- ------ ---- ---- ----\n"))) +;; XEmacs (defvar list-buffers-identification 'default-list-buffers-identification "String used to identify this buffer, or a function of one argument to generate such a string. This variable is always buffer-local.") (make-variable-buffer-local 'list-buffers-identification) +;; XEmacs (defvar list-buffers-directory) (make-variable-buffer-local 'list-buffers-directory) @@ -581,6 +590,7 @@ (Buffer-menu-mode) (if (not (bufferp current)) (goto-char current))))) +;(define-key ctl-x-map "\C-b" 'list-buffers) (defun list-buffers (&optional files-only) "Display a list of names of existing buffers. @@ -590,7 +600,7 @@ The M column contains a * for buffers that are modified. The R column contains a % for buffers that are read-only." - (interactive (list (if current-prefix-arg t nil))) + (interactive (list (if current-prefix-arg t nil))) ; XEmacs (display-buffer (list-buffers-noselect files-only))) ;; #### not synched diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/column.el --- a/lisp/packages/column.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/column.el Mon Aug 13 08:46:56 2007 +0200 @@ -65,10 +65,14 @@ ;; Function updating the string containing the current column. (defvar update-column-function - (function (lambda () - (setq current-column (int-to-string (current-column))) - (setq current-line (int-to-string (current-line))) - (set-buffer-modified-p (buffer-modified-p))))) + (lambda () + (setq current-column + (int-to-string (if (and (boundp 'column-number-start-at-one) + column-number-start-at-one) + (1+ (current-column)) + (current-column)))) + (setq current-line (int-to-string (current-line))) + (set-buffer-modified-p (buffer-modified-p)))) (defvar display-column-mode nil "Show current column and line in mode line if non-nil.") diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/compile.el --- a/lisp/packages/compile.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/compile.el Mon Aug 13 08:46:56 2007 +0200 @@ -210,10 +210,10 @@ ;; jwz: ;; IRIX 5.2 ;; cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ... - (" \\([^ \n,]+\\), line \\([0-9]+\\):" 1 2) + (" \\([^ \n,\"]+\\), line \\([0-9]+\\):" 1 2) ;; IRIX 5.2 ;; cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ... - (": \\([^ \n,]+\\): \\([0-9]+\\):" 1 2) + (": \\([^ \n,\"]+\\): \\([0-9]+\\):" 1 2) ;; Cray C compiler error messages ("\n\\(cc\\| cft\\)-[0-9]+ c\\(c\\|f77\\): ERROR \\([^,\n]+, \\)* File = \\([^,\n]+\\), Line = \\([0-9]+\\)" 4 5) diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/fontl-hooks.el --- a/lisp/packages/fontl-hooks.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/fontl-hooks.el Mon Aug 13 08:46:56 2007 +0200 @@ -18,7 +18,8 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. ;;; Synched up with: FSF 19.30. (font-lock.el) @@ -81,3 +82,6 @@ font-lock-keywords) (turn-on-font-lock))))) +(provide 'fontl-hooks) + +;;; fontl-hooks.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/icomplete.el --- a/lisp/packages/icomplete.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/icomplete.el Mon Aug 13 08:46:56 2007 +0200 @@ -4,7 +4,7 @@ ;;; Author: Ken Manheimer ;;; Maintainer: Ken Manheimer -;;; Version: $Id: icomplete.el,v 1.1.1.2 1996/12/18 03:44:58 steve Exp $ +;;; Version: $Id: icomplete.el,v 1.1.1.3 1996/12/18 03:53:27 steve Exp $ ;;; Created: Mar 1993 klm@nist.gov - first release to usenet ;;; Keywords: help, abbrev @@ -91,6 +91,9 @@ will constrain rsz-mini to a maximum minibuffer height of 3 lines when icompletion is occurring.") +(if (string-match "XEmacs\\|Lucid" emacs-version) + (add-hook 'icomplete-minibuffer-setup-hook 'icomplete-exhibit)) + ;;;_ + Internal Variables ;;;_ = icomplete-mode (defvar icomplete-mode t @@ -273,7 +276,7 @@ " [Matched]" ;; XEmacs (if (and icomplete-show-key-bindings - (commandp (car comps))) + (commandp (intern-soft (car comps)))) (icomplete-get-keys (car comps)) "") )) diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/jwz-man.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/packages/jwz-man.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,529 @@ +;;; man.el --- browse UNIX manual pages +;; Keywords: help + +;; Copyright (C) 1985, 1993, 1994, 1996 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. + +;; This file defines "manual-entry", and the remaining definitions all +;; begin with "Manual-". This makes the autocompletion on "M-x man" work. +;; +;; Eviscerated 26-Jun-96 by Jamie Zawinski . +;; All that stuff about looking at $MANPATH and building up lists of +;; directories was bullshit. Now we just invoke "man" and format the +;; output, end of story. +;; +;; [ older changelog entries removed, since they're all about code that +;; I've deleted. ] + +(defvar Manual-program "man" "\ +*Name of the program to invoke in order to format the source man pages.") + +(defvar Manual-buffer-view-mode t "\ +*Whether manual buffers should be placed in view-mode. +nil means leave the buffer in fundamental-mode in another window. +t means use `view-buffer' to display the man page in the current window. +Any other value means use `view-buffer-other-window'.") + +(defvar Manual-mode-hook nil + "Function or functions run on entry to Manual-mode.") + +(defvar Manual-page-history nil "\ +A list of names of previously visited man page buffers.") + + +;; New variables. + +(make-face 'man-italic) +(or (face-differs-from-default-p 'man-italic) + (copy-face 'italic 'man-italic)) +;; XEmacs (from Darrell Kindred): underlining is annoying due to +;; large blank spaces in this face. +;; (or (face-differs-from-default-p 'man-italic) +;; (set-face-underline-p 'man-italic t)) + +(make-face 'man-bold) +(or (face-differs-from-default-p 'man-bold) + (copy-face 'bold 'man-bold)) +(or (face-differs-from-default-p 'man-bold) + (copy-face 'man-italic 'man-bold)) + +(make-face 'man-heading) +(or (face-differs-from-default-p 'man-heading) + (copy-face 'man-bold 'man-heading)) + +(make-face 'man-xref) +(or (face-differs-from-default-p 'man-xref) + (set-face-underline-p 'man-xref t)) + +(defvar Manual-mode-map + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'Manual-mode-map) + (define-key m "l" 'Manual-last-page) + (define-key m 'button2 'Manual-follow-xref) + (define-key m 'button3 'Manual-popup-menu) + m)) + +;;;###autoload +(defun manual-entry (topic &optional arg silent) + "Display the Unix manual entry (or entries) for TOPIC." + (interactive + (list (let* ((fmh "-A-Za-z0-9_.") + (default (save-excursion + (buffer-substring + (progn + (re-search-backward "\\sw" nil t) + (skip-chars-backward fmh) (point)) + (progn (skip-chars-forward fmh) (point))))) + (thing (read-string + (if (equal default "") "Manual entry: " + (concat "Manual entry: (default " default ") "))))) + (if (equal thing "") default thing)) + (prefix-numeric-value current-prefix-arg))) + ;;(interactive "sManual entry (topic): \np") + (or arg (setq arg 1)) + (let (section apropos-mode) + (let ((case-fold-search nil)) + (if (and (null section) + (string-match "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" + topic)) + (setq section (substring topic (match-beginning 2) + (match-end 2)) + topic (substring topic (match-beginning 1) + (match-end 1))) + (if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic) + (setq section "-k" + topic (substring topic (match-beginning 1)))))) + + ;; jwz: turn section "3x11" and "3n" into "3". + (if (and section (string-match "\\`\\([0-9]+\\)[^0-9]" section)) + (setq section (substring section 0 (match-end 1)))) + (if (equal section "-k") + (setq apropos-mode t)) + + (let ((bufname (cond (apropos-mode + (concat "*man apropos " topic "*")) + (t + (concat "*man " topic + (if 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)) + (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) + + (let ((args (list topic)) + args-string) + (if section + (setq args + (if (eq system-type 'usg-unix-v) + (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 args) + + (if (< (buffer-size) 200) + (progn + (goto-char (point-min)) + (error (buffer-substring (point) + (progn (end-of-line) + (point)))))) + + (message "%s (cleaning...)" args-string) + (Manual-nuke-nroff-bs apropos-mode) + (message "%s (done.)" args-string) + ) + + (set-buffer-modified-p nil) + (Manual-mode) + )))) + (setq Manual-page-history + (cons (buffer-name) + (delete (buffer-name) Manual-page-history))))) + (message nil) + t) + +(defun Manual-mode () + (kill-all-local-variables) + (setq buffer-read-only t) + (use-local-map Manual-mode-map) + (setq major-mode 'Manual-mode + mode-name "Manual") + ;; man pages with long lines are buggy! + ;; This looks slightly better if they only + ;; overran by a couple of chars. + (setq truncate-lines t) + ;; turn off horizontal scrollbars in this buffer + (set-specifier scrollbar-height (cons (current-buffer) 0)) + (run-hooks 'Manual-mode-hook)) + +(defun Manual-last-page () + (interactive) + (while (or (not (get-buffer (car (or Manual-page-history + (error "No more history."))))) + (eq (get-buffer (car Manual-page-history)) (current-buffer))) + (setq Manual-page-history (cdr Manual-page-history))) + (switch-to-buffer (car Manual-page-history))) + + +(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.) + (list 'delete-region '(point) (list '+ '(point) n))) + +;; Hint: BS stands form more things than "back space" +(defun Manual-nuke-nroff-bs (&optional apropos-mode) + (interactive "*") + ;; + ;; turn underlining into italics + ;; + (goto-char (point-min)) + (while (search-forward "_\b" nil t) + ;; searching for underscore-backspace and then comparing the following + ;; chars until the sequence ends turns out to be much faster than searching + ;; for a regexp which matches the whole sequence. + (let ((s (match-beginning 0))) + (goto-char s) + (while (and (= (following-char) ?_) + (= (char-after (1+ (point))) ?\b)) + (Manual-delete-char 2) + (forward-char 1)) + (set-extent-face (make-extent s (point)) 'man-italic))) + ;; + ;; turn overstriking into bold + ;; + (goto-char (point-min)) + (while (re-search-forward "\\([^\n]\\)\\(\b\\1\\)" nil t) + ;; Surprisingly, searching for the above regexp is faster than searching + ;; for a backspace and then comparing the preceding and following chars, + ;; I presume because there are many false matches, meaning more funcalls + ;; to re-search-forward. + (let ((s (match-beginning 0))) + (goto-char s) + ;; Some systems (SGI) overstrike multiple times, eg, "M\bM\bM\bM". + (while (looking-at "\\([^\n]\\)\\(\b\\1\\)+") + (delete-region (+ (point) 1) (match-end 0)) + (forward-char 1)) + (set-extent-face (make-extent s (point)) 'man-bold))) + ;; + ;; hack bullets: o^H+ --> + + (goto-char (point-min)) + (while (search-forward "\b" nil t) + (Manual-delete-char -2)) + + (if (> (buffer-size) 100) ; minor kludge + (Manual-nuke-nroff-bs-footers)) + ;; + ;; turn subsection header lines into bold + ;; + (goto-char (point-min)) + (if apropos-mode + (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t) + (forward-char -2) + (delete-backward-char 1)) + + ;; (while (re-search-forward "^[^ \t\n]" nil t) + ;; (set-extent-face (make-extent (match-beginning 0) + ;; (progn (end-of-line) (point))) + ;; 'man-heading)) + + ;; boldface the first line + (if (looking-at "[^ \t\n].*$") + (set-extent-face (make-extent (match-beginning 0) (match-end 0)) + 'man-bold)) + + ;; boldface subsequent title lines + ;; 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 + (while (re-search-forward "\n\n\\([^ \t\n].*\\)\n[ \t]+[^ \t\n]" nil t) + (goto-char (match-end 1)) + (set-extent-face (make-extent (match-beginning 1) (match-end 1)) + 'man-heading) + (forward-line 1)) + ) + + ;; 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 "")) + + ;; Nuke blanks lines at start. + ;; (goto-char (point-min)) + ;; (skip-chars-forward "\n") + ;; (delete-region (point-min) (point)) + + (Manual-mouseify-xrefs) + ) + +(fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name + + +(defun Manual-nuke-nroff-bs-footers () + ;; Nuke headers and footers. + ;; + ;; nroff assumes pages are 66 lines high. We assume that, and that the + ;; first and last line on each page is expendible. There is no way to + ;; tell the difference between a page break in the middle of a paragraph + ;; and a page break between paragraphs (the amount of extra whitespace + ;; that nroff inserts is the same in both cases) so this might strip out + ;; a blank line were one should remain. I think that's better than + ;; leaving in a blank line where there shouldn't be one. (Need I say + ;; it: FMH.) + ;; + ;; Note that if nroff spits out error messages, pages will be more than + ;; 66 lines high, and we'll lose badly. 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.) + ;; + (goto-char (point-min)) + ;; first lose the status output + (let ((case-fold-search t)) + (if (and (not (looking-at "[^\n]*warning")) + (looking-at "Reformatting.*\n")) + (delete-region (match-beginning 0) (match-end 0)))) + + ;; kludge around a groff bug where it won't keep quiet about some + ;; warnings even with -Wall or -Ww. + (cond ((looking-at "grotty:") + (while (looking-at "grotty:") + (delete-region (point) (progn (forward-line 1) (point)))) + (if (looking-at " *done\n") + (delete-region (point) (match-end 0))))) + + (let ((pages '()) + p) + ;; collect the page boundary markers before we start deleting, to make + ;; it easier to strip things out without changing the page sizes. + (while (not (eobp)) + (forward-line 66) + (setq pages (cons (point-marker) pages))) + (setq pages (nreverse pages)) + (while pages + (goto-char (car pages)) + (set-marker (car pages) nil) + ;; + ;; The lines are: 3 blank; footer; 6 blank; header; 3 blank. + ;; We're in between the previous footer and the following header, + ;; + ;; First lose 3 blank lines, the header, and then 3 more. + ;; + (setq p (point)) + (skip-chars-forward "\n") + (delete-region p (point)) + (and (looking-at "[^\n]+\n\n?\n?\n?") + (delete-region (match-beginning 0) (match-end 0))) + ;; + ;; Next lose the footer, and the 3 blank lines after, and before it. + ;; But don't lose the last footer of the manual entry; that contains + ;; the "last change" date, so it's not completely uninteresting. + ;; (Actually lose all blank lines before it; sh(1) needs this.) + ;; + (skip-chars-backward "\n") + (beginning-of-line) + (if (null (cdr pages)) + nil + (and (looking-at "[^\n]+\n\n?\n?\n?") + (delete-region (match-beginning 0) (match-end 0)))) + (setq p (point)) + (skip-chars-backward "\n") + (if (> (- p (point)) 4) + (delete-region (+ 2 (point)) p) + (delete-region (1+ (point)) p)) +; (and (looking-at "\n\n?\n?") +; (delete-region (match-beginning 0) (match-end 0))) + + (setq pages (cdr pages))) + ;; + ;; Now nuke the extra blank lines at the beginning and end. + (goto-char (point-min)) + (if (looking-at "\n+") + (delete-region (match-beginning 0) (match-end 0))) + (forward-line 1) + (if (looking-at "\n\n+") + (delete-region (1+ (match-beginning 0)) (match-end 0))) + (goto-char (point-max)) + (skip-chars-backward "\n") + (delete-region (point) (point-max)) + (beginning-of-line) + (forward-char -1) + (setq p (point)) + (skip-chars-backward "\n") + (if (= ?\n (following-char)) (forward-char 1)) + (if (> (point) (1+ p)) + (delete-region (point) p)) + )) + +(defun Manual-mouseify-xrefs () + (goto-char (point-min)) + (forward-line 1) + (let ((case-fold-search nil) + s e name 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) + (setq s (match-beginning 0) + e (match-end 0) + name (buffer-substring s e)) + (goto-char s) + (skip-chars-backward " \t") + (if (and (bolp) + (progn (backward-char 1) (= (preceding-char) ?-))) + (progn + (setq s (point)) + (skip-chars-backward "-a-zA-Z0-9_.") + (setq name (concat (buffer-substring (point) (1- s)) name)) + (setq s (point)))) + ;; 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)))))) + ;; (setq already-fontified (extent-at s)) + (setq extent (make-extent s e)) + (set-extent-property extent 'man (list 'Manual-follow-xref name)) + (set-extent-property extent 'highlight t) + ;; (if (not already-fontified)... + (set-extent-face extent 'man-xref) + (goto-char e)))) + +(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") + (if (eventp name-or-event) + (let* ((p (event-point name-or-event)) + (extent (and p (extent-at p + (event-buffer name-or-event) + 'highlight))) + (data (and extent (extent-property extent 'man)))) + (if (eq (car-safe data) 'Manual-follow-xref) + (eval 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)))))) + +(defun Manual-popup-menu (&optional event) + "Pops 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." + (interactive "e") + (let ((buffer (current-buffer)) + (sep "---") + (prefix "Show Manual Page for ") + 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))) + (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 nil)) + (popup-menu + (cons "Manual Entry" + (mapcar #'(lambda (item) + (if (eq item sep) + item + (vector (concat prefix item) + (list 'Manual-follow-xref item) t))) + (nreverse items))))))) + +(defun pager-cleanup-hook () + "cleanup man page if called via $PAGER" + (let ((buf-name (or buffer-file-name (buffer-name)))) + (if (or (string-match "^/tmp/man[0-9]+" buf-name) + (string-match ".*/man/\\(man\\|cat\\)[1-9a-z]/" buf-name)) + (let (buffer manpage) + (require 'man) + (goto-char (point-min)) + (setq buffer-read-only nil) + (Manual-nuke-nroff-bs) + (goto-char (point-min)) + (if (re-search-forward "[^ \t]") + (goto-char (- (point) 1))) + (if (looking-at "\\([a-zA-Z0-9]+\\)[ \t]*(") + (setq manpage (buffer-substring (match-beginning 1) + (match-end 1))) + (setq manpage "???")) + (setq buffer + (rename-buffer + (generate-new-buffer-name (concat "*man " manpage "*")))) + (setq buffer-file-name nil) + (goto-char (point-min)) + (insert (format "%s\n" buf-name)) + (goto-char (point-min)) + (buffer-disable-undo buffer) + (set-buffer-modified-p nil) + (Manual-mode) + )))) + +(add-hook 'server-visit-hook 'pager-cleanup-hook) +(provide 'man) + +;;; man.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/man-xref.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/packages/man-xref.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,166 @@ +;;; man-xref.el --- cross reference selection functions for man mode + +;; Author: Mark Hood +;; @(#)man-xref.el 1.15 + +;; 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.35. + +;;; Commentary: + +;; This package is an add-on to the man.el that comes with Emacs +;; 19.34. It renders manpage cross references in bold, sets them up +;; for mouse highlighting, and allows selection via keystrokes or +;; mouse. All strings matching Man-reference-regexp in the text of +;; the man page are set up, in addition to the ones in the See Also +;; section. + +;; To use this package, put something like the following in your Emacs +;; initialization file. This example causes tab and M-tab to go to +;; the next and previous manual cross references, causes carriage +;; return to display a man page for the reference under point, and +;; allows mouse button 2 to invoke a man page display. + +;; (add-hook 'Man-mode-hook +;; '(lambda () +;; (Man-mouseify-xrefs) +;; (define-key Man-mode-map "\r" 'Man-do-manual-reference) +;; (define-key Man-mode-map "\t" 'Man-next-manual-reference) +;; (define-key Man-mode-map "\e\t" 'Man-prev-manual-reference) +;; (define-key Man-mode-map [mouse-2] 'Man-mouse-manual-reference) +;; )) +;; +;; (autoload 'Man-mouseify-xrefs "~/emacs/man-xref") + +(eval-when-compile (require 'cl)) + +(defvar Man-word-syntax "w_()" "Syntax for words in a man buffer.") + +(defun Man-current-word () + "Return word under point, using `Man-word-syntax' for word syntax." + (save-excursion + (let ((s (+ (point) (skip-syntax-backward Man-word-syntax)))) + (skip-syntax-forward Man-word-syntax) + (buffer-substring s (point))))) + +(defun Man-prev-word-hyphen-p () + "Return nil if previous word is not hyphenated. +Non-nil value is the buffer position of the beginning of the hyphenated word." + (save-excursion + (skip-syntax-backward Man-word-syntax) + (skip-chars-backward " \t") + (cond ((and (> (point) (1+ (point-min))) + (string-equal "-\n" (buffer-substring (- (point) 2) (point)))) + (backward-char) + (skip-syntax-backward Man-word-syntax) + (point))))) + +(defun Man-next-manual-reference () + "Move point to the beginning of the next manual reference." + (interactive) + (let ((current (point)) + (end (re-search-forward (concat "[ \t]" Man-reference-regexp) nil t)) + (start (or (Man-prev-word-hyphen-p) (1+ (match-beginning 0))))) + (cond ((eq end nil)) + ((> start current) + (goto-char start)) + ;; current is in the pre-hyphen portion of a hyphenated reference + ((re-search-forward Man-reference-regexp nil t) + (goto-char (or (Man-prev-word-hyphen-p) (match-beginning 0)))) + ((goto-char current))))) + +(defun Man-prev-manual-reference () + "Move point to the beginning of the previous manual reference." + (interactive) + (if (re-search-backward (concat "[ \t]" Man-reference-regexp) nil t) + (goto-char (or (Man-prev-word-hyphen-p) (1+ (match-beginning 0)))))) + +(defun Man-mouseify-xrefs () + "Render man cross references in bold font and set up mouse highlighting. +Add these cross references to `Man-refpages-alist'." + (let (start end xref hyphen alist) + (goto-char (point-min)) + (forward-line 1) + (while (re-search-forward Man-reference-regexp nil t) + (setq start (match-beginning 0)) + (setq end (match-end 0)) + (setq xref (buffer-substring start end)) + (cond ((setq hyphen (Man-prev-word-hyphen-p)) + (setq start hyphen) + (goto-char hyphen) + (setq xref (concat (substring (Man-current-word) 0 -1) xref)) + (goto-char end))) + (setq Man-refpages-alist (cons (list xref) Man-refpages-alist)) + (Man-boldify-mouse-region start end)) + (setq Man-refpages-alist + (sort Man-refpages-alist + (function (lambda (a b) (string< (car a) (car b)))))) + ;; delete duplicate entries in the alist + (setq alist Man-refpages-alist) + (while alist + (cond ((string= (car (car alist)) (car (car (cdr alist)))) + (setcdr alist (cdr (cdr alist)))) + ((setq alist (cdr alist))))) + (goto-char (point-min)) + (forward-line 1))) + +(defun Man-mouse-manual-reference (mouse) + "Move point to mouse position and run `Man-getpage-in-background' there." + (interactive "e") + (select-window (car (car (cdr mouse)))) + (goto-char (car (cdr (car (cdr mouse))))) + (Man-do-manual-reference)) + +(defun Man-do-manual-reference () + "Run `Man-getpage-in-background' on cross reference under point. +Word under point is checked for a match with `Man-reference-regexp'. +If point is not over a word, try to use previous word for a match." + (interactive) + (save-excursion + (let ((xref (Man-current-word)) (hyphen (Man-prev-word-hyphen-p))) + (if (and (zerop (length xref)) + (setq xref " ") + (skip-syntax-backward " ") + (not (eq (point) (point-min)))) + (Man-do-manual-reference) + (cond ((string-equal "-" (substring xref -1)) + (skip-syntax-forward Man-word-syntax) + (skip-syntax-forward " ") + (setq xref (concat (substring xref 0 -1) (Man-current-word)))) + (hyphen + (goto-char hyphen) + (setq xref (concat (substring (Man-current-word) 0 -1) xref)))) + (if (string-match Man-reference-regexp xref) + (Man-getpage-in-background + (Man-translate-references + (substring xref (match-beginning 0) (match-end 0)))) + (message "No cross reference found under point.")))))) + +(eval-and-compile + (when (string-match "XEmacs\\|Lucid" emacs-version) + (fset 'make-overlay 'make-extent) + (fset 'overlay-put 'set-extent-property))) + +(defun Man-boldify-mouse-region (beg end) + "Render region text in bold with mouse highlighting." + (let ((overlay (make-overlay beg end))) + (overlay-put overlay 'face 'bold) + (overlay-put overlay 'mouse-face 'highlight) + (overlay-put overlay 'hilit t))) + diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/man.el --- a/lisp/packages/man.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/packages/man.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,8 +1,11 @@ ;;; man.el --- browse UNIX manual pages -;; Keywords: help + +;; Copyright (C) 1993, 1994, 1996 Free Software Foundation, Inc. -;; Copyright (C) 1985, 1993, 1994 Free Software Foundation, Inc. -;; +;; Author: Barry A. Warsaw +;; Keywords: help +;; Adapted-By: ESR, pot + ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify it @@ -17,1209 +20,1045 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: Not synched with FSF. -;;; ICK! This file is almost completely different from FSF. -;;; Someone clarify please. +;;; Synched up with: FSF 19.34. -;; Mostly rewritten by Alan K. Stebbens 11-apr-90. -;; -;; o Match multiple man pages using TOPIC as a simple pattern -;; o Search unformatted pages, even when formatted matches are found -;; o Query the user as to which pages are desired -;; o Use of the prefix arg to toggle/bypass the above features -;; o Buffers named by the first topic in the buffer -;; o Automatic uncompress for compressed man pages (.Z, .z, and .gz) -;; o View the resulting buffer using M-x view mode -;; -;; Modified 16-mar-91 by Jamie Zawinski to default the -;; manual topic to the symbol at point, just like find-tag does. -;; -;; Modified 22-mar-93 by jwz to use multiple fonts and follow xrefs with mouse. -;; -;; Modified 16-apr-93 by Dave Gillespie to make -;; apropos work nicely; work correctly when bold or italic is unavailable; -;; reuse old buffer if topic is re-selected (in Manual-topic-buffer mode). -;; -;; Modified 4-apr-94 by jwz: merged in Tibor Polgar's code for manpath.conf. -;; -;; Modified 19-apr-94 by Tibor Polgar to add support for -;; $PAGER variable to be emacsclient and properly process man pages (assuming -;; the man pages were built by man in /tmp. also fixed bug with man list being -;; backwards. -;; -;; Modified 23-aug-94 by Tibor Polgar to add support for -;; displaying only one instance of a man page (Manual-unique-man-sections-only) -;; Fixed some more man page ordering bugs, bug with Manual-query-multiple-pages. -;; -;; Modified 29-nov-94 by Ben Wing : small fixes -;; that should hopefully make things work under HPUX and IRIX.; +;;; Commentary: + +;; This code provides a function, `man', with which you can browse +;; UNIX manual pages. Formatting is done in background so that you +;; can continue to use your Emacs while processing is going on. ;; -;; Modified 15-jul-95 by Dale Atems : -;; some extensive rewriting to make things work right (more or less) -;; under IRIX. -;; -;; Modified 08-mar-96 by Hubert Palme : -;; added /usr/share/catman to the manual directory list for IRIX (5.3) -;; -;; This file defines "manual-entry", and the remaining definitions all -;; begin with "Manual-". This makes the autocompletion on "M-x man" work. -;; -;; Variables of interest: -;; -;; Manual-program -;; Manual-topic-buffer -;; Manual-buffer-view-mode -;; Manual-directory-list -;; Manual-formatted-directory-list -;; Manual-match-topic-exactly -;; Manual-query-multiple-pages -;; Manual-page-history -;; Manual-subdirectory-list -;; Manual-man-page-section-ids -;; Manual-formatted-page-prefix -;; Manual-unformatted-page-prefix -;; Manual-use-full-section-ids +;; The mode also supports hypertext-like following of manual page SEE +;; ALSO references, and other features. See below or do `?' in a +;; manual page buffer for details. + +;; ========== Credits and History ========== +;; In mid 1991, several people posted some interesting improvements to +;; man.el from the standard emacs 18.57 distribution. I liked many of +;; these, but wanted everything in one single package, so I decided +;; to incorporate them into a single manual browsing mode. While +;; much of the code here has been rewritten, and some features added, +;; these folks deserve lots of credit for providing the initial +;; excellent packages on which this one is based. + +;; Nick Duffek , posted a very nice +;; improvement which retrieved and cleaned the manpages in a +;; background process, and which correctly deciphered such options as +;; man -k. + +;; Eric Rose , submitted manual.el which +;; provided a very nice manual browsing mode. + +;; This package was available as `superman.el' from the LCD package +;; for some time before it was accepted into Emacs 19. The entry +;; point and some other names have been changed to make it a drop-in +;; replacement for the old man.el package. + +;; Francesco Potorti` cleaned it up thoroughly, +;; making it faster, more robust and more tolerant of different +;; systems' man idiosyncrasies. + +;; ========== Features ========== +;; + Runs "man" in the background and pipes the results through a +;; series of sed and awk scripts so that all retrieving and cleaning +;; is done in the background. The cleaning commands are configurable. +;; + Syntax is the same as Un*x man +;; + Functionality is the same as Un*x man, including "man -k" and +;; "man
", etc. +;; + Provides a manual browsing mode with keybindings for traversing +;; the sections of a manpage, following references in the SEE ALSO +;; section, and more. +;; + Multiple manpages created with the same man command are put into +;; a narrowed buffer circular list. -(defvar Manual-program "man" "\ -*Name of the program to invoke in order to format the source man pages.") +;; ============= TODO =========== +;; - Add a command for printing. +;; - The awk script deletes multiple blank lines. This behaviour does +;; not allow to understand if there was indeed a blank line at the +;; end or beginning of a page (after the header, or before the +;; footer). A different algorithm should be used. It is easy to +;; compute how many blank lines there are before and after the page +;; headers, and after the page footer. But it is possible to compute +;; the number of blank lines before the page footer by euristhics +;; only. Is it worth doing? +;; - Allow a user option to mean that all the manpages should go in +;; the same buffer, where they can be browsed with M-n and M-p. +;; - Allow completion on the manpage name when calling man. This +;; requires a reliable list of places where manpages can be found. The +;; drawback would be that if the list is not complete, the user might +;; be led to believe that the manpages in the missing directories do +;; not exist. -(defvar Manual-section-switch (if (eq system-type 'usg-unix-v) "-s" nil) - "SysV needs this to work right.") + +;;; Code: + +(require 'assoc) + +;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +;; empty defvars (keep the compiler quiet) -(defvar Manual-topic-buffer t "\ -*Non-nil means \\[Manual-entry] should output the manual entry for TOPIC into -a buffer named *man TOPIC*, otherwise, it should name the buffer -*Manual Entry*.") +(defvar Man-notify) +(defvar Man-current-page) +(defvar Man-page-list) +(defvar Man-filter-list nil + "*Manpage cleaning filter command phrases. +This variable contains a list of the following form: + +'((command-string phrase-string*)*) + +Each phrase-string is concatenated onto the command-string to form a +command filter. The (standard) output (and standard error) of the Un*x +man command is piped through each command filter in the order the +commands appear in the association list. The final output is placed in +the manpage buffer.") -(defvar Manual-buffer-view-mode t "\ -*Whether manual buffers should be placed in view-mode. -nil means leave the buffer in fundamental-mode in another window. -t means use `view-buffer' to display the man page in the current window. -Any other value means use `view-buffer-other-window'.") +(defvar Man-original-frame) +(defvar Man-arguments) +(defvar Man-sections-alist) +(defvar Man-refpages-alist) +(defvar Man-uses-untabify-flag t + "When non-nil use `untabify' instead of Man-untabify-command.") +(defvar Man-page-mode-string) +(defvar Man-sed-script nil + "Script for sed to nuke backspaces and ANSI codes from manpages.") + +;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +;; user variables + +(defvar Man-fontify-manpage-flag t + "*Make up the manpage with fonts.") + +(defvar Man-overstrike-face 'bold + "*Face to use when fontifying overstrike.") -(defvar Manual-match-topic-exactly t "\ -*Non-nil means that \\[manual-entry] will match the given TOPIC exactly, rather -apply it as a pattern. When this is nil, and \"Manual-query-multiple-pages\" -is non-nil, then \\[manual-entry] will query you for all matching TOPICs. -This variable only has affect on the preformatted man pages (the \"cat\" files), -since the \"man\" command always does exact topic matches.") +(defvar Man-underline-face 'underline + "*Face to use when fontifying underlining.") + +;; Use the value of the obsolete user option Man-notify, if set. +(defvar Man-notify-method (if (boundp 'Man-notify) Man-notify 'friendly) + "*Selects the behavior when manpage is ready. +This variable may have one of the following values, where (sf) means +that the frames are switched, so the manpage is displayed in the frame +where the man command was called from: -(defvar Manual-query-multiple-pages nil "\ -*Non-nil means that \\[manual-entry] will query the user about multiple man -pages which match the given topic. The query is done using the function -\"y-or-n-p\". If this variable is nil, all man pages with topics matching the -topic given to \\[manual-entry] will be inserted into the temporary buffer. -See the variable \"Manual-match-topic-exactly\" to control the matching.") +newframe -- put the manpage in its own frame (see `Man-frame-parameters') +pushy -- make the manpage the current buffer in the current window +bully -- make the manpage the current buffer and only window (sf) +aggressive -- make the manpage the current buffer in the other window (sf) +friendly -- display manpage in the other window but don't make current (sf) +polite -- don't display manpage, but prints message and beep when ready +quiet -- like `polite', but don't beep +meek -- make no indication that the manpage is ready + +Any other value of `Man-notify-method' is equivalent to `meek'.") + +(defvar Man-frame-parameters nil + "*Frame parameter list for creating a new frame for a manual page.") -(defvar Manual-unique-man-sections-only nil - "*Only present one man page per section. This variable is useful if the same or -up/down level man pages for the same entry are present in mulitple man paths. -When set to t, only the first entry found in a section is displayed, the others -are ignored without any messages or warnings. Note that duplicates can occur if -the system has both formatted and unformatted version of the same page.") +(defvar Man-downcase-section-letters-flag t + "*Letters in sections are converted to lower case. +Some Un*x man commands can't handle uppercase letters in sections, for +example \"man 2V chmod\", but they are often displayed in the manpage +with the upper case letter. When this variable is t, the section +letter (e.g., \"2V\") is converted to lowercase (e.g., \"2v\") before +being sent to the man background process.") -(defvar Manual-mode-hook nil - "Function or functions run on entry to Manual-mode.") +(defvar Man-circular-pages-flag t + "*If t, the manpage list is treated as circular for traversal.") -(defvar Manual-directory-list nil "\ -*A list of directories used with the \"man\" command, where each directory -contains a set of \"man?\" and \"cat?\" subdirectories. If this variable is nil, -it is initialized by \\[Manual-directory-list-init].") +(defvar Man-section-translations-alist + (list + '("3C++" . "3") + ;; Some systems have a real 3x man section, so let's comment this. + ;; '("3X" . "3") ; Xlib man pages + '("3X11" . "3") + '("1-UCB" . "")) + "*Association list of bogus sections to real section numbers. +Some manpages (e.g. the Sun C++ 2.1 manpages) have section numbers in +their references which Un*x `man' does not recognize. This +association list is used to translate those sections, when found, to +the associated section number.") -(defvar Manual-formatted-directory-list nil "\ -A list of directories containing formatted man pages. Initialized by -\\[Manual-directory-list-init].") +(defvar manual-program "man" + "The name of the program that produces man pages.") -(defvar Manual-unformatted-directory-list nil "\ -A list of directories containing the unformatted (source) man pages. -Initialized by \\[Manual-directory-list-init].") +(defvar Man-untabify-command "pr" + "Command used for untabifying.") -(defvar Manual-page-history nil "\ -A list of names of previously visited man page buffers.") +(defvar Man-untabify-command-args (list "-t" "-e") + "List of arguments to be passed to Man-untabify-command (which see).") -(defvar Manual-manpath-config-file "/usr/lib/manpath.config" - "*Location of the manpath.config file, if any.") +(defvar Man-sed-command "sed" + "Command used for processing sed scripts.") -(defvar Manual-apropos-switch "-k" - "*Man apropos switch") - -;; New variables. +(defvar Man-awk-command "awk" + "Command used for processing awk scripts.") -(defvar Manual-subdirectory-list nil "\ -A list of all the subdirectories in which man pages may be found. -Iniialized by Manual-directory-list-init.") +(defvar Man-mode-line-format + '("" mode-line-modified + mode-line-buffer-identification " " + global-mode-string + " " Man-page-mode-string + " %[(" mode-name mode-line-process minor-mode-alist ")%]----" + (-3 . "%p") "-%-") + "Mode line format for manual mode buffer.") -;; This is for SGI systems; don't know what it should be otherwise. -(defvar Manual-man-page-section-ids "1nl6823457poD" "\ -String containing all suffix characters for \"cat\" and \"man\" -that identify valid sections of the Un*x manual.") +(defvar Man-mode-map nil + "Keymap for Man mode.") + +(defvar Man-mode-hook nil + "Hook run when Man mode is enabled.") -(defvar Manual-formatted-page-prefix "cat" "\ -Prefix for directories where formatted man pages are to be found. -Defaults to \"cat\".") +(defvar Man-cooked-hook nil + "Hook run after removing backspaces but before Man-mode processing.") + +(defvar Man-name-regexp "[-a-zA-Z0-9_][-a-zA-Z0-9_.]*" + "Regular expression describing the name of a manpage (without section).") -(defvar Manual-unformatted-page-prefix "man" "\ -Prefix for directories where unformatted man pages are to be found. -Defaults to \"man\".") +(defvar Man-section-regexp "[0-9][a-zA-Z+]*\\|[LNln]" + "Regular expression describing a manpage section within parentheses.") -(defvar Manual-leaf-signature "" "\ -Regexp for identifying \"leaf\" subdirectories in the search path. -If empty, initialized by Manual-directory-list-init.") +(defvar Man-page-header-regexp + (concat "^[ \t]*\\(" Man-name-regexp + "(\\(" Man-section-regexp "\\))\\).*\\1") + "Regular expression describing the heading of a page.") -(defvar Manual-use-full-section-ids t "\ -If non-nil, pass full section ids to Manual-program, otherwise pass -only the first character. Defaults to 't'.") +(defvar Man-heading-regexp "^\\([A-Z][A-Z ]+\\)$" + "Regular expression describing a manpage heading entry.") + +(defvar Man-see-also-regexp "SEE ALSO" + "Regular expression for SEE ALSO heading (or your equivalent). +This regexp should not start with a `^' character.") -(defvar Manual-use-subdirectory-list (eq system-type 'irix) "\ -This makes manual-entry work correctly on SGI machines but it -imposes a large startup cost which is why it is not simply on by -default on all systems.") +(defvar Man-first-heading-regexp "^[ \t]*NAME$\\|^[ \t]*No manual entry fo.*$" + "Regular expression describing first heading on a manpage. +This regular expression should start with a `^' character.") + +(defvar Man-reference-regexp + (concat "\\(" Man-name-regexp "\\)(\\(" Man-section-regexp "\\))") + "Regular expression describing a reference in the SEE ALSO section.") -(defvar Manual-use-rosetta-man (not (null (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. +(defvar Man-switches "" + "Switches passed to the man command, as a single string.") -Here is information on RosettaMan, from Neal.Becker@comsat.com (Neal Becker): +(defvar Man-specified-section-option + (if (string-match "-solaris[0-9.]*$" system-configuration) + "-s" + "") + "Option that indicates a specified a manual section name.") -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. +;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +;; end user variables + +;; other variables and keymap initializations +(make-variable-buffer-local 'Man-sections-alist) +(make-variable-buffer-local 'Man-refpages-alist) +(make-variable-buffer-local 'Man-page-list) +(make-variable-buffer-local 'Man-current-page) +(make-variable-buffer-local 'Man-page-mode-string) +(make-variable-buffer-local 'Man-original-frame) +(make-variable-buffer-local 'Man-arguments) -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. +(setq-default Man-sections-alist nil) +(setq-default Man-refpages-alist nil) +(setq-default Man-page-list nil) +(setq-default Man-current-page 0) +(setq-default Man-page-mode-string "1 of 1") -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. +(defconst Man-sysv-sed-script "\ +/\b/ { s/_\b//g + s/\b_//g + s/o\b+/o/g + s/+\bo/o/g + :ovstrk + s/\\(.\\)\b\\1/\\1/g + t ovstrk + } +/\e\\[[0-9][0-9]*m/ s///g" + "Script for sysV-like sed to nuke backspaces and ANSI codes from manpages.") - - -*** NOTES ON CURRENT VERSION *** +(defconst Man-berkeley-sed-script "\ +/\b/ { s/_\b//g\\ + s/\b_//g\\ + s/o\b+/o/g\\ + s/+\bo/o/g\\ + :ovstrk\\ + s/\\(.\\)\b\\1/\\1/g\\ + t ovstrk\\ + }\\ +/\e\\[[0-9][0-9]*m/ s///g" + "Script for berkeley-like sed to nuke backspaces and ANSI codes from manpages.") -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
!  Man page references are turned into hypertext links.")
+(if Man-mode-map
+    nil
+  (setq Man-mode-map (make-keymap))
+  (suppress-keymap Man-mode-map)
+  (define-key Man-mode-map " "    'scroll-up)
+  (define-key Man-mode-map "\177" 'scroll-down)
+  (define-key Man-mode-map "n"    'Man-next-section)
+  (define-key Man-mode-map "p"    'Man-previous-section)
+  (define-key Man-mode-map "\en"  'Man-next-manpage)
+  (define-key Man-mode-map "\ep"  'Man-previous-manpage)
+  (define-key Man-mode-map ">"    'end-of-buffer)
+  (define-key Man-mode-map "<"    'beginning-of-buffer)
+  (define-key Man-mode-map "."    'beginning-of-buffer)
+  (define-key Man-mode-map "r"    'Man-follow-manual-reference)
+  (define-key Man-mode-map "g"    'Man-goto-section)
+  (define-key Man-mode-map "s"    'Man-goto-see-also-section)
+  (define-key Man-mode-map "k"    'Man-kill)
+  (define-key Man-mode-map "q"    'Man-quit)
+  (define-key Man-mode-map "m"    'man)
+  (define-key Man-mode-map "?"    'describe-mode)
+  )
 
-(make-face 'man-italic)
-(or (face-differs-from-default-p 'man-italic)
-    (copy-face 'italic 'man-italic))
-;; XEmacs (from Darrell Kindred): underlining is annoying due to
-;; large blank spaces in this face.
-;; (or (face-differs-from-default-p 'man-italic)
-;;    (set-face-underline-p 'man-italic t))
+
+;; ======================================================================
+;; utilities
+
+(defun Man-init-defvars ()
+  "Used for initialising variables based on the value of window-system.
+This is necessary if one wants to dump man.el with emacs."
 
-(make-face 'man-bold)
-(or (face-differs-from-default-p 'man-bold)
-    (copy-face 'bold 'man-bold))
-(or (face-differs-from-default-p 'man-bold)
-    (copy-face 'man-italic 'man-bold))
+  ;; The following is necessary until fonts are implemented on
+  ;; terminals.
+  (setq Man-fontify-manpage-flag (and Man-fontify-manpage-flag
+				      window-system))
 
-(make-face 'man-heading)
-(or (face-differs-from-default-p 'man-heading)
-    (copy-face 'man-bold 'man-heading))
-
-(make-face 'man-xref)
-(or (face-differs-from-default-p 'man-xref)
-    (set-face-underline-p 'man-xref t))
-
-;; Manual-directory-list-init
-;; Initialize the directory lists.
+  (setq Man-sed-script
+	(cond
+	 (Man-fontify-manpage-flag
+	  nil)
+	 ((= 0 (call-process Man-sed-command nil nil nil Man-sysv-sed-script))
+	  Man-sysv-sed-script)
+	 ((= 0 (call-process Man-sed-command nil nil nil Man-berkeley-sed-script))
+	  Man-berkeley-sed-script)
+	 (t
+	  nil)))
 
-(defun Manual-directory-list-init (&optional arg) 
-  "Initialize the Manual-directory-list variable from $MANPATH
-if it is not already set, or if a prefix argument is provided."
-  (interactive "P")
-  (if arg (setq Manual-directory-list nil))
-  (if (null Manual-directory-list)
-      (let ((manpath (getenv "MANPATH"))
-	    (global (Manual-manpath-config-contents))
-	    (dirlist nil)
-	    dir)
-	(cond ((and manpath global)
-	       (setq manpath (concat manpath ":" global)))
-	      (global
-	       (setq manpath global))
-	      ((not manpath)
-	       ;; XEmacs - (bpw/stig) Unix-specifix hack for lusers w/ no manpath
-	       (setq manpath "/usr/local/man:/usr/share/man:/usr/share/catman:/usr/contrib/man:/usr/X11/man:/usr/man:/usr/catman")))
-	;; Make sure that any changes we've made internally are seen by man.
-	(setenv "MANPATH" manpath)
-	(while (string-match "\\`:*\\([^:]+\\)" manpath)
-	  (setq dir (substring manpath (match-beginning 1) (match-end 1)))
-	  (and (not (member dir dirlist))
-	       (setq dirlist (cons dir dirlist)))
-	  (setq manpath (substring manpath (match-end 0))))
-	(setq dirlist (nreverse dirlist))
-	(setq Manual-directory-list dirlist)
-	(setq Manual-subdirectory-list nil)
-	(setq Manual-formatted-directory-list nil)
-	(setq Manual-unformatted-directory-list nil)))
-  (if (string-equal Manual-leaf-signature "")
-      (setq Manual-leaf-signature
-	    (concat "/\\("
-		    Manual-formatted-page-prefix
-		    "\\|" Manual-unformatted-page-prefix
-		    "\\)"
-		    "[" Manual-man-page-section-ids
-		    "].?/.")))
-  (if Manual-use-subdirectory-list
-      (progn
-	(if (null Manual-subdirectory-list)
-	    (setq Manual-subdirectory-list
-		  (Manual-all-subdirectories Manual-directory-list
-					     Manual-leaf-signature nil)))
-	(if (null Manual-formatted-directory-list)
-	    (setq Manual-formatted-directory-list
-		  (Manual-filter-subdirectories Manual-subdirectory-list
-						Manual-formatted-page-prefix)))
-	(if (null Manual-unformatted-directory-list)
-	    (setq Manual-unformatted-directory-list
-		  (Manual-filter-subdirectories Manual-subdirectory-list
-						Manual-unformatted-page-prefix))))
-    (if (null Manual-formatted-directory-list)
-        (setq Manual-formatted-directory-list
-	      (Manual-select-subdirectories Manual-directory-list
-					    Manual-formatted-page-prefix)))
-    (if (null Manual-unformatted-directory-list)
-        (setq Manual-unformatted-directory-list
-	      (Manual-select-subdirectories Manual-directory-list
-					    Manual-unformatted-page-prefix)))))
+  (setq Man-filter-list
+	(list
+	 (cons
+	  Man-sed-command
+	  (list
+	   (if Man-sed-script
+	       (concat "-e '" Man-sed-script "'")
+	     "")
+	   "-e '/^[\001-\032][\001-\032]*$/d'"
+	   "-e '/\e[789]/s///g'"
+	   "-e '/Reformatting page.  Wait/d'"
+	   "-e '/Reformatting entry.  Wait/d'"
+	   "-e '/^[ \t]*Hewlett-Packard[ \t]Company[ \t]*-[ \t][0-9]*[ \t]-/d'"
+	   "-e '/^[ \t]*Hewlett-Packard[ \t]*-[ \t][0-9]*[ \t]-.*$/d'"
+	   "-e '/^[ \t][ \t]*-[ \t][0-9]*[ \t]-[ \t]*Formatted:.*[0-9]$/d'"
+	   "-e '/^[ \t]*Page[ \t][0-9]*.*(printed[ \t][0-9\\/]*)$/d'"
+	   "-e '/^Printed[ \t][0-9].*[0-9]$/d'"
+	   "-e '/^[ \t]*X[ \t]Version[ \t]1[01].*Release[ \t][0-9]/d'"
+	   "-e '/^[A-za-z].*Last[ \t]change:/d'"
+	   "-e '/^Sun[ \t]Release[ \t][0-9].*[0-9]$/d'"
+	   "-e '/[ \t]*Copyright [0-9]* UNIX System Laboratories, Inc.$/d'"
+	   "-e '/^[ \t]*Rev\\..*Page [0-9][0-9]*$/d'"
+	   ))
+	 (cons
+	  Man-awk-command
+	  (list
+	   "'\n"
+	   "BEGIN { blankline=0; anonblank=0; }\n"
+	   "/^$/ { if (anonblank==0) next; }\n"
+	   "{ anonblank=1; }\n"
+	   "/^$/ { blankline++; next; }\n"
+	   "{ if (blankline>0) { print \"\"; blankline=0; } print $0; }\n"
+	   "'"
+	   ))
+	 (if (not Man-uses-untabify-flag)
+	     (cons
+	      Man-untabify-command
+	      Man-untabify-command-args)
+	   )))
+)
+
+(defsubst Man-match-substring (&optional n string)
+  "Return the substring matched by the last search.
+Optional arg N means return the substring matched by the Nth paren
+grouping.  Optional second arg STRING means return a substring from
+that string instead of from the current buffer."
+  (if (null n) (setq n 0))
+  (if string
+      (substring string (match-beginning n) (match-end n))
+    (buffer-substring (match-beginning n) (match-end n))))
+
+(defsubst Man-make-page-mode-string ()
+  "Formats part of the mode line for Man mode."
+  (format "%s page %d of %d"
+	  (or (nth 2 (nth (1- Man-current-page) Man-page-list))
+	      "")
+	  Man-current-page
+	  (length Man-page-list)))
+
+(defsubst Man-build-man-command ()
+  "Builds the entire background manpage and cleaning command."
+  (let ((command (concat manual-program " " Man-switches " %s 2>/dev/null"))
+	(flist Man-filter-list))
+    (while (and flist (car flist))
+      (let ((pcom (car (car flist)))
+	    (pargs (cdr (car flist))))
+	(setq command
+	      (concat command " | " pcom " "
+		      (mapconcat '(lambda (phrase)
+				    (if (not (stringp phrase))
+					(error "Malformed Man-filter-list"))
+				    phrase)
+				 pargs " ")))
+	(setq flist (cdr flist))))
+    command))
 
+(defun Man-translate-references (ref)
+  "Translates REF from \"chmod(2V)\" to \"2v chmod\" style.
+Leave it as is if already in that style.  Possibly downcase and
+translate the section (see the Man-downcase-section-letters-flag
+and the Man-section-translations-alist variables)."
+  (let ((name "")
+	(section "")
+	(slist Man-section-translations-alist))
+    (cond
+     ;; "chmod(2V)" case ?
+     ((string-match (concat "^" Man-reference-regexp "$") ref)
+      (setq name (Man-match-substring 1 ref)
+	    section (Man-match-substring 2 ref)))
+     ;; "2v chmod" case ?
+     ((string-match (concat "^\\(" Man-section-regexp
+			    "\\) +\\(" Man-name-regexp "\\)$") ref)
+      (setq name (Man-match-substring 2 ref)
+	    section (Man-match-substring 1 ref))))
+    (if (string= name "")
+	ref				; Return the reference as is
+      (if Man-downcase-section-letters-flag
+	  (setq section (downcase section)))
+      (while slist
+	(let ((s1 (car (car slist)))
+	      (s2 (cdr (car slist))))
+	  (setq slist (cdr slist))
+	  (if Man-downcase-section-letters-flag
+	      (setq s1 (downcase s1)))
+	  (if (not (string= s1 section)) nil
+	    (setq section (if Man-downcase-section-letters-flag
+			      (downcase s2)
+			    s2)
+		  slist nil))))
+      (concat Man-specified-section-option section " " name))))
 
-(defun Manual-manpath-config-contents ()
-  "Parse the `Manual-manpath-config-file' file, if any.
-Returns a string like in $MANPATH."
-  (if (and Manual-manpath-config-file
-	   (file-readable-p Manual-manpath-config-file))
-      (let ((buf (get-buffer-create " *Manual-config*"))
-	    path)
-	(set-buffer buf)
-	(buffer-disable-undo buf)
-	(erase-buffer)
-	(insert-file-contents Manual-manpath-config-file)
-	(while (re-search-forward "^\\(MANDATORY_MANPATH\\|MANPATH_MAP\\)"
-				  nil t)
-	  (and (re-search-forward "\\(/[^ \t\n]+\\)[ \t]*$")
-	       (setq path (concat path (buffer-substring (match-beginning 1)
-							 (match-end 1))
-				  ":"))))
-	(kill-buffer buf)
-	path)))
-;;
-;; manual-entry  -- The "main" user function
-;;
+
+;; ======================================================================
+;; default man entry: get word under point
+
+(defsubst Man-default-man-entry ()
+  "Make a guess at a default manual entry.
+This guess is based on the text surrounding the cursor, and the
+default section number is selected from `Man-auto-section-alist'."
+  (let (default-title)
+    (save-excursion
+      
+      ;; Default man entry title is any word the cursor is on, or if
+      ;; cursor not on a word, then nearest preceding word.  Cannot
+      ;; use the current-word function because it skips the dots.
+      (if (not (looking-at "[-a-zA-Z_.]"))
+	  (skip-chars-backward "^a-zA-Z"))
+      (skip-chars-backward "-(a-zA-Z_0-9_.")
+      (if (looking-at "(") (forward-char 1))
+      (setq default-title
+	    (buffer-substring
+	     (point)
+	     (progn (skip-chars-forward "-a-zA-Z0-9_.") (point))))
+      
+      ;; If looking at something like ioctl(2) or brc(1M), include the
+      ;; section number in the returned value.  Remove text properties.
+      (let ((result (concat
+		     default-title
+		     (if (looking-at
+			  (concat "[ \t]*([ \t]*\\("
+				  Man-section-regexp "\\)[ \t]*)"))
+			 (format "(%s)" (Man-match-substring 1))))))
+	(set-text-properties 0 (length result) nil result)
+	result))))
+
+
+;; ======================================================================
+;; Top level command and background process sentinel
+
+;; For compatibility with older versions.
+;;;###autoload
+(defalias 'manual-entry 'man)
 
 ;;;###autoload
-(defun manual-entry (topic &optional arg silent)
-  "Display the Unix manual entry (or entries) for TOPIC.
-If prefix arg is given, modify the search according to the value:
-  2 = complement default exact matching of the TOPIC name;
-      exact matching default is specified by `Manual-match-topic-exactly'
-  3 = force a search of the unformatted man directories
-  4 = both 2 and 3
-The manual entries are searched according to the variable
-Manual-directory-list, which should be a list of directories.  If
-Manual-directory-list is nil, \\[Manual-directory-list-init] is
-invoked to create this list from the MANPATH environment variable.
-See the variable Manual-topic-buffer which controls how the buffer
-is named.  See also the variables Manual-match-topic-exactly,
-Manual-query-multiple-pages, and Manual-buffer-view-mode."
+(defun man (man-args)
+  "Get a Un*x manual page and put it in a buffer.
+This command is the top-level command in the man package.  It runs a Un*x
+command to retrieve and clean a manpage in the background and places the
+results in a Man mode (manpage browsing) buffer.  See variable
+`Man-notify-method' for what happens when the buffer is ready.
+If a buffer already exists for this man page, it will display immediately."
   (interactive
-   (list (let* ((fmh "-A-Za-z0-9_.")
-		(default (save-excursion
-			   (buffer-substring
-			    (progn
-			      (re-search-backward "\\sw" nil t)
-			      (skip-chars-backward fmh) (point))
-			    (progn (skip-chars-forward fmh) (point)))))
-		(thing (read-string
-			(if (equal default "") "Manual entry: "
-			  (concat "Manual entry: (default " default ") ")))))
-	   (if (equal thing "") default thing))
-	 (prefix-numeric-value current-prefix-arg)))
-  ;;(interactive "sManual entry (topic): \np")
-  (or arg (setq arg 1))
-  (Manual-directory-list-init nil)
-  (let ((exact (if (or (= arg 2) (= arg 4))
-		   (not Manual-match-topic-exactly)
-		 Manual-match-topic-exactly))
-	(force (if (>= arg 3)
-                   t
-                   nil))
-	section fmtlist manlist apropos-mode)
-    (let ((case-fold-search nil))
-      (if (and (null section)
-	       (string-match
-		"\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic))
-	  (setq section (substring topic (match-beginning 2)
-				   (match-end 2))
-		topic (substring topic (match-beginning 1)
-				 (match-end 1)))
-	(if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic)
-	    (setq section "-k"
-		  topic (substring topic (match-beginning 1))))))
-    (if (equal section "-k")
-	(setq apropos-mode t)
-      (or silent
-	  (message "Looking for formatted entry for %s%s..."
-		   topic (if section (concat "(" section ")") "")))
-      (setq fmtlist (Manual-select-man-pages
-                      Manual-formatted-directory-list
-                      topic section exact '()))
-      (if (or force (not section) (null fmtlist))
-	  (progn
-	    (or silent
-		(message "%sooking for unformatted entry for %s%s..."
-			 (if fmtlist "L" "No formatted entry, l")
-			 topic (if section (concat "(" section ")") "")))
-	    (setq manlist (Manual-select-man-pages
-                            Manual-unformatted-directory-list
-                            topic section exact (if force '() fmtlist))))))
-
-    ;; Delete duplicate man pages (a file of the same name in multiple
-    ;; directories.)
-    (or nil ;force
-        (let ((rest (append fmtlist manlist)))
-          (while rest
-            (let ((rest2 (cdr rest)))
-              (while rest2
-                (if (equal (file-name-nondirectory (car rest))
-                           (file-name-nondirectory (car rest2)))
-                    (setq fmtlist (delq (car rest2) fmtlist)
-                          manlist (delq (car rest2) manlist)))
-                (setq rest2 (cdr rest2))))
-            (setq rest (cdr rest)))))
-
-    (if (not (or fmtlist manlist apropos-mode))
-        (progn
-          (message "No entries found for %s%s" topic
-                   (if section (concat "(" section ")") ""))
-          nil)
-      (let ((bufname (cond ((not Manual-topic-buffer)
-                            ;; What's the point of retaining this?
-                            (if apropos-mode
-                                "*Manual Apropos*"
-                                "*Manual Entry*"))
-                           (apropos-mode
-                            (concat "*man apropos " topic "*"))
-                           (t
-                            (concat "*man "
-                                    (cond (exact
-                                           (if section
-                                               (concat topic "." section)
-                                               topic))
-                                          ((or (cdr fmtlist) (cdr manlist)
-                                               (and fmtlist manlist))
-                                           ;; more than one entry found
-                                           (concat topic "..."))
-                                          (t
-                                           (file-name-nondirectory
-                                            (car (or fmtlist manlist)))))
-                                    "*"))))
-            (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))))
-
-        (if apropos-mode
-            (setq manlist (list (format "%s.%s" topic section))))
+   (list (let* ((default-entry (Man-default-man-entry))
+		(input (read-string
+			(format "Manual entry%s: "
+				(if (string= default-entry "")
+				    ""
+				  (format " (default %s)" default-entry))))))
+	   (if (string= input "")
+	       (if (string= default-entry "")
+		   (error "No man args given")
+		 default-entry)
+	     input))))
 
-        (cond
-          ((and Manual-topic-buffer (get-buffer bufname))
-           ;; reselect an old man page buffer if it exists already.
-           (save-excursion
-             (set-buffer (get-buffer bufname))
-             (Manual-mode))
-           (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)
-	       (Manual-insert-pages fmtlist manlist apropos-mode)
-               (set-buffer-modified-p nil)
-               (Manual-mode)
-               ))))
-        (setq Manual-page-history
-              (cons (buffer-name)
-                    (delete (buffer-name) Manual-page-history)))
-        (message nil)
-        t))))
-
-(defun Manpage-apropos (topic &optional arg silent)
-  "Apropos on Unix manual pages for TOPIC.
-It calls the function `manual-entry'. Look at this function for
-further description. Look also at the variable `Manual-apropos-switch',
-if this function doesn't work on your system."
-  (interactive
-   (list (let* ((fmh "-A-Za-z0-9_.")
-		(default (save-excursion
-			   (buffer-substring
-			    (progn
-			      (re-search-backward "\\sw" nil t)
-			      (skip-chars-backward fmh) (point))
-			    (progn (skip-chars-forward fmh) (point)))))
-		(thing (read-string
-			(if (equal default "") "Manual entry: "
-			  (concat "Manual entry: (default " default ") ")))))
-	   (if (equal thing "") default thing))
-	 (prefix-numeric-value current-prefix-arg)))
-  (manual-entry (concat Manual-apropos-switch " " topic) arg silent))
+  ;; Possibly translate the "subject(section)" syntax into the
+  ;; "section subject" syntax and possibly downcase the section.
+  (setq man-args (Man-translate-references man-args))
 
-(defun Manual-insert-pages (fmtlist manlist apropos-mode)
-  (let ((sep (make-string 65 ?-))
-	name start end topic section)
-    (while fmtlist			; insert any formatted files
-      (setq name (car fmtlist))
-      (goto-char (point-max))
-      (setq start (point))
-      ;; In case the file can't be read or uncompressed or
-      ;; something like that.
-      (condition-case ()
-	  (Manual-insert-man-file name)
-	(file-error nil))
-      (goto-char (point-max))
-      (setq end (point))
-      (save-excursion
-	(save-restriction
-	  (message "Cleaning manual entry for %s..."
-		   (file-name-nondirectory name))
-	  (narrow-to-region start end)
-	  (Manual-nuke-nroff-bs)
-	  (goto-char (point-min))
-	  (insert "File: " name "\n")
-	  (goto-char (point-max))
-	  ))
-      (if (or (cdr fmtlist) manlist)
-	  (insert "\n\n" sep "\n"))
-      (setq fmtlist (cdr fmtlist)))
-
-    (while manlist			; process any unformatted files
-      (setq name (car manlist))
-      (or (string-match "\\([^/]+\\)\\.\\([^./]+\\)\\(\\.gz\\'\\)" name)
-	  (string-match "\\([^/]+\\)\\.\\([^./]+\\)\\'" name))
-      (setq topic (substring name (match-beginning 1) (match-end 1)))
-      (setq section (substring name (match-beginning 2) (match-end 2)))
-      ;; This won't work under IRIX, because SGI man accepts only the
-      ;; "main" (one-character) section id, not full section ids
-      ;; like 1M, 3X, etc. Put (setq Manual-use-full-section-ids nil)
-      ;; in your .emacs to work around this problem.
-      (if (not (or Manual-use-full-section-ids (string-equal section "")))
-	  (setq section (substring section 0 1)))
-      (message "Invoking man %s%s %s..."
-	       (if Manual-section-switch
-		   (concat Manual-section-switch " ")
-		 "")
-	       section topic)
-      (setq start (point))
-      (Manual-run-formatter name topic section)
-      (setq end (point))
-      (save-excursion
-	(save-restriction
-	  (message "Cleaning manual entry for %s(%s)..." topic section)
-	  (narrow-to-region start end)
-	  (Manual-nuke-nroff-bs apropos-mode)
-	  (goto-char (point-min))
-	  (insert "File: " name "\n")
-	  (goto-char (point-max))
-	  ))
-      (if (cdr manlist)
-	  (insert "\n\n" sep "\n"))
-      (setq manlist (cdr manlist))))
-  (if (< (buffer-size) 200)
-      (progn
-	(goto-char (point-min))
-	(if (looking-at "^File: ")
-	    (forward-line 1))
-	(error (buffer-substring (point) (progn (end-of-line) (point))))))
-  nil)
-
-
-(defun Manual-run-formatter (name topic section)
-  (cond
-   ((string-match "roff\\'" Manual-program)
-    ;; kludge kludge
-    (call-process Manual-program nil t nil "-Tman" "-man" name))
-
-   (t
-    (call-process Manual-program nil t nil
-                  (concat Manual-section-switch section) topic))))
-
-   ;(Manual-use-rosetta-man
-   ; (call-process "/bin/sh" nil t nil "-c"
-   ;               (format "man %s %s | rman" section topic)))
+  (Man-getpage-in-background man-args))
 
 
-(defvar Manual-mode-map
-  (let ((m (make-sparse-keymap)))
-    (set-keymap-name m 'Manual-mode-map)
-    (define-key m "l" 'Manual-last-page)
-    (define-key m 'button2 'Manual-follow-xref)
-    (define-key m 'button3 'Manual-popup-menu)
-    m))
+(defun Man-getpage-in-background (topic)
+  "Uses TOPIC to build and fire off the manpage and cleaning command."
+  (let* ((man-args topic)
+	 (bufname (concat "*Man " man-args "*"))
+	 (buffer  (get-buffer bufname)))
+    (if buffer
+	(Man-notify-when-ready buffer)
+      (require 'env)
+      (message "Invoking %s %s in the background" manual-program man-args)
+      (setq buffer (generate-new-buffer bufname))
+      (save-excursion
+	(set-buffer buffer)
+	(setq Man-original-frame (selected-frame))
+	(setq Man-arguments man-args))
+      (let ((process-environment (copy-sequence process-environment)))
+	;; Prevent any attempt to use display terminal fanciness.
+	(setenv "TERM" "dumb")
+	(set-process-sentinel
+	 (start-process manual-program buffer "sh" "-c"
+			(format (Man-build-man-command) man-args))
+	 'Man-bgproc-sentinel)))))
 
-(defun Manual-mode ()
-  (kill-all-local-variables)
-  (setq buffer-read-only t)
-  (use-local-map Manual-mode-map)
-  (setq major-mode 'Manual-mode
-	mode-name "Manual")
-  ;; man pages with long lines are buggy!
-  ;; This looks slightly better if they only
-  ;; overran by a couple of chars.
-  (setq truncate-lines t)
-  (if (featurep 'scrollbar)
-      ;; turn off horizontal scrollbars in this buffer
-      (set-specifier scrollbar-height (cons (current-buffer) 0)))
-  (run-hooks 'Manual-mode-hook))
+(defun Man-notify-when-ready (man-buffer)
+  "Notify the user when MAN-BUFFER is ready.
+See the variable `Man-notify-method' for the different notification behaviors."
+  (let ((saved-frame (save-excursion
+		       (set-buffer man-buffer)
+		       Man-original-frame)))
+    (cond
+     ((eq Man-notify-method 'newframe)
+      ;; Since we run asynchronously, perhaps while Emacs is waiting
+      ;; for input, we must not leave a different buffer current.  We
+      ;; can't rely on the editor command loop to reselect the
+      ;; selected window's buffer.
+      (save-excursion
+	(set-buffer man-buffer)
+	(make-frame Man-frame-parameters)))
+     ((eq Man-notify-method 'pushy)
+      (switch-to-buffer man-buffer))
+     ((eq Man-notify-method 'bully)
+      (and window-system
+	   (frame-live-p saved-frame)
+	   (select-frame saved-frame))
+      (pop-to-buffer man-buffer)
+      (delete-other-windows))
+     ((eq Man-notify-method 'aggressive)
+      (and window-system
+	   (frame-live-p saved-frame)
+	   (select-frame saved-frame))
+      (pop-to-buffer man-buffer))
+     ((eq Man-notify-method 'friendly)
+      (and window-system
+	   (frame-live-p saved-frame)
+	   (select-frame saved-frame))
+      (display-buffer man-buffer 'not-this-window))
+     ((eq Man-notify-method 'polite)
+      (beep)
+      (message "Manual buffer %s is ready" (buffer-name man-buffer)))
+     ((eq Man-notify-method 'quiet)
+      (message "Manual buffer %s is ready" (buffer-name man-buffer)))
+     ((or (eq Man-notify-method 'meek)
+	  t)
+      (message ""))
+     )))
 
-(defun Manual-last-page ()
+(defun Man-fontify-manpage ()
+  "Convert overstriking and underlining to the correct fonts.
+Same for the ANSI bold and normal escape sequences."
   (interactive)
-  (while (or (not (get-buffer (car (or Manual-page-history
-				       (error "No more history.")))))
-	     (eq (get-buffer (car Manual-page-history)) (current-buffer)))
-    (setq Manual-page-history (cdr Manual-page-history)))
-  (switch-to-buffer (car Manual-page-history)))
-
-
-;; Manual-select-subdirectories
-;; Given a DIRLIST and a SUBDIR name, return all subdirectories of the former which
-;; match the latter.
-
-(defun Manual-select-subdirectories (dirlist subdir)
-  (let ((dirs '())
-        (case-fold-search nil)
-        (match (concat "\\`" (regexp-quote subdir)))
-        d)
-    (while dirlist
-      (setq d (car dirlist) dirlist (cdr dirlist))
-      (if (file-directory-p d)
-          (let ((files (directory-files d t match nil 'dirs-only))
-		(dir-temp '()))
-            (while files
-              (if (file-executable-p (car files))
-                  (setq dir-temp (cons (file-name-as-directory (car files))
-                                   dir-temp)))
-              (setq files (cdr files)))
-	    (and dir-temp
-		 (setq dirs (append dirs (nreverse dir-temp)))))))
-    dirs))
-
+  (message "Please wait: making up the %s man page..." Man-arguments)
+  (goto-char (point-min))
+  (while (search-forward "\e[1m" nil t)
+    (delete-backward-char 4)
+    (put-text-property (point)
+		       (progn (if (search-forward "\e[0m" nil 'move)
+				  (delete-backward-char 4))
+			      (point))
+		       'face Man-overstrike-face))
+  (goto-char (point-min))
+  (while (search-forward "_\b" nil t)
+    (backward-delete-char 2)
+    (put-text-property (point) (1+ (point)) 'face Man-underline-face))
+  (goto-char (point-min))
+  (while (search-forward "\b_" nil t)
+    (backward-delete-char 2)
+    (put-text-property (1- (point)) (point) 'face Man-underline-face))
+  (goto-char (point-min))
+  (while (re-search-forward "\\(.\\)\\(\b\\1\\)+" nil t)
+    (replace-match "\\1")
+    (put-text-property (1- (point)) (point) 'face Man-overstrike-face))
+  (goto-char (point-min))
+  (while (re-search-forward "o\b\\+\\|\\+\bo" nil t)
+    (replace-match "o")
+    (put-text-property (1- (point)) (point) 'face 'bold))
+  (goto-char (point-min))
+  (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t)
+    (replace-match "+")
+    (put-text-property (1- (point)) (point) 'face 'bold))
+  ;; \255 is some kind of dash in Latin-1.
+  (goto-char (point-min))
+  (while (search-forward "\255" nil t) (replace-match "-"))
+  (message "%s man page made up" Man-arguments))
 
-;; Manual-filter-subdirectories
-;; Given a DIRLIST and a SUBDIR name, return all members of the former
-;; which match the latter.
+(defun Man-cleanup-manpage ()
+  "Remove overstriking and underlining from the current buffer."
+  (interactive)
+  (message "Please wait: cleaning up the %s man page..."
+	   Man-arguments)
+  (if (or (interactive-p) (not Man-sed-script))
+      (progn
+	(goto-char (point-min))
+	(while (search-forward "_\b" nil t) (backward-delete-char 2))
+	(goto-char (point-min))
+	(while (search-forward "\b_" nil t) (backward-delete-char 2))
+	(goto-char (point-min))
+	(while (re-search-forward "\\(.\\)\\(\b\\1\\)+" nil t)
+	  (replace-match "\\1"))
+	(goto-char (point-min))
+	(while (re-search-forward "\e\\[[0-9]+m" nil t) (replace-match ""))
+	(goto-char (point-min))
+	(while (re-search-forward "o\b\\+\\|\\+\bo" nil t) (replace-match "o"))
+	))
+  (goto-char (point-min))
+  (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t) (replace-match "+"))
+  ;; \255 is some kind of dash in Latin-1.
+  (goto-char (point-min))
+  (while (search-forward "\255" nil t) (replace-match "-"))
+  (message "%s man page cleaned up" Man-arguments))
+
+(defun Man-bgproc-sentinel (process msg)
+  "Manpage background process sentinel."
+  (let ((Man-buffer (process-buffer process))
+	(delete-buff nil)
+	(err-mess nil))
+
+    (if (null (buffer-name Man-buffer)) ;; deleted buffer
+	(set-process-buffer process nil)
 
-(defun Manual-filter-subdirectories (dirlist subdir)
-  (let ((match (concat
-		"/"
-		(regexp-quote subdir)
-		"[" Manual-man-page-section-ids "]"))
-	slist dir)
-    (while dirlist
-      (setq dir (car dirlist) dirlist (cdr dirlist))
-      (if (and (file-executable-p dir) (string-match match dir))
-	    (setq slist (cons dir slist))))
-    (nreverse slist)))
+      (save-excursion
+	(set-buffer Man-buffer)
+	(let ((case-fold-search nil))
+	  (goto-char (point-min))
+	  (cond ((or (looking-at "No \\(manual \\)*entry for")
+		     (looking-at "[^\n]*: nothing appropriate$"))
+		 (setq err-mess (buffer-substring (point)
+						  (progn
+						    (end-of-line) (point)))
+		       delete-buff t))
+		((not (and (eq (process-status process) 'exit)
+			   (= (process-exit-status process) 0)))
+		 (setq err-mess
+		       (concat (buffer-name Man-buffer)
+			       ": process "
+			       (let ((eos (1- (length msg))))
+				 (if (= (aref msg eos) ?\n)
+				     (substring msg 0 eos) msg))))
+		 (goto-char (point-max))
+		 (insert (format "\nprocess %s" msg))
+		 ))
+	  (if delete-buff
+	      (kill-buffer Man-buffer)
+	    (if Man-fontify-manpage-flag
+		(Man-fontify-manpage)
+	      (Man-cleanup-manpage))
+	    (run-hooks 'Man-cooked-hook)
+	    (Man-mode)
+	    (set-buffer-modified-p nil)
+	    ))
+	;; Restore case-fold-search before calling
+	;; Man-notify-when-ready because it may switch buffers.
 
-
-(defun Manual-all-subdirectories (dirlist leaf-signature dirs &optional silent) "\
-Given a DIRLIST, return a backward-sorted list of all subdirectories
-thereof, prepended to DIRS if non-nil. This function calls itself
-recursively until subdirectories matching LEAF-SIGNATURE are reached,
-or the hierarchy has been thoroughly searched. This code is a modified
-version of a function written by Tim Bradshaw (tfb@ed.ac.uk)."
-  (Manual-all-subdirectories-noloop dirlist leaf-signature dirs nil silent))
+	(if (not delete-buff)
+	    (Man-notify-when-ready Man-buffer))
 
-(defun Manual-all-subdirectories-noloop (dirlist leaf-signature dirs been &optional silent) "\
-Does the job of manual-all-subdirectories and keeps track of where it
-has been to avoid loops."
-  (let (dir)
-    (while dirlist
-      (setq dir (car dirlist) dirlist (cdr dirlist))
-      (if (file-directory-p dir)
-	  (let ((dir-temp (cons (file-name-as-directory dir) dirs)))
-	    ;; Without feedback the user might wonder about the delay!
-	    (or silent (message
-			"Building list of search directories... %s"
-			(car dir-temp)))
-	    (if (member (file-truename dir) been)
-		()		 ; Ignore. We have been here before
-	      (setq been (cons (file-truename dir) been))
-	      (setq dirs
-		    (if (string-match leaf-signature dir)
-			dir-temp
-		      (Manual-all-subdirectories-noloop
-		       (directory-files dir t "[^.]$" nil 'dirs-only)
-		       leaf-signature dir-temp been silent))))))))
-  dirs)
+	(if err-mess
+	    (error err-mess))
+	))))
+
+
+;; ======================================================================
+;; set up manual mode in buffer and build alists
+
+(defun Man-mode ()
+  "A mode for browsing Un*x manual pages.
+
+The following man commands are available in the buffer. Try
+\"\\[describe-key]  RET\" for more information:
+
+\\[man]       Prompt to retrieve a new manpage.
+\\[Man-follow-manual-reference]       Retrieve reference in SEE ALSO section.
+\\[Man-next-manpage]   Jump to next manpage in circular list.
+\\[Man-previous-manpage]   Jump to previous manpage in circular list.
+\\[Man-next-section]       Jump to next manpage section.
+\\[Man-previous-section]       Jump to previous manpage section.
+\\[Man-goto-section]       Go to a manpage section.
+\\[Man-goto-see-also-section]       Jumps to the SEE ALSO manpage section.
+\\[Man-quit]       Deletes the manpage window, bury its buffer.
+\\[Man-kill]       Deletes the manpage window, kill its buffer.
+\\[describe-mode]       Prints this help text.
+
+The following variables may be of some use. Try
+\"\\[describe-variable]  RET\" for more information:
 
-
-(defvar Manual-bogus-file-pattern "\\.\\(lpr\\|ps\\|PS\\)\\'"
-  "Some systems have files in the man/man*/ directories which aren't man pages.
-This pattern is used to prune those files.")
+Man-notify-method               What happens when manpage formatting is done.
+Man-downcase-section-letters-flag  Force section letters to lower case.
+Man-circular-pages-flag         Treat multiple manpage list as circular.
+Man-auto-section-alist          List of major modes and their section numbers.
+Man-section-translations-alist  List of section numbers and their Un*x equiv.
+Man-filter-list                 Background manpage filter command.
+Man-mode-line-format            Mode line format for Man mode buffers.
+Man-mode-map                    Keymap bindings for Man mode buffers.
+Man-mode-hook                   Normal hook run on entry to Man mode.
+Man-section-regexp              Regexp describing manpage section letters.
+Man-heading-regexp              Regexp describing section headers.
+Man-see-also-regexp             Regexp for SEE ALSO section (or your equiv).
+Man-first-heading-regexp        Regexp for first heading on a manpage.
+Man-reference-regexp            Regexp matching a references in SEE ALSO.
+Man-switches			Background `man' command switches.
 
-;; Manual-select-man-pages
-;;
-;; Given a DIRLIST, discover all filenames which complete given the TOPIC
-;; and SECTION.
+The following key bindings are currently in effect in the buffer:
+\\{Man-mode-map}"
+  (interactive)
+  (setq major-mode 'Man-mode
+	mode-name "Man"
+	buffer-auto-save-file-name nil
+	mode-line-format Man-mode-line-format
+	truncate-lines t
+	buffer-read-only t)
+  (buffer-disable-undo (current-buffer))
+  (auto-fill-mode -1)
+  (use-local-map Man-mode-map)
+  (Man-build-page-list)
+  (Man-strip-page-headers)
+  (Man-unindent)
+  (Man-goto-page 1)
+  (run-hooks 'Man-mode-hook))
 
-;; ## Note: BSD man looks for .../man1/foo.1 and .../man1/$MACHINE/foo.1
+(defsubst Man-build-section-alist ()
+  "Build the association list of manpage sections."
+  (setq Man-sections-alist nil)
+  (goto-char (point-min))
+  (let ((case-fold-search nil))
+    (while (re-search-forward Man-heading-regexp (point-max) t)
+      (aput 'Man-sections-alist (Man-match-substring 1))
+      (forward-line 1))))
 
-;; ## Fixed for SGI IRIX 5.x on Sat Jul 15 1995 by Dale Atems
-;; (atems@physics.wayne.edu).
+(defsubst Man-build-references-alist ()
+  "Build the association list of references (in the SEE ALSO section)."
+  (setq Man-refpages-alist nil)
+  (save-excursion
+    (if (Man-find-section Man-see-also-regexp)
+	(let ((start (progn (forward-line 1) (point)))
+	      (end (progn
+		     (Man-next-section 1)
+		     (point)))
+	      hyphenated
+	      (runningpoint -1))
+	  (save-restriction
+	    (narrow-to-region start end)
+	    (goto-char (point-min))
+	    (back-to-indentation)
+	    (while (and (not (eobp)) (/= (point) runningpoint))
+	      (setq runningpoint (point))
+	      (if (re-search-forward Man-reference-regexp end t)
+		  (let* ((word (Man-match-substring 0))
+			 (len (1- (length word))))
+		    (if hyphenated
+			(setq word (concat hyphenated word)
+			      hyphenated nil))
+		    (if (= (aref word len) ?-)
+			(setq hyphenated (substring word 0 len))
+		      (aput 'Man-refpages-alist word))))
+	      (skip-chars-forward " \t\n,")))))))
+
+(defun Man-build-page-list ()
+  "Build the list of separate manpages in the buffer."
+  (setq Man-page-list nil)
+  (let ((page-start (point-min))
+	(page-end (point-max))
+	(header ""))
+    (goto-char page-start)
+    ;; (switch-to-buffer (current-buffer))(debug)
+    (while (not (eobp))
+      (setq header
+	    (if (looking-at Man-page-header-regexp)
+		(Man-match-substring 1)
+	      nil))
+      ;; Go past both the current and the next Man-first-heading-regexp
+      (if (re-search-forward Man-first-heading-regexp nil 'move 2)
+	  (let ((p (progn (beginning-of-line) (point))))
+	    ;; We assume that the page header is delimited by blank
+	    ;; lines and that it contains at most one blank line.  So
+	    ;; if we back by three blank lines we will be sure to be
+	    ;; before the page header but not before the possible
+	    ;; previous page header.
+	    (search-backward "\n\n" nil t 3)
+	    (if (re-search-forward Man-page-header-regexp p 'move)
+		(beginning-of-line))))
+      (setq page-end (point))
+      (setq Man-page-list (append Man-page-list
+				  (list (list (copy-marker page-start)
+					      (copy-marker page-end)
+					      header))))
+      (setq page-start page-end)
+      )))
 
-(defun Manual-select-man-pages (dirlist topic section exact shadow)
-  (let ((case-fold-search nil))
-    (and section
-      (let ((l '())
-	    ;;(match (concat (substring section 0 1) "/?\\'"))
-	    ;;                                          ^^^
-	    ;; We'll lose any pages inside subdirectories of the "standard"
-	    ;; ones if we insist on this! The following regexp should
-	    ;; match any directory ending with the full section id or
-	    ;; its first character, or any direct subdirectory thereof:
-	    (match (concat "\\("
-			   (regexp-quote section)
-			   "\\|"
-			   (substring section 0 1)
-			   "\\)/?"))
-	    d)
-	(while dirlist
-	  (setq d (car dirlist) dirlist (cdr dirlist))
-	  (if (string-match match d)
-	      (setq l (cons d l))))
-	(setq dirlist l)))
-    (if shadow
-        (setq shadow (concat "/\\("
-                             (mapconcat #'(lambda (n)
-                                            (regexp-quote
-                                             (file-name-nondirectory n)))
-                                        shadow
-                                        "\\|")
-                             "\\)\\'")))
-    (let ((manlist '())
-          (match (concat "\\`"
-                           (regexp-quote topic)
-			    ;; **Note: on IRIX the preformatted pages
-			    ;; are packed, so they end with ".z". This
-			    ;; way you miss them if you specify a
-			    ;; section. I don't see any point to it here
-			    ;; even on BSD systems since we're looking
-			    ;; one level down already, but I can't test
-			    ;; this. More thought needed (???)
+(defun Man-strip-page-headers ()
+  "Strip all the page headers but the first from the manpage."
+  (let ((buffer-read-only nil)
+	(case-fold-search nil)
+	(page-list Man-page-list)
+	(page ())
+	(header ""))
+    (while page-list
+      (setq page (car page-list))
+      (and (nth 2 page)
+	   (goto-char (car page))
+	   (re-search-forward Man-first-heading-regexp nil t)
+	   (setq header (buffer-substring (car page) (match-beginning 0)))
+	   ;; Since the awk script collapses all successive blank
+	   ;; lines into one, and since we don't want to get rid of
+	   ;; the fast awk script, one must choose between adding
+	   ;; spare blank lines between pages when there were none and
+	   ;; deleting blank lines at page boundaries when there were
+	   ;; some.  We choose the first, so we comment the following
+	   ;; line.
+	   ;; (setq header (concat "\n" header)))
+	   (while (search-forward header (nth 1 page) t)
+	     (replace-match "")))
+      (setq page-list (cdr page-list)))))
+
+(defun Man-unindent ()
+  "Delete the leading spaces that indent the manpage."
+  (let ((buffer-read-only nil)
+	(case-fold-search nil)
+	(page-list Man-page-list))
+    (while page-list
+      (let ((page (car page-list))
+	    (indent "")
+	    (nindent 0))
+	(narrow-to-region (car page) (car (cdr page)))
+	(if Man-uses-untabify-flag
+	    (untabify (point-min) (point-max)))
+	(if (catch 'unindent
+	      (goto-char (point-min))
+	      (if (not (re-search-forward Man-first-heading-regexp nil t))
+		  (throw 'unindent nil))
+	      (beginning-of-line)
+	      (setq indent (buffer-substring (point)
+					     (progn
+					       (skip-chars-forward " ")
+					       (point))))
+	      (setq nindent (length indent))
+	      (if (zerop nindent)
+		  (throw 'unindent nil))
+	      (setq indent (concat indent "\\|$"))
+	      (goto-char (point-min))
+	      (while (not (eobp))
+		(if (looking-at indent)
+		    (forward-line 1)
+		  (throw 'unindent nil)))
+	      (goto-char (point-min)))
+	    (while (not (eobp))
+	      (or (eolp)
+		  (delete-char nindent))
+	      (forward-line 1)))
+	(setq page-list (cdr page-list))
+	))))
+
+
+;; ======================================================================
+;; Man mode commands
 
-			   (cond ((and section
-				       (not Manual-use-subdirectory-list))
-				  (concat "\\." (regexp-quote section)))
-                                 (exact
-                                  ;; If Manual-match-topic-exactly is
-                                  ;; set, then we must make sure the
-                                  ;; completions are exact, except for
-                                  ;; trailing weird characters after
-                                  ;; the section.
-                                  "\\.")
-                                 (t
-                                  ""))))
-          dir)
-      (while dirlist
-        (setq dir (car dirlist) dirlist (cdr dirlist))
-        (if (not (file-directory-p dir))
-            (progn
-              (message "warning: %s is not a directory" dir)
-              ;;(sit-for 1)
-              )
-            (let ((files (directory-files dir t match nil t))
-                  f)
-              (while files
-                (setq f (car files) files (cdr files))
-                (cond ((string-match Manual-bogus-file-pattern f)
-		       ;(message "Bogus fule %s" f) (sit-for 2)
-                       )
-		      ((and shadow (string-match shadow f))
-                       ;(message "Shadowed %s" f) (sit-for 2)
-                       )
-                      ((not (file-readable-p f))
-                       ;(message "Losing with %s" f) (sit-for 2)
-                       )
-                      (t
-                       (setq manlist (cons f manlist))))))))
-      (setq manlist (nreverse manlist))
-      (and Manual-unique-man-sections-only
-	   (setq manlist (Manual-clean-to-unique-pages-only manlist)))
-      (if (and manlist Manual-query-multiple-pages)
-          (apply #'append
-                 (mapcar #'(lambda (page)
-                             (and page 
-                                  (y-or-n-p (format "Read %s? " page))
-				  (list page)))
-                         manlist))
-          manlist))))
+(defun Man-next-section (n)
+  "Move point to Nth next section (default 1)."
+  (interactive "p")
+  (let ((case-fold-search nil))
+    (if (looking-at Man-heading-regexp)
+	(forward-line 1))
+    (if (re-search-forward Man-heading-regexp (point-max) t n)
+	(beginning-of-line)
+      (goto-char (point-max)))))
+
+(defun Man-previous-section (n)
+  "Move point to Nth previous section (default 1)."
+  (interactive "p")
+  (let ((case-fold-search nil))
+    (if (looking-at Man-heading-regexp)
+	(forward-line -1))
+    (if (re-search-backward Man-heading-regexp (point-min) t n)
+	(beginning-of-line)
+      (goto-char (point-min)))))
+
+(defun Man-find-section (section)
+  "Move point to SECTION if it exists, otherwise don't move point.
+Returns t if section is found, nil otherwise."
+  (let ((curpos (point))
+	(case-fold-search nil))
+    (goto-char (point-min))
+    (if (re-search-forward (concat "^" section) (point-max) t)
+	(progn (beginning-of-line) t)
+      (goto-char curpos)
+      nil)
+    ))
+
+(defun Man-goto-section ()
+  "Query for section to move point to."
+  (interactive)
+  (aput 'Man-sections-alist
+	(let* ((default (aheadsym Man-sections-alist))
+	       (completion-ignore-case t)
+	       chosen
+	       (prompt (concat "Go to section: (default " default ") ")))
+	  (setq chosen (completing-read prompt Man-sections-alist))
+	  (if (or (not chosen)
+		  (string= chosen ""))
+	      default
+	    chosen)))
+  (Man-find-section (aheadsym Man-sections-alist)))
+
+(defun Man-goto-see-also-section ()
+  "Move point the the \"SEE ALSO\" section.
+Actually the section moved to is described by `Man-see-also-regexp'."
+  (interactive)
+  (if (not (Man-find-section Man-see-also-regexp))
+      (error (concat "No " Man-see-also-regexp
+		     " section found in the current manpage"))))
 
-(defun Manual-clean-to-unique-pages-only (manlist)
-  "Prune the current list of pages down to a unique set."
-  (let (page-name unique-pages)
-    (apply 'append
-	   (mapcar '(lambda (page)
-		      (cond (page
-			     (and (string-match ".*/\\(.*\\)" page)
-				  (setq page-name (substring page (match-beginning 1)
-							     (match-end 1)))
-				  ;; try to clip off .Z, .gz suffixes
-				  (and (string-match "\\(.*\\)\\.\\(.+\\)\\.\\(.+\\)"
-						     page-name)
-				       (setq page-name
-					     (substring page-name (match-beginning 1)
-							(match-end 2)))))
-			     ;; add Manual-unique-pages if it isn't there
-			     ;;  and return file
-			     (if (and unique-pages
-				      page-name
-				      (string-match (concat "\\b" page-name "\\b")
-						    unique-pages))
-				 nil
-			       (setq unique-pages (concat unique-pages
-								 page-name
-								 " "))
-			       (list page)))))
-		   manlist))))
-			    
+(defun Man-follow-manual-reference (reference)
+  "Get one of the manpages referred to in the \"SEE ALSO\" section.
+Specify which reference to use; default is based on word at point."
+  (interactive
+   (if (not Man-refpages-alist)
+       (error "There are no references in the current man page")
+     (list (let* ((default (or
+			     (car (all-completions
+				   (save-excursion
+				     (skip-syntax-backward "w()")
+				     (skip-chars-forward " \t")
+				     (let ((word (current-word)))
+				       ;; strip a trailing '-':
+				       (if (string-match "-$" word)
+					   (substring word 0
+						      (match-beginning 0))
+					 word)))
+				   Man-refpages-alist))
+			     (aheadsym Man-refpages-alist)))
+		   chosen
+		   (prompt (concat "Refer to: (default " default ") ")))
+	      (setq chosen (completing-read prompt Man-refpages-alist nil t))
+	      (if (or (not chosen)
+		      (string= chosen ""))
+		  default
+		chosen)))))
+  (if (not Man-refpages-alist)
+      (error "Can't find any references in the current manpage")
+    (aput 'Man-refpages-alist reference)
+    (Man-getpage-in-background
+     (Man-translate-references (aheadsym Man-refpages-alist)))))
+
+(defun Man-kill ()
+  "Kill the buffer containing the manpage."
+  (interactive)
+  (let ((buff (current-buffer)))
+    (delete-windows-on buff)
+    (kill-buffer buff))
+  (if (and window-system
+	   (or (eq Man-notify-method 'newframe)
+	       (and pop-up-frames
+		    (eq Man-notify-method 'bully))))
+      (delete-frame)))
+
+(defun Man-quit ()
+  "Bury the buffer containing the manpage."
+  (interactive)
+  (let ((buff (current-buffer)))
+    (delete-windows-on buff)
+    (bury-buffer buff))
+  (if (and window-system
+	   (or (eq Man-notify-method 'newframe)
+	       (and pop-up-frames
+		    (eq Man-notify-method 'bully))))
+      (delete-frame)))
+
+(defun Man-goto-page (page)
+  "Go to the manual page on page PAGE."
+  (interactive
+   (if (not Man-page-list)
+       (let ((args Man-arguments))
+	 (kill-buffer (current-buffer))
+	 (error "Can't find the %s manpage" args))
+     (if (= (length Man-page-list) 1)
+	 (error "You're looking at the only manpage in the buffer")
+       (list (read-minibuffer (format "Go to manpage [1-%d]: "
+				      (length Man-page-list)))))))
+  (if (not Man-page-list)
+      (let ((args Man-arguments))
+	(kill-buffer (current-buffer))
+	(error "Can't find the %s manpage" args)))
+  (if (or (< page 1)
+	  (> page (length Man-page-list)))
+      (error "No manpage %d found" page))
+  (let* ((page-range (nth (1- page) Man-page-list))
+	 (page-start (car page-range))
+	 (page-end (car (cdr page-range))))
+    (setq Man-current-page page
+	  Man-page-mode-string (Man-make-page-mode-string))
+    (widen)
+    (goto-char page-start)
+    (narrow-to-region page-start page-end)
+    (Man-build-section-alist)
+    (Man-build-references-alist)
+    (goto-char (point-min))))
 
 
-(defun Manual-insert-man-file (name)
-  ;; Insert manual file (unpacked as necessary) into buffer
-  (cond ((equal (substring name -3) ".gz")
-	 (call-process "gunzip" nil t nil "--stdout" name))
-        ((or (equal (substring name -2) ".Z")
-	     ;; HPUX uses directory names that end in .Z and compressed
-	     ;; files that don't.  How gratuitously random.
-             (let ((case-fold-search nil))
-               (string-match "\\.Z/" name)))
-	 (call-process "zcat" name t nil)) ;; XEmacs change for HPUX
-	((equal (substring name -2) ".z")
-	 (call-process "pcat" nil t nil name))
-	(t
-	 (insert-file-contents name))))
-
-(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.)
-  (list 'delete-region '(point) (list '+ '(point) n)))
-
-;; Hint: BS stands for more things than "back space"
-(defun Manual-nuke-nroff-bs (&optional apropos-mode)
-  (interactive "*")
-  (if Manual-use-rosetta-man
-      (call-process-region (point-min) (point-max) "rman" t t nil)
-    ;;
-    ;; turn underlining into italics
-    ;;
-    (goto-char (point-min))
-    (while (search-forward "_\b" nil t)
-      ;; searching for underscore-backspace and then comparing the following
-      ;; chars until the sequence ends turns out to be much faster than searching
-      ;; for a regexp which matches the whole sequence.
-      (let ((s (match-beginning 0)))
-	(goto-char s)
-	(while (and (= (following-char) ?_)
-		    (= (char-after (1+ (point))) ?\b))
-	  (Manual-delete-char 2)
-	  (forward-char 1))
-	(set-extent-face (make-extent s (point)) 'man-italic)))
-    ;;
-    ;; turn overstriking into bold
-    ;;
-    (goto-char (point-min))
-    (while (re-search-forward "\\([^\n]\\)\\(\b\\1\\)" nil t)
-      ;; Surprisingly, searching for the above regexp is faster than searching
-      ;; for a backspace and then comparing the preceding and following chars,
-      ;; I presume because there are many false matches, meaning more funcalls
-      ;; to re-search-forward.
-      (let ((s (match-beginning 0)))
-	(goto-char s)
-	;; Some systems (SGI) overstrike multiple times, eg, "M\bM\bM\bM".
-	(while (looking-at "\\([^\n]\\)\\(\b\\1\\)+")
-	  (delete-region (+ (point) 1) (match-end 0))
-	  (forward-char 1))
-	(set-extent-face (make-extent s (point)) 'man-bold)))
-    ;;
-    ;; hack bullets: o^H+ --> +
-    (goto-char (point-min))
-    (while (search-forward "\b" nil t)
-      (Manual-delete-char -2))
-
-    (if (> (buffer-size) 100) ; minor kludge
-	(Manual-nuke-nroff-bs-footers))
-    ) ;; not Manual-use-rosetta-man
-  ;;
-  ;; turn subsection header lines into bold
-  ;;
-  (goto-char (point-min))
-  (if apropos-mode
-      (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t)
-	(forward-char -2)
-	(delete-backward-char 1))
-
-    ;;    (while (re-search-forward "^[^ \t\n]" nil t)
-    ;;      (set-extent-face (make-extent (match-beginning 0)
-    ;;                                   (progn (end-of-line) (point)))
-    ;;                      'man-heading))
-
-    ;; boldface the first line
-    (if (looking-at "[^ \t\n].*$")
-	(set-extent-face (make-extent (match-beginning 0) (match-end 0))
-			 'man-bold))
-
-    ;; boldface subsequent title lines
-    ;; 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
-    (while (re-search-forward "\n\n\\([^ \t\n].*\\)\n[ \t]+[^ \t\n]" nil t)
-      (goto-char (match-end 1))
-      (set-extent-face (make-extent (match-beginning 1) (match-end 1))
-		       'man-heading)
-      (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 "")))
-  
-  ;; Nuke blanks lines at start.
-  ;;  (goto-char (point-min))
-  ;;  (skip-chars-forward "\n")
-  ;;  (delete-region (point-min) (point))
-
-  (Manual-mouseify-xrefs)
-  )
-
-(fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name
-
-
-(defun Manual-nuke-nroff-bs-footers ()
-  ;; Nuke headers and footers.
-  ;;
-  ;; nroff assumes pages are 66 lines high.  We assume that, and that the
-  ;; first and last line on each page is expendible.  There is no way to
-  ;; tell the difference between a page break in the middle of a paragraph
-  ;; and a page break between paragraphs (the amount of extra whitespace
-  ;; that nroff inserts is the same in both cases) so this might strip out
-  ;; a blank line were one should remain.  I think that's better than
-  ;; leaving in a blank line where there shouldn't be one.  (Need I say
-  ;; it: FMH.)
-  ;;
-  ;; Note that if nroff spits out error messages, pages will be more than
-  ;; 66 lines high, and we'll lose badly.  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.)
-  ;; 
-  (goto-char (point-min))
-  ;; first lose the status output
-  (let ((case-fold-search t))
-    (if (and (not (looking-at "[^\n]*warning"))
-	     (looking-at "Reformatting.*\n"))
-	(delete-region (match-beginning 0) (match-end 0))))
-
-  ;; kludge around a groff bug where it won't keep quiet about some
-  ;; warnings even with -Wall or -Ww.
-  (cond ((looking-at "grotty:")
-	 (while (looking-at "grotty:")
-	   (delete-region (point) (progn (forward-line 1) (point))))
-	 (if (looking-at " *done\n")
-	     (delete-region (point) (match-end 0)))))
-
-  (let ((pages '())
-	p)
-    ;; collect the page boundary markers before we start deleting, to make
-    ;; it easier to strip things out without changing the page sizes.
-    (while (not (eobp))
-      (forward-line 66)
-      (setq pages (cons (point-marker) pages)))
-    (setq pages (nreverse pages))
-    (while pages
-      (goto-char (car pages))
-      (set-marker (car pages) nil)
-      ;;
-      ;; The lines are: 3 blank; footer; 6 blank; header; 3 blank.
-      ;; We're in between the previous footer and the following header,
-      ;;
-      ;; First lose 3 blank lines, the header, and then 3 more.
-      ;;
-      (setq p (point))
-      (skip-chars-forward "\n")
-      (delete-region p (point))
-      (and (looking-at "[^\n]+\n\n?\n?\n?")
-	   (delete-region (match-beginning 0) (match-end 0)))
-      ;;
-      ;; Next lose the footer, and the 3 blank lines after, and before it.
-      ;; But don't lose the last footer of the manual entry; that contains
-      ;; the "last change" date, so it's not completely uninteresting.
-      ;; (Actually lose all blank lines before it; sh(1) needs this.)
-      ;;
-      (skip-chars-backward "\n")
-      (beginning-of-line)
-      (if (null (cdr pages))
-	  nil
-	(and (looking-at "[^\n]+\n\n?\n?\n?")
-	     (delete-region (match-beginning 0) (match-end 0))))
-      (setq p (point))
-      (skip-chars-backward "\n")
-      (if (> (- p (point)) 4)
-	  (delete-region (+ 2 (point)) p)
-	(delete-region (1+ (point)) p))
-;      (and (looking-at "\n\n?\n?")
-;	   (delete-region (match-beginning 0) (match-end 0)))
+(defun Man-next-manpage ()
+  "Find the next manpage entry in the buffer."
+  (interactive)
+  (if (= (length Man-page-list) 1)
+      (error "This is the only manpage in the buffer"))
+  (if (< Man-current-page (length Man-page-list))
+      (Man-goto-page (1+ Man-current-page))
+    (if Man-circular-pages-flag
+	(Man-goto-page 1)
+      (error "You're looking at the last manpage in the buffer"))))
 
-      (setq pages (cdr pages)))
-    ;;
-    ;; Now nuke the extra blank lines at the beginning and end.
-    (goto-char (point-min))
-    (if (looking-at "\n+")
-	(delete-region (match-beginning 0) (match-end 0)))
-    (forward-line 1)
-    (if (looking-at "\n\n+")
-	(delete-region (1+ (match-beginning 0)) (match-end 0)))
-    (goto-char (point-max))
-    (skip-chars-backward "\n")
-    (delete-region (point) (point-max))
-    (beginning-of-line)
-    (forward-char -1)
-    (setq p (point))
-    (skip-chars-backward "\n")
-    (if (= ?\n (following-char)) (forward-char 1))
-    (if (> (point) (1+ p))
-	(delete-region (point) p))
-    ))
-
-;(defun Manual-nuke-nroff-bs-footers ()
-;  ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
-;  (goto-char (point-min))
-;  (while (re-search-forward "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Za-z]+)\\).*\\1$" nil t)
-;    (replace-match ""))
-;  
-;  ;;
-;  ;; it would appear that we have a choice between sometimes introducing
-;  ;; an extra blank line when a paragraph was broken by a footer, and
-;  ;; sometimes not putting in a blank line between two paragraphs when
-;  ;; a footer appeared right between them.  FMH; I choose the latter.
-;  ;;
-;
-;  ;; Nuke footers: "Printed 12/3/85	27 April 1981	1"
-;  ;;    Sun appear to be on drugz:
-;  ;;     "Sun Release 3.0B  Last change: 1 February 1985     1"
-;  ;;    HP are even worse!
-;  ;;     "     Hewlett-Packard   -1- (printed 12/31/99)"  FMHWA12ID!!
-;  ;;    System V (well WICATs anyway):
-;  ;;     "Page 1			  (printed 7/24/85)"
-;  ;;    Who is administering PCP to these corporate bozos?
-;  (goto-char (point-min))
-;  (while (re-search-forward
-;	   (cond
-;	    ((eq system-type 'hpux)
-;	     "\n\n?[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*\n")
-;	    ((eq system-type 'dgux-unix)
-;	     "\n\n?[ \t]*Licensed material--.*Page [0-9]*\n")
-;	    ((eq system-type 'usg-unix-v)
-;	     "\n\n? *Page [0-9]*.*(printed [0-9/]*)\n")
-;	    (t
-;	     "\n\n?\\(Printed\\|Sun Release\\) [0-9].*[0-9]\n"))
-;	   nil t)
-;    (replace-match ""))
-;
-;  ;;    Also, hack X footers:
-;  ;;     "X Version 11         Last change: Release 5         1"
-;  (goto-char (point-min))
-;  (while (re-search-forward "\n\n?X Version [^\n]+\n" nil t)
-;    (replace-match ""))
-;
-;  ;; Crunch blank lines
-;  (goto-char (point-min))
-;  (while (re-search-forward "\n\n\n\n*" nil t)
-;    (replace-match "\n\n"))
-;  )
+(defun Man-previous-manpage ()
+  "Find the previous manpage entry in the buffer."
+  (interactive)
+  (if (= (length Man-page-list) 1)
+      (error "This is the only manpage in the buffer"))
+  (if (> Man-current-page 1)
+      (Man-goto-page (1- Man-current-page))
+    (if Man-circular-pages-flag
+	(Man-goto-page (length Man-page-list))
+      (error "You're looking at the first manpage in the buffer"))))
+
+;; Init the man package variables, if not already done.
+(Man-init-defvars)
 
-(defun Manual-mouseify-xrefs ()
-  (goto-char (point-min))
-  (forward-line 1)
-  (let ((case-fold-search nil)
-	s e name 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)
-      (setq s (match-beginning 0)
-	    e (match-end 0)
-	    name (buffer-substring s e))
-      (goto-char s)
-      (skip-chars-backward " \t")
-      (if (and (bolp)
-	       (progn (backward-char 1) (= (preceding-char) ?-)))
-	  (progn
-	    (setq s (point))
-	    (skip-chars-backward "-a-zA-Z0-9_.")
-	    (setq name (concat (buffer-substring (point) (1- s)) name))
-	    (setq s (point))))
-      ;; 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))))))
-      ;; (setq already-fontified (extent-at s))
-      (setq extent (make-extent s e))
-      (set-extent-property extent 'man (list 'Manual-follow-xref name))
-      (set-extent-property extent 'highlight t)
-      ;; (if (not already-fontified)...
-      (set-extent-face extent 'man-xref)
-      (goto-char e))))
-
-(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")
-  (if (eventp name-or-event)
-      (let* ((p (event-point name-or-event))
-	     (extent (and p (extent-at p
-			     (event-buffer name-or-event)
-			     'highlight)))
-	     (data (and extent (extent-property extent 'man))))
-	(if (eq (car-safe data) 'Manual-follow-xref)
-	    (eval data)
-	  (error "no manual cross-reference there.")))
-    (let ((Manual-match-topic-exactly t)
-	  (Manual-query-multiple-pages nil))
-      (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)))))))
+(provide 'man)
 
-(defun Manual-popup-menu (&optional event)
-  "Pops 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."
-  (interactive "e")
-  (let ((buffer (current-buffer))
-	(sep "---")
-	(prefix "Show Manual Page for ")
-	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)))
-    (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 nil))
-      (popup-menu
-       (cons "Manual Entry"
-	     (mapcar #'(lambda (item)
-			 (if (eq item sep)
-			     item
-                           (vector (concat prefix item)
-                                   (list 'Manual-follow-xref item) t)))
-		     (nreverse items)))))))
-
-(defun pager-cleanup-hook ()
-  "cleanup man page if called via $PAGER"
-  (let ((buf-name (or buffer-file-name (buffer-name))))
-	(if (and (or (string-match "^/tmp/man[0-9]+" buf-name)
-		     (string-match ".*/man/\\(man\\|cat\\)[1-9a-z]/" buf-name))
-		 (not (string-match Manual-bogus-file-pattern buf-name)))
-	    (let (buffer manpage)
-	      (require 'man)
-	      (goto-char (point-min))
-	      (setq buffer-read-only nil)
-	      (Manual-nuke-nroff-bs)
-	      (goto-char (point-min))
-	      (if (re-search-forward "[^ \t]")
-		  (goto-char (- (point) 1)))
-	      (if (looking-at "\\([a-zA-Z0-9]+\\)[ \t]*(")
-		  (setq manpage (buffer-substring (match-beginning 1) (match-end 1)))
-		(setq manpage "???"))
-	      (setq buffer
-		    (rename-buffer
-		     (generate-new-buffer-name (concat "*man " manpage "*"))))
-	      (setq buffer-file-name nil)
-	      (goto-char (point-min))
-	      (insert (format "%s\n" buf-name))
-	      (goto-char (point-min))
-	      (buffer-disable-undo buffer)
-	      (set-buffer-modified-p nil)
-	      (Manual-mode)
-	      ))))
-
-(add-hook 'server-visit-hook 'pager-cleanup-hook)
-(provide 'man)
+;;; man.el ends here
diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/old-man.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/packages/old-man.el	Mon Aug 13 08:46:56 2007 +0200
@@ -0,0 +1,1225 @@
+;;; man.el --- browse UNIX manual pages
+;; Keywords: help
+
+;; Copyright (C) 1985, 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.
+
+;;; Synched up with: Not synched with FSF.
+;;; ICK!  This file is almost completely different from FSF.
+;;; Someone clarify please.
+
+;; Mostly rewritten by Alan K. Stebbens  11-apr-90.
+;;
+;;  o  Match multiple man pages using TOPIC as a simple pattern
+;;  o  Search unformatted pages, even when formatted matches are found
+;;  o  Query the user as to which pages are desired
+;;  o  Use of the prefix arg to toggle/bypass the above features
+;;  o  Buffers named by the first topic in the buffer
+;;  o  Automatic uncompress for compressed man pages (.Z, .z, and .gz)
+;;  o  View the resulting buffer using M-x view mode
+;;
+;; Modified 16-mar-91 by Jamie Zawinski  to default the 
+;; manual topic to the symbol at point, just like find-tag does.
+;;
+;; Modified 22-mar-93 by jwz to use multiple fonts and follow xrefs with mouse.
+;;
+;; Modified 16-apr-93 by Dave Gillespie  to make
+;; apropos work nicely; work correctly when bold or italic is unavailable; 
+;; reuse old buffer if topic is re-selected (in Manual-topic-buffer mode).
+;;
+;; Modified 4-apr-94 by jwz: merged in Tibor Polgar's code for manpath.conf.
+;;
+;; Modified 19-apr-94 by Tibor Polgar  to add support for
+;; $PAGER variable to be emacsclient and properly process man pages (assuming
+;; the man pages were built by man in /tmp.  also fixed bug with man list being
+;; backwards.
+;;
+;; Modified 23-aug-94 by Tibor Polgar  to add support for
+;; displaying only one instance of a man page (Manual-unique-man-sections-only)
+;; Fixed some more man page ordering bugs, bug with Manual-query-multiple-pages.
+;;
+;; Modified 29-nov-94 by Ben Wing : small fixes
+;; that should hopefully make things work under HPUX and IRIX.; 
+;;
+;; Modified 15-jul-95 by Dale Atems :
+;; some extensive rewriting to make things work right (more or less)
+;; under IRIX.
+;;
+;; Modified 08-mar-96 by Hubert Palme :
+;; added /usr/share/catman to the manual directory list for IRIX (5.3)
+;; 
+;; This file defines "manual-entry", and the remaining definitions all
+;; begin with "Manual-".  This makes the autocompletion on "M-x man" work.
+;;
+;; Variables of interest:
+;;
+;;	Manual-program
+;;	Manual-topic-buffer
+;;	Manual-buffer-view-mode
+;;	Manual-directory-list
+;;	Manual-formatted-directory-list
+;;	Manual-match-topic-exactly
+;;	Manual-query-multiple-pages
+;;	Manual-page-history
+;;	Manual-subdirectory-list
+;;	Manual-man-page-section-ids
+;;	Manual-formatted-page-prefix
+;;	Manual-unformatted-page-prefix
+;;	Manual-use-full-section-ids
+
+(defvar Manual-program "man" "\
+*Name of the program to invoke in order to format the source man pages.")
+
+(defvar Manual-section-switch (if (eq system-type 'usg-unix-v) "-s" nil)
+  "SysV needs this to work right.")
+
+(defvar Manual-topic-buffer t "\
+*Non-nil means \\[Manual-entry] should output the manual entry for TOPIC into
+a buffer named *man TOPIC*, otherwise, it should name the buffer
+*Manual Entry*.")
+
+(defvar Manual-buffer-view-mode t "\
+*Whether manual buffers should be placed in view-mode.
+nil means leave the buffer in fundamental-mode in another window.
+t means use `view-buffer' to display the man page in the current window.
+Any other value means use `view-buffer-other-window'.")
+
+(defvar Manual-match-topic-exactly t "\
+*Non-nil means that \\[manual-entry] will match the given TOPIC exactly, rather
+apply it as a pattern.  When this is nil, and \"Manual-query-multiple-pages\"
+is non-nil, then \\[manual-entry] will query you for all matching TOPICs.
+This variable only has affect on the preformatted man pages (the \"cat\" files),
+since the \"man\" command always does exact topic matches.")
+
+(defvar Manual-query-multiple-pages nil "\
+*Non-nil means that \\[manual-entry] will query the user about multiple man
+pages which match the given topic.  The query is done using the function 
+\"y-or-n-p\".  If this variable is nil, all man pages with topics matching the
+topic given to \\[manual-entry] will be inserted into the temporary buffer.
+See the variable \"Manual-match-topic-exactly\" to control the matching.")
+
+(defvar Manual-unique-man-sections-only nil
+  "*Only present one man page per section.  This variable is useful if the same or
+up/down level man pages for the same entry are present in mulitple man paths.
+When set to t, only the first entry found in a section is displayed, the others
+are ignored without any messages or warnings.  Note that duplicates can occur if
+the system has both formatted and unformatted version of the same page.")
+
+(defvar Manual-mode-hook nil
+  "Function or functions run on entry to Manual-mode.")
+
+(defvar Manual-directory-list nil "\
+*A list of directories used with the \"man\" command, where each directory
+contains a set of \"man?\" and \"cat?\" subdirectories.  If this variable is nil,
+it is initialized by \\[Manual-directory-list-init].")
+
+(defvar Manual-formatted-directory-list nil "\
+A list of directories containing formatted man pages.  Initialized by
+\\[Manual-directory-list-init].")
+
+(defvar Manual-unformatted-directory-list nil "\
+A list of directories containing the unformatted (source) man pages.  
+Initialized by \\[Manual-directory-list-init].")
+
+(defvar Manual-page-history nil "\
+A list of names of previously visited man page buffers.")
+
+(defvar Manual-manpath-config-file "/usr/lib/manpath.config"
+  "*Location of the manpath.config file, if any.")
+
+(defvar Manual-apropos-switch "-k"
+  "*Man apropos switch")
+
+;; New variables.
+
+(defvar Manual-subdirectory-list nil "\
+A list of all the subdirectories in which man pages may be found.
+Iniialized by Manual-directory-list-init.")
+
+;; This is for SGI systems; don't know what it should be otherwise.
+(defvar Manual-man-page-section-ids "1nl6823457poD" "\
+String containing all suffix characters for \"cat\" and \"man\"
+that identify valid sections of the Un*x manual.") 
+
+(defvar Manual-formatted-page-prefix "cat" "\
+Prefix for directories where formatted man pages are to be found.
+Defaults to \"cat\".")
+
+(defvar Manual-unformatted-page-prefix "man" "\
+Prefix for directories where unformatted man pages are to be found.
+Defaults to \"man\".")
+
+(defvar Manual-leaf-signature "" "\
+Regexp for identifying \"leaf\" subdirectories in the search path.
+If empty, initialized by Manual-directory-list-init.")
+
+(defvar Manual-use-full-section-ids t "\
+If non-nil, pass full section ids to Manual-program, otherwise pass
+only the first character. Defaults to 't'.")
+
+(defvar Manual-use-subdirectory-list (eq system-type 'irix) "\
+This makes manual-entry work correctly on SGI machines but it
+imposes a large startup cost which is why it is not simply on by
+default on all systems.")
+
+(defvar Manual-use-rosetta-man (not (null (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.
+
+Here is information on RosettaMan, from Neal.Becker@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 
!  Man page references are turned into hypertext links.")
+
+(make-face 'man-italic)
+(or (face-differs-from-default-p 'man-italic)
+    (copy-face 'italic 'man-italic))
+;; XEmacs (from Darrell Kindred): underlining is annoying due to
+;; large blank spaces in this face.
+;; (or (face-differs-from-default-p 'man-italic)
+;;    (set-face-underline-p 'man-italic t))
+
+(make-face 'man-bold)
+(or (face-differs-from-default-p 'man-bold)
+    (copy-face 'bold 'man-bold))
+(or (face-differs-from-default-p 'man-bold)
+    (copy-face 'man-italic 'man-bold))
+
+(make-face 'man-heading)
+(or (face-differs-from-default-p 'man-heading)
+    (copy-face 'man-bold 'man-heading))
+
+(make-face 'man-xref)
+(or (face-differs-from-default-p 'man-xref)
+    (set-face-underline-p 'man-xref t))
+
+;; Manual-directory-list-init
+;; Initialize the directory lists.
+
+(defun Manual-directory-list-init (&optional arg) 
+  "Initialize the Manual-directory-list variable from $MANPATH
+if it is not already set, or if a prefix argument is provided."
+  (interactive "P")
+  (if arg (setq Manual-directory-list nil))
+  (if (null Manual-directory-list)
+      (let ((manpath (getenv "MANPATH"))
+	    (global (Manual-manpath-config-contents))
+	    (dirlist nil)
+	    dir)
+	(cond ((and manpath global)
+	       (setq manpath (concat manpath ":" global)))
+	      (global
+	       (setq manpath global))
+	      ((not manpath)
+	       ;; XEmacs - (bpw/stig) Unix-specifix hack for lusers w/ no manpath
+	       (setq manpath "/usr/local/man:/usr/share/man:/usr/share/catman:/usr/contrib/man:/usr/X11/man:/usr/man:/usr/catman")))
+	;; Make sure that any changes we've made internally are seen by man.
+	(setenv "MANPATH" manpath)
+	(while (string-match "\\`:*\\([^:]+\\)" manpath)
+	  (setq dir (substring manpath (match-beginning 1) (match-end 1)))
+	  (and (not (member dir dirlist))
+	       (setq dirlist (cons dir dirlist)))
+	  (setq manpath (substring manpath (match-end 0))))
+	(setq dirlist (nreverse dirlist))
+	(setq Manual-directory-list dirlist)
+	(setq Manual-subdirectory-list nil)
+	(setq Manual-formatted-directory-list nil)
+	(setq Manual-unformatted-directory-list nil)))
+  (if (string-equal Manual-leaf-signature "")
+      (setq Manual-leaf-signature
+	    (concat "/\\("
+		    Manual-formatted-page-prefix
+		    "\\|" Manual-unformatted-page-prefix
+		    "\\)"
+		    "[" Manual-man-page-section-ids
+		    "].?/.")))
+  (if Manual-use-subdirectory-list
+      (progn
+	(if (null Manual-subdirectory-list)
+	    (setq Manual-subdirectory-list
+		  (Manual-all-subdirectories Manual-directory-list
+					     Manual-leaf-signature nil)))
+	(if (null Manual-formatted-directory-list)
+	    (setq Manual-formatted-directory-list
+		  (Manual-filter-subdirectories Manual-subdirectory-list
+						Manual-formatted-page-prefix)))
+	(if (null Manual-unformatted-directory-list)
+	    (setq Manual-unformatted-directory-list
+		  (Manual-filter-subdirectories Manual-subdirectory-list
+						Manual-unformatted-page-prefix))))
+    (if (null Manual-formatted-directory-list)
+        (setq Manual-formatted-directory-list
+	      (Manual-select-subdirectories Manual-directory-list
+					    Manual-formatted-page-prefix)))
+    (if (null Manual-unformatted-directory-list)
+        (setq Manual-unformatted-directory-list
+	      (Manual-select-subdirectories Manual-directory-list
+					    Manual-unformatted-page-prefix)))))
+
+
+(defun Manual-manpath-config-contents ()
+  "Parse the `Manual-manpath-config-file' file, if any.
+Returns a string like in $MANPATH."
+  (if (and Manual-manpath-config-file
+	   (file-readable-p Manual-manpath-config-file))
+      (let ((buf (get-buffer-create " *Manual-config*"))
+	    path)
+	(set-buffer buf)
+	(buffer-disable-undo buf)
+	(erase-buffer)
+	(insert-file-contents Manual-manpath-config-file)
+	(while (re-search-forward "^\\(MANDATORY_MANPATH\\|MANPATH_MAP\\)"
+				  nil t)
+	  (and (re-search-forward "\\(/[^ \t\n]+\\)[ \t]*$")
+	       (setq path (concat path (buffer-substring (match-beginning 1)
+							 (match-end 1))
+				  ":"))))
+	(kill-buffer buf)
+	path)))
+;;
+;; manual-entry  -- The "main" user function
+;;
+
+;;;###autoload
+(defun manual-entry (topic &optional arg silent)
+  "Display the Unix manual entry (or entries) for TOPIC.
+If prefix arg is given, modify the search according to the value:
+  2 = complement default exact matching of the TOPIC name;
+      exact matching default is specified by `Manual-match-topic-exactly'
+  3 = force a search of the unformatted man directories
+  4 = both 2 and 3
+The manual entries are searched according to the variable
+Manual-directory-list, which should be a list of directories.  If
+Manual-directory-list is nil, \\[Manual-directory-list-init] is
+invoked to create this list from the MANPATH environment variable.
+See the variable Manual-topic-buffer which controls how the buffer
+is named.  See also the variables Manual-match-topic-exactly,
+Manual-query-multiple-pages, and Manual-buffer-view-mode."
+  (interactive
+   (list (let* ((fmh "-A-Za-z0-9_.")
+		(default (save-excursion
+			   (buffer-substring
+			    (progn
+			      (re-search-backward "\\sw" nil t)
+			      (skip-chars-backward fmh) (point))
+			    (progn (skip-chars-forward fmh) (point)))))
+		(thing (read-string
+			(if (equal default "") "Manual entry: "
+			  (concat "Manual entry: (default " default ") ")))))
+	   (if (equal thing "") default thing))
+	 (prefix-numeric-value current-prefix-arg)))
+  ;;(interactive "sManual entry (topic): \np")
+  (or arg (setq arg 1))
+  (Manual-directory-list-init nil)
+  (let ((exact (if (or (= arg 2) (= arg 4))
+		   (not Manual-match-topic-exactly)
+		 Manual-match-topic-exactly))
+	(force (if (>= arg 3)
+                   t
+                   nil))
+	section fmtlist manlist apropos-mode)
+    (let ((case-fold-search nil))
+      (if (and (null section)
+	       (string-match
+		"\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic))
+	  (setq section (substring topic (match-beginning 2)
+				   (match-end 2))
+		topic (substring topic (match-beginning 1)
+				 (match-end 1)))
+	(if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic)
+	    (setq section "-k"
+		  topic (substring topic (match-beginning 1))))))
+    (if (equal section "-k")
+	(setq apropos-mode t)
+      (or silent
+	  (message "Looking for formatted entry for %s%s..."
+		   topic (if section (concat "(" section ")") "")))
+      (setq fmtlist (Manual-select-man-pages
+                      Manual-formatted-directory-list
+                      topic section exact '()))
+      (if (or force (not section) (null fmtlist))
+	  (progn
+	    (or silent
+		(message "%sooking for unformatted entry for %s%s..."
+			 (if fmtlist "L" "No formatted entry, l")
+			 topic (if section (concat "(" section ")") "")))
+	    (setq manlist (Manual-select-man-pages
+                            Manual-unformatted-directory-list
+                            topic section exact (if force '() fmtlist))))))
+
+    ;; Delete duplicate man pages (a file of the same name in multiple
+    ;; directories.)
+    (or nil ;force
+        (let ((rest (append fmtlist manlist)))
+          (while rest
+            (let ((rest2 (cdr rest)))
+              (while rest2
+                (if (equal (file-name-nondirectory (car rest))
+                           (file-name-nondirectory (car rest2)))
+                    (setq fmtlist (delq (car rest2) fmtlist)
+                          manlist (delq (car rest2) manlist)))
+                (setq rest2 (cdr rest2))))
+            (setq rest (cdr rest)))))
+
+    (if (not (or fmtlist manlist apropos-mode))
+        (progn
+          (message "No entries found for %s%s" topic
+                   (if section (concat "(" section ")") ""))
+          nil)
+      (let ((bufname (cond ((not Manual-topic-buffer)
+                            ;; What's the point of retaining this?
+                            (if apropos-mode
+                                "*Manual Apropos*"
+                                "*Manual Entry*"))
+                           (apropos-mode
+                            (concat "*man apropos " topic "*"))
+                           (t
+                            (concat "*man "
+                                    (cond (exact
+                                           (if section
+                                               (concat topic "." section)
+                                               topic))
+                                          ((or (cdr fmtlist) (cdr manlist)
+                                               (and fmtlist manlist))
+                                           ;; more than one entry found
+                                           (concat topic "..."))
+                                          (t
+                                           (file-name-nondirectory
+                                            (car (or fmtlist manlist)))))
+                                    "*"))))
+            (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))))
+
+        (if apropos-mode
+            (setq manlist (list (format "%s.%s" topic section))))
+
+        (cond
+          ((and Manual-topic-buffer (get-buffer bufname))
+           ;; reselect an old man page buffer if it exists already.
+           (save-excursion
+             (set-buffer (get-buffer bufname))
+             (Manual-mode))
+           (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)
+	       (Manual-insert-pages fmtlist manlist apropos-mode)
+               (set-buffer-modified-p nil)
+               (Manual-mode)
+               ))))
+        (setq Manual-page-history
+              (cons (buffer-name)
+                    (delete (buffer-name) Manual-page-history)))
+        (message nil)
+        t))))
+
+(defun Manpage-apropos (topic &optional arg silent)
+  "Apropos on Unix manual pages for TOPIC.
+It calls the function `manual-entry'. Look at this function for
+further description. Look also at the variable `Manual-apropos-switch',
+if this function doesn't work on your system."
+  (interactive
+   (list (let* ((fmh "-A-Za-z0-9_.")
+		(default (save-excursion
+			   (buffer-substring
+			    (progn
+			      (re-search-backward "\\sw" nil t)
+			      (skip-chars-backward fmh) (point))
+			    (progn (skip-chars-forward fmh) (point)))))
+		(thing (read-string
+			(if (equal default "") "Manual entry: "
+			  (concat "Manual entry: (default " default ") ")))))
+	   (if (equal thing "") default thing))
+	 (prefix-numeric-value current-prefix-arg)))
+  (manual-entry (concat Manual-apropos-switch " " topic) arg silent))
+
+(defun Manual-insert-pages (fmtlist manlist apropos-mode)
+  (let ((sep (make-string 65 ?-))
+	name start end topic section)
+    (while fmtlist			; insert any formatted files
+      (setq name (car fmtlist))
+      (goto-char (point-max))
+      (setq start (point))
+      ;; In case the file can't be read or uncompressed or
+      ;; something like that.
+      (condition-case ()
+	  (Manual-insert-man-file name)
+	(file-error nil))
+      (goto-char (point-max))
+      (setq end (point))
+      (save-excursion
+	(save-restriction
+	  (message "Cleaning manual entry for %s..."
+		   (file-name-nondirectory name))
+	  (narrow-to-region start end)
+	  (Manual-nuke-nroff-bs)
+	  (goto-char (point-min))
+	  (insert "File: " name "\n")
+	  (goto-char (point-max))
+	  ))
+      (if (or (cdr fmtlist) manlist)
+	  (insert "\n\n" sep "\n"))
+      (setq fmtlist (cdr fmtlist)))
+
+    (while manlist			; process any unformatted files
+      (setq name (car manlist))
+      (or (string-match "\\([^/]+\\)\\.\\([^./]+\\)\\(\\.gz\\'\\)" name)
+	  (string-match "\\([^/]+\\)\\.\\([^./]+\\)\\'" name))
+      (setq topic (substring name (match-beginning 1) (match-end 1)))
+      (setq section (substring name (match-beginning 2) (match-end 2)))
+      ;; This won't work under IRIX, because SGI man accepts only the
+      ;; "main" (one-character) section id, not full section ids
+      ;; like 1M, 3X, etc. Put (setq Manual-use-full-section-ids nil)
+      ;; in your .emacs to work around this problem.
+      (if (not (or Manual-use-full-section-ids (string-equal section "")))
+	  (setq section (substring section 0 1)))
+      (message "Invoking man %s%s %s..."
+	       (if Manual-section-switch
+		   (concat Manual-section-switch " ")
+		 "")
+	       section topic)
+      (setq start (point))
+      (Manual-run-formatter name topic section)
+      (setq end (point))
+      (save-excursion
+	(save-restriction
+	  (message "Cleaning manual entry for %s(%s)..." topic section)
+	  (narrow-to-region start end)
+	  (Manual-nuke-nroff-bs apropos-mode)
+	  (goto-char (point-min))
+	  (insert "File: " name "\n")
+	  (goto-char (point-max))
+	  ))
+      (if (cdr manlist)
+	  (insert "\n\n" sep "\n"))
+      (setq manlist (cdr manlist))))
+  (if (< (buffer-size) 200)
+      (progn
+	(goto-char (point-min))
+	(if (looking-at "^File: ")
+	    (forward-line 1))
+	(error (buffer-substring (point) (progn (end-of-line) (point))))))
+  nil)
+
+
+(defun Manual-run-formatter (name topic section)
+  (cond
+   ((string-match "roff\\'" Manual-program)
+    ;; kludge kludge
+    (call-process Manual-program nil t nil "-Tman" "-man" name))
+
+   (t
+    (call-process Manual-program nil t nil
+                  (concat Manual-section-switch section) topic))))
+
+   ;(Manual-use-rosetta-man
+   ; (call-process "/bin/sh" nil t nil "-c"
+   ;               (format "man %s %s | rman" section topic)))
+
+
+(defvar Manual-mode-map
+  (let ((m (make-sparse-keymap)))
+    (set-keymap-name m 'Manual-mode-map)
+    (define-key m "l" 'Manual-last-page)
+    (define-key m 'button2 'Manual-follow-xref)
+    (define-key m 'button3 'Manual-popup-menu)
+    m))
+
+(defun Manual-mode ()
+  (kill-all-local-variables)
+  (setq buffer-read-only t)
+  (use-local-map Manual-mode-map)
+  (setq major-mode 'Manual-mode
+	mode-name "Manual")
+  ;; man pages with long lines are buggy!
+  ;; This looks slightly better if they only
+  ;; overran by a couple of chars.
+  (setq truncate-lines t)
+  (if (featurep 'scrollbar)
+      ;; turn off horizontal scrollbars in this buffer
+      (set-specifier scrollbar-height (cons (current-buffer) 0)))
+  (run-hooks 'Manual-mode-hook))
+
+(defun Manual-last-page ()
+  (interactive)
+  (while (or (not (get-buffer (car (or Manual-page-history
+				       (error "No more history.")))))
+	     (eq (get-buffer (car Manual-page-history)) (current-buffer)))
+    (setq Manual-page-history (cdr Manual-page-history)))
+  (switch-to-buffer (car Manual-page-history)))
+
+
+;; Manual-select-subdirectories
+;; Given a DIRLIST and a SUBDIR name, return all subdirectories of the former which
+;; match the latter.
+
+(defun Manual-select-subdirectories (dirlist subdir)
+  (let ((dirs '())
+        (case-fold-search nil)
+        (match (concat "\\`" (regexp-quote subdir)))
+        d)
+    (while dirlist
+      (setq d (car dirlist) dirlist (cdr dirlist))
+      (if (file-directory-p d)
+          (let ((files (directory-files d t match nil 'dirs-only))
+		(dir-temp '()))
+            (while files
+              (if (file-executable-p (car files))
+                  (setq dir-temp (cons (file-name-as-directory (car files))
+                                   dir-temp)))
+              (setq files (cdr files)))
+	    (and dir-temp
+		 (setq dirs (append dirs (nreverse dir-temp)))))))
+    dirs))
+
+
+;; Manual-filter-subdirectories
+;; Given a DIRLIST and a SUBDIR name, return all members of the former
+;; which match the latter.
+
+(defun Manual-filter-subdirectories (dirlist subdir)
+  (let ((match (concat
+		"/"
+		(regexp-quote subdir)
+		"[" Manual-man-page-section-ids "]"))
+	slist dir)
+    (while dirlist
+      (setq dir (car dirlist) dirlist (cdr dirlist))
+      (if (and (file-executable-p dir) (string-match match dir))
+	    (setq slist (cons dir slist))))
+    (nreverse slist)))
+
+
+(defun Manual-all-subdirectories (dirlist leaf-signature dirs &optional silent) "\
+Given a DIRLIST, return a backward-sorted list of all subdirectories
+thereof, prepended to DIRS if non-nil. This function calls itself
+recursively until subdirectories matching LEAF-SIGNATURE are reached,
+or the hierarchy has been thoroughly searched. This code is a modified
+version of a function written by Tim Bradshaw (tfb@ed.ac.uk)."
+  (Manual-all-subdirectories-noloop dirlist leaf-signature dirs nil silent))
+
+(defun Manual-all-subdirectories-noloop (dirlist leaf-signature dirs been &optional silent) "\
+Does the job of manual-all-subdirectories and keeps track of where it
+has been to avoid loops."
+  (let (dir)
+    (while dirlist
+      (setq dir (car dirlist) dirlist (cdr dirlist))
+      (if (file-directory-p dir)
+	  (let ((dir-temp (cons (file-name-as-directory dir) dirs)))
+	    ;; Without feedback the user might wonder about the delay!
+	    (or silent (message
+			"Building list of search directories... %s"
+			(car dir-temp)))
+	    (if (member (file-truename dir) been)
+		()		 ; Ignore. We have been here before
+	      (setq been (cons (file-truename dir) been))
+	      (setq dirs
+		    (if (string-match leaf-signature dir)
+			dir-temp
+		      (Manual-all-subdirectories-noloop
+		       (directory-files dir t "[^.]$" nil 'dirs-only)
+		       leaf-signature dir-temp been silent))))))))
+  dirs)
+
+
+(defvar Manual-bogus-file-pattern "\\.\\(lpr\\|ps\\|PS\\)\\'"
+  "Some systems have files in the man/man*/ directories which aren't man pages.
+This pattern is used to prune those files.")
+
+;; Manual-select-man-pages
+;;
+;; Given a DIRLIST, discover all filenames which complete given the TOPIC
+;; and SECTION.
+
+;; ## Note: BSD man looks for .../man1/foo.1 and .../man1/$MACHINE/foo.1
+
+;; ## Fixed for SGI IRIX 5.x on Sat Jul 15 1995 by Dale Atems
+;; (atems@physics.wayne.edu).
+
+(defun Manual-select-man-pages (dirlist topic section exact shadow)
+  (let ((case-fold-search nil))
+    (and section
+      (let ((l '())
+	    ;;(match (concat (substring section 0 1) "/?\\'"))
+	    ;;                                          ^^^
+	    ;; We'll lose any pages inside subdirectories of the "standard"
+	    ;; ones if we insist on this! The following regexp should
+	    ;; match any directory ending with the full section id or
+	    ;; its first character, or any direct subdirectory thereof:
+	    (match (concat "\\("
+			   (regexp-quote section)
+			   "\\|"
+			   (substring section 0 1)
+			   "\\)/?"))
+	    d)
+	(while dirlist
+	  (setq d (car dirlist) dirlist (cdr dirlist))
+	  (if (string-match match d)
+	      (setq l (cons d l))))
+	(setq dirlist l)))
+    (if shadow
+        (setq shadow (concat "/\\("
+                             (mapconcat #'(lambda (n)
+                                            (regexp-quote
+                                             (file-name-nondirectory n)))
+                                        shadow
+                                        "\\|")
+                             "\\)\\'")))
+    (let ((manlist '())
+          (match (concat "\\`"
+                           (regexp-quote topic)
+			    ;; **Note: on IRIX the preformatted pages
+			    ;; are packed, so they end with ".z". This
+			    ;; way you miss them if you specify a
+			    ;; section. I don't see any point to it here
+			    ;; even on BSD systems since we're looking
+			    ;; one level down already, but I can't test
+			    ;; this. More thought needed (???)
+
+			   (cond ((and section
+				       (not Manual-use-subdirectory-list))
+				  (concat "\\." (regexp-quote section)))
+                                 (exact
+                                  ;; If Manual-match-topic-exactly is
+                                  ;; set, then we must make sure the
+                                  ;; completions are exact, except for
+                                  ;; trailing weird characters after
+                                  ;; the section.
+                                  "\\.")
+                                 (t
+                                  ""))))
+          dir)
+      (while dirlist
+        (setq dir (car dirlist) dirlist (cdr dirlist))
+        (if (not (file-directory-p dir))
+            (progn
+              (message "warning: %s is not a directory" dir)
+              ;;(sit-for 1)
+              )
+            (let ((files (directory-files dir t match nil t))
+                  f)
+              (while files
+                (setq f (car files) files (cdr files))
+                (cond ((string-match Manual-bogus-file-pattern f)
+		       ;(message "Bogus fule %s" f) (sit-for 2)
+                       )
+		      ((and shadow (string-match shadow f))
+                       ;(message "Shadowed %s" f) (sit-for 2)
+                       )
+                      ((not (file-readable-p f))
+                       ;(message "Losing with %s" f) (sit-for 2)
+                       )
+                      (t
+                       (setq manlist (cons f manlist))))))))
+      (setq manlist (nreverse manlist))
+      (and Manual-unique-man-sections-only
+	   (setq manlist (Manual-clean-to-unique-pages-only manlist)))
+      (if (and manlist Manual-query-multiple-pages)
+          (apply #'append
+                 (mapcar #'(lambda (page)
+                             (and page 
+                                  (y-or-n-p (format "Read %s? " page))
+				  (list page)))
+                         manlist))
+          manlist))))
+
+(defun Manual-clean-to-unique-pages-only (manlist)
+  "Prune the current list of pages down to a unique set."
+  (let (page-name unique-pages)
+    (apply 'append
+	   (mapcar '(lambda (page)
+		      (cond (page
+			     (and (string-match ".*/\\(.*\\)" page)
+				  (setq page-name (substring page (match-beginning 1)
+							     (match-end 1)))
+				  ;; try to clip off .Z, .gz suffixes
+				  (and (string-match "\\(.*\\)\\.\\(.+\\)\\.\\(.+\\)"
+						     page-name)
+				       (setq page-name
+					     (substring page-name (match-beginning 1)
+							(match-end 2)))))
+			     ;; add Manual-unique-pages if it isn't there
+			     ;;  and return file
+			     (if (and unique-pages
+				      page-name
+				      (string-match (concat "\\b" page-name "\\b")
+						    unique-pages))
+				 nil
+			       (setq unique-pages (concat unique-pages
+								 page-name
+								 " "))
+			       (list page)))))
+		   manlist))))
+			    
+
+
+(defun Manual-insert-man-file (name)
+  ;; Insert manual file (unpacked as necessary) into buffer
+  (cond ((equal (substring name -3) ".gz")
+	 (call-process "gunzip" nil t nil "--stdout" name))
+        ((or (equal (substring name -2) ".Z")
+	     ;; HPUX uses directory names that end in .Z and compressed
+	     ;; files that don't.  How gratuitously random.
+             (let ((case-fold-search nil))
+               (string-match "\\.Z/" name)))
+	 (call-process "zcat" name t nil)) ;; XEmacs change for HPUX
+	((equal (substring name -2) ".z")
+	 (call-process "pcat" nil t nil name))
+	(t
+	 (insert-file-contents name))))
+
+(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.)
+  (list 'delete-region '(point) (list '+ '(point) n)))
+
+;; Hint: BS stands for more things than "back space"
+(defun Manual-nuke-nroff-bs (&optional apropos-mode)
+  (interactive "*")
+  (if Manual-use-rosetta-man
+      (call-process-region (point-min) (point-max) "rman" t t nil)
+    ;;
+    ;; turn underlining into italics
+    ;;
+    (goto-char (point-min))
+    (while (search-forward "_\b" nil t)
+      ;; searching for underscore-backspace and then comparing the following
+      ;; chars until the sequence ends turns out to be much faster than searching
+      ;; for a regexp which matches the whole sequence.
+      (let ((s (match-beginning 0)))
+	(goto-char s)
+	(while (and (= (following-char) ?_)
+		    (= (char-after (1+ (point))) ?\b))
+	  (Manual-delete-char 2)
+	  (forward-char 1))
+	(set-extent-face (make-extent s (point)) 'man-italic)))
+    ;;
+    ;; turn overstriking into bold
+    ;;
+    (goto-char (point-min))
+    (while (re-search-forward "\\([^\n]\\)\\(\b\\1\\)" nil t)
+      ;; Surprisingly, searching for the above regexp is faster than searching
+      ;; for a backspace and then comparing the preceding and following chars,
+      ;; I presume because there are many false matches, meaning more funcalls
+      ;; to re-search-forward.
+      (let ((s (match-beginning 0)))
+	(goto-char s)
+	;; Some systems (SGI) overstrike multiple times, eg, "M\bM\bM\bM".
+	(while (looking-at "\\([^\n]\\)\\(\b\\1\\)+")
+	  (delete-region (+ (point) 1) (match-end 0))
+	  (forward-char 1))
+	(set-extent-face (make-extent s (point)) 'man-bold)))
+    ;;
+    ;; hack bullets: o^H+ --> +
+    (goto-char (point-min))
+    (while (search-forward "\b" nil t)
+      (Manual-delete-char -2))
+
+    (if (> (buffer-size) 100) ; minor kludge
+	(Manual-nuke-nroff-bs-footers))
+    ) ;; not Manual-use-rosetta-man
+  ;;
+  ;; turn subsection header lines into bold
+  ;;
+  (goto-char (point-min))
+  (if apropos-mode
+      (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t)
+	(forward-char -2)
+	(delete-backward-char 1))
+
+    ;;    (while (re-search-forward "^[^ \t\n]" nil t)
+    ;;      (set-extent-face (make-extent (match-beginning 0)
+    ;;                                   (progn (end-of-line) (point)))
+    ;;                      'man-heading))
+
+    ;; boldface the first line
+    (if (looking-at "[^ \t\n].*$")
+	(set-extent-face (make-extent (match-beginning 0) (match-end 0))
+			 'man-bold))
+
+    ;; boldface subsequent title lines
+    ;; 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
+    (while (re-search-forward "\n\n\\([^ \t\n].*\\)\n[ \t]+[^ \t\n]" nil t)
+      (goto-char (match-end 1))
+      (set-extent-face (make-extent (match-beginning 1) (match-end 1))
+		       'man-heading)
+      (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 "")))
+  
+  ;; Nuke blanks lines at start.
+  ;;  (goto-char (point-min))
+  ;;  (skip-chars-forward "\n")
+  ;;  (delete-region (point-min) (point))
+
+  (Manual-mouseify-xrefs)
+  )
+
+(fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name
+
+
+(defun Manual-nuke-nroff-bs-footers ()
+  ;; Nuke headers and footers.
+  ;;
+  ;; nroff assumes pages are 66 lines high.  We assume that, and that the
+  ;; first and last line on each page is expendible.  There is no way to
+  ;; tell the difference between a page break in the middle of a paragraph
+  ;; and a page break between paragraphs (the amount of extra whitespace
+  ;; that nroff inserts is the same in both cases) so this might strip out
+  ;; a blank line were one should remain.  I think that's better than
+  ;; leaving in a blank line where there shouldn't be one.  (Need I say
+  ;; it: FMH.)
+  ;;
+  ;; Note that if nroff spits out error messages, pages will be more than
+  ;; 66 lines high, and we'll lose badly.  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.)
+  ;; 
+  (goto-char (point-min))
+  ;; first lose the status output
+  (let ((case-fold-search t))
+    (if (and (not (looking-at "[^\n]*warning"))
+	     (looking-at "Reformatting.*\n"))
+	(delete-region (match-beginning 0) (match-end 0))))
+
+  ;; kludge around a groff bug where it won't keep quiet about some
+  ;; warnings even with -Wall or -Ww.
+  (cond ((looking-at "grotty:")
+	 (while (looking-at "grotty:")
+	   (delete-region (point) (progn (forward-line 1) (point))))
+	 (if (looking-at " *done\n")
+	     (delete-region (point) (match-end 0)))))
+
+  (let ((pages '())
+	p)
+    ;; collect the page boundary markers before we start deleting, to make
+    ;; it easier to strip things out without changing the page sizes.
+    (while (not (eobp))
+      (forward-line 66)
+      (setq pages (cons (point-marker) pages)))
+    (setq pages (nreverse pages))
+    (while pages
+      (goto-char (car pages))
+      (set-marker (car pages) nil)
+      ;;
+      ;; The lines are: 3 blank; footer; 6 blank; header; 3 blank.
+      ;; We're in between the previous footer and the following header,
+      ;;
+      ;; First lose 3 blank lines, the header, and then 3 more.
+      ;;
+      (setq p (point))
+      (skip-chars-forward "\n")
+      (delete-region p (point))
+      (and (looking-at "[^\n]+\n\n?\n?\n?")
+	   (delete-region (match-beginning 0) (match-end 0)))
+      ;;
+      ;; Next lose the footer, and the 3 blank lines after, and before it.
+      ;; But don't lose the last footer of the manual entry; that contains
+      ;; the "last change" date, so it's not completely uninteresting.
+      ;; (Actually lose all blank lines before it; sh(1) needs this.)
+      ;;
+      (skip-chars-backward "\n")
+      (beginning-of-line)
+      (if (null (cdr pages))
+	  nil
+	(and (looking-at "[^\n]+\n\n?\n?\n?")
+	     (delete-region (match-beginning 0) (match-end 0))))
+      (setq p (point))
+      (skip-chars-backward "\n")
+      (if (> (- p (point)) 4)
+	  (delete-region (+ 2 (point)) p)
+	(delete-region (1+ (point)) p))
+;      (and (looking-at "\n\n?\n?")
+;	   (delete-region (match-beginning 0) (match-end 0)))
+
+      (setq pages (cdr pages)))
+    ;;
+    ;; Now nuke the extra blank lines at the beginning and end.
+    (goto-char (point-min))
+    (if (looking-at "\n+")
+	(delete-region (match-beginning 0) (match-end 0)))
+    (forward-line 1)
+    (if (looking-at "\n\n+")
+	(delete-region (1+ (match-beginning 0)) (match-end 0)))
+    (goto-char (point-max))
+    (skip-chars-backward "\n")
+    (delete-region (point) (point-max))
+    (beginning-of-line)
+    (forward-char -1)
+    (setq p (point))
+    (skip-chars-backward "\n")
+    (if (= ?\n (following-char)) (forward-char 1))
+    (if (> (point) (1+ p))
+	(delete-region (point) p))
+    ))
+
+;(defun Manual-nuke-nroff-bs-footers ()
+;  ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
+;  (goto-char (point-min))
+;  (while (re-search-forward "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Za-z]+)\\).*\\1$" nil t)
+;    (replace-match ""))
+;  
+;  ;;
+;  ;; it would appear that we have a choice between sometimes introducing
+;  ;; an extra blank line when a paragraph was broken by a footer, and
+;  ;; sometimes not putting in a blank line between two paragraphs when
+;  ;; a footer appeared right between them.  FMH; I choose the latter.
+;  ;;
+;
+;  ;; Nuke footers: "Printed 12/3/85	27 April 1981	1"
+;  ;;    Sun appear to be on drugz:
+;  ;;     "Sun Release 3.0B  Last change: 1 February 1985     1"
+;  ;;    HP are even worse!
+;  ;;     "     Hewlett-Packard   -1- (printed 12/31/99)"  FMHWA12ID!!
+;  ;;    System V (well WICATs anyway):
+;  ;;     "Page 1			  (printed 7/24/85)"
+;  ;;    Who is administering PCP to these corporate bozos?
+;  (goto-char (point-min))
+;  (while (re-search-forward
+;	   (cond
+;	    ((eq system-type 'hpux)
+;	     "\n\n?[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*\n")
+;	    ((eq system-type 'dgux-unix)
+;	     "\n\n?[ \t]*Licensed material--.*Page [0-9]*\n")
+;	    ((eq system-type 'usg-unix-v)
+;	     "\n\n? *Page [0-9]*.*(printed [0-9/]*)\n")
+;	    (t
+;	     "\n\n?\\(Printed\\|Sun Release\\) [0-9].*[0-9]\n"))
+;	   nil t)
+;    (replace-match ""))
+;
+;  ;;    Also, hack X footers:
+;  ;;     "X Version 11         Last change: Release 5         1"
+;  (goto-char (point-min))
+;  (while (re-search-forward "\n\n?X Version [^\n]+\n" nil t)
+;    (replace-match ""))
+;
+;  ;; Crunch blank lines
+;  (goto-char (point-min))
+;  (while (re-search-forward "\n\n\n\n*" nil t)
+;    (replace-match "\n\n"))
+;  )
+
+(defun Manual-mouseify-xrefs ()
+  (goto-char (point-min))
+  (forward-line 1)
+  (let ((case-fold-search nil)
+	s e name 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)
+      (setq s (match-beginning 0)
+	    e (match-end 0)
+	    name (buffer-substring s e))
+      (goto-char s)
+      (skip-chars-backward " \t")
+      (if (and (bolp)
+	       (progn (backward-char 1) (= (preceding-char) ?-)))
+	  (progn
+	    (setq s (point))
+	    (skip-chars-backward "-a-zA-Z0-9_.")
+	    (setq name (concat (buffer-substring (point) (1- s)) name))
+	    (setq s (point))))
+      ;; 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))))))
+      ;; (setq already-fontified (extent-at s))
+      (setq extent (make-extent s e))
+      (set-extent-property extent 'man (list 'Manual-follow-xref name))
+      (set-extent-property extent 'highlight t)
+      ;; (if (not already-fontified)...
+      (set-extent-face extent 'man-xref)
+      (goto-char e))))
+
+(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")
+  (if (eventp name-or-event)
+      (let* ((p (event-point name-or-event))
+	     (extent (and p (extent-at p
+			     (event-buffer name-or-event)
+			     'highlight)))
+	     (data (and extent (extent-property extent 'man))))
+	(if (eq (car-safe data) 'Manual-follow-xref)
+	    (eval data)
+	  (error "no manual cross-reference there.")))
+    (let ((Manual-match-topic-exactly t)
+	  (Manual-query-multiple-pages nil))
+      (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)))))))
+
+(defun Manual-popup-menu (&optional event)
+  "Pops 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."
+  (interactive "e")
+  (let ((buffer (current-buffer))
+	(sep "---")
+	(prefix "Show Manual Page for ")
+	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)))
+    (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 nil))
+      (popup-menu
+       (cons "Manual Entry"
+	     (mapcar #'(lambda (item)
+			 (if (eq item sep)
+			     item
+                           (vector (concat prefix item)
+                                   (list 'Manual-follow-xref item) t)))
+		     (nreverse items)))))))
+
+(defun pager-cleanup-hook ()
+  "cleanup man page if called via $PAGER"
+  (let ((buf-name (or buffer-file-name (buffer-name))))
+	(if (and (or (string-match "^/tmp/man[0-9]+" buf-name)
+		     (string-match ".*/man/\\(man\\|cat\\)[1-9a-z]/" buf-name))
+		 (not (string-match Manual-bogus-file-pattern buf-name)))
+	    (let (buffer manpage)
+	      (require 'man)
+	      (goto-char (point-min))
+	      (setq buffer-read-only nil)
+	      (Manual-nuke-nroff-bs)
+	      (goto-char (point-min))
+	      (if (re-search-forward "[^ \t]")
+		  (goto-char (- (point) 1)))
+	      (if (looking-at "\\([a-zA-Z0-9]+\\)[ \t]*(")
+		  (setq manpage (buffer-substring (match-beginning 1) (match-end 1)))
+		(setq manpage "???"))
+	      (setq buffer
+		    (rename-buffer
+		     (generate-new-buffer-name (concat "*man " manpage "*"))))
+	      (setq buffer-file-name nil)
+	      (goto-char (point-min))
+	      (insert (format "%s\n" buf-name))
+	      (goto-char (point-min))
+	      (buffer-disable-undo buffer)
+	      (set-buffer-modified-p nil)
+	      (Manual-mode)
+	      ))))
+
+(add-hook 'server-visit-hook 'pager-cleanup-hook)
+(provide 'man)
diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/ps-print.el
--- a/lisp/packages/ps-print.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/packages/ps-print.el	Mon Aug 13 08:46:56 2007 +0200
@@ -1899,6 +1899,8 @@
       (if ps-razzle-dazzle
 	  (message "Formatting...done")))))
 
+;; XEmacs change
+;; Permit dynamic evaluation at print time of ps-lpr-switches
 (defun ps-do-despool (filename)
   (if (or (not (boundp 'ps-spool-buffer))
 	  (not ps-spool-buffer))
@@ -1921,12 +1923,21 @@
 	(set-buffer ps-spool-buffer)
 	(if (and (eq system-type 'ms-dos) (stringp dos-ps-printer))
 	    (write-region (point-min) (point-max) dos-ps-printer t 0)
-	  (let ((binary-process-input t)) ; for MS-DOS
+	  (let ((binary-process-input t)  ; for MS-DOS
+		(ps-lpr-sw (message-flatten-list    ; XEmacs
+			    (mapcar '(lambda (arg)  ; Dynamic evaluation
+				       (cond ((stringp arg) arg)
+					     ((functionp arg) (apply arg nil))
+					     ((symbolp arg) (eval arg))
+					     ((consp arg) (apply (car arg)
+								 (cdr arg)))
+					     (t nil)))
+				    ps-lpr-switches))))
 	    (apply 'call-process-region
 		   (point-min) (point-max) ps-lpr-command nil
 		   (if (fboundp 'start-process) 0 nil)
 		   nil
-		   ps-lpr-switches))))
+		   ps-lpr-sw))))
       (if ps-razzle-dazzle
 	  (message "Printing...done")))
     (kill-buffer ps-spool-buffer)))
@@ -2029,12 +2040,16 @@
 ;; article subjects shows up at the printer.  This function, bound to
 ;; prsc for the gnus *Summary* buffer means I don't have to switch
 ;; buffers first.
+;; sb:  Updated for Gnus 5.
 (defun ps-gnus-print-article-from-summary ()
   (interactive)
-  (if (get-buffer "*Article*")
-      (save-excursion
-	(set-buffer "*Article*")
-	(ps-spool-buffer-with-faces))))
+  (let ((ps-buf (if (boundp 'gnus-article-buffer)
+		    gnus-article-buffer
+		  "*Article*")))
+    (if (get-buffer ps-buf)
+	(save-excursion
+	  (set-buffer ps-buf)
+	  (ps-spool-buffer-with-faces)))))
 
 ;; See ps-gnus-print-article-from-summary.  This function does the
 ;; same thing for vm.
diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/scroll-in-place.el
--- a/lisp/packages/scroll-in-place.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/packages/scroll-in-place.el	Mon Aug 13 08:46:56 2007 +0200
@@ -17,7 +17,7 @@
 ;;;;
 ;;;; You should have received a copy of the GNU General Public License along
 ;;;; with GNU Emacs.  If you did not, write to the Free Software Foundation,
-;;;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA.
+;;;; Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 
 ;;; Synched up with: Not in FSF.
 
@@ -461,6 +461,9 @@
 ;;;;   invoke scrolling commands (although many filters move point around,
 ;;;;   which will also confuse `scroll-window-in-place').
 
+;; sb -- Added turn-on and turn-off hook functions to prepare for making this
+;;  a standardly dumped package with XEmacs.
+
 ;; (provide 'scroll-in-place) at the end of this file.
 
 
@@ -495,7 +498,7 @@
   ;; be worth it.
   )
 
-(defvar scroll-allow-blank-lines-past-eob nil
+(defvar scroll-allow-blank-lines-past-eob t
   "*When this variable is `nil' the \"in place\" scrolling commands will avoid
 displaying empty lines past the end of the buffer text.  In other words, just
 as you can't see \"dead space\" before the beginning of the buffer text, the
@@ -625,6 +628,16 @@
 set for all versions of Epoch 4 and for Lucid GNU Emacs 19.8.")
 
 
+;; Hook functions to make turning the mode on and off easier.
+(defun turn-on-scroll-in-place ()
+  "Unconditionally turn on scroll-in-place mode."
+  (set (make-local-variable 'scroll-in-place) t))
+
+(defun turn-off-scroll-in-place ()
+  "Unconditionally turn on scroll-in-place mode."
+  (set (make-local-variable 'scroll-in-place) nil))
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -1547,6 +1560,16 @@
 	  nil))
 
 
+;;; Some convenience redefinitions for modes that don't like scroll-in-place
+(add-hook 'vm-mode-hook 'turn-off-scroll-in-place)
+(add-hook 'vm-select-message-hook 'turn-off-scroll-in-place)
+(add-hook 'vm-summary-mode-hook 'turn-off-scroll-in-place)
+
+(add-hook 'list-mode-hook 'turn-off-scroll-in-place)
+
+;; This doesn't work with Red Gnus
+;; (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -1557,5 +1580,4 @@
 
 (provide 'scroll-in-place)
 
-;; End of file.
-
+;;; scroll-in-place.el ends here
diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/texnfo-upd.el
--- a/lisp/packages/texnfo-upd.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/packages/texnfo-upd.el	Mon Aug 13 08:46:56 2007 +0200
@@ -1268,7 +1268,7 @@
       (save-restriction
 	(narrow-to-region beginning end)
 	(goto-char beginning)
-        (push-mark (point) t)
+        (push-mark (point) t t)
 	(while (re-search-forward "^@node" (point-max) t)
           (beginning-of-line)            
           (texinfo-update-the-node))
@@ -1279,13 +1279,14 @@
   "Update every node in a Texinfo file."
   (interactive)
   (save-excursion
-    (push-mark (point-max) t)
-    (goto-char (point-min))
-    ;; Using the mark to pass bounds this way
-    ;; is kludgy, but it's not worth fixing. -- rms.
-    (let ((mark-active t))
-      (texinfo-update-node t))
-    (message "Done...updated every node.       You may save the buffer.")))
+    (let ((zmacs-regions nil))
+      (push-mark (point-max) t t)
+      (goto-char (point-min))
+      ;; Using the mark to pass bounds this way
+      ;; is kludgy, but it's not worth fixing. -- rms.
+      (let ((mark-active t))
+	(texinfo-update-node t))
+      (message "Done...updated every node.       You may save the buffer."))))
 
 (defun texinfo-update-the-node ()
   "Update one node.  Point must be at the beginning of node line.  
diff -r 30df88044ec6 -r b82b59fe008d lisp/packages/time-stamp.el
--- a/lisp/packages/time-stamp.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/packages/time-stamp.el	Mon Aug 13 08:46:56 2007 +0200
@@ -1,134 +1,419 @@
 ;;; time-stamp.el --- Maintain last change time stamps in files edited by Emacs
-;;; Copyright 1989, 1993 Free Software Foundation, Inc.
 
+;; Copyright 1989, 1993, 1994, 1995 Free Software Foundation, Inc.
+
+;; Maintainer's Time-stamp: <95/12/28 19:48:49 gildea>
 ;; Maintainer: Stephen Gildea 
-;; Time-stamp: <93/06/20 17:36:04 gildea>
 ;; Keywords: tools
 
-;; This file 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.
 
-;; This file 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
 
-;;; Synched up with: Not synched with FSF.
+;;; Synched up with: 19.34.
 
 ;;; Commentary:
 
-;;; If you put a time stamp template anywhere in the first 8 lines of a file,
-;;; it can be updated every time you save the file.  See the top of
-;;; time-stamp.el for a sample.  The template looks like one of the following:
-;;;     Time-stamp: <>
-;;;     Time-stamp: " "
-;;; The time stamp is written between the brackets or quotes, resulting in
-;;;     Time-stamp: <93/06/18 10:26:51 gildea>
-;;; Here is an example which puts the file name and time stamp in the binary:
-;;; static char *time_stamp = "sdmain.c Time-stamp: <>";
+;; If you put a time stamp template anywhere in the first 8 lines of a file,
+;; it can be updated every time you save the file.  See the top of
+;; time-stamp.el for a sample.  The template looks like one of the following:
+;;     Time-stamp: <>
+;;     Time-stamp: " "
+;; The time stamp is written between the brackets or quotes, resulting in
+;;     Time-stamp: <95/01/18 10:20:51 gildea>
+;; Here is an example that puts the file name and time stamp in the binary:
+;; static char *time_stamp = "sdmain.c Time-stamp: <>";
 
-;;; To activate automatic time stamping, add this code to your .emacs file:
-;;;
-;;; (autoload 'time-stamp "time-stamp" "Update the time stamp in a buffer." t)
-;;; (if (not (memq 'time-stamp write-file-hooks))
-;;;     (setq write-file-hooks
-;;;           (cons 'time-stamp write-file-hooks)))
+;; To activate automatic time stamping in GNU Emacs 19, add this code
+;; to your .emacs file:
+;; (add-hook 'write-file-hooks 'time-stamp)
+;;
+;; In Emacs 18 you will need to do this instead:
+;; (if (not (memq 'time-stamp write-file-hooks))
+;;     (setq write-file-hooks
+;;           (cons 'time-stamp write-file-hooks)))
+;; (autoload 'time-stamp "time-stamp" "Update the time stamp in a buffer." t)
+
+;; See the documentation for the function `time-stamp' for more details.
 
 ;;; Change Log:
 
-;;; Originally based on the 19 Dec 88 version of
-;;;   date.el by John Sturdy 
+;; Originally based on the 19 Dec 88 version of
+;;   date.el by John Sturdy 
+;; version 2, January 1995: replaced functions with %-escapes
+;; $Id: time-stamp.el,v 1.1.1.2 1996/12/18 03:53:21 steve Exp $
 
 ;;; Code:
 
 (defvar time-stamp-active t
-  "*Non-nil to enable time-stamping of files.  See the function time-stamp.")
+  "*Non-nil to enable time-stamping of buffers by \\[time-stamp].
+Can be toggled by \\[time-stamp-toggle-active].
+See also the variable time-stamp-warn-inactive.")
+
+(defvar time-stamp-warn-inactive t
+  "*Non-nil to have \\[time-stamp] warn if a buffer did not get time-stamped.
+A warning is printed if time-stamp-active is nil and the buffer contains
+a time stamp template that would otherwise have been updated.")
+
+(defvar time-stamp-format "%02y/%02m/%02d %02H:%02M:%02S %u"
+  "*Template for the string inserted by \\[time-stamp].
+Value may be a string or a list.  (Lists are supported only for
+backward compatibility.)  A string is used verbatim except
+for character sequences beginning with %:
 
-(defvar time-stamp-format
-  '(time-stamp-yy/mm/dd time-stamp-hh:mm:ss user-login-name)
-  "*A list of functions to call to generate the time stamp string.
-Each element of the list is called as a function and the results are
-concatenated together separated by spaces.  Elements may also be strings,
-which are included verbatim.  Spaces are not inserted around literal strings.")
+%a  weekday name: `Monday'.		%A gives uppercase: `MONDAY'
+%b  month name: `January'.		%B gives uppercase: `JANUARY'
+%d  day of month
+%H  24-hour clock hour
+%I  12-hour clock hour
+%m  month number
+%M  minute
+%p  `am' or `pm'.			%P gives uppercase: `AM' or `PM'
+%S  seconds
+%w  day number of week, Sunday is 0
+%y  year: `1995'
+%z  time zone name: `est'.		%Z gives uppercase: `EST'
+
+Non-date items:
+%%  a literal percent character: `%'
+%f  file name without directory		%F gives absolute pathname
+%s  system name
+%u  user's login name
+%h  mail host name
+
+Decimal digits between the % and the type character specify the
+field width.  Strings are truncated on the right; numbers on the left.
+A leading zero causes numbers to be zero-filled.
+
+For example, to get the format used by the `date' command,
+use \"%3a %3b %2d %02H:%02M:%02S %Z %y\"")
+
 
 ;;; Do not change time-stamp-line-limit, time-stamp-start, or
 ;;; time-stamp-end in your .emacs or you will be incompatible
 ;;; with other people's files!  If you must change them,
 ;;; do so only in the local variables section of the file itself.
 
-(defvar time-stamp-line-limit 8	    ;Do not change!  See comment above.
-  "Number of lines at the beginning of a file that are searched.
-The patterns time-stamp-start and time-stamp-end must be found on one
-of the first time-stamp-line-limit lines of the file for the file to
-be time-stamped.")
+(defvar time-stamp-line-limit 8	    ;Do not change!
+  "Lines of a file searched; positive counts from start, negative from end.
+The patterns `time-stamp-start' and `time-stamp-end' must be found on one
+of the first (last) `time-stamp-line-limit' lines of the file for the
+file to be time-stamped by \\[time-stamp].
 
-(defvar time-stamp-start "Time-stamp: \\\\?[\"<]+"    ;Do not change!
-  "Regexp after which the time stamp is written by \\[time-stamp].
-See also the variables  time-stamp-end  and  time-stamp-line-limit.
-
-Do not change time-stamp-line-limit, time-stamp-start, or
-time-stamp-end for yourself or you will be incompatible
+Do not change `time-stamp-line-limit', `time-stamp-start', or
+`time-stamp-end' for yourself or you will be incompatible
 with other people's files!  If you must change them for some application,
 do so in the local variables section of the time-stamped file itself.")
 
 
-(defvar time-stamp-end "\\\\?[\">]"    ;Do not change!  See comment above.
+(defvar time-stamp-start "Time-stamp:[ \t]+\\\\?[\"<]+"    ;Do not change!
+  "Regexp after which the time stamp is written by \\[time-stamp].
+See also the variables `time-stamp-end' and `time-stamp-line-limit'.
+
+Do not change `time-stamp-line-limit', `time-stamp-start', or
+`time-stamp-end' for yourself or you will be incompatible
+with other people's files!  If you must change them for some application,
+do so in the local variables section of the time-stamped file itself.")
+
+
+(defvar time-stamp-end "\\\\?[\">]"    ;Do not change!
   "Regexp marking the text after the time stamp.
-\\[time-stamp] deletes the text between the first match of  time-stamp-start
-\(which see) and the following match of  time-stamp-end  on the same line,
-then writes the time stamp specified by  time-stamp-format  between them.")
+\\[time-stamp] deletes the text between the first match of `time-stamp-start'
+and the following match of `time-stamp-end' on the same line,
+then writes the time stamp specified by `time-stamp-format' between them.
+
+Do not change `time-stamp-line-limit', `time-stamp-start', or
+`time-stamp-end' for yourself or you will be incompatible
+with other people's files!  If you must change them for some application,
+do so in the local variables section of the time-stamped file itself.")
+
 
 ;;;###autoload
 (defun time-stamp ()
   "Update the time stamp string in the buffer.
+If you put a time stamp template anywhere in the first 8 lines of a file,
+it can be updated every time you save the file.  See the top of
+`time-stamp.el' for a sample.  The template looks like one of the following:
+    Time-stamp: <>
+    Time-stamp: \" \"
+The time stamp is written between the brackets or quotes, resulting in
+    Time-stamp: <95/01/18 10:20:51 gildea>
 Only does its thing if the variable  time-stamp-active  is non-nil.
 Typically used on  write-file-hooks  for automatic time-stamping.
-The format of the time stamp is determined by the variable
-time-stamp-format.  The first  time-stamp-line-limit  lines of the
-buffer (normally 8) are searched for the time stamp template,
-and if it is found, a new time stamp is written into it."
+The format of the time stamp is determined by the variable  time-stamp-format.
+The variables time-stamp-line-limit, time-stamp-start, and time-stamp-end
+control finding the template."
   (interactive)
-  (if time-stamp-active
-       (let ((case-fold-search nil))
-	 (if (and (stringp time-stamp-start)
-		  (stringp time-stamp-end))
-	     (save-excursion
-	       (goto-char (point-min))
-	       (if (re-search-forward time-stamp-start
-				      (save-excursion
-					(forward-line time-stamp-line-limit)
-					(point))
-				      t)
-		   (let ((start (point)))
-		     (if (re-search-forward time-stamp-end
-					    (save-excursion (end-of-line) (point))
-					    t)
-			 (let ((end (match-beginning 0)))
-			   (delete-region start end)
-			   (goto-char start)
-			   (insert (time-stamp-string))
-			   (setq end (point))
-			   ;; remove any tabs used to format the time stamp
-			   (goto-char start)
-			   (if (search-forward "\t" end t)
-			       (untabify start end)))))))
-	   ;; don't signal an error in a write-file-hook
-	   (message "time-stamp-start or time-stamp-end is not a string"))))
+  (let ((case-fold-search nil)
+	(need-to-warn nil)
+	start search-end)
+    (if (and (stringp time-stamp-start)
+	     (stringp time-stamp-end))
+	(save-excursion
+	  (save-restriction
+	    (widen)
+	    (if (> time-stamp-line-limit 0)
+		(progn
+		  (goto-char (setq start (point-min)))
+		  (forward-line time-stamp-line-limit)
+		  (setq search-end (point)))
+	      (goto-char (setq search-end (point-max)))
+	      (forward-line time-stamp-line-limit)
+	      (setq start (point)))
+	    (goto-char start)
+	    (while
+		(and (< (point) search-end)
+		     (re-search-forward time-stamp-start search-end 'move))
+	      (setq start (point))
+	      (end-of-line)
+	      (let ((line-end (point)))
+		(goto-char start)
+		(if (re-search-forward time-stamp-end line-end 'move)
+		    (progn
+		      (if time-stamp-active
+			  (let ((end (match-beginning 0)))
+			    (delete-region start end)
+			    (goto-char start)
+			    (insert (time-stamp-string))
+			    (setq end (point))
+			    ;; remove any tabs used to format time stamp
+			    (goto-char start)
+			    (if (search-forward "\t" end t)
+				(untabify start end)))
+			(if time-stamp-warn-inactive
+			    ;; do warning outside save-excursion
+			    (setq need-to-warn t)))
+		      (setq search-end (point))))))))
+      ;; don't signal an error in a write-file-hook
+      (message "time-stamp-start or time-stamp-end is not a string")
+      (sit-for 1))
+    (if need-to-warn
+	(progn
+	  (message "Warning: time-stamp-active is off; did not time-stamp buffer.")
+	  (sit-for 1))))
   ;; be sure to return nil so can be used on write-file-hooks
   nil)
 
+;;;###autoload
+(defun time-stamp-toggle-active (&optional arg)
+  "Toggle time-stamp-active, setting whether \\[time-stamp] updates a buffer.
+With arg, turn time stamping on if and only if arg is positive."
+  (interactive "P")
+  (setq time-stamp-active
+	(if (null arg)
+	    (not time-stamp-active)
+	  (> (prefix-numeric-value arg) 0)))
+  (message "time-stamp is now %s." (if time-stamp-active "active" "off")))
+
+
 (defun time-stamp-string ()
   "Generate the new string to be inserted by \\[time-stamp]."
-  (time-stamp-fconcat time-stamp-format " "))
+  (if (stringp time-stamp-format)
+      (time-stamp-strftime time-stamp-format)
+    (time-stamp-fconcat time-stamp-format " "))) ;version 1 compatibility
+
+(defconst time-stamp-month-numbers
+  '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
+    ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))
+  "Alist of months and their number.")
+
+(defconst time-stamp-month-full-names
+  ["(zero)" "January" "February" "March" "April" "May" "June"
+   "July" "August" "September" "October" "November" "December"])
+
+(defconst time-stamp-weekday-numbers
+  '(("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3)
+    ("Thu" . 4) ("Fri" . 5) ("Sat" . 6))
+  "Alist of weekdays and their number.")
+
+(defconst time-stamp-weekday-full-names
+  ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"])
+
+(defconst time-stamp-am-pm '("am" "pm")
+  "List of strings used to denote morning and afternoon.")
+
+(defconst time-stamp-no-file "(no file)"
+  "String to use when the buffer is not associated with a file.")
+
+(defun time-stamp-strftime (format &optional time)
+  "Uses a FORMAT to format date, time, file, and user information.
+Optional second argument TIME will be used instead of the current time.
+See the description of the variable `time-stamp-format' for a description
+of the format string."
+  (let ((time-string (cond ((stringp time)
+			    time)
+			   (time
+			    (current-time-string time))
+			   (t
+			    (current-time-string))))
+	(fmt-len (length format))
+	(ind 0)
+	cur-char
+	(prev-char nil)
+	(result "")
+	field-index
+	field-width
+	field-result
+	(paren-level 0))
+    (while (< ind fmt-len)
+      (setq cur-char (aref format ind))
+      (setq
+       result
+       (concat result 
+      (cond
+       ((eq cur-char ?%)
+	(setq field-index (1+ ind))
+	(while (progn
+		 (setq ind (1+ ind))
+		 (setq cur-char (if (< ind fmt-len)
+				    (aref format ind)
+				  ?\0))
+		 (and (<= ?0 cur-char) (>= ?9 cur-char))))
+	(setq field-width (substring format field-index ind))
+	;; eat any additional args to allow for future expansion
+	(while (or (and (<= ?0 cur-char) (>= ?9 cur-char)) (eq ?. cur-char)
+		   (eq ?, cur-char) (eq ?: cur-char) (eq ?@ cur-char)
+		   (eq ?- cur-char) (eq ?+ cur-char)
+		   (eq ?\  cur-char) (eq ?# cur-char)
+		   (and (eq ?\( cur-char)
+			(not (eq prev-char ?\\))
+			(setq paren-level (1+ paren-level)))
+		   (if (and (eq ?\) cur-char)
+			    (not (eq prev-char ?\\))
+			    (> paren-level 0))
+		       (setq paren-level (1- paren-level))
+		     (and (> paren-level 0)
+			  (< ind fmt-len))))
+	  (setq ind (1+ ind))
+	  (setq prev-char cur-char)
+	  (setq cur-char (if (< ind fmt-len)
+			     (aref format ind)
+			   ?\0)))
+	(setq field-result
+	(cond
+	 ((eq cur-char ?%)
+	  "%")
+	 ((or (eq cur-char ?a)		;weekday name
+	      (eq cur-char ?A))
+	  (let ((name
+		 (aref time-stamp-weekday-full-names
+		       (cdr (assoc (substring time-string 0 3)
+				   time-stamp-weekday-numbers)))))
+	    (if (eq cur-char ?a)
+		name
+	      (upcase name))))
+	 ((or (eq cur-char ?b)		;month name
+	      (eq cur-char ?B))
+	  (let ((name
+		 (aref time-stamp-month-full-names
+		       (cdr (assoc (substring time-string 4 7)
+				   time-stamp-month-numbers)))))
+	    (if (eq cur-char ?b)
+		name
+	      (upcase name))))
+	 ((eq cur-char ?d)		;day of month, 1-31
+	  (string-to-int (substring time-string 8 10)))
+	 ((eq cur-char ?H)		;hour, 0-23
+	  (string-to-int (substring time-string 11 13)))
+	 ((eq cur-char ?I)		;hour, 1-12
+	  (let ((hour (string-to-int (substring time-string 11 13))))
+	    (cond ((< hour 1)
+		   (+ hour 12))
+		  ((> hour 12)
+		   (- hour 12))
+		  (t
+		   hour))))
+	 ((eq cur-char ?m)		;month number, 1-12
+	  (cdr (assoc (substring time-string 4 7)
+		      time-stamp-month-numbers)))
+	 ((eq cur-char ?M)		;minute, 0-59
+	  (string-to-int (substring time-string 14 16)))
+	 ((or (eq cur-char ?p)		;am or pm
+	      (eq cur-char ?P))
+	  (let ((name
+		 (if (> 12 (string-to-int (substring time-string 11 13)))
+		     (car time-stamp-am-pm)
+		   (car (cdr time-stamp-am-pm)))))
+	    (if (eq cur-char ?p)
+		name
+	      (upcase name))))
+	 ((eq cur-char ?S)		;seconds, 00-60
+	  (string-to-int (substring time-string 17 19)))
+	 ((eq cur-char ?w)		;weekday number, Sunday is 0
+	  (cdr (assoc (substring time-string 0 3) time-stamp-weekday-numbers)))
+	 ((eq cur-char ?y)		;year
+	  (string-to-int (substring time-string -4)))
+	 ((or (eq cur-char ?z)		;time zone
+	      (eq cur-char ?Z))
+	  (let ((name
+		 (if (fboundp 'current-time-zone)
+		     (car (cdr (current-time-zone time))))))
+	    (or name (setq name ""))
+	    (if (eq cur-char ?z)
+		(downcase name)
+	      (upcase name))))
+	 ((eq cur-char ?f)		;buffer-file-name, base name only
+	  (if buffer-file-name
+	      (file-name-nondirectory buffer-file-name)
+	    time-stamp-no-file))
+	 ((eq cur-char ?F)		;buffer-file-name, full path
+	  (or buffer-file-name
+	      time-stamp-no-file))
+	 ((eq cur-char ?s)		;system name
+	  (system-name))
+	 ((eq cur-char ?u)		;user name
+	  (user-login-name))
+	 ((eq cur-char ?h)		;mail host name
+	  (time-stamp-mail-host-name))
+	 ))
+	(if (string-equal field-width "")
+	    field-result
+	  (let ((padded-result
+		 (format (format "%%%s%c"
+				 field-width
+				 (if (numberp field-result) ?d ?s))
+			 (or field-result ""))))
+	    (let ((initial-length (length padded-result))
+		  (desired-length (string-to-int field-width)))
+	      (if (> initial-length desired-length)
+		  ;; truncate strings on right, numbers on left
+		  (if (stringp field-result)
+		      (substring padded-result 0 desired-length)
+		    (substring padded-result (- desired-length)))
+		padded-result)))))
+       (t
+	(char-to-string cur-char)))))
+      (setq ind (1+ ind)))
+    result))
+
+(defun time-stamp-mail-host-name ()
+  "Return the name of the host where the user receives mail.
+This is the value of `mail-host-address' if bound and a string,
+otherwise the value of `time-stamp-mail-host' (for versions of Emacs
+before 19.29) otherwise the value of the function system-name."
+  (or (and (boundp 'mail-host-address)
+	   (stringp mail-host-address)
+	   mail-host-address)
+      (and (boundp 'time-stamp-mail-host) ;for backward compatibility
+	   (stringp time-stamp-mail-host)
+	   time-stamp-mail-host)
+      (system-name)))
+
+;;; the rest of this file is for version 1 compatibility
 
 (defun time-stamp-fconcat (list sep)
-  "Similar to (mapconcat 'funcall LIST SEP) but LIST can have literals.
+  "Similar to (mapconcat 'funcall LIST SEP) but LIST allows literals.
 If an element of LIST is a symbol, it is funcalled to get the string to use;
 the separator SEP is used between two strings obtained by funcalling a
 symbol.  Otherwise the element itself is inserted; no separator is used
@@ -148,43 +433,17 @@
     return-string))
 
 
-(defconst time-stamp-month-numbers
-  '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
-    ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))
-  "Assoc list of months and their number.")
-
-(defconst time-stamp-month-full-names
-  ["(zero)" "January" "February" "March" "April" "May" "June"
-   "July" "August" "September" "October" "November" "December"])
-
-(defvar time-stamp-mail-host nil
-  "Name of the host where the user receives mail.
-See the function time-stamp-mail-host-name.")
-
 ;;; Some useful functions to use in time-stamp-format
 
 ;;; Could generate most of a message-id with
-;;; '(yymmdd "" hhmm "@" mail-host-name)
-
-(defun time-stamp-mail-host-name ()
-  "Return the name of the host where the user receives mail.
-This is the value of time-stamp-mail-host if bound and a string,
-otherwise the value of the function system-name."
-  (or (and (boundp 'time-stamp-mail-host)
-	   (stringp time-stamp-mail-host)
-	   time-stamp-mail-host)
-      (system-name)))
-
-(defun time-stamp-current-year ()
-  "Return the current year as a four-character string."
-  (substring (current-time-string) -4))
+;;; '(time-stamp-yymmdd "" time-stamp-hhmm "@" time-stamp-mail-host-name)
 
 ;;; pretty form, suitable for a title page
 
 (defun time-stamp-month-dd-yyyy ()
-  "Return the current date as a string in \"Month dd, yyyy\" form."
+  "Return the current date as a string in \"Month DD, YYYY\" form."
   (let ((date (current-time-string)))
-    (format "%s %02d, %s"
+    (format "%s %d, %s"
 	    (aref time-stamp-month-full-names
 		  (cdr (assoc (substring date 4 7) time-stamp-month-numbers)))
 	    (string-to-int (substring date 8 10))
@@ -193,8 +452,8 @@
 ;;; same as __DATE__ in ANSI C
 
 (defun time-stamp-mon-dd-yyyy ()
-  "Return the current date as a string in \"Mon dd yyyy\" form.
-The first character of dd is Space if the value is less than 10."
+  "Return the current date as a string in \"Mon DD YYYY\" form.
+The first character of DD is space if the value is less than 10."
   (let ((date (current-time-string)))
     (format "%s %2d %s"
 	    (substring date 4 7)
@@ -204,7 +463,7 @@
 ;;; RFC 822 date
 
 (defun time-stamp-dd-mon-yy ()
-  "Return the current date as a string in \"dd Mon yy\" form."
+  "Return the current date as a string in \"DD Mon YY\" form."
   (let ((date (current-time-string)))
     (format "%02d %s %s"
 	    (string-to-int (substring date 8 10))
@@ -214,7 +473,7 @@
 ;;; RCS 3 date
 
 (defun time-stamp-yy/mm/dd ()
-  "Return the current date as a string in \"yy/mm/dd\" form."
+  "Return the current date as a string in \"YY/MM/DD\" form."
   (let ((date (current-time-string)))
     (format "%s/%02d/%02d"
 	    (substring date -2)
@@ -224,47 +483,37 @@
 ;;; RCS 5 date
 
 (defun time-stamp-yyyy/mm/dd ()
-  "Return the current date as a string in \"yyyy/mm/dd\" form."
+  "Return the current date as a string in \"YYYY/MM/DD\" form."
   (let ((date (current-time-string)))
     (format "%s/%02d/%02d"
 	    (substring date -4)
 	    (cdr (assoc (substring date 4 7) time-stamp-month-numbers))
 	    (string-to-int (substring date 8 10)))))
 
+;;; ISO 8601 date
+
+(defun time-stamp-yyyy-mm-dd ()
+  "Return the current date as a string in \"YYYY-MM-DD\" form."
+  (let ((date (current-time-string)))
+    (format "%s-%02d-%02d"
+	    (substring date -4)
+	    (cdr (assoc (substring date 4 7) time-stamp-month-numbers))
+	    (string-to-int (substring date 8 10)))))
+
 (defun time-stamp-yymmdd ()
-  "Return the current date as a string in \"yymmdd\" form."
+  "Return the current date as a string in \"YYMMDD\" form."
   (let ((date (current-time-string)))
     (format "%s%02d%02d"
 	    (substring date -2)
 	    (cdr (assoc (substring date 4 7) time-stamp-month-numbers))
 	    (string-to-int (substring date 8 10)))))
 
-(defun time-stamp-dd/mm/yy ()
-  "Return the current date as a string in \"dd/mm/yy\" form."
-  (let ((date (current-time-string)))
-    (format "%02d/%02d/%s"
-	    (string-to-int (substring date 8 10))
-	    (cdr (assoc (substring date 4 7) time-stamp-month-numbers))
-	    (substring date -2))))
-
-(defun time-stamp-mm/dd/yy ()
-  "Return the current date as a string in \"mm/dd/yy\" form."
-  (let ((date (current-time-string)))
-    (format "%02d/%02d/%s"
-	    (cdr (assoc (substring date 4 7) time-stamp-month-numbers))
-	    (string-to-int (substring date 8 10))
-	    (substring date -2))))
-
 (defun time-stamp-hh:mm:ss ()
-  "Return the current time as a string in \"hh:mm:ss\" form."
+  "Return the current time as a string in \"HH:MM:SS\" form."
   (substring (current-time-string) 11 19))
 
-(defun time-stamp-hh:mm ()
-  "Return the current time as a string in \"hh:mm\" form."
-  (substring (current-time-string) 11 16))
-
 (defun time-stamp-hhmm ()
-  "Return the current time as a string in \"hhmm\" form."
+  "Return the current time as a string in \"HHMM\" form."
   (let ((date (current-time-string)))
     (concat (substring date 11 13)
 	    (substring date 14 16))))
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/buffer.el
--- a/lisp/prim/buffer.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/buffer.el	Mon Aug 13 08:46:56 2007 +0200
@@ -65,12 +65,16 @@
 If optional second arg NOT-THIS-WINDOW-P is non-nil, insist on finding
 another window even if BUFNAME is already visible in the selected window.
 If optional third arg is non-nil, it is the frame to pop to this
-buffer on."
+buffer on.
+If `focus-follows-mouse' is non-nil, keyboard focus is left unchanged."
   ;; #ifdef I18N3
   ;; #### Doc string should indicate that the buffer name will get
   ;; translated.
   ;; #endif
-  (let (buf window frame)
+  ;; This is twisted.  It is evil to throw the keyboard focus around
+  ;; willy-nilly if the user wants focus-follows-mouse.
+  (let ((oldbuf (current-buffer))
+	buf window frame)
     (if (null bufname)
 	(setq buf (other-buffer (current-buffer)))
       (setq buf (get-buffer bufname))
@@ -83,9 +87,15 @@
     (setq window (display-buffer buf not-this-window-p on-frame))
     (setq frame (window-frame window))
     ;; if the display-buffer hook decided to show this buffer in another
-    ;; frame, then select that frame.
-    (if (not (eq frame (selected-frame)))
+    ;; frame, then select that frame, (unless obeying focus-follows-mouse -sb).
+    (if (and (not focus-follows-mouse)
+	     (not (eq frame (selected-frame))))
 	(select-frame frame))
     (record-buffer buf)
-    (select-window window)
+    (if (and focus-follows-mouse
+	     on-frame
+	     (not (eq on-frame (selected-frame))))
+	(set-buffer oldbuf)
+      ;; select-window will modify the internal keyboard focus of XEmacs
+      (select-window window))
     buf))
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/debug.el
--- a/lisp/prim/debug.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/debug.el	Mon Aug 13 08:46:56 2007 +0200
@@ -19,9 +19,16 @@
 
 ;; 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.
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: FSF 19.34.
 
-;;; Synched up with: FSF 19.30.
+;;; Commentary:
+
+;; NB: There are lots of formatting changes in the XEmacs version. -sb
+
+;; This is a major mode documented in the Emacs manual.
 
 ;;; Code:
 
@@ -46,10 +53,14 @@
 (defvar debugger-outer-last-command)
 (defvar debugger-outer-this-command)
 (defvar debugger-outer-unread-command-event)
+;; FSF: (defvar debugger-outer-unread-command-char)
+(defvar debugger-outer-unread-command-events)
 (defvar debugger-outer-last-input-event)
 (defvar debugger-outer-last-input-char)
 (defvar debugger-outer-last-input-time)
 (defvar debugger-outer-last-command-event)
+;; (defvar debugger-outer-last-nonmenu-event)
+;; (defvar debugger-outer-last-event-frame)
 (defvar debugger-outer-last-command-char)
 (defvar debugger-outer-standard-input)
 (defvar debugger-outer-standard-output)
@@ -65,12 +76,12 @@
 ;;;###autoload
 (defun debug (&rest debugger-args)
   "Enter debugger.  To return, type \\`\\[debugger-continue]'.
-Arguments are mainly for use when this is called
- from the internals of the evaluator.
-You may call with no args, or you may
- pass nil as the first arg and any other args you like.
- In that case, the list of args after the first will 
- be printed into the backtrace buffer."
+Arguments are mainly for use when this is called from the internals
+of the evaluator.
+
+You may call with no args, or you may pass nil as the first arg and
+any other args you like.  In that case, the list of args after the
+first will be printed into the backtrace buffer."
   (interactive)
   ;; XEmacs: it doesn't work to enter the debugger non-interactively
   ;; so just print out a backtrace and exit.
@@ -79,32 +90,32 @@
   (let (debugger-value
 	(debug-on-error nil)
 	(debug-on-quit nil)
-	(debug-on-signal nil)
+	(debug-on-signal nil)	; XEmacs
 	(debugger-buffer (let ((default-major-mode 'fundamental-mode))
 			   (get-buffer-create "*Backtrace*")))
 	;; #### I18N3 set the debugger-buffer to output-translating
 	(debugger-old-buffer (current-buffer))
 	(debugger-step-after-exit nil)
-        ;; Don't keep reading from an executing kbd macro!
-        (executing-macro nil)
-        ;; Save the outer values of these vars for the `e' command
+	;; Don't keep reading from an executing kbd macro!
+	(executing-macro nil)
+	;; Save the outer values of these vars for the `e' command
 	;; before we replace the values.
 	(debugger-outer-match-data (match-data))
 	(debugger-outer-load-read-function load-read-function)
 	(debugger-outer-overriding-local-map overriding-local-map)
 	;; FSFmacs (debugger-outer-track-mouse track-mouse)
-        (debugger-outer-last-command last-command)
-        (debugger-outer-this-command this-command)
-        (debugger-outer-unread-command-event unread-command-event)
-        (debugger-outer-last-input-event last-input-event)
-        (debugger-outer-last-input-char last-input-char)
-        (debugger-outer-last-input-time last-input-time)
-        (debugger-outer-last-command-event last-command-event)
-        (debugger-outer-last-command-char last-command-char)
-        (debugger-outer-standard-input standard-input)
-        (debugger-outer-standard-output standard-output)
-        (debugger-outer-cursor-in-echo-area cursor-in-echo-area)
-        )
+	(debugger-outer-last-command last-command)
+	(debugger-outer-this-command this-command)
+	(debugger-outer-unread-command-event unread-command-event)
+	(debugger-outer-unread-command-events unread-command-events)
+	(debugger-outer-last-input-event last-input-event)
+	(debugger-outer-last-input-char last-input-char)
+	(debugger-outer-last-input-time last-input-time)
+	(debugger-outer-last-command-event last-command-event)
+	(debugger-outer-last-command-char last-command-char)
+	(debugger-outer-standard-input standard-input)
+	(debugger-outer-standard-output standard-output)
+	(debugger-outer-cursor-in-echo-area cursor-in-echo-area))
     ;; Don't let these magic variables affect the debugger itself.
     (unwind-protect                     ;XEmacs change
 	(let ((last-command nil)
@@ -132,12 +143,13 @@
 	      (debugger-mode)
 	      (delete-region (point)
 			     (progn
+			       ;; XEmacs change
 			       (re-search-forward "\n[* ] debug(")
 			       (forward-line 1)
 			       (point)))
+	      (debugger-reenable)
 	      ;; lambda is for debug-on-call when a function call is next.
 	      ;; debug is for debug-on-entry function called.
-	      (debugger-reenable)
 	      (cond ((memq (car debugger-args) '(lambda debug))
 		     (insert "Entering:\n")
 		     (if (eq (car debugger-args) 'debug)
@@ -159,13 +171,12 @@
 		     (beginning-of-line))
 		    ;; Debugger entered for an error.
 		    ((eq (car debugger-args) 'error)
-		     (insert "Signalling: ")
+		     (insert "Signaling: ")
 		     (prin1 (nth 1 debugger-args) (current-buffer))
 		     (insert ?\n))
 		    ;; debug-on-call, when the next thing is an eval.
 		    ((eq (car debugger-args) t)
-		     (insert
-		      "Beginning evaluation of function call form:\n"))
+		     (insert "Beginning evaluation of function call form:\n"))
 		    ;; User calls debug directly.
 		    (t
 		     (prin1 (if (eq (car debugger-args) 'nil)
@@ -176,11 +187,12 @@
 	      (let ((inhibit-trace t)
 		    (standard-output nil)
 		    (buffer-read-only t))
-		(message nil)
+		(message "")
 		(recursive-edit)))
+	    ;; XEmacs change
 	    debugger-value))
-	;; Kill or at least neuter the backtrace buffer, so that users
-	;; don't try to execute debugger commands in an invalid context.
+      ;; Kill or at least neuter the backtrace buffer, so that users
+      ;; don't try to execute debugger commands in an invalid context.
       (if (get-buffer-window debugger-buffer 'visible)
 	    ;; Still visible despite the save-window-excursion?  Maybe it
 	    ;; it's in a pop-up frame.  It would be annoying to delete and
@@ -200,6 +212,7 @@
       (setq last-command debugger-outer-last-command)
       (setq this-command debugger-outer-this-command)
       (setq unread-command-event debugger-outer-unread-command-event)
+      (setq unread-command-event debugger-outer-unread-command-events)
       (setq last-input-event debugger-outer-last-input-event)
       (setq last-input-char debugger-outer-last-input-char)
       (setq last-input-time debugger-outer-last-input-time)
@@ -211,7 +224,7 @@
       (setq debug-on-next-call debugger-step-after-exit) ;do this last!
       )))
 
-
+;; XEmacs
 (defun debugger-exit ()
   (condition-case nil
       (let ((debug-on-error nil)
@@ -228,12 +241,14 @@
   (interactive)
   (setq debugger-step-after-exit t)
   (message "Proceeding, will debug on next eval or call.")
+  ;; XEmacs
   (debugger-exit))
 
 (defun debugger-continue ()
   "Continue, evaluating this expression without stopping."
   (interactive)
   (message "Continuing.")
+  ;; XEmacs
   (debugger-exit))
 
 (defun debugger-return-value (val)
@@ -246,6 +261,7 @@
   (prin1 debugger-value)
   (exit-recursive-edit))
 
+;; XEmacs: [Moved block]
 ;; Chosen empirically to account for all the frames
 ;; that will exist when debugger-frame is called
 ;; within the first one that appears in the backtrace buffer.
@@ -286,7 +302,7 @@
     (let ((opoint (point))
 	  (count 0))
       (goto-char (point-min))
-      ;; #### I18N3 will not localize properly!
+      ;; XEmacs:#### I18N3 will not localize properly!
       (if (or (equal (buffer-substring (point) (+ (point) 6))
 		     (gettext "Signal"))
 	      (equal (buffer-substring (point) (+ (point) 6))
@@ -343,15 +359,16 @@
 	(setq debugger-old-buffer (current-buffer)))
     (set-buffer debugger-old-buffer)
     (let ((last-command debugger-outer-last-command)
-          (this-command debugger-outer-this-command)
-          (unread-command-event debugger-outer-unread-command-event)
-          (last-input-event debugger-outer-last-input-event)
-          (last-input-char debugger-outer-last-input-char)
-          (last-input-time debugger-outer-last-input-time)
-          (last-command-event debugger-outer-last-command-event)
-          (last-command-char debugger-outer-last-command-char)
-          (standard-input debugger-outer-standard-input)
-          (standard-output debugger-outer-standard-output)
+	  (this-command debugger-outer-this-command)
+	  (unread-command-event debugger-outer-unread-command-event)
+	  (unread-command-event debugger-outer-unread-command-events)
+	  (last-input-event debugger-outer-last-input-event)
+	  (last-input-char debugger-outer-last-input-char)
+	  (last-input-time debugger-outer-last-input-time)
+	  (last-command-event debugger-outer-last-command-event)
+	  (last-command-char debugger-outer-last-command-char)
+	  (standard-input debugger-outer-standard-input)
+	  (standard-output debugger-outer-standard-output)
 	  (cursor-in-echo-area debugger-outer-cursor-in-echo-area)
 	  (overriding-local-map debugger-outer-overriding-local-map)
 	  (load-read-function debugger-outer-load-read-function))
@@ -372,23 +389,24 @@
               debugger-outer-standard-output standard-output
               debugger-outer-cursor-in-echo-area cursor-in-echo-area)))))
 
-(defvar debugger-mode-map
-  (let ((map (make-keymap)))
-    (set-keymap-name map 'debugger-mode-map)
-    (suppress-keymap map)
-    (define-key map "-" 'negative-argument)
-    (define-key map "b" 'debugger-frame)
-    (define-key map "c" 'debugger-continue)
-    (define-key map "j" 'debugger-jump)
-    (define-key map "r" 'debugger-return-value)
-    (define-key map "u" 'debugger-frame-clear)
-    (define-key map "d" 'debugger-step-through)
-    (define-key map "l" 'debugger-list-functions)
-    (define-key map "h" 'describe-mode)
-    (define-key map "q" 'top-level)
-    (define-key map "e" 'debugger-eval-expression)
-    (define-key map " " 'next-line)
-    map))
+(defvar debugger-mode-map nil)
+(if debugger-mode-map
+    nil
+  (let ((loop ? ))
+    (setq debugger-mode-map (make-keymap))
+    (suppress-keymap debugger-mode-map)
+    (define-key debugger-mode-map "-" 'negative-argument)
+    (define-key debugger-mode-map "b" 'debugger-frame)
+    (define-key debugger-mode-map "c" 'debugger-continue)
+    (define-key debugger-mode-map "j" 'debugger-jump)
+    (define-key debugger-mode-map "r" 'debugger-return-value)
+    (define-key debugger-mode-map "u" 'debugger-frame-clear)
+    (define-key debugger-mode-map "d" 'debugger-step-through)
+    (define-key debugger-mode-map "l" 'debugger-list-functions)
+    (define-key debugger-mode-map "h" 'describe-mode)
+    (define-key debugger-mode-map "q" 'top-level)
+    (define-key debugger-mode-map "e" 'debugger-eval-expression)
+    (define-key debugger-mode-map " " 'next-line)))
 
 (put 'debugger-mode 'mode-class 'special)
 
@@ -409,7 +427,7 @@
 \\{debugger-mode-map}"
   (kill-all-local-variables)    
   (setq major-mode 'debugger-mode)
-  (setq mode-name (gettext "Debugger"))
+  (setq mode-name (gettext "Debugger"))	; XEmacs
   (setq truncate-lines t)
   (set-syntax-table emacs-lisp-mode-syntax-table)
   (use-local-map debugger-mode-map))
@@ -441,11 +459,12 @@
 If argument is nil or an empty string, cancel for all functions."
   (interactive
    (list (let ((name
-                (completing-read "Cancel debug on entry (to function): "
-                                 ;; Make an "alist" of the functions
+		(completing-read "Cancel debug on entry (to function): "
+				 ;; Make an "alist" of the functions
 				 ;; that now have debug on entry.
-				 (mapcar 'list (mapcar 'symbol-name
-                                                       debug-function-list))
+				 (mapcar 'list
+					 (mapcar 'symbol-name
+						 debug-function-list))
 				 nil t nil)))
 	   (if name (intern name)))))
   (debugger-reenable)
@@ -485,7 +504,8 @@
       (let (tail prec)
 	(if (stringp (car (nthcdr 2 defn)))
 	    (setq tail (nthcdr 3 defn)
-		  prec (list (car defn) (car (cdr defn)) (car (cdr (cdr defn)))))
+		  prec (list (car defn) (car (cdr defn))
+			     (car (cdr (cdr defn)))))
 	  (setq tail (nthcdr 2 defn)
 		prec (list (car defn) (car (cdr defn)))))
 	(if (eq flag (equal (car tail) '(debug 'debug)))
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/files.el
--- a/lisp/prim/files.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/files.el	Mon Aug 13 08:46:56 2007 +0200
@@ -17,9 +17,10 @@
 
 ;; 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.
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
 
-;;; Synched up with: FSF 19.30.
+;;; Synched up with: FSF 19.34 [Partial].
 ;;; Warning: Merging this file is tough.  Beware.
 
 ;;; Commentary:
@@ -30,14 +31,28 @@
 
 ;;; Code:
 
-;; Avoid compilation warnings.
+;; XEmacs: Avoid compilation warnings.
 (defvar overriding-file-coding-system)
 (defvar file-coding-system)
 
-;; In buffer.c
+;; XEmacs: In buffer.c
 ;(defconst delete-auto-save-files t
 ;  "*Non-nil means delete auto-save file when a buffer is saved or killed.")
 
+;; FSF has automount-dir-prefix.  Our directory-abbrev-alist is more general.
+;; note: tmp_mnt bogosity conversion is established in paths.el.
+(defvar directory-abbrev-alist nil
+  "*Alist of abbreviations for file directories.
+A list of elements of the form (FROM . TO), each meaning to replace
+FROM with TO when it appears in a directory name.
+This replacement is done when setting up the default directory of a
+newly visited file.  *Every* FROM string should start with \\\\` or ^.
+
+Use this feature when you have directories which you normally refer to
+via absolute symbolic links or to eliminate automounter mount points
+from the beginning of your filenames.  Make TO the name of the link,
+and FROM the name it is linked to.")
+
 ;;; Turn off backup files on VMS since it has version numbers.
 (defconst make-backup-files (not (eq system-type 'vax-vms))
   "*Non-nil means make a backup of a file the first time it is saved.
@@ -95,6 +110,7 @@
 Automatically local in all buffers.")
 (make-variable-buffer-local 'buffer-offer-save)
 
+;; FSF uses normal defconst
 (defvaralias 'find-file-visit-truename 'find-file-use-truenames)
 (defvaralias 'find-file-existing-other-name 'find-file-compare-truenames)
 
@@ -106,6 +122,9 @@
 (make-variable-buffer-local 'buffer-file-number)
 (put 'buffer-file-number 'permanent-local t)
 
+(defvar buffer-file-numbers-unique (not (memq system-type '(windows-nt)))
+  "Non-nil means that buffer-file-number uniquely identifies files.")
+
 (defconst file-precious-flag nil
   "*Non-nil means protect against I/O errors while saving files.
 Some modes set this non-nil in particular buffers.
@@ -179,20 +198,26 @@
 and the rest are not called.
 These hooks are considered to pertain to the visited file.
 So this list is cleared if you change the visited file name.
-See also `write-contents-hooks' and `continue-save-buffer'.
-Don't make this variable buffer-local; instead, use `local-write-file-hooks'.")
+
+Don't make this variable buffer-local; instead, use `local-write-file-hooks'.
+See also `write-contents-hooks' and `continue-save-buffer'.")
 ;;; However, in case someone does make it local...
 (put 'write-file-hooks 'permanent-local t)
 
 (defvar local-write-file-hooks nil
   "Just like `write-file-hooks', except intended for per-buffer use.
 The functions in this list are called before the ones in
-`write-file-hooks'.")
+`write-file-hooks'.
+
+This variable is meant to be used for hooks that have to do with a
+particular visited file.  Therefore, it is a permanent local, so that
+changing the major mode does not clear it.  However, calling
+`set-visited-file-name' does clear it.")
 (make-variable-buffer-local 'local-write-file-hooks)
 (put 'local-write-file-hooks 'permanent-local t)
 
 
-;; #### think about this (added by Sun).
+;; XEmacs: #### think about this (added by Sun).
 (put 'after-set-visited-file-name-hooks 'permanent-local t)
 (defvar after-set-visited-file-name-hooks nil
   "List of functions to be called after \\[set-visited-file-name]
@@ -211,8 +236,9 @@
 not to the particular visited file; thus, `set-visited-file-name' does
 not clear this variable, but changing the major mode does clear it.
 See also `write-file-hooks' and `continue-save-buffer'.")
+;(make-variable-buffer-local 'write-contents-hooks)
 
-;;  Not in FSF19
+;; XEmacs addition
 ;;  Energize needed this to hook into save-buffer at a lower level; we need
 ;;  to provide a new output method, but don't want to have to duplicate all
 ;;  of the backup file and file modes logic.that does not occur if one uses
@@ -247,15 +273,6 @@
 The command \\[normal-mode] always obeys local-variables lists
 and ignores this variable.")
 
-(defvar hack-local-variables-hook nil
-  "Normal hook run after processing a file's local variables specs.
-Major modes can use this to examine user-specified local variables
-in order to initialize other data structure based on them.
-
-This hook runs even if there were no local variables or if their
-evaluation was suppressed.  See also `enable-local-variables' and
-`enable-local-eval'.")
-
 ;; Avoid losing in versions where CLASH_DETECTION is disabled.
 (or (fboundp 'lock-buffer)
     (defalias 'lock-buffer 'ignore))
@@ -299,7 +316,7 @@
 (defun parse-colon-path (cd-path)
   "Explode a colon-separated list of paths into a string list."
   (and cd-path
-       (let (cd-list (cd-start 0) cd-colon)
+       (let (cd-prefix cd-list (cd-start 0) cd-colon)
 	 (setq cd-path (concat cd-path path-separator))
 	 (while (setq cd-colon (string-match path-separator cd-path cd-start))
 	   (setq cd-list
@@ -334,22 +351,21 @@
   "Make DIR become the current buffer's default directory.
 If your environment includes a `CDPATH' variable, try each one of that
 colon-separated list of directories when resolving a relative directory name."
-;  (interactive "DChange default directory: ")
   (interactive
-   ;; XEmacs change?
+   ;; XEmacs change? (read-file-name => read-directory-name)
    (list (read-directory-name "Change default directory: "
 			      default-directory default-directory
 			      (and (member cd-path '(nil ("./")))
 				   (null (getenv "CDPATH"))))))
   (if (file-name-absolute-p dir)
       (cd-absolute (expand-file-name dir))
-    (progn
-      (if (null cd-path)
-          ;;#### Unix-specific
-          (let ((trypath (parse-colon-path (getenv "CDPATH"))))
-            (setq cd-path (or trypath (list "./")))))
-      (or (catch 'found
-            (mapcar #'(lambda (x)
+    ;; XEmacs
+    (if (null cd-path)
+	;;#### Unix-specific
+	(let ((trypath (parse-colon-path (getenv "CDPATH"))))
+	  (setq cd-path (or trypath (list "./")))))
+    (or (catch 'found
+	  (mapcar #'(lambda (x)
                         (let ((f (expand-file-name (concat x dir))))
                           (if (file-directory-p f)
                               (progn
@@ -361,28 +377,19 @@
 	  ;; good taste not to use a kludge like $CDPATH.
 	  (if (equal cd-path '("./"))
 	      (error "No such directory: %s" (expand-file-name dir))
-	    (error "Directory not found in $CDPATH: %s" dir))))))
+	    (error "Directory not found in $CDPATH: %s" dir)))))
 
 (defun load-file (file)
   "Load the Lisp file named FILE."
   (interactive "fLoad file: ")
   (load (expand-file-name file) nil nil t))
 
-; We now dump utils/lib-complete.el which has improved versions of these.
+; We now dump utils/lib-complete.el which has an improved version of this.
 ;(defun load-library (library)
 ;  "Load the library named LIBRARY.
 ;This is an interface to the function `load'."
 ;  (interactive "sLoad library: ")
 ;  (load library))
-;
-;(defun find-library (library)
-;  "Find the library of Lisp code named LIBRARY.
-;This searches `load-path' for a file named either \"LIBRARY\" or \"LIBRARY.el\"."
-;  (interactive "sFind library file: ")
-;  (let ((f (locate-file library load-path ":.el:")))
-;    (if f
-;        (find-file f)
-;        (error "Couldn't locate library %s" library))))
 
 (defun file-local-copy (file &optional buffer)
   "Copy the file FILE into a temporary file on this machine.
@@ -393,6 +400,7 @@
 	(funcall handler 'file-local-copy file)
       nil)))
 
+;; XEmacs change block
 ; We have this in C and use the realpath() system call.
 
 ;(defun file-truename (filename &optional counter prev-dirs)
@@ -502,6 +510,7 @@
 	(setq buffer-file-name (abbreviate-file-name buffer-file-truename)
 	      default-directory (file-name-directory buffer-file-name)))
     buffer-file-truename))
+;; End XEmacs change block
 
 (defun file-chase-links (filename)
   "Chase links in FILENAME until a name that is not a link.
@@ -558,6 +567,7 @@
 (defun switch-to-buffer-other-frame (buffer)
   "Switch to buffer BUFFER in a newly-created frame."
   (interactive "BSwitch to buffer in other frame: ")
+  ;; XEmacs guarantees a new frame
   (let* ((name (get-frame-name-for-buffer buffer))
 	 (frame (make-frame (if name
 				  (list (cons 'name (symbol-name name)))))))
@@ -580,7 +590,9 @@
   (switch-to-buffer-other-window (find-file-noselect filename)))
 
 (defun find-file-other-frame (filename)
-  "Edit file FILENAME, in a newly-created frame."
+  "Edit file FILENAME, in a newly-created frame.
+This function will create a new frame.
+See the function `display-buffer'."
   (interactive "FFind file in other frame: ")
   (switch-to-buffer-other-frame (find-file-noselect filename)))
 
@@ -624,8 +636,7 @@
 	    (setq file-name (file-name-nondirectory file)
 		  file-dir (file-name-directory file)))
        (list (read-file-name
-	      "Find alternate file: " file-dir nil nil file-name)
-	     ))))
+	      "Find alternate file: " file-dir nil nil file-name)))))
   (if (one-window-p)
       (find-file-other-window filename)
     (save-selected-window
@@ -647,9 +658,8 @@
 	    "Find alternate file: " file-dir nil nil file-name))))
   (and (buffer-modified-p) (buffer-file-name)
        ;; (not buffer-read-only)
-       (not (yes-or-no-p (format
-			  "Buffer %s is modified; kill anyway? "
-			  (buffer-name))))
+       (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? "
+				 (buffer-name))))
        (error "Aborted"))
   (let ((obuf (current-buffer))
 	(ofile buffer-file-name)
@@ -659,12 +669,12 @@
     (if (get-buffer " **lose**")
 	(kill-buffer " **lose**"))
     (rename-buffer " **lose**")
-    (setq buffer-file-name nil)
-    (setq buffer-file-number nil)
-    (setq buffer-file-truename nil)
     (unwind-protect
 	(progn
 	  (unlock-buffer)
+	  (setq buffer-file-name nil)
+	  (setq buffer-file-number nil)
+	  (setq buffer-file-truename nil)
 	  (find-file filename))
       (cond ((eq obuf (current-buffer))
 	     (setq buffer-file-name ofile)
@@ -689,23 +699,13 @@
 Choose the buffer's name using `generate-new-buffer-name'."
   (get-buffer-create (generate-new-buffer-name name)))
 
-;; FSF has automount-dir-prefix.  Our directory-abbrev-alist is more general.
-;; note: tmp_mnt bogosity conversion is established in paths.el.
-(defvar directory-abbrev-alist nil
-  "*Alist of abbreviations for file directories.
-A list of elements of the form (FROM . TO), each meaning to replace
-FROM with TO when it appears in a directory name.
-This replacement is done when setting up the default directory of a
-newly visited file.  *Every* FROM string should start with \\\\` or ^.
-
-Use this feature when you have directories which you normally refer to
-via absolute symbolic links or to eliminate automounter mount points
-from the beginning of your filenames.  Make TO the name of the link,
-and FROM the name it is linked to.")
+;(defconst automount-dir-prefix "^/tmp_mnt/"
+;  "Regexp to match the automounter prefix in a directory name.")
 
 (defvar abbreviated-home-dir nil
   "The user's homedir abbreviated according to `directory-abbrev-alist'.")
 
+;; XEmacs additional parameter
 (defun abbreviate-file-name (filename &optional hack-homedir)
   "Return a version of FILENAME shortened using `directory-abbrev-alist'.
 See documentation of variable `directory-abbrev-alist' for more information.
@@ -743,10 +743,12 @@
                  ;; If the home dir is just /, don't change it.
                  (not (and (= (match-end 0) 1) ;#### unix-specific
 			   (= (aref filename 0) ?/)))
+		 ;; MS-DOS root directories can come with a drive letter;
+		 ;; Novell Netware allows drive letters beyond `Z:'.
 		 (not (and (or (eq system-type 'ms-dos) 
 			       (eq system-type 'windows-nt))
 			   (save-match-data
-			     (string-match "^[a-zA-Z]:/$" filename)))))
+			     (string-match "^[a-zA-Z-`]:/$" filename)))))
 	    (setq filename
 		  (concat "~"
 			  (substring filename
@@ -780,12 +782,13 @@
 ;	  found)
 ;	(let ((number (nthcdr 10 (file-attributes truename)))
 ;	      (list (buffer-list)) found)
-;	  (and number
+;	  (and buffer-file-numbers-unique
+;	       number
 ;	       (while (and (not found) list)
 ;		 (save-excursion
 ;		   (set-buffer (car list))
-;		   (if (and buffer-file-number
-;                           (equal buffer-file-number number)
+;		   (if (and buffer-file-name
+;			    (equal buffer-file-number number)
 ;			    ;; Verify this buffer's file number
 ;			    ;; still belongs to its file.
 ;			    (file-exists-p buffer-file-name)
@@ -823,13 +826,15 @@
 The buffer is not selected, just returned to the caller.
 If NOWARN is non-nil warning messages about several potential
 problems will be suppressed."
-  (setq filename (abbreviate-file-name (expand-file-name filename)))
+  (setq filename
+	(abbreviate-file-name
+	 (expand-file-name filename)))
   (if (file-directory-p filename)
       (if find-file-run-dired
-	  (dired-noselect (if find-file-use-truenames
+	  (dired-noselect (if find-file-use-truenames	; XEmacs
 			      (abbreviate-file-name (file-truename filename))
 			    filename))
-	(error "%s is a directory." filename))
+	(error "%s is a directory" filename))
     (let* ((buf (get-file-buffer filename))
 ;	   (truename (abbreviate-file-name (file-truename filename)))
 ;	   (number (nthcdr 10 (file-attributes truename)))
@@ -839,17 +844,16 @@
 ;	   (other (and (not buf) (find-buffer-visiting filename)))
            (error nil))
 
-;     ;; Let user know if there is a buffer with the same truename.
-;      (if (and (not buf) same-truename (not nowarn))
-;	  (message "%s and %s are the same file (%s)"
-;		   filename (buffer-file-name same-truename)
-;		   truename)
-;	(if (and (not buf) same-number (not nowarn))
-;	  (message "%s and %s are the same file"
-;		   filename (buffer-file-name same-number))))
-;      ;; Optionally also find that buffer.
-;      (if (or find-file-existing-other-name find-file-visit-truename)
-;	  (setq buf (or same-truename same-number)))
+;      ;; Let user know if there is a buffer with the same truename.
+;      (if other
+;	  (progn
+;	    (or nowarn
+;		(string-equal filename (buffer-file-name other))
+;		(message "%s and %s are the same file"
+;			 filename (buffer-file-name other)))
+;	    ;; Optionally also find that buffer.
+;	    (if (or find-file-existing-other-name find-file-visit-truename)
+;		(setq buf other))))
 
       (if (and buf
                (or find-file-compare-truenames find-file-use-truenames)
@@ -901,13 +905,13 @@
 		(file-error
 		 ;; Unconditionally set error
 		 (setq error t)))
-	    (condition-case e
+	    (condition-case e	; XEmacs - pass error through
 		(insert-file-contents filename t)
 	      (file-error
 	       ;; Run find-file-not-found-hooks until one returns non-nil.
 	       (or (run-hook-with-args-until-success 'find-file-not-found-hooks)
 		   ;; If they fail too, set error.
-		   (setq error e)))))
+		   (setq error e))))) ; XEmacs
 	  ;; Find the file's truename, and maybe use that as visited name.
 	  ;; automatically computed in XEmacs.
 ;         (setq buffer-file-truename truename)
@@ -941,13 +945,15 @@
 		 (setq backup-inhibited t)))
 	  (if rawfile
 	      nil
-	    (after-find-file error (not nowarn)))))
+	    (after-find-file error (not nowarn))
+	    (setq buf (current-buffer)))))
       buf)))
 
 (defvar after-find-file-from-revert-buffer nil)
 
 (defun after-find-file (&optional error warn noauto
-				  after-find-file-from-revert-buffer)
+				  after-find-file-from-revert-buffer
+				  nomodes)
   "Called after finding a file and by the default revert function.
 Sets buffer mode, parses local variables.
 Optional args ERROR, WARN, and NOAUTO: ERROR non-nil means there was an
@@ -956,7 +962,10 @@
 NOAUTO means don't mess with auto-save mode.
 Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER non-nil
  means this call was from `revert-buffer'.
-Finishes by calling the functions in `find-file-hooks'."
+Finishes by calling the functions in `find-file-hooks'.
+Fifth arg NOMODES non-nil means don't alter the file's modes.
+Finishes by calling the functions in `find-file-hooks'
+unless NOMODES is non-nil."
   (setq buffer-read-only (not (file-writable-p buffer-file-name)))
   (if noninteractive
       nil
@@ -985,6 +994,7 @@
 		   ;; than when we save the buffer, because we want
 		   ;; autosaving to work.
 		   (setq buffer-read-only nil)
+		   ;; XEmacs change
 		   (or (file-exists-p (file-name-directory buffer-file-name))
 		       (if (yes-or-no-p
 			    (format
@@ -1000,8 +1010,9 @@
 	    (or not-serious (sit-for 1 t)))))
     (if (and auto-save-default (not noauto))
 	(auto-save-mode t)))
-  (normal-mode t)
-  (run-hooks 'find-file-hooks))
+  (unless nomodes
+    (normal-mode t)
+    (run-hooks 'find-file-hooks)))
 
 (defun normal-mode (&optional find-file)
   "Choose the major mode for this buffer automatically.
@@ -1015,6 +1026,7 @@
 run `normal-mode' explicitly."
   (interactive)
   (or find-file (funcall (or default-major-mode 'fundamental-mode)))
+  ;; XEmacs change
   (and (condition-case err
            (progn (set-auto-mode)
                   t)
@@ -1031,6 +1043,7 @@
    'purecopy
    '(("\\.te?xt\\'" . text-mode)
      ("\\.[ch]\\'" . c-mode)
+     ("\\.tex\\'" . tex-mode)
      ("\\.ltx\\'" . latex-mode)
      ("\\.el\\'" . emacs-lisp-mode)
      ("\\.l\\(i?sp\\)?\\'" . lisp-mode)
@@ -1055,6 +1068,10 @@
      ("\\.mss\\'" . scribe-mode)
      ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode)
      ("\\.icn\\'" . icon-mode)
+     ("\\.[ck]?sh\\'\\|\\.shar\\'\\|/\\.z?profile\\'" . sh-mode)
+     ("/\\.\\(bash_profile\\|z?login\\|bash_login\\|z?logout\\)\\'" . sh-mode)
+     ("/\\.\\(bash_logout\\|[kz]shrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode)
+     ("/\\.\\([kz]shenv\\|xinitrc\\|startxrc\\|xsession\\)\\'" . sh-mode)
 ;;; The following should come after the ChangeLog pattern
 ;;; for the sake of ChangeLog.1, etc.
 ;;; and after the .scm.[0-9] pattern too.
@@ -1074,6 +1091,7 @@
      ;; Mailer puts message to be edited in
      ;; /tmp/Re.... or Message
      ("^/tmp/Re" . text-mode)
+     ("^/tmp/L[0-9]+TMP\\.html" . text-mode)	; Lynx mail mode
      ("/Message[0-9]*\\'" . text-mode)
      ("/drafts/[0-9]+\\'" . mh-letter-mode)
      ;; some news reader is reported to use this
@@ -1104,15 +1122,15 @@
 
 (defconst interpreter-mode-alist
   (mapcar 'purecopy
-          '(("^#!.*csh"	  . csh-mode)
-            ("^#!.*sh\\b" . ksh-mode)
+          '(("^#!.*[acjkwz]sh"	  . sh-mode)
+            ("^#!.*sh\\b" . sh-mode)
             ("^#!.*\\b\\(scope\\|wish\\|tcl\\|expect\\)" . tcl-mode)
             ("perl"   . perl-mode)
             ("python" . python-mode)
             ("awk\\b" . awk-mode)
             ("rexx"   . rexx-mode)
             ("scm"    . scheme-mode)
-            ("^:"     . ksh-mode)
+            ("^:"     . sh-mode)
             ))
   "Alist mapping interpreter names to major modes.
 This alist is used to guess the major mode of a file based on the
@@ -1140,6 +1158,7 @@
   "" ; set by command-line
   "File name including directory of user's initialization file.")
 
+;; XEmacs (This function is not synched with FSF)
 (defun set-auto-mode ()
   "Select major mode appropriate for current buffer.
 This checks for a -*- mode tag in the buffer's text,
@@ -1201,6 +1220,89 @@
                   (funcall mode))
               ))))))
 
+;; XEmacs: this function is not synched with FSF
+(defun hack-local-variables-prop-line (&optional force)
+  ;; Set local variables specified in the -*- line.
+  ;; Returns t if mode was set.
+  (let ((result nil))
+    (save-excursion
+      (goto-char (point-min))
+      (skip-chars-forward " \t\n\r")
+      (let ((end (save-excursion 
+		   ;; If the file begins with "#!"
+		   ;; (un*x exec interpreter magic), look
+		   ;; for mode frobs in the first two
+		   ;; lines.  You cannot necessarily
+		   ;; put them in the first line of
+		   ;; such a file without screwing up
+		   ;; the interpreter invocation.
+		   (end-of-line (and (looking-at "^#!") 2))
+		   (point))))
+	;; Parse the -*- line into the `result' alist.
+	(cond ((not (search-forward "-*-" end t))
+	       ;; doesn't have one.
+	       nil)
+	      ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)")
+	       ;; Antiquated form: "-*- ModeName -*-".
+	       (setq result
+		     (list (cons 'mode
+				 (intern (buffer-substring
+					  (match-beginning 1)
+					  (match-end 1)))))
+		     ))
+	      (t
+	       ;; Usual form: '-*-' [  ':'  ';' ]* '-*-'
+	       ;; (last ";" is optional).
+	       (save-excursion
+		 (if (search-forward "-*-" end t)
+		     (setq end (- (point) 3))
+		   (error "-*- not terminated before end of line")))
+	       (while (< (point) end)
+		 (or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*")
+		     (error "malformed -*- line"))
+		 (goto-char (match-end 0))
+		 ;; There used to be a downcase here,
+		 ;; but the manual didn't say so,
+		 ;; and people want to set var names that aren't all lc.
+		 (let ((key (intern (buffer-substring
+				     (match-beginning 1)
+				     (match-end 1))))
+		       (val (save-restriction
+			      (narrow-to-region (point) end)
+			      (read (current-buffer)))))
+		   ;; Case sensitivity!  Icepicks in my forehead!
+		   (if (equal (downcase (symbol-name key)) "mode")
+		       (setq key 'mode))
+		   (setq result (cons (cons key val) result))
+		   (skip-chars-forward " \t;")))
+	       (setq result (nreverse result))))))
+	
+    (let ((set-any-p (or force (hack-local-variables-p t)))
+	  (mode-p nil))
+      (while result
+	(let ((key (car (car result)))
+	      (val (cdr (car result))))
+	  (cond ((eq key 'mode)
+		 (setq mode-p t)
+		 (funcall (intern (concat (downcase (symbol-name val))
+					  "-mode"))))
+		(set-any-p
+		 (hack-one-local-variable key val))
+		(t
+		 nil)))
+	(setq result (cdr result)))
+      mode-p)))
+
+(defvar hack-local-variables-hook nil
+  "Normal hook run after processing a file's local variables specs.
+Major modes can use this to examine user-specified local variables
+in order to initialize other data structure based on them.
+
+This hook runs even if there were no local variables or if their
+evaluation was suppressed.  See also `enable-local-variables' and
+`enable-local-eval'.")
+
+;; XEmacs this function is not synched with FSF
 (defun hack-local-variables (&optional force)
   "Parse, and bind or evaluate as appropriate, any local variables
 for current buffer."
@@ -1336,80 +1438,9 @@
                 (hack-one-local-variable var val))))))))
 
 
-(defun hack-local-variables-prop-line (&optional force)
-  ;; Set local variables specified in the -*- line.
-  ;; Returns t if mode was set.
-  (let ((result nil))
-    (save-excursion
-      (goto-char (point-min))
-      (skip-chars-forward " \t\n\r")
-      (let ((end (save-excursion 
-		   ;; If the file begins with "#!"
-		   ;; (un*x exec interpreter magic), look
-		   ;; for mode frobs in the first two
-		   ;; lines.  You cannot necessarily
-		   ;; put them in the first line of
-		   ;; such a file without screwing up
-		   ;; the interpreter invocation.
-		   (end-of-line (and (looking-at "^#!") 2))
-		   (point))))
-	;; Parse the -*- line into the `result' alist.
-	(cond ((not (search-forward "-*-" end t))
-	       ;; doesn't have one.
-	       nil)
-	      ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)")
-	       ;; Antiquated form: "-*- ModeName -*-".
-	       (setq result
-		     (list (cons 'mode
-				 (intern (buffer-substring
-					  (match-beginning 1)
-					  (match-end 1)))))
-		     ))
-	      (t
-	       ;; Usual form: '-*-' [  ':'  ';' ]* '-*-'
-	       ;; (last ";" is optional).
-	       (save-excursion
-		 (if (search-forward "-*-" end t)
-		     (setq end (- (point) 3))
-		   (error "-*- not terminated before end of line")))
-	       (while (< (point) end)
-		 (or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*")
-		     (error "malformed -*- line"))
-		 (goto-char (match-end 0))
-		 ;; There used to be a downcase here,
-		 ;; but the manual didn't say so,
-		 ;; and people want to set var names that aren't all lc.
-		 (let ((key (intern (buffer-substring
-				     (match-beginning 1)
-				     (match-end 1))))
-		       (val (save-restriction
-			      (narrow-to-region (point) end)
-			      (read (current-buffer)))))
-		   ;; Case sensitivity!  Icepicks in my forehead!
-		   (if (equal (downcase (symbol-name key)) "mode")
-		       (setq key 'mode))
-		   (setq result (cons (cons key val) result))
-		   (skip-chars-forward " \t;")))
-	       (setq result (nreverse result))))))
-	
-    (let ((set-any-p (or force (hack-local-variables-p t)))
-	  (mode-p nil))
-      (while result
-	(let ((key (car (car result)))
-	      (val (cdr (car result))))
-	  (cond ((eq key 'mode)
-		 (setq mode-p t)
-		 (funcall (intern (concat (downcase (symbol-name val))
-					  "-mode"))))
-		(set-any-p
-		 (hack-one-local-variable key val))
-		(t
-		 nil)))
-	(setq result (cdr result)))
-      mode-p)))
 
 (defconst ignored-local-variables
-  (list 'enable-local-eval)
+  '(enable-local-eval)
   "Variables to be ignored in a file's local variable spec.")
 
 ;; Get confirmation before setting these variables as locals in a file.
@@ -1427,10 +1458,12 @@
 (put 'load-path 'risky-local-variable t)
 (put 'exec-directory 'risky-local-variable t)
 (put 'process-environment 'risky-local-variable t)
+(put 'dabbrev-case-fold-search 'risky-local-variable t)
+(put 'dabbrev-case-replace 'risky-local-variable t)
 ;; Don't wait for outline.el to be loaded, for the sake of outline-minor-mode.
 (put 'outline-level 'risky-local-variable t)
 (put 'rmail-output-file-alist 'risky-local-variable t)
-	    
+
 ;; This one is safe because the user gets to check it before it is used.
 (put 'compile-command 'safe-local-variable t)
 
@@ -1485,12 +1518,15 @@
 	(t (make-local-variable var)
 	   (set var val))))
 
-(defun set-visited-file-name (filename)
+(defun set-visited-file-name (filename &optional no-query)
   "Change name of file visited in current buffer to FILENAME.
 The next time the buffer is saved it will go in the newly specified file.
 nil or empty string as argument means make buffer not be visiting any file.
 Remember to delete the initial contents of the minibuffer
-if you wish to pass an empty string as the argument."
+if you wish to pass an empty string as the argument.
+
+The optional second argument NO-QUERY, if non-nil, inhibits asking for
+confirmation in the case where the file FILENAME already exists."
   (interactive "FSet visited file name: ")
   (if (buffer-base-buffer)
       (error "An indirect buffer cannot visit a file"))
@@ -1504,8 +1540,15 @@
 	(progn
 	  (setq truename (file-truename filename))
 	  ;; #### Do we need to check if truename is non-nil?
+	  ;; XEmacs: FSF uses -visit-
 	  (if find-file-use-truenames
 	      (setq filename truename))))
+;    (let ((buffer (and filename (find-buffer-visiting filename))))
+;      (and buffer (not (eq buffer (current-buffer)))
+;	   (not no-query)
+;	   (not (y-or-n-p (message "A buffer is visiting %s; proceed? "
+;				   filename)))
+;	   (error "Aborted")))
     (or (equal filename buffer-file-name)
 	(progn
 	  (and filename (lock-buffer filename))
@@ -1523,6 +1566,7 @@
     (setq buffer-backed-up nil)
     (clear-visited-file-modtime)
     (compute-buffer-file-truename) ; insert-file-contents does this too.
+;; XEmacs deletion
 ;    ;; Abbreviate the file names of the buffer.
 ;    (if truename
 ;	 (progn
@@ -1537,9 +1581,9 @@
   ;; that visit things that are not local files as if they were files.
   ;; Changing to visit an ordinary local file instead should flush the hook.
   (kill-local-variable 'write-file-hooks)
-  (kill-local-variable 'after-save-hook)
+  (kill-local-variable 'after-save-hook) ; XEmacs
   (kill-local-variable 'local-write-file-hooks)
-  (kill-local-variable 'write-file-data-hooks)
+  (kill-local-variable 'write-file-data-hooks) ; XEmacs
   (kill-local-variable 'revert-buffer-function)
   (kill-local-variable 'backup-inhibited)
   ;; If buffer was read-only because of version control,
@@ -1571,7 +1615,7 @@
 	 (rename-file oauto buffer-auto-save-file-name t)))
   (if buffer-file-name
       (set-buffer-modified-p t))
-  ;; #### ??
+  ;; #### ?? (Not in FSF -sb)
   (run-hooks 'after-set-visited-file-name-hooks))
 
 (defun write-file (filename &optional confirm)
@@ -1580,8 +1624,10 @@
 If the buffer is already visiting a file, you can specify
 a directory name as FILENAME, to write a file of the same
 old name in that directory.
+
 If optional second arg CONFIRM is non-nil,
-ask for confirmation for overwriting an existing file."
+ask for confirmation for overwriting an existing file.
+Interactively, confirmation is required unless you supply a prefix argument."
 ;;  (interactive "FWrite file: ")
   (interactive
    (list (if buffer-file-name
@@ -1592,6 +1638,7 @@
 					  (buffer-local-variables)))
 			       nil nil (buffer-name)))
 	 t))
+  ;; XEmacs
   (and (eq (current-buffer) mouse-grabbed-buffer)
        (error "Can't write minibuffer window"))
   (or (null filename) (string-equal filename "")
@@ -1607,17 +1654,16 @@
 		 (error "Canceled")))
 	(set-visited-file-name filename)))
   (set-buffer-modified-p t)
-  (setq buffer-read-only nil)
+  (setq buffer-read-only nil)	; XEmacs
   (save-buffer))
 
 (defun backup-buffer ()
   "Make a backup of the disk file visited by the current buffer, if appropriate.
 This is normally done before saving the buffer the first time.
-If the value is non-nil, it is the result of `file-modes' on the original file;
-this means that the caller, after saving the buffer, should change the modes
-of the new file to agree with the old modes."
-  (if (and make-backup-files
-           (not backup-inhibited)
+If the value is non-nil, it is the result of `file-modes' on the original
+file; this means that the caller, after saving the buffer, should change
+the modes of the new file to agree with the old modes."
+  (if (and make-backup-files (not backup-inhibited)
 	   (not buffer-backed-up)
 	   (file-exists-p buffer-file-name)
 	   (memq (aref (elt (file-attributes buffer-file-name) 8) 0)
@@ -1669,8 +1715,11 @@
 			(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%%~")
+		     (setq backupname (expand-file-name
+				       (convert-standard-filename
+					"~/%backup%~")))
+		     (message "Cannot write backup file; backing up in %s"
+			      (file-name-nondirectory backupname))
 		     (sleep-for 1)
 		     (condition-case ()
 			 (copy-file real-file-name backupname t t)
@@ -1716,7 +1765,8 @@
 		   (if keep-backup-version
 		       (length name)
 		     (or (string-match "\\.~[0-9.]+~\\'" name)
-			 ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~"
+			 ;; XEmacs - VC uses extensions like ".~tagname~"
+			 ;; or ".~1.1.5.2~"
 			 (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name)))
 			   (and pos
 				;; #### - is this filesystem check too paranoid?
@@ -1752,11 +1802,17 @@
 (defun make-backup-file-name (file)
   "Create the non-numeric backup file name for FILE.
 This is a separate function so you can redefine it for customization."
-  (if (eq system-type 'ms-dos)
+  (if (and (eq system-type 'ms-dos)
+	   (not (msdos-long-file-names)))
       (let ((fn (file-name-nondirectory file)))
 	(concat (file-name-directory file)
 		(if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
 		    (substring fn 0 (match-end 1)))
+;		(or
+;		 (and (string-match "\\`[^.]+\\'" fn)
+;		      (concat (match-string 0 fn) ".~"))
+;		 (and (string-match "\\`[^.]+\\.\\(..?\\)?" fn)
+;		      (concat (match-string 0 fn) "~")))))
 		".bak"))
     (concat file "~")))
 
@@ -1837,33 +1893,27 @@
 (defun file-relative-name (filename &optional directory)
   "Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
   (setq filename (expand-file-name filename)
-        directory (file-name-as-directory (if directory
-					      (expand-file-name directory)
-					      default-directory)))
-  (while directory
-    (let ((up (file-name-directory (directory-file-name directory))))
-      (cond ((and (string= directory up)
-                  (file-name-absolute-p directory))
-             ;; "/"
-             (setq directory nil))
-            ((string-match (concat "\\`" (regexp-quote directory))
-                           filename)
-             (setq filename (substring filename (match-end 0)))
-             (setq directory nil))
-            (t
-             ;; go up one level
-             (setq directory up)))))
-  filename)
+	directory (file-name-as-directory (expand-file-name
+					   (or directory default-directory))))
+  (let ((ancestor ""))
+    (while (not (string-match (concat "^" (regexp-quote directory)) filename))
+      (setq directory (file-name-directory (substring directory 0 -1))
+	    ancestor (concat "../" ancestor)))
+    (concat ancestor (substring filename (match-end 0)))))
 
 (defun save-buffer (&optional args)
   "Save current buffer in visited file if modified.  Versions described below.
 
 By default, makes the previous version into a backup file
  if previously requested or if this is the first save.
-With 1 or 3 \\[universal-argument]'s, marks this version
+With 1 \\[universal-argument], marks this version
  to become a backup when the next save is done.
-With 2 or 3 \\[universal-argument]'s,
+With 2 \\[universal-argument]'s,
  unconditionally makes the previous version into a backup file.
+With 3 \\[universal-argument]'s, marks this version
+ to become a backup when the next save is done,
+ and unconditionally makes the previous version into a backup file.
+
 With argument of 0, never makes the previous version into a backup file.
 
 If a file's name is FOO, the names of its numbered backup versions are
@@ -1885,8 +1935,7 @@
 	(make-backup-files (or (and make-backup-files (not (eq args 0)))
 			       (memq args '(16 64)))))
     (and modp (memq args '(16 64)) (setq buffer-backed-up nil))
-    (if (and modp large) (message "Saving file %s..."
-				  (buffer-file-name)))
+    (if (and modp large) (message "Saving file %s..." (buffer-file-name)))
     (basic-save-buffer)
     (and modp (memq args '(4 64)) (setq buffer-backed-up nil))))
 
@@ -1941,7 +1990,8 @@
     (if (buffer-base-buffer)
 	(set-buffer (buffer-base-buffer)))
     (if (buffer-modified-p)
-	(let ((recent-save (recent-auto-save-p)))
+	(let ((recent-save (recent-auto-save-p))
+	      setmodes tempsetmodes)
 	  ;; On VMS, rename file and buffer to get rid of version number.
 	  (if (and (eq system-type 'vax-vms)
 		   (not (string= buffer-file-name
@@ -2027,7 +2077,7 @@
 ;; but inhibited if one of write-file-hooks returns non-nil.
 ;; It returns a value to store in setmodes.
 (defun basic-save-buffer-1 ()
-  (let (setmodes tempsetmodes)
+  (let (tempsetmodes setmodes)
     (if (not (file-writable-p buffer-file-name))
 	(let ((dir (file-name-directory buffer-file-name)))
 	  (if (not (file-directory-p dir))
@@ -2043,20 +2093,25 @@
 		 "Attempt to save to a file which you aren't allowed to write"))))))
     (or buffer-backed-up
 	(setq setmodes (backup-buffer)))
-    (let ((dir (file-name-directory buffer-file-name))) 
+    (let ((dir (file-name-directory buffer-file-name)))
       (if (and file-precious-flag
 	       (file-writable-p dir))
 	  ;; If file is precious, write temp name, then rename it.
 	  ;; This requires write access to the containing dir,
 	  ;; which is why we don't try it if we don't have that access.
 	  (let ((realname buffer-file-name)
-		tempname nogood i succeed
+		tempname temp nogood i succeed
 		(old-modtime (visited-file-modtime)))
 	    (setq i 0)
 	    (setq nogood t)
 	    ;; Find the temporary name to write under.
 	    (while nogood
-	      (setq tempname (format "%s#tmp#%d" dir i))
+	      (setq tempname (format
+			      (if (and (eq system-type 'ms-dos)
+				       (not (msdos-long-file-names)))
+				  "%s#%d.tm#" ; MSDOS limits files to 8+3
+				"%s#tmp#%d")
+			      dir i))
 	      (setq nogood (file-exists-p tempname))
 	      (setq i (1+ i)))
 	    (unwind-protect
@@ -2067,7 +2122,7 @@
 		       (setq succeed t))
 	      ;; If writing the temp file fails,
 	      ;; delete the temp file.
-	      (or succeed 
+	      (or succeed
 		  (progn
 		    (delete-file tempname)
 		    (set-visited-file-modtime old-modtime))))
@@ -2086,6 +2141,7 @@
 	       ;; Change the mode back, after writing.
 	       (setq setmodes (file-modes buffer-file-name))
 	       (set-file-modes buffer-file-name 511)))
+	;; XEmacs change to end of function
 	(basic-write-file-data buffer-file-name buffer-file-truename)))
     (setq buffer-file-number
 	  (if buffer-file-name
@@ -2129,6 +2185,7 @@
  as well as about file buffers."
   (interactive "P")
   (save-window-excursion
+    ;; XEmacs - do not use queried flag
     (let ((files-done
 	   (map-y-or-n-p
 	    (function
@@ -2239,13 +2296,16 @@
 	 (file (file-name-nondirectory filename))
 	 (dir  (file-name-directory    filename))
 	 (comp (file-name-all-completions file dir))
-	 newest)
+	 newest tem)
     (while comp
-      (setq file (concat dir (car comp))
+      (setq tem (car comp)
 	    comp (cdr comp))
-      (if (and (backup-file-name-p file)
-	       (or (null newest) (file-newer-than-file-p file newest)))
-	  (setq newest file)))
+      (cond ((and (backup-file-name-p tem)
+		  (string= (file-name-sans-versions tem) file))
+	     (setq tem (concat dir tem))
+	     (if (or (null newest)
+		     (file-newer-than-file-p tem newest))
+		 (setq newest tem)))))
     newest))
 
 (defun rename-uniquely ()
@@ -2270,6 +2330,7 @@
       (rename-buffer name)
       (redraw-modeline))))
 
+;; XEmacs
 (defun make-directory-path (path)
   "Create all the directories along path that don't exist yet."
   (interactive "Fdirectory path to create: ")
@@ -2283,6 +2344,7 @@
 
 Noninteractively, the second (optional) argument PARENTS says whether
 to create parent directories if they don't exist."
+  ;; XEmacs
   (interactive (list (let ((current-prefix-arg current-prefix-arg))
 		       (read-directory-name "Create directory: "))
 		     current-prefix-arg))
@@ -2326,7 +2388,7 @@
 If `revert-buffer-function' is used to override the normal revert
 mechanism, this hook is not used.")
 
-(defun revert-buffer (&optional ignore-auto noconfirm)
+(defun revert-buffer (&optional ignore-auto noconfirm preserve-modes)
   "Replace the buffer text with the text of the visited file on disk.
 This undoes all changes since the file was visited or saved.
 With a prefix argument, offer to revert from latest auto-save file, if
@@ -2356,7 +2418,7 @@
       (funcall revert-buffer-function ignore-auto noconfirm)
     (let* ((opoint (point))
 	   (auto-save-p (and (not ignore-auto)
-                             (recent-auto-save-p)
+			     (recent-auto-save-p)
 			     buffer-auto-save-file-name
 			     (file-readable-p buffer-auto-save-file-name)
 			     (y-or-n-p
@@ -2381,6 +2443,7 @@
 	     ;; Effectively copy the after-revert-hook status,
 	     ;; since after-find-file will clobber it.
 	     (let ((global-hook (default-value 'after-revert-hook))
+		   ;; XEmacs
 		   (local-hook-p (local-variable-p 'after-revert-hook
 						   (current-buffer)))
 		   (local-hook (and (local-variable-p 'after-revert-hook
@@ -2407,7 +2470,7 @@
 	       ;; have changed the truename.
 	       ;XEmacs: already done by insert-file-contents
 	       ;(compute-buffer-file-truename)
-	       (after-find-file nil nil t t)
+	       (after-find-file nil nil t t preserve-modes)
 	       ;; Run after-revert-hook as it was before we reverted.
 	       (setq-default revert-buffer-internal-hook global-hook)
 	       (if local-hook-p
@@ -2425,7 +2488,7 @@
   ;; Not just because users often use the default.
   (interactive "FRecover file: ")
   (setq file (expand-file-name file))
-  (if (auto-save-file-name-p file)
+  (if (auto-save-file-name-p (file-name-nondirectory file))
       (error "%s is an auto-save file" file))
   (let ((file-name (let ((buffer-file-name file))
 		     (make-auto-save-file-name))))
@@ -2455,7 +2518,8 @@
 To choose one, move point to the proper line and then type C-c C-c.
 Then you'll be asked about a number of files to recover."
   (interactive)
-  (dired (concat auto-save-list-file-prefix "*"))
+  (let ((ls-lisp-support-shell-wildcards t))
+    (dired (concat auto-save-list-file-prefix "*")))
   (goto-char (point-min))
   (or (looking-at "Move to the session you want to recover,")
       (let ((inhibit-read-only t))
@@ -2463,6 +2527,7 @@
 		"then type C-c C-c to select it.\n\n"
 		"You can also delete some of these files;\n"
 		"type d on a line to mark that file for deletion.\n\n")))
+  ;; XEmacs
   (use-local-map (let ((map (make-sparse-keymap)))
 		   (set-keymap-parents map (list (current-local-map)))
 		   map))
@@ -2532,7 +2597,7 @@
 			     (lambda (file)
 			       (condition-case nil
 				   (save-excursion (recover-file file))
-				 (error 
+				 (error
 				  "Failed to recover `%s'" file)))
 			     files
 			     '("file" "files" "recover"))
@@ -2549,6 +2614,7 @@
 	(and (not (string-equal name ""))
 	     (/= (aref name 0) ? )
 	     (yes-or-no-p
+	      ;; XEmacs change
 	      (format
 	       (if (buffer-modified-p buffer)
 		   (gettext "Buffer %s HAS BEEN EDITED.  Kill? ")
@@ -2596,6 +2662,7 @@
 	(rename-file osave buffer-auto-save-file-name t))))
 
 ;; see also ../packages/auto-save.el
+;; XEmacs change
 (defun make-auto-save-file-name (&optional filename)
   "Return file name to use for auto-saves of current buffer.
 Does not consider `auto-save-visited-file-name' as that variable is checked
@@ -2658,10 +2725,76 @@
 
 (defun auto-save-file-name-p (filename)
   "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'.
-FILENAME should lack slashes.
-You can redefine this for customization."
+FILENAME should lack slashes.  You can redefine this for customization."
   (string-match "\\`#.*#\\'" filename))
 
+(defun wildcard-to-regexp (wildcard)
+  "Given a shell file name pattern WILDCARD, return an equivalent regexp.
+The generated regexp will match a filename iff the filename
+matches that wildcard according to shell rules.  Only wildcards known
+by `sh' are supported."
+  (let* ((i (string-match "[[.*+\\^$?]" wildcard))
+	 ;; Copy the initial run of non-special characters.
+	 (result (substring wildcard 0 i))
+	 (len (length wildcard)))
+    ;; If no special characters, we're almost done.
+    (if i
+	(while (< i len)
+	  (let ((ch (aref wildcard i))
+		j)
+	    (setq
+	     result
+	     (concat result
+		     (cond
+		      ((eq ch ?\[)	; [...] maps to regexp char class
+		       (progn
+			 (setq i (1+ i))
+			 (concat
+			  (cond
+			   ((eq (aref wildcard i) ?!) ; [!...] -> [^...]
+			    (progn
+			      (setq i (1+ i))
+			      (if (eq (aref wildcard i) ?\])
+				  (progn
+				    (setq i (1+ i))
+				    "[^]")
+				"[^")))
+			   ((eq (aref wildcard i) ?^)
+			    ;; Found "[^".  Insert a `\0' character
+			    ;; (which cannot happen in a filename)
+			    ;; into the character class, so that `^'
+			    ;; is not the first character after `[',
+			    ;; and thus non-special in a regexp.
+			    (progn
+			      (setq i (1+ i))
+			      "[\000^"))
+			   ((eq (aref wildcard i) ?\])
+			    ;; I don't think `]' can appear in a
+			    ;; character class in a wildcard, but
+			    ;; let's be general here.
+			    (progn
+			      (setq i (1+ i))
+			      "[]"))
+			   (t "["))
+			  (prog1        ; copy everything upto next `]'.
+			      (substring wildcard
+					 i
+					 (setq j (string-match
+						  "]" wildcard i)))
+			    (setq i (if j (1- j) (1- len)))))))
+		      ((eq ch ?.)  "\\.")
+		      ((eq ch ?*)  "[^\000]*")
+		      ((eq ch ?+)  "\\+")
+		      ((eq ch ?^)  "\\^")
+		      ((eq ch ?$)  "\\$")
+		      ((eq ch ?\\) "\\\\") ; probably cannot happen...
+		      ((eq ch ??)  "[^\000]")
+		      (t (char-to-string ch)))))
+	    (setq i (1+ i)))))
+    ;; Shell wildcards should match the entire filename,
+    ;; not its part.  Make the regexp say so.
+    (concat "\\`" result "\\'")))
+
 (defconst list-directory-brief-switches
   (if (eq system-type 'vax-vms) "" "-CF")
   "*Switches for list-directory to pass to `ls' for brief listing,")
@@ -2694,7 +2827,10 @@
       (terpri)
       (save-excursion
 	(set-buffer "*Directory*")
-	(setq default-directory (file-name-directory dirname))
+	(setq default-directory
+	      (if (file-directory-p dirname)
+		  (file-name-as-directory dirname)
+		(file-name-directory dirname)))
 	(let ((wildcard (not (file-directory-p dirname))))
 	  (insert-directory dirname switches wildcard (not wildcard)))))))
 
@@ -2740,10 +2876,10 @@
 	  (vms-read-directory file switches (current-buffer))
 	(if wildcard
 	    ;; Run ls in the directory of the file pattern we asked for.
-	    (let ((default-directory 
-                      (if (file-name-absolute-p file)
-                          (file-name-directory file)
-                          (file-name-directory (expand-file-name file))))
+	    (let ((default-directory
+		    (if (file-name-absolute-p file)
+			(file-name-directory file)
+		      (file-name-directory (expand-file-name file))))
 		  (pattern (file-name-nondirectory file))
 		  (beg 0))
 	      ;; Quote some characters that have special meanings in shells;
@@ -2751,7 +2887,7 @@
 	      ;; We also currently don't quote the quoting characters
 	      ;; in case people want to use them explicitly to quote
 	      ;; wildcard characters.
-              ;;#### Unix-specific
+	      ;;#### Unix-specific
 	      (while (string-match "[ \t\n;<>&|()#$]" pattern beg)
 		(setq pattern
 		      (concat (substring pattern 0 (match-beginning 0))
@@ -2782,7 +2918,7 @@
 			     (setq list (cons (substring switches 0 (match-beginning 0))
 					      list)
 				   switches (substring switches (match-end 0))))
-			   (setq list (cons switches list)))))
+			   (setq list (nreverse (cons switches list))))))
 		   (append list
 			   (list
 			    (if full-directory-p
@@ -2824,6 +2960,7 @@
        (run-hook-with-args-until-failure 'kill-emacs-query-functions)
        (kill-emacs)))
 
+;; XEmacs
 (defun symlink-expand-file-name (filename)
   "If FILENAME is a symlink, return its non-symlink equivalent.
 Unlike `file-truename', this doesn't chase symlinks in directory
@@ -2838,7 +2975,7 @@
       (error "Apparently circular symlink path"))))
 
 
-
+;; Written in C in FSF
 (defun insert-file-contents (filename &optional visit beg end replace)
   "Insert contents of file FILENAME after point.
 Returns list of absolute file name and length of data inserted.
@@ -2857,6 +2994,7 @@
 and (2) it puts less data in the undo list."
   (insert-file-contents-internal filename visit beg end replace))
 
+;; Written in C in FSF
 (defun write-region (start end filename &optional append visit lockname)
   "Write current region into specified file.
 When called from a program, takes three arguments:
@@ -2878,6 +3016,7 @@
   (interactive "r\nFWrite region to file: ")
   (write-region-internal start end filename append visit lockname))
 
+;; Written in C in FSF
 (defun load (file &optional noerror nomessage nosuffix)
   "Execute a file of Lisp code named FILE.
 First try FILE with `.elc' appended, then try with `.el',
@@ -2892,4 +3031,27 @@
 Return t if file exists."
   (load-internal file noerror nomessage nosuffix))
 
+;(define-key ctl-x-map "\C-f" 'find-file)
+;(define-key ctl-x-map "\C-q" 'toggle-read-only)
+;(define-key ctl-x-map "\C-r" 'find-file-read-only)
+;(define-key ctl-x-map "\C-v" 'find-alternate-file)
+;(define-key ctl-x-map "\C-s" 'save-buffer)
+;(define-key ctl-x-map "s" 'save-some-buffers)
+;(define-key ctl-x-map "\C-w" 'write-file)
+;(define-key ctl-x-map "i" 'insert-file)
+;(define-key esc-map "~" 'not-modified)
+;(define-key ctl-x-map "\C-d" 'list-directory)
+;(define-key ctl-x-map "\C-c" 'save-buffers-kill-emacs)
+
+;(define-key ctl-x-4-map "f" 'find-file-other-window)
+;(define-key ctl-x-4-map "r" 'find-file-read-only-other-window)
+;(define-key ctl-x-4-map "\C-f" 'find-file-other-window)
+;(define-key ctl-x-4-map "b" 'switch-to-buffer-other-window)
+;(define-key ctl-x-4-map "\C-o" 'display-buffer)
+
+;(define-key ctl-x-5-map "b" 'switch-to-buffer-other-frame)
+;(define-key ctl-x-5-map "f" 'find-file-other-frame)
+;(define-key ctl-x-5-map "\C-f" 'find-file-other-frame)
+;(define-key ctl-x-5-map "r" 'find-file-read-only-other-frame)
+
 ;;; files.el ends here
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/fill.el
--- a/lisp/prim/fill.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/fill.el	Mon Aug 13 08:46:56 2007 +0200
@@ -693,7 +693,8 @@
 			   (point) (min (point-max) (+ (length fill-prefix)
 						       (point))))))
 	      (forward-char (length fill-prefix))
-	    (if (and adaptive-fill-mode 
+	    ;; XEmacs bug fix
+	    (if (and adaptive-fill-mode adaptive-fill-regexp
 		     (looking-at adaptive-fill-regexp))
 		(goto-char (match-end 0))))
 	  (setq fp-end (point))
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/format.el
--- a/lisp/prim/format.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/format.el	Mon Aug 13 08:46:56 2007 +0200
@@ -1,7 +1,9 @@
 ;;; format.el --- read and save files in multiple formats
+
 ;; Copyright (c) 1994, 1995 Free Software Foundation
 
 ;; Author: Boris Goldowsky 
+;; Keywords: extensions
 
 ;; This file is part of GNU Emacs.
 
@@ -9,55 +11,59 @@
 ;; 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.
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
 
-;;; Synched up with: FSF 19.30.
+;;; Synched up with: FSF 19.34.
 
 ;;; Commentary:
-;; This file defines a unified mechanism for saving & loading files stored in
-;; different formats.  `format-alist' contains information that directs
+
+;; This file defines a unified mechanism for saving & loading files stored
+;; in different formats.  `format-alist' contains information that directs
 ;; Emacs to call an encoding or decoding function when reading or writing
-;; files that match certain conditions.  
+;; files that match certain conditions.
 ;;
-;; When a file is visited, its format is determined by matching the beginning
-;; of the file against regular expressions stored in `format-alist'.  If this
-;; fails, you can manually translate the buffer using `format-decode-buffer'.
-;; In either case, the formats used are listed in the variable
-;; `buffer-file-format', and become the default format for saving the buffer.
-;; To save a buffer in a different format, change this variable, or use
-;; `format-write-file'.
+;; When a file is visited, its format is determined by matching the
+;; beginning of the file against regular expressions stored in
+;; `format-alist'.  If this fails, you can manually translate the buffer
+;; using `format-decode-buffer'.  In either case, the formats used are
+;; listed in the variable `buffer-file-format', and become the default
+;; format for saving the buffer.  To save a buffer in a different format,
+;; change this variable, or use `format-write-file'.
 ;;
 ;; Auto-save files are normally created in the same format as the visited
-;; file, but the variable `auto-save-file-format' can be set to a particularly
-;; fast or otherwise preferred format to be used for auto-saving (or nil to do
-;; no encoding on auto-save files, but then you risk losing any
-;; text-properties in the buffer).
+;; file, but the variable `auto-save-file-format' can be set to a
+;; particularly fast or otherwise preferred format to be used for
+;; auto-saving (or nil to do no encoding on auto-save files, but then you
+;; risk losing any text-properties in the buffer).
 ;;
-;; You can manually translate a buffer into or out of a particular format with
-;; the functions `format-encode-buffer' and `format-decode-buffer'.
-;; To translate just the region use the functions `format-encode-region' and
-;; `format-decode-region'.  
+;; You can manually translate a buffer into or out of a particular format
+;; with the functions `format-encode-buffer' and `format-decode-buffer'.
+;; To translate just the region use the functions `format-encode-region'
+;; and `format-decode-region'.  
 ;;
-;; You can define a new format by writing the encoding and decoding functions,
-;; and adding an entry to `format-alist'.  See enriched.el for an example of
-;; how to implement a file format.  There are various functions defined
-;; in this file that may be useful for writing the encoding and decoding
-;; functions:
-;;  * `format-annotate-region' and `format-deannotate-region' allow a single
-;;     alist of information to be used for encoding and decoding.  The alist
-;;     defines a correspondence between strings in the file ("annotations")
-;;     and text-properties in the buffer.
+;; You can define a new format by writing the encoding and decoding
+;; functions, and adding an entry to `format-alist'.  See enriched.el for
+;; an example of how to implement a file format.  There are various
+;; functions defined in this file that may be useful for writing the
+;; encoding and decoding functions:
+;;  * `format-annotate-region' and `format-deannotate-region' allow a
+;;     single alist of information to be used for encoding and decoding.
+;;     The alist defines a correspondence between strings in the file
+;;     ("annotations") and text-properties in the buffer.
 ;;  * `format-replace-strings' is similarly useful for doing simple
 ;;     string->string translations in a reversible manner.
 
+;;; Code:
+
 (put 'buffer-file-format 'permanent-local t)
 
 (defconst format-alist 
@@ -470,7 +476,7 @@
 		  (message "Extra closing annotation (%s) in file" name)
 	      ;; If one is open, but not on the top of the stack, close
 	      ;; the things in between as well.  Set `found' when the real
-	      ;; oneis closed.
+	      ;; one is closed.
 		(while (not found)
 		  (let* ((top (car open-ans)) ; first on stack: should match.
 			 (top-name (car top))
@@ -497,8 +503,21 @@
 						    (assoc r open-ans))
 						  ans))
 				    nil	; multiple ans not satisfied
-				  ;; Yes, use the current property name &
-				  ;; value.  Set loop variables to nil so loop
+				  ;; Yes, all set.
+				  ;; If there are multiple annotations going
+				  ;; into one text property, adjust the 
+				  ;; begin points of the other annotations
+				  ;; so that we don't get double marking.
+				  (let ((to-reset ans)
+					this-one)
+				    (while to-reset
+				      (setq this-one
+					    (assoc (car to-reset) 
+						   (cdr open-ans)))
+				      (if this-one
+					  (setcdr this-one (list loc)))
+				      (setq to-reset (cdr to-reset))))
+				  ;; Set loop variables to nil so loop
 				  ;; will exit.
 				  (setq alist nil aalist nil matched t
 					;; pop annotation off stack.
@@ -734,11 +753,9 @@
     (if (not prop-alist)
 	nil
       ;; If property is numeric, nil means 0
-      (cond ((and (numberp old) (null new)
-		  (numberp (car (car prop-alist))))
+      (cond ((and (numberp old) (null new))
 	     (setq new 0))
-	    ((and (numberp new) (null old)
-		  (numberp (car (car prop-alist))))
+	    ((and (numberp new) (null old))
 	     (setq old 0)))
       ;; If either old or new is a list, have to treat both that way.
       (if (or (consp old) (consp new))
@@ -763,12 +780,11 @@
 
 (defun format-annotate-atomic-property-change (prop-alist old new)
   "Internal function annotate a single property change.
-PROP-ALIST is the relevant segement of a TRANSLATIONS list.
+PROP-ALIST is the relevant segment of a TRANSLATIONS list.
 OLD and NEW are the values."
   (cond
    ;; Numerical annotation - use difference
-   ((and (numberp old) (numberp new)
-	 (numberp (car (car prop-alist))))
+   ((and (numberp old) (numberp new))
     (let* ((entry (progn
 		    (while (and (car (car prop-alist))
 				(not (numberp (car (car prop-alist)))))
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/help.el
--- a/lisp/prim/help.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/help.el	Mon Aug 13 08:46:56 2007 +0200
@@ -1093,9 +1093,10 @@
   (interactive "sLocate library: \nP")
   ;; XEmacs: We have the nifty `locate-file' so we use it.
   (let ((file (locate-file library load-path (if nosuffix nil ".elc:.el:"))))
-    (if file
-	(message "Library is file %s" file)
-      (message "No library %s in search path" library))
+    (when (interactive-p)
+      (if file
+	  (message "Library is file %s" file)
+	(message "No library %s in search path" library)))
     file))
 
 ;; Functions ported from C into Lisp in XEmacs
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/indent.el
--- a/lisp/prim/indent.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/indent.el	Mon Aug 13 08:46:56 2007 +0200
@@ -1,9 +1,9 @@
 ;;; indent.el --- indentation commands for XEmacs
-;; Keywords: lisp languages tools
 
 ;; Copyright (C) 1985, 1992, 1993, 1995 Free Software Foundation, Inc.
 
 ;; Maintainer: FSF
+;; Keywords: lisp languages tools
 
 ;; This file is part of XEmacs.
 
@@ -19,7 +19,8 @@
 
 ;; 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.
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
 
 ;;; Synched up with: FSF 19.30.
 
@@ -45,17 +46,19 @@
   "Indent line in proper way for current major mode."
   (interactive "P")
   (if (eq indent-line-function 'indent-to-left-margin)
-      (insert-tab)
+      (insert-tab prefix-arg)
     (if prefix-arg
 	(funcall indent-line-function prefix-arg)
       (funcall indent-line-function))))
 
-(defun insert-tab ()
-  (if abbrev-mode
-      (expand-abbrev))
-  (if indent-tabs-mode
-      (insert ?\t)
-    (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))
+(defun insert-tab (&optional prefix-arg)
+  (let ((count (prefix-numeric-value prefix-arg)))
+    (if abbrev-mode
+	(expand-abbrev))
+    (if indent-tabs-mode
+	(insert-char ?\t count)
+      ;; XEmacs: (Need the `1+')
+      (indent-to (* tab-width (1+ (/ (current-column) tab-width)))))))
 
 (defun indent-rigidly (start end arg)
   "Indent all lines starting in the region sideways by ARG columns.
@@ -77,7 +80,7 @@
 	(delete-region (point) (progn (skip-chars-forward " \t") (point))))
       (forward-line 1))
     (move-marker end nil)
-    (setq zmacs-region-stays nil)))
+    (setq zmacs-region-stays nil))) ; XEmacs
 
 (defun indent-line-to (column)
   "Indent current line to COLUMN.
@@ -206,12 +209,12 @@
     (if (bolp) (setq from (point)))
     (goto-char to)
     (setq to (point-marker)))
-  (alter-text-property from (marker-position to) 'left-margin
+  (alter-text-property from (marker-position to) 'left-margin ; XEmacs
 		       (lambda (v) (max (- left-margin) (+ inc (or v 0)))))
-  (indent-rigidly from (marker-position to) inc)
+  (indent-rigidly from (marker-position to) inc) ; XEmacs
   (if auto-fill-function
       (save-excursion
-	(fill-region from (marker-position to) nil t t)))
+	(fill-region from (marker-position to) nil t t))) ; XEmacs
   (move-marker to nil))
 
 (defun decrease-left-margin (from to inc)
@@ -269,7 +272,7 @@
 		 (buffer-substring 
 		  (point) (min (point-max) (+ (length fill-prefix) (point)))))
 	  (forward-char (length fill-prefix)))
-    (if (and adaptive-fill-mode 
+    (if (and adaptive-fill-mode adaptive-fill-regexp
 	     (looking-at adaptive-fill-regexp))
 	(goto-char (match-end 0))))
   ;; Skip centering or flushright indentation
@@ -333,8 +336,8 @@
 (defun indent-relative (&optional unindented-ok)
   "Space out to under next indent point in previous nonblank line.
 An indent point is a non-whitespace character following whitespace.
-If the previous nonblank line has no indent points beyond
-the column point starts at, `tab-to-tab-stop' is done instead."
+If the previous nonblank line has no indent points beyond the
+column point starts at, `tab-to-tab-stop' is done instead."
   (interactive "P")
   (if abbrev-mode (expand-abbrev))
   (let ((start-column (current-column))
@@ -407,6 +410,7 @@
     (while (> count 0)
       (insert "0123456789")
       (setq count (1- count))))
+  ;; XEmacs
   (insert (substitute-command-keys "\nTo install changes, type \\\\[edit-tab-stops-note-changes]"))
   (goto-char (point-min)))
 
@@ -464,4 +468,9 @@
 		    (forward-char -1))
 		  (delete-region (point) before))))))))
 
+;(define-key global-map "\t" 'indent-for-tab-command)
+;(define-key esc-map "\034" 'indent-region)
+;(define-key ctl-x-map "\t" 'indent-rigidly)
+;(define-key esc-map "i" 'tab-to-tab-stop)
+
 ;;; indent.el ends here
diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/loaddefs.el
--- a/lisp/prim/loaddefs.el	Mon Aug 13 08:46:35 2007 +0200
+++ b/lisp/prim/loaddefs.el	Mon Aug 13 08:46:56 2007 +0200
@@ -1057,8 +1057,10 @@
 
 ;;;### (autoloads nil "cl" "cl/cl.el" (12860 19475))
 ;;; Generated autoloads from cl/cl.el
-
-;;;### (autoloads nil "background" "comint/background.el" (12675 57061))
+
+;;;***
+
+;;;### (autoloads nil "background" "comint/background.el" (12864 52236))
 ;;; Generated autoloads from comint/background.el
 
 ;;;### (autoloads (comint-dynamic-list-completions comint-dynamic-complete comint-run make-comint) "comint" "comint/comint.el" (12860 19312))
@@ -1093,11 +1095,13 @@
 Typing SPC flushes the help buffer." nil nil)
 
 ;;;***
-
-;;;### (autoloads nil "dbx" "comint/dbx.el" (12376 19381))
+
+;;;***
+
+;;;### (autoloads nil "dbx" "comint/dbx.el" (12864 52536))
 ;;; Generated autoloads from comint/dbx.el
 
-;;;### (autoloads (gdb) "gdb" "comint/gdb.el" (12727 30092))
+;;;### (autoloads (gdb) "gdb" "comint/gdb.el" (12864 52628))
 ;;; Generated autoloads from comint/gdb.el
 
 (defvar gdb-command-name "gdb" "\
@@ -1111,7 +1115,7 @@
 
 ;;;***
 
-;;;### (autoloads (gdbsrc) "gdbsrc" "comint/gdbsrc.el" (12743 11566))
+;;;### (autoloads (gdbsrc) "gdbsrc" "comint/gdbsrc.el" (12897 5133))
 ;;; Generated autoloads from comint/gdbsrc.el
 
 (autoload 'gdbsrc "gdbsrc" "\
@@ -1148,9 +1152,13 @@
 and source-file directory for your debugger." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "history" "comint/history.el" (12376 19384))
+
+;;;***
+
+;;;### (autoloads nil "history" "comint/history.el" (12864 52863))
 ;;; Generated autoloads from comint/history.el
+
+;;;***
 
 ;;;### (autoloads nil "inf-lisp" "comint/inf-lisp.el" (12546 50428))
 ;;; Generated autoloads from comint/inf-lisp.el
@@ -1158,8 +1166,6 @@
 (add-hook 'same-window-buffer-names "*inferior-lisp*")
 
 ;;;***
-
-;;;***
 
 ;;;### (autoloads nil "kermit" "comint/kermit.el" (12851 23354))
 ;;; Generated autoloads from comint/kermit.el
@@ -1246,7 +1252,7 @@
 
 ;;;***
 
-;;;### (autoloads (rsh telnet) "telnet" "comint/telnet.el" (12546 50428))
+;;;### (autoloads (rsh telnet) "telnet" "comint/telnet.el" (12864 53480))
 ;;; Generated autoloads from comint/telnet.el
 
 (add-hook 'same-window-regexps "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)")
@@ -1268,7 +1274,7 @@
 
 ;;;***
 
-;;;### (autoloads (ange-ftp-hook-function) "ange-ftp" "dired/ange-ftp.el" (12851 23360))
+;;;### (autoloads (ange-ftp-hook-function) "ange-ftp" "dired/ange-ftp.el" (12865 38768))
 ;;; Generated autoloads from dired/ange-ftp.el
 
 (defvar ange-ftp-path-format '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" 3 2 4) "\
@@ -1571,24 +1577,31 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "cl-read" "edebug/cl-read.el" (12851 23502))
+
+;;;***
+
+;;;### (autoloads nil "advise-eval-region" "edebug/advise-eval-region.el" (12864 30312))
+;;; Generated autoloads from edebug/advise-eval-region.el
+
+;;;***
+
+;;;### (autoloads nil "cl-read" "edebug/cl-read.el" (12864 29087))
 ;;; Generated autoloads from edebug/cl-read.el
-
-;;;### (autoloads nil "cl-specs" "edebug/cl-specs.el" (12546 50556))
+
+;;;***
+
+;;;### (autoloads nil "cl-specs" "edebug/cl-specs.el" (12864 27740))
 ;;; Generated autoloads from edebug/cl-specs.el
 
 ;;;***
 
-;;;### (autoloads nil "cust-print" "edebug/cust-print.el" (12546 50558))
+;;;### (autoloads nil "cust-print" "edebug/cust-print.el" (12864 28985))
 ;;; Generated autoloads from edebug/cust-print.el
 
 ;;;***
 
-;;;### (autoloads nil "edebug-cl-read" "edebug/edebug-cl-read.el" (12546 50559))
+;;;### (autoloads nil "edebug-cl-read" "edebug/edebug-cl-read.el" (12864 28195))
 ;;; Generated autoloads from edebug/edebug-cl-read.el
-
-;;;***
 
 ;;;### (autoloads nil "edebug-test" "edebug/edebug-test.el" (12546 50592))
 ;;; Generated autoloads from edebug/edebug-test.el
@@ -1596,7 +1609,7 @@
 
 ;;;***
 
-;;;### (autoloads (edebug-eval-top-level-form def-edebug-spec) "edebug" "edebug/edebug.el" (12639 8668))
+;;;### (autoloads (edebug-eval-top-level-form def-edebug-spec) "edebug" "edebug/edebug.el" (12864 29565))
 ;;; Generated autoloads from edebug/edebug.el
 
 (autoload 'def-edebug-spec "edebug" "\
@@ -1613,12 +1626,11 @@
 or if an error occurs, leave point after it with mark at the original point." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "eval-reg" "edebug/eval-reg.el" (12546 50591))
+
+;;;***
+
+;;;### (autoloads nil "eval-reg" "edebug/eval-reg.el" (12864 29073))
 ;;; Generated autoloads from edebug/eval-reg.el
-
-
-;;;***
 
 ;;;### (autoloads nil "ediff-diff" "ediff/ediff-diff.el" (12747 30846))
 ;;; Generated autoloads from ediff/ediff-diff.el
@@ -1664,7 +1676,163 @@
 ;;;### (autoloads nil "ediff-wind" "ediff/ediff-wind.el" (12851 23552))
 ;;; Generated autoloads from ediff/ediff-wind.el
 
-;;;### (autoloads (electric-buffer-list) "ebuff-menu" "electric/ebuff-menu.el" (12698 33526))
+;;;### (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" (12851 23551))
+;;; Generated autoloads from 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 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 lide 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)
+
+(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." t nil)
+
+;;;***
+
+;;;### (autoloads (electric-buffer-list) "ebuff-menu" "electric/ebuff-menu.el" (12863 14816))
 ;;; Generated autoloads from electric/ebuff-menu.el
 
 (autoload 'electric-buffer-list "ebuff-menu" "\
@@ -1673,31 +1841,25 @@
 listing with menuoid buffer selection.
 
 If the very next character typed is a space then the buffer list
-window disappears.  Otherwise, one may move around in the
-buffer list window, marking buffers to be selected, saved or deleted.
-
-To exit and select a new buffer, type a space when the cursor is on the
-appropriate line of the buffer-list window.
-
-Other commands are much like those of buffer-menu-mode.
+window disappears.  Otherwise, one may move around in the buffer list
+window, marking buffers to be selected, saved or deleted.
+
+To exit and select a new buffer, type a space when the cursor is on
+the appropriate line of the buffer-list window.  Other commands are
+much like those of buffer-menu-mode.
 
 Calls value of `electric-buffer-menu-mode-hook' on entry if non-nil.
 
-Non-null optional arg FILES-ONLY means mention only file buffers.
-When called from Lisp code, FILES-ONLY may be a regular expression,
-in which case only buffers whose names match that expression are listed,
-or an arbitrary predicate function.
-
 \\{electric-buffer-menu-mode-map}" t nil)
 
 ;;;***
 
-;;;### (autoloads (electric-command-history Electric-command-history-redo-expression) "echistory" "electric/echistory.el" (12657 40690))
+;;;### (autoloads (electric-command-history Electric-command-history-redo-expression) "echistory" "electric/echistory.el" (12863 16763))
 ;;; Generated autoloads from electric/echistory.el
 
 (autoload 'Electric-command-history-redo-expression "echistory" "\
 Edit current history line in minibuffer and execute result.
-With prefix argument NOCONFIRM, execute current line as-is without editing." t nil)
+With prefix arg NOCONFIRM, execute current line as-is without editing." t nil)
 
 (autoload 'electric-command-history "echistory" "\
 \\Major mode for examining and redoing commands from `command-history'.
@@ -1709,12 +1871,6 @@
 
 The history displayed is filtered by `list-command-history-filter' if non-nil.
 
-This pops up a window with the Command History listing.  If the very
-next character typed is Space, the listing is killed and the previous
-window configuration is restored.  Otherwise, you can browse in the
-Command History with  Return  moving down and  Delete  moving up, possibly
-selecting an expression to be redone with Space or quitting with `Q'.
-
 Like Emacs-Lisp mode except that characters do not insert themselves and
 Tab and Linefeed do not indent.  Instead these commands are provided:
 \\{electric-history-map}
@@ -1724,7 +1880,7 @@
 
 ;;;***
 
-;;;### (autoloads (electric-helpify with-electric-help) "ehelp" "electric/ehelp.el" (12657 40690))
+;;;### (autoloads (electric-helpify with-electric-help) "ehelp" "electric/ehelp.el" (12863 18269))
 ;;; Generated autoloads from electric/ehelp.el
 
 (autoload 'with-electric-help "ehelp" "\
@@ -1755,11 +1911,13 @@
 (autoload 'electric-helpify "ehelp" nil nil nil)
 
 ;;;***
-
-;;;### (autoloads nil "electric" "electric/electric.el" (12657 40689))
+
+;;;***
+
+;;;### (autoloads nil "electric" "electric/electric.el" (12863 15816))
 ;;; Generated autoloads from electric/electric.el
 
-;;;### (autoloads (Helper-help Helper-describe-bindings) "helper" "electric/helper.el" (12657 40691))
+;;;### (autoloads (Helper-help Helper-describe-bindings) "helper" "electric/helper.el" (12863 17069))
 ;;; Generated autoloads from electric/helper.el
 
 (autoload 'Helper-describe-bindings "helper" "\
@@ -1769,32 +1927,54 @@
 Provide help for current mode." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "edt" "emulators/edt.el" (12376 19400))
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "crisp" "emulators/crisp.el" (12967 874))
+;;; Generated autoloads from emulators/crisp.el
+
+;;;### (autoloads nil "edt-lk201" "emulators/edt-lk201.el" (12864 33439))
+;;; Generated autoloads from emulators/edt-lk201.el
+
+;;;***
+
+;;;### (autoloads nil "edt-mapper" "emulators/edt-mapper.el" (12864 32718))
+;;; Generated autoloads from emulators/edt-mapper.el
+
+;;;***
+
+;;;### (autoloads nil "edt-pc" "emulators/edt-pc.el" (12864 33459))
+;;; Generated autoloads from emulators/edt-pc.el
+
+;;;***
+
+;;;### (autoloads nil "edt-vt100" "emulators/edt-vt100.el" (12864 33409))
+;;; Generated autoloads from emulators/edt-vt100.el
+
+;;;### (autoloads (edt-emulation-on) "edt" "emulators/edt.el" (12864 32301))
 ;;; Generated autoloads from emulators/edt.el
-
-;;;### (autoloads (evi) "evi" "emulators/evi.el" (12376 19401))
-;;; Generated autoloads from emulators/evi.el
-
-(autoload 'evi "evi" "\
-Start vi emulation in this buffer." t nil)
-
-;;;***
-
-;;;### (autoloads (convert-mocklisp-buffer) "mlconvert" "emulators/mlconvert.el" (12376 19400))
+
+(autoload 'edt-emulation-on "edt" "\
+Turn on EDT Emulation." t nil)
+
+;;;***
+
+;;;### (autoloads (convert-mocklisp-buffer) "mlconvert" "emulators/mlconvert.el" (12864 34692))
 ;;; Generated autoloads from emulators/mlconvert.el
 
 (autoload 'convert-mocklisp-buffer "mlconvert" "\
 Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "mlsupport" "emulators/mlsupport.el" (12546 50433))
+
+;;;***
+
+;;;### (autoloads nil "mlsupport" "emulators/mlsupport.el" (12864 34452))
 ;;; Generated autoloads from emulators/mlsupport.el
-
-;;;***
-
-;;;### (autoloads (teco-command) "teco" "emulators/teco.el" (11903 15655))
+
+;;;### (autoloads (teco-command) "teco" "emulators/teco.el" (12864 34887))
 ;;; Generated autoloads from emulators/teco.el
 
 (autoload 'teco-command "teco" "\
@@ -1807,7 +1987,7 @@
 ;;;### (autoloads nil "tpu-doc" "emulators/tpu-doc.el" (12851 23364))
 ;;; Generated autoloads from emulators/tpu-doc.el
 
-;;;### (autoloads (tpu-edt-on) "tpu-edt" "emulators/tpu-edt.el" (12657 40693))
+;;;### (autoloads (tpu-edt-on) "tpu-edt" "emulators/tpu-edt.el" (12864 37148))
 ;;; Generated autoloads from emulators/tpu-edt.el
 
 (fset 'tpu-edt-mode 'tpu-edt-on)
@@ -1819,19 +1999,134 @@
 
 ;;;***
 
-;;;### (autoloads nil "tpu-extras" "emulators/tpu-extras.el" (12376 19402))
+;;;### (autoloads (tpu-set-cursor-bound tpu-set-cursor-free tpu-set-scroll-margins) "tpu-extras" "emulators/tpu-extras.el" (12864 37229))
 ;;; Generated autoloads from emulators/tpu-extras.el
 
-;;;***
-
-;;;### (autoloads nil "tpu-mapper" "emulators/tpu-mapper.el" (12376 19403))
+(autoload 'tpu-set-scroll-margins "tpu-extras" "\
+Set scroll margins." t nil)
+
+(autoload 'tpu-set-cursor-free "tpu-extras" "\
+Allow the cursor to move freely about the screen." t nil)
+
+(autoload 'tpu-set-cursor-bound "tpu-extras" "\
+Constrain the cursor to the flow of the text." t nil)
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "tpu-mapper" "emulators/tpu-mapper.el" (12864 37347))
 ;;; Generated autoloads from emulators/tpu-mapper.el
-
-;;;***
-
-;;;### (autoloads nil "ws-mode" "emulators/ws-mode.el" (12376 19402))
+
+;;;### (autoloads (wordstar-mode) "ws-mode" "emulators/ws-mode.el" (12864 35539))
 ;;; Generated autoloads from emulators/ws-mode.el
 
+(autoload 'wordstar-mode "ws-mode" "\
+Major mode with WordStar-like key bindings.
+
+BUGS:
+ - Help menus with WordStar commands (C-j just calls help-for-help)
+   are not implemented
+ - Options for search and replace
+ - Show markers (C-k h) is somewhat strange
+ - Search and replace (C-q a) is only available in forward direction
+
+No key bindings beginning with ESC are installed, they will work
+Emacs-like.
+
+The key bindings are:
+
+  C-a		backward-word
+  C-b		fill-paragraph
+  C-c		scroll-up-line
+  C-d		forward-char
+  C-e		previous-line
+  C-f		forward-word
+  C-g		delete-char
+  C-h		backward-char
+  C-i		indent-for-tab-command
+  C-j		help-for-help
+  C-k		ordstar-C-k-map
+  C-l		ws-repeat-search
+  C-n		open-line
+  C-p		quoted-insert
+  C-r		scroll-down-line
+  C-s		backward-char
+  C-t		kill-word
+  C-u		keyboard-quit
+  C-v		overwrite-mode
+  C-w		scroll-down
+  C-x		next-line
+  C-y		kill-complete-line
+  C-z		scroll-up
+
+  C-k 0		ws-set-marker-0
+  C-k 1		ws-set-marker-1
+  C-k 2		ws-set-marker-2
+  C-k 3		ws-set-marker-3
+  C-k 4		ws-set-marker-4
+  C-k 5		ws-set-marker-5
+  C-k 6		ws-set-marker-6
+  C-k 7		ws-set-marker-7
+  C-k 8		ws-set-marker-8
+  C-k 9		ws-set-marker-9
+  C-k b		ws-begin-block
+  C-k c		ws-copy-block
+  C-k d		save-buffers-kill-emacs
+  C-k f		find-file
+  C-k h		ws-show-markers
+  C-k i		ws-indent-block
+  C-k k		ws-end-block
+  C-k p		ws-print-block
+  C-k q		kill-emacs
+  C-k r		insert-file
+  C-k s		save-some-buffers
+  C-k t		ws-mark-word
+  C-k u		ws-exdent-block
+  C-k C-u	keyboard-quit
+  C-k v		ws-move-block
+  C-k w		ws-write-block
+  C-k x		kill-emacs
+  C-k y		ws-delete-block
+
+  C-o c		wordstar-center-line
+  C-o b		switch-to-buffer
+  C-o j		justify-current-line
+  C-o k		kill-buffer
+  C-o l		list-buffers
+  C-o m		auto-fill-mode
+  C-o r		set-fill-column
+  C-o C-u	keyboard-quit
+  C-o wd	delete-other-windows
+  C-o wh	split-window-horizontally
+  C-o wo	other-window
+  C-o wv	split-window-vertically
+
+  C-q 0		ws-find-marker-0
+  C-q 1		ws-find-marker-1
+  C-q 2		ws-find-marker-2
+  C-q 3		ws-find-marker-3
+  C-q 4		ws-find-marker-4
+  C-q 5		ws-find-marker-5
+  C-q 6		ws-find-marker-6
+  C-q 7		ws-find-marker-7
+  C-q 8		ws-find-marker-8
+  C-q 9		ws-find-marker-9
+  C-q a		ws-query-replace
+  C-q b		ws-to-block-begin
+  C-q c		end-of-buffer
+  C-q d		end-of-line
+  C-q f		ws-search
+  C-q k		ws-to-block-end
+  C-q l		ws-undo
+  C-q p		ws-last-cursorp
+  C-q r		beginning-of-buffer
+  C-q C-u	keyboard-quit
+  C-q w		ws-last-error
+  C-q y		ws-kill-eol
+  C-q DEL	ws-kill-bol
+" t nil)
+
 ;;;***
 
 ;;;### (autoloads nil "backtrace-logging" "energize/backtrace-logging.el" (12376 19404))
@@ -2054,11 +2349,13 @@
 \(Type \\[describe-mode] in the shell buffer for a list of commands.)" t nil)
 
 ;;;***
-
-;;;### (autoloads nil "NeXTify" "games/NeXTify.el" (12376 19620))
+
+;;;***
+
+;;;### (autoloads nil "NeXTify" "games/NeXTify.el" (12864 38746))
 ;;; Generated autoloads from games/NeXTify.el
 
-;;;### (autoloads (blackbox) "blackbox" "games/blackbox.el" (12376 19614))
+;;;### (autoloads (blackbox) "blackbox" "games/blackbox.el" (12864 38281))
 ;;; Generated autoloads from games/blackbox.el
 
 (autoload 'blackbox "blackbox" "\
@@ -2175,7 +2472,7 @@
 
 ;;;***
 
-;;;### (autoloads (conx-load conx conx-region conx-buffer) "conx" "games/conx.el" (12376 19618))
+;;;### (autoloads (conx-load conx conx-region conx-buffer) "conx" "games/conx.el" (12864 38761))
 ;;; Generated autoloads from games/conx.el
 
 (autoload 'conx-buffer "conx" "\
@@ -2193,7 +2490,7 @@
 
 ;;;***
 
-;;;### (autoloads (shuffle-vector cookie-snarf cookie-insert cookie) "cookie1" "games/cookie1.el" (12376 19615))
+;;;### (autoloads (shuffle-vector cookie-snarf cookie-insert cookie) "cookie1" "games/cookie1.el" (12864 38717))
 ;;; Generated autoloads from games/cookie1.el
 
 (autoload 'cookie "cookie1" "\
@@ -2214,7 +2511,7 @@
 
 ;;;***
 
-;;;### (autoloads (dissociated-press) "dissociate" "games/dissociate.el" (12376 19615))
+;;;### (autoloads (dissociated-press) "dissociate" "games/dissociate.el" (12864 38924))
 ;;; Generated autoloads from games/dissociate.el
 
 (autoload 'dissociated-press "dissociate" "\
@@ -2228,7 +2525,7 @@
 
 ;;;***
 
-;;;### (autoloads (doctor) "doctor" "games/doctor.el" (12376 19616))
+;;;### (autoloads (doctor) "doctor" "games/doctor.el" (12864 39378))
 ;;; Generated autoloads from games/doctor.el
 
 (autoload 'doctor "doctor" "\
@@ -2236,7 +2533,7 @@
 
 ;;;***
 
-;;;### (autoloads (dunnet) "dunnet" "games/dunnet.el" (12376 19621))
+;;;### (autoloads (dunnet) "dunnet" "games/dunnet.el" (12864 39880))
 ;;; Generated autoloads from games/dunnet.el
 
 (autoload 'dunnet "dunnet" "\
@@ -2244,7 +2541,7 @@
 
 ;;;***
 
-;;;### (autoloads (flame) "flame" "games/flame.el" (12376 19618))
+;;;### (autoloads (flame) "flame" "games/flame.el" (12864 40457))
 ;;; Generated autoloads from games/flame.el
 
 (autoload 'flame "flame" "\
@@ -2252,24 +2549,26 @@
 
 ;;;***
 
-;;;### (autoloads (gomoku) "gomoku" "games/gomoku.el" (12546 50547))
+;;;### (autoloads (gomoku) "gomoku" "games/gomoku.el" (12864 45708))
 ;;; Generated autoloads from 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
+If prefix arg is given for N, M is prompted for.
+
+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" (12546 50548))
+;;;### (autoloads (hanoi) "hanoi" "games/hanoi.el" (12864 41986))
 ;;; Generated autoloads from games/hanoi.el
 
 (autoload 'hanoi "hanoi" "\
@@ -2277,7 +2576,7 @@
 
 ;;;***
 
-;;;### (autoloads (life) "life" "games/life.el" (12743 11635))
+;;;### (autoloads (life) "life" "games/life.el" (12864 42236))
 ;;; Generated autoloads from games/life.el
 
 (autoload 'life "life" "\
@@ -2288,7 +2587,7 @@
 
 ;;;***
 
-;;;### (autoloads (mpuz) "mpuz" "games/mpuz.el" (12546 50549))
+;;;### (autoloads (mpuz) "mpuz" "games/mpuz.el" (12864 42342))
 ;;; Generated autoloads from games/mpuz.el
 
 (autoload 'mpuz "mpuz" "\
@@ -2296,7 +2595,7 @@
 
 ;;;***
 
-;;;### (autoloads (snarf-spooks spook) "spook" "games/spook.el" (12546 50549))
+;;;### (autoloads (snarf-spooks spook) "spook" "games/spook.el" (12864 42460))
 ;;; Generated autoloads from games/spook.el
 
 (autoload 'spook "spook" "\
@@ -2306,11 +2605,15 @@
 Return a vector containing the lines from `spook-phrases-file'." nil nil)
 
 ;;;***
-
-;;;### (autoloads nil "studly" "games/studly.el" (12376 19619))
+
+;;;***
+
+;;;### (autoloads nil "studly" "games/studly.el" (12864 42564))
 ;;; Generated autoloads from games/studly.el
-
-;;;### (autoloads (psychoanalyze-pinhead insert-zippyism yow) "yow" "games/yow.el" (12546 50550))
+
+;;;***
+
+;;;### (autoloads (psychoanalyze-pinhead apropos-zippy insert-zippyism yow) "yow" "games/yow.el" (12864 42881))
 ;;; Generated autoloads from games/yow.el
 
 (autoload 'yow "yow" "\
@@ -2319,12 +2622,14 @@
 (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)
 
 ;;;***
-
-;;;***
 
 ;;;### (autoloads nil "custom" "gnus/custom.el" (12851 23371))
 ;;; Generated autoloads from gnus/custom.el
@@ -2948,11 +3253,11 @@
 ;;; Generated autoloads from hm--html-menus/hm--html-drag-and-drop.el
 
 ;;;***
-
-;;;### (autoloads nil "hm--html-keys" "hm--html-menus/hm--html-keys.el" (12851 23568))
+
+;;;***
+
+;;;### (autoloads nil "hm--html-keys" "hm--html-menus/hm--html-keys.el" (12861 22560))
 ;;; Generated autoloads from hm--html-menus/hm--html-keys.el
-
-;;;***
 
 ;;;### (autoloads nil "hm--html-menu" "hm--html-menus/hm--html-menu.el" (12851 23562))
 ;;; Generated autoloads from hm--html-menus/hm--html-menu.el
@@ -2973,15 +3278,12 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "hm--html" "hm--html-menus/hm--html.el" (12851 23565))
+
+;;;***
+
+;;;### (autoloads nil "hm--html" "hm--html-menus/hm--html.el" (12861 21554))
 ;;; Generated autoloads from hm--html-menus/hm--html.el
 
-;;;### (autoloads nil "html-mode" "hm--html-menus/html-mode.el" (12639 8719))
-;;; Generated autoloads from hm--html-menus/html-mode.el
-
-;;;***
-
 ;;;### (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" (12318 54261))
 ;;; Generated autoloads from hm--html-menus/html-view.el
 
@@ -3527,260 +3829,311 @@
 of a string." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "bridge" "ilisp/bridge.el" (12376 19421))
+
+;;;***
+
+;;;### (autoloads nil "bridge" "ilisp/bridge.el" (12930 49948))
 ;;; Generated autoloads from ilisp/bridge.el
 
 ;;;***
 
-;;;### (autoloads nil "comint-ipc" "ilisp/comint-ipc.el" (12376 19418))
+;;;### (autoloads nil "comint-ipc" "ilisp/comint-ipc.el" (12930 51131))
 ;;; Generated autoloads from ilisp/comint-ipc.el
 
 ;;;***
 
 ;;;***
 
-;;;### (autoloads nil "comint-v18" "ilisp/comint-v18.el" (12851 23418))
+;;;### (autoloads nil "comint-v18" "ilisp/comint-v18.el" (12930 51160))
 ;;; Generated autoloads from ilisp/comint-v18.el
-
-;;;### (autoloads nil "completer" "ilisp/completer.el" (12675 57068))
+
+;;;***
+
+;;;### (autoloads nil "completer" "ilisp/completer.el" (12930 51342))
 ;;; Generated autoloads from ilisp/completer.el
-
-;;;### (autoloads nil "ilcompat" "ilisp/ilcompat.el" (12376 19424))
+
+;;;***
+
+;;;### (autoloads nil "completer.new" "ilisp/completer.new.el" (12930 51637))
+;;; Generated autoloads from ilisp/completer.new.el
+
+;;;***
+
+;;;### (autoloads nil "completer.no-fun" "ilisp/completer.no-fun.el" (12930 51677))
+;;; Generated autoloads from ilisp/completer.no-fun.el
+
+;;;***
+
+;;;### (autoloads nil "ilcompat" "ilisp/ilcompat.el" (12930 49377))
 ;;; Generated autoloads from ilisp/ilcompat.el
-
-;;;### (autoloads nil "ilfsf18" "ilisp/ilfsf18.el" (12376 19438))
+
+;;;***
+
+;;;### (autoloads nil "ilfsf18" "ilisp/ilfsf18.el" (12930 49388))
 ;;; Generated autoloads from ilisp/ilfsf18.el
 
 ;;;***
 
-;;;### (autoloads nil "ilfsf19" "ilisp/ilfsf19.el" (12376 19439))
+;;;### (autoloads nil "ilfsf19" "ilisp/ilfsf19.el" (12930 49394))
 ;;; Generated autoloads from ilisp/ilfsf19.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-acl" "ilisp/ilisp-acl.el" (12376 19427))
+;;;### (autoloads nil "ilisp-acl" "ilisp/ilisp-acl.el" (12930 49400))
 ;;; Generated autoloads from ilisp/ilisp-acl.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-aut" "ilisp/ilisp-aut.el" (12376 19428))
+;;;### (autoloads nil "ilisp-aut" "ilisp/ilisp-aut.el" (12930 49405))
 ;;; Generated autoloads from ilisp/ilisp-aut.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-bat" "ilisp/ilisp-bat.el" (12376 19419))
+;;;### (autoloads nil "ilisp-bat" "ilisp/ilisp-bat.el" (12930 49411))
 ;;; Generated autoloads from ilisp/ilisp-bat.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-bug" "ilisp/ilisp-bug.el" (12376 19425))
+;;;### (autoloads nil "ilisp-bug" "ilisp/ilisp-bug.el" (12930 49417))
 ;;; Generated autoloads from ilisp/ilisp-bug.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-chs" "ilisp/ilisp-chs.el" (12376 19439))
+;;;### (autoloads nil "ilisp-chs" "ilisp/ilisp-chs.el" (12930 49423))
 ;;; Generated autoloads from ilisp/ilisp-chs.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-cl" "ilisp/ilisp-cl.el" (12376 19427))
+;;;### (autoloads nil "ilisp-cl" "ilisp/ilisp-cl.el" (12930 49429))
 ;;; Generated autoloads from ilisp/ilisp-cl.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-cmp" "ilisp/ilisp-cmp.el" (12376 19428))
+;;;### (autoloads nil "ilisp-cmp" "ilisp/ilisp-cmp.el" (12930 49436))
 ;;; Generated autoloads from ilisp/ilisp-cmp.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-cmt" "ilisp/ilisp-cmt.el" (12376 19428))
+;;;### (autoloads nil "ilisp-cmt" "ilisp/ilisp-cmt.el" (12930 49442))
 ;;; Generated autoloads from ilisp/ilisp-cmt.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-cmu" "ilisp/ilisp-cmu.el" (12376 19431))
+;;;### (autoloads nil "ilisp-cmu" "ilisp/ilisp-cmu.el" (12930 49447))
 ;;; Generated autoloads from ilisp/ilisp-cmu.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-cpat" "ilisp/ilisp-cpat.el" (12376 19423))
+;;;### (autoloads nil "ilisp-cpat" "ilisp/ilisp-cpat.el" (12930 49453))
 ;;; Generated autoloads from ilisp/ilisp-cpat.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-def" "ilisp/ilisp-def.el" (12376 19429))
+;;;### (autoloads nil "ilisp-def" "ilisp/ilisp-def.el" (12930 49460))
 ;;; Generated autoloads from ilisp/ilisp-def.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-dia" "ilisp/ilisp-dia.el" (12376 19429))
+;;;### (autoloads nil "ilisp-dia" "ilisp/ilisp-dia.el" (12930 49466))
 ;;; Generated autoloads from ilisp/ilisp-dia.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-doc" "ilisp/ilisp-doc.el" (12376 19429))
+;;;### (autoloads nil "ilisp-doc" "ilisp/ilisp-doc.el" (12930 49473))
 ;;; Generated autoloads from ilisp/ilisp-doc.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-el" "ilisp/ilisp-el.el" (12376 19431))
+;;;### (autoloads nil "ilisp-el" "ilisp/ilisp-el.el" (12930 49479))
 ;;; Generated autoloads from ilisp/ilisp-el.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-ext" "ilisp/ilisp-ext.el" (12376 19420))
+;;;### (autoloads nil "ilisp-ext" "ilisp/ilisp-ext.el" (12930 49485))
 ;;; Generated autoloads from ilisp/ilisp-ext.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-hi" "ilisp/ilisp-hi.el" (12376 19431))
+;;;### (autoloads nil "ilisp-hi" "ilisp/ilisp-hi.el" (12930 49492))
 ;;; Generated autoloads from ilisp/ilisp-hi.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-hlw" "ilisp/ilisp-hlw.el" (12376 19440))
+;;;### (autoloads nil "ilisp-hlw" "ilisp/ilisp-hlw.el" (12930 49498))
 ;;; Generated autoloads from ilisp/ilisp-hlw.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-hnd" "ilisp/ilisp-hnd.el" (12376 19431))
+;;;### (autoloads nil "ilisp-hnd" "ilisp/ilisp-hnd.el" (12930 49503))
 ;;; Generated autoloads from ilisp/ilisp-hnd.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-ind" "ilisp/ilisp-ind.el" (12376 19430))
+;;;### (autoloads nil "ilisp-ind" "ilisp/ilisp-ind.el" (12930 49509))
 ;;; Generated autoloads from ilisp/ilisp-ind.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-inp" "ilisp/ilisp-inp.el" (12376 19431))
+;;;### (autoloads nil "ilisp-inp" "ilisp/ilisp-inp.el" (12930 49515))
 ;;; Generated autoloads from ilisp/ilisp-inp.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-kcl" "ilisp/ilisp-kcl.el" (12376 19433))
+;;;### (autoloads nil "ilisp-kcl" "ilisp/ilisp-kcl.el" (12930 49521))
 ;;; Generated autoloads from ilisp/ilisp-kcl.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-key" "ilisp/ilisp-key.el" (12376 19433))
+;;;### (autoloads nil "ilisp-key" "ilisp/ilisp-key.el" (12930 49527))
 ;;; Generated autoloads from ilisp/ilisp-key.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-kil" "ilisp/ilisp-kil.el" (12376 19433))
+;;;### (autoloads nil "ilisp-kil" "ilisp/ilisp-kil.el" (12930 49533))
 ;;; Generated autoloads from ilisp/ilisp-kil.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-low" "ilisp/ilisp-low.el" (12376 19433))
+;;;### (autoloads nil "ilisp-low" "ilisp/ilisp-low.el" (12930 49540))
 ;;; Generated autoloads from ilisp/ilisp-low.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-luc" "ilisp/ilisp-luc.el" (12376 19433))
+;;;### (autoloads nil "ilisp-luc" "ilisp/ilisp-luc.el" (12930 49549))
 ;;; Generated autoloads from ilisp/ilisp-luc.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-mak" "ilisp/ilisp-mak.el" (12376 19424))
+;;;### (autoloads nil "ilisp-mak" "ilisp/ilisp-mak.el" (12930 49555))
 ;;; Generated autoloads from ilisp/ilisp-mak.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-menu" "ilisp/ilisp-menu.el" (12376 19419))
+;;;### (autoloads nil "ilisp-menu" "ilisp/ilisp-menu.el" (12930 49561))
 ;;; Generated autoloads from ilisp/ilisp-menu.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-mnb" "ilisp/ilisp-mnb.el" (12376 19440))
+;;;### (autoloads nil "ilisp-mnb" "ilisp/ilisp-mnb.el" (12930 49567))
 ;;; Generated autoloads from ilisp/ilisp-mnb.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-mod" "ilisp/ilisp-mod.el" (12558 60883))
+;;;### (autoloads nil "ilisp-mod" "ilisp/ilisp-mod.el" (12930 49573))
 ;;; Generated autoloads from ilisp/ilisp-mod.el
-
-;;;### (autoloads nil "ilisp-mov" "ilisp/ilisp-mov.el" (12376 19435))
+
+;;;***
+
+;;;### (autoloads nil "ilisp-mov" "ilisp/ilisp-mov.el" (12930 49579))
 ;;; Generated autoloads from ilisp/ilisp-mov.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-out" "ilisp/ilisp-out.el" (12376 19435))
+;;;### (autoloads nil "ilisp-out" "ilisp/ilisp-out.el" (12930 49586))
 ;;; Generated autoloads from ilisp/ilisp-out.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-prc" "ilisp/ilisp-prc.el" (12376 19435))
+;;;### (autoloads nil "ilisp-prc" "ilisp/ilisp-prc.el" (12930 49354))
 ;;; Generated autoloads from ilisp/ilisp-prc.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-prn" "ilisp/ilisp-prn.el" (12376 19434))
+;;;### (autoloads nil "ilisp-prn" "ilisp/ilisp-prn.el" (12930 49340))
 ;;; Generated autoloads from ilisp/ilisp-prn.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-rng" "ilisp/ilisp-rng.el" (12376 19436))
+;;;### (autoloads nil "ilisp-rng" "ilisp/ilisp-rng.el" (12930 49593))
 ;;; Generated autoloads from ilisp/ilisp-rng.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-s2c" "ilisp/ilisp-s2c.el" (12376 19425))
+;;;### (autoloads nil "ilisp-s2c" "ilisp/ilisp-s2c.el" (12930 49599))
 ;;; Generated autoloads from ilisp/ilisp-s2c.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-sch" "ilisp/ilisp-sch.el" (12376 19436))
+;;;### (autoloads nil "ilisp-sch" "ilisp/ilisp-sch.el" (12930 49605))
 ;;; Generated autoloads from ilisp/ilisp-sch.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-snd" "ilisp/ilisp-snd.el" (12376 19437))
+;;;### (autoloads nil "ilisp-snd" "ilisp/ilisp-snd.el" (12930 49117))
 ;;; Generated autoloads from ilisp/ilisp-snd.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-src" "ilisp/ilisp-src.el" (12376 19421))
+;;;### (autoloads nil "ilisp-src" "ilisp/ilisp-src.el" (12930 49614))
 ;;; Generated autoloads from ilisp/ilisp-src.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-sym" "ilisp/ilisp-sym.el" (12376 19437))
+;;;### (autoloads nil "ilisp-sym" "ilisp/ilisp-sym.el" (12930 49620))
 ;;; Generated autoloads from ilisp/ilisp-sym.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-utl" "ilisp/ilisp-utl.el" (12376 19437))
+;;;### (autoloads nil "ilisp-utl" "ilisp/ilisp-utl.el" (12930 49625))
 ;;; Generated autoloads from ilisp/ilisp-utl.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-val" "ilisp/ilisp-val.el" (12376 19438))
+;;;### (autoloads nil "ilisp-val" "ilisp/ilisp-val.el" (12930 49255))
 ;;; Generated autoloads from ilisp/ilisp-val.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp-xfr" "ilisp/ilisp-xfr.el" (12376 19438))
+;;;### (autoloads nil "ilisp-xfr" "ilisp/ilisp-xfr.el" (12930 49632))
 ;;; Generated autoloads from ilisp/ilisp-xfr.el
 
 ;;;***
 
-;;;### (autoloads nil "ilisp" "ilisp/ilisp.el" (12376 19421))
+;;;### (autoloads nil "ilisp-xls" "ilisp/ilisp-xls.el" (12930 51400))
+;;; Generated autoloads from ilisp/ilisp-xls.el
+
+;;;***
+
+;;;### (autoloads nil "ilisp" "ilisp/ilisp.el" (12930 49230))
 ;;; Generated autoloads from ilisp/ilisp.el
 
 ;;;***
 
-;;;### (autoloads nil "illuc19" "ilisp/illuc19.el" (12376 19441))
+;;;### (autoloads nil "illuc19" "ilisp/illuc19.el" (12930 49638))
 ;;; Generated autoloads from ilisp/illuc19.el
 
 ;;;***
 
-;;;### (autoloads nil "ilxemacs" "ilisp/ilxemacs.el" (12657 40696))
+;;;### (autoloads nil "ilxemacs" "ilisp/ilxemacs.el" (12930 49644))
 ;;; Generated autoloads from ilisp/ilxemacs.el
 
 ;;;***
+
+;;;### (autoloads (iso-accents-mode) "iso-acc" "iso/iso-acc.el" (12913 18100))
+;;; Generated autoloads from iso/iso-acc.el
+
+(autoload 'iso-accents-mode "iso-acc" "\
+Toggle ISO Accents mode, in which accents modify the following letter.
+This permits easy insertion of accented characters according to ISO-8859-1.
+When Iso-accents mode is enabled, accent character keys
+\(`, ', \", ^, / and ~) do not self-insert; instead, they modify the following
+letter key so that it inserts an ISO accented letter.
+
+You can customize ISO Accents mode to a particular language
+with the command `iso-accents-customize'.
+
+Special combinations: ~c gives a c with cedilla,
+~d gives an Icelandic eth (d with dash).
+~t gives an Icelandic thorn.
+\"s gives German sharp s.
+/a gives a with ring.
+/e gives an a-e ligature.
+~< and ~> give guillemots.
+~! gives an inverted exclamation mark.
+~? gives an inverted question mark.
+
+With an argument, a positive argument enables ISO Accents mode, 
+and a negative argument disables it." t nil)
 
 ;;;***
 
@@ -4312,36 +4665,42 @@
 
 ;;;### (autoloads nil "c-comment" "modes/c-comment.el" (12690 2171))
 ;;; Generated autoloads from modes/c-comment.el
-
-;;;### (autoloads nil "c-fill" "modes/c-fill.el" (12559 34900))
+
+;;;***
+
+;;;### (autoloads nil "c-fill" "modes/c-fill.el" (12677 32378))
 ;;; Generated autoloads from modes/c-fill.el
 
 ;;;***
 
-;;;### (autoloads nil "c-style" "modes/c-style.el" (12559 34900))
+;;;### (autoloads nil "c-style" "modes/c-style.el" (12906 6792))
 ;;; Generated autoloads from modes/c-style.el
 
 ;;;***
 
-;;;### (autoloads nil "cc-compat" "modes/cc-compat.el" (12559 34905))
+;;;### (autoloads nil "cc-compat" "modes/cc-compat.el" (12936 63268))
 ;;; Generated autoloads from modes/cc-compat.el
 
 ;;;***
 
-;;;### (autoloads nil "cc-guess" "modes/cc-guess.el" (12559 34906))
+;;;### (autoloads nil "cc-guess" "modes/cc-guess.el" (12936 63329))
 ;;; Generated autoloads from modes/cc-guess.el
 
 ;;;***
 
-;;;### (autoloads nil "cc-lobotomy" "modes/cc-lobotomy.el" (12559 34904))
+;;;### (autoloads nil "cc-lobotomy" "modes/cc-lobotomy.el" (12936 63305))
 ;;; Generated autoloads from modes/cc-lobotomy.el
 
 ;;;***
 
 ;;;***
 
-;;;### (autoloads nil "cc-mode" "modes/cc-mode.el" (12851 27486))
+;;;### (autoloads nil "cc-mode" "modes/cc-mode.el" (12964 17751))
 ;;; Generated autoloads from modes/cc-mode.el
+
+(fset 'set-c-style           'c-set-style)
+
+;;;***
 
 ;;;### (autoloads (common-lisp-indent-function) "cl-indent" "modes/cl-indent.el" (12860 19322))
 ;;; Generated autoloads from modes/cl-indent.el
@@ -4368,8 +4727,10 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "cperl-mode" "modes/cperl-mode.el" (12851 23434))
+
+;;;***
+
+;;;### (autoloads nil "cperl-mode" "modes/cperl-mode.el" (12947 52528))
 ;;; Generated autoloads from modes/cperl-mode.el
 
 ;;;### (autoloads (enriched-decode enriched-encode enriched-mode) "enriched" "modes/enriched.el" (12860 19332))
@@ -4746,7 +5107,7 @@
 
 ;;;***
 
-;;;### (autoloads (imenu imenu-add-to-menubar) "imenu" "modes/imenu.el" (12860 19511))
+;;;### (autoloads (imenu imenu-add-to-menubar) "imenu" "modes/imenu.el" (12876 17607))
 ;;; Generated autoloads from modes/imenu.el
 
 (defvar imenu-generic-expression nil "\
@@ -4794,7 +5155,7 @@
 ;;; Generated autoloads from modes/ksh-mode.el
 
 (autoload 'ksh-mode "ksh-mode" "\
-ksh-mode $Revision: 1.1.1.2 $ - Major mode for editing (Bourne, Korn or Bourne again)
+ksh-mode $Revision: 1.1.1.3 $ - Major mode for editing (Bourne, Korn or Bourne again)
 shell scripts.
 Special key bindings and commands:
 \\{ksh-mode-map}
@@ -4911,15 +5272,25 @@
 ;;; Generated autoloads from modes/lisp-mnt.el
 
 ;;;***
-
-;;;### (autoloads nil "lisp-mode" "modes/lisp-mode.el" (12860 19331))
+
+;;;***
+
+;;;### (autoloads nil "lisp-mode" "modes/lisp-mode.el" (12926 33284))
 ;;; Generated autoloads from modes/lisp-mode.el
-
-;;;***
 
 ;;;### (autoloads nil "list-mode" "modes/list-mode.el" (12851 27167))
 ;;; Generated autoloads from modes/list-mode.el
 
+;;;### (autoloads (m4-mode) "m4-mode" "modes/m4-mode.el" (12949 7770))
+;;; Generated autoloads from modes/m4-mode.el
+
+(autoload 'm4-mode "m4-mode" "\
+A major-mode to edit m4 macro files
+\\{m4-mode-map}
+" t nil)
+
+;;;***
+
 ;;;### (autoloads (makefile-mode) "make-mode" "modes/make-mode.el" (12860 19318))
 ;;; Generated autoloads from modes/make-mode.el
 
@@ -5007,7 +5378,7 @@
 ;;;### (autoloads nil "old-c-mode" "modes/old-c-mode.el" (12546 50448))
 ;;; Generated autoloads from modes/old-c-mode.el
 
-;;;### (autoloads (define-mail-alias build-mail-aliases mail-aliases-setup) "mail-abbrevs" "modes/mail-abbrevs.el" (12376 19450))
+;;;### (autoloads (define-mail-alias build-mail-aliases mail-aliases-setup) "mail-abbrevs" "modes/mail-abbrevs.el" (12928 50037))
 ;;; Generated autoloads from modes/mail-abbrevs.el
 
 (defvar mail-abbrev-mailrc-file nil "\
@@ -5380,7 +5751,7 @@
 
 ;;;***
 
-;;;### (autoloads (python-mode) "python-mode" "modes/python-mode.el" (12851 23770))
+;;;### (autoloads (py-shell python-mode) "python-mode" "modes/python-mode.el" (12912 14823))
 ;;; Generated autoloads from modes/python-mode.el
 
 (eval-when-compile (condition-case nil (progn (require 'cl) (require 'imenu)) (error nil)))
@@ -5406,6 +5777,33 @@
 py-temp-directory		directory used for temp files (if needed)
 py-beep-if-tab-change		ring the bell if tab-width is changed" t nil)
 
+(autoload 'py-shell "python-mode" "\
+Start an interactive Python interpreter in another window.
+This is like Shell mode, except that Python is running in the window
+instead of a shell.  See the `Interactive Shell' and `Shell Mode'
+sections of the Emacs manual for details, especially for the key
+bindings active in the `*Python*' buffer.
+
+See the docs for variable `py-scroll-buffer' for info on scrolling
+behavior in the process window.
+
+Warning: Don't use an interactive Python if you change sys.ps1 or
+sys.ps2 from their default values, or if you're running code that
+prints `>>> ' or `... ' at the start of a line.  `python-mode' can't
+distinguish your output from Python's output, and assumes that `>>> '
+at the start of a line is a prompt from Python.  Similarly, the Emacs
+Shell mode code assumes that both `>>> ' and `... ' at the start of a
+line are Python prompts.  Bad things can happen if you fool either
+mode.
+
+Warning:  If you do any editing *in* the process buffer *while* the
+buffer is accepting output from Python, do NOT attempt to `undo' the
+changes.  Some of the output (nowhere near the parts you changed!) may
+be lost if you do.  This appears to be an Emacs bug, an unfortunate
+interaction between undo and process filters; the same problem exists in
+non-Python process buffers using the default (Emacs-supplied) process
+filter." t nil)
+
 ;;;***
 
 ;;;### (autoloads (rexx-mode) "rexx-mode" "modes/rexx-mode.el" (12558 60898))
@@ -5806,7 +6204,7 @@
 
 ;;;***
 
-;;;### (autoloads (latex-mode plain-tex-mode tex-mode) "tex-mode" "modes/tex-mode.el" (12376 19459))
+;;;### (autoloads (latex-mode plain-tex-mode tex-mode) "tex-mode" "modes/tex-mode.el" (12905 8489))
 ;;; Generated autoloads from modes/tex-mode.el
 
 (autoload 'tex-mode "tex-mode" "\
@@ -5984,123 +6382,43 @@
 ;;;### (autoloads nil "text-mode" "modes/text-mode.el" (12860 19337))
 ;;; Generated autoloads from modes/text-mode.el
 
-;;;### (autoloads (tc-recenter tc-scroll-down tc-scroll-up tc-scroll-line tc-associated-buffer tc-merge tc-dissociate tc-split tc-associate-buffer tc-two-columns) "two-column" "modes/two-column.el" (12648 18571))
+;;;### (autoloads (2C-split 2C-associate-buffer 2C-two-columns) "two-column" "modes/two-column.el" (12941 23726))
 ;;; Generated autoloads from modes/two-column.el
 
-(defvar tc-mode-map nil "\
-Keymap for commands for two-column mode.")
-
-(if tc-mode-map nil (setq tc-mode-map (make-sparse-keymap)) (define-key tc-mode-map "1" 'tc-merge) (define-key tc-mode-map "2" 'tc-two-columns) (define-key tc-mode-map "b" 'tc-associate-buffer) (define-key tc-mode-map "d" 'tc-dissociate) (define-key tc-mode-map "\^L" 'tc-recenter) (define-key tc-mode-map "o" 'tc-associated-buffer) (define-key tc-mode-map "s" 'tc-split) (define-key tc-mode-map "{" 'shrink-window-horizontally) (define-key tc-mode-map "}" 'enlarge-window-horizontally) (define-key tc-mode-map " " 'tc-scroll-up) (define-key tc-mode-map "" 'tc-scroll-down) (define-key tc-mode-map "
" 'tc-scroll-line))
-
-(global-set-key "6" tc-mode-map)
-
-(defvar tc-other nil "\
-Marker to the associated buffer, if non-nil.")
-
-(make-variable-buffer-local 'tc-other)
-
-(put 'tc-other 'permanent-local t)
-
-(autoload 'tc-two-columns "two-column" "\
+(autoload '2C-command "two-column" () t 'keymap)
+
+(autoload '2C-two-columns "two-column" "\
 Split current window vertically for two-column editing.
-
 When called the first time, associates a buffer with the current
-buffer.  Both buffers are put in two-column minor mode and
-tc-mode-hook gets called on both.  These buffers remember
-about one another, even when renamed.
-
+buffer in two-column minor mode (see  \\[describe-mode] ).
+Runs `2C-other-buffer-hook' in the new buffer.
 When called again, restores the screen layout with the current buffer
-first and the associated buffer to it's right.
-
-If you include long lines, i.e which will span both columns (eg.
-source code), they should be in what will be the first column, with
-the associated buffer having empty lines next to them.
-
-You have the following commands at your disposal:
-
-\\[tc-two-columns]   Rearrange screen
-\\[tc-associate-buffer]   Reassociate buffer after changing major mode
-\\[tc-scroll-up]   Scroll both buffers up by a screenfull
-\\[tc-scroll-down]   Scroll both buffers down by a screenful
-\\[tc-scroll-line]   Scroll both buffers up by one or more lines
-\\[tc-recenter]   Recenter and realign other buffer
-\\[shrink-window-horizontally], \\[enlarge-window-horizontally]   Shrink, enlarge current column
-\\[tc-associated-buffer]   Switch to associated buffer
-\\[tc-merge]   Merge both buffers
-
-These keybindings can be customized in your ~/.emacs by `tc-prefix'
-and `tc-mode-map'.
-
-The appearance of the screen can be customized by the variables
-`tc-window-width', `tc-beyond-fill-column',
-`tc-mode-line-format' and `truncate-partial-width-windows'." t nil)
-
-(add-minor-mode 'tc-other " 2C" nil nil 'tc-two-columns)
-
-(autoload 'tc-associate-buffer "two-column" "\
+first and the associated buffer to it's right." t nil)
+
+(autoload '2C-associate-buffer "two-column" "\
 Associate another buffer with this one in two-column minor mode.
 Can also be used to associate a just previously visited file, by
 accepting the proposed default buffer.
 
-See  \\[tc-two-columns]  and  `lisp/two-column.el'  for further details." t nil)
-
-(autoload 'tc-split "two-column" "\
-Unmerge a two-column text into two buffers in two-column minor mode.
-The text is unmerged at the cursor's column which becomes the local
-value of `tc-window-width'.  Only lines that have the ARG same
-preceding characters at that column get split.  The ARG preceding
-characters without any leading whitespace become the local value for
-`tc-separator'.  This way lines that continue across both
+\(See  \\[describe-mode] .)" t nil)
+
+(autoload '2C-split "two-column" "\
+Split a two-column text at point, into two buffers in two-column minor mode.
+Point becomes the local value of `2C-window-width'.  Only lines that
+have the ARG same preceding characters at that column get split.  The
+ARG preceding characters without any leading whitespace become the local
+value for `2C-separator'.  This way lines that continue across both
 columns remain untouched in the first buffer.
 
-This function can be used with a prototype line, to set up things as
-you like them.  You write the first line of each column with the
-separator you like and then unmerge that line.  E.g.:
-
-First column's text    sSs  Second columns text
+This function can be used with a prototype line, to set up things.  You
+write the first line of each column and then split that line.  E.g.:
+
+First column's text    sSs  Second column's text
 		       \\___/\\
 			/    \\
-   5 character Separator      You type  M-5 \\[tc-split]  with the point here
-
-See  \\[tc-two-columns]  and  `lisp/two-column.el'  for further details." t nil)
-
-(autoload 'tc-dissociate "two-column" "\
-Turn off two-column minor mode in current and associated buffer.
-If the associated buffer is unmodified and empty, it is killed." t nil)
-
-(autoload 'tc-merge "two-column" "\
-Merges the associated buffer with the current buffer.
-They get merged at the column, which is the value of
-`tc-window-width', i.e. usually at the vertical window
-separator.  This separator gets replaced with white space.  Beyond
-that the value of gets inserted on merged lines.  The two columns are
-thus pasted side by side, in a single text.  If the other buffer is
-not displayed to the left of this one, then this one becomes the left
-column.
-
-If you want `tc-separator' on empty lines in the second column,
-you should put just one space in them.  In the final result, you can strip
-off trailing spaces with \\[beginning-of-buffer] \\[replace-regexp] [ SPC TAB ] + $ RET RET" t nil)
-
-(autoload 'tc-associated-buffer "two-column" "\
-Switch to associated buffer." t nil)
-
-(autoload 'tc-scroll-line "two-column" "\
-Scroll current window upward by ARG lines.
-The associated window gets scrolled to the same line." t nil)
-
-(autoload 'tc-scroll-up "two-column" "\
-Scroll current window upward by ARG screens.
-The associated window gets scrolled to the same line." t nil)
-
-(autoload 'tc-scroll-down "two-column" "\
-Scroll current window downward by ARG screens.
-The associated window gets scrolled to the same line." t nil)
-
-(autoload 'tc-recenter "two-column" "\
-Center point in window.  With ARG, put point on line ARG.
-This counts from bottom if ARG is negative.  The associated window
-gets scrolled to the same line." t nil)
+   5 character Separator      You type  M-5 \\[2C-split]  with the point here.
+
+\(See  \\[describe-mode] .)" t nil)
 
 ;;;***
 
@@ -6206,7 +6524,7 @@
 
 ;;;***
 
-;;;### (autoloads (xpm-mode) "xpm-mode" "modes/xpm-mode.el" (12860 19349))
+;;;### (autoloads (xpm-mode) "xpm-mode" "modes/xpm-mode.el" (12908 14737))
 ;;; Generated autoloads from modes/xpm-mode.el
 
 (autoload 'xpm-mode "xpm-mode" "\
@@ -6227,6 +6545,31 @@
 \\{xpm-mode-map}" t nil)
 
 ;;;***
+
+;;;***
+
+;;;### (autoloads nil "mu-bbdb" "mu/mu-bbdb.el" (12949 26608))
+;;; Generated autoloads from mu/mu-bbdb.el
+
+;;;***
+
+;;;### (autoloads nil "mu-cite" "mu/mu-cite.el" (12883 24796))
+;;; Generated autoloads from mu/mu-cite.el
+
+;;;***
+
+;;;### (autoloads nil "std11-parse" "mu/std11-parse.el" (12957 59956))
+;;; Generated autoloads from mu/std11-parse.el
+
+;;;***
+
+;;;### (autoloads nil "std11" "mu/std11.el" (12962 62381))
+;;; Generated autoloads from mu/std11.el
+
+;;;***
+
+;;;### (autoloads nil "tl-822" "mu/tl-822.el" (12858 28766))
+;;; Generated autoloads from mu/tl-822.el
 
 ;;;### (autoloads nil "ns-init" "ns/ns-init.el" (12528 24026))
 ;;; Generated autoloads from ns/ns-init.el
@@ -6570,7 +6913,7 @@
 
 ;;;***
 
-;;;### (autoloads (apropos-documentation apropos-value apropos apropos-command) "apropos" "packages/apropos.el" (12860 19361))
+;;;### (autoloads (apropos-documentation apropos-value apropos apropos-command) "apropos" "packages/apropos.el" (12870 6875))
 ;;; Generated autoloads from packages/apropos.el
 
 (fset 'command-apropos 'apropos-command)
@@ -6611,7 +6954,7 @@
 ;;;### (autoloads nil "auto-save" "packages/auto-save.el" (12178 28935))
 ;;; Generated autoloads from packages/auto-save.el
 
-;;;### (autoloads (define-auto-insert auto-insert) "autoinsert" "packages/autoinsert.el" (12860 19362))
+;;;### (autoloads (define-auto-insert auto-insert) "autoinsert" "packages/autoinsert.el" (12866 47734))
 ;;; Generated autoloads from packages/autoinsert.el
 
 (autoload 'auto-insert "autoinsert" "\
@@ -6899,8 +7242,12 @@
 \"-menu-\" in its name)." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "buff-menu" "packages/buff-menu.el" (12731 19066))
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "buff-menu" "packages/buff-menu.el" (12941 16898))
 ;;; Generated autoloads from packages/buff-menu.el
 
 ;;;### (autoloads (command-history-mode list-command-history repeat-matching-complex-command) "chistory" "packages/chistory.el" (12860 19367))
@@ -6942,7 +7289,7 @@
 
 ;;;***
 
-;;;### (autoloads (display-column-mode) "column" "packages/column.el" (12657 40702))
+;;;### (autoloads (display-column-mode) "column" "packages/column.el" (12898 25467))
 ;;; Generated autoloads from packages/column.el
 
 (autoload 'display-column-mode "column" "\
@@ -6974,7 +7321,7 @@
 
 ;;;***
 
-;;;### (autoloads (first-error previous-error next-error compilation-minor-mode grep compile) "compile" "packages/compile.el" (12860 19372))
+;;;### (autoloads (first-error previous-error next-error compilation-minor-mode grep compile) "compile" "packages/compile.el" (12906 48567))
 ;;; Generated autoloads from packages/compile.el
 
 (defvar compilation-mode-hook nil "\
@@ -7663,11 +8010,11 @@
 (add-minor-mode 'font-lock-mode " Font")
 
 ;;;***
-
-;;;### (autoloads nil "fontl-hooks" "packages/fontl-hooks.el" (12558 61068))
+
+;;;***
+
+;;;### (autoloads nil "fontl-hooks" "packages/fontl-hooks.el" (12933 26528))
 ;;; Generated autoloads from packages/fontl-hooks.el
-
-;;;***
 
 ;;;### (autoloads nil "func-menu" "packages/func-menu.el" (12721 2479))
 ;;; Generated autoloads from packages/func-menu.el
@@ -7868,7 +8215,7 @@
 
 ;;;***
 
-;;;### (autoloads (icomplete-minibuffer-setup icomplete-mode) "icomplete" "packages/icomplete.el" (12860 19419))
+;;;### (autoloads (icomplete-minibuffer-setup icomplete-mode) "icomplete" "packages/icomplete.el" (12870 50497))
 ;;; Generated autoloads from packages/icomplete.el
 
 (autoload 'icomplete-mode "icomplete" "\
@@ -8168,6 +8515,14 @@
 
 ;;;***
 
+;;;### (autoloads (manual-entry) "jwz-man" "packages/jwz-man.el" (12875 12533))
+;;; Generated autoloads from packages/jwz-man.el
+
+(autoload 'manual-entry "jwz-man" "\
+Display the Unix manual entry (or entries) for TOPIC." t nil)
+
+;;;***
+
 ;;;### (autoloads (turn-on-lazy-lock lazy-lock-mode) "lazy-lock" "packages/lazy-lock.el" (12851 23453))
 ;;; Generated autoloads from packages/lazy-lock.el
 
@@ -8276,24 +8631,24 @@
 Previous contents of that buffer are killed first." t nil)
 
 ;;;***
-
-;;;### (autoloads (manual-entry) "man" "packages/man.el" (12860 19390))
+
+;;;***
+
+;;;### (autoloads nil "man-xref" "packages/man-xref.el" (12968 61833))
+;;; Generated autoloads from packages/man-xref.el
+
+;;;### (autoloads (man) "man" "packages/man.el" (12968 61736))
 ;;; Generated autoloads from packages/man.el
 
-(autoload 'manual-entry "man" "\
-Display the Unix manual entry (or entries) for TOPIC.
-If prefix arg is given, modify the search according to the value:
-  2 = complement default exact matching of the TOPIC name;
-      exact matching default is specified by `Manual-match-topic-exactly'
-  3 = force a search of the unformatted man directories
-  4 = both 2 and 3
-The manual entries are searched according to the variable
-Manual-directory-list, which should be a list of directories.  If
-Manual-directory-list is nil, \\[Manual-directory-list-init] is
-invoked to create this list from the MANPATH environment variable.
-See the variable Manual-topic-buffer which controls how the buffer
-is named.  See also the variables Manual-match-topic-exactly,
-Manual-query-multiple-pages, and Manual-buffer-view-mode." t nil)
+(defalias 'manual-entry 'man)
+
+(autoload 'man "man" "\
+Get a Un*x manual page and put it in a buffer.
+This command is the top-level command in the man package.  It runs a Un*x
+command to retrieve and clean a manpage in the background and places the
+results in a Man mode (manpage browsing) buffer.  See variable
+`Man-notify-method' for what happens when the buffer is ready.
+If a buffer already exists for this man page, it will display immediately." t nil)
 
 ;;;***
 
@@ -8349,6 +8704,26 @@
 
 ;;;***
 
+;;;### (autoloads (manual-entry) "old-man" "packages/old-man.el" (12875 12228))
+;;; Generated autoloads from packages/old-man.el
+
+(autoload 'manual-entry "old-man" "\
+Display the Unix manual entry (or entries) for TOPIC.
+If prefix arg is given, modify the search according to the value:
+  2 = complement default exact matching of the TOPIC name;
+      exact matching default is specified by `Manual-match-topic-exactly'
+  3 = force a search of the unformatted man directories
+  4 = both 2 and 3
+The manual entries are searched according to the variable
+Manual-directory-list, which should be a list of directories.  If
+Manual-directory-list is nil, \\[Manual-directory-list-init] is
+invoked to create this list from the MANPATH environment variable.
+See the variable Manual-topic-buffer which controls how the buffer
+is named.  See also the variables Manual-match-topic-exactly,
+Manual-query-multiple-pages, and Manual-buffer-view-mode." t nil)
+
+;;;***
+
 ;;;### (autoloads nil "page-ext" "packages/page-ext.el" (12860 19393))
 ;;; Generated autoloads from packages/page-ext.el
 
@@ -8402,7 +8777,7 @@
 
 ;;;***
 
-;;;### (autoloads (ps-despool ps-spool-region-with-faces ps-spool-region ps-spool-buffer-with-faces ps-spool-buffer ps-print-region-with-faces ps-print-region ps-print-buffer-with-faces ps-print-buffer) "ps-print" "packages/ps-print.el" (12860 19418))
+;;;### (autoloads (ps-despool ps-spool-region-with-faces ps-spool-region ps-spool-buffer-with-faces ps-spool-buffer ps-print-region-with-faces ps-print-region ps-print-buffer-with-faces ps-print-buffer) "ps-print" "packages/ps-print.el" (12934 24347))
 ;;; Generated autoloads from packages/ps-print.el
 
 (defvar ps-paper-type 'ps-letter "\
@@ -8539,11 +8914,11 @@
 ;;; Generated autoloads from packages/sccs.el
 
 ;;;***
-
-;;;### (autoloads nil "scroll-in-place" "packages/scroll-in-place.el" (12547 2457))
+
+;;;***
+
+;;;### (autoloads nil "scroll-in-place" "packages/scroll-in-place.el" (12942 17712))
 ;;; Generated autoloads from packages/scroll-in-place.el
-
-;;;***
 
 ;;;### (autoloads nil "server" "packages/server.el" (12860 19397))
 ;;; Generated autoloads from packages/server.el
@@ -8691,7 +9066,7 @@
 ;;;### (autoloads nil "texnfo-tex" "packages/texnfo-tex.el" (12657 40704))
 ;;; Generated autoloads from packages/texnfo-tex.el
 
-;;;### (autoloads (texinfo-sequential-node-update texinfo-every-node-update texinfo-update-node) "texnfo-upd" "packages/texnfo-upd.el" (12860 19402))
+;;;### (autoloads (texinfo-sequential-node-update texinfo-every-node-update texinfo-update-node) "texnfo-upd" "packages/texnfo-upd.el" (12893 48280))
 ;;; Generated autoloads from packages/texnfo-upd.el
 
 (autoload 'texinfo-update-node "texnfo-upd" "\
@@ -8737,17 +9112,27 @@
 
 ;;;***
 
-;;;### (autoloads (time-stamp) "time-stamp" "packages/time-stamp.el" (12547 2415))
+;;;### (autoloads (time-stamp-toggle-active time-stamp) "time-stamp" "packages/time-stamp.el" (12869 6042))
 ;;; Generated autoloads from packages/time-stamp.el
 
 (autoload 'time-stamp "time-stamp" "\
 Update the time stamp string in the buffer.
+If you put a time stamp template anywhere in the first 8 lines of a file,
+it can be updated every time you save the file.  See the top of
+`time-stamp.el' for a sample.  The template looks like one of the following:
+    Time-stamp: <>
+    Time-stamp: \" \"
+The time stamp is written between the brackets or quotes, resulting in
+    Time-stamp: <95/01/18 10:20:51 gildea>
 Only does its thing if the variable  time-stamp-active  is non-nil.
 Typically used on  write-file-hooks  for automatic time-stamping.
-The format of the time stamp is determined by the variable
-time-stamp-format.  The first  time-stamp-line-limit  lines of the
-buffer (normally 8) are searched for the time stamp template,
-and if it is found, a new time stamp is written into it." t nil)
+The format of the time stamp is determined by the variable  time-stamp-format.
+The variables time-stamp-line-limit, time-stamp-start, and time-stamp-end
+control finding the template." t nil)
+
+(autoload 'time-stamp-toggle-active "time-stamp" "\
+Toggle time-stamp-active, setting whether \\[time-stamp] updates a buffer.
+With arg, turn time stamping on if and only if arg is positive." t nil)
 
 ;;;***
 
@@ -9110,11 +9495,11 @@
 ;;; Generated autoloads from prim/backquote.el
 
 ;;;***
-
-;;;### (autoloads nil "buffer" "prim/buffer.el" (12639 8641))
+
+;;;***
+
+;;;### (autoloads nil "buffer" "prim/buffer.el" (12941 13414))
 ;;; Generated autoloads from prim/buffer.el
-
-;;;***
 
 ;;;### (autoloads (describe-buffer-case-table) "case-table" "prim/case-table.el" (12851 23462))
 ;;; Generated autoloads from prim/case-table.el
@@ -9140,17 +9525,17 @@
 ;;;### (autoloads nil "curmudgeon" "prim/curmudgeon.el" (12648 454))
 ;;; Generated autoloads from prim/curmudgeon.el
 
-;;;### (autoloads (cancel-debug-on-entry debug-on-entry debug) "debug" "prim/debug.el" (12639 8609))
+;;;### (autoloads (cancel-debug-on-entry debug-on-entry debug) "debug" "prim/debug.el" (12868 31993))
 ;;; Generated autoloads from prim/debug.el
 
 (autoload 'debug "debug" "\
 Enter debugger.  To return, type \\`\\[debugger-continue]'.
-Arguments are mainly for use when this is called
- from the internals of the evaluator.
-You may call with no args, or you may
- pass nil as the first arg and any other args you like.
- In that case, the list of args after the first will 
- be printed into the backtrace buffer." t nil)
+Arguments are mainly for use when this is called from the internals
+of the evaluator.
+
+You may call with no args, or you may pass nil as the first arg and
+any other args you like.  In that case, the list of args after the
+first will be printed into the backtrace buffer." t nil)
 
 (autoload 'debug-on-entry "debug" "\
 Request FUNCTION to invoke debugger each time it is called.
@@ -9247,26 +9632,28 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "files" "prim/files.el" (12860 19422))
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "files" "prim/files.el" (12920 56154))
 ;;; Generated autoloads from prim/files.el
 
 ;;;***
 
-;;;### (autoloads nil "fill" "prim/fill.el" (12860 19424))
+;;;### (autoloads nil "fill" "prim/fill.el" (12877 49271))
 ;;; Generated autoloads from prim/fill.el
-
-;;;***
 
 ;;;### (autoloads nil "float-sup" "prim/float-sup.el" (12860 19426))
 ;;; Generated autoloads from prim/float-sup.el
-
-;;;### (autoloads nil "format" "prim/format.el" (12648 18601))
+
+;;;***
+
+;;;### (autoloads nil "format" "prim/format.el" (12869 1042))
 ;;; Generated autoloads from prim/format.el
 
 ;;;***
-
-;;;***
 
 ;;;### (autoloads nil "frame" "prim/frame.el" (12851 23472))
 ;;; Generated autoloads from prim/frame.el
@@ -9280,27 +9667,31 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "help" "prim/help.el" (12851 23462))
+
+;;;***
+
+;;;### (autoloads nil "help" "prim/help.el" (12897 20925))
 ;;; Generated autoloads from prim/help.el
-
-;;;***
 
 ;;;### (autoloads nil "inc-vers" "prim/inc-vers.el" (12546 50487))
 ;;; Generated autoloads from prim/inc-vers.el
 
 ;;;***
-
-;;;### (autoloads nil "indent" "prim/indent.el" (12648 18582))
+
+;;;***
+
+;;;### (autoloads nil "indent" "prim/indent.el" (12869 152))
 ;;; Generated autoloads from prim/indent.el
+
+;;;***
 
 ;;;### (autoloads nil "isearch-mode" "prim/isearch-mode.el" (12698 33552))
 ;;; Generated autoloads from prim/isearch-mode.el
+
+;;;***
 
 ;;;### (autoloads nil "itimer" "prim/itimer.el" (12546 50498))
 ;;; Generated autoloads from prim/itimer.el
-
-;;;***
 
 ;;;### (autoloads nil "keydefs" "prim/keydefs.el" (12639 8614))
 ;;; Generated autoloads from prim/keydefs.el
@@ -9320,18 +9711,22 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "loaddefs" "prim/loaddefs.el" (12860 42262))
+
+;;;***
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "loaddefs" "prim/loaddefs.el" (12971 18885))
 ;;; Generated autoloads from prim/loaddefs.el
-
-;;;***
 
 ;;;### (autoloads nil "loadup-el" "prim/loadup-el.el" (12639 8618))
 ;;; Generated autoloads from prim/loadup-el.el
 
 ;;;***
 
-;;;### (autoloads nil "loadup" "prim/loadup.el" (12860 19422))
+;;;### (autoloads nil "loadup" "prim/loadup.el" (12971 18018))
 ;;; Generated autoloads from prim/loadup.el
 
 ;;;### (autoloads (apply-macro-to-region-lines kbd-macro-query insert-kbd-macro name-last-kbd-macro) "macros" "prim/macros.el" (12546 50477))
@@ -9420,16 +9815,18 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "minibuf" "prim/minibuf.el" (12851 23464))
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "minibuf" "prim/minibuf.el" (12929 30936))
 ;;; Generated autoloads from prim/minibuf.el
 
 ;;;***
 
 ;;;### (autoloads nil "misc" "prim/misc.el" (12860 19429))
 ;;; Generated autoloads from prim/misc.el
-
-;;;***
 
 ;;;### (autoloads nil "mode-motion" "prim/mode-motion.el" (12657 40715))
 ;;; Generated autoloads from prim/mode-motion.el
@@ -9442,7 +9839,7 @@
 ;;;### (autoloads nil "mouse" "prim/mouse.el" (12744 55115))
 ;;; Generated autoloads from prim/mouse.el
 
-;;;### (autoloads (disable-command enable-command disabled-command-hook) "novice" "prim/novice.el" (12546 50489))
+;;;### (autoloads (disable-command enable-command disabled-command-hook) "novice" "prim/novice.el" (12869 1329))
 ;;; Generated autoloads from prim/novice.el
 
 (autoload 'disabled-command-hook "novice" nil nil nil)
@@ -9469,7 +9866,7 @@
 
 ;;;***
 
-;;;### (autoloads (edit-options list-options) "options" "prim/options.el" (12546 50481))
+;;;### (autoloads (edit-options list-options) "options" "prim/options.el" (12869 58219))
 ;;; Generated autoloads from prim/options.el
 
 (autoload 'list-options "options" "\
@@ -9482,16 +9879,16 @@
 Type \\[describe-mode] in that buffer for a list of commands." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "page" "prim/page.el" (12546 50475))
+
+;;;***
+
+;;;### (autoloads nil "page" "prim/page.el" (12869 59057))
 ;;; Generated autoloads from prim/page.el
 
 ;;;***
 
-;;;### (autoloads nil "paragraphs" "prim/paragraphs.el" (12558 60931))
+;;;### (autoloads nil "paragraphs" "prim/paragraphs.el" (12869 59880))
 ;;; Generated autoloads from prim/paragraphs.el
-
-;;;***
 
 ;;;### (autoloads nil "process" "prim/process.el" (12727 30162))
 ;;; Generated autoloads from prim/process.el
@@ -9501,14 +9898,13 @@
 
 ;;;***
 
-;;;### (autoloads (clear-rectangle string-rectangle open-rectangle insert-rectangle yank-rectangle kill-rectangle extract-rectangle delete-extract-rectangle delete-rectangle) "rect" "prim/rect.el" (12546 50488))
+;;;### (autoloads (clear-rectangle string-rectangle open-rectangle insert-rectangle yank-rectangle kill-rectangle extract-rectangle delete-extract-rectangle delete-rectangle) "rect" "prim/rect.el" (12868 62568))
 ;;; Generated autoloads from prim/rect.el
 
 (autoload 'delete-rectangle "rect" "\
 Delete (don't save) text in rectangle with point and mark as corners.
-The same range of columns is deleted in each line
-starting with the line where the region begins
-and ending with the line where the region ends." t nil)
+The same range of columns is deleted in each line starting with the line
+where the region begins and ending with the line where the region ends." t nil)
 
 (autoload 'delete-extract-rectangle "rect" "\
 Delete contents of rectangle and return it as a list of strings.
@@ -9532,8 +9928,8 @@
 
 (autoload 'insert-rectangle "rect" "\
 Insert text of RECTANGLE with upper left corner at point.
-RECTANGLE's first line is inserted at point,
-its second line is inserted at a point vertically under point, etc.
+RECTANGLE's first line is inserted at point, its second
+line is inserted at a point vertically under point, etc.
 RECTANGLE should be a list of strings.
 After this command, the mark is at the upper left corner
 and point is at the lower right corner." nil nil)
@@ -9556,18 +9952,22 @@
 When called from a program, requires two args which specify the corners." t nil)
 
 ;;;***
-
-;;;### (autoloads nil "register" "prim/register.el" (12540 24673))
+
+;;;***
+
+;;;### (autoloads nil "register" "prim/register.el" (12868 63160))
 ;;; Generated autoloads from prim/register.el
 
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "replace" "prim/replace.el" (12851 23479))
+
+;;;***
+
+;;;### (autoloads nil "replace" "prim/replace.el" (12870 12308))
 ;;; Generated autoloads from prim/replace.el
 
-;;;### (autoloads (reposition-window) "reposition" "prim/reposition.el" (12546 50489))
+;;;### (autoloads (reposition-window) "reposition" "prim/reposition.el" (12868 64283))
 ;;; Generated autoloads from prim/reposition.el
 
 (autoload 'reposition-window "reposition" "\
@@ -9597,11 +9997,15 @@
 ;;;***
 
 ;;;***
-
-;;;### (autoloads nil "simple" "prim/simple.el" (12860 19432))
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "simple" "prim/simple.el" (12971 16993))
 ;;; Generated autoloads from prim/simple.el
 
-;;;### (autoloads (reverse-region sort-columns sort-regexp-fields sort-fields sort-float-fields sort-numeric-fields sort-pages sort-paragraphs sort-lines sort-subr) "sort" "prim/sort.el" (12546 50495))
+;;;### (autoloads (reverse-region sort-columns sort-regexp-fields sort-fields sort-float-fields sort-numeric-fields sort-pages sort-paragraphs sort-lines sort-subr) "sort" "prim/sort.el" (12868 64792))
 ;;; Generated autoloads from prim/sort.el
 
 (autoload 'sort-subr "sort" "\
@@ -9745,14 +10149,16 @@
 ;;; Generated autoloads from prim/startup.el
 
 ;;;***
-
-;;;### (autoloads nil "subr" "prim/subr.el" (12851 23467))
+
+;;;***
+
+;;;***
+
+;;;### (autoloads nil "subr" "prim/subr.el" (12971 17139))
 ;;; Generated autoloads from prim/subr.el
 
 ;;;### (autoloads nil "symbols" "prim/symbols.el" (12546 50529))
 ;;; Generated autoloads from prim/symbols.el
-
-;;;***
 
 ;;;### (autoloads nil "syntax" "prim/syntax.el" (12851 23473))
 ;;; Generated autoloads from prim/syntax.el
@@ -9791,7 +10197,7 @@
 
 ;;;***
 
-;;;### (autoloads (ask-user-about-supersession-threat ask-user-about-lock) "userlock" "prim/userlock.el" (12639 8617))
+;;;### (autoloads (ask-user-about-supersession-threat ask-user-about-lock) "userlock" "prim/userlock.el" (12869 60811))
 ;;; Generated autoloads from prim/userlock.el
 
 (autoload 'ask-user-about-lock "userlock" "\
@@ -9979,19 +10385,18 @@
 ;;; Generated autoloads from psgml/tempo.el
 
 ;;;***
-
-;;;### (autoloads nil "rmail-kill" "rmail/rmail-kill.el" (11903 15862))
+
+;;;***
+
+;;;### (autoloads nil "rmail-kill" "rmail/rmail-kill.el" (12864 53554))
 ;;; Generated autoloads from rmail/rmail-kill.el
-
-;;;### (autoloads nil "rmail-lucid" "rmail/rmail-lucid.el" (12376 19553))
-;;; Generated autoloads from rmail/rmail-lucid.el
-
-;;;***
-
-;;;### (autoloads nil "rmail-xemacs" "rmail/rmail-xemacs.el" (12860 19512))
+
+;;;***
+
+;;;### (autoloads nil "rmail-xemacs" "rmail/rmail-xemacs.el" (12864 48388))
 ;;; Generated autoloads from rmail/rmail-xemacs.el
 
-;;;### (autoloads (rmail-input rmail-mode rmail) "rmail" "rmail/rmail.el" (12860 19435))
+;;;### (autoloads (rmail-input rmail-mode rmail) "rmail" "rmail/rmail.el" (12864 50999))
 ;;; Generated autoloads from rmail/rmail.el
 
 (defvar rmail-dont-reply-to-names nil "\
@@ -10005,6 +10410,22 @@
 value is the user's name.)
 It is useful to set this variable in the site customization file.")
 
+(defvar rmail-displayed-headers nil "\
+*Regexp to match Header fields that Rmail should display.
+If nil, display all header fields except those matched by
+`rmail-ignored-headers'.")
+
+(defvar rmail-retry-ignored-headers nil "\
+*Headers that should be stripped when retrying a failed message.")
+
+(defvar rmail-highlighted-headers "^From:\\|^Subject:" "\
+*Regexp to match Header fields that Rmail should normally highlight.
+A value of nil means don't highlight.
+See also `rmail-highlight-face'.")
+
+(defvar rmail-highlight-face nil "\
+*Face used by Rmail for highlighting headers.")
+
 (defvar rmail-delete-after-output nil "\
 *Non-nil means automatically delete a message that is copied to a file.")
 
@@ -10320,6 +10741,445 @@
 ;;; Generated autoloads from term/xterm.el
 
 ;;;***
+
+;;;***
+
+;;;### (autoloads nil "bitmap" "tl/bitmap.el" (12674 16523))
+;;; Generated autoloads from tl/bitmap.el
+
+;;;***
+
+;;;### (autoloads nil "cless" "tl/cless.el" (12862 10354))
+;;; Generated autoloads from tl/cless.el
+
+;;;***
+
+;;;### (autoloads nil "emu-e19" "tl/emu-e19.el" (12881 7264))
+;;; Generated autoloads from tl/emu-e19.el
+
+;;;***
+
+;;;### (autoloads nil "emu-orig" "tl/emu-orig.el" (12661 2648))
+;;; Generated autoloads from tl/emu-orig.el
+
+;;;***
+
+;;;### (autoloads nil "emu-x20" "tl/emu-x20.el" (12699 65190))
+;;; Generated autoloads from tl/emu-x20.el
+
+;;;***
+
+;;;### (autoloads nil "emu-xemacs" "tl/emu-xemacs.el" (12839 1369))
+;;; Generated autoloads from tl/emu-xemacs.el
+
+;;;***
+
+;;;### (autoloads nil "emu" "tl/emu.el" (12870 52383))
+;;; Generated autoloads from tl/emu.el
+
+;;;***
+
+;;;### (autoloads nil "file-detect" "tl/file-detect.el" (12842 61245))
+;;; Generated autoloads from tl/file-detect.el
+
+;;;***
+
+;;;### (autoloads nil "mime-setup" "tl/mime-setup.el" (12972 48090))
+;;; Generated autoloads from tl/mime-setup.el
+
+;;;***
+
+;;;### (autoloads nil "mu-comment" "tl/mu-comment.el" (12714 41382))
+;;; Generated autoloads from tl/mu-comment.el
+
+;;;***
+
+;;;### (autoloads nil "mu-replace" "tl/mu-replace.el" (12770 23464))
+;;; Generated autoloads from tl/mu-replace.el
+
+;;;***
+
+;;;### (autoloads nil "range" "tl/range.el" (12819 55004))
+;;; Generated autoloads from tl/range.el
+
+;;;***
+
+;;;### (autoloads nil "richtext" "tl/richtext.el" (12467 2855))
+;;; Generated autoloads from tl/richtext.el
+
+;;;***
+
+;;;### (autoloads nil "texi-util" "tl/texi-util.el" (12893 1584))
+;;; Generated autoloads from tl/texi-util.el
+
+;;;***
+
+;;;### (autoloads nil "tinyrich" "tl/tinyrich.el" (12384 10532))
+;;; Generated autoloads from tl/tinyrich.el
+
+;;;***
+
+;;;### (autoloads nil "tl-atype" "tl/tl-atype.el" (12870 33841))
+;;; Generated autoloads from tl/tl-atype.el
+
+;;;***
+
+;;;### (autoloads nil "tl-list" "tl/tl-list.el" (12888 36045))
+;;; Generated autoloads from tl/tl-list.el
+
+;;;***
+
+;;;### (autoloads nil "tl-misc" "tl/tl-misc.el" (12842 60937))
+;;; Generated autoloads from tl/tl-misc.el
+
+;;;***
+
+;;;### (autoloads nil "tl-num" "tl/tl-num.el" (12351 26596))
+;;; Generated autoloads from tl/tl-num.el
+
+;;;***
+
+;;;### (autoloads nil "tl-seq" "tl/tl-seq.el" (12836 12947))
+;;; Generated autoloads from tl/tl-seq.el
+
+;;;***
+
+;;;### (autoloads nil "tl-str" "tl/tl-str.el" (12892 64865))
+;;; Generated autoloads from tl/tl-str.el
+
+;;;***
+
+;;;### (autoloads nil "tu-comment" "tl/tu-comment.el" (12842 55775))
+;;; Generated autoloads from tl/tu-comment.el
+
+;;;***
+
+;;;### (autoloads nil "tu-replace" "tl/tu-replace.el" (12842 55923))
+;;; Generated autoloads from tl/tu-replace.el
+
+;;;***
+
+;;;### (autoloads nil "gnus-art-mime" "tm/gnus-art-mime.el" (12956 34426))
+;;; Generated autoloads from tm/gnus-art-mime.el
+
+;;;***
+
+;;;### (autoloads nil "gnus-charset" "tm/gnus-charset.el" (12963 57217))
+;;; Generated autoloads from tm/gnus-charset.el
+
+;;;***
+
+;;;### (autoloads nil "gnus-mime-old" "tm/gnus-mime-old.el" (12845 28266))
+;;; Generated autoloads from tm/gnus-mime-old.el
+
+;;;***
+
+;;;### (autoloads nil "gnus-mime" "tm/gnus-mime.el" (12940 33311))
+;;; Generated autoloads from tm/gnus-mime.el
+
+;;;***
+
+;;;### (autoloads nil "gnus-msg-mime" "tm/gnus-msg-mime.el" (12814 62260))
+;;; Generated autoloads from tm/gnus-msg-mime.el
+
+;;;***
+
+;;;### (autoloads nil "gnus-sum-mime" "tm/gnus-sum-mime.el" (12866 19119))
+;;; Generated autoloads from tm/gnus-sum-mime.el
+
+;;;***
+
+;;;### (autoloads nil "message-mime" "tm/message-mime.el" (12814 62793))
+;;; Generated autoloads from tm/message-mime.el
+
+;;;***
+
+;;;### (autoloads nil "sc-setup" "tm/sc-setup.el" (12351 27119))
+;;; Generated autoloads from tm/sc-setup.el
+
+;;;***
+
+;;;### (autoloads nil "signature" "tm/signature.el" (12838 28532))
+;;; Generated autoloads from tm/signature.el
+
+;;;***
+
+;;;### (autoloads nil "tm-bbdb" "tm/tm-bbdb.el" (12970 37786))
+;;; Generated autoloads from tm/tm-bbdb.el
+
+;;;***
+
+;;;### (autoloads nil "tm-def" "tm/tm-def.el" (12955 12366))
+;;; Generated autoloads from tm/tm-def.el
+
+;;;***
+
+;;;### (autoloads nil "tm-edit-mc" "tm/tm-edit-mc.el" (12941 29098))
+;;; Generated autoloads from tm/tm-edit-mc.el
+
+;;;### (autoloads (mime/editor-mode) "tm-edit" "tm/tm-edit.el" (12965 344))
+;;; Generated autoloads from tm/tm-edit.el
+
+(autoload 'mime/editor-mode "tm-edit" "\
+MIME minor mode for editing the tagged MIME message.
+
+In this mode, basically, the message is composed in the tagged MIME
+format. The message tag looks like:
+
+	`--[[text/plain; charset=ISO-2022-JP][7bit]]'.
+
+The tag specifies the MIME content type, subtype, optional parameters
+and transfer encoding of the message following the tag. Messages
+without any tag are treated as `text/plain' by default. Charset and
+transfer encoding are automatically defined unless explicitly
+specified. Binary messages such as audio and image are usually hidden.
+The messages in the tagged MIME format are automatically translated
+into a MIME compliant message when exiting this mode.
+
+Available charsets depend on Emacs version being used. The following
+lists the available charsets of each emacs.
+
+EMACS 18:	US-ASCII is only available.
+NEmacs:		US-ASCII and ISO-2022-JP are available.
+EMACS 19:	US-ASCII and ISO-8859-1 (or other charset) are available.
+XEmacs 19:	US-ASCII and ISO-8859-1 (or other charset) are available.
+Mule:		US-ASCII, ISO-8859-* (except for ISO-8859-5), KOI8-R,
+		ISO-2022-JP, ISO-2022-JP-2, ISO-2022-KR, BIG5 and
+		ISO-2022-INT-1 are available.
+
+ISO-2022-JP-2 and ISO-2022-INT-1 charsets used in mule is expected to
+be used to represent multilingual text in intermixed manner. Any
+languages that has no registered charset are represented as either
+ISO-2022-JP-2 or ISO-2022-INT-1 in mule.
+
+If you want to use non-ISO-8859-1 charset in EMACS 19 or XEmacs 19,
+please set variable `default-mime-charset'. This variable must be
+symbol of which name is a MIME charset.
+
+If you want to add more charsets in mule, please set variable
+`charsets-mime-charset-alist'. This variable must be alist of which
+key is list of leading-char/charset and value is symbol of MIME
+charset. (leading-char is a term of MULE 1.* and 2.*. charset is a
+term of XEmacs/mule, mule merged EMACS and MULE 3.*) If name of
+coding-system is different as MIME charset, please set variable
+`mime-charset-coding-system-alist'. This variable must be alist of
+which key is MIME charset and value is coding-system.
+
+Following commands are available in addition to major mode commands:
+\\[mime-editor/insert-text]	insert a text message.
+\\[mime-editor/insert-file]	insert a (binary) file.
+\\[mime-editor/insert-external]	insert a reference to external body.
+\\[mime-editor/insert-voice]	insert a voice message.
+\\[mime-editor/insert-message]	insert a mail or news message.
+\\[mime-editor/insert-mail]	insert a mail message.
+\\[mime-editor/insert-signature]	insert a signature file at end.
+\\[mime-editor/insert-tag]	insert a new MIME tag.
+\\[mime-editor/enclose-alternative-region]	enclose as multipart/alternative.
+\\[mime-editor/enclose-parallel-region]	enclose as multipart/parallel.
+\\[mime-editor/enclose-mixed-region]	enclose as multipart/mixed.
+\\[mime-editor/enclose-digest-region]	enclose as multipart/digest.
+\\[mime-editor/enclose-signed-region]	enclose as PGP signed.
+\\[mime-editor/enclose-encrypted-region]	enclose as PGP encrypted.
+\\[mime-editor/insert-key]	insert PGP public key.
+\\[mime-editor/preview-message]	preview editing MIME message.
+\\[mime-editor/exit]	exit and translate into a MIME compliant message.
+\\[mime-editor/maybe-translate]	exit and translate if in MIME mode, then split.
+\\[mime-editor/help]	show this help.
+
+Additional commands are available in some major modes:
+C-c C-c		exit, translate and run the original command.
+C-c C-s		exit, translate and run the original command.
+
+The following is a message example written in the tagged MIME format.
+TABs at the beginning of the line are not a part of the message:
+
+	This is a conventional plain text.  It should be translated
+	into text/plain.
+	--[[text/plain]]
+	This is also a plain text.  But, it is explicitly specified as
+	is.
+	--[[text/plain; charset=ISO-2022-JP]]
+	$B$3$l$O(B charset $B$r(B ISO-2022-JP $B$K;XDj$7$?F|K8l$N(B plain $B%F%-%9(B
+	$B%H$G$9(B.
+	--[[text/richtext]]
+	
This is a richtext.
+ --[[image/gif][base64]]^M...image encoded in base64 here... + --[[audio/basic][base64]]^M...audio encoded in base64 here... + +User customizable variables (not documented all of them): + mime-prefix + Specifies a key prefix for MIME minor mode commands. + + mime-ignore-preceding-spaces + Preceding white spaces in a message body are ignored if non-nil. + + mime-ignore-trailing-spaces + Trailing white spaces in a message body are ignored if non-nil. + + mime-auto-fill-header + Fill header fields that contain encoded-words if non-nil. + + mime-auto-hide-body + Hide a non-textual body message encoded in base64 after insertion + if non-nil. + + mime-editor/voice-recorder + Specifies a function to record a voice message and encode it. + The function `mime-editor/voice-recorder-for-sun' is for Sun + SparcStations. + + mime/editor-mode-hook + Turning on MIME mode calls the value of mime/editor-mode-hook, if + it is non-nil. + + mime-editor/translate-hook + The value of mime-editor/translate-hook is called just before translating + the tagged MIME format into a MIME compliant message if it is + non-nil. If the hook call the function mime-editor/insert-signature, + the signature file will be inserted automatically. + + mime-editor/exit-hook + Turning off MIME mode calls the value of mime-editor/exit-hook, if it is + non-nil." t nil) + +(defalias 'edit-mime 'mime/editor-mode) + +;;;*** + +;;;*** + +;;;### (autoloads nil "tm-ew-d" "tm/tm-ew-d.el" (12965 715)) +;;; Generated autoloads from tm/tm-ew-d.el + +;;;*** + +;;;### (autoloads nil "tm-ew-e" "tm/tm-ew-e.el" (12965 677)) +;;; Generated autoloads from tm/tm-ew-e.el + +;;;*** + +;;;### (autoloads nil "tm-file" "tm/tm-file.el" (12870 36296)) +;;; Generated autoloads from tm/tm-file.el + +;;;*** + +;;;### (autoloads nil "tm-ftp" "tm/tm-ftp.el" (12376 20248)) +;;; Generated autoloads from tm/tm-ftp.el + +;;;*** + +;;;### (autoloads nil "tm-gd3" "tm/tm-gd3.el" (12633 38536)) +;;; Generated autoloads from tm/tm-gd3.el + +;;;*** + +;;;### (autoloads nil "tm-gnus" "tm/tm-gnus.el" (12754 40488)) +;;; Generated autoloads from tm/tm-gnus.el + +;;;*** + +;;;### (autoloads nil "tm-gnus4" "tm/tm-gnus4.el" (12730 29943)) +;;; Generated autoloads from tm/tm-gnus4.el + +;;;*** + +;;;### (autoloads nil "tm-gnus5" "tm/tm-gnus5.el" (12782 12538)) +;;; Generated autoloads from tm/tm-gnus5.el + +;;;*** + +;;;### (autoloads nil "tm-html" "tm/tm-html.el" (12713 24931)) +;;; Generated autoloads from tm/tm-html.el + +;;;*** + +;;;### (autoloads nil "tm-image" "tm/tm-image.el" (12872 47232)) +;;; Generated autoloads from tm/tm-image.el + +;;;*** + +;;;### (autoloads nil "tm-latex" "tm/tm-latex.el" (12376 20359)) +;;; Generated autoloads from tm/tm-latex.el + +;;;*** + +;;;### (autoloads nil "tm-mail" "tm/tm-mail.el" (12852 60003)) +;;; Generated autoloads from tm/tm-mail.el + +;;;*** + +;;;### (autoloads nil "tm-mh-e" "tm/tm-mh-e.el" (12880 65084)) +;;; Generated autoloads from tm/tm-mh-e.el + +;;;*** + +;;;### (autoloads nil "tm-orig" "tm/tm-orig.el" (12550 19621)) +;;; Generated autoloads from tm/tm-orig.el + +;;;*** + +;;;### (autoloads nil "tm-parse" "tm/tm-parse.el" (12916 29278)) +;;; Generated autoloads from tm/tm-parse.el + +;;;*** + +;;;### (autoloads nil "tm-partial" "tm/tm-partial.el" (12838 28108)) +;;; Generated autoloads from tm/tm-partial.el + +;;;*** + +;;;### (autoloads nil "tm-pgp" "tm/tm-pgp.el" (12903 3014)) +;;; Generated autoloads from tm/tm-pgp.el + +;;;*** + +;;;### (autoloads nil "tm-play" "tm/tm-play.el" (12963 19710)) +;;; Generated autoloads from tm/tm-play.el + +;;;*** + +;;;### (autoloads nil "tm-rich" "tm/tm-rich.el" (12672 24525)) +;;; Generated autoloads from tm/tm-rich.el + +;;;*** + +;;;### (autoloads nil "tm-rmail" "tm/tm-rmail.el" (12734 22484)) +;;; Generated autoloads from tm/tm-rmail.el + +;;;*** + +;;;### (autoloads nil "tm-setup" "tm/tm-setup.el" (12840 20109)) +;;; Generated autoloads from tm/tm-setup.el + +;;;*** + +;;;### (autoloads nil "tm-sgnus" "tm/tm-sgnus.el" (12730 30178)) +;;; Generated autoloads from tm/tm-sgnus.el + +;;;*** + +;;;### (autoloads nil "tm-tar" "tm/tm-tar.el" (12426 11042)) +;;; Generated autoloads from tm/tm-tar.el + +;;;*** + +;;;### (autoloads nil "tm-text" "tm/tm-text.el" (12796 4145)) +;;; Generated autoloads from tm/tm-text.el + +;;;*** + +;;;### (autoloads nil "tm-view" "tm/tm-view.el" (12870 36191)) +;;; Generated autoloads from tm/tm-view.el + +;;;*** + +;;;### (autoloads nil "tm-vm" "tm/tm-vm.el" (12972 48597)) +;;; Generated autoloads from tm/tm-vm.el + +;;;*** + +;;;### (autoloads nil "tmh-comp" "tm/tmh-comp.el" (12874 1879)) +;;; Generated autoloads from tm/tmh-comp.el ;;;### (autoloads nil "tooltalk-init" "tooltalk/tooltalk-init.el" (12714 11728)) ;;; Generated autoloads from tooltalk/tooltalk-init.el @@ -10677,7 +11537,7 @@ ;;;### (autoloads nil "blessmail" "utils/blessmail.el" (12860 19451)) ;;; Generated autoloads from utils/blessmail.el -;;;### (autoloads (browse-url-lynx-emacs browse-url-lynx-xterm browse-url-w3 browse-url-iximosaic browse-url-grail browse-url-mosaic browse-url-netscape) "browse-url" "utils/browse-url.el" (12745 43114)) +;;;### (autoloads (browse-url-lynx-emacs browse-url-lynx-xterm browse-url-w3 browse-url-iximosaic browse-url-grail browse-url-mosaic browse-url-netscape) "browse-url" "utils/browse-url.el" (12928 48607)) ;;; Generated autoloads from utils/browse-url.el (defvar browse-url-browser-function 'browse-url-w3 "\ @@ -10819,7 +11679,7 @@ ;;;*** -;;;### (autoloads (elp-submit-bug-report elp-results elp-instrument-package elp-instrument-list elp-restore-function elp-instrument-function) "elp" "utils/elp.el" (12559 34934)) +;;;### (autoloads (elp-submit-bug-report elp-results elp-instrument-package elp-instrument-list elp-restore-function elp-instrument-function) "elp" "utils/elp.el" (12912 14855)) ;;; Generated autoloads from utils/elp.el (autoload 'elp-instrument-function "elp" "\ @@ -10965,7 +11825,7 @@ ;;;### (autoloads nil "finder" "utils/finder.el" (12860 19447)) ;;; Generated autoloads from utils/finder.el -;;;### (autoloads (enable-flow-control-on enable-flow-control) "flow-ctrl" "utils/flow-ctrl.el" (12851 23485)) +;;;### (autoloads (enable-flow-control-on enable-flow-control) "flow-ctrl" "utils/flow-ctrl.el" (12869 51011)) ;;; Generated autoloads from utils/flow-ctrl.el (autoload 'enable-flow-control "flow-ctrl" "\ @@ -11003,27 +11863,28 @@ ;;;### (autoloads nil "forms-pass" "utils/forms-pass.el" (12860 19445)) ;;; Generated autoloads from utils/forms-pass.el -;;;### (autoloads (forms-find-file-other-window forms-find-file forms-mode) "forms" "utils/forms.el" (12559 34930)) +;;;### (autoloads (forms-find-file-other-window forms-find-file forms-mode) "forms" "utils/forms.el" (12869 55653)) ;;; Generated autoloads from utils/forms.el (autoload 'forms-mode "forms" "\ Major mode to visit files in a field-structured manner using a form. Commands: Equivalent keys in read-only mode: - - TAB forms-next-field TAB - C-c TAB forms-next-field - C-c < forms-first-record < - C-c > forms-last-record > - C-c ? describe-mode ? - C-c C-k forms-delete-record - C-c C-q forms-toggle-read-only q - C-c C-o forms-insert-record - C-c C-l forms-jump-record l - C-c C-n forms-next-record n - C-c C-p forms-prev-record p - C-c C-s forms-search s - C-c C-x forms-exit x" t nil) + TAB forms-next-field TAB + \\C-c TAB forms-next-field + \\C-c < forms-first-record < + \\C-c > forms-last-record > + \\C-c ? describe-mode ? + \\C-c \\C-k forms-delete-record + \\C-c \\C-q forms-toggle-read-only q + \\C-c \\C-o forms-insert-record + \\C-c \\C-l forms-jump-record l + \\C-c \\C-n forms-next-record n + \\C-c \\C-p forms-prev-record p + \\C-c \\C-r forms-search-backward r + \\C-c \\C-s forms-search-forward s + \\C-c \\C-x forms-exit x +" t nil) (autoload 'forms-find-file "forms" "\ Visit a file in Forms mode." t nil) @@ -11066,6 +11927,41 @@ ;;;*** +;;;### (autoloads (id-select-double-click-hook id-select-and-kill-thing id-select-and-copy-thing id-select-goto-matching-tag id-select-thing-with-mouse id-select-thing) "id-select" "utils/id-select.el" (12967 2888)) +;;; Generated autoloads from utils/id-select.el + +(autoload 'id-select-thing "id-select" "\ +Mark the region selected by the syntax of the thing at point. +If invoked repeatedly, selects bigger and bigger things. +If `id-select-display-type' is non-nil, the type of selection is displayed in +the minibuffer." t nil) + +(autoload 'id-select-thing-with-mouse "id-select" "\ +Select a region based on the syntax of the character from a mouse click. +If the click occurs at the same point as the last click, select +the next larger syntactic structure. If `id-select-display-type' is non-nil, +the type of selection is displayed in the minibuffer." t nil) + +(autoload 'id-select-goto-matching-tag "id-select" "\ +If in a major mode listed in `id-select-markup-modes,' moves point to the start of the tag paired with the closest tag that point is within or precedes. +Returns t if point is moved, else nil. +Signals an error if no tag is found following point or if the closing tag +does not have a `>' terminator character." t nil) + +(autoload 'id-select-and-copy-thing "id-select" "\ +Copy the region surrounding the syntactical unit at point." t nil) + +(autoload 'id-select-and-kill-thing "id-select" "\ +Kill the region surrounding the syntactical unit at point." t nil) + +(autoload 'id-select-double-click-hook "id-select" "\ +Select a region based on the syntax of the character wherever the mouse is double-clicked. +If the double-click occurs at the same point as the last double-click, select +the next larger syntactic structure. If `id-select-display-type' is non-nil, +the type of selection is displayed in the minibuffer." nil nil) + +;;;*** + ;;;### (autoloads nil "lib-complete" "utils/lib-complete.el" (12675 57130)) ;;; Generated autoloads from utils/lib-complete.el @@ -11360,6 +12256,11 @@ ;;;*** ;;;*** + +;;;*** + +;;;### (autoloads nil "smtpmail" "utils/smtpmail.el" (12871 64617)) +;;; Generated autoloads from utils/smtpmail.el ;;;### (autoloads nil "soundex" "utils/soundex.el" (12860 19454)) ;;; Generated autoloads from utils/soundex.el @@ -11998,7 +12899,7 @@ ;;;### (autoloads nil "x-faces" "x11/x-faces.el" (12698 33571)) ;;; Generated autoloads from x11/x-faces.el -;;;### (autoloads (font-menu-weight-constructor font-menu-size-constructor font-menu-family-constructor reset-device-font-menus) "x-font-menu" "x11/x-font-menu.el" (12851 23497)) +;;;### (autoloads (font-menu-weight-constructor font-menu-size-constructor font-menu-family-constructor reset-device-font-menus) "x-font-menu" "x11/x-font-menu.el" (12874 15156)) ;;; Generated autoloads from x11/x-font-menu.el (defvar font-menu-ignore-scaled-fonts t "\ @@ -12027,11 +12928,11 @@ ;;;*** ;;;*** - -;;;### (autoloads nil "x-init" "x11/x-init.el" (12851 23499)) + +;;;*** + +;;;### (autoloads nil "x-init" "x11/x-init.el" (12933 12020)) ;;; Generated autoloads from x11/x-init.el - -;;;*** ;;;### (autoloads nil "x-iso8859-1" "x11/x-iso8859-1.el" (12639 8655)) ;;; Generated autoloads from x11/x-iso8859-1.el @@ -12039,14 +12940,16 @@ ;;;*** ;;;*** - -;;;### (autoloads nil "x-menubar" "x11/x-menubar.el" (12860 19461)) + +;;;*** + +;;;### (autoloads nil "x-menubar" "x11/x-menubar.el" (12874 15306)) ;;; Generated autoloads from x11/x-menubar.el + +;;;*** ;;;### (autoloads nil "x-misc" "x11/x-misc.el" (12639 8659)) ;;; Generated autoloads from x11/x-misc.el - -;;;*** ;;;### (autoloads nil "x-mouse" "x11/x-mouse.el" (12698 33572)) ;;; Generated autoloads from x11/x-mouse.el diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/loadup.el --- a/lisp/prim/loadup.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/loadup.el Mon Aug 13 08:46:56 2007 +0200 @@ -135,7 +135,8 @@ (load-gc "lisp-mode") (load-gc "text-mode") (load-gc "fill") - (load-gc "cc-mode") + ;; (load-gc "cc-mode") ; as FSF goes so go we .. + (load-gc "scroll-in-place") ;; we no longer load buff-menu automatically. ;; it will get autoloaded if needed. @@ -204,7 +205,7 @@ )) ;; end of call-with-condition-handler -(setq load-warn-when-source-newer nil ; set to t at top of file +(setq load-warn-when-source-newer t ; set to t at top of file load-warn-when-source-only nil) (setq debugger 'debug) diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/minibuf.el --- a/lisp/prim/minibuf.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/minibuf.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,8 +1,12 @@ -;;; minibuf.el +;;; minibuf.el -- Minibuffer support functions for XEmacs + ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. ;; Copyright (C) 1995 Tinker Systems ;; Copyright (C) 1995, 1996 Ben Wing +;; Author: Richard Mlynarik +;; Keywords: internal + ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify it @@ -17,10 +21,11 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. ;;; Synched up with: all the minibuffer history stuff is synched with -;;; 19.30. Not sure about the rest. +;;; 19.34. Not sure about the rest. ;;; Commentary: @@ -156,6 +161,10 @@ (define-key map "\M-?" 'comint-dynamic-list-completions) map) "Minibuffer keymap used by shell-command and related commands.") + +(defvar should-use-dialog-box t + "Variable controlling usage of the dialog box. If nil, the dialog box +will never be used, even in response to mouse events.") (defvar minibuffer-electric-file-name-behavior t "If non-nil, slash and tilde in certain places cause immediate deletion. @@ -2002,9 +2011,13 @@ "If non-nil, questions should be asked with a dialog box instead of the minibuffer. This looks at `last-command-event' to see if it was a mouse event, and checks whether dialog-support exists and the current device -supports dialog boxes." +supports dialog boxes. + +The dialog box is totally disabled if the variable `should-use-dialog-box' +is set to nil." (and (featurep 'dialog) (device-on-window-system-p) + should-use-dialog-box (or force-dialog-box-use (button-press-event-p last-command-event) (button-release-event-p last-command-event) diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/novice.el --- a/lisp/prim/novice.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/novice.el Mon Aug 13 08:46:56 2007 +0200 @@ -20,9 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -78,6 +79,12 @@ (set-buffer standard-output) (help-mode))) (message "Type y, n or Space: ") +; (let ((cursor-in-echo-area t)) +; (while (not (memq (setq char (downcase (read-char))) +; '(? ?y ?n))) +; (ding) +; (message "Please type y, n or Space: ")))) + ;; XEmacs version (let ((cursor-in-echo-area t) (inhibit-quit t) event) @@ -109,7 +116,7 @@ (not (string= "" user-init-file)) (y-or-n-p "Enable command for future editing sessions also? ")) (enable-command this-command) - (put this-command 'disabled nil))) + (put this-command 'disabled nil))) (if (/= char ?n) (call-interactively this-command)))) diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/options.el --- a/lisp/prim/options.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/options.el Mon Aug 13 08:46:56 2007 +0200 @@ -18,9 +18,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -41,7 +42,7 @@ (Edit-options-mode)) (with-output-to-temp-buffer "*List Options*" (let (vars) - (mapatoms #'(lambda (sym) + (mapatoms #'(lambda (sym) ; XEmacs (if (user-variable-p sym) (setq vars (cons sym vars))))) (setq vars (sort vars 'string-lessp)) @@ -50,7 +51,7 @@ (princ ";; ") (prin1 sym) (princ ":\n\t") - (if (boundp sym) + (if (boundp sym) ; XEmacs (prin1 (symbol-value sym)) (princ "#")) (terpri) @@ -108,12 +109,12 @@ (setq paragraph-start "\t") (setq truncate-lines t) (setq major-mode 'Edit-options-mode) - (setq mode-name (gettext "Options")) + (setq mode-name (gettext "Options")) ; XEmacs (run-hooks 'Edit-options-mode-hook)) (defun Edit-options-set () (interactive) (Edit-options-modify - '(lambda (var) (eval-minibuffer (format "New %s:" (symbol-name var)))))) + '(lambda (var) (eval-minibuffer (concat "New " (symbol-name var) ": "))))) (defun Edit-options-toggle () (interactive) (Edit-options-modify '(lambda (var) (not (symbol-value var))))) @@ -131,14 +132,14 @@ (forward-char 3) (setq pos (point)) (save-restriction - (narrow-to-region pos (progn (end-of-line) (1- (point)))) - (goto-char pos) - (setq var (read (current-buffer)))) + (narrow-to-region pos (progn (end-of-line) (1- (point)))) + (goto-char pos) + (setq var (read (current-buffer)))) (goto-char pos) (forward-line 1) (forward-char 1) (save-excursion - (set var (funcall modfun var))) + (set var (funcall modfun var))) (kill-sexp 1) (prin1 (symbol-value var) (current-buffer))))) diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/page.el --- a/lisp/prim/page.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/page.el Mon Aug 13 08:46:56 2007 +0200 @@ -18,9 +18,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -33,7 +34,7 @@ "Move forward to page boundary. With arg, repeat, or go back if negative. A page boundary is any line whose beginning matches the regexp `page-delimiter'." - (interactive "_p") + (interactive "_p") ; XEmacs (or count (setq count 1)) (while (and (> count 0) (not (eobp))) ;; In case the page-delimiter matches the null string, @@ -44,26 +45,24 @@ (goto-char (point-max))) (setq count (1- count))) (while (and (< count 0) (not (bobp))) + ;; In case the page-delimiter matches the null string, + ;; don't find a match without moving. + (and (save-excursion (re-search-backward page-delimiter nil t)) + (= (match-end 0) (point)) + (goto-char (match-beginning 0))) (forward-char -1) - (let (result (end (point))) - ;; If we find a match that ends where we started searching, - ;; look for another one. - (while (and (setq result (re-search-backward page-delimiter nil t)) - (= (match-end 0) end)) - ;; Just search again. - ) - (if result - ;; We found one--move to the end of it. - (goto-char (match-end 0)) - ;; We found nothing--go to beg of buffer. - (goto-char (point-min)))) + (if (re-search-backward page-delimiter nil t) + ;; We found one--move to the end of it. + (goto-char (match-end 0)) + ;; We found nothing--go to beg of buffer. + (goto-char (point-min))) (setq count (1+ count)))) (defun backward-page (&optional count) "Move backward to page boundary. With arg, repeat, or go fwd if negative. A page boundary is any line whose beginning matches the regexp `page-delimiter'." - (interactive "p") + (interactive "_p") ; XEmacs (or count (setq count 1)) (forward-page (- count))) @@ -113,10 +112,11 @@ (if (and (eolp) (not (bobp))) (forward-line 1)) (point))))) +(put 'narrow-to-page 'disabled t) (defun count-lines-page () "Report number of lines on current page, and how many are before or after point." - (interactive "_") + (interactive "_") ; XEmacs (save-excursion (let ((opoint (point)) beg end total before after) @@ -134,7 +134,7 @@ (defun what-page () "Print page and line number of point." - (interactive "_") + (interactive "_") ; XEmacs (save-restriction (widen) (save-excursion diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/paragraphs.el --- a/lisp/prim/paragraphs.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/paragraphs.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,7 +1,6 @@ ;;; paragraphs.el --- paragraph and sentence parsing. -;; Copyright (C) 1985, 1986, 1987, 1991, 1993, 1994, 1995 -;; Free Software Foundation, Inc. +;; Copyright (C) 1985, 86, 87, 91, 94, 95 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: wp @@ -20,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -43,6 +43,7 @@ Each buffer has its own value of this variable.") (make-variable-buffer-local 'use-hard-newlines) +;; XEmacs - use purecopy (defconst paragraph-start (purecopy "[ \t\n\f]") "\ *Regexp for beginning of a line that starts OR separates paragraphs. This regexp should match lines that separate paragraphs @@ -66,6 +67,7 @@ ;; something very minimal, even including "." (which makes every hard newline ;; start a new paragraph). +;; XEmacs -- use purecopy (defconst paragraph-separate (purecopy "[ \t\f]*$") "\ *Regexp for beginning of a line that separates paragraphs. If you change this, you may have to change paragraph-start also. @@ -75,6 +77,7 @@ ensures that the paragraph functions will work equally within a region of text indented by a margin setting.") +;; XEmacs -- use purecopy (defconst sentence-end (purecopy "[.?!][]\"')}]*\\($\\| $\\|\t\\| \\)[ \t\n]*") "\ *Regexp describing the end of a sentence. All paragraph boundaries also end sentences, regardless. @@ -83,6 +86,7 @@ question mark, or exclamation point must be followed by two spaces, unless it's inside some sort of quotes or parenthesis.") +;; XEmacs -- use purecopy (defconst page-delimiter (purecopy "^\014") "\ *Regexp describing line-beginnings that separate pages.") @@ -98,7 +102,7 @@ \(if `paragraph-separate' matches it also) or is the first line of a paragraph. A paragraph end is the beginning of a line which is not part of the paragraph to which the end of the previous line belongs, or the end of the buffer." - (interactive "_p") + (interactive "_p") ; XEmacs (or arg (setq arg 1)) (let* ((fill-prefix-regexp (and fill-prefix (not (equal fill-prefix "")) @@ -139,12 +143,11 @@ (forward-line -1)) (if (bobp) nil - (progn - ;; Go to end of the previous (non-separating) line. - (end-of-line) - ;; Search back for line that starts or separates paragraphs. - (if (if fill-prefix-regexp - ;; There is a fill prefix; it overrides paragraph-start. + ;; Go to end of the previous (non-separating) line. + (end-of-line) + ;; Search back for line that starts or separates paragraphs. + (if (if fill-prefix-regexp + ;; There is a fill prefix; it overrides paragraph-start. (let (multiple-lines) (while (and (progn (beginning-of-line) (not (bobp))) (progn (move-to-left-margin) @@ -174,15 +177,15 @@ 'hard))))) (goto-char start)) (> (point) (point-min))) - ;; Found one. - (progn - ;; Move forward over paragraph separators. - ;; We know this cannot reach the place we started - ;; because we know we moved back over a non-separator. + ;; Found one. + (progn + ;; Move forward over paragraph separators. + ;; We know this cannot reach the place we started + ;; because we know we moved back over a non-separator. (while (and (not (eobp)) (progn (move-to-left-margin) (looking-at paragraph-separate))) - (forward-line 1)) + (forward-line 1)) ;; If line before paragraph is just margin, back up to there. (end-of-line 0) (if (> (current-column) (current-left-margin)) @@ -190,10 +193,11 @@ (skip-chars-backward " \t") (if (not (bolp)) (forward-line 1)))) - ;; No starter or separator line => use buffer beg. - (goto-char (point-min)))))) + ;; No starter or separator line => use buffer beg. + (goto-char (point-min))))) (setq arg (1+ arg))) (while (and (> arg 0) (not (eobp))) + ;; Move forward over separator lines, and one more line. (while (prog1 (and (not (eobp)) (progn (move-to-left-margin) (not (eobp))) (looking-at paragraph-separate)) @@ -230,7 +234,7 @@ blank line. See `forward-paragraph' for more information." - (interactive "_p") + (interactive "_p") ; XEmacs (or arg (setq arg 1)) (forward-paragraph (- arg))) @@ -246,14 +250,14 @@ "Kill forward to end of paragraph. With arg N, kill forward to Nth end of paragraph; negative arg -N means kill backward to Nth start of paragraph." - (interactive "*p") + (interactive "*p") ; XEmacs (kill-region (point) (progn (forward-paragraph arg) (point)))) (defun backward-kill-paragraph (arg) "Kill back to start of paragraph. With arg N, kill back to Nth start of paragraph; negative arg -N means kill forward to Nth end of paragraph." - (interactive "*p") + (interactive "*p") ; XEmacs (kill-region (point) (progn (backward-paragraph arg) (point)))) (defun transpose-paragraphs (arg) @@ -290,10 +294,9 @@ "Move forward to next `sentence-end'. With argument, repeat. With negative argument, move backward repeatedly to `sentence-beginning'. -The variable `sentence-end' is a regular expression that matches ends -of sentences. Also, every paragraph boundary terminates sentences as -well." - (interactive "_p") +The variable `sentence-end' is a regular expression that matches ends of +sentences. Also, every paragraph boundary terminates sentences as well." + (interactive "_p") ; XEmacs (or arg (setq arg 1)) (while (< arg 0) (let ((par-beg (save-excursion (start-of-paragraph-text) (point)))) @@ -311,25 +314,31 @@ (defun backward-sentence (&optional arg) "Move backward to start of sentence. With arg, do it arg times. See `forward-sentence' for more information." - (interactive "_p") + (interactive "_p") ; XEmacs (or arg (setq arg 1)) (forward-sentence (- arg))) (defun kill-sentence (&optional arg) "Kill from point to end of sentence. With arg, repeat; negative arg -N means kill back to Nth start of sentence." - (interactive "p") + (interactive "*p") ; XEmacs (kill-region (point) (progn (forward-sentence arg) (point)))) (defun backward-kill-sentence (&optional arg) "Kill back from point to start of sentence. With arg, repeat, or kill forward to Nth end of sentence if negative arg -N." - (interactive "p") + (interactive "*p") ; XEmacs (kill-region (point) (progn (backward-sentence arg) (point)))) (defun mark-end-of-sentence (arg) "Put mark at end of sentence. Arg works as in `forward-sentence'." (interactive "p") + ;; FSF Version: +; (push-mark +; (save-excursion +; (forward-sentence arg) +; (point)) +; nil t)) (mark-something 'mark-end-of-sentence 'forward-sentence arg)) (defun transpose-sentences (arg) @@ -338,4 +347,3 @@ (transpose-subr 'forward-sentence arg)) ;;; paragraphs.el ends here - diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/rect.el --- a/lisp/prim/rect.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/rect.el Mon Aug 13 08:46:56 2007 +0200 @@ -19,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -53,22 +54,23 @@ (forward-line 1) (setq endlinepos (point-marker))) (if (< endcol startcol) + ;; XEmacs (let ((tem startcol)) (setq startcol endcol endcol tem))) (save-excursion (goto-char startlinepos) (while (< (point) endlinepos) - (let (startpos begextra endextra) - (move-to-column startcol coerce-tabs) - (setq begextra (- (current-column) startcol)) - (setq startpos (point)) - (move-to-column endcol coerce-tabs) - (setq endextra (- endcol (current-column))) - (if (< begextra 0) - (setq endextra (+ endextra begextra) - begextra 0)) + (let (startpos begextra endextra) + (move-to-column startcol coerce-tabs) + (setq begextra (- (current-column) startcol)) + (setq startpos (point)) + (move-to-column endcol coerce-tabs) + (setq endextra (- endcol (current-column))) + (if (< begextra 0) + (setq endextra (+ endextra begextra) + begextra 0)) (apply function startpos begextra endextra extra-args)) - (forward-line 1))) + (forward-line 1))) (- endcol startcol))) (defun delete-rectangle-line (startdelpos ignore ignore) @@ -96,7 +98,7 @@ (setq line (concat (spaces-string begextra) line (spaces-string endextra)))) - (setcdr lines (cons line (cdr lines))))) + (setcdr lines (cons line (cdr lines))))) ; XEmacs (defconst spaces-strings (purecopy '["" " " " " " " " " " " " " " " " "])) @@ -112,9 +114,8 @@ ;;;###autoload (defun delete-rectangle (start end) "Delete (don't save) text in rectangle with point and mark as corners. -The same range of columns is deleted in each line -starting with the line where the region begins -and ending with the line where the region ends." +The same range of columns is deleted in each line starting with the line +where the region begins and ending with the line where the region ends." (interactive "r") (operate-on-rectangle 'delete-rectangle-line start end t)) @@ -161,8 +162,8 @@ ;;;###autoload (defun insert-rectangle (rectangle) "Insert text of RECTANGLE with upper left corner at point. -RECTANGLE's first line is inserted at point, -its second line is inserted at a point vertically under point, etc. +RECTANGLE's first line is inserted at point, its second +line is inserted at a point vertically under point, etc. RECTANGLE should be a list of strings. After this command, the mark is at the upper left corner and point is at the lower right corner." @@ -212,7 +213,7 @@ Called from a program, takes three args; START, END and STRING." (interactive "r\nsString rectangle: ") - (operate-on-rectangle 'string-rectangle-line start end t string)) + (operate-on-rectangle 'string-rectangle-line start end t string)) ; XEmacs ;; XEmacs: add string arg (defun string-rectangle-line (startpos begextra endextra string) @@ -249,13 +250,6 @@ ;; Reindent out to same column that we were at. (indent-to column))) -;(defun rectangle-coerce-tab (column) -; (let ((aftercol (current-column)) -; (indent-tabs-mode nil)) -; (delete-char -1) -; (indent-to aftercol) -; (backward-char (- aftercol column)))) - (provide 'rect) ;;; rect.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/register.el --- a/lisp/prim/register.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/register.el Mon Aug 13 08:46:56 2007 +0200 @@ -19,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -62,18 +63,18 @@ (set-register register (if arg (current-frame-configuration) (point-marker)))) -(defun window-configuration-to-register (register) +(defun window-configuration-to-register (register &optional arg) "Store the window configuration of the selected frame in register REGISTER. Use \\[jump-to-register] to restore the configuration. Argument is a character, naming the register." - (interactive "cWindow configuration to register: ") + (interactive "cWindow configuration to register: \nP") (set-register register (current-window-configuration))) (defun frame-configuration-to-register (register &optional arg) "Store the window configuration of all frames in register REGISTER. Use \\[jump-to-register] to restore the configuration. Argument is a character, naming the register." - (interactive "cFrame configuration to register: ") + (interactive "cFrame configuration to register: \nP") (set-register register (current-frame-configuration))) (defalias 'register-to-point 'jump-to-register) @@ -105,8 +106,6 @@ (t (error "Register doesn't contain a buffer position or configuration"))))) -; In FSFmacs, these are commented out, too. - ;(defun number-to-register (arg char) ; "Store a number in a register. ;Two args, NUMBER and REGISTER (a character, naming the register). @@ -141,23 +140,22 @@ (interactive "cView register: ") (let ((val (get-register register))) (if (null val) - (message "Register %s is empty" - (single-key-description register)) + (message "Register %s is empty" (single-key-description register)) (with-output-to-temp-buffer "*Output*" (princ (format "Register %s contains " (single-key-description register))) (cond - ((integerp val) - (princ val)) + ((integerp val) + (princ val)) - ((markerp val) - (let ((buf (marker-buffer val))) - (if (null buf) - (princ "a marker in no buffer") - (princ (format - "a buffer position:\nbuff %s, position %s" - (buffer-name (marker-buffer val)) - (marker-position val)))))) + ((markerp val) + (let ((buf (marker-buffer val))) + (if (null buf) + (princ "a marker in no buffer") + (princ (format + "a buffer position:\nbuff %s, position %s" + (buffer-name (marker-buffer val)) + (marker-position val)))))) ((window-configuration-p val) (princ "a window configuration.")) @@ -171,47 +169,46 @@ (prin1 (cdr val)) (princ ".")) - ((consp val) - (princ "the rectangle:\n") + ((consp val) + (princ "the rectangle:\n") (while val - (princ (car val)) - (terpri) - (setq val (cdr val)))) + (princ (car val)) + (terpri) + (setq val (cdr val)))) ((stringp val) (princ "the text:\n") (princ val)) - (t + (t (princ "Garbage:\n") (prin1 val))))))) (defun insert-register (register &optional arg) - "Insert contents of register REGISTER. REGISTER is a character. + "Insert contents of register REGISTER. (REGISTER is a character). Normally puts point before and mark after the inserted text. If optional second arg is non-nil, puts mark before and point after. Interactively, second arg is non-nil if prefix arg is supplied." (interactive "*cInsert register: \nP") (push-mark) (let ((val (get-register register))) - (cond ((consp val) - (insert-rectangle val)) - ((stringp val) - (insert val)) - ((integerp val) - (princ val (current-buffer))) - ((and (markerp val) (marker-position val)) - (princ (marker-position val) (current-buffer))) - (t - (error "Register does not contain text")))) + (cond + ((consp val) + (insert-rectangle val)) + ((stringp val) + (insert val)) + ((integerp val) + (princ val (current-buffer))) + ((and (markerp val) (marker-position val)) + (princ (marker-position val) (current-buffer))) + (t + (error "Register does not contain text")))) ;; XEmacs: don't activate the region. It's annoying. (if (not arg) (exchange-point-and-mark t))) (defun copy-to-register (register start end &optional delete-flag) - "Copy region into register REGISTER. -With prefix arg, delete as well. -Called from program, takes four args: -REGISTER, START, END and DELETE-FLAG. + "Copy region into register REGISTER. With prefix arg, delete as well. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to copy." (interactive "cCopy to register: \nr\nP") (set-register register (buffer-substring start end)) @@ -220,8 +217,7 @@ (defun append-to-register (register start end &optional delete-flag) "Append region to text in register REGISTER. With prefix arg, delete as well. -Called from program, takes four args: -REGISTER, START, END and DELETE-FLAG. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to append." (interactive "cAppend to register: \nr\nP") (or (stringp (get-register register)) @@ -233,8 +229,7 @@ (defun prepend-to-register (register start end &optional delete-flag) "Prepend region to text in register REGISTER. With prefix arg, delete as well. -Called from program, takes four args: -REGISTER, START, END and DELETE-FLAG. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to prepend." (interactive "cPrepend to register: \nr\nP") (or (stringp (get-register register)) @@ -246,8 +241,7 @@ (defun copy-rectangle-to-register (register start end &optional delete-flag) "Copy rectangular region into register REGISTER. With prefix arg, delete as well. -Called from program, takes four args: -REGISTER, START, END and DELETE-FLAG. +Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions giving two corners of rectangle." (interactive "cCopy rectangle to register: \nr\nP") (set-register register diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/replace.el --- a/lisp/prim/replace.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/replace.el Mon Aug 13 08:46:56 2007 +0200 @@ -16,18 +16,21 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34 [Partially]. ;;; Commentary: ;; This package supplies the string and regular-expression replace functions ;; documented in the XEmacs Reference Manual. +;; All the gettext calls are for XEmacs I18N3 message catalog support. + ;;; Code: -(defvar case-replace t "\ +(defconst case-replace t "\ *Non-nil means `query-replace' should preserve case in replacements. What this means is that `query-replace' will change the case of the replacement text so that it matches the text that was replaced. @@ -144,6 +147,9 @@ "Replace occurrences of FROM-STRING with TO-STRING. Preserve case in each match if `case-replace' and `case-fold-search' are non-nil and FROM-STRING has no uppercase letters. +\(Preserving case means that if the string matched is all caps, or capitalized, +then its replacement is upcased or capitalized.) + Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace only matches surrounded by word boundaries. @@ -251,8 +257,8 @@ (if occur-mode-map () (setq occur-mode-map (make-sparse-keymap)) - (set-keymap-name occur-mode-map 'occur-mode-map) - (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) + (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs + (define-key occur-mode-map [mouse-2] 'occur-mode-mouse-goto) (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence)) @@ -270,15 +276,26 @@ (kill-all-local-variables) (use-local-map occur-mode-map) (setq major-mode 'occur-mode) - (setq mode-name (gettext "Occur")) + (setq mode-name (gettext "Occur")) ; XEmacs (make-local-variable 'occur-buffer) (make-local-variable 'occur-nlines) (make-local-variable 'occur-pos-list) - (require 'mode-motion) - (setq mode-motion-hook 'mode-motion-highlight-line) + (require 'mode-motion) ; XEmacs + (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs (run-hooks 'occur-mode-hook)) -(defun occur-mode-mouse-goto (e) +;; FSF Version of next function: +; (let (buffer pos) +; (save-excursion +; (set-buffer (window-buffer (posn-window (event-end event)))) +; (save-excursion +; (goto-char (posn-point (event-end event))) +; (setq pos (occur-mode-find-occurrence)) +; (setq buffer occur-buffer))) +; (pop-to-buffer buffer) +; (goto-char (marker-position pos)))) + +(defun occur-mode-mouse-goto (event) "Go to the occurrence highlighted by mouse. This function is only reasonable when bound to a mouse key in the occur buffer" (interactive "e") @@ -292,6 +309,7 @@ (select-frame frame-save) (select-window window-save)))) +;; Called occur-mode-find-occurrence in FSF (defun occur-mode-goto-occurrence () "Go to the occurrence the current line describes." (interactive) @@ -322,7 +340,7 @@ (error "No occurrence on this line")) (or pos (error "No occurrence on this line")) - ;; don't raise window unless it isn't visible + ;; XEmacs: don't raise window unless it isn't visible ;; allow for the possibility that the occur buffer is on another frame (or (and window (window-live-p window) @@ -343,7 +361,7 @@ ;;; Damn you Jamie, this is utter trash. (defvar list-matching-lines-whole-buffer t "If t, occur operates on whole buffer, otherwise occur starts from point. -default is nil.") +default is t.") (define-function 'occur 'list-matching-lines) (defun list-matching-lines (regexp &optional nlines) @@ -354,8 +372,8 @@ If variable `list-matching-lines-whole-buffer' is non-nil, the entire buffer is searched, otherwise search begins at point. -Each line is displayed with NLINES lines before and after, -or -NLINES before if NLINES is negative. +Each line is displayed with NLINES lines before and after, or -NLINES +before if NLINES is negative. NLINES defaults to `list-matching-lines-default-context-lines'. Interactively it is the prefix arg. @@ -363,6 +381,7 @@ It serves as a menu to find any of the occurrences in this buffer. \\[describe-mode] in that buffer will explain how." (interactive + ;; XEmacs change (list (let* ((default (or (symbol-near-point) (and regexp-history (car regexp-history)))) @@ -395,6 +414,8 @@ (buffer (current-buffer)) (linenum 1) (prevpos (point-min)) + ;; The rest of this function is very different from FSF. + ;; Presumably that's due to Jamie's misfeature (final-context-start (make-marker))) (if (not list-matching-lines-whole-buffer) (save-excursion @@ -497,24 +518,27 @@ ;; It would be nice to use \\[...], but there is no reasonable way ;; to make that display both SPC and Y. -(defvar query-replace-help (purecopy - "Type Space or `y' to replace one match, Delete or `n' to skip to next, +(defconst query-replace-help + (purecopy + "Type Space or `y' to replace one match, Delete or `n' to skip to next, RET or `q' to exit, Period to replace one match and exit, Comma to replace but not move point immediately, C-r to enter recursive edit (\\[exit-recursive-edit] to get out again), C-w to delete match and recursive edit, C-l to clear the frame, redisplay, and offer same replacement again, ! to replace all remaining matches with no more questions, -^ to move point back to previous match.") +^ to move point back to previous match." +) "Help message while in query-replace") -(defvar query-replace-map nil +(defvar query-replace-map nil "Keymap that defines the responses to questions in `query-replace'. The \"bindings\" in this map are not commands; they are answers. The valid answers include `act', `skip', `act-and-show', `exit', `act-and-exit', `edit', `delete-and-edit', `recenter', `automatic', `backup', `exit-prefix', and `help'.") +;; Why does it seem that ever file has a different method of doing this? (if query-replace-map nil (let ((map (make-sparse-keymap))) @@ -551,6 +575,7 @@ (autoload 'isearch-highlight "isearch") +;; XEmacs (defun perform-replace-next-event (event) (if isearch-highlight (let ((aborted t)) @@ -574,8 +599,8 @@ (or map (setq map query-replace-map)) (let* ((event (make-event)) (nocasify (not (and case-fold-search case-replace - (string-equal from-string - (downcase from-string))))) + (string-equal from-string + (downcase from-string))))) (literal (not regexp-flag)) (search-function (if regexp-flag 're-search-forward 'search-forward)) (search-string from-string) @@ -608,186 +633,195 @@ "\\b"))) (push-mark) (undo-boundary) - ;; Loop finding occurrences that perhaps should be replaced. - (while (and keep-going - (not (eobp)) - (let ((case-fold-search qr-case-fold-search)) - (funcall search-function search-string nil t)) - ;; If the search string matches immediately after - ;; the previous match, but it did not match there - ;; before the replacement was done, ignore the match. - (if (or (eq lastrepl (point)) - (and regexp-flag - (eq lastrepl (match-beginning 0)) - (not match-again))) + (unwind-protect + ;; Loop finding occurrences that perhaps should be replaced. + (while (and keep-going + (not (eobp)) + (let ((case-fold-search qr-case-fold-search)) + (funcall search-function search-string nil t)) + ;; If the search string matches immediately after + ;; the previous match, but it did not match there + ;; before the replacement was done, ignore the match. + (if (or (eq lastrepl (point)) + (and regexp-flag + (eq lastrepl (match-beginning 0)) + (not match-again))) + (if (eobp) + nil + ;; Don't replace the null string + ;; right after end of previous replacement. + (forward-char 1) + (let ((case-fold-search qr-case-fold-search)) + (funcall search-function search-string nil t))) + t)) - (if (eobp) - nil - ;; Don't replace the null string - ;; right after end of previous replacement. - (forward-char 1) - (let ((case-fold-search qr-case-fold-search)) - (funcall search-function search-string nil t))) - t)) - ;; Save the data associated with the real match. - (setq real-match-data (match-data)) - - ;; Before we make the replacement, decide whether the search string - ;; can match again just after this match. - (if regexp-flag - (progn - (setq match-again (looking-at search-string)) - (store-match-data real-match-data))) + ;; Save the data associated with the real match. + (setq real-match-data (match-data)) - ;; If time for a change, advance to next replacement string. - (if (and (listp replacements) - (= next-rotate-count replace-count)) - (progn - (setq next-rotate-count - (+ next-rotate-count repeat-count)) - (setq next-replacement (nth replacement-index replacements)) - (setq replacement-index (% (1+ replacement-index) (length replacements))))) - (if (not query-flag) - (progn - (store-match-data real-match-data) - (replace-match next-replacement nocasify literal) - (setq replace-count (1+ replace-count))) - (undo-boundary) - (let ((help-form - '(concat (format "Query replacing %s%s with %s.\n\n" - (if regexp-flag (gettext "regexp ") "") - from-string next-replacement) - (substitute-command-keys query-replace-help))) - (done nil) - (replaced nil) - def) - ;; Loop reading commands until one of them sets done, - ;; which means it has finished handling this occurrence. - (while (not done) - ;; Don't fill up the message log - ;; with a bunch of identical messages. - (display-message 'prompt - (format message from-string next-replacement)) - (perform-replace-next-event event) - (setq def (lookup-key map (vector event))) - ;; Restore the match data while we process the command. - (store-match-data real-match-data) - (cond ((eq def 'help) - (with-output-to-temp-buffer (gettext "*Help*") - (princ (concat - (format "Query replacing %s%s with %s.\n\n" - (if regexp-flag "regexp " "") - from-string next-replacement) - (substitute-command-keys - query-replace-help))) + ;; Before we make the replacement, decide whether the search string + ;; can match again just after this match. + (if regexp-flag + (progn + (setq match-again (looking-at search-string)) + ;; XEmacs addition + (store-match-data real-match-data))) + ;; If time for a change, advance to next replacement string. + (if (and (listp replacements) + (= next-rotate-count replace-count)) + (progn + (setq next-rotate-count + (+ next-rotate-count repeat-count)) + (setq next-replacement (nth replacement-index replacements)) + (setq replacement-index (% (1+ replacement-index) (length replacements))))) + (if (not query-flag) + (progn + (store-match-data real-match-data) + (replace-match next-replacement nocasify literal) + (setq replace-count (1+ replace-count))) + (undo-boundary) + (let ((help-form + '(concat (format "Query replacing %s%s with %s.\n\n" + (if regexp-flag (gettext "regexp ") "") + from-string next-replacement) + (substitute-command-keys query-replace-help))) + done replaced def) + ;; Loop reading commands until one of them sets done, + ;; which means it has finished handling this occurrence. + (while (not done) + ;; Don't fill up the message log + ;; with a bunch of identical messages. + ;; XEmacs change + (display-message 'prompt + (format message from-string next-replacement)) + (perform-replace-next-event event) + (setq def (lookup-key map (vector event))) + ;; Restore the match data while we process the command. + (store-match-data real-match-data) + (cond ((eq def 'help) + (with-output-to-temp-buffer (gettext "*Help*") + (princ (concat + (format "Query replacing %s%s with %s.\n\n" + (if regexp-flag "regexp " "") + from-string next-replacement) + (substitute-command-keys + query-replace-help))) (save-excursion (set-buffer standard-output) (help-mode)))) - ((eq def 'exit) - (setq keep-going nil) - (setq done t)) - ((eq def 'backup) - (if stack - (let ((elt (car stack))) - (goto-char (car elt)) - (setq replaced (eq t (cdr elt))) - (or replaced - (store-match-data (cdr elt))) - (setq stack (cdr stack))) - (progn + ((eq def 'exit) + (setq keep-going nil) + (setq done t)) + ((eq def 'backup) + (if stack + (let ((elt (car stack))) + (goto-char (car elt)) + (setq replaced (eq t (cdr elt))) + (or replaced + (store-match-data (cdr elt))) + (setq stack (cdr stack))) (message "No previous match") (ding 'no-terminate) - (sit-for 1)))) - ((eq def 'act) - (or replaced - (replace-match next-replacement nocasify literal)) - (setq done t replaced t)) - ((eq def 'act-and-exit) - (or replaced - (replace-match next-replacement nocasify literal)) - (setq keep-going nil) - (setq done t replaced t)) - ((eq def 'act-and-show) - (if (not replaced) - (progn - (replace-match next-replacement nocasify literal) - (setq replaced t)))) - ((eq def 'automatic) - (or replaced - (replace-match next-replacement nocasify literal)) - (setq done t query-flag nil replaced t)) - ((eq def 'skip) - (setq done t)) - ((eq def 'recenter) - (recenter nil)) - ((eq def 'edit) - (store-match-data - (prog1 (match-data) - (save-excursion (recursive-edit)))) - ;; Before we make the replacement, - ;; decide whether the search string - ;; can match again just after this match. - (if regexp-flag - (setq match-again (looking-at search-string)))) - ((eq def 'delete-and-edit) - (delete-region (match-beginning 0) (match-end 0)) - (store-match-data (prog1 (match-data) - (save-excursion (recursive-edit)))) - (setq replaced t)) - ;; Note: we do not need to treat `exit-prefix' - ;; specially here, since we reread - ;; any unrecognized character. - (t - (setq this-command 'mode-exited) - (setq keep-going nil) - (setq unread-command-events - (cons event unread-command-events)) - (setq done t)))) - ;; Record previous position for ^ when we move on. - ;; Change markers to numbers in the match data - ;; since lots of markers slow down editing. - (setq stack - (cons (cons (point) - (or replaced - (mapcar - #'(lambda (elt) - (if (markerp elt) - (prog1 (marker-position elt) - (set-marker elt nil)) - elt)) - (match-data)))) - stack)) - (if replaced (setq replace-count (1+ replace-count))))) - (setq lastrepl (point))) + (sit-for 1))) + ((eq def 'act) + (or replaced + (replace-match next-replacement nocasify literal)) + (setq done t replaced t)) + ((eq def 'act-and-exit) + (or replaced + (replace-match next-replacement nocasify literal)) + (setq keep-going nil) + (setq done t replaced t)) + ((eq def 'act-and-show) + (if (not replaced) + (progn + (replace-match next-replacement nocasify literal) + (setq replaced t)))) + ((eq def 'automatic) + (or replaced + (replace-match next-replacement nocasify literal)) + (setq done t query-flag nil replaced t)) + ((eq def 'skip) + (setq done t)) + ((eq def 'recenter) + (recenter nil)) + ((eq def 'edit) + (store-match-data + (prog1 (match-data) + (save-excursion (recursive-edit)))) + ;; Before we make the replacement, + ;; decide whether the search string + ;; can match again just after this match. + (if regexp-flag + (setq match-again (looking-at search-string)))) + ((eq def 'delete-and-edit) + (delete-region (match-beginning 0) (match-end 0)) + (store-match-data (prog1 (match-data) + (save-excursion (recursive-edit)))) + (setq replaced t)) + ;; Note: we do not need to treat `exit-prefix' + ;; specially here, since we reread + ;; any unrecognized character. + (t + (setq this-command 'mode-exited) + (setq keep-going nil) + (setq unread-command-events + (cons event unread-command-events)) + (setq done t)))) + ;; Record previous position for ^ when we move on. + ;; Change markers to numbers in the match data + ;; since lots of markers slow down editing. + (setq stack + (cons (cons (point) + (or replaced + (mapcar + #'(lambda (elt) + (if (markerp elt) + (prog1 (marker-position elt) + (set-marker elt nil)) + elt)) + (match-data)))) + stack)) + (if replaced (setq replace-count (1+ replace-count))))) + (setq lastrepl (point))) + (replace-dehighlight)) (or unread-command-events (message "Replaced %d occurrence%s" replace-count (if (= replace-count 1) "" "s"))) (and keep-going stack))) -; FSF 19.30 original: -; (defun match-string (num &optional string) -; "Return string of text matched by last search. -; NUM specifies which parenthesized expression in the last regexp. -; Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -; Zero means the entire text matched by the whole regexp or whole string. -; STRING should be given if the last search was by `string-match' on STRING." -; (if (match-beginning num) -; (if string -; (substring string (match-beginning num) (match-end num)) -; (buffer-substring (match-beginning num) (match-end num))))) +(defvar query-replace-highlight nil + "*Non-nil means to highlight words during query replacement.") + +(defvar replace-overlay nil) + +(defun replace-dehighlight () + (and replace-overlay + (progn + (delete-overlay replace-overlay) + (setq replace-overlay nil)))) -;; #### - this could stand to be in C... -(defmacro match-string (n &optional string) - "Returns the Nth subexpression matched by the last regular expression -search. The second argument, STRING, must be specified if the last -regular expression search was done with `string-match'." - ;; #### - note that match-beginning is byte coded, so it's more efficient - ;; to just call it twice than it is to let-bind its return value... --Stig - `(and (match-beginning ,n) - ,(if string - `(substring ,string (match-beginning ,n) (match-end ,n)) - `(buffer-substring (match-beginning ,n) (match-end ,n))))) +(defun replace-highlight (start end) + (and query-replace-highlight + (progn + (or replace-overlay + (progn + (setq replace-overlay (make-overlay start end)) + (overlay-put replace-overlay 'face + (if (internal-find-face 'query-replace) + 'query-replace 'region)))) + (move-overlay replace-overlay start end (current-buffer))))) + +(defun match-string (num &optional string) + "Return string of text matched by last search. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num))))) (defmacro save-match-data (&rest body) "Execute BODY forms, restoring the global value of the match data." diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/reposition.el --- a/lisp/prim/reposition.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/reposition.el Mon Aug 13 08:46:56 2007 +0200 @@ -20,23 +20,24 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: -;;; Reposition-window makes an entire function definition or comment visible, -;;; or, if it is already visible, places it at the top of the window; -;;; additional invocations toggle the visibility of comments preceding the -;;; code. For the gory details, see the documentation for reposition-window; -;;; rather than reading that, you may just want to play with it. +;; Reposition-window makes an entire function definition or comment visible, +;; or, if it is already visible, places it at the top of the window; +;; additional invocations toggle the visibility of comments preceding the +;; code. For the gory details, see the documentation for reposition-window; +;; rather than reading that, you may just want to play with it. -;;; This tries pretty hard to do the recentering correctly; the precise -;;; action depends on what the buffer looks like. If you find a situation -;;; where it doesn't behave well, let me know. This function is modeled -;;; after one of the same name in ZMACS, but the code is all-new and the -;;; behavior in some situations differs. +;; This tries pretty hard to do the recentering correctly; the precise +;; action depends on what the buffer looks like. If you find a situation +;; where it doesn't behave well, let me know. This function is modeled +;; after one of the same name in ZMACS, but the code is all-new and the +;; behavior in some situations differs. ;;; Code: @@ -73,13 +74,13 @@ ;; the beginning of the preceding comment (save-excursion (if (not (eobp)) (forward-char 1)) - (end-of-defun -1) + (end-of-defun -1) ;; Skip whitespace, newlines, and form feeds. (if (re-search-forward "[^ \t\n\f]" nil t) (backward-char 1)) (point)) here))) - (defun-height + (defun-height (repos-count-screen-lines-signed (save-excursion (end-of-defun 1) ; so comments associate with following defuns @@ -121,16 +122,16 @@ ;; whose first line is offscreen. ;; Avoid moving definition up even if defun runs offscreen; ;; we care more about getting the comment onscreen. - + (cond ((= line ht) ;; cursor on last screen line (and so in a comment) (if arg (progn (end-of-defun) (beginning-of-defun))) (recenter 0) ;;(repos-debug-macro "2a") ) - + ;; This condition, copied from case 4, may not be quite right - + ((and arg (< ht comment-height)) ;; Can't get first comment line onscreen. ;; Go there and try again. diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/simple.el --- a/lisp/prim/simple.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 08:46:56 2007 +0200 @@ -17,39 +17,40 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34 [But not very closely]. ;;; Commentary: ;; A grab-bag of basic XEmacs commands not specifically related to some ;; major mode or to file-handling. -;;; Changes for zmacs-style active-regions: -;;; -;;; beginning-of-buffer, end-of-buffer, count-lines-region, -;;; count-lines-buffer, what-line, what-cursor-position, set-goal-column, -;;; set-fill-column, prefix-arg-internal, and line-move (which is used by -;;; next-line and previous-line) set zmacs-region-stays to t, so that they -;;; don't affect the current region-hilighting state. -;;; -;;; mark-whole-buffer, mark-word, exchange-point-and-mark, and -;;; set-mark-command (without an argument) call zmacs-activate-region. -;;; -;;; mark takes an optional arg like the new Fmark_marker() does. When -;;; the region is not active, mark returns nil unless the optional arg is true. -;;; -;;; push-mark, pop-mark, exchange-point-and-mark, and set-marker, and -;;; set-mark-command use (mark t) so that they can access the mark whether -;;; the region is active or not. -;;; -;;; shell-command, shell-command-on-region, yank, and yank-pop (which all -;;; push a mark) have been altered to call exchange-point-and-mark with an -;;; argument, meaning "don't activate the region". These commands only use -;;; exchange-point-and-mark to position the newly-pushed mark correctly, so -;;; this isn't a user-visible change. These functions have also been altered -;;; to use (mark t) for the same reason. +;; Changes for zmacs-style active-regions: +;; +;; beginning-of-buffer, end-of-buffer, count-lines-region, +;; count-lines-buffer, what-line, what-cursor-position, set-goal-column, +;; set-fill-column, prefix-arg-internal, and line-move (which is used by +;; next-line and previous-line) set zmacs-region-stays to t, so that they +;; don't affect the current region-hilighting state. +;; +;; mark-whole-buffer, mark-word, exchange-point-and-mark, and +;; set-mark-command (without an argument) call zmacs-activate-region. +;; +;; mark takes an optional arg like the new Fmark_marker() does. When +;; the region is not active, mark returns nil unless the optional arg is true. +;; +;; push-mark, pop-mark, exchange-point-and-mark, and set-marker, and +;; set-mark-command use (mark t) so that they can access the mark whether +;; the region is active or not. +;; +;; shell-command, shell-command-on-region, yank, and yank-pop (which all +;; push a mark) have been altered to call exchange-point-and-mark with an +;; argument, meaning "don't activate the region". These commands only use +;; exchange-point-and-mark to position the newly-pushed mark correctly, so +;; this isn't a user-visible change. These functions have also been altered +;; to use (mark t) for the same reason. ;;; Code: @@ -66,6 +67,14 @@ ;; the end of the previous line. (let ((flag (and (not (bobp)) (bolp) + ;; Make sure the newline before point isn't intangible. + (not (get-char-property (1- (point)) 'intangible)) + ;; Make sure the newline before point isn't read-only. + (not (get-char-property (1- (point)) 'read-only)) + ;; Make sure the newline before point isn't invisible. + (not (get-char-property (1- (point)) 'invisible)) + ;; Make sure the newline before point has the same + ;; properties as the char before it (if any). (< (or (previous-extent-change (point)) -2) (- (point) 2)))) (was-page-start (and (bolp) @@ -88,11 +97,11 @@ ;; Mark the newline(s) `hard'. (if use-hard-newlines (let* ((from (- (point) (if arg (prefix-numeric-value arg) 1))) - (sticky (get-text-property from 'end-open))) + (sticky (get-text-property from 'end-open))) ; XEmacs (put-text-property from (point) 'hard 't) ;; If end-open is not "t", add 'hard to end-open list (if (and (listp sticky) (not (memq 'hard sticky))) - (put-text-property from (point) 'end-open + (put-text-property from (point) 'end-open ; XEmacs (cons 'hard sticky))))) ;; If the newline leaves the previous line blank, ;; and we have a left margin, delete that from the blank line. @@ -116,14 +125,8 @@ If there is a fill prefix and/or a left-margin, insert them on the new line if the line would have been blank. With arg N, insert N newlines." -;; "Insert a newline and leave point before it. -;; If there is a fill prefix, insert the fill prefix on the new line -;; if the line would have been empty. -;; With arg N, insert N newlines." (interactive "*p") (let* ((do-fill-prefix (and fill-prefix (bolp))) - ;well, I'm going to re-enable this. --ben - ;(do-fill-prefix nil) ;; screw this -- says JWZ (do-left-margin (and (bolp) (> (current-left-margin) 0))) (loc (point))) (newline arg) @@ -213,7 +216,7 @@ (defun just-one-space () "Delete all spaces and tabs around point, leaving one space." (interactive "*") - (if abbrev-mode + (if abbrev-mode ; XEmacs (expand-abbrev)) (skip-chars-backward " \t") (if (= (following-char) ? ) @@ -263,6 +266,7 @@ (defun back-to-indentation () "Move point to the first non-whitespace character on this line." + ;; XEmacs change (interactive "_") (beginning-of-line 1) (skip-chars-forward " \t")) @@ -322,7 +326,7 @@ (forward-char -1) (setq count (1- count))))) (delete-backward-char arg killp) - ;; In overwrite mode, back over columns while clearing them out, + ;; XEmacs: In overwrite mode, back over columns while clearing them out, ;; unless at end of line. (and overwrite-mode (not (eolp)) (save-excursion (insert-char ?\ arg)))) @@ -345,6 +349,7 @@ Don't use this command in Lisp programs! \(goto-char (point-min)) is faster and avoids clobbering the mark." + ;; XEmacs change (interactive "_P") (push-mark) (let ((size (- (point-max) (point-min)))) @@ -367,6 +372,7 @@ Don't use this command in Lisp programs! \(goto-char (point-max)) is faster and avoids clobbering the mark." + ;; XEmacs change (interactive "_P") (push-mark) ;; XEmacs changes here. @@ -384,11 +390,13 @@ ;; If we went to a place in the middle of the buffer, ;; adjust it to the beginning of a line. (forward-line 1)) + ;; XEmacs change (scroll-to-end ;; If the end of the buffer is not already on the screen, ;; then scroll specially to put it near, but not at, the bottom. (recenter -3))))) +;; XEmacs (not in FSF) (defun mark-beginning-of-buffer (&optional arg) "Push a mark at the beginning of the buffer; leave point where it is. With arg N, push mark N/10 of the way from the true beginning." @@ -404,6 +412,7 @@ t)) (define-function 'mark-bob 'mark-beginning-of-buffer) +;; XEmacs (not in FSF) (defun mark-end-of-buffer (&optional arg) "Push a mark at the end of the buffer; leave point where it is. With arg N, push mark N/10 of the way from the true end." @@ -430,6 +439,7 @@ (push-mark (point-max) nil t) (goto-char (point-min))) +;; XEmacs (defun eval-current-buffer (&optional printflag) "Evaluate the current buffer as Lisp code. Programs can pass argument PRINTFLAG which controls printing of output: @@ -437,6 +447,7 @@ (interactive) (eval-buffer (current-buffer) printflag)) +;; XEmacs (defun count-words-buffer (b) (interactive "b") (save-excursion @@ -445,6 +456,7 @@ (message "Buffer has %d words" (count-words-region (point-min) (point-max)))))) +;; XEmacs (defun count-words-region (start end) (interactive "r") (save-excursion @@ -458,12 +470,12 @@ (defun count-lines-region (start end) "Print number of lines and characters in the region." + ;; XEmacs change (interactive "_r") - (let ((n (count-lines start end))) - (message "Region has %d lines, %d characters" - n (- end start)) - n)) + (message "Region has %d lines, %d characters" + (count-lines start end) (- end start))) +;; XEmacs (defun count-lines-buffer (b) "Print number of lines and charcters in the specified buffer." (interactive "_b") @@ -472,12 +484,13 @@ cnt) (set-buffer buf) (setq cnt (count-lines (point-min) (point-max))) - (message "Region has %d lines, %d characters" + (message "Buffer has %d lines, %d characters" cnt (- (point-max) (point-min))) cnt))) (defun what-line () "Print the current buffer line number and narrowed line number of point." + ;; XEmacs change (interactive "_") (let ((opoint (point)) start) (save-excursion @@ -520,6 +533,7 @@ (defun what-cursor-position () "Print info on cursor position (on screen and within buffer)." + ;; XEmacs change (interactive "_") (let* ((char (following-char)) (beg (point-min)) @@ -540,6 +554,7 @@ pos total percent beg end col hscroll) (message "point=%d of %d(%d%%) column %d %s" pos total percent col hscroll)) + ;; XEmacs: don't use single-key-description (if (or (/= beg 1) (/= end (1+ total))) (message "Char: %s (0%o, %d, 0x%x) point=%d of %d(%d%%) <%d - %d> column %d %s" (text-char-description char) char char char pos total @@ -554,16 +569,29 @@ (interactive) (kill-all-local-variables)) +;; XEmacs the following are declared elsewhere +;(defvar read-expression-map (cons 'keymap minibuffer-local-map) +; "Minibuffer keymap used for reading Lisp expressions.") +;(define-key read-expression-map "\M-\t" 'lisp-complete-symbol) + +;(put 'eval-expression 'disabled t) + +;(defvar read-expression-history nil) ;; We define this, rather than making `eval' interactive, ;; for the sake of completion of names like eval-region, eval-current-buffer. (defun eval-expression (expression) "Evaluate EXPRESSION and print value in minibuffer. Value is also consed on to front of the variable `values'." - (interactive "xEval: ") + ;(interactive "xEval: ") + (interactive + (list (read-from-minibuffer "Eval: " + nil read-expression-map t + 'read-expression-history))) (setq values (cons (eval expression) values)) (prin1 (car values) t)) +;; XEmacs -- extra parameter (variant, but equivalent logic) (defun edit-and-eval-command (prompt command &optional history) "Prompting with PROMPT, let user edit COMMAND and eval result. COMMAND is a Lisp expression. Let user edit that expression in @@ -602,11 +630,20 @@ You can use the minibuffer history commands \\\\[next-history-element] and \\[previous-history-element] to get different commands to edit and resubmit." (interactive "p") + ;; XEmacs: It looks like our version is better -sb (let ((print-level nil)) (edit-and-eval-command "Redo: " (or (nth (1- arg) command-history) (error "")) (cons 'command-history arg)))) + +;; XEmacs: Functions moved to minibuf.el +;; previous-matching-history-element +;; next-matching-history-element +;; next-history-element +;; previous-history-element +;; next-complete-history-element +;; previous-complete-history-element (defun goto-line (arg) "Goto line ARG, counting from line 1 at beginning of buffer." @@ -635,7 +672,7 @@ (or (eq (selected-window) (minibuffer-window)) (message "Undo!")) (or (and (eq last-command 'undo) - (eq (current-buffer) last-undo-buffer)) + (eq (current-buffer) last-undo-buffer)) ; XEmacs (progn (undo-start) (undo-more 1))) (undo-more (or arg 1)) @@ -657,7 +694,7 @@ (defvar pending-undo-list nil "Within a run of consecutive undo commands, list remaining to be undone.") -(defvar last-undo-buffer nil) +(defvar last-undo-buffer nil) ; XEmacs (defun undo-start () "Set `pending-undo-list' to the front of the undo list. @@ -673,8 +710,9 @@ (or pending-undo-list (error "No further undo information")) (setq pending-undo-list (primitive-undo count pending-undo-list) - last-undo-buffer (current-buffer))) + last-undo-buffer (current-buffer))) ; XEmacs +;; XEmacs (defun call-with-transparent-undo (fn &rest args) "Apply FN to ARGS, and then undo all changes made by FN to the current buffer. The undo records are processed even if FN returns non-locally. @@ -701,23 +739,31 @@ (while tail (setq tail (primitive-undo (length tail) tail)))))))))) +;; XEmacs: The following are in other files +;; shell-command-history +;; shell-command-switch +;; shell-command +;; shell-command-sentinel + (defconst universal-argument-map (let ((map (make-sparse-keymap))) (set-keymap-default-binding map 'universal-argument-other-key) ;FSFmacs (define-key map [switch-frame] nil) + (define-key map [(t)] 'universal-argument-other-key) + (define-key map [(meta t)] 'universal-argument-other-key) (define-key map [(control u)] 'universal-argument-more) - (define-key map ?- 'universal-argument-minus) - (define-key map ?0 'digit-argument) - (define-key map ?1 'digit-argument) - (define-key map ?2 'digit-argument) - (define-key map ?3 'digit-argument) - (define-key map ?4 'digit-argument) - (define-key map ?5 'digit-argument) - (define-key map ?6 'digit-argument) - (define-key map ?7 'digit-argument) - (define-key map ?8 'digit-argument) - (define-key map ?9 'digit-argument) + (define-key map [?-] 'universal-argument-minus) + (define-key map [?0] 'digit-argument) + (define-key map [?1] 'digit-argument) + (define-key map [?2] 'digit-argument) + (define-key map [?3] 'digit-argument) + (define-key map [?4] 'digit-argument) + (define-key map [?5] 'digit-argument) + (define-key map [?6] 'digit-argument) + (define-key map [?7] 'digit-argument) + (define-key map [?8] 'digit-argument) + (define-key map [?9] 'digit-argument) map) "Keymap used while processing \\[universal-argument].") @@ -735,7 +781,7 @@ multiplies the argument by 4 each time." (interactive) (setq prefix-arg (list 4)) - (setq zmacs-region-stays t) + (setq zmacs-region-stays t) ; XEmacs (setq universal-argument-num-events (length (this-command-keys))) (setq overriding-terminal-local-map universal-argument-map)) @@ -747,7 +793,7 @@ (setq prefix-arg (list (* 4 (car arg)))) (setq prefix-arg arg) (setq overriding-terminal-local-map nil)) - (setq zmacs-region-stays t) + (setq zmacs-region-stays t) ; XEmacs (setq universal-argument-num-events (length (this-command-keys)))) (defun negative-argument (arg) @@ -760,10 +806,11 @@ (setq prefix-arg nil)) (t (setq prefix-arg '-))) - (setq zmacs-region-stays t) + (setq zmacs-region-stays t) ; XEmacs (setq universal-argument-num-events (length (this-command-keys))) (setq overriding-terminal-local-map universal-argument-map)) +;; XEmacs: This function not synched with FSF (defun digit-argument (arg) "Part of the numeric argument for the next command. \\[universal-argument] following digits or minus sign ends the argument." @@ -800,7 +847,7 @@ (defun universal-argument-other-key (arg) (interactive "P") (setq prefix-arg arg) - (setq zmacs-region-stays t) + (setq zmacs-region-stays t) ; XEmacs (let* ((key (this-command-keys)) ;; FSF calls silly function `listify-key-sequence' here. (keylist (append key nil))) @@ -811,6 +858,7 @@ (setq overriding-terminal-local-map nil)) +;; XEmacs -- shouldn't these functions keep the zmacs region active? (defun forward-to-indentation (arg) "Move forward ARG lines and position at first nonblank character." (interactive "p") @@ -840,6 +888,13 @@ (kill-region (point) ;; Don't shift point before doing the delete; that way, ;; undo will record the right position of point. +;; FSF +; ;; It is better to move point to the other end of the kill +; ;; before killing. That way, in a read-only buffer, point +; ;; moves across the text that is copied to the kill ring. +; ;; The choice has no effect on undo now that undo records +; ;; the value of point from before the command was run. +; (progn (save-excursion (if arg (forward-line (prefix-numeric-value arg)) @@ -850,6 +905,7 @@ (end-of-line))) (point)))) +;; XEmacs (defun backward-kill-line nil "Kill back to the beginning of the line." (interactive) @@ -912,12 +968,15 @@ (defvar kill-ring nil "List of killed text sequences. -In order to maintain correct interaction with cut-and-paste facilities -offered by window systems, the functions `kill-new', `kill-append', and -`current-kill' should be used to access the kill ring, instead of using -this variable directly.") +Since the kill ring is supposed to interact nicely with cut-and-paste +facilities offered by window systems, use of this variable should +interact nicely with `interprogram-cut-function' and +`interprogram-paste-function'. The functions `kill-new', +`kill-append', and `current-kill' are supposed to implement this +interaction; you may want to use them instead of manipulating the kill +ring directly.") -(defvar kill-ring-max 30 +(defconst kill-ring-max 30 "*Maximum length of kill ring before oldest elements are thrown away.") (defvar kill-ring-yank-pointer nil @@ -969,6 +1028,10 @@ ;(defvar kill-read-only-ok nil ; "*Non-nil means don't signal an error for killing read-only text.") +;(put 'text-read-only 'error-conditions +; '(text-read-only buffer-read-only error)) +;(put 'text-read-only 'error-message "Text is read-only") + (defun kill-region (beg end &optional verbose) ; verbose is XEmacs addition "Kill between point and mark. The text is deleted but saved in the kill ring. @@ -1005,19 +1068,23 @@ (cond ;; I don't like this large change in behavior -- jwz + ;; Read-Only text means it shouldn't be deleted, so I'm restoring + ;; this code, but only for text-properties and not full extents. -sb ;; If the buffer is read-only, we should beep, in case the person ;; just isn't aware of this. However, there's no harm in putting ;; the region's text in the kill ring, anyway. - ;;((or (and buffer-read-only (not inhibit-read-only)) - ;; (text-property-not-all beg end 'read-only nil)) + ((or (and buffer-read-only (not inhibit-read-only)) + (text-property-not-all beg end 'read-only nil)) + ;; This is redundant. ;; (if verbose (message "Copying %d characters" - ;; (- (max beg end) (min beg end)))) - ;; (copy-region-as-kill beg end) + ;; (- (max beg end) (min beg end)))) + (copy-region-as-kill beg end) ;; ;; This should always barf, and give us the correct error. ;; (if kill-read-only-ok ;; (message "Read only text copied to kill ring") - ;; (setq this-command 'kill-region) - ;; (barf-if-buffer-read-only))) + (setq this-command 'kill-region) + (barf-if-buffer-read-only) + (signal 'text-read-only (list (current-buffer)))) ;; In certain cases, we can arrange for the undo list and the kill ;; ring to share the same string object. This code does that. @@ -1026,6 +1093,7 @@ ;; Use = since positions may be numbers or markers. (= beg end))) ;; Don't let the undo list be truncated before we can even access it. + ;; FSF calls this `undo-strong-limit' (let ((undo-high-threshold (+ (- (max beg end) (min beg end)) 100)) ;(old-list buffer-undo-list) tail) @@ -1033,7 +1101,7 @@ ;; Search back in buffer-undo-list for this string, ;; in case a change hook made property changes. (setq tail buffer-undo-list) - (while (not (stringp (car-safe (car-safe tail)))) + (while (not (stringp (car-safe (car-safe tail)))) ; XEmacs (setq tail (cdr tail))) ;; Take the same string recorded for undo ;; and put it in the kill-ring. @@ -1073,8 +1141,13 @@ (inhibit-quit t)) (if (pos-visible-in-window-p other-end (selected-window)) (progn + ;; FSF (I'm not sure what this does -sb) +; ;; Swap point and mark. +; (set-marker (mark-marker) (point) (current-buffer)) (goto-char other-end) (sit-for 1) +; ;; Swap back. +; (set-marker (mark-marker) other-end (current-buffer)) (goto-char opoint) ;; If user quit, deactivate the mark ;; as C-g would as a command. @@ -1093,6 +1166,7 @@ (defun append-next-kill () "Cause following command, if it kills, to append to previous kill." + ;; XEmacs (interactive "_") (if (interactive-p) (progn @@ -1117,18 +1191,28 @@ (if (not (eq last-command 'yank)) (error "Previous command was not a yank")) (setq this-command 'yank) - (let ((before (< (point) (mark t)))) + (let ((inhibit-read-only t) + (before (< (point) (mark t)))) (delete-region (point) (mark t)) + ;;(set-marker (mark-marker) (point) (current-buffer)) (set-mark (point)) (insert (current-kill arg)) - (if before (exchange-point-and-mark t)))) + (if before + ;; This is like exchange-point-and-mark, but doesn't activate the mark. + ;; It is cleaner to avoid activation, even though the command + ;; loop would deactivate the mark because we inserted text. + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) (current-buffer)))))) + nil) + (defun yank (&optional arg) "Reinsert the last stretch of killed text. More precisely, reinsert the stretch of killed text most recently killed OR yanked. Put point at end, and set mark at beginning. With just C-u as argument, same but put point at beginning (and mark at end). -With argument N, reinsert the Nth most recently killed stretch of killed text. +With argument N, reinsert the Nth most recently killed stretch of killed +text. See also the command \\[yank-pop]." (interactive "*P") ;; If we don't get all the way through, make last-command indicate that @@ -1140,9 +1224,14 @@ ((eq arg '-) -1) (t (1- arg))))) (if (consp arg) - (exchange-point-and-mark t)) - ;; If we do get all the way through, make this-command indicate that. - (setq this-command 'yank)) + ;; This is like exchange-point-and-mark, but doesn't activate the mark. + ;; It is cleaner to avoid activation, even though the command + ;; loop would deactivate the mark because we inserted text. + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) (current-buffer))))) + ;; If we do get all the way thru, make this-command indicate that. + (setq this-command 'yank) + nil) (defun rotate-yank-pointer (arg) "Rotate the yanking point in the kill ring. @@ -1155,11 +1244,14 @@ "Insert after point the contents of BUFFER. Puts mark after the inserted text. BUFFER may be a buffer or a buffer name." - (interactive (list (progn (barf-if-buffer-read-only) - (read-buffer "Insert buffer: " - ;; XEmacs: we have different args - (other-buffer (current-buffer) nil t) - t)))) + (interactive + (list + (progn + (barf-if-buffer-read-only) + (read-buffer "Insert buffer: " + ;; XEmacs: we have different args + (other-buffer (current-buffer) nil t) + t)))) (or (bufferp buffer) (setq buffer (get-buffer buffer))) (let (start end newmark) @@ -1219,7 +1311,8 @@ (insert-buffer-substring oldbuf start end))))) ;FSFmacs -;(define-error 'mark-inactive "The mark is not active now") +;(put 'mark-inactive 'error-conditions '(mark-inactive error)) +;(put 'mark-inactive 'error-message "The mark is not active now") (defun mark (&optional force buffer) "Return this buffer's mark value as integer, or nil if no mark. @@ -1271,13 +1364,25 @@ (setq buffer (decode-buffer buffer)) (set-marker (mark-marker t buffer) pos buffer)) +;; FSF +; (if pos +; (progn +; (setq mark-active t) +; (run-hooks 'activate-mark-hook) +; (set-marker (mark-marker) pos (current-buffer))) +; ;; Normally we never clear mark-active except in Transient Mark mode. +; ;; But when we actually clear out the mark value too, +; ;; we must clear mark-active in any mode. +; (setq mark-active nil) +; (run-hooks 'deactivate-mark-hook) +; (set-marker (mark-marker) nil))) (defvar mark-ring nil "The list of former marks of the current buffer, most recent first.") (make-variable-buffer-local 'mark-ring) (put 'mark-ring 'permanent-local t) -(defvar mark-ring-max 16 +(defconst mark-ring-max 16 "*Maximum size of mark ring. Start discarding off end if gets this big.") (defvar global-mark-ring nil @@ -1289,7 +1394,7 @@ (defun set-mark-command (arg) "Set mark at where point is, or jump to mark. -With no prefix argument, set mark, push old mark position on local mark +With no prefix argument, set mark, push old mark position on local mark ring, and push mark on global mark ring. With argument, jump to mark, and pop a new position for mark off the ring \(does not affect global mark ring\). @@ -1304,6 +1409,7 @@ (goto-char (mark t)) (pop-mark)))) +;; XEmacs: Extra parameter (defun push-mark (&optional location nomsg activate-region buffer) "Set mark at LOCATION (point, by default) and push old mark on mark ring. If the last global mark pushed was not in the current buffer, @@ -1313,8 +1419,8 @@ Novice Emacs Lisp programmers often try to use the mark for the wrong purposes. See the documentation of `set-mark' for more information." - (setq buffer (decode-buffer buffer)) - (if (null (mark t buffer)) + (setq buffer (decode-buffer buffer)) ; XEmacs + (if (null (mark t buffer)) ; XEmacs nil ;; The save-excursion / set-buffer is necessary because mark-ring ;; is a buffer local variable @@ -1326,6 +1432,7 @@ (move-marker (car (nthcdr mark-ring-max mark-ring)) nil buffer) (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))))) (set-mark (or location (point buffer)) buffer) +; (set-marker (mark-marker) (or location (point)) (current-buffer)) ; FSF ;; Now push the mark on the global mark ring. (if (or (null global-mark-ring) (not (eq (marker-buffer (car global-mark-ring)) buffer))) @@ -1344,6 +1451,8 @@ (progn (setq zmacs-region-stays t) (zmacs-activate-region))) +; (if (or activate (not transient-mark-mode)) ; FSF +; (set-mark (mark t))) ; FSF nil) (defun pop-mark () @@ -1367,9 +1476,10 @@ (error "No mark set in this buffer")) (set-mark (point)) (goto-char omark) - (or dont-activate-region (zmacs-activate-region)) + (or dont-activate-region (zmacs-activate-region)) ; XEmacs nil)) +;; XEmacs (defun mark-something (mark-fn movement-fn arg) "internal function used by mark-sexp, mark-word, etc." (let (newmark (pushp t)) @@ -1446,7 +1556,7 @@ If you are thinking of using this in a Lisp program, consider using `forward-line' instead. It is usually easier to use and more reliable (no dependence on goal column, etc.)." - (interactive "_p") + (interactive "_p") ; XEmacs (if (and next-line-add-newlines (= arg 1)) (let ((opoint (point))) (end-of-line) @@ -1474,7 +1584,7 @@ If you are thinking of using this in a Lisp program, consider using `forward-line' with a negative argument instead. It is usually easier to use and more reliable (no dependence on goal column, etc.)." - (interactive "_p") + (interactive "_p") ; XEmacs (if (interactive-p) (condition-case nil (line-move (- arg)) @@ -1482,7 +1592,7 @@ (line-move (- arg))) nil) -(defvar track-eol nil +(defconst track-eol nil "*Non-nil means vertical motion starting at end of line keeps to ends of lines. This means moving to the end of each line moved onto. The beginning of a blank line does not count as the end of a line.") @@ -1556,7 +1666,7 @@ (assq prop buffer-invisibility-spec))))) (if (get-text-property (point) 'invisible) (goto-char (next-single-property-change (point) 'invisible)) - (goto-char (next-extent-change (point))))) + (goto-char (next-extent-change (point))))) ; XEmacs (setq arg (1- arg))) (while (< arg 0) (beginning-of-line) @@ -1571,7 +1681,7 @@ (assq prop buffer-invisibility-spec))))) (if (get-text-property (1- (point)) 'invisible) (goto-char (previous-single-property-change (point) 'invisible)) - (goto-char (previous-extent-change (point))))) + (goto-char (previous-extent-change (point))))) ; XEmacs (setq arg (1+ arg)))) (move-to-column (or goal-column temporary-goal-column))) ;; Remember where we moved to, go back home, @@ -1595,7 +1705,7 @@ With a non-nil argument, clears out the goal column so that \\[next-line] and \\[previous-line] resume vertical motion. The goal column is stored in the variable `goal-column'." - (interactive "_P") + (interactive "_P") ; XEmacs (if arg (progn (setq goal-column nil) @@ -1606,8 +1716,12 @@ goal-column)) nil) - -;;; deleted FSFmacs terminal randomness hscroll-point-visible stuff. +;; deleted FSFmacs terminal randomness hscroll-point-visible stuff. +;; hscroll-step +;; hscroll-point-visible +;; hscroll-window-column +;; right-arrow +;; left-arrow (defun scroll-other-window-down (lines) "Scroll the \"other window\" down. @@ -1619,6 +1733,7 @@ (if (eq lines '-) nil (if (null lines) '- (- (prefix-numeric-value lines)))))) +;(define-key esc-map [?\C-\S-v] 'scroll-other-window-down) (defun beginning-of-buffer-other-window (arg) "Move point to the beginning of the buffer in the other window. @@ -1712,13 +1827,13 @@ (setq end2 (point)) (funcall mover -1) (setq start2 (point)) - (goto-char (mark t)) + (goto-char (mark t)) ; XEmacs (funcall mover 1) (setq end1 (point)) (funcall mover -1) (setq start1 (point)) (transpose-subr-1)) - (exchange-point-and-mark t))) + (exchange-point-and-mark t))) ; XEmacs (while (> arg 0) (funcall mover -1) (setq start1 (point)) @@ -1757,22 +1872,22 @@ (delete-char (length word1)) (insert word2))) -(defvar comment-column 32 +(defconst comment-column 32 "*Column to indent right-margin comments to. Setting this variable automatically makes it local to the current buffer. Each mode establishes a different default value for this variable; you can set the value for a particular mode using that mode's hook.") (make-variable-buffer-local 'comment-column) -(defvar comment-start nil +(defconst comment-start nil "*String to insert to start a new comment, or nil if no comment syntax.") -(defvar comment-start-skip nil +(defconst comment-start-skip nil "*Regexp to match the start of a comment plus everything up to its body. If there are any \\(...\\) pairs, the comment delimiter text is held to begin at the place matched by the close of the first pair.") -(defvar comment-end "" +(defconst comment-end "" "*String to insert to end a new comment. Should be an empty string if comments are terminated by end-of-line.") @@ -1782,7 +1897,7 @@ This function is called with no args with point at the beginning of the comment's starting delimiter.") -(defvar comment-indent-function +(defconst comment-indent-function ;; XEmacs - add at least one space after the end of the text on the ;; current line... #'(lambda () @@ -1985,6 +2100,7 @@ (insert ce))) (search-forward "\n" nil 'move))))))) +;; XEmacs (defun prefix-region (prefix) "Add a prefix string to each line between mark and point." (interactive "sPrefix string: ") @@ -1999,11 +2115,12 @@ (forward-char 1))))) +;; XEmacs - extra parameter (defun backward-word (arg &optional buffer) "Move backward until encountering the end of a word. With argument, do this that many times. In programs, it is faster to call `forward-word' with negative arg." - (interactive "_p") + (interactive "_p") ; XEmacs (forward-word (- arg) buffer)) (defun mark-word (arg) @@ -2011,6 +2128,7 @@ (interactive "p") (mark-something 'mark-word 'forward-word arg)) +;; XEmacs modified (defun kill-word (arg) "Kill characters forward until encountering the end of a word. With argument, do this that many times." @@ -2020,7 +2138,7 @@ (defun backward-kill-word (arg) "Kill characters backward until encountering the end of a word. With argument, do this that many times." - (interactive "*p") + (interactive "*p") ; XEmacs (kill-word (- arg))) (defun current-word (&optional strict) @@ -2061,14 +2179,18 @@ (buffer-substring start end))) (buffer-substring start end))))) -(defvar fill-prefix nil +(defconst fill-prefix nil "*String for filling to insert at front of new line, or nil for none. Setting this variable automatically makes it local to the current buffer.") (make-variable-buffer-local 'fill-prefix) -(defvar auto-fill-inhibit-regexp nil +(defconst auto-fill-inhibit-regexp nil "*Regexp to match lines which should not be auto-filled.") +;; This function is the auto-fill-function of a buffer +;; when Auto-Fill mode is enabled. +;; It returns t if it really did any work. +;; XEmacs: This function is totally different. (defun do-auto-fill () (let (give-up) (or (and auto-fill-inhibit-regexp @@ -2143,6 +2265,143 @@ ;; No place to break => stop trying. (setq give-up t))))))) +;; Put FSF one in until I can one or the other working properly, then the +;; other one is history. +(defun fsf:do-auto-fill () + (let (fc justify bol give-up + (fill-prefix fill-prefix)) + (if (or (not (setq justify (current-justification))) + (null (setq fc (current-fill-column))) + (and (eq justify 'left) + (<= (current-column) fc)) + (save-excursion (beginning-of-line) + (setq bol (point)) + (and auto-fill-inhibit-regexp + (looking-at auto-fill-inhibit-regexp)))) + nil ;; Auto-filling not required + (if (memq justify '(full center right)) + (save-excursion (unjustify-current-line))) + + ;; Choose a fill-prefix automatically. + (if (and adaptive-fill-mode + (or (null fill-prefix) (string= fill-prefix ""))) + (let ((prefix + (fill-context-prefix + (save-excursion (backward-paragraph 1) (point)) + (save-excursion (forward-paragraph 1) (point)) + ;; Don't accept a non-whitespace fill prefix + ;; from the first line of a paragraph. + "^[ \t]*$"))) + (and prefix (not (equal prefix "")) + (setq fill-prefix prefix)))) + + (while (and (not give-up) (> (current-column) fc)) + ;; Determine where to split the line. + (let ((fill-point + (let ((opoint (point)) + bounce + (first t)) + (save-excursion + (move-to-column (1+ fc)) + ;; Move back to a word boundary. + (while (or first + ;; If this is after period and a single space, + ;; move back once more--we don't want to break + ;; the line there and make it look like a + ;; sentence end. + (and (not (bobp)) + (not bounce) + sentence-end-double-space + (save-excursion (forward-char -1) + (and (looking-at "\\. ") + (not (looking-at "\\. ")))))) + (setq first nil) + (skip-chars-backward "^ \t\n") + ;; If we find nowhere on the line to break it, + ;; break after one word. Set bounce to t + ;; so we will not keep going in this while loop. + (if (bolp) + (progn + (re-search-forward "[ \t]" opoint t) + (setq bounce t))) + (skip-chars-backward " \t")) + ;; Let fill-point be set to the place where we end up. + (point))))) + ;; If that place is not the beginning of the line, + ;; break the line there. + (if (save-excursion + (goto-char fill-point) + (not (bolp))) + (let ((prev-column (current-column))) + ;; If point is at the fill-point, do not `save-excursion'. + ;; Otherwise, if a comment prefix or fill-prefix is inserted, + ;; point will end up before it rather than after it. + (if (save-excursion + (skip-chars-backward " \t") + (= (point) fill-point)) + (indent-new-comment-line t) + (save-excursion + (goto-char fill-point) + (indent-new-comment-line t))) + ;; Now do justification, if required + (if (not (eq justify 'left)) + (save-excursion + (end-of-line 0) + (justify-current-line justify nil t))) + ;; If making the new line didn't reduce the hpos of + ;; the end of the line, then give up now; + ;; trying again will not help. + (if (>= (current-column) prev-column) + (setq give-up t))) + ;; No place to break => stop trying. + (setq give-up t)))) + ;; Justify last line. + (justify-current-line justify t t) + t))) + +(defvar normal-auto-fill-function 'do-auto-fill + "The function to use for `auto-fill-function' if Auto Fill mode is turned on. +Some major modes set this.") + +(defun auto-fill-mode (&optional arg) + "Toggle auto-fill mode. +With arg, turn auto-fill mode on if and only if arg is positive. +In Auto-Fill mode, inserting a space at a column beyond `current-fill-column' +automatically breaks the line at a previous space. + +The value of `normal-auto-fill-function' specifies the function to use +for `auto-fill-function' when turning Auto Fill mode on." + (interactive "P") + (prog1 (setq auto-fill-function + (if (if (null arg) + (not auto-fill-function) + (> (prefix-numeric-value arg) 0)) + normal-auto-fill-function + nil)) + (redraw-modeline))) + +;; This holds a document string used to document auto-fill-mode. +(defun auto-fill-function () + "Automatically break line at a previous space, in insertion of text." + nil) + +(defun turn-on-auto-fill () + "Unconditionally turn on Auto Fill mode." + (auto-fill-mode 1)) + +(defun set-fill-column (arg) + "Set `fill-column' to current column, or to argument if given. +The variable `fill-column' has a separate value for each buffer." + (interactive "_P") ; XEmacs + (cond ((integerp arg) + (setq fill-column arg)) + ((consp arg) + (setq fill-column (current-column))) + ;; Disallow missing argument; it's probably a typo for C-x C-f. + (t + (error "set-fill-column requires an explicit argument"))) + (message "fill-column set to %d" fill-column)) + (defvar comment-multi-line t ; XEmacs - this works well with adaptive fill "*Non-nil means \\[indent-new-comment-line] should continue same comment on new line, with no new terminator or starter. @@ -2228,35 +2487,6 @@ (delete-char 1))) (indent-according-to-mode))))) -(defun auto-fill-mode (&optional arg) - "Toggle auto-fill mode. -With arg, turn auto-fill mode on if and only if arg is positive. -In Auto-Fill mode, inserting a space at a column beyond `current-fill-column' -automatically breaks the line at a previous space." - (interactive "P") - (prog1 (setq auto-fill-function - (if (if (null arg) - (not auto-fill-function) - (> (prefix-numeric-value arg) 0)) - 'do-auto-fill - nil)) - (redraw-modeline))) - -;; This holds a document string used to document auto-fill-mode. -(defun auto-fill-function () - "Automatically break line at a previous space, in insertion of text." - nil) - -(defun turn-on-auto-fill () - "Unconditionally turn on Auto Fill mode." - (auto-fill-mode 1)) - -(defun set-fill-column (arg) - "Set `fill-column' to current column, or to argument if given. -The variable `fill-column' has a separate value for each buffer." - (interactive "_P") - (setq fill-column (if (integerp arg) arg (current-column))) - (message "fill-column set to %d" fill-column)) (defun set-selective-display (arg) "Set `selective-display' to ARG; clear it if no arg. @@ -2280,6 +2510,7 @@ (prin1 selective-display t) (princ "." t)) +;; XEmacs (defun nuke-selective-display () "Ensure that the buffer is not in selective-display mode. If `selective-display' is t, then restore the buffer text to it's original @@ -2302,10 +2533,10 @@ (add-hook 'change-major-mode-hook 'nuke-selective-display) -(defvar overwrite-mode-textual (purecopy " Ovwrt") - "The string displayed in the modeline when in overwrite mode.") -(defvar overwrite-mode-binary (purecopy " Bin Ovwrt") - "The string displayed in the modeline when in binary overwrite mode.") +(defconst overwrite-mode-textual (purecopy " Ovwrt") + "The string displayed in the mode line when in overwrite mode.") +(defconst overwrite-mode-binary (purecopy " Bin Ovwrt") + "The string displayed in the mode line when in binary overwrite mode.") (defun overwrite-mode (arg) "Toggle overwrite mode. @@ -2352,7 +2583,7 @@ "Toggle Line Number mode. With arg, turn Line Number mode on iff arg is positive. When Line Number mode is enabled, the line number appears -in the modeline." +in the mode line." (interactive "P") (setq line-number-mode (if (null arg) (not line-number-mode) @@ -2360,13 +2591,13 @@ (redraw-modeline)) (defvar column-number-mode nil - "*Non-nil means display column number in modeline.") + "*Non-nil means display column number in mode line.") (defun column-number-mode (arg) "Toggle Column Number mode. With arg, turn Column Number mode on iff arg is positive. When Column Number mode is enabled, the column number appears -in the modeline." +in the mode line." (interactive "P") (setq column-number-mode (if (null arg) (not column-number-mode) @@ -2377,7 +2608,12 @@ (defvar blink-matching-paren t "*Non-nil means show matching open-paren when close-paren is inserted.") -(defvar blink-matching-paren-distance 12000 +(defvar blink-matching-paren-on-screen t + "*Non-nil means show matching open-paren when it is on screen. +nil means don't show it (but the open-paren can still be shown +when it is off screen.") + +(defconst blink-matching-paren-distance 12000 "*If non-nil, is maximum distance to search for matching open-paren.") (defconst blink-matching-delay 1 @@ -2388,7 +2624,7 @@ (defun blink-matching-open () "Move cursor momentarily to the beginning of the sexp before point." - (interactive "_") + (interactive "_") ; XEmacs (and (> (point) (1+ (point-min))) blink-matching-paren ;; Verify an even number of quoting characters precede the close. @@ -2425,7 +2661,8 @@ (progn (goto-char blinkpos) (if (pos-visible-in-window-p) - (sit-for blink-matching-delay) + (and blink-matching-paren-on-screen + (sit-for blink-matching-delay)) (goto-char blinkpos) (message "Matches %s" @@ -2440,8 +2677,8 @@ (forward-char 1) (skip-chars-forward " \t") (not (eolp))) - (buffer-substring blinkpos - (progn (end-of-line) (point))) + (buffer-substring blinkpos + (progn (end-of-line) (point))) ;; Otherwise show the previous nonblank line, ;; if there is one. (if (save-excursion @@ -2470,6 +2707,11 @@ (eval-when-compile (defvar myhelp)) ; suppress compiler warning +;; XEmacs: Some functions moved to cmdloop.el: +;; keyboard-quit +;; buffer-quit-function +;; keyboard-escape-quit + (defun set-variable (var val) "Set VARIABLE to VALUE. VALUE is a Lisp object. When using this interactively, supply a Lisp expression for VALUE. @@ -2509,6 +2751,7 @@ (eval-minibuffer (format "Set %s to value: " var))))))) (set var val)) +;; XEmacs (defun activate-region () "Activate the region, if `zmacs-regions' is true. Setting `zmacs-regions' to true causes LISPM-style active regions to be used. @@ -2516,6 +2759,7 @@ (interactive) (and zmacs-regions (zmacs-activate-region))) +;; XEmacs (defsubst region-exists-p () "Non-nil iff the region exists. If active regions are in use (i.e. `zmacs-regions' is true), this means that @@ -2525,12 +2769,31 @@ limits of the region." (not (null (mark)))) +;; XEmacs (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." (and zmacs-regions zmacs-region-extent)) +;; A bunch of stuff was moved elsewhere: +;; completion-list-mode-map +;; completion-reference-buffer +;; completion-base-size +;; delete-completion-window +;; previous-completion +;; next-completion +;; choose-completion +;; choose-completion-delete-max-match +;; choose-completion-string +;; completion-list-mode +;; completion-fixup-function +;; completion-setup-function +;; switch-to-completions +;; event stuffs +;; keypad stuffs + +;; The rest of this file is not in Lisp in FSF (defun capitalize-region-or-word (arg) "Capitalize the selected region or the following word (or ARG words)." (interactive "p") @@ -2722,7 +2985,10 @@ ;; need this to terminate the currently-displayed message ;; ("Loading simple ...") -(or (fboundp 'display-message) (send-string-to-terminal "\n")) +(when (and + (not (fboundp 'display-message)) + (not (featurep 'debug))) + (send-string-to-terminal "\n")) (defvar message-stack nil "An alist of label/string pairs representing active echo-area messages. @@ -2846,7 +3112,7 @@ area will be returned, or nil if the message-stack is now empty. If LABEL is nil, the entire message-stack is cleared. -Unless you need the return value or you need to specify a lable, +Unless you need the return value or you need to specify a label, you should just use (message nil)." (or frame (setq frame (selected-frame))) (let ((clear-stream (and message-stack (eq 'stream (frame-type frame))))) @@ -3130,3 +3396,5 @@ (set-marker warning-marker 1 buffer))) (set-window-start (display-buffer buffer) warning-marker) (set-marker warning-marker (point-max buffer) buffer))) + +;;; simple.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/sort.el --- a/lisp/prim/sort.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/sort.el Mon Aug 13 08:46:56 2007 +0200 @@ -20,9 +20,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -74,42 +75,43 @@ (save-excursion (if messages (message "Finding sort keys...")) (let* ((sort-lists (sort-build-lists nextrecfun endrecfun - startkeyfun endkeyfun)) - (old (reverse sort-lists)) + startkeyfun endkeyfun)) + (old (reverse sort-lists)) (case-fold-search sort-fold-case)) - (if (null sort-lists) - () - (or reverse (setq sort-lists (nreverse sort-lists))) - (if messages (message "Sorting records...")) - (setq sort-lists - (if (fboundp 'sortcar) - (sortcar sort-lists - (cond ((numberp (car (car sort-lists))) + (if (null sort-lists) + () + (or reverse (setq sort-lists (nreverse sort-lists))) + (if messages (message "Sorting records...")) + (setq sort-lists + (if (fboundp 'sortcar) + (sortcar sort-lists + (cond ((numberp (car (car sort-lists))) ;; This handles both ints and floats. - '<) - ((consp (car (car sort-lists))) + '<) + ((consp (car (car sort-lists))) (function (lambda (a b) (> 0 (compare-buffer-substrings nil (car a) (cdr a) nil (car b) (cdr b)))))) - (t - 'string<))) - (sort sort-lists - (cond ((numberp (car (car sort-lists))) + (t + 'string<))) + (sort sort-lists + (cond ((numberp (car (car sort-lists))) 'car-less-than-car) - ((consp (car (car sort-lists))) - (function (lambda (a b) - (> 0 (compare-buffer-substrings - nil (car (car a)) (cdr (car a)) - nil (car (car b)) (cdr (car b))))))) - (t - (function - (lambda (a b) - (string< (car a) (car b))))))))) - (if reverse (setq sort-lists (nreverse sort-lists))) - (if messages (message "Reordering buffer...")) - (sort-reorder-buffer sort-lists old))) + ((consp (car (car sort-lists))) + (function + (lambda (a b) + (> 0 (compare-buffer-substrings + nil (car (car a)) (cdr (car a)) + nil (car (car b)) (cdr (car b))))))) + (t + (function + (lambda (a b) + (string< (car a) (car b))))))))) + (if reverse (setq sort-lists (nreverse sort-lists))) + (if messages (message "Reordering buffer...")) + (sort-reorder-buffer sort-lists old))) (if messages (message "Reordering buffer... Done")))) nil) @@ -138,7 +140,7 @@ (let ((start (point))) (funcall (or endkeyfun (prog1 endrecfun (setq done t)))) - (cons start (point)))))) + (cons start (point)))))) ;; Move to end of this record (start of next one, or end of buffer). (cond ((prog1 done (setq done nil))) (endrecfun (funcall endrecfun)) @@ -211,9 +213,10 @@ (narrow-to-region beg end) (goto-char (point-min)) (sort-subr reverse - (function (lambda () - (while (and (not (eobp)) (looking-at paragraph-separate)) - (forward-line 1)))) + (function + (lambda () + (while (and (not (eobp)) (looking-at paragraph-separate)) + (forward-line 1)))) 'forward-paragraph)))) ;;;###autoload @@ -266,6 +269,7 @@ (point)))))) nil)) +;; This function is commented out of 19.34. ;;;###autoload (defun sort-float-fields (field beg end) "Sort lines in region numerically by the ARGth field of each line. @@ -347,7 +351,6 @@ ;; Position at the front of the field ;; even if moving backwards. (skip-chars-backward "^ \t\n"))) - (defvar sort-regexp-fields-regexp) (defvar sort-regexp-record-end) @@ -455,12 +458,12 @@ (setq col-start (min col-beg1 col-end1)) (setq col-end (max col-beg1 col-end1)) (if (search-backward "\t" beg1 t) - (error - "sort-columns does not work with tabs. Use M-x untabify.")) + (error "sort-columns does not work with tabs. Use M-x untabify.")) (if (not (eq system-type 'vax-vms)) ;; Use the sort utility if we can; it is 4 times as fast. (call-process-region beg1 end1 "sort" t t nil (if reverse "-rt\n" "-t\n") + ;; XEmacs (use int-to-string conversion) (concat "+0." (int-to-string col-start)) (concat "-0." (int-to-string col-end))) ;; On VMS, use Emacs's own facilities. diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/subr.el --- a/lisp/prim/subr.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/subr.el Mon Aug 13 08:46:56 2007 +0200 @@ -18,9 +18,17 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34. -;;; Synched up with: FSF 19.30. +;;; Commentary: + +;; There's not a whole lot in common now with the FSF version, +;; be wary when applying differences. I've left in a number of lines +;; of commentary just to give diff(1) something to synch itself with to +;; provide useful context diffs. -sb ;;; Code: @@ -46,11 +54,44 @@ ;; depend on backquote.el. ;; #### - I don't see why. So long as backquote.el doesn't use anything ;; from subr.el, there's no problem with using backquotes here. --Stig - (list 'function (cons 'lambda cdr))) + ;;(list 'function (cons 'lambda cdr))) + `(function (lambda ,@cdr))) + +(defmacro defun-when-void (&rest args) + "Define a function, just like `defun', unless it's already defined. +Used for compatibility among different emacs variants." + `(if (fboundp ',(car args)) + nil + (defun ,@args))) +(defmacro define-function-when-void (&rest args) + "Define a function, just like `define-function', unless it's already defined. +Used for compatibility among different emacs variants." + `(if (fboundp ,(car args)) + nil + (define-function ,@args))) + +;;;; Keymap support. +;; XEmacs: removed to keymap.el + +;;;; The global keymap tree. + +;;; global-map, esc-map, and ctl-x-map have their values set up in +;;; keymap.c; we just give them docstrings here. + +;;;; Event manipulation functions. + +;; The call to `read' is to ensure that the value is computed at load time +;; and not compiled into the .elc file. The value is negative on most +;; machines, but not on all! +;; XEmacs: This stuff is done in C Code. + +;;;; Obsolescent names for functions. +;; XEmacs: not used. + +;; XEmacs: (define-function 'not 'null) -(if (not (fboundp 'numberp)) - (define-function 'numberp 'integerp)) ; different when floats +(define-function-when-void 'numberp 'intergerp) ; different when floats (defun local-variable-if-set-p (sym buffer) "Return t if SYM would be local to BUFFER after it is set. @@ -62,6 +103,8 @@ ;;;; Hook manipulation functions. +;; (defconst run-hooks 'run-hooks ...) + (defun make-local-hook (hook) "Make the hook HOOK local to the current buffer. When a hook is local, its local and global values @@ -80,7 +123,7 @@ buffer. Do not use `make-local-variable' to make a hook variable buffer-local." - (if (local-variable-p hook (current-buffer)) + (if (local-variable-p hook (current-buffer)) ; XEmacs nil (or (boundp hook) (set hook nil)) (make-local-variable hook) @@ -102,7 +145,6 @@ HOOK should be a symbol, and FUNCTION may be any valid function. If HOOK is void, it is first set to nil. If HOOK's value is a single function, it is changed to a list of functions." - ;(interactive "SAdd to hook-var (symbol): \naAdd which function to %s? ") (or (boundp hook) (set hook nil)) (or (default-boundp hook) (set-default hook nil)) ;; If the hook value is a single function, turn it into a list. @@ -112,7 +154,7 @@ (if (or local ;; Detect the case where make-local-variable was used on a hook ;; and do what we used to do. - (and (local-variable-if-set-p hook (current-buffer)) + (and (local-variable-if-set-p hook (current-buffer)) ; XEmacs (not (memq t (symbol-value hook))))) ;; Alter the local value only. (or (if (consp function) @@ -170,6 +212,7 @@ (defun add-to-list (list-var element) "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. +The test for presence of ELEMENT is done with `equal'. If you want to use `add-to-list' on a variable that is not defined until a certain package is loaded, you should put the call to `add-to-list' into a hook function that will be run only after loading the package. @@ -178,6 +221,7 @@ (or (member element (symbol-value list-var)) (set list-var (cons element (symbol-value list-var))))) +;; XEmacs additions ;; called by Fkill_buffer() (defvar kill-buffer-hook nil "Function or functions to be called when a buffer is killed. @@ -193,6 +237,7 @@ (define-function 'rplaca 'setcar) (define-function 'rplacd 'setcdr) +;; XEmacs (defun mapvector (__function __seq) "Apply FUNCTION to each element of SEQ, making a vector of the results. The result is a vector of the same length as SEQ. @@ -209,6 +254,7 @@ ;;;; String functions. +;; XEmacs (defun replace-in-string (str regexp newtext &optional literal) "Replaces all matches in STR for REGEXP with NEWTEXT string. Optional LITERAL non-nil means do a literal replacement. @@ -532,3 +578,5 @@ (define-function 'set-match-data 'store-match-data) (define-function 'send-string-to-terminal 'external-debugging-output) (define-function 'buffer-string 'buffer-substring) + +;;; subr.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/prim/userlock.el --- a/lisp/prim/userlock.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/prim/userlock.el Mon Aug 13 08:46:56 2007 +0200 @@ -19,9 +19,10 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.30. +;;; Synched up with: FSF 19.34. ;;; Commentary: @@ -32,7 +33,7 @@ ;;; Code: -(define-error 'file-locked "File is locked" 'file-error) +(define-error 'file-locked "File is locked" 'file-error) ; XEmacs (defun ask-user-about-lock-minibuf (fn opponent) (save-window-excursion @@ -58,7 +59,7 @@ (ask-user-about-lock-help) (setq answer nil)) ((eq (cdr answer) 'yield) - (signal 'file-locked (list fn opponent))))))) + (signal 'file-locked (list "File is locked" fn opponent))))))) (cdr answer)))) (defun ask-user-about-lock-help () @@ -74,13 +75,13 @@ (set-buffer standard-output) (help-mode)))) -(define-error 'file-supersession "File changed on disk" 'file-error) +(define-error 'file-supersession "File changed on disk" 'file-error) ; XEmacs (defun ask-user-about-supersession-threat-minibuf (fn) (save-window-excursion (let (answer) (while (null answer) - (message "%s changed on disk; really edit the buffer? (y, n or C-h) " + (message "%s changed on disk; really edit the buffer? (y, n, r or C-h) " (file-name-nondirectory fn)) (let ((tem (downcase (let ((cursor-in-echo-area t)) (read-char))))) @@ -90,17 +91,23 @@ (cdr (assoc tem '((?n . yield) (?\C-g . yield) (?y . proceed) + (?r . revert) (?? . help)))))) (cond ((null answer) (beep) - (message "Please type y or n; or ? for help") + (message "Please type y, n or r; or ? for help") (sit-for 3)) ((eq answer 'help) (ask-user-about-supersession-help) (setq answer nil)) + ((eq answer 'revert) + (revert-buffer nil (not (buffer-modified-p))) + ; ask confirmation iff buffer modified + (signal 'file-supersession + (list "File reverted" fn))) ((eq answer 'yield) (signal 'file-supersession - (list fn)))))) + (list "File changed on disk" fn)))))) (message "File on disk now will become a backup file if you save these changes.") (setq buffer-backed-up nil)))) @@ -112,6 +119,8 @@ If you say `y' to go ahead and modify this buffer, you risk ruining the work of whoever rewrote the file. +If you say `r' to revert, the contents of the buffer are refreshed +from the file on disk. If you say `n', the change you started to make will be aborted. Usually, you should type `n' and then `M-x revert-buffer', @@ -119,9 +128,8 @@ (save-excursion (set-buffer standard-output) (help-mode)))) - -;;; dialog-box versions +;;; dialog-box versions [XEmacs] (defun ask-user-about-lock-dbox (fn opponent) (let ((echo-keystrokes 0) @@ -145,7 +153,7 @@ ((and (misc-user-event-p event) (eq (event-object event) 'steal)) (throw 'aual-done t)) ((and (misc-user-event-p event) (eq (event-object event) 'yield)) - (signal 'file-locked (list fn opponent))) + (signal 'file-locked (list "File is locked" fn opponent))) ((button-release-event-p event) ;; don't beep twice nil) (t diff -r 30df88044ec6 -r b82b59fe008d lisp/rmail/rmail-kill.el --- a/lisp/rmail/rmail-kill.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/rmail/rmail-kill.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,3 +1,31 @@ +;;; rmail-kill.el --- Mail filtering for rmail + +;; Copyright status unknown + +;; Author: Unknown +;; Keywords: mail + +;; 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: +;; This is the Original Notice on this file: ;; GNU Emacs and this file "rmail-kill.el", 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 @@ -13,6 +41,7 @@ ;; named COPYING. Among other things, the copyright notice and this ;; notice must be preserved on all copies. +;;; Code: (setq rmail-message-filter 'rmail-maybe-execute-message rmail-mode-hook '((lambda () (define-key rmail-mode-map "e" 'rmail-extract-rejected-message) @@ -123,3 +152,7 @@ (defun read-string-with-default (prompt default) (let ((s (read-string prompt))) (if (string= s "") default s))) + +(provide 'rmail-kill) + +;;; rmail-kill.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/rmail/rmail-xemacs.el --- a/lisp/rmail/rmail-xemacs.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/rmail/rmail-xemacs.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,7 +1,10 @@ -;; Mouse and font support for RMAIL running in Lucid GNU Emacs -;; written by Wilson H. Tien (wtien@urbana.mcd.mot.com); modified by jwz. +;;; rmail-xemacs.el --- Mouse and font support for RMAIL running on XEmacs + ;; Copyright (C) 1992-1993 Free Software Foundation, Inc. +;; Author: Wilson H. Tien +;; Keywords: mail + ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify it @@ -16,10 +19,20 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: -;;; Right button pops up a menu of commands in Rmail and Rmail summary buffers. -;;; Middle button selects indicated mail message in Rmail summary buffer +;; Mouse and font support for RMAIL running in Lucid GNU Emacs +;; written by Wilson H. Tien (wtien@urbana.mcd.mot.com); modified by jwz. + +;; Right button pops up a menu of commands in Rmail and Rmail summary buffers. +;; Middle button selects indicated mail message in Rmail summary buffer + +;;; Code: (defvar rmail-summary-mode-menu '("Rmail Summary Commands" @@ -218,3 +231,5 @@ (provide 'rmail-xemacs) + +;;; rmail-xemacs ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/rmail/rmail.el --- a/lisp/rmail/rmail.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/rmail/rmail.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,7 +1,6 @@ ;;; rmail.el --- main code of "RMAIL" mail reader for Emacs. -;; Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994 -;;; Free Software Foundation, Inc. +;; Copyright (C) 1985,86,87,88,93,94,95,96 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: mail @@ -20,7 +19,8 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. ;;; Code: @@ -54,6 +54,15 @@ ; (expand-file-name "~/RMAIL") ; "") +(defvar rmail-movemail-program nil + "If non-nil, name of program for fetching new mail.") + +(defvar rmail-pop-password nil + "*Password to use when reading mail from a POP server, if required.") + +(defvar rmail-pop-password-required nil + "*Non-nil if a password is required when reading mail using POP.") + ;;;###autoload (defvar rmail-dont-reply-to-names nil "\ *A regexp specifying names to prune of reply to messages. @@ -70,10 +79,30 @@ ;;; XEmacs change: moved rmail-ignored-headers to sendmail.el for the ;;; benefit of automatically generated autoloads. ;;;minimalist FSF version -;(defvar rmail-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^message-id:\\|^summary-line:" "\ +;(defvar rmail-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^x400-originator:\\|^x400-recipients:\\|^x400-received:\\|^x400-mts-identifier:\\|^x400-content-type:\\|^\\(resent-\\|\\)message-id:\\|^summary-line:\\|^resent-date:\\|^nntp-posting-host:" ;*Gubbish headers one would rather not see.") ;;;###autoload +(defvar rmail-displayed-headers nil + "*Regexp to match Header fields that Rmail should display. +If nil, display all header fields except those matched by +`rmail-ignored-headers'.") + +;;;###autoload +(defvar rmail-retry-ignored-headers nil "\ +*Headers that should be stripped when retrying a failed message.") + +;;;###autoload +(defvar rmail-highlighted-headers "^From:\\|^Subject:" "\ +*Regexp to match Header fields that Rmail should normally highlight. +A value of nil means don't highlight. +See also `rmail-highlight-face'.") + +;;;###autoload +(defvar rmail-highlight-face nil "\ +*Face used by Rmail for highlighting headers.") + +;;;###autoload (defvar rmail-delete-after-output nil "\ *Non-nil means automatically delete a message that is copied to a file.") diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/bitmap.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/bitmap.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,279 @@ +;; bitmap.el -- bitmap (xbm) file handler on Mule + +;; Copyright (C) 1992 Electrotechnical Laboratory, JAPAN. +;; Copyright (C) 1996 UENO Hiroshi +;; Copyright (C) 1996 MORIOKA Tomohiko + +;; Author: Ken'ichi HANDA +;; Hiroshi Ueno +;; MORIOKA Tomohiko +;; Version: +;; $Id: bitmap.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: bitmap, xbm, X-Face, Mule + +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;; Code: + +(require 'tl-822) + +(defvar lc-bitmap + (new-private-character-set 2 1 3 0 ?0 0 "BITMAP 8x16" "bitmap") + "Leading character for BITMAP.8x16.") + +(mapcar (lambda (fontset) + (if (= (fontset-pixel-size fontset) 16) + (set-fontset-font + fontset lc-bitmap + "-etl-fixed-medium-r-*--16-*-100-100-m-*-bitmap.8x16-0") + )) + (fontset-list)) + +;; Block (all bits set) character +(defvar bitmap-block (make-character lc-bitmap 32 33)) + +;; Simple examples: +;; (bitmap-compose "00FF00FF00FF00FF00FF00FF00FF00FF") +;; (bitmap-compose +;; "FF00FF00FF00FF00FF00FF00FF00FF00AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA") + +(defun read-hexa (str) + (let ((result 0) (i 0) (max (length str))) + (while (< i max) + (let ((ch (aref str i))) + (cond((and (<= ?0 ch) (<= ch ?9)) + (setq result (+ (* result 16) (- ch ?0)))) + ((and (<= ?a ch) (<= ch ?f)) + (setq result (+ (* result 16) (+ (- ch ?a) 10)))) + ((and (<= ?A ch) (<= ch ?F)) + (setq result (+ (* result 16) (+ (- ch ?A) 10))))) + (setq i (1+ i)))) + result)) + +(defun bitmap-compose (hex) + "Return a string of composite characters which represents BITMAP-PATTERN. +BITMAP-PATTERN is a string of hexa decimal for 8x16 dot-pattern. +For example the pattern \"0081814242242442111124244242818100\" is + for a bitmap of shape something like 'X' character." + (let* ((len (/ (length hex) 2)) + (bytes (char-bytes lc-bitmap)) + (cmpstr "") + (buf (make-string 64 0)) + block-flag i j row code c1 c2) + (setq i 0 j 0 block-flag t) + (while (< i len) + (setq row (read-hexa (substring hex (* i 2) (+ (* i 2) 2)))) + (if block-flag + (setq block-flag (= row 255))) + (if (/= row 0) + (progn + (setq code (+ (* (% i 16) 255) row -1)) + (setq c1 (+ (/ code 96) 33) + c2 (+ (% code 96) 32)) + (sset buf j (make-character lc-bitmap c1 c2)) + (setq j (+ j bytes)))) + (setq i (1+ i)) + (if (or (= (% i 16) 0) (>= i len)) + (setq cmpstr + (concat cmpstr + (if (and block-flag (= j 64)) + (char-to-string bitmap-block) + (if (= j 0) + " " + (compose-string (substring buf 0 j))))) + block-flag t + j 0))) + cmpstr)) + + +;;; @ BDF +;;; + +;; Internal variables -- declared here to reduce garbage collection. +(defconst *hex* (vector (make-string 96 0) (make-string 96 0))) +(defconst *hex-len* (length *hex*)) +(defconst *cmp* (make-vector *hex-len* nil)) + +(defun bdf-to-bitmap (bdf) + "Set *cmp* a vector of string for BDF. +BDF is a vector of string, each elements corresponds to a line of bitmap +of difinition of a character glyph in bdf file." + (let ((width (length (aref bdf 0))) + (height (length bdf)) + i j) + (if (or (/= (/ (+ height 15) 16) *hex-len*) + (/= width (length (aref *hex* 0)))) + (progn + (setq *hex-len* (/ (+ height 15) 16)) + (setq *hex* (make-vector *hex-len* nil)) + (setq *cmp* (make-vector *hex-len* nil)) + (setq i 0) + (while (< i *hex-len*) + (aset *hex* i (make-string 96 0)) + (setq i (1+ i))))) + (setq j 0) + (while (< j width) + (setq i 0) + (while (< i (* *hex-len* 16)) + (aset (aref *hex* (/ i 16)) + (+ (* (/ j 2) 32) (* (% i 16) 2) (% j 2)) + (if (< i height) (aref (aref bdf i) j) 0)) + (setq i (1+ i))) + (setq j (1+ j))) + (setq i 0) + (while (< i *hex-len*) + (aset *cmp* i (bitmap-compose (aref *hex* i))) + (setq i (1+ i))) + *cmp* + )) + + +;;; @ XBM +;;; + +(defun bitmap-show-xbm (buf) + "Show bitmap in buffer BUF. Very slow! [bitmap.el]" + (let ((hexa-string "0123456789ABCDEF") + (reverse-bit '[0 8 4 12 2 10 6 14 1 9 5 13 3 11 7 15]) + i j w h bitmap cmp c temp) + (save-excursion + (set-buffer buf) + (goto-char 1) + (search-forward "width " nil t) + (setq w (read (current-buffer))) + (goto-char 1) + (search-forward "height " nil t) + (setq h (read (current-buffer))) + (search-forward "0x" nil t) + (setq bitmap (make-vector h 0)) + (setq cmp (make-vector (/ (+ h 15) 16) nil)) + (setq j 0) + (setq w (/ (+ w 7) 8)) + (while (< j h) + (aset bitmap j (make-vector w 0)) + (setq j (1+ j))) + (setq j 0) + (message "%dx%d" w h) + (while (< j h) + (setq i 0) + (while (< i w) + (setq temp (buffer-substring (point) (+ (point) 2))) + (aset (aref bitmap j) i temp) + (setq c (read-hexa temp)) + (aset temp 0 (aref hexa-string (aref reverse-bit (% c 16)))) + (aset temp 1 (aref hexa-string (aref reverse-bit (/ c 16)))) + (setq i (1+ i)) + (search-forward "0x" nil t)) + (setq j (1+ j))) + (message "bitmap translating...") + (setq i 0) + (while (< i w) + (setq j 0) + (while (< j h) + (aset cmp (/ j 16) + (concat (aref cmp (/ j 16)) + (aref (aref bitmap j) i))) + (setq j (1+ j))) + (if (> (% h 16) 0) + (aset cmp (/ h 16) + (concat (aref cmp (/ h 16)) + (make-string (* (- 16 (% h 16)) 2) ?0)))) + (setq i (1+ i))) + (message "cmp created")) + (setq j 0) + (while (< j (length cmp)) + (insert (bitmap-compose (aref cmp j)) ?\n) + ;;(insert (aref cmp j) ?\n) + (setq j (1+ j))))) + +(defun bitmap-read-xbm (file) + "Read .xbm file and show the bitmap. +Very slow! [bitmap.el]" + (interactive "fBitmap-file: ") + (bitmap-show-xbm (find-file-noselect (expand-file-name file))) + ) + + +;;; @ X-Face +;;; + +(defvar bitmap-uncompface-program "uncompface") + +(defun bitmap-decode-x-face () + (save-restriction + (rfc822/narrow-to-header) + (goto-char (point-min)) + (if (re-search-forward "^X-Face:[ \t]*" nil t) + (let ((p (match-beginning 0)) + (beg (match-end 0)) + (end (rfc822/field-end)) + (cur-buf (current-buffer)) + ) + (if (< end (point-max)) + (setq end (1+ end)) + ) + (save-restriction + (narrow-to-region p end) + (delete-region p beg) + (call-process-region p (point-max) + bitmap-uncompface-program t t nil) + (let (i k k+6 cmp temp) + (goto-char (point-min)) + (search-forward "0x" nil t) + (setq cmp (make-vector 18 nil)) + (setq i 0) + (while (< i 48) + (setq k (* (/ i 16) 6)) + (setq k+6 (+ k 6)) + (while (< k k+6) + (setq temp (buffer-substring (point) (+ (point) 2))) + (aset cmp k (concat (aref cmp k) temp)) + (setq k (1+ k)) + (setq temp (buffer-substring (+ (point) 2) (+ (point) 4))) + (aset cmp k (concat (aref cmp k) temp)) + (setq k (1+ k)) + (search-forward "0x" nil t) + ) + (setq i (1+ i))) + (delete-region (point-min)(point-max)) + (insert "X-Face: ") + (setq k 0) + (while (< k 6) + (insert (bitmap-compose (aref cmp k))) + (setq k (1+ k)) + ) + (insert ?\n) + (setq i 1) + (while (< i 3) + (insert " ") + (setq k (* i 6) + k+6 (+ k 6)) + (while (< k k+6) + (insert (bitmap-compose (aref cmp k))) + (setq k (1+ k)) + ) + (insert ?\n) + (setq i (1+ i)) + ))))))) + + +;;; @ end +;;; + +(provide 'bitmap) + +;;; bitmap.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/cless.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/cless.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,80 @@ +;;; cless.el --- Common lisp and Emacs Lisp source sharing + +;; Copyright (C) 1996 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Version: +;; $Id: cless.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: common lisp + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, 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. + +;;; Code: + +(require 'cl) + +(defun call-after-loaded (module func &optional hook-name) + "If MODULE is provided, then FUNC is called. +Otherwise func is set to MODULE-load-hook. +If optional argument HOOK-NAME is specified, +it is used as hook to set. [cless.el; imported from tl-misc.el]" + (if (featurep module) + (funcall func) + (progn + (if (null hook-name) + (setq hook-name + (intern (concat (symbol-name module) "-load-hook"))) + ) + (add-hook hook-name func) + ))) + +(defun define-cless-alias (alias func) + (defalias alias func) + (call-after-loaded + 'cl-macs + (` (lambda () + (define-compiler-macro (, alias) (&rest args) + (cons (, (list 'quote func)) args) + )) + )) + ) + +(define-cless-alias 'FLOOR 'floor*) +(define-cless-alias 'CEILING 'ceiling*) +(define-cless-alias 'TRUNCATE 'truncate*) +(define-cless-alias 'ROUND 'round*) +(define-cless-alias 'MOD 'mod*) + +(define-cless-alias 'DELETE 'delete*) +(define-cless-alias 'SORT 'sort*) +(define-cless-alias 'MEMBER 'member*) +(define-cless-alias 'ASSOC 'assoc*) +(define-cless-alias 'RASSOC 'rassoc*) + +(define-cless-alias 'MAPCAR 'mapcar*) + +(define-cless-alias 'DEFUN 'defun*) + + + +;;; @ end +;;; + +(provide 'cless) + +;;; cless.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/emu-e19.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/emu-e19.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,271 @@ +;;; emu-e19.el --- emu module for Emacs 19 and XEmacs 19 + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Id: emu-e19.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: emulation, compatibility, mule, Latin-1 + +;; 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 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: + +;;; @ version and variant specific features +;;; + +(cond (running-xemacs + (require 'emu-xemacs)) + (running-emacs-19 + (require 'emu-19) + )) + + +;;; @ character set +;;; + +(defconst charset-ascii 0 "Character set of ASCII") +(defconst charset-latin-1 129 "Character set of ISO-8859-1") + +(defun charset-description (charset) + "Return description of CHARSET. [emu-e19.el]" + (if (< charset 128) + (documentation-property 'charset-ascii 'variable-documentation) + (documentation-property 'charset-latin-1 'variable-documentation) + )) + +(defun charset-registry (charset) + "Return registry name of CHARSET. [emu-e19.el]" + (if (< charset 128) + "ASCII" + "ISO8859-1")) + +(defun charset-columns (charset) + "Return number of columns a CHARSET occupies when displayed. +\[emu-e19.el]" + 1) + +(defun charset-direction (charset) + "Return the direction of a character of CHARSET by + 0 (left-to-right) or 1 (right-to-left). [emu-e19.el]" + 0) + +(defun find-charset-string (str) + "Return a list of charsets in the string. +\[emu-e19.el; Mule emulating function]" + (if (string-match "[\200-\377]" str) + (list lc-ltn1) + )) + +(defalias 'find-non-ascii-charset-string 'find-charset-string) + +(defun find-charset-region (start end) + "Return a list of charsets in the region between START and END. +\[emu-e19.el; Mule emulating function]" + (if (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (re-search-forward "[\200-\377]" nil t) + )) + (list lc-ltn1) + )) + +(defalias 'find-non-ascii-charset-region 'find-charset-region) + +;;; @@ for old MULE emulation +;;; + +(defconst lc-ascii 0) +(defconst lc-ltn1 129) + + +;;; @ coding-system +;;; + +(defconst *internal* nil) +(defconst *ctext* nil) +(defconst *noconv* nil) + +(defun decode-coding-string (string coding-system) + "Decode the STRING which is encoded in CODING-SYSTEM. +\[emu-e19.el; Emacs 20 emulating function]" + string) + +(defun encode-coding-string (string coding-system) + "Encode the STRING as CODING-SYSTEM. +\[emu-e19.el; Emacs 20 emulating function]" + string) + +(defun decode-coding-region (start end coding-system) + "Decode the text between START and END which is encoded in CODING-SYSTEM. +\[emu-e19.el; Emacs 20 emulating function]" + 0) + +(defun encode-coding-region (start end coding-system) + "Encode the text between START and END to CODING-SYSTEM. +\[emu-e19.el; Emacs 20 emulating function]" + 0) + +(defun detect-coding-region (start end) + "Detect coding-system of the text in the region between START and END. +\[emu-e19.el; Emacs 20 emulating function]" + ) + +(defun set-buffer-file-coding-system (coding-system &optional force) + "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM. +\[emu-e19.el; Emacs 20 emulating function]" + ) + +(defmacro as-binary-process (&rest body) + (` (let (selective-display) ; Disable ^M to nl translation. + (,@ body) + ))) + +(defmacro as-binary-input-file (&rest body) + (` (let ((emx-binary-mode t)) ; Stop CRLF to LF conversion in OS/2 + (,@ body) + ))) + + +;;; @@ for old MULE emulation +;;; + +(defun code-convert-string (str ic oc) + "Convert code in STRING from SOURCE code to TARGET code, +On successful converion, returns the result string, +else returns nil. [emu-e19.el; old MULE emulating function]" + str) + +(defun code-convert-region (beg end ic oc) + "Convert code of the text between BEGIN and END from SOURCE +to TARGET. On successful conversion returns t, +else returns nil. [emu-e19.el; old MULE emulating function]" + t) + + +;;; @ MIME charset +;;; + +(defvar charsets-mime-charset-alist + (list (cons (list charset-ascii) 'us-ascii))) + +(defvar default-mime-charset 'iso-8859-1) + +(defun mime-charset-to-coding-system (charset) + (if (stringp charset) + (setq charset (intern (downcase charset))) + ) + (and (memq charset (list 'us-ascii default-mime-charset)) + charset) + ) + +(defun detect-mime-charset-region (start end) + "Return MIME charset for region between START and END. +\[emu-e19.el]" + (if (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (re-search-forward "[\200-\377]" nil t) + )) + default-mime-charset + 'us-ascii)) + +(defun encode-mime-charset-region (start end charset) + "Encode the text between START and END as MIME CHARSET. +\[emu-e19.el]" + ) + +(defun decode-mime-charset-region (start end charset) + "Decode the text between START and END as MIME CHARSET. +\[emu-e19.el]" + ) + +(defun encode-mime-charset-string (string charset) + "Encode the STRING as MIME CHARSET. [emu-e19.el]" + string) + +(defun decode-mime-charset-string (string charset) + "Decode the STRING as MIME CHARSET. [emu-e19.el]" + string) + + +;;; @ character +;;; + +(defun char-charset (chr) + "Return the character set of char CHR. +\[emu-e19.el; XEmacs 20 emulating function]" + (if (< chr 128) + charset-ascii + charset-latin-1)) + +(defun char-bytes (char) + "Return number of bytes a character in CHAR occupies in a buffer. +\[emu-e19.el; MULE emulating function]" + 1) + +(defalias 'char-length 'char-bytes) + +(defun char-columns (character) + "Return number of columns a CHARACTER occupies when displayed. +\[emu-e19.el]" + 1) + +;;; @@ for old MULE emulation +;;; + +(defalias 'char-width 'char-columns) + +(defalias 'char-leading-char 'char-charset) + + +;;; @ string +;;; + +(defalias 'string-columns 'length) + +(defun string-to-char-list (str) + (mapcar (function identity) str) + ) + +(defalias 'string-to-int-list 'string-to-char-list) + +(defalias 'sref 'aref) + +(defun truncate-string (str width &optional start-column) + "Truncate STR to fit in WIDTH columns. +Optional non-nil arg START-COLUMN specifies the starting column. +\[emu-e19.el; MULE 2.3 emulating function]" + (or start-column + (setq start-column 0)) + (substring str start-column width) + ) + +;;; @@ for old MULE emulation +;;; + +(defalias 'string-width 'length) + + +;;; @ end +;;; + +(provide 'emu-e19) + +;;; emu-e19.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/emu-orig.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/emu-orig.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,130 @@ +;;; +;;; emu-orig.el --- Mule 2 emulation module for Original Emacs and XEmacs +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Version: +;;; $Id: emu-orig.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; Keywords: emulation, compatibility, Mule +;;; +;;; 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. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +;;; @ leading-char +;;; + +(defconst lc-ascii 0) +(defconst lc-ltn1 129) + +(defun char-leading-char (chr) + "Return leading character of CHAR. +\[emu-orig.el; Mule emulating function]" + (if (< chr 128) + lc-ascii + lc-ltn1)) + +(defalias 'get-lc 'char-leading-char) + +(defun find-charset-string (str) + "Return a list of leading-chars in the string. +\[emu-orig.el; Mule emulating function]" + (if (string-match "[\200-\377]" str) + (list lc-ltn1) + )) + +(defun find-charset-region (start end) + "Return a list of leading-chars in the region between START and END. +\[emu-orig.el; Mule emulating function]" + (if (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (re-search-forward "[\200-\377]" nil t) + )) + (list lc-ltn1) + )) + + +;;; @ coding-system +;;; + +(defconst *internal* nil) +(defconst *ctext* nil) +(defconst *noconv* nil) + +(defun code-convert-string (str ic oc) + "Convert code in STRING from SOURCE code to TARGET code, +On successful converion, returns the result string, +else returns nil. [emu-orig.el; Mule emulating function]" + str) + +(defun code-convert-region (beg end ic oc) + "Convert code of the text between BEGIN and END from SOURCE +to TARGET. On successful conversion returns t, +else returns nil. [emu-orig.el; Mule emulating function]" + t) + +(defun code-detect-region (beg end) + "Detect coding-system of the text in the region between START and END. +\[emu-orig.el; Mule emulating function]" + ) + +(defun set-file-coding-system (coding-system &optional force) + ) + + +;;; @ character and string +;;; + +(defun char-bytes (chr) 1) +(defun char-width (chr) 1) + +(defalias 'string-width 'length) + +(defun string-to-char-list (str) + (mapcar (function identity) str) + ) + +(defun truncate-string (str width &optional start-column) + "Truncate STR to fit in WIDTH columns. +Optional non-nil arg START-COLUMN specifies the starting column. +\[emu-orig.el; Mule 2.3 emulating function]" + (or start-column + (setq start-column 0)) + (substring str start-column width) + ) + + +;;; @ etc +;;; + +(cond (running-xemacs + (require 'emu-xemacs)) + (running-emacs-19 + (require 'emu-19) + )) + + +;;; @ end +;;; + +(provide 'emu-orig) + +;;; emu-orig.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/emu-x20.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/emu-x20.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,158 @@ +;;; +;;; emu-x20.el --- Mule 2 emulation module for XEmacs 20 with Mule +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Version: +;;; $Id: emu-x20.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; Keywords: emulation, compatibility, Mule, XEmacs +;;; +;;; 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. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(defvar xemacs-beta-version + (if (string-match "(beta\\([0-9]+\\))" emacs-version) + (string-to-number + (substring emacs-version (match-beginning 1)(match-end 1)) + ))) + + +;;; @ character set +;;; + +(defalias 'char-leading-char 'char-charset) + +(defun find-charset-string (string) + "Return a list of charsets in the STRING except ascii. +\[emu-x20.el; Mule emulating function]" + (delq 'ascii (charsets-in-string string)) + ) + +(defun find-charset-region (start end) + "Return a list of charsets except ascii +in the region between START and END. +\[emu-x20.el; Mule emulating function]" + (delq 'ascii (charsets-in-region start end)) + ) + +(defconst lc-ascii 'ascii) +(defconst lc-ltn1 'latin-1) +(defconst lc-ltn2 'latin-2) +(defconst lc-ltn3 'latin-3) +(defconst lc-ltn4 'latin-4) +(defconst lc-crl 'cyrillic) +(defconst lc-arb 'arabic) +(defconst lc-grk 'greek) +(defconst lc-hbw 'hebrew) +(defconst lc-ltn5 'latin-5) +(defconst lc-jp 'japanese) +(defconst lc-jp2 'japanese-2) +(defconst lc-kr 'korean) +(defconst lc-big5-1 'chinese-big5-1) +(defconst lc-big5-2 'chinese-big5-2) +(defconst lc-cn 'chinese-gb) +(defconst lc-cns1 'chinese-cns-1) +(defconst lc-cns2 'chinese-cns-2) +(defconst lc-cns3 'chinese-cns-3) +(defconst lc-cns4 'chinese-cns-4) +(defconst lc-cns5 'chinese-cns-5) +(defconst lc-cns6 'chinese-cns-6) +(defconst lc-cns7 'chinese-cns-7) + + +;;; @ coding-system +;;; + +(defconst *noconv* 'noconv) +(defconst *ctext* 'ctext) +(defconst *hz* 'hz) +(defconst *big5* 'big5) +(defconst *euc-kr* 'euc-kr) +(defconst *koi8* nil) + +(defvar code-converter-is-broken + (and xemacs-beta-version (<= xemacs-beta-version 18))) + +(if code-converter-is-broken +(progn +;;; +(defun decode-coding-region (start end coding-system &optional buffer) + "Decode the text between START and END which is encoded in CODING-SYSTEM. +\[emu-x20.el; XEmacs 20 emulating function]" + (save-excursion + (if buffer + (set-buffer buffer) + ) + (save-restriction + (narrow-to-region start end) + (let ((process-output-coding-system 'noconv) + (process-input-coding-system coding-system)) + (call-process-region start end "cat" t t nil) + )))) + +(defun encode-coding-region (start end coding-system &optional buffer) + "Encode the text between START and END which is encoded in CODING-SYSTEM. +\[emu-x20.el; XEmacs 20 emulating function]" + (save-excursion + (if buffer + (set-buffer buffer) + ) + (save-restriction + (narrow-to-region start end) + (let ((process-output-coding-system coding-system) + (process-input-coding-system 'noconv)) + (call-process-region start end "cat" t t nil) + )))) +;;; +)) + + +;;; @ character and string +;;; + +(defun char-bytes (chr) 1) +(defun char-width (chr) 1) + +(defalias 'string-width 'length) + +(defalias 'sref 'aref) + +(defun truncate-string (str width &optional start-column) + "Truncate STR to fit in WIDTH columns. +Optional non-nil arg START-COLUMN specifies the starting column. +\[emu-x20.el; Mule 2.3 emulating function]" + (or start-column + (setq start-column 0)) + (substring str start-column width) + ) + + +;;; @ etc +;;; + +(require 'emu-xemacs) + + +;;; @ end +;;; + +(provide 'emu-x20) + +;;; emu-x20.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/emu-xemacs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/emu-xemacs.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,149 @@ +;;; emu-xemacs.el --- Emacs 19 emulation module for XEmacs + +;; Copyright (C) 1995 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Version: +;; $Id: emu-xemacs.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: emulation, compatibility, XEmacs + +;; 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. + +;;; Code: + +;;; @ text property +;;; + +(or (fboundp 'face-list) + (defalias 'face-list 'list-faces) + ) + +(or (memq 'underline (face-list)) + (and (fboundp 'make-face) + (make-face 'underline) + )) + +(or (face-differs-from-default-p 'underline) + (set-face-underline-p 'underline t)) + +(or (fboundp 'tl:set-text-properties) + (defun tl:set-text-properties (start end props &optional buffer) + (if (or (null buffer) (bufferp buffer)) + (if props + (while props + (put-text-property + start end (car props) (nth 1 props) buffer) + (setq props (nthcdr 2 props))) + (remove-text-properties start end ()) + ))) + ) + +(defun tl:add-text-properties (start end properties) + (add-text-properties start end + (append properties (list 'highlight t)) + ) + ) + +(defalias 'tl:make-overlay 'make-extent) +(defalias 'tl:overlay-put 'set-extent-property) +(defalias 'tl:overlay-buffer 'extent-buffer) + +(defun tl:move-overlay (extent start end &optional buffer) + (set-extent-endpoints extent start end) + ) + + +;;; @@ visible/invisible +;;; + +(defmacro enable-invisible ()) + +(defmacro end-of-invisible ()) + +(defun invisible-region (start end) + (if (save-excursion + (goto-char start) + (eq (following-char) ?\n) + ) + (setq start (1+ start)) + ) + (put-text-property start end 'invisible t) + ) + +(defun visible-region (start end) + (put-text-property start end 'invisible nil) + ) + +(defun invisible-p (pos) + (if (save-excursion + (goto-char pos) + (eq (following-char) ?\n) + ) + (setq pos (1+ pos)) + ) + (get-text-property pos 'invisible) + ) + +(defun next-visible-point (pos) + (save-excursion + (if (save-excursion + (goto-char pos) + (eq (following-char) ?\n) + ) + (setq pos (1+ pos)) + ) + (or (next-single-property-change pos 'invisible) + (point-max)) + )) + + +;;; @ mouse +;;; + +(defvar mouse-button-1 'button1) +(defvar mouse-button-2 'button2) +(defvar mouse-button-3 'button3) + + +;;; @ dired +;;; + +(or (fboundp 'dired-other-frame) + (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)) + ) + ) + + +;;; @ string +;;; + +(defmacro char-list-to-string (char-list) + "Convert list of character CHAR-LIST to string. [emu-xemacs.el]" + `(mapconcat #'char-to-string ,char-list "")) + + +;;; @ end +;;; + +(provide 'emu-xemacs) + +;;; emu-xemacs.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/emu.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/emu.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,274 @@ +;;; emu.el --- Emulation module for each Emacs variants + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Id: emu.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: emulation, compatibility, NEmacs, MULE, XEmacs + +;; 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 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: + +(or (boundp 'emacs-major-version) + (defconst emacs-major-version (string-to-int emacs-version))) +(or (boundp 'emacs-minor-version) + (defconst emacs-minor-version + (string-to-int + (substring + emacs-version + (string-match (format "%d\\." emacs-major-version) emacs-version) + )))) + +(defvar running-emacs-18 (<= emacs-major-version 18)) +(defvar running-xemacs (string-match "XEmacs" emacs-version)) + +(defvar running-mule-merged-emacs (and (not (boundp 'MULE)) + (not running-xemacs) (featurep 'mule))) +(defvar running-xemacs-with-mule (and running-xemacs (featurep 'mule))) + +(defvar running-emacs-19 (and (not running-xemacs) (= emacs-major-version 19))) +(defvar running-emacs-19_29-or-later + (or (and running-emacs-19 (>= emacs-minor-version 29)) + (and (not running-xemacs)(>= emacs-major-version 20)))) + +(defvar running-xemacs-19 (and running-xemacs + (= emacs-major-version 19))) +(defvar running-xemacs-20-or-later (and running-xemacs + (>= emacs-major-version 20))) +(defvar running-xemacs-19_14-or-later + (or (and running-xemacs-19 (>= emacs-minor-version 14)) + running-xemacs-20-or-later)) + +(cond (running-mule-merged-emacs + ;; for mule merged EMACS + (require 'emu-e20) + ) + (running-xemacs-with-mule + ;; for XEmacs/mule + (require 'emu-x20) + ) + ((boundp 'MULE) + ;; for MULE 1.* and 2.* + (require 'emu-mule) + ) + ((boundp 'NEMACS) + ;; for NEmacs and NEpoch + (require 'emu-nemacs) + ) + (t + ;; for EMACS 19 and XEmacs 19 (without mule) + (require 'emu-e19) + )) + + +;;; @ binary access +;;; + +(defun insert-binary-file-contents-literally + (filename &optional visit beg end replace) + "Like `insert-file-contents-literally', q.v., but don't code conversion. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place. +\[emu.el]" + (as-binary-input-file + (insert-file-contents-literally filename visit beg end replace) + )) + + +;;; @ MIME charset +;;; + +(defun charsets-to-mime-charset (charsets) + "Return MIME charset from list of charset CHARSETS. +This function refers variable `charsets-mime-charset-alist' +and `default-mime-charset'. [emu.el]" + (if charsets + (or (catch 'tag + (let ((rest charsets-mime-charset-alist) + cell csl) + (while (setq cell (car rest)) + (if (catch 'not-subset + (let ((set1 charsets) + (set2 (car cell)) + obj) + (while set1 + (setq obj (car set1)) + (or (memq obj set2) + (throw 'not-subset nil) + ) + (setq set1 (cdr set1)) + ) + t)) + (throw 'tag (cdr cell)) + ) + (setq rest (cdr rest)) + ))) + default-mime-charset))) + + +;;; @ EMACS 19.29 emulation +;;; + +(defvar path-separator ":" + "Character used to separate concatenated paths.") + +(or (fboundp 'buffer-substring-no-properties) + (defun buffer-substring-no-properties (beg end) + "Return the text from BEG to END, without text properties, as a string. +\[emu.el; EMACS 19.29 emulating function]" + (let ((string (buffer-substring beg end))) + (tl:set-text-properties 0 (length string) nil string) + string)) + ) + +(or running-emacs-19_29-or-later + running-xemacs + ;; for Emacs 19.28 or earlier + (fboundp 'si:read-string) + (progn + (fset 'si:read-string (symbol-function 'read-string)) + + (defun read-string (prompt &optional initial-input history) + "Read a string from the minibuffer, prompting with string PROMPT. +If non-nil, second arg INITIAL-INPUT is a string to insert before reading. +The third arg HISTORY, is dummy for compatibility. [emu.el] +See `read-from-minibuffer' for details of HISTORY argument." + (si:read-string prompt initial-input) + ) + )) + +(or (fboundp 'add-to-list) + ;; This function was imported Emacs 19.30. + (defun add-to-list (list-var element) + "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. +If you want to use `add-to-list' on a variable that is not defined +until a certain package is loaded, you should put the call to `add-to-list' +into a hook function that will be run only after loading the package. +\[emu.el; EMACS 19.30 emulating function]" + (or (member element (symbol-value list-var)) + (set list-var (cons element (symbol-value list-var))))) + ) + + +;;; @ EMACS 19.30 emulation +;;; + +(cond ((fboundp 'insert-file-contents-literally) + ) + ((boundp 'file-name-handler-alist) + (defun insert-file-contents-literally + (filename &optional visit beg end replace) + "Like `insert-file-contents', q.v., but only reads in the file. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place. +\[emu.el; Emacs 19.30 emulating function]" + (let (file-name-handler-alist) + (insert-file-contents filename visit beg end replace) + )) + ) + (t + (defalias 'insert-file-contents-literally 'insert-file-contents) + )) + + +;;; @ EMACS 19.31 emulation +;;; + +(or (fboundp 'buffer-live-p) + (defun buffer-live-p (object) + "Return non-nil if OBJECT is a buffer which has not been killed. +Value is nil if OBJECT is not a buffer or if it has been killed. +\[emu.el; EMACS 19.31 emulating function]" + (and object + (get-buffer object) + (buffer-name (get-buffer object)) + )) + ) + +(or (fboundp 'save-selected-window) + ;; This function was imported Emacs 19.33. + (defmacro save-selected-window (&rest body) + "Execute BODY, then select the window that was selected before BODY. +\[emu.el; EMACS 19.31 emulating function]" + (list 'let + '((save-selected-window-window (selected-window))) + (list 'unwind-protect + (cons 'progn body) + (list 'select-window 'save-selected-window-window)))) + ) + + +;;; @ XEmacs emulation +;;; + +(or (fboundp 'functionp) + (defun functionp (obj) + "Returns t if OBJ is a function, nil otherwise. +\[emu.el; XEmacs emulating function]" + (or (subrp obj) + (byte-code-function-p obj) + (and (symbolp obj)(fboundp obj)) + (and (consp obj)(eq (car obj) 'lambda)) + )) + ) + + +;;; @ for XEmacs 20 +;;; + +(or (fboundp 'char-int) + (fset 'char-int (symbol-function 'identity)) + ) +(or (fboundp 'int-char) + (fset 'int-char (symbol-function 'identity)) + ) + + +;;; @ for text/richtext and text/enriched +;;; + +(cond ((or running-emacs-19_29-or-later running-xemacs-19_14-or-later) + ;; have enriched.el + (autoload 'richtext-decode "richtext") + (or (assq 'text/richtext format-alist) + (setq format-alist + (cons + (cons 'text/richtext + '("Extended MIME text/richtext format." + "Content-[Tt]ype:[ \t]*text/richtext" + richtext-decode richtext-encode t enriched-mode)) + format-alist))) + ) + (t + ;; don't have enriched.el + (autoload 'richtext-decode "tinyrich") + (autoload 'enriched-decode "tinyrich") + )) + + +;;; @ end +;;; + +(provide 'emu) + +;;; emu.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/file-detect.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/file-detect.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,140 @@ +;;; file-detect.el --- Emacs Lisp file detection utility + +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: +;; $Id: file-detect.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: install, module + +;; 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. + +;;; Code: + +(defvar default-load-path load-path) + +(defun add-path (path &rest options) + "Add PATH to `load-path' if it exists under `default-load-path' +directories and it does not exist in `load-path'. + +You can use following PATH styles: + load-path relative: \"PATH/\" + (it is searched from `defaul-load-path') + home directory relative: \"~/PATH/\" \"~USER/PATH/\" + absolute path: \"/HOO/BAR/BAZ/\" + +You can specify following OPTIONS: + 'all-paths search from `load-path' + instead of `default-load-path' + 'append add PATH to the last of `load-path' + +\[file-detect.el]" + (let ((rest (if (memq 'all-paths options) + load-path + default-load-path)) + p) + (if (and (catch 'tag + (while rest + (setq p (expand-file-name path (car rest))) + (if (file-directory-p p) + (throw 'tag p) + ) + (setq rest (cdr rest)) + )) + (not (member p load-path)) + ) + (setq load-path + (if (memq 'append options) + (append load-path (list p)) + (cons p load-path) + )) + ))) + +(defun get-latest-path (pat &optional all-paths) + "Return latest directory in default-load-path +which is matched to regexp PAT. +If optional argument ALL-PATHS is specified, +it is searched from all of load-path instead of default-load-path. +\[file-detect.el]" + (catch 'tag + (let ((paths (if all-paths + load-path + default-load-path)) + dir) + (while (setq dir (car paths)) + (let ((files (sort (directory-files dir t pat t) + (function file-newer-than-file-p))) + file) + (while (setq file (car files)) + (if (file-directory-p file) + (throw 'tag file) + ) + (setq files (cdr files)) + )) + (setq paths (cdr paths)) + )))) + +(defun file-installed-p (file &optional paths) + "Return t if FILE exists in PATHS. +If PATHS is omitted, `load-path' is used. [file-detect.el]" + (if (null paths) + (setq paths load-path) + ) + (catch 'tag + (let (path) + (while paths + (setq path (expand-file-name file (car paths))) + (if (file-exists-p path) + (throw 'tag path) + ) + (setq paths (cdr paths)) + )))) + +(defun module-installed-p (module &optional paths) + "Return t if module is provided or exists in PATHS. +If PATHS is omitted, `load-path' is used. [file-detect.el]" + (or (featurep module) + (let ((name (symbol-name module))) + (if (null paths) + (setq paths load-path) + ) + (catch 'tag + (while paths + (let ((file (expand-file-name name (car paths)))) + (let ((elc-file (concat file ".elc"))) + (if (file-exists-p elc-file) + (throw 'tag elc-file) + )) + (let ((el-file (concat file ".el"))) + (if (file-exists-p el-file) + (throw 'tag el-file) + )) + (if (file-exists-p file) + (throw 'tag file) + ) + ) + (setq paths (cdr paths)) + ))))) + + +;;; @ end +;;; + +(provide 'file-detect) + +;;; file-detect.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/mime-setup.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/mime-setup.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,189 @@ +;;; mime-setup.el --- setup file for tm viewer and composer. + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: +;; $Id: mime-setup.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + + +(require 'tl-misc) + +(defvar mime-viewer/external-progs + (expand-file-name "lib-src" data-directory)) +(require 'tm-setup) + +(autoload 'mime/editor-mode "tm-edit" + "Minor mode for editing MIME message." t) +(autoload 'mime/decode-message-header "tm-ew-d" + "Decode MIME encoded-words in message header." t) + +(defun mime-setup-decode-message-header () + (save-excursion + (save-restriction + (goto-char (point-min)) + (narrow-to-region + (point-min) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (match-beginning 0) + (point-max) + )) + (mime/decode-message-header) + (set-buffer-modified-p nil) + ))) + +(add-hook 'mime/editor-mode-hook 'mime-setup-decode-message-header) + + +;;; @ variables +;;; + +(defvar mime-setup-use-sc nil + "If it is not nil, mime-setup requires sc-setup. [mime-setup.el]") + +(defvar mime-setup-use-signature t + "If it is not nil, mime-setup sets up to use signature.el. +\[mime-setup.el]") + +(defvar mime-setup-default-signature-key "\C-c\C-s" + "*Key to insert signature. [mime-setup.el]") + +(defvar mime-setup-signature-key-alist '((mail-mode . "\C-c\C-w")) + "Alist of major-mode vs. key to insert signature. [mime-setup.el]") + + +;;; @ for signature +;;; + +(defun mime-setup-set-signature-key () + (let ((key (or (cdr (assq major-mode mime-setup-signature-key-alist)) + mime-setup-default-signature-key))) + (define-key (current-local-map) key (function insert-signature)) + )) + +(if mime-setup-use-signature + (progn + (autoload 'insert-signature "signature" "Insert signature" t) + (add-hook 'mime/editor-mode-hook 'mime-setup-set-signature-key) + (setq gnus-signature-file nil) + (setq mail-signature nil) + (setq message-signature nil) + )) + + +;;; @ about SuperCite +;;; + +(if mime-setup-use-sc + (require 'sc-setup) + ) + + +;;; @ for mu-cite +;;; + +(add-hook 'mu-cite/pre-cite-hook 'mime/decode-message-header) + + +;;; @ for RMAIL and VM +;;; + +(add-hook 'mail-setup-hook 'mime/decode-message-header) +(add-hook 'mail-setup-hook 'mime/editor-mode 'append) +(add-hook 'mail-send-hook 'mime-editor/maybe-translate) + + +;;; @ for mh-e +;;; + +(defun mime-setup-mh-draft-setting () + (mime/editor-mode) + (make-local-variable 'mail-header-separator) + (setq mail-header-separator "--------") + (save-excursion + (goto-char (point-min)) + (setq buffer-read-only nil) + (if (re-search-forward "^-*$" nil t) + (progn + (replace-match mail-header-separator) + (set-buffer-modified-p (buffer-modified-p)) + )) + )) + +(add-hook 'mh-letter-mode-hook 'mime-setup-mh-draft-setting t) +(add-hook 'mh-before-send-letter-hook 'mime-editor/maybe-translate) + + +;;; @ for GNUS +;;; + +(add-hook 'news-reply-mode-hook 'mime/editor-mode) +(add-hook 'news-inews-hook 'mime-editor/maybe-translate) + + +;;; @ for message (September Gnus 0.58 or later) +;;; + +(defun message-maybe-setup-default-charset () + (let ((charset + (and (boundp 'gnus-summary-buffer) + (buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)))) + (if charset + (progn + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + )))) + +(or (boundp 'epoch::version) + (progn + (add-hook 'message-setup-hook 'mime/editor-mode) + (add-hook 'message-setup-hook 'message-maybe-setup-default-charset) + (add-hook 'message-send-hook 'mime-editor/maybe-translate) + (add-hook 'message-header-hook 'mime/encode-message-header) + + (call-after-loaded + 'message + (function + (lambda () + (require 'message-mime) + ))) + )) + + +;;; @ end +;;; + +(provide 'mime-setup) + +(run-hooks 'mime-setup-load-hook) + +;;; mime-setup.el ends here +;;; +;;; Local Variables: +;;; mode: emacs-lisp +;;; End: diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/mu-bbdb.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/mu-bbdb.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,128 @@ +;;; 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.1 1996/12/18 03:55:31 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) +(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 30df88044ec6 -r b82b59fe008d lisp/tl/mu-cite.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/mu-cite.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,480 @@ +;;; mu-cite.el --- yet another citation tool for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; MINOURA Makoto +;; Shuhei KOBAYASHI +;; Maintainer: Shuhei KOBAYASHI +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: mail, news, citation + +;; 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: +;; 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.1.1.1 1996/12/18 03:55:31 steve Exp $") +(defconst mu-cite/version (get-version-string mu-cite/RCS-ID)) + + +;;; @ formats +;;; + +(defvar cited-prefix-regexp "^[^ \t>]*[>|]+[ \t#]*") +(defvar mu-cite/cited-prefix-regexp "\\(^[^ \t\n>]+>+[ \t]*\\|^[ \t]*$\\)") + +(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/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 + (list (cons 'mh-letter-mode + (function + (lambda (name) + (if (and (stringp mh-sent-from-folder) + (numberp mh-sent-from-msg)) + (save-excursion + (set-buffer mh-sent-from-folder) + (set-buffer mh-show-buffer) + (and (boundp 'mime::preview/article-buffer) + (bufferp mime::preview/article-buffer) + (set-buffer mime::preview/article-buffer)) + (std11-field-body name) + )) + ))))) + +(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) +(load mu-cite/registration-file t t t) +(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-to-file) + ) + +;; save to file +(defun mu-cite/save-to-file () + (let* ((filename mu-cite/registration-file) + (buffer (get-buffer-create " *mu-register*"))) + (save-excursion + (set-buffer buffer) + (setq buffer-file-name filename) + (erase-buffer) + (insert + (format ";;; %s\n" (file-name-nondirectory filename))) + (insert + (format ";;; This file is generated automatically by mu-cite %s.\n\n" + mu-cite/version)) + (insert (format "(setq %s\n '(" mu-cite/registration-symbol)) + (insert (mapconcat + (function prin1-to-string) + mu-cite/citation-name-alist "\n ")) + (insert "\n ))\n\n") + (insert + (format ";;; %s ends here.\n" (file-name-nondirectory filename))) + (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")) + +(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 +;;; + +(defun fill-cited-region (beg end) + (interactive "*r") + (save-excursion + (save-restriction + (goto-char end) + (while (not (eolp)) + (backward-char) + ) + (setq end (point)) + (narrow-to-region beg end) + (goto-char (point-min)) + (let* ((fill-prefix + (let* ((str1 (buffer-substring + (progn (beginning-of-line)(point)) + (progn (end-of-line)(point)) + )) + (str2 (let ((p0 (point))) + (forward-line) + (if (> (count-lines p0 (point)) 0) + (buffer-substring + (progn (beginning-of-line)(point)) + (progn (end-of-line)(point)) + )))) + (ret (string-compare-from-top str1 str2)) + ) + (if ret + (nth 1 ret) + (goto-char (point-min)) + (if (re-search-forward cited-prefix-regexp nil t) + (buffer-substring (match-beginning 0) (match-end 0)) + )))) + (pat (concat "\n" fill-prefix)) + ) + (goto-char (point-min)) + (while (search-forward pat nil t) + (if (and (> (match-beginning 0) (point-min)) + (member (char-category + (char-before (match-beginning 0))) + '("a" "l")) + ) + (replace-match " ") + (replace-match "") + ) + ) + (goto-char (point-min)) + (fill-region (point-min) (point-max)) + )))) + +(defvar citation-mark-chars ">}|") + +(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 30df88044ec6 -r b82b59fe008d lisp/tl/mu-comment.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/mu-comment.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,129 @@ +;;; +;;; mu-comment.el --- a comment out utility for Lisp programs. +;;; +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Created: 1995/10/27 +;;; Version: +;;; $Id: mu-comment.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; Keywords: comment, Lisp +;;; +;;; 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. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Commentary: +;;; +;;; - How to install. +;;; 1. bytecompile this file and copy it to the apropriate directory. +;;; 2. put the following lines to your ~/.emacs: +;;; (autoload 'comment-sexp "mu-comment" nil t) +;;; (global-set-key "\C-c\C-q" 'comment-sexp) +;;; - How to use. +;;; type `C-c C-q' at the beginning of S-expression you want to +;;; comment out. +;;; +;;; Code: + +(defvar comment-sexp-first-line-method-alist + '((emacs-lisp-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-interaction-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-mode . comment-sexp-middle-line-method-for-lisp) + (scheme-mode . comment-sexp-middle-line-method-for-lisp) + (c-mode . comment-sexp-first-line-method-for-c) + (c++-mode . comment-sexp-middle-line-method-for-c++) + )) + +(defvar comment-sexp-middle-line-method-alist + '((emacs-lisp-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-interaction-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-mode . comment-sexp-middle-line-method-for-lisp) + (scheme-mode . comment-sexp-middle-line-method-for-lisp) + (c-mode . comment-sexp-middle-line-method-for-c) + (c++-mode . comment-sexp-middle-line-method-for-c++) + )) + +(defvar comment-sexp-last-line-method-alist + '((emacs-lisp-mode . comment-sexp-last-line-method-for-dummy) + (lisp-interaction-mode . comment-sexp-last-line-method-for-dummy) + (lisp-mode . comment-sexp-last-line-method-for-dummy) + (scheme-mode . comment-sexp-last-line-method-for-dummy) + (c-mode . comment-sexp-last-line-method-for-c) + (c++-mode . comment-sexp-last-line-method-for-dummy) + )) + +(defun comment-sexp-middle-line-method-for-lisp () + (insert ";; ") + ) + +(defun comment-sexp-middle-line-method-for-c++ () + (insert "// ") + ) + +(defun comment-sexp-first-line-method-for-c () + (insert "/* ") + ) + +(defun comment-sexp-middle-line-method-for-c () + (insert " * ") + ) + +(defun comment-sexp-last-line-method-for-c (c) + (insert "\n") + (while (< 0 c) + (insert " ") + (setq c (1- c)) + ) + (insert " */") + ) + +(defun comment-sexp-last-line-method-for-dummy (c)) + +(defun comment-sexp () + (interactive) + (let ((c (current-column)) + (b (save-excursion + (beginning-of-line) + (point))) + (e (save-excursion + (forward-sexp) + (point) + )) + ) + (save-excursion + (save-restriction + (narrow-to-region b e) + (untabify b e) + + (beginning-of-line) + (move-to-column c) + (funcall + (cdr (assq major-mode comment-sexp-first-line-method-alist))) + (forward-line) + + (while (< (point) (point-max)) + (beginning-of-line) + (move-to-column c) + (funcall + (cdr (assq major-mode comment-sexp-middle-line-method-alist))) + (forward-line) + ) + + (funcall + (cdr (assq major-mode comment-sexp-last-line-method-alist)) c) + )))) + +;;; mu-comment.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/mu-replace.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/mu-replace.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,85 @@ +;;; +;;; mu-replace.el --- a replacing utility for GNU Emacs +;;; +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Version: +;;; $Id: mu-replace.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; Keywords: replace +;;; +;;; 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. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Commentary: +;;; +;;; - How to install. +;;; 1. bytecompile this file and copy it to the apropriate directory. +;;; 2. put the following lines to your ~/.emacs: +;;; (autoload 'edit-replace-region "mu-replace" nil t) +;;; - How to use. +;;; 1. mark in beginning of region you want to replace. +;;; 2. go to end of region you want to replace. +;;; 3. type M-x edit-replace-region [CR] +;;; then entering to ``edit-replace mode''. +;;; 4. edit replacement string. +;;; 5. type C-c C-c then specified region will be replaced. +;;; +;;; Code: + +(defvar edit-replace-mode-map nil) +(if (null edit-replace-mode-map) + (progn + (setq edit-replace-mode-map (copy-keymap text-mode-map)) + (define-key edit-replace-mode-map + "\C-c\C-c" (function edit-replace-query-replace)) + )) + +(make-variable-buffer-local 'edit-replace-original-buffer) +(make-variable-buffer-local 'edit-replace-start-point) +(make-variable-buffer-local 'edit-replace-end-point) + +(defvar edit-replace-original-buffer nil) +(defvar edit-replace-start-point nil) +(defvar edit-replace-end-point nil) + +(defun edit-replace-region (beg end &optional str) + (interactive "r") + (let ((the-buf (current-buffer)) + (buf (get-buffer-create " *edit-replace*"))) + (pop-to-buffer buf) + (setq major-mode 'edit-replace) + (setq mode-name "edit for replace") + (use-local-map edit-replace-mode-map) + (setq edit-replace-original-buffer the-buf) + (setq edit-replace-start-point beg) + (setq edit-replace-end-point end) + )) + +(defun edit-replace-query-replace () + (interactive) + (let ((beg edit-replace-start-point) + (end edit-replace-end-point) + str + (rstr (buffer-string)) + ) + (switch-to-buffer edit-replace-original-buffer) + (setq str (buffer-substring beg end)) + (goto-char beg) + (query-replace str rstr) + )) + +;;; mu-replace.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/range.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/range.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,109 @@ +;;; range.el --- range functions + +;; Copyright (C) 1987 .. 1996 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; MORIOKA Tomohiko +;; Version: +;; $Id: range.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: range + +;; 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. + +;;; Code: + +;; These functions were imported from September Gnus 0.40. + +(defun compress-sorted-numbers (numbers &optional always-list) + "Convert list of numbers to a list of ranges or a single range. +If ALWAYS-LIST is non-nil, this function will always release a list of +ranges. [range.el]" + (let* ((first (car numbers)) + (last (car numbers)) + result) + (if (null numbers) + nil + (if (not (listp (cdr numbers))) + numbers + (while numbers + (cond ((= last (car numbers)) nil) ;Omit duplicated number + ((= (1+ last) (car numbers)) ;Still in sequence + (setq last (car numbers))) + (t ;End of one sequence + (setq result + (cons (if (= first last) first + (cons first last)) result)) + (setq first (car numbers)) + (setq last (car numbers)))) + (setq numbers (cdr numbers))) + (if (and (not always-list) (null result)) + (if (= first last) (list first) (cons first last)) + (nreverse (cons (if (= first last) first (cons first last)) + result))))))) + +(defun expand-range (range) + "Expand a range into a list of numbers. [range.el]" + (cond ((numberp range) + range) + ((numberp (cdr range)) + (index (car range)(cdr range)) + ) + (t + (let (dest ret) + (mapcar (function + (lambda (sec) + (setq ret (expand-range sec)) + (setq dest + (nconc dest + (if (and (listp ret) + (listp (cdr ret))) + ret + (list ret) + ))) + )) + range) + dest)))) + +(defun member-of-range (number range) + "Return t if NUMBER is a member of RANGE. [range.el]" + (cond ((numberp range) + (= number range) + ) + ((numberp (cdr range)) + (and (<= (car range) number) + (<= number (cdr range)) + ) + ) + (t + (catch 'tag + (while range + (if (member-of-range number (car range)) + (throw 'tag t) + ) + (setq range (cdr range)) + )) + ))) + + +;;; @ end +;;; + +(provide 'range) + +;;; range.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/richtext.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/richtext.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,183 @@ +;;; +;;; richtext.el -- read and save files in text/richtext format +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Created: 1995/7/15 +;;; Version: +;;; $Id: richtext.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; Keywords: wp, faces, MIME, multimedia +;;; +;;; 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. + +(require 'enriched) + + +;;; @ variables +;;; + +(defconst richtext-initial-annotation + (lambda () + (format "Content-Type: text/richtext\nText-Width: %d\n\n" + (enriched-text-width))) + "What to insert at the start of a text/richtext file. +If this is a string, it is inserted. If it is a list, it should be a lambda +expression, which is evaluated to get the string to insert.") + +(defconst richtext-annotation-regexp + "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*" + "Regular expression matching richtext annotations.") + +(defconst richtext-translations + '((face (bold-italic "bold" "italic") + (bold "bold") + (italic "italic") + (underline "underline") + (fixed "fixed") + (excerpt "excerpt") + (default ) + (nil enriched-encode-other-face)) + (invisible (t "comment")) + (left-margin (4 "indent")) + (right-margin (4 "indentright")) + (justification (right "flushright") + (left "flushleft") + (full "flushboth") + (center "center")) + ;; The following are not part of the standard: + (FUNCTION (enriched-decode-foreground "x-color") + (enriched-decode-background "x-bg-color")) + (read-only (t "x-read-only")) + (unknown (nil format-annotate-value)) +; (font-size (2 "bigger") ; unimplemented +; (-2 "smaller")) +) + "List of definitions of text/richtext annotations. +See `format-annotate-region' and `format-deannotate-region' for the definition +of this structure.") + + +;;; @ encoder +;;; + +(defun richtext-encode (from to) + (if enriched-verbose (message "Richtext: encoding document...")) + (save-restriction + (narrow-to-region from to) + (delete-to-left-margin) + (unjustify-region) + (goto-char from) + (format-replace-strings '(("<" . ""))) + (format-insert-annotations + (format-annotate-region from (point-max) richtext-translations + 'enriched-make-annotation enriched-ignore)) + (goto-char from) + (insert (if (stringp enriched-initial-annotation) + richtext-initial-annotation + (funcall richtext-initial-annotation))) + (enriched-map-property-regions 'hard + (lambda (v b e) + (goto-char b) + (if (eolp) + (while (search-forward "\n" nil t) + (replace-match "\n") + ))) + (point) nil) + (if enriched-verbose (message nil)) + ;; Return new end. + (point-max))) + + +;;; @ decoder +;;; + +(defun richtext-next-annotation () + "Find and return next text/richtext annotation. +Return value is \(begin end name positive-p), or nil if none was found." + (catch 'tag + (while (re-search-forward richtext-annotation-regexp nil t) + (let* ((beg0 (match-beginning 0)) + (end0 (match-end 0)) + (beg (match-beginning 1)) + (end (match-end 1)) + (name (downcase (buffer-substring + (match-beginning 3) (match-end 3)))) + (pos (not (match-beginning 2))) + ) + (cond ((equal name "lt") + (delete-region beg end) + (goto-char beg) + (insert "<") + ) + ((equal name "comment") + (if pos + (throw 'tag (list beg0 end name pos)) + (throw 'tag (list beg end0 name pos)) + ) + ) + (t + (throw 'tag (list beg end name pos)) + )) + )))) + +(defun richtext-decode (from to) + (if enriched-verbose (message "Richtext: decoding document...")) + (save-excursion + (save-restriction + (narrow-to-region from to) + (goto-char from) + (let ((file-width (enriched-get-file-width)) + (use-hard-newlines t) pc nc) + (enriched-remove-header) + + (goto-char from) + (while (re-search-forward "\n\n+" nil t) + (replace-match "\n") + ) + + ;; Deal with newlines + (goto-char from) + (while (re-search-forward "[ \t\n]*[ \t\n]*" nil t) + (replace-match "\n") + (put-text-property (match-beginning 0) (point) 'hard t) + (put-text-property (match-beginning 0) (point) 'front-sticky nil) + ) + + ;; Translate annotations + (format-deannotate-region from (point-max) richtext-translations + 'richtext-next-annotation) + + ;; Fill paragraphs + (if (or (and file-width ; possible reasons not to fill: + (= file-width (enriched-text-width))) ; correct wd. + (null enriched-fill-after-visiting) ; never fill + (and (eq 'ask enriched-fill-after-visiting) ; asked & declined + (not (y-or-n-p "Re-fill for current display width? ")))) + ;; Minimally, we have to insert indentation and justification. + (enriched-insert-indentation) + (if enriched-verbose (message "Filling paragraphs...")) + (fill-region (point-min) (point-max)))) + (if enriched-verbose (message nil)) + (point-max)))) + + +;;; @ end +;;; + +(provide 'richtext) diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/std11-parse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/std11-parse.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,441 @@ +;;; std11-parse.el --- STD 11 parser for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, RFC 822, STD 11 +;; Version: $Id: std11-parse.el,v 1.1.1.1 1996/12/18 03:55:31 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. + +;;; Code: + +(require 'std11) + +(autoload 'find-charset-string "emu") + + +;;; @ lexical analyze +;;; + +(defconst std11-space-chars " \t\n") +(defconst std11-spaces-regexp (concat "^[" std11-space-chars "]+")) +(defconst std11-special-chars "][()<>@,;:\\<>.\"") +(defconst std11-atom-regexp + (concat "^[^" std11-special-chars std11-space-chars "]+")) + +(defun std11-analyze-spaces (str) + (if (string-match std11-spaces-regexp str) + (let ((end (match-end 0))) + (cons (cons 'spaces (substring str 0 end)) + (substring str end) + )))) + +(defun std11-analyze-special (str) + (if (and (> (length str) 0) + (find (aref str 0) std11-special-chars) + ) + (cons (cons 'specials (substring str 0 1)) + (substring str 1) + ))) + +(defun std11-analyze-atom (str) + (if (string-match std11-atom-regexp str) + (let ((end (match-end 0))) + (cons (cons 'atom (substring str 0 end)) + (substring str end) + )))) + +(defun std11-check-enclosure (str open close &optional recursive from) + (let ((len (length str)) + (i (or from 0)) + ) + (if (and (> len i) + (eq (aref str i) open)) + (let (p chr dest) + (setq i (1+ i)) + (catch 'tag + (while (< i len) + (setq chr (aref str i)) + (cond ((eq chr ?\\) + (setq i (1+ i)) + (if (>= i len) + (throw 'tag nil) + ) + (setq i (1+ i)) + ) + ((eq chr close) + (throw 'tag (1+ i)) + ) + ((eq chr open) + (if (and recursive + (setq p (std11-check-enclosure + str open close recursive i)) + ) + (setq i p) + (throw 'tag nil) + )) + (t + (setq i (1+ i)) + )) + )))))) + +(defun std11-analyze-quoted-string (str) + (let ((p (std11-check-enclosure str ?\" ?\"))) + (if p + (cons (cons 'quoted-string (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-analyze-domain-literal (str) + (let ((p (std11-check-enclosure str ?\[ ?\]))) + (if p + (cons (cons 'domain-literal (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-analyze-comment (str) + (let ((p (std11-check-enclosure str ?\( ?\) t))) + (if p + (cons (cons 'comment (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-lexical-analyze (str) + (let (dest ret) + (while (not (string-equal str "")) + (setq ret + (or (std11-analyze-quoted-string str) + (std11-analyze-domain-literal str) + (std11-analyze-comment str) + (std11-analyze-spaces str) + (std11-analyze-special str) + (std11-analyze-atom str) + '((error) . "") + )) + (setq dest (cons (car ret) dest)) + (setq str (cdr ret)) + ) + (nreverse dest) + )) + + +;;; @ parser +;;; + +(defun std11-ignored-token-p (token) + (let ((type (car token))) + (or (eq type 'spaces)(eq type 'comment)) + )) + +(defun std11-parse-token (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-ascii-token (lal) + (let (token itl parsed token-value) + (while (and lal + (setq token (car lal)) + (if (and (setq token-value (cdr token)) + (find-charset-string token-value) + ) + (setq token nil) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (if (and token + (setq parsed (nreverse (cons token itl))) + ) + (cons parsed (cdr lal)) + ))) + +(defun std11-parse-token-or-comment (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (eq (car token) 'spaces) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-word (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (if (or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ))))) + +(defun std11-parse-word-or-comment (lal) + (let ((ret (std11-parse-token-or-comment lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (cond ((or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ) + ((assq 'comment elt) + (cons (cons 'comment-word elt) rest) + )) + )))) + +(defun std11-parse-phrase (lal) + (let (ret phrase) + (while (setq ret (std11-parse-word-or-comment lal)) + (setq phrase (append phrase (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (if phrase + (cons (cons 'phrase phrase) lal) + ))) + +(defun std11-parse-local-part (lal) + (let ((ret (std11-parse-word lal))) + (if ret + (let ((local-part (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-word (cdr ret))) + (setq local-part + (append local-part dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'local-part local-part) lal) + )))) + +(defun std11-parse-sub-domain (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((sub-domain (car ret))) + (if (or (assq 'atom sub-domain) + (assq 'domain-literal sub-domain) + ) + (cons (cons 'sub-domain sub-domain) + (cdr ret) + ) + ))))) + +(defun std11-parse-domain (lal) + (let ((ret (std11-parse-sub-domain lal))) + (if ret + (let ((domain (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-sub-domain (cdr ret))) + (setq domain + (append domain dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'domain domain) lal) + )))) + +(defun std11-parse-at-domain (lal) + (let ((ret (std11-parse-ascii-token lal)) at-sign) + (if (and ret + (setq at-sign (car ret)) + (string-equal (cdr (assq 'specials at-sign)) "@") + (setq ret (std11-parse-domain (cdr ret))) + ) + (cons (cons 'at-domain (append at-sign (cdr (car ret)))) + (cdr ret)) + ))) + +(defun std11-parse-addr-spec (lal) + (let ((ret (std11-parse-local-part lal)) + addr) + (if (and ret + (prog1 + (setq addr (cdr (car ret))) + (setq lal (cdr ret)) + (and (setq ret (std11-parse-at-domain lal)) + (setq addr (append addr (cdr (car ret)))) + (setq lal (cdr ret)) + ))) + (cons (cons 'addr-spec addr) lal) + ))) + +(defun std11-parse-route (lal) + (let ((ret (std11-parse-at-domain lal)) + route comma colon) + (if (and ret + (progn + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal (cdr (assq 'specials comma)) ",") + (setq ret (std11-parse-at-domain (cdr ret))) + ) + (setq route (append route comma (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (and (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq route (append route colon)) + ) + )) + (cons (cons 'route route) + (cdr ret) + ) + ))) + +(defun std11-parse-route-addr (lal) + (let ((ret (std11-parse-ascii-token lal)) + < route addr-spec >) + (if (and ret + (setq < (car ret)) + (string-equal (cdr (assq 'specials <)) "<") + (setq lal (cdr ret)) + (progn (and (setq ret (std11-parse-route lal)) + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + ) + (setq ret (std11-parse-addr-spec lal)) + ) + (setq addr-spec (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq > (car ret)) + (string-equal (cdr (assq 'specials >)) ">") + ) + (cons (cons 'route-addr (append route addr-spec)) + (cdr ret) + ) + ))) + +(defun std11-parse-phrase-route-addr (lal) + (let ((ret (std11-parse-phrase lal)) phrase) + (if ret + (progn + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + )) + (if (setq ret (std11-parse-route-addr lal)) + (cons (list 'phrase-route-addr + phrase + (cdr (car ret))) + (cdr ret)) + ))) + +(defun std11-parse-mailbox (lal) + (let ((ret (or (std11-parse-phrase-route-addr lal) + (std11-parse-addr-spec lal))) + mbox comment) + (if (and ret + (prog1 + (setq mbox (car ret)) + (setq lal (cdr ret)) + (if (and (setq ret (std11-parse-token-or-comment lal)) + (setq comment (cdr (assq 'comment (car ret)))) + ) + (setq lal (cdr ret)) + ))) + (cons (list 'mailbox mbox comment) + lal) + ))) + +(defun std11-parse-group (lal) + (let ((ret (std11-parse-phrase lal)) + phrase colon comma mbox semicolon) + (if (and ret + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq lal (cdr ret)) + (progn + (and (setq ret (std11-parse-mailbox lal)) + (setq mbox (list (car ret))) + (setq lal (cdr ret)) + (progn + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal + (cdr (assq 'specials comma)) ",") + (setq lal (cdr ret)) + (setq ret (std11-parse-mailbox lal)) + (setq mbox (cons (car ret) mbox)) + (setq lal (cdr ret)) + ) + ))) + (and (setq ret (std11-parse-ascii-token lal)) + (setq semicolon (car ret)) + (string-equal (cdr (assq 'specials semicolon)) ";") + ))) + (cons (list 'group phrase (nreverse mbox)) + (cdr ret) + ) + ))) + +(defun std11-parse-address (lal) + (or (std11-parse-group lal) + (std11-parse-mailbox lal) + )) + +(defun std11-parse-addresses (lal) + (let ((ret (std11-parse-address lal))) + (if ret + (let ((dest (list (car ret)))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (string-equal (cdr (assq 'specials (car ret))) ",") + (setq ret (std11-parse-address (cdr ret))) + ) + (setq dest (cons (car ret) dest)) + (setq lal (cdr ret)) + ) + (nreverse dest) + )))) + + +;;; @ end +;;; + +(provide 'std11-parse) + +;;; std11-parse.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/std11.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/std11.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,284 @@ +;;; std11.el --- STD 11 functions for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, RFC 822, STD 11 +;; Version: $Id: std11.el,v 1.1.1.1 1996/12/18 03:55:31 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. + +;;; Code: + +(autoload 'buffer-substring-no-properties "emu") +(autoload 'member "emu") + + +;;; @ field +;;; + +(defconst std11-field-name-regexp "[!-9;-~]+") +(defconst std11-field-head-regexp + (concat "^" std11-field-name-regexp ":")) +(defconst std11-next-field-head-regexp + (concat "\n" std11-field-name-regexp ":")) + +(defun std11-field-end () + "Move to end of field and return this point. [std11.el]" + (if (re-search-forward std11-next-field-head-regexp nil t) + (goto-char (match-beginning 0)) + (if (re-search-forward "^$" nil t) + (goto-char (1- (match-beginning 0))) + (end-of-line) + )) + (point) + ) + +(defun std11-field-body (name &optional boundary) + "Return body of field NAME. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (re-search-forward (concat "^" name ":[ \t]*") nil t) + (buffer-substring-no-properties (match-end 0) (std11-field-end)) + ))))) + +(defun std11-find-field-body (field-names &optional boundary) + "Return the first found field-body specified by FIELD-NAMES +of the message header in current buffer. If BOUNDARY is not nil, it is +used as message header separator. [std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (let ((case-fold-search t) + field-name) + (catch 'tag + (while (setq field-name (car field-names)) + (goto-char (point-min)) + (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) + (throw 'tag + (buffer-substring-no-properties + (match-end 0) (std11-field-end))) + ) + (setq field-names (cdr field-names)) + )))))) + +(defun std11-field-bodies (field-names &optional default-value boundary) + "Return list of each field-bodies of FIELD-NAMES of the message header +in current buffer. If BOUNDARY is not nil, it is used as message +header separator. [std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (let* ((case-fold-search t) + (dest (make-list (length field-names) default-value)) + (s-rest field-names) + (d-rest dest) + field-name) + (while (setq field-name (car s-rest)) + (goto-char (point-min)) + (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) + (setcar d-rest + (buffer-substring-no-properties + (match-end 0) (std11-field-end))) + ) + (setq s-rest (cdr s-rest) + d-rest (cdr d-rest)) + ) + dest)))) + + +;;; @ unfolding +;;; + +(defun std11-unfold-string (string) + "Unfold STRING as message header field. [std11.el]" + (let ((dest "")) + (while (string-match "\n\\s +" string) + (setq dest (concat dest (substring string 0 (match-beginning 0)) " ")) + (setq string (substring string (match-end 0))) + ) + (concat dest string) + )) + + +;;; @ header +;;; + +(defun std11-narrow-to-header (&optional boundary) + "Narrow to the message header. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward + (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$") + nil t) + (match-beginning 0) + (point-max) + ))) + +(defun std11-header-string (regexp &optional boundary) + "Return string of message header fields matched by REGEXP. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (let ((case-fold-search t)) + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (field header) + (while (re-search-forward std11-field-head-regexp nil t) + (setq field + (buffer-substring (match-beginning 0) (std11-field-end))) + (if (string-match regexp field) + (setq header (concat header field "\n")) + )) + header) + )))) + +(defun std11-header-string-except (regexp &optional boundary) + "Return string of message header fields not matched by REGEXP. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (let ((case-fold-search t)) + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (field header) + (while (re-search-forward std11-field-head-regexp nil t) + (setq field + (buffer-substring (match-beginning 0) (std11-field-end))) + (if (not (string-match regexp field)) + (setq header (concat header field "\n")) + )) + header) + )))) + +(defun std11-collect-field-names (&optional boundary) + "Return list of all field-names of the message header in current buffer. +If BOUNDARY is not nil, it is used as message header separator. +\[std11.el]" + (save-excursion + (save-restriction + (std11-narrow-to-header boundary) + (goto-char (point-min)) + (let (dest name) + (while (re-search-forward std11-field-head-regexp nil t) + (setq name (buffer-substring-no-properties + (match-beginning 0)(1- (match-end 0)))) + (or (member name dest) + (setq dest (cons name dest)) + ) + ) + dest)))) + + +;;; @ composer +;;; + +(defun std11-addr-to-string (seq) + "Return string from lexical analyzed list SEQ +represents addr-spec of RFC 822. [std11.el]" + (mapconcat (function + (lambda (token) + (if (let ((name (car token))) + (or (eq name 'spaces) + (eq name 'comment) + )) + "" + (cdr token) + ))) + seq "") + ) + +(defun std11-address-string (address) + "Return string of address part from parsed ADDRESS of RFC 822. +\[std11.el]" + (cond ((eq (car address) 'group) + (mapconcat (function std11-address-string) + (car (cdr address)) + ", ") + ) + ((eq (car address) 'mailbox) + (let ((addr (nth 1 address))) + (std11-addr-to-string + (if (eq (car addr) 'phrase-route-addr) + (nth 2 addr) + (cdr addr) + ) + ))))) + +(defun std11-full-name-string (address) + "Return string of full-name part from parsed ADDRESS of RFC 822. +\[std11.el]" + (cond ((eq (car address) 'group) + (mapconcat (function + (lambda (token) + (cdr token) + )) + (nth 1 address) "") + ) + ((eq (car address) 'mailbox) + (let ((addr (nth 1 address)) + (comment (nth 2 address)) + phrase) + (if (eq (car addr) 'phrase-route-addr) + (setq phrase (mapconcat (function + (lambda (token) + (cdr token) + )) + (nth 1 addr) "")) + ) + (or phrase comment) + )))) + + +;;; @ parser +;;; + +(defun std11-parse-address-string (string) + "Parse STRING as mail address. [std11.el]" + (std11-parse-address (std11-lexical-analyze string)) + ) + +(defun std11-parse-addresses-string (string) + "Parse STRING as mail address list. [std11.el]" + (std11-parse-addresses (std11-lexical-analyze string)) + ) + +(provide 'std11) + +(mapcar (function + (lambda (func) + (autoload func "std11-parse") + )) + '(std11-lexical-analyze + std11-parse-address std11-parse-addresses + std11-parse-address-string)) + + +;;; @ end +;;; + +;;; std11.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/texi-util.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/texi-util.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,64 @@ +;;; texi-util.el --- Texinfo utility + +;; Copyright (C) 1996 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Version: $Id: texi-util.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: Texinfo + +;; 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. + +;;; Code: + +(defun texinfo-all-menu-titles-update () + (interactive) + (goto-char (point-min)) + (while (search-forward "\n@menu\n" nil t) + (goto-char (match-end 0)) + (while (looking-at "* \\([^:]+\\)::") + (let ((title (buffer-substring (match-beginning 1)(match-end 1))) + subj) + (save-excursion + (let ((ret + (re-search-forward + (format + "@node %s.*\n@\\(chapter\\|\\(sub\\)*section\\) \\(.+\\)" + (regexp-quote title))))) + (if ret + (let ((data (last (match-data) 2))) + (setq subj (buffer-substring (car data) + (car (cdr data)))) + )) + )) + (if subj + (or (string= subj title) + (progn + (end-of-line) + (insert subj) + ))) + (end-of-line) + (forward-char) + )))) + + +;;; @ end +;;; + +(provide 'texi-util) + +;;; texi-util.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tinyrich.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tinyrich.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,166 @@ +;;; +;;; $Id: tinyrich.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; +;;; by MORIOKA Tomohiko +;;; modified by YAMATE Keiichirou +;;; + +(defvar mime-viewer/face-list-for-text/enriched + (cond ((and (>= emacs-major-version 19) window-system) + '(bold italic fixed underline) + ) + ((and (boundp 'NEMACS) NEMACS) + '("bold" "italic" "underline") + ))) + +(defun enriched-decode (beg end) + (interactive "*r") + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (while (re-search-forward "[ \t]*\\(\n+\\)[ \t]*" nil t) + (let ((str (buffer-substring (match-beginning 1) + (match-end 1)))) + (if (string= str "\n") + (replace-match " ") + (replace-match (substring str 1)) + ))) + (goto-char beg) + (let (cmd sym str (fb (point)) fe b e) + (while (re-search-forward "<\\(<\\|[^<>\n\r \t]+>\\)" nil t) + (setq b (match-beginning 0)) + (setq cmd (buffer-substring b (match-end 0))) + (if (string= cmd "<<") + (replace-match "<") + (replace-match "") + (setq cmd (downcase (substring cmd 1 (- (length cmd) 1)))) + ) + (setq sym (intern cmd)) + (cond ((eq sym 'param) + (setq b (point)) + (save-excursion + (save-restriction + (if (search-forward "" nil t) + (progn + (replace-match "") + (setq e (point)) + ) + (setq e end) + ))) + (delete-region b e) + ) + ((memq sym mime-viewer/face-list-for-text/enriched) + (setq b (point)) + (save-excursion + (save-restriction + (if (re-search-forward (concat "") nil t) + (progn + (replace-match "") + (setq e (point)) + ) + (setq e end) + ))) + (tm:set-face-region b e sym) + ))) + (goto-char (point-max)) + (if (not (eq (preceding-char) ?\n)) + (insert "\n") + ) + )))) + + +;;; @ text/richtext <-> text/enriched converter +;;; + +(defun richtext-to-enriched-region (beg end) + "Convert the region of text/richtext style to text/enriched style." + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (let (b e i) + (while (re-search-forward "[ \t]*" nil t) + (setq b (match-beginning 0)) + (delete-region b + (if (re-search-forward "[ \t]*" nil t) + (match-end 0) + (point-max) + )) + ) + (goto-char (point-min)) + (while (re-search-forward "\n\n+" nil t) + (replace-match "\n") + ) + (goto-char (point-min)) + (while (re-search-forward "[ \t\n]*[ \t\n]*" nil t) + (setq b (match-beginning 0)) + (setq e (match-end 0)) + (setq i 1) + (while (looking-at "[ \t\n]*[ \t\n]*") + (setq e (match-end 0)) + (setq i (1+ i)) + (goto-char e) + ) + (delete-region b e) + (while (>= i 0) + (insert "\n") + (setq i (1- i)) + )) + (goto-char (point-min)) + (while (search-forward "" nil t) + (replace-match "<<") + ) + )))) + +(defun enriched-to-richtext-region (beg end) + "Convert the region of text/enriched style to text/richtext style." + (save-excursion + (save-restriction + (goto-char beg) + (and (search-forward "text/enriched") + (replace-match "text/richtext")) + (search-forward "\n\n") + (narrow-to-region (match-end 0) end) + (let (str n) + (goto-char (point-min)) + (while (re-search-forward "\n\n+" nil t) + (setq str (buffer-substring (match-beginning 0) + (match-end 0))) + (setq n (1- (length str))) + (setq str "") + (while (> n 0) + (setq str (concat str "\n")) + (setq n (1- n)) + ) + (replace-match str) + ) + (goto-char (point-min)) + (while (search-forward "<<" nil t) + (replace-match "") + ) + )))) + + +;;; @ encoder and decoder +;;; + +(defun richtext-decode (beg end) + (save-restriction + (narrow-to-region beg end) + (richtext-to-enriched-region beg (point-max)) + (enriched-decode beg (point-max)) + )) + +;; (defun richtext-encode (beg end) +;; (save-restriction +;; (narrow-to-region beg end) +;; (enriched-encode beg (point-max)) +;; (enriched-to-richtext-region beg (point-max)) +;; )) + + +;;; @ end +;;; + +(provide 'tinyrich) diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tl-822.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tl-822.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,148 @@ +;;; tl-822.el --- RFC 822 parser for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: mail, news, RFC 822 + +;; 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. + +;;; Code: + +(require 'tl-seq) +(require 'tl-str) +(require 'std11) + + +(defconst rfc822/RCS-ID + "$Id: tl-822.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $") +(defconst rfc822/version (get-version-string rfc822/RCS-ID)) + + +;;; @ header +;;; + +(defalias 'rfc822/narrow-to-header 'std11-narrow-to-header) +(defalias 'rfc822/get-header-string 'std11-header-string) +(defalias 'rfc822/get-header-string-except 'std11-header-string-except) +(defalias 'rfc822/get-field-names 'std11-collect-field-names) + + +;;; @ field +;;; + +(defalias `rfc822/field-end 'std11-field-end) +(defalias 'rfc822/get-field-body 'std11-field-body) +(defalias 'rfc822/get-field-bodies 'std11-field-bodies) + + +;;; @ quoting +;;; + +(defconst rfc822/linear-white-space-regexp "\\(\n?[ \t]\\)+") +(defconst rfc822/quoted-pair-regexp "\\\\.") +(defconst rfc822/non-qtext-char-list '(?\" ?\\ ?\r ?\n)) +(defconst rfc822/qtext-regexp + (concat "[^" (char-list-to-string rfc822/non-qtext-char-list) "]")) +(defconst rfc822/quoted-string-regexp + (concat "\"" + (regexp-* + (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp) + ) + "\"")) + +(defun rfc822/wrap-as-quoted-string (str) + "Wrap string STR as RFC 822 quoted-string. [tl-822.el]" + (concat "\"" + (mapconcat (function + (lambda (chr) + (if (memq chr rfc822/non-qtext-char-list) + (concat "\\" (char-to-string chr)) + (char-to-string chr) + ) + )) str "") + "\"")) + +(defun rfc822/strip-quoted-pair (str) + (let ((dest "") + (i 0) + (len (length str)) + chr flag) + (while (< i len) + (setq chr (elt str i)) + (if (or flag (not (eq chr ?\\))) + (progn + (setq dest (concat dest (char-to-string chr))) + (setq flag nil) + ) + (setq flag t) + ) + (setq i (+ i 1)) + ) + dest)) + +(defun rfc822/strip-quoted-string (str) + (rfc822/strip-quoted-pair + (let ((max (- (length str) 1)) + ) + (if (and (eq (elt str 0) ?\") + (eq (elt str max) ?\") + ) + (substring str 1 max) + str) + ))) + + +;;; @ unfolding +;;; + +(defalias 'rfc822/unfolding-string 'std11-unfold-string) + + +;;; @ lexical analyze +;;; + +(defalias 'rfc822/lexical-analyze 'std11-lexical-analyze) + + +;;; @ parser +;;; + +(defalias 'rfc822/parse-address 'std11-parse-address) +(defalias 'rfc822/parse-addresses 'std11-parse-addresses) +(defalias 'rfc822/address-string 'std11-address-string) +(defalias 'rfc822/full-name-string 'std11-full-name-string) + +(defun rfc822/extract-address-components (string) + "Extract full name and canonical address from STRING. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). +If no name can be extracted, FULL-NAME will be nil. [tl-822.el]" + (let* ((structure (car (std11-parse-address-string string))) + (phrase (rfc822/full-name-string structure)) + (address (rfc822/address-string structure)) + ) + (list phrase address) + )) + + +;;; @ end +;;; + +(provide 'tl-822) + +;;; tl-822.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tl-atype.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tl-atype.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,205 @@ +;;; tl-atype.el --- atype functions + +;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Id: tl-atype.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: atype + +;; 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 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 'tl-str) +(require 'tl-list) + + +;;; @ field +;;; + +(defalias 'fetch-field 'assoc) +(defalias 'fetch-field-value 'assoc-value) +(defalias 'put-field 'put-alist) +(defalias 'delete-field 'del-alist) + +(defun put-fields (tp c) + (catch 'tag + (let ((r tp) f ret) + (while r + (setq f (car r)) + (if (not (if (setq ret (fetch-field (car f) c)) + (equal (cdr ret)(cdr f)) + (setq c (cons f c)) + )) + (throw 'tag 'error)) + (setq r (cdr r)) + )) + c)) + + +;;; @ field unifier +;;; + +(defun field-unifier-for-default (a b) + (let ((ret + (cond ((equal a b) a) + ((null (cdr b)) a) + ((null (cdr a)) b) + ))) + (if ret + (list nil ret nil) + ))) + +(defun field-unify (a b) + (let ((sym (symbol-concat "field-unifier-for-" (car a)))) + (if (not (fboundp sym)) + (setq sym (function field-unifier-for-default)) + ) + (funcall sym a b) + )) + + +;;; @ type unifier +;;; + +(defun assoc-unify (class instance) + (catch 'tag + (let ((cla (copy-alist class)) + (ins (copy-alist instance)) + (r class) + cell aret ret prev rest) + (while r + (setq cell (car r)) + (setq aret (fetch-field (car cell) ins)) + (if aret + (if (setq ret (field-unify cell aret)) + (progn + (if (car ret) + (setq prev (put-field (car (car ret)) + (cdr (car ret)) + prev)) + ) + (if (nth 2 ret) + (setq rest (put-field (car (nth 2 ret)) + (cdr (nth 2 ret)) + rest)) + ) + (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla)) + (setq ins (delete-field (car cell) ins)) + ) + (throw 'tag nil) + )) + (setq r (cdr r)) + ) + (setq r (copy-alist ins)) + (while r + (setq cell (car r)) + (setq aret (fetch-field (car cell) cla)) + (if aret + (if (setq ret (field-unify cell aret)) + (progn + (if (car ret) + (setq prev (put-field (car (car ret)) + (cdr (car ret)) + prev)) + ) + (if (nth 2 ret) + (setq rest (put-field (car (nth 2 ret)) + (cdr (nth 2 ret)) + rest)) + ) + (setq cla (delete-field (car cell) cla)) + (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins)) + ) + (throw 'tag nil) + )) + (setq r (cdr r)) + ) + (list prev (append cla ins) rest) + ))) + +(defun get-unified-alist (db al) + (let ((r db) ret) + (catch 'tag + (while r + (if (setq ret (nth 1 (assoc-unify (car r) al))) + (throw 'tag ret) + ) + (setq r (cdr r)) + )))) + +(defun delete-atype (atl al) + (let* ((r atl) ret oal) + (setq oal + (catch 'tag + (while r + (if (setq ret (nth 1 (assoc-unify (car r) al))) + (throw 'tag (car r)) + ) + (setq r (cdr r)) + ))) + (delete oal atl) + )) + +(defun remove-atype (sym al) + (and (boundp sym) + (set sym (delete-atype (eval sym) al)) + )) + +(defun replace-atype (atl old-al new-al) + (let* ((r atl) ret oal) + (if (catch 'tag + (while r + (if (setq ret (nth 1 (assoc-unify (car r) old-al))) + (throw 'tag (rplaca r new-al)) + ) + (setq r (cdr r)) + )) + atl))) + +(defun set-atype (sym al &rest options) + (if (null (boundp sym)) + (set sym al) + (let* ((replacement (memq 'replacement options)) + (ignore-fields (car (cdr (memq 'ignore options)))) + (remove (or (car (cdr (memq 'remove options))) + (let ((ral (copy-alist al))) + (mapcar (function + (lambda (type) + (setq ral (del-alist type ral)) + )) + ignore-fields) + ral))) + ) + (set sym + (or (if replacement + (replace-atype (eval sym) remove al) + ) + (cons al + (delete-atype (eval sym) remove) + ) + ))))) + + +;;; @ end +;;; + +(provide 'tl-atype) + +;;; tl-atype.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tl-list.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tl-list.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,386 @@ +;;; tl-list.el --- utility functions about list + +;; Copyright (C) 1987 .. 1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; Version: +;; $Id: tl-list.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: list + +;; 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. + +;;; Code: + +(require 'file-detect) + +(cond ((file-installed-p "cl-seq.elc") + (require 'cless) + ) + (t + ;; New cl is not exist (Don't use old cl.el) + +(defun last (ls &optional n) + "Returns the last element in list LS. +With optional argument N, returns Nth-to-last link (default 1). +\[tl-list.el; tomo's Common Lisp emulating function]" + (nthcdr (- (length ls) (or n 1)) ls) + ) + +;; imported from cl.el +(defun list* (arg &rest rest) + "Return a new list with specified args as elements, cons'd to last arg. +Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to +`(cons A (cons B (cons C D)))'." + (cond ((not rest) arg) + ((not (cdr rest)) (cons arg (car rest))) + (t (let* ((n (length rest)) + (copy (copy-sequence rest)) + (last (nthcdr (- n 2) copy))) + (setcdr last (car (cdr last))) + (cons arg copy))))) + +(defconst :test ':test) + +(defun MEMBER (elt list &rest keywords) + (let ((test + (or + (let ((ret (memq ':test keywords))) + (car (cdr ret)) + ) + 'eq))) + (cond ((eq test 'eq) + (memq elt list) + ) + ((eq test 'equal) + (member elt list) + ) + (t + (catch 'tag + (while list + (let* ((cell (car list)) + (ret (funcall test elt cell)) + ) + (if ret + (throw 'tag list) + )) + (setq list (cdr list)) + )))))) + +(defun ASSOC (key alist &rest keywords) + (let ((test + (or + (let ((ret (memq ':test keywords))) + (car (cdr ret)) + ) + 'eq))) + (cond ((eq test 'eq) + (assq key alist) + ) + ((eq test 'equal) + (assoc key alist) + ) + (t + (catch 'tag + (while alist + (let* ((cell (car alist)) + (ret (funcall test key (car cell))) + ) + (if ret + (throw 'tag cell) + )) + (setq alist (cdr alist)) + )))))) +)) + +(autoload 'compress-sorted-numbers "range") +(autoload 'expand-range "range") +(autoload 'member-of-range "range") + + +;;; @ list +;;; + +(defun nnth-prev (n ls) + "Modify list LS to remove elements after N th. [tl-list.el]" + (and (> n 0) + (let ((cell (nthcdr (1- n) ls))) + (if (consp cell) + (setcdr cell nil) + ) + ls))) + +(defun nth-prev (n ls) + "Return the first N elements. [tl-list.el]" + (let (dest) + (while (and (> n 0) ls) + (setq dest (cons (car ls) dest)) + (setq ls (cdr ls) + n (1- n)) + ) + (nreverse dest) + )) + +(defun nexcept-nth (n ls) + "Modify list LS to remove N th element. [tl-list.el]" + (cond ((< n 0) ls) + ((= n 0) (cdr ls)) + (t + (let ((cell (nthcdr (1- n) ls))) + (if (consp cell) + (setcdr cell (cdr (cdr cell))) + )) + ls))) + +(defun except-nth (n ls) + "Return elements of LS except N th. [tl-list.el]" + (if (< n 0) + ls + (let (dest) + (while (and (> n 0) ls) + (setq dest (cons (car ls) dest)) + (setq ls (cdr ls) + n (1- n)) + ) + (setq ls (cdr ls)) + (while dest + (setq ls (cons (car dest) ls)) + (setq dest (cdr dest)) + ) + ls))) + +(defun last-element (ls) + "Return last element. [tl-list.el]" + (car (last ls)) + ) + +(defun cons-element (elt ls) + "Cons ELT to LS if ELT is not nil. [tl-list.el]" + (if elt + (cons elt ls) + ls)) + +(defun cons-if (elt ls) + "Cons ELT to LS if LS is not nil, otherwise return nil. [tl-list.el]" + (if ls + (cons elt ls) + )) + +(defun append-element (ls elt) + "Append ELT to last of LS if ELT is not nil. [tl-list.el]" + (if elt + (append ls (list elt)) + ls)) + + +;;; @ permutation and combination +;;; + +(defun every-combination (prev &rest rest) + "Every arguments are OR list, +and return list of all possible sequence. [tl-list.el]" + (if (null prev) + (setq prev '(nil)) + ) + (cond ((null rest) + (mapcar 'list prev) + ) + (t (let (dest + (pr prev) + (rest-mixed (apply 'every-combination rest)) + ) + (while pr + (let ((rr rest-mixed)) + (while rr + (setq dest (cons (cons (car pr)(car rr)) dest)) + (setq rr (cdr rr)) + )) + (setq pr (cdr pr)) + ) + (nreverse dest) + )) + )) + +(defun permute (&rest ls) + "Return permutation of arguments as list. [tl-list.el]" + (let ((len (length ls))) + (if (<= len 1) + (list ls) + (let (prev + (rest ls) + c dest) + (while rest + (setq c (car rest)) + (setq rest (cdr rest)) + (setq dest + (nconc dest + (mapcar (function + (lambda (s) + (cons c s) + )) + (apply (function permute) + (append prev rest)) + ))) + (setq prev (nconc prev (list c))) + ) + dest) + ))) + + +;;; @ index +;;; + +(defun index (start end &optional inc) + "Return list of numbers from START to END. +Element of the list increases by INC (default value is 1). +\[tl-list.el; ELIS compatible function]" + (or inc + (setq inc 1) + ) + (let ((pred (if (>= inc 0) + (function <=) + (function >=) + )) + (i start) + dest) + (while (funcall pred i end) + (setq dest (cons i dest)) + (setq i (+ i inc)) + ) + (nreverse dest) + )) + + +;;; @ set +;;; + +(defun map-union (func ls) + "Apply FUNC to each element of LS. +And return union of each result returned by FUNC. [tl-list.el]" + (let ((r ls) ret rc dest) + (while r + (setq ret (funcall func (car r))) + (while ret + (setq rc (car ret)) + (or (member rc dest) + (setq dest (cons rc dest)) + ) + (setq ret (cdr ret)) + ) + (setq r (cdr r)) + ) + (nreverse dest) + )) + + +;;; @ alist +;;; + +(defun put-alist (item value alist) + "Modify ALIST to set VALUE to ITEM. +If there is a pair whose car is ITEM, replace its cdr by VALUE. +If there is not such pair, create new pair (ITEM . VALUE) and +return new alist whose car is the new pair and cdr is ALIST. +\[tl-list.el; tomo's ELIS like function]" + (let ((pair (assoc item alist))) + (if pair + (progn + (setcdr pair value) + alist) + (cons (cons item value) alist) + ))) + +(defun del-alist (item alist) + "If there is a pair whose key is , delete it from . +\[tl-list.el; mol's ELIS emulating function]" + (if (equal item (car (car alist))) + (cdr alist) + (let ((pr alist) + (r (cdr alist)) + ) + (catch 'tag + (while (not (null r)) + (if (equal item (car (car r))) + (progn + (rplacd pr (cdr r)) + (throw 'tag alist))) + (setq pr r) + (setq r (cdr r)) + ) + alist)))) + +(defun assoc-value (item alist) + "Return value of from . [tl-list.el]" + (cdr (assoc item alist)) + ) + +(defun set-alist (symbol item value) + "Modify a alist indicated by SYMBOL to set VALUE to ITEM. [tl-list.el]" + (or (boundp symbol) + (set symbol nil) + ) + (set symbol (put-alist item value (symbol-value symbol))) + ) + +(defun remove-alist (symbol item) + "Remove ITEM from the alist indicated by SYMBOL. [tl-list.el]" + (and (boundp symbol) + (set symbol (del-alist item (symbol-value symbol))) + )) + +(defun modify-alist (modifier default) + "Modify alist DEFAULT into alist MODIFIER. [tl-list.el]" + (mapcar (function + (lambda (as) + (setq default (put-alist (car as)(cdr as) default)) + )) + modifier) + default) + +(defun set-modified-alist (sym modifier) + "Modify a value of a symbol SYM into alist MODIFIER. +The symbol SYM should be alist. If it is not bound, +its value regard as nil. [tl-list.el]" + (if (not (boundp sym)) + (set sym nil) + ) + (set sym (modify-alist modifier (eval sym))) + ) + + +;;; @ poly-apply +;;; + +(defun poly-funcall (functions arg) + (while functions + (setq arg (funcall (car functions) arg) + functions (cdr functions)) + ) + arg) + + +;;; @ end +;;; + +(provide 'tl-list) + +(require 'tl-seq) +(require 'tl-atype) + +;;; tl-list.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tl-misc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tl-misc.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,94 @@ +;;; tl-misc.el --- miscellaneous utility of tl. + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: +;; $Id: tl-misc.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: load-path, module, structure + +;; 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. + +;;; Code: + +(require 'emu) +(require 'tl-str) + +(autoload 'add-path "file-detect") +(autoload 'get-latest-path "file-detect") +(autoload 'file-installed-p "file-detect") + + +;;; @ module and hook +;;; + +(defun call-after-loaded (module func &optional hook-name) + "If MODULE is provided, then FUNC is called. +Otherwise func is set to MODULE-load-hook. +If optional argument HOOK-NAME is specified, +it is used as hook to set. [tl-misc.el]" + (if (featurep module) + (funcall func) + (progn + (if (null hook-name) + (setq hook-name (symbol-concat module "-load-hook")) + ) + (add-hook hook-name func) + ))) + + +;;; @ structure +;;; + +(defmacro define-structure (name &rest slots) + (let ((pred (symbol-concat name '-p))) + (cons 'progn + (nconc + (list + (` (defun (, pred) (obj) + (and (vectorp obj) + (eq (elt obj 0) '(, name)) + )) + ) + (` (defun (, (symbol-concat name '/create)) (, slots) + (, (cons 'vector (cons (list 'quote name) slots))) + ) + )) + (let ((i 1)) + (mapcar (function + (lambda (slot) + (prog1 + (` (defun (, (symbol-concat name '/ slot)) (obj) + (if ((, pred) obj) + (elt obj (, i)) + )) + ) + (setq i (+ i 1)) + ) + )) slots) + ) + (list (list 'quote name)) + )))) + + +;;; @ end +;;; + +(provide 'tl-misc) + +;;; tl-misc.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tl-num.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tl-num.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,71 @@ +;;; +;;; $Id: tl-num.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; +;;; by MORIOKA Tomohiko , 1993/10/4 +;;; + +(require 'emu) +(require 'tl-seq) + + +;;; @ n base +;;; + +(defun char-to-int (chr) + "Convert n base character CHR to integer (n <= 36). [tl-num]" + (cond ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) + ((and (<= ?A chr)(<= chr ?Z)) (+ (- chr ?A) 10)) + ((and (<= ?a chr)(<= chr ?z)) (+ (- chr ?a) 10)) + )) + +(defun int-to-char (n) + "Convert integer N to n base character (n <= 36). [tl-num]" + (if (< n 10) + (+ ?0 n) + (+ ?A (- n 10)) + )) + +(defun base-seq-to-int (base seq) + "Convert n base number sequence SEQ to number. [tl-num]" + (foldl (function + (lambda (n m) + (+ (* n base) m) + )) + 0 seq)) + +(defun base-char-seq-to-int (base seq) + "Convert n base char sequence SEQ to number. [tl-num]" + (foldl (function + (lambda (n chr) + (+ (* n base)(char-to-int chr)) + )) + 0 seq)) + + +;;; @ Hex +;;; + +(defun hex-char-to-number (chr) + "Convert hex character CHR to number. [tl-num]" + (cond ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) + ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10)) + ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10)) + )) + +(defalias 'number-to-hex-char 'int-to-char) + +(defun hex-seq-to-int (seq) + "Convert hex number sequence SEQ to integer. [tl-num]" + (base-seq-to-int 16 seq) + ) + +(defun hex-char-seq-to-int (seq) + "Convert hex char sequence SEQ to integer. [tl-num]" + (base-char-seq-to-int 16 seq) + ) + + +;;; @ end +;;; + +(provide 'tl-num) diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tl-seq.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tl-seq.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,109 @@ +;;; tl-seq.el --- sequence functions + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: +;; $Id: tl-seq.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: sequence + +;; 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. + +;;; Code: + +(require 'file-detect) + +(cond ((file-installed-p "cl-seq.elc") + (require 'cl) + ) + (t + (defun find-if (pred seq) + "Return the first element of sequence SEQ satisfying PRED. +\[tl-seq.el]" + (let ((i 0)(len (length seq)) element) + (catch 'tag + (while (< i len) + (if (funcall pred (setq element (elt seq i))) + (throw 'tag element) + ) + (setq i (+ i 1)) + )) + )) + + (defun find (item seq) + "Return the first element which is found in sequence SEQ as item. +\[tl-seq.el]" + (find-if (function + (lambda (elt) + (eq elt item) + )) + seq)) + )) + +(defun foldr (func a seq) + "Return (func (func (func (... (func a Sn) ...) S2) S1) S0) +when func's argument is 2 and seq is a sequence whose +elements = S0 S1 S2 ... Sn. [tl-seq.el]" + (let ((i (length seq))) + (while (> i 0) + (setq i (1- i)) + (setq a (funcall func a (elt seq i))) + ) + a)) + +(defun foldl (func a seq) + "Return (... (func (func (func a S0) S1) S2) ...) +when func's argument is 2 and seq is a sequence whose +elements = S0 S1 S2 .... [tl-seq.el]" + (let ((len (length seq)) + (i 0)) + (while (< i len) + (setq a (funcall func a (elt seq i))) + (setq i (1+ i)) + ) + a)) + +(defun pack-sequence (seq size) + (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 'tl-seq) + +;;; tl-seq.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tl-str.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tl-str.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,343 @@ +;;; tl-str.el --- Emacs Lisp Library module about string + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: +;; $Id: tl-str.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: string + +;; 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 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 'tl-list) + + +;;; @ converter +;;; + +(defun expand-char-ranges (str) + (let ((i 0) + (len (length str)) + chr pchr nchr + (dest "")) + (while (< i len) + (setq chr (elt str i)) + (cond ((and pchr (eq chr ?-)) + (setq pchr (1+ pchr)) + (setq i (1+ i)) + (setq nchr (elt str i)) + (while (<= pchr nchr) + (setq dest (concat dest (char-to-string pchr))) + (setq pchr (1+ pchr)) + ) + ) + (t + (setq dest (concat dest (char-to-string chr))) + )) + (setq pchr chr) + (setq i (1+ i)) + ) + dest)) + + +;;; @ space +;;; + +(defun eliminate-top-spaces (str) + "Eliminate top sequence of space or tab and return it. [tl-str.el]" + (if (string-match "^[ \t]+" str) + (substring str (match-end 0)) + str)) + +(defun eliminate-last-spaces (str) + "Eliminate last sequence of space or tab and return it. [tl-str.el]" + (if (string-match "[ \t]+$" str) + (substring str 0 (match-beginning 0)) + str)) + +(defun replace-space-with-underline (str) + (mapconcat (function + (lambda (arg) + (char-to-string + (if (eq arg ?\ ) + ?_ + arg)))) str "") + ) + + +;;; @ version +;;; + +(defun version-to-list (str) + (if (string-match "[0-9]+" str) + (let ((dest + (list + (string-to-number + (substring str (match-beginning 0)(match-end 0)) + )))) + (setq str (substring str (match-end 0))) + (while (string-match "^\\.[0-9]+" str) + (setq dest + (cons + (string-to-number + (substring str (1+ (match-beginning 0))(match-end 0))) + dest)) + (setq str (substring str (match-end 0))) + ) + (nreverse dest) + ))) + +(defun version< (v1 v2) + (or (listp v1) + (setq v1 (version-to-list v1)) + ) + (or (listp v2) + (setq v2 (version-to-list v2)) + ) + (catch 'tag + (while (and v1 v2) + (cond ((< (car v1)(car v2)) + (throw 'tag v2) + ) + ((> (car v1)(car v2)) + (throw 'tag nil) + )) + (setq v1 (cdr v1) + v2 (cdr v2)) + ) + v2)) + +(defun version<= (v1 v2) + (or (listp v1) + (setq v1 (version-to-list v1)) + ) + (or (listp v2) + (setq v2 (version-to-list v2)) + ) + (catch 'tag + (while (and v1 v2) + (cond ((< (car v1)(car v2)) + (throw 'tag v2) + ) + ((> (car v1)(car v2)) + (throw 'tag nil) + )) + (setq v1 (cdr v1) + v2 (cdr v2)) + ) + (or v2 (and (null v1)(null v2))) + )) + +(defun version> (v1 v2) + (or (listp v1) + (setq v1 (version-to-list v1)) + ) + (or (listp v2) + (setq v2 (version-to-list v2)) + ) + (catch 'tag + (while (and v1 v2) + (cond ((> (car v1)(car v2)) + (throw 'tag v1) + ) + ((< (car v1)(car v2)) + (throw 'tag nil) + )) + (setq v1 (cdr v1) + v2 (cdr v2)) + ) + v1)) + +(defun version>= (v1 v2) + (or (listp v1) + (setq v1 (version-to-list v1)) + ) + (or (listp v2) + (setq v2 (version-to-list v2)) + ) + (catch 'tag + (while (and v1 v2) + (cond ((> (car v1)(car v2)) + (throw 'tag v1) + ) + ((< (car v1)(car v2)) + (throw 'tag nil) + )) + (setq v1 (cdr v1) + v2 (cdr v2)) + ) + (or v1 (and (null v1)(null v2))) + )) + + +;;; @ RCS version +;;; + +(defun get-version-string (id) + "Return a version-string from RCS ID. [tl-str.el]" + (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id) + (substring id (match-beginning 1)(match-end 1)) + )) + + +;;; @ file name +;;; + +(defun file-name-non-extension (filename) + (if (string-match "\\.[^.]+$" filename) + (substring filename 0 (match-beginning 0)) + filename)) + +(defvar filename-special-char-range + (nconc '((0 . 31)) + (string-to-int-list "!\"$") + (list (cons (char-int ?&) (char-int ?*))) + (string-to-int-list "/;<>?") + (list (cons (char-int ?\[) (char-int ?^))) + (string-to-int-list "`") + (list (cons (char-int ?{) (char-int ?}))) + '((127 . 159))) + "*Range of characters which is not available in file name. [tl-str.el]") + +(defvar filename-space-char-range '(9 32 160) + "*Range of characters which indicates space. These characters +are replaced to `_' by function `replace-as-filename' [tl-str.el]") + +(defun replace-as-filename (str) + "Return safety filename from STR. [tl-str.el]" + (let (sf) + (mapconcat (function + (lambda (chr) + (cond ((member-of-range chr filename-space-char-range) + (if sf + "" + (setq sf t) + "_")) + ((member-of-range chr filename-special-char-range) + "") + (t + (setq sf nil) + (char-to-string chr) + )) + )) + (string-to-char-list str) + ""))) + + +;;; @ symbol +;;; + +(defun symbol-concat (&rest args) + "Return a symbol whose name is concatenation of arguments ARGS +which are string or symbol. [tl-str.el]" + (intern (apply (function concat) + (mapcar (function + (lambda (s) + (cond ((symbolp s) (symbol-name s)) + ((stringp s) s) + ) + )) + args))) + ) + + +;;; @ matching +;;; + +(defun top-string-match (pat str) + "Return a list (MATCHED REST) if string PAT is top substring of +string STR. [tl-str.el]" + (if (string-match + (concat "^" (regexp-quote pat)) + str) + (list pat (substring str (match-end 0))) + )) + +(defun middle-string-match (pat str) + "Return a list (PREVIOUS MATCHED REST) if string PAT is found in +string STR. [tl-str.el]" + (if (equal pat str) + (list nil pat nil) + (if (string-match (regexp-quote pat) str) + (let ((b (match-beginning 0)) + (e (match-end 0)) ) + (list (if (not (= b 0)) + (substring str 0 b) + ) + pat + (if (> (length str) e) + (substring str e) + ) + ))))) + +(defun re-top-string-match (pat str) + "Return a list (MATCHED REST) if regexp PAT is matched as top +substring of string STR. [tl-str.el]" + (if (string-match (concat "^" pat) str) + (let ((e (match-end 0))) + (list (substring str 0 e)(substring str e)) + ))) + + +;;; @ compare +;;; + +(defun string-compare-from-top (str1 str2) + (let* ((len1 (length str1)) + (len2 (length str2)) + (len (min len1 len2)) + (p 0) + c1 c2) + (while (and (< p len) + (progn + (setq c1 (sref str1 p) + c2 (sref str2 p)) + (eq c1 c2) + )) + (setq p (+ p (char-length c1))) + ) + (and (> p 0) + (let ((matched (substring str1 0 p)) + (r1 (and (< p len1)(substring str1 p))) + (r2 (and (< p len2)(substring str2 p))) + ) + (if (eq r1 r2) + matched + (list 'seq matched (list 'or r1 r2)) + ))))) + + +;;; @ regexp +;;; + +(defun regexp-* (regexp) + (concat regexp "*")) + +(defun regexp-or (&rest args) + (concat "\\(" (mapconcat (function identity) args "\\|") "\\)")) + + +;;; @ end +;;; + +(provide 'tl-str) + +;;; tl-str.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tu-comment.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tu-comment.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,128 @@ +;;; tu-comment.el --- a comment out utility for Lisp programs. + +;; Copyright (C) 1995,1996 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Created: 1995/10/27 +;; Version: $Id: tu-comment.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: comment, Lisp + +;; 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 install. +;; 1. bytecompile this file and copy it to the apropriate directory. +;; 2. put the following lines to your ~/.emacs: +;; (autoload 'comment-sexp "tu-comment" nil t) +;; (global-set-key "\C-c\C-q" 'comment-sexp) +;; - How to use. +;; type `C-c C-q' at the beginning of S-expression you want to +;; comment out. + +;;; Code: + +(defvar comment-sexp-first-line-method-alist + '((emacs-lisp-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-interaction-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-mode . comment-sexp-middle-line-method-for-lisp) + (scheme-mode . comment-sexp-middle-line-method-for-lisp) + (c-mode . comment-sexp-first-line-method-for-c) + (c++-mode . comment-sexp-middle-line-method-for-c++) + )) + +(defvar comment-sexp-middle-line-method-alist + '((emacs-lisp-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-interaction-mode . comment-sexp-middle-line-method-for-lisp) + (lisp-mode . comment-sexp-middle-line-method-for-lisp) + (scheme-mode . comment-sexp-middle-line-method-for-lisp) + (c-mode . comment-sexp-middle-line-method-for-c) + (c++-mode . comment-sexp-middle-line-method-for-c++) + )) + +(defvar comment-sexp-last-line-method-alist + '((emacs-lisp-mode . comment-sexp-last-line-method-for-dummy) + (lisp-interaction-mode . comment-sexp-last-line-method-for-dummy) + (lisp-mode . comment-sexp-last-line-method-for-dummy) + (scheme-mode . comment-sexp-last-line-method-for-dummy) + (c-mode . comment-sexp-last-line-method-for-c) + (c++-mode . comment-sexp-last-line-method-for-dummy) + )) + +(defun comment-sexp-middle-line-method-for-lisp () + (insert ";; ") + ) + +(defun comment-sexp-middle-line-method-for-c++ () + (insert "// ") + ) + +(defun comment-sexp-first-line-method-for-c () + (insert "/* ") + ) + +(defun comment-sexp-middle-line-method-for-c () + (insert " * ") + ) + +(defun comment-sexp-last-line-method-for-c (c) + (insert "\n") + (while (< 0 c) + (insert " ") + (setq c (1- c)) + ) + (insert " */") + ) + +(defun comment-sexp-last-line-method-for-dummy (c)) + +(defun comment-sexp () + (interactive) + (let ((c (current-column)) + (b (save-excursion + (beginning-of-line) + (point))) + (e (save-excursion + (forward-sexp) + (point) + )) + ) + (save-excursion + (save-restriction + (narrow-to-region b e) + (untabify b e) + + (beginning-of-line) + (move-to-column c) + (funcall + (cdr (assq major-mode comment-sexp-first-line-method-alist))) + (forward-line) + + (while (< (point) (point-max)) + (beginning-of-line) + (move-to-column c) + (funcall + (cdr (assq major-mode comment-sexp-middle-line-method-alist))) + (forward-line) + ) + + (funcall + (cdr (assq major-mode comment-sexp-last-line-method-alist)) c) + )))) + +;;; tu-comment.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tl/tu-replace.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tl/tu-replace.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,84 @@ +;;; tu-replace.el --- a replacing utility for GNU Emacs + +;; Copyright (C) 1995,1996 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Version: $Id: tu-replace.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: replace + +;; 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 install. +;; 1. bytecompile this file and copy it to the apropriate directory. +;; 2. put the following lines to your ~/.emacs: +;; (autoload 'edit-replace-region "tu-replace" nil t) +;; - How to use. +;; 1. mark in beginning of region you want to replace. +;; 2. go to end of region you want to replace. +;; 3. type M-x edit-replace-region [CR] +;; then entering to ``edit-replace mode''. +;; 4. edit replacement string. +;; 5. type C-c C-c then specified region will be replaced. + +;;; Code: + +(defvar edit-replace-mode-map nil) +(if (null edit-replace-mode-map) + (progn + (setq edit-replace-mode-map (copy-keymap text-mode-map)) + (define-key edit-replace-mode-map + "\C-c\C-c" (function edit-replace-query-replace)) + )) + +(make-variable-buffer-local 'edit-replace-original-buffer) +(make-variable-buffer-local 'edit-replace-start-point) +(make-variable-buffer-local 'edit-replace-end-point) + +(defvar edit-replace-original-buffer nil) +(defvar edit-replace-start-point nil) +(defvar edit-replace-end-point nil) + +(defun edit-replace-region (beg end &optional str) + (interactive "r") + (let ((the-buf (current-buffer)) + (buf (get-buffer-create " *edit-replace*"))) + (pop-to-buffer buf) + (setq major-mode 'edit-replace) + (setq mode-name "edit for replace") + (use-local-map edit-replace-mode-map) + (setq edit-replace-original-buffer the-buf) + (setq edit-replace-start-point beg) + (setq edit-replace-end-point end) + )) + +(defun edit-replace-query-replace () + (interactive) + (let ((beg edit-replace-start-point) + (end edit-replace-end-point) + str + (rstr (buffer-string)) + ) + (switch-to-buffer edit-replace-original-buffer) + (setq str (buffer-substring beg end)) + (goto-char beg) + (query-replace str rstr) + )) + +;;; tu-replace.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/gnus-art-mime.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/gnus-art-mime.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,170 @@ +;;; gnus-art-mime.el --- MIME extension for article mode of Gnus + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/8/6 +;; Version: +;; $Id: gnus-art-mime.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: news, MIME, multimedia, multilingual, encoded-word + +;; This file is not part of GNU Emacs 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 'gnus-mime) +(require 'gnus-art) +(require 'tm-view) + +(autoload 'mime-eword/decode-region "tm-ew-d" + "Decode MIME encoded-words in region." t) +(autoload 'mime/decode-message-header "tm-ew-d" + "Decode MIME encoded-words in message header." t) + + +;;; @ encoded-word +;;; + +;;; `gnus-decode-rfc1522' of Gnus works only Q-encoded iso-8859-1 +;;; encoded-words. In addition, it does not apply decoding rule of +;;; RFC 1522 and it does not do unfolding. So gnus-mime defines own +;;; function using tm-ew-d. + +(defun gnus-decode-rfc1522 () + (goto-char (point-min)) + (if (re-search-forward "^[0-9]+\t" nil t) + (progn + (goto-char (point-min)) + ;; for XOVER + (while (re-search-forward "^[0-9]+\t\\([^\t]+\\)\t" nil t) + (mime-eword/decode-region (match-beginning 1) (match-end 1) + 'unfolding 'must-unfold) + (if (re-search-forward "[^\t]+" nil t) + (mime-eword/decode-region (match-beginning 0)(match-end 0) + 'unfolding 'must-unfold) + ) + )) + (mime-eword/decode-region (point-min)(point-max) t) + )) + + +;;; @ article filter +;;; + +(defun gnus-article-preview-mime-message () + (make-local-variable 'tm:mother-button-dispatcher) + (setq tm:mother-button-dispatcher + (function gnus-article-push-button)) + (let ((mime-viewer/ignored-field-regexp "^:$") + (default-mime-charset + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)) + ) + (save-window-excursion + (mime/viewer-mode nil nil nil gnus-original-article-buffer + gnus-article-buffer + gnus-article-mode-map) + )) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + +(defun gnus-article-decode-encoded-word () + (decode-mime-charset-region (point-min)(point-max) + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)) + (mime/decode-message-header) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + + +;;; @ for tm-view +;;; + +(defun gnus-content-header-filter () + (goto-char (point-min)) + (mime-preview/cut-header) + (decode-mime-charset-region (point-min)(point-max) default-mime-charset) + (mime/decode-message-header) + ) + +(defun mime-viewer/quitting-method-for-gnus () + (if (not gnus-show-mime) + (mime-viewer/kill-buffer)) + (delete-other-windows) + (gnus-article-show-summary) + (if (or (not gnus-show-mime) + (null gnus-have-all-headers)) + (gnus-summary-select-article nil t) + )) + +(call-after-loaded + 'tm-view + (lambda () + (set-alist 'mime-viewer/content-header-filter-alist + 'gnus-original-article-mode + (function gnus-content-header-filter)) + + (set-alist 'mime-viewer/code-converter-alist + 'gnus-original-article-mode + (function mime-charset/decode-buffer)) + + (set-alist 'mime-viewer/quitting-method-alist + 'gnus-original-article-mode + (function mime-viewer/quitting-method-for-gnus)) + + (set-alist 'mime-viewer/show-summary-method + 'gnus-original-article-mode + (function mime-viewer/quitting-method-for-gnus)) + )) + + +;;; @ for BBDB +;;; + +(call-after-loaded + 'bbdb + (function + (lambda () + (require 'tm-bbdb) + ))) + +(autoload 'tm-bbdb/update-record "tm-bbdb") + +(defun tm-gnus/bbdb-setup () + (if (and (boundp 'gnus-article-prepare-hook) + (memq 'bbdb/gnus-update-record gnus-article-prepare-hook) + ) + (progn + (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record) + (add-hook 'gnus-article-display-hook 'tm-bbdb/update-record) + ))) + +(add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t) + +(tm-gnus/bbdb-setup) + + +;;; @ end +;;; + +(provide 'gnus-art-mime) + +;;; gnus-art-mime.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/gnus-charset.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/gnus-charset.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,150 @@ +;;; gnus-charset.el --- MIME charset extension for Gnus + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/8/6 +;; Version: +;; $Id: gnus-charset.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: news, MIME, multimedia, multilingual, encoded-word + +;; This file is not part of GNU Emacs 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 'gnus) + +(defvar gnus-is-red-gnus-or-later + (or (featurep 'gnus-load) + (module-installed-p 'gnus-sum) + )) + + +;;; @ newsgroup default charset +;;; + +(defvar gnus-newsgroup-default-charset-alist nil) + +(defun gnus-set-newsgroup-default-charset (newsgroup charset) + "Set CHARSET for the NEWSGROUP as default MIME charset." + (let* ((ng-regexp (concat "^" (regexp-quote newsgroup) "\\($\\|\\.\\)")) + (pair (assoc ng-regexp gnus-newsgroup-default-charset-alist)) + ) + (if pair + (setcdr pair charset) + (setq gnus-newsgroup-default-charset-alist + (cons (cons ng-regexp charset) + gnus-newsgroup-default-charset-alist)) + ))) + + +;;; @ for mule (Multilingual support) +;;; + +(cond + ((featurep 'mule) + (require 'emu) + (defvar nntp-open-binary-connection-function + (if gnus-is-red-gnus-or-later + ;; maybe Red Gnus + (if (boundp 'nntp-open-connection-function) + nntp-open-connection-function + 'nntp-open-network-stream) + ;; maybe Gnus 5.[01] or Gnus 5.[23] + (if (boundp 'nntp-open-server-function) + nntp-open-server-function + 'nntp-open-network-stream) + )) + (defun nntp-open-network-stream-with-no-code-conversion (&rest args) + (let ((proc (apply nntp-open-binary-connection-function args))) + (set-process-input-coding-system proc *noconv*) + proc)) + (if gnus-is-red-gnus-or-later + (setq nntp-open-connection-function + 'nntp-open-network-stream-with-no-code-conversion) + (setq nntp-open-server-function + 'nntp-open-network-stream-with-no-code-conversion) + ) + (call-after-loaded + 'nnheader + (lambda () + (defun nnheader-find-file-noselect (&rest args) + (as-binary-input-file + (let ((format-alist nil) + (auto-mode-alist (nnheader-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (after-insert-file-functions nil)) + (apply 'find-file-noselect args))) + ) + ;; Red Gnus 0.67 or later + (defun nnheader-insert-file-contents + (filename &optional visit beg end replace) + (as-binary-input-file + (let ((format-alist nil) + (auto-mode-alist (nnheader-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (after-insert-file-functions nil)) + (insert-file-contents filename visit beg end replace)) + )) + ;; alias for Old Gnus + (defalias 'nnheader-insert-file-contents-literally + 'nnheader-insert-file-contents) + )) + (call-after-loaded + 'nnmail + (lambda () + (defun nnmail-find-file (file) + "Insert FILE in server buffer safely. [gnus-charset.el]" + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((format-alist nil) + (after-insert-file-functions ; for jam-code-guess + (if (memq 'jam-code-guess-after-insert-file-function + after-insert-file-functions) + '(jam-code-guess-after-insert-file-function))) + ) + (as-binary-input-file + (condition-case () + (progn (insert-file-contents file) t) + (file-error nil)) + ))) + )) + (defun gnus-prepare-save-mail-function () + (setq file-coding-system *noconv* + coding-system-for-write 'no-conversion) + ) + (add-hook 'nnmail-prepare-save-mail-hook + 'gnus-prepare-save-mail-function) + + (gnus-set-newsgroup-default-charset "alt.chinese" 'hz-gb-2312) + (gnus-set-newsgroup-default-charset "alt.chinese.text.big5" 'cn-big5) + (gnus-set-newsgroup-default-charset "fj" 'iso-2022-jp-2) + (gnus-set-newsgroup-default-charset "han" 'euc-kr) + (gnus-set-newsgroup-default-charset "hk" 'cn-big5) + (gnus-set-newsgroup-default-charset "hkstar" 'cn-big5) + (gnus-set-newsgroup-default-charset "relcom" 'koi8-r) + (gnus-set-newsgroup-default-charset "tw" 'cn-big5) + )) + + +;;; @ end +;;; + +(provide 'gnus-charset) + +;;; gnus-charset.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/gnus-mime-old.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/gnus-mime-old.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,84 @@ +;;; gnus-mime-old.el --- MIME extensions for Gnus 5.[01] and 5.[23] + +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/9/4 +;; Version: +;; $Id: gnus-mime-old.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: news, MIME, multimedia, multilingual, encoded-word + +;; This file is not part of GNU Emacs 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 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. + +;;; Code: + +(require 'gnus-mime) + +(provide 'gnus-sum) +(provide 'gnus-art) + +(or (boundp 'gnus-original-article-buffer) + (progn + ;; for Gnus 5.0.* and 5.1 + (defvar gnus-original-article-buffer " *Original Article*") + + (defun gnus-article-setup-original-article-buffer () + (save-excursion + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (erase-buffer) + (insert-buffer gnus-article-buffer) + (setq major-mode 'gnus-original-article-mode) + )) + + (add-hook 'gnus-article-prepare-hook + 'gnus-article-setup-original-article-buffer) + + (setq gnus-strict-mime nil) + )) + +(if running-xemacs + (progn + ;; modified by Steven L. Baur + ;; 1995/12/6 (c.f. [tm-en:209]) + (defun mime-editor/attach-to-news-reply-menu () + "Arrange to attach MIME editor's popup menu to VM's" + (if (boundp 'news-reply-menu) + (progn + (setq news-reply-menu + (append news-reply-menu + '("---") + mime-editor/popup-menu-for-xemacs)) + (remove-hook 'news-setup-hook + 'mime-editor/attach-to-news-reply-menu) + ))) + (call-after-loaded + 'tm-edit + (function + (lambda () + (add-hook 'news-setup-hook + 'mime-editor/attach-to-news-reply-menu) + ))) + )) + + +;;; @ end +;;; + +(provide 'gnus-mime-old) + +;;; gnus-mime-old.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/gnus-mime.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/gnus-mime.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,118 @@ +;;; gnus-mime.el --- MIME extensions for Gnus + +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/8/6 +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: news, MIME, multimedia, multilingual, encoded-word + +;; This file is not part of GNU Emacs 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 'tl-misc) + + +;;; @ version +;;; + +(defconst gnus-mime-RCS-ID + "$Id: gnus-mime.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $") + +(defconst gnus-mime-version + (get-version-string gnus-mime-RCS-ID)) + + +;;; @ variables +;;; + +(defvar gnus-show-mime t + "*If non-nil, do mime processing of articles. +The articles will simply be fed to the function given by +`gnus-show-mime-method'.") + +(defvar gnus-show-mime-method 'gnus-article-preview-mime-message + "*Function to process a MIME message. +The function is called from the article buffer.") + +(defvar gnus-decode-encoded-word-method 'gnus-article-decode-encoded-word + "*Function to decode a MIME encoded-words. +The function is called from the article buffer.") + +(defvar gnus-parse-headers-hook + '(gnus-set-summary-default-charset gnus-decode-rfc1522) + "*A hook called before parsing the headers.") + + +;;; @ load +;;; + +(require 'gnus) +(autoload 'gnus-decode-rfc1522 "gnus-art-mime") +(autoload 'gnus-article-preview-mime-message "gnus-art-mime") +(autoload 'gnus-article-decode-encoded-word "gnus-art-mime") +(autoload 'gnus-set-summary-default-charset "gnus-sum-mime") +;;(autoload 'gnus-get-newsgroup-headers "gnus-sum-mime") +;;(autoload 'gnus-get-newsgroup-headers-xover "gnus-sum-mime") +(require 'gnus-charset) + + +;;; @ for tm-partial +;;; + +(defun gnus-mime-partial-preview-function () + (gnus-summary-preview-mime-message (gnus-summary-article-number)) + ) + +(call-after-loaded + 'tm-partial + (function + (lambda () + (set-atype 'mime/content-decoding-condition + '((type . "message/partial") + (method . mime-article/grab-message/partials) + (major-mode . gnus-original-article-mode) + (summary-buffer-exp . gnus-summary-buffer) + )) + (set-alist 'tm-partial/preview-article-method-alist + 'gnus-original-article-mode + 'gnus-mime-partial-preview-function) + ))) + + +;;; @ end +;;; + +(provide 'gnus-mime) + +(if gnus-is-red-gnus-or-later + (progn + (call-after-loaded 'gnus-art (lambda () + (require 'gnus-art-mime) + )) + (call-after-loaded 'gnus-sum (lambda () + (require 'gnus-sum-mime) + )) + ) + (require 'gnus-mime-old) + ) + +(run-hooks 'gnus-mime-load-hook) + +;;; gnus-mime.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/gnus-msg-mime.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/gnus-msg-mime.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,57 @@ +;;; gnus-msg-mime.el --- MIME extension for mail and post interface of Gnus + +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/8/8 +;; Version: +;; $Id: gnus-msg-mime.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: news, MIME, multimedia, multilingual, encoded-word + +;; This file is not part of GNU Emacs 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 This program. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Code: + +(require 'gnus-msg) + +(defun gnus-copy-article-buffer-with-no-filter () + ;; make a copy of the article buffer with all text properties removed + ;; this copy is in the buffer gnus-article-copy. + ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used + ;; this buffer should be passed to all mail/news reply/post routines. + (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) + (buffer-disable-undo gnus-article-copy) + (or (memq gnus-article-copy gnus-buffer-list) + (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list))) + (let (mime-viewer/plain-text-preview-hook + (mime-viewer/ignored-field-regexp "^:$")) + (save-window-excursion + (mime/viewer-mode nil nil nil + gnus-original-article-buffer gnus-article-copy) + ) + gnus-article-copy)) + + +;;(fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-with-no-filter) + + +;;; @ end +;;; + +(provide 'gnus-msg-mime) + +;;; gnus-msg-mime.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/gnus-sum-mime.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/gnus-sum-mime.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,104 @@ +;;; gnus-sum-mime.el --- MIME extension for summary mode of Gnus + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/8/6 +;; Version: +;; $Id: gnus-sum-mime.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: news, MIME, multimedia, multilingual, encoded-word + +;; This file is not part of GNU Emacs 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 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. + +;;; Code: + +(require 'gnus-mime) +(require 'gnus-art-mime) + + +;;; @ summary filter +;;; + +(defun gnus-set-summary-default-charset () + (let ((charset + (if (buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((ret (assoc-if (function + (lambda (key) + (string-match key gnus-newsgroup-name) + )) + gnus-newsgroup-default-charset-alist) + )) + (if ret + (progn + (make-local-variable 'default-mime-charset) + (setq default-mime-charset (cdr ret)) + )) + ) + default-mime-charset) + default-mime-charset))) + (goto-char (point-min)) + (while (< (point)(point-max)) + (decode-mime-charset-region (point) + (progn + (end-of-line) + (point)) + charset) + (end-of-line) + (forward-char) + ))) + + +;;; @ command functions +;;; + +(defun gnus-summary-preview-mime-message (arg) + "MIME decode and play this message." + (interactive "P") + (let ((gnus-break-pages nil)) + (gnus-summary-select-article t t) + ) + (pop-to-buffer gnus-original-article-buffer t) + (let (buffer-read-only) + (if (text-property-any (point-min) (point-max) 'invisible t) + (remove-text-properties (point-min) (point-max) + gnus-hidden-properties) + )) + (mime/viewer-mode nil nil nil gnus-original-article-buffer + gnus-article-buffer) + ) + +(defun gnus-summary-scroll-down () + "Scroll down one line current article." + (interactive) + (gnus-summary-scroll-up -1) + ) + +(define-key gnus-summary-mode-map "v" + (function gnus-summary-preview-mime-message)) +(define-key gnus-summary-mode-map "\e\r" + (function gnus-summary-scroll-down)) + + +;;; @ end +;;; + +(provide 'gnus-sum-mime) + +;;; gnus-sum-mime.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/message-mime.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/message-mime.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,77 @@ +;;; message-mime.el --- MIME extensions for message.el + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/8/6 +;; Version: +;; $Id: message-mime.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: news, MIME, multimedia, multilingual, encoded-word + +;; This file is not part of GNU Emacs 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 This program. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Code: + +(require 'tm-edit) + +(setq message-forward-start-separator + (concat (mime-make-tag "message" "rfc822") "\n")) + +(setq message-forward-end-separator "") + +(or (string-match message-included-forward-headers "Mime-Version:") + (setq message-included-forward-headers + (concat message-included-forward-headers "\\|^Mime-Version:")) + ) + +(or (string-match message-included-forward-headers "Content-Type:") + (setq message-included-forward-headers + (concat message-included-forward-headers "\\|^Content-Type:")) + ) + + +;;; @ for tm-edit +;;; + +;; suggested by OKABE Yasuo +;; 1995/11/08 (c.f. [tm ML:1067]) +(defun message-mime-insert-article (&optional message) + (interactive) + (let ((message-cite-function 'mime-editor/inserted-message-filter) + (message-reply-buffer gnus-original-article-buffer) + ) + (message-yank-original nil) + )) + +(set-alist 'mime-editor/message-inserter-alist + 'message-mode (function message-mime-insert-article)) +(set-alist 'mime-editor/split-message-sender-alist + 'message-mode + (lambda () + (interactive) + (let (message-send-hook + message-sent-message-via) + (message-send) + ))) + + +;;; @ end +;;; + +(provide 'message-mime) + +;;; message-mime.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/sc-setup.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/sc-setup.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,77 @@ +;;; +;;; $Id: sc-setup.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; + +(require 'emu) + + +;;; @ for Super Cite +;;; + +(if (< emacs-major-version 19) + (autoload 'sc-cite-original "sc" nil t) + (autoload 'sc-cite-original "supercite" "supercite 3.1" t) + (autoload 'sc-submit-bug-report "supercite" "Supercite 3.1" t) + ) + +(setq sc-citation-leader "") + +(cond ((boundp 'MULE) + ;; for MULE + (setq sc-cite-regexp "\\s *\\([a-zA-Z0-9]\\|\\cj\\)*>+\\s *") + ) + ((boundp 'NEMACS) + ;; for Nemacs + (setq sc-cite-regexp + "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*>+\\s *") + )) + +(if (< emacs-major-version 19) + (progn + (defun my-sc-overload-hook () + (require 'sc-oloads) + (sc-overload-functions) + ) + + ;; @@ for all but mh-e + ;; + (setq mail-yank-hooks (function sc-cite-original)) + + ;; @@ for RMAIL, PCMAIL, GNUS + ;; + (add-hook 'mail-setup-hook (function my-sc-overload-hook)) + + ;; @@ for Gnus + ;; + (add-hook 'news-reply-mode-hook (function my-sc-overload-hook)) + (add-hook 'gnews-ready-hook (function my-sc-overload-hook)) + + ;; @@ for mh-e + ;; + (add-hook 'mh-letter-mode-hook (function my-sc-overload-hook)) + (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only + ) + (add-hook 'mail-citation-hook 'sc-cite-original) + (setq news-reply-header-hook nil) + ) + + +;;; @ for sc-register +;;; +;; (setq sc-load-hook +;; '(lambda () +;; (require 'sc-register) +;; (setq sc-rewrite-header-list +;; (append sc-rewrite-header-list +;; (list (list 'sc-header-in-Japanese)) +;; )) +;; (setq sc-preferred-header-style +;; (- (length sc-rewrite-header-list) 1)) +;; )) +(setq sc-preferred-attribution 'registeredname) + + +;;; @ end +;;; + +(provide 'sc-setup) diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/signature.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/signature.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,160 @@ +;;; signature.el --- a signature utility for GNU Emacs + +;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; OKABE Yasuo +;; Artur Pioro +;; KOBAYASHI Shuhei +;; Maintainer: Shuhei KOBAYASHI +;; Created: 1994/7/11 +;; Version: +;; $Id: signature.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: mail, news, signature + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with 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. + +;;; Code: + +(require 'std11) + + +;;; @ valiables +;;; + +(defvar signature-insert-at-eof nil + "*If non-nil, insert signature at the end of file.") + +(defvar signature-delete-blank-lines-at-eof nil + "*If non-nil, signature-insert-at-eof deletes blank lines at the end +of file.") + +(defvar signature-load-hook nil + "*List of functions called after signature.el is loaded.") + +(defvar signature-file-name "~/.signature" + "*Name of file containing the user's signature.") + +(defvar signature-file-alist nil) + +(defvar signature-file-prefix nil + "*String containing optional prefix for the signature file names") + +(defvar signature-insert-hook nil + "*List of functions called before inserting a signature.") + +(defvar signature-use-bbdb nil + "*If non-nil, Register sigtype to BBDB.") + +;;; +;;; Example: +;;; +;;; (setq signature-file-alist +;;; '((("Newsgroups" . "zxr") . "~/.signature-sun") +;;; (("To" . "uramimi") . "~/.signature-sun") +;;; (("Newsgroups" . "jokes") . "~/.signature-jokes") +;;; (("To" . "tea") . "~/.signature-jokes") +;;; (("To" . ("sim" "oku")) . "~/.signature-formal") +;;; )) + +(autoload 'signature/get-sigtype-from-bbdb "tm-bbdb") + +(defun signature/get-sigtype-interactively (&optional default) + (read-file-name "Insert your signature: " + (or default (concat signature-file-name "-")) + (or default signature-file-name) + nil)) + +(defun signature/get-signature-file-name () + (save-excursion + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (match-beginning 0) + (point-max) + )) + (catch 'found + (let ((alist signature-file-alist) cell field value) + (while alist + (setq cell (car alist) + field (std11-field-body (car (car cell))) + value (cdr (car cell))) + (cond ((functionp value) + (let ((name (apply value field (cdr cell)))) + (if name + (throw 'found + (concat signature-file-prefix name)) + ))) + ((stringp field) + (cond ((consp value) + (while value + (if (string-match (car value) field) + (throw 'found + (concat + signature-file-prefix (cdr cell))) + (setq value (cdr value)) + ))) + ((stringp value) + (if (string-match value field) + (throw 'found + (concat + signature-file-prefix (cdr cell))) + ))))) + (setq alist (cdr alist)) + )) + signature-file-name)))) + +(defun insert-signature (&optional arg) + "Insert the file named by signature-file-name. +It is inserted at the end of file if signature-insert-at-eof is non-nil, +and otherwise at the current point. A prefix argument enables user to +specify a file named -DISTRIBUTION interactively." + (interactive "P") + (let ((signature-file-name + (expand-file-name + (or (and signature-use-bbdb + (signature/get-sigtype-from-bbdb arg)) + (and arg + (signature/get-sigtype-interactively)) + (signature/get-signature-file-name)) + ))) + (or (file-readable-p signature-file-name) + (error "Cannot open signature file: %s" signature-file-name)) + (if signature-insert-at-eof + (progn + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (if signature-delete-blank-lines-at-eof (delete-blank-lines)) + )) + (run-hooks 'signature-insert-hook) + (insert-file-contents signature-file-name) + (force-mode-line-update) + signature-file-name)) + + +;;; @ end +;;; + +(provide 'signature) + +(run-hooks 'signature-load-hook) + +;;; signature.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-bbdb.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-bbdb.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,271 @@ +;;; tm-bbdb.el --- tm shared module for BBDB + +;; Copyright (C) 1995,1996 Shuhei KOBAYASHI +;; Copyright (C) 1996 Artur Pioro + +;; Author: Shuhei KOBAYASHI +;; Artur Pioro +;; Maintainer: Shuhei KOBAYASHI +;; Version: $Id: tm-bbdb.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, multilingual, BBDB + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'std11) +(require 'tm-ew-d) +(require 'tm-view) +(require 'bbdb-com) ; (require 'bbdb) implicitly + +;;; @ mail-extr +;;; + +(defvar tm-bbdb/use-mail-extr t) + +(defun tm-bbdb/extract-address-components (str) + (let* ((ret (std11-extract-address-components str)) + (phrase (car ret)) + (address (car (cdr ret))) + (methods tm-bbdb/canonicalize-full-name-methods)) + (while (and phrase methods) + (setq phrase (funcall (car methods) phrase) + methods (cdr methods))) + (if (string= address "") (setq address nil)) + (if (string= phrase "") (setq phrase nil)) + (list phrase address) + )) + +(or tm-bbdb/use-mail-extr + (progn + (require 'mail-extr) ; for `what-domain' + (or (fboundp 'tm:mail-extract-address-components) + (fset 'tm:mail-extract-address-components + (symbol-function 'mail-extract-address-components))) + (fset 'mail-extract-address-components + (symbol-function 'tm-bbdb/extract-address-components)) + )) + + +;;; @ bbdb-extract-field-value +;;; + +(or (fboundp 'tm:bbdb-extract-field-value) + (progn + ;; (require 'bbdb-hooks) ; not provided. + ;; (or (fboundp 'bbdb-extract-field-value) ; defined as autoload + (or (fboundp 'bbdb-header-start) + (load "bbdb-hooks")) + (fset 'tm:bbdb-extract-field-value + (symbol-function 'bbdb-extract-field-value)) + (defun bbdb-extract-field-value (field) + (let ((value (tm:bbdb-extract-field-value field))) + (and value + (mime-eword/decode-string value)))) + )) + + +;;; @ full-name canonicalization methods +;;; + +(defun tm-bbdb/canonicalize-spaces (str) + (let (dest) + (while (string-match "\\s +" str) + (setq dest (cons (substring str 0 (match-beginning 0)) dest)) + (setq str (substring str (match-end 0))) + ) + (or (string= str "") + (setq dest (cons str dest))) + (setq dest (nreverse dest)) + (mapconcat 'identity dest " ") + )) + +(defun tm-bbdb/canonicalize-dots (str) + (let (dest) + (while (string-match "\\." str) + (setq dest (cons (substring str 0 (match-end 0)) dest)) + (setq str (substring str (match-end 0))) + ) + (or (string= str "") + (setq dest (cons str dest))) + (setq dest (nreverse dest)) + (mapconcat 'identity dest " ") + )) + +(defvar tm-bbdb/canonicalize-full-name-methods + '(mime-eword/decode-string + tm-bbdb/canonicalize-dots + tm-bbdb/canonicalize-spaces)) + + +;;; @ BBDB functions for mime/viewer-mode +;;; + +(defvar tm-bbdb/auto-create-p nil) + +(defun tm-bbdb/update-record (&optional offer-to-create) + "Return the record corresponding to the current MIME previewing message. +Creating or modifying it as necessary. A record will be created if +tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and +the user confirms the creation." + (save-excursion + (if (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)) + (set-buffer mime::article/preview-buffer)) + (if bbdb-use-pop-up + (tm-bbdb/pop-up-bbdb-buffer offer-to-create) + (let* ((from (std11-field-body "From")) + (addr (if from + (car (cdr (mail-extract-address-components from)))))) + (if (or (null from) + (null addr) + (string-match (bbdb-user-mail-names) addr)) + (setq from (or (std11-field-body "To") from)) + ) + (if from + (bbdb-annotate-message-sender + from t + (or (bbdb-invoke-hook-for-value tm-bbdb/auto-create-p) + offer-to-create) + offer-to-create)) + )))) + +(defun tm-bbdb/annotate-sender (string) + "Add a line to the end of the Notes field of the BBDB record +corresponding to the sender of this message." + (interactive + (list (if bbdb-readonly-p + (error "The Insidious Big Brother Database is read-only.") + (read-string "Comments: ")))) + (bbdb-annotate-notes (tm-bbdb/update-record t) string)) + +(defun tm-bbdb/edit-notes (&optional arg) + "Edit the notes field or (with a prefix arg) a user-defined field +of the BBDB record corresponding to the sender of this message." + (interactive "P") + (let ((record (or (tm-bbdb/update-record t) + (error "")))) + (bbdb-display-records (list record)) + (if arg + (bbdb-record-edit-property record nil t) + (bbdb-record-edit-notes record t)))) + +(defun tm-bbdb/show-sender () + "Display the contents of the BBDB for the sender of this message. +This buffer will be in bbdb-mode, with associated keybindings." + (interactive) + (let ((record (tm-bbdb/update-record t))) + (if record + (bbdb-display-records (list record)) + (error "unperson")))) + +(defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create) + "Make the *BBDB* buffer be displayed along with the MIME preview window(s), +displaying the record corresponding to the sender of the current message." + (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer))) + (or framepop + (bbdb-pop-up-bbdb-buffer + (function + (lambda (w) + (let ((b (current-buffer))) + (set-buffer (window-buffer w)) + (prog1 (eq major-mode 'mime/viewer-mode) + (set-buffer b))))))) + (let ((bbdb-gag-messages t) + (bbdb-use-pop-up nil) + (bbdb-electric-p nil)) + (let ((record (tm-bbdb/update-record offer-to-create)) + (bbdb-elided-display (bbdb-pop-up-elided-display)) + (b (current-buffer))) + (if framepop + (if record + (bbdb-display-records (list record)) + (framepop-banish)) + (bbdb-display-records (if record (list record) nil)) + (if (not record) + (progn + (set-buffer "*BBDB*") + (delete-window)))) + (set-buffer b) + record)))) + +(defun tm-bbdb/define-keys () + (let ((mime/viewer-mode-map (current-local-map))) + (define-key mime/viewer-mode-map ";" 'tm-bbdb/edit-notes) + (define-key mime/viewer-mode-map ":" 'tm-bbdb/show-sender) + )) + +(add-hook 'mime-viewer/define-keymap-hook 'tm-bbdb/define-keys) + + +;;; @ for signature.el +;;; + +(defun signature/get-bbdb-sigtype (addr) + "Extract sigtype information from BBDB." + (let ((record (bbdb-search-simple nil addr))) + (and record + (bbdb-record-getprop record 'sigtype)) + )) + +(defun signature/set-bbdb-sigtype (sigtype addr) + "Add sigtype 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 'sigtype sigtype) + (bbdb-change-record record nil)) + ))) + +(defun signature/get-sigtype-from-bbdb (&optional verbose) + (let* ((to (std11-field-body "To")) + (addr (and to + (car (cdr (mail-extract-address-components to))))) + (sigtype (signature/get-bbdb-sigtype addr)) + return + ) + (if addr + (if verbose + (progn + (setq return (signature/get-sigtype-interactively sigtype)) + (if (and (not (string-equal return sigtype)) + (y-or-n-p + (format "Register \"%s\" for <%s>? " return addr)) + ) + (signature/set-bbdb-sigtype return addr) + ) + return) + (or sigtype + (signature/get-signature-file-name)) + )) + )) + + +;;; @ end +;;; + +(provide 'tm-bbdb) + +(run-hooks 'tm-bbdb-load-hook) + +;;; end of tm-bbdb.el diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-def.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-def.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,343 @@ +;;; tm-def.el --- definition module for tm + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Id: tm-def.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, definition + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'emu) + + +;;; @ variables +;;; + +(defvar mime/tmp-dir (or (getenv "TM_TMP_DIR") "/tmp/")) + +(defvar mime/use-multi-frame + (and (>= emacs-major-version 19) window-system)) + +(defvar mime/find-file-function + (if mime/use-multi-frame + (function find-file-other-frame) + (function find-file) + )) + +(defvar mime/output-buffer-window-is-shared-with-bbdb t + "*If t, mime/output-buffer window is shared with BBDB window.") + + +;;; @ constants +;;; + +(defconst mime/output-buffer-name "*MIME-out*") +(defconst mime/temp-buffer-name " *MIME-temp*") + + +;;; @ charset and encoding +;;; + +(defvar mime-charset-type-list + '((us-ascii 7 nil) + (iso-8859-1 8 "quoted-printable") + (iso-8859-2 8 "quoted-printable") + (iso-8859-3 8 "quoted-printable") + (iso-8859-4 8 "quoted-printable") + (iso-8859-5 8 "quoted-printable") + (koi8-r 8 "quoted-printable") + (iso-8859-7 8 "quoted-printable") + (iso-8859-8 8 "quoted-printable") + (iso-8859-9 8 "quoted-printable") + (iso-2022-jp 7 "base64") + (iso-2022-kr 7 "base64") + (euc-kr 8 "base64") + (gb2312 8 "quoted-printable") + (big5 8 "base64") + (iso-2022-jp-2 7 "base64") + (iso-2022-int-1 7 "base64") + )) + +(defun mime/encoding-name (transfer-level &optional not-omit) + (cond ((> transfer-level 8) "binary") + ((= transfer-level 8) "8bit") + (not-omit "7bit") + )) + +(defun mime/make-charset-default-encoding-alist (transfer-level) + (mapcar (function + (lambda (charset-type) + (let ((charset (upcase (symbol-name (car charset-type)))) + (type (nth 1 charset-type)) + (encoding (nth 2 charset-type)) + ) + (if (<= type transfer-level) + (cons charset (mime/encoding-name type)) + (cons charset encoding) + )))) + mime-charset-type-list)) + + +;;; @ button +;;; + +(defun tm:set-face-region (b e face) + (let ((overlay (tl:make-overlay b e))) + (tl:overlay-put overlay 'face face) + )) + +(setq tm:button-face 'bold) +(setq tm:mouse-face 'highlight) + +(defun tm:add-button (from to func &optional data) + "Create a button between FROM and TO with callback FUNC and data DATA." + (and tm:button-face + (tl:overlay-put (tl:make-overlay from to) 'face tm:button-face)) + (tl:add-text-properties from to + (append (and tm:mouse-face + (list 'mouse-face tm:mouse-face)) + (list 'tm-callback func) + (and data (list 'tm-data data)) + )) + ) + +(defvar tm:mother-button-dispatcher nil) + +(defun tm:button-dispatcher (event) + "Select the button under point." + (interactive "e") + (let (buf point func data) + (save-window-excursion + (mouse-set-point event) + (setq buf (current-buffer) + point (point) + func (get-text-property (point) 'tm-callback) + data (get-text-property (point) 'tm-data) + ) + ) + (save-excursion + (set-buffer buf) + (goto-char point) + (if func + (apply func data) + (if (fboundp tm:mother-button-dispatcher) + (funcall tm:mother-button-dispatcher event) + ) + )))) + + +;;; @ for URL +;;; + +(defvar tm:URL-regexp + "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]") + +(defvar browse-url-browser-function nil) + +(defun tm:browse-url (&optional url) + (if (fboundp browse-url-browser-function) + (if url + (funcall browse-url-browser-function url) + (call-interactively browse-url-browser-function)) + (if (fboundp tm:mother-button-dispatcher) + (call-interactively tm:mother-button-dispatcher) + ) + )) + + +;;; @ definitions about MIME +;;; + +(defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=") +(defconst mime/token-regexp (concat "[^" mime/tspecials "]+")) +(defconst mime/charset-regexp mime/token-regexp) + +(defconst mime/content-type-subtype-regexp + (concat mime/token-regexp "/" mime/token-regexp)) + +(defconst mime/disposition-type-regexp mime/token-regexp) + + +;;; @@ Base64 +;;; + +(defconst base64-token-regexp "[A-Za-z0-9+/=]") +(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]") + +(defconst mime/B-encoded-text-regexp + (concat "\\(\\(" + base64-token-regexp + base64-token-regexp + base64-token-regexp + base64-token-regexp + "\\)*" + base64-token-regexp + base64-token-regexp + base64-token-padding-regexp + base64-token-padding-regexp + "\\)")) + +(defconst mime/B-encoding-and-encoded-text-regexp + (concat "\\(B\\)\\?" mime/B-encoded-text-regexp)) + + +;;; @@ Quoted-Printable +;;; + +(defconst quoted-printable-hex-chars "0123456789ABCDEF") +(defconst quoted-printable-octet-regexp + (concat "=[" quoted-printable-hex-chars + "][" quoted-printable-hex-chars "]")) + +(defconst mime/Q-encoded-text-regexp + (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+")) +(defconst mime/Q-encoding-and-encoded-text-regexp + (concat "\\(Q\\)\\?" mime/Q-encoded-text-regexp)) + + +;;; @ rot13-47 +;;; +;; caesar-region written by phr@prep.ai.mit.edu Nov 86 +;; modified by tower@prep Nov 86 +;; gnus-caesar-region +;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47. +(defun tm:caesar-region (&optional n) + "Caesar rotation of region by N, default 13, for decrypting netnews. +ROT47 will be performed for Japanese text in any case." + (interactive (if current-prefix-arg ; Was there a prefix arg? + (list (prefix-numeric-value current-prefix-arg)) + (list nil))) + (cond ((not (numberp n)) (setq n 13)) + (t (setq n (mod n 26)))) ;canonicalize N + (if (not (zerop n)) ; no action needed for a rot of 0 + (progn + (if (or (not (boundp 'caesar-translate-table)) + (/= (aref caesar-translate-table ?a) (+ ?a n))) + (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) + (message "Building caesar-translate-table...") + (setq caesar-translate-table (make-vector 256 0)) + (while (< i 256) + (aset caesar-translate-table i i) + (setq i (1+ i))) + (setq lower (concat lower lower) upper (upcase lower) i 0) + (while (< i 26) + (aset caesar-translate-table (+ ?a i) (aref lower (+ i n))) + (aset caesar-translate-table (+ ?A i) (aref upper (+ i n))) + (setq i (1+ i))) + ;; ROT47 for Japanese text. + ;; Thanks to ichikawa@flab.fujitsu.junet. + (setq i 161) + (let ((t1 (logior ?O 128)) + (t2 (logior ?! 128)) + (t3 (logior ?~ 128))) + (while (< i 256) + (aset caesar-translate-table i + (let ((v (aref caesar-translate-table i))) + (if (<= v t1) (if (< v t2) v (+ v 47)) + (if (<= v t3) (- v 47) v)))) + (setq i (1+ i)))) + (message "Building caesar-translate-table...done"))) + (let ((from (region-beginning)) + (to (region-end)) + (i 0) str len) + (setq str (buffer-substring from to)) + (setq len (length str)) + (while (< i len) + (aset str i (aref caesar-translate-table (aref str i))) + (setq i (1+ i))) + (goto-char from) + (delete-region from to) + (insert str))))) + + +;;; @ field +;;; + +(defun tm:set-fields (sym field-list &optional regexp-sym) + (or regexp-sym + (setq regexp-sym + (let ((name (symbol-name sym))) + (intern + (concat (if (string-match "\\(.*\\)-list" name) + (substring name 0 (match-end 1)) + name) + "-regexp") + ))) + ) + (set sym field-list) + (set regexp-sym + (concat "^" (apply (function regexp-or) field-list) ":")) + ) + +(defun tm:add-fields (sym field-list &optional regexp-sym) + (or regexp-sym + (setq regexp-sym + (let ((name (symbol-name sym))) + (intern + (concat (if (string-match "\\(.*\\)-list" name) + (substring name 0 (match-end 1)) + name) + "-regexp") + ))) + ) + (let ((fields (eval sym))) + (mapcar (function + (lambda (field) + (or (member field fields) + (setq fields (cons field fields)) + ) + )) + (reverse field-list) + ) + (set regexp-sym + (concat "^" (apply (function regexp-or) fields) ":")) + (set sym fields) + )) + +(defun tm:delete-fields (sym field-list &optional regexp-sym) + (or regexp-sym + (setq regexp-sym + (let ((name (symbol-name sym))) + (intern + (concat (if (string-match "\\(.*\\)-list" name) + (substring name 0 (match-end 1)) + name) + "-regexp") + ))) + ) + (let ((fields (eval sym))) + (mapcar (function + (lambda (field) + (setq fields (delete field fields)) + )) + field-list) + (set regexp-sym + (concat "^" (apply (function regexp-or) fields) ":")) + (set sym fields) + )) + + +;;; @ end +;;; + +(provide 'tm-def) + +;;; tm-def.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-edit-mc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-edit-mc.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,165 @@ +;;; tm-edit-mc.el --- Mailcrypt interface for tm-edit + +;; Copyright (C) 1996 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Version: $Id: tm-edit-mc.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, multilingual, security, PGP + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'mailcrypt) +(load "mc-pgp") + +(defun tm:mc-pgp-generic-parser (result) + (let ((ret (mc-pgp-generic-parser result))) + (if (consp ret) + (vector (car ret)(cdr ret)) + ))) + +(defun tm:mc-process-region + (beg end passwd program args parser &optional buffer boundary) + (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) + (if boundary + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (insert (format "--%s\n" boundary)) + (goto-char (point-max)) + (insert (format "\n--%s +Content-Type: application/pgp-signature +Content-Transfer-Encoding: 7bit + +" boundary)) + (insert-buffer-substring mybuf (car rgn) (cdr rgn)) + (goto-char (point-max)) + (insert (format "\n--%s--\n" boundary)) + ) + (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))))) + +(defun tm:mc-pgp-sign-region (start end &optional id unclear boundary) + ;; (if (not (boundp 'mc-pgp-user-id)) + ;; (load "mc-pgp") + ;; ) + (let ((process-environment process-environment) + (buffer (get-buffer-create mc-buffer-name)) + passwd args key + (parser (function mc-pgp-generic-parser)) + (pgp-path mc-pgp-path) + ) + (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 + (cons + (if boundary + "-fbast" + "-fast") + (list "+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 (tm:mc-process-region + start end passwd pgp-path args parser buffer boundary) + (progn + (if boundary + (progn + (goto-char (point-min)) + (insert + (format "\ +--[[multipart/signed; protocol=\"application/pgp-signature\"; + boundary=\"%s\"; micalg=pgp-md5][7bit]]\n" boundary)) + )) + (message "Signing as %s ... Done." (car key)) + t) + nil))) + +(defun tm:mc-pgp-encrypt-region (recipients start end &optional id sign) + (let ((mc-pgp-always-sign (if (eq sign 'maybe) + mc-pgp-always-sign + 'never))) + (mc-pgp-encrypt-region + (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients) + start end id nil) + )) + + +;;; @ end +;;; + +(provide 'tm-edit-mc) + +;;; tm-edit-mc.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-edit.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,2581 @@ +;;; tm-edit.el --- Simple MIME Composer for GNU Emacs + +;; Copyright (C) 1993 .. 1996 Free Software Foundation, Inc. + +;; Author: UMEDA Masanobu +;; MORIOKA Tomohiko +;; Maintainer: MORIOKA Tomohiko +;; Created: 1994/08/21 renamed from mime.el +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: mail, news, MIME, multimedia, multilingual + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This is an Emacs minor mode for editing Internet multimedia +;; messages formatted in MIME (RFC 2045, 2046, 2047, 2048 and 2049). +;; All messages in this mode are composed in the tagged MIME format, +;; that are described in the following examples. The messages +;; composed in the tagged MIME format are automatically translated +;; into a MIME compliant message when exiting the mode. + +;; Mule (a multilingual extension to Emacs 18 and 19) has a capability +;; of handling multilingual text in limited ISO-2022 manner that is +;; based on early experiences in Japanese Internet community and +;; resulted in RFC 1468 (ISO-2022-JP charset for MIME). In order to +;; enable multilingual capability in single text message in MIME, +;; charset of multilingual text written in Mule is declared as either +;; `ISO-2022-JP-2' [RFC 1554] or `ISO-2022-INT-1'. Mule is required +;; for reading the such messages. + +;; This MIME composer can work with Mail mode, mh-e letter Mode, and +;; News mode. First of all, you need the following autoload +;; definition to load mime/editor-mode automatically: +;; +;; (autoload 'mime/editor-mode "tm-edit" +;; "Minor mode for editing MIME message." t) +;; +;; In case of Mail mode (includes VM mode), you need the following +;; hook definition: +;; +;; (add-hook 'mail-mode-hook 'mime/editor-mode) +;; (add-hook 'mail-send-hook 'mime-editor/maybe-translate) +;; +;; In case of MH-E, you need the following hook definition: +;; +;; (add-hook 'mh-letter-mode-hook +;; (function +;; (lambda () +;; (mime/editor-mode) +;; (make-local-variable 'mail-header-separator) +;; (setq mail-header-separator "--------") +;; )))) +;; (add-hook 'mh-before-send-letter-hook 'mime-editor/maybe-translate) +;; +;; In case of News mode, you need the following hook definition: +;; +;; (add-hook 'news-reply-mode-hook 'mime/editor-mode) +;; (add-hook 'news-inews-hook 'mime-editor/maybe-translate) +;; +;; In case of Emacs 19, it is possible to emphasize the message tags +;; using font-lock mode as follows: +;; +;; (add-hook 'mime/editor-mode-hook +;; (function +;; (lambda () +;; (font-lock-mode 1) +;; (setq font-lock-keywords (list mime-editor/tag-regexp)) +;; )))) + +;; The message tag looks like: +;; +;; --[[TYPE/SUBTYPE;PARAMETERS][ENCODING]] +;; +;; The tagged MIME message examples: +;; +;; This is a conventional plain text. It should be translated into +;; text/plain. +;; +;;--[[text/plain]] +;; This is also a plain text. But, it is explicitly specified as is. +;; +;;--[[text/plain; charset=ISO-2022-JP]] +;; $B$3$l$O(B charset $B$r(B ISO-2022-JP $B$K;XDj$7$?F|K\8l$N(B plain $B%F%-%9%H$G$9(B. +;; +;;--[[text/richtext]] +;;
This is a richtext.
+;; +;;--[[image/gif][base64]]^M...image encoded in base64 comes here... +;; +;;--[[audio/basic][base64]]^M...audio encoded in base64 comes here... + +;;; Code: + +(require 'sendmail) +(require 'mail-utils) +(require 'mel) +(require 'tl-822) +(require 'tl-list) +(require 'tm-view) +(require 'tm-ew-e) +(require 'signature) + + +;;; @ version +;;; + +(defconst mime-editor/RCS-ID + "$Id: tm-edit.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $") + +(defconst mime-editor/version (get-version-string mime-editor/RCS-ID)) + +(defconst mime-editor/version-name + (concat "tm-edit " mime-editor/version)) + + +;;; @ variables +;;; + +(defvar mime-prefix "\C-c\C-x" + "*Keymap prefix for MIME commands.") + +(defvar mime-ignore-preceding-spaces nil + "*Ignore preceding white spaces if non-nil.") + +(defvar mime-ignore-trailing-spaces nil + "*Ignore trailing white spaces if non-nil.") + +(defvar mime-ignore-same-text-tag t + "*Ignore preceding text content-type tag that is same with new one. +If non-nil, the text tag is not inserted unless something different.") + +(defvar mime-auto-hide-body t + "*Hide non-textual body encoded in base64 after insertion if non-nil.") + +(defvar mime-editor/voice-recorder + (function mime-editor/voice-recorder-for-sun) + "*Function to record a voice message and encode it. [tm-edit.el]") + +(defvar mime/editor-mode-hook nil + "*Hook called when enter MIME mode.") + +(defvar mime-editor/translate-hook nil + "*Hook called before translating into a MIME compliant message. +To insert a signature file automatically, call the function +`mime-editor/insert-signature' from this hook.") + +(defvar mime-editor/exit-hook nil + "*Hook called when exit MIME mode.") + +(defvar mime-content-types + '(("text" + ;; Charset parameter need not to be specified, since it is + ;; defined automatically while translation. + ("plain" + ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") + ) + ("richtext" + ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") + ) + ("enriched" + ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") + ) + ("x-latex" + ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") + ) + ("html" + ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") + ) + ("x-rot13-47") + ) + ("message" + ("external-body" + ("access-type" + ("anon-ftp" + ("site" "ftp.jaist.ac.jp" "wnoc-fuk.wide.ad.jp" "nic.karrn.ad.jp") + ("directory" "/pub/GNU/elisp/mime") + ("name") + ("mode" "image" "ascii" "local8")) + ("ftp" + ("site") + ("directory") + ("name") + ("mode" "image" "ascii" "local8")) + ("tftp" ("site") ("name")) + ("afs" ("site") ("name")) + ("local-file" ("site") ("name")) + ("mail-server" ("server" "ftpmail@nic.karrn.ad.jp")) + )) + ("rfc822") + ) + ("application" + ("octet-stream" ("type" "" "tar" "shar")) + ("postscript") + ("x-kiss" ("x-cnf"))) + ("image" + ("gif") + ("jpeg") + ("tiff") + ("x-pic") + ("x-mag") + ("x-xwd") + ("x-xbm") + ) + ("audio" ("basic")) + ("video" ("mpeg")) + ) + "*Alist of content-type, subtype, parameters and its values.") + +(defvar mime-file-types + '(("\\.rtf$" + "text" "richtext" nil + nil + nil nil) + ("\\.html$" + "text" "html" nil + nil + nil nil) + ("\\.ps$" + "application" "postscript" nil + "quoted-printable" + "attachment" (("filename" . file)) + ) + ("\\.jpg$" + "image" "jpeg" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.gif$" + "image" "gif" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.tiff$" + "image" "tiff" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.pic$" + "image" "x-pic" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.mag$" + "image" "x-mag" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.xbm$" + "image" "x-xbm" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.xwd$" + "image" "x-xwd" nil + "base64" + "inline" (("filename" . file)) + ) + ("\\.au$" + "audio" "basic" nil + "base64" + "attachment" (("filename" . file)) + ) + ("\\.mpg$" + "video" "mpeg" nil + "base64" + "attachment" (("filename" . file)) + ) + ("\\.el$" + "application" "octet-stream" (("type" . "emacs-lisp")) + "7bit" + "attachment" (("filename" . file)) + ) + ("\\.lsp$" + "application" "octet-stream" (("type" . "common-lisp")) + "7bit" + "attachment" (("filename" . file)) + ) + ("\\.tar\\.gz$" + "application" "octet-stream" (("type" . "tar+gzip")) + nil + "attachment" (("filename" . file)) + ) + ("\\.tgz$" + "application" "octet-stream" (("type" . "tar+gzip")) + nil + "attachment" (("filename" . file)) + ) + ("\\.tar\\.Z$" + "application" "octet-stream" (("type" . "tar+compress")) + nil + "attachment" (("filename" . file)) + ) + ("\\.taz$" + "application" "octet-stream" (("type" . "tar+compress")) + nil + "attachment" (("filename" . file)) + ) + ("\\.gz$" + "application" "octet-stream" (("type" . "gzip")) + nil + "attachment" (("filename" . file)) + ) + ("\\.Z$" + "application" "octet-stream" (("type" . "compress")) + nil + "attachment" (("filename" . file)) + ) + ("\\.lzh$" + "application" "octet-stream" (("type" . "lha")) + nil + "attachment" (("filename" . file)) + ) + ("\\.zip$" + "application" "zip" nil + nil + "attachment" (("filename" . file)) + ) + ("\\.diff$" + "application" "octet-stream" (("type" . "patch")) + nil + "attachment" (("filename" . file)) + ) + ("\\.patch$" + "application" "octet-stream" (("type" . "patch")) + nil + "attachment" (("filename" . file)) + ) + ("\\.signature" + "text" "plain" nil nil) + (".*" + "application" "octet-stream" nil + nil + "attachment" (("filename" . file)) + ) + ) + "*Alist of file name, types, parameters, and default encoding. +If encoding is nil, it is determined from its contents.") + +;;; @@ about charset, encoding and transfer-level +;;; + +(defvar mime-editor/transfer-level 7 + "*A number of network transfer level. It should be bigger than 7.") +(make-variable-buffer-local 'mime-editor/transfer-level) + +(defvar mime-editor/transfer-level-string + (mime/encoding-name mime-editor/transfer-level 'not-omit) + "*A string formatted version of mime/defaul-transfer-level") +(make-variable-buffer-local 'mime-editor/transfer-level-string) + +(defun mime-editor/make-charset-default-encoding-alist (transfer-level) + (mapcar (function + (lambda (charset-type) + (let ((charset (car charset-type)) + (type (nth 1 charset-type)) + (encoding (nth 2 charset-type)) + ) + (if (<= type transfer-level) + (cons charset (mime/encoding-name type)) + (cons charset encoding) + )))) + mime-charset-type-list)) + +(defvar mime-editor/charset-default-encoding-alist + (mime-editor/make-charset-default-encoding-alist mime-editor/transfer-level)) +(make-variable-buffer-local 'mime-editor/charset-default-encoding-alist) + +;;; @@ about message inserting +;;; + +(defvar mime-editor/yank-ignored-field-list + '("Received" "Approved" "Path" "Replied" "Status" + "Xref" "X-UIDL" "X-Filter" "X-Gnus-.*" "X-VM-.*") + "Delete these fields from original message when it is inserted +as message/rfc822 part. +Each elements are regexp of field-name. [tm-edit.el]") + +(defvar mime-editor/yank-ignored-field-regexp + (concat "^" + (apply (function regexp-or) mime-editor/yank-ignored-field-list) + ":")) + +(defvar mime-editor/message-inserter-alist nil) +(defvar mime-editor/mail-inserter-alist nil) + +;;; @@ about message splitting +;;; + +(defvar mime-editor/split-message t + "*Split large message if it is non-nil. [tm-edit.el]") + +(defvar mime-editor/message-default-max-lines 1000 + "*Default maximum lines of a message. [tm-edit.el]") + +(defvar mime-editor/message-max-lines-alist + '((news-reply-mode . 500)) + "Alist of major-mode vs maximum lines of a message. +If it is not specified for a major-mode, +`mime-editor/message-default-max-lines' is used. [tm-edit.el]") + +(defconst mime-editor/split-ignored-field-regexp + "\\(^Content-\\|^Subject:\\|^Mime-Version:\\)") + +(defvar mime-editor/split-blind-field-regexp + "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)") + +(defvar mime-editor/split-message-sender-alist nil) + +(defvar mime-editor/news-reply-mode-server-running nil) + + +;;; @@ about PGP +;;; + +(defvar mime-editor/signing-type 'pgp-elkins + "*PGP signing type (pgp-elkins, pgp-kazu or nil). [tm-edit.el]") + +(defvar mime-editor/encrypting-type 'pgp-elkins + "*PGP encrypting type (pgp-elkins, pgp-kazu or nil). [tm-edit.el]") + +(defvar mime-editor/pgp-sign-function 'tm:mc-pgp-sign-region) +(defvar mime-editor/pgp-encrypt-function 'tm:mc-pgp-encrypt-region) +(defvar mime-editor/traditional-pgp-sign-function 'mc-pgp-sign-region) +(defvar mime-editor/pgp-insert-public-key-function 'mc-insert-public-key) + +(autoload mime-editor/pgp-sign-function "tm-edit-mc") +(autoload mime-editor/pgp-encrypt-function "tm-edit-mc") +(autoload mime-editor/traditional-pgp-sign-function "mc-pgp") +(autoload mime-editor/pgp-insert-public-key-function "mc-toplev") + + +;;; @@ about tag +;;; + +(defconst mime-editor/single-part-tag-regexp + "--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]" + "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].") + +(defconst mime-editor/quoted-single-part-tag-regexp + (concat "- " (substring mime-editor/single-part-tag-regexp 1))) + +(defconst mime-editor/multipart-beginning-regexp "--<<\\([^<>]+\\)>>-{\n") + +(defconst mime-editor/multipart-end-regexp "--}-<<\\([^<>]+\\)>>\n") + +(defconst mime-editor/beginning-tag-regexp + (regexp-or mime-editor/single-part-tag-regexp + mime-editor/multipart-beginning-regexp)) + +(defconst mime-editor/end-tag-regexp + (regexp-or mime-editor/single-part-tag-regexp + mime-editor/multipart-end-regexp)) + +(defconst mime-editor/tag-regexp + (regexp-or mime-editor/single-part-tag-regexp + mime-editor/multipart-beginning-regexp + mime-editor/multipart-end-regexp)) + +(defvar mime-tag-format "--[[%s]]" + "*Control-string making a MIME tag.") + +(defvar mime-tag-format-with-encoding "--[[%s][%s]]" + "*Control-string making a MIME tag with encoding.") + +;;; @@ multipart boundary +;;; + +(defvar mime-multipart-boundary "Multipart" + "*Boundary of a multipart message.") + + +;;; @@ buffer local variables +;;; + +(defvar mime/editor-mode-old-local-map nil) +(defvar mime/editing-buffer nil) + + +;;; @ constants +;;; + +(defconst mime-tspecials-regexp "[][()<>@,;:\\\"/?.= \t]" + "*Specify MIME tspecials. +Tspecials means any character that matches with it in header must be quoted.") + +(defconst mime-editor/mime-version-value + (concat "1.0 (generated by " mime-editor/version-name ")") + "MIME version number.") + +(defconst mime-editor/mime-map (make-sparse-keymap) + "Keymap for MIME commands.") + +;;; @ keymap and menu +;;; + +(defvar mime/editor-mode-flag nil) +(make-variable-buffer-local 'mime/editor-mode-flag) + +(defun mime-editor/define-keymap (keymap) + "Add mime-editor commands to KEYMAP." + (if (not (keymapp keymap)) + nil + (define-key keymap "\C-t" 'mime-editor/insert-text) + (define-key keymap "\C-i" 'mime-editor/insert-file) + (define-key keymap "\C-e" 'mime-editor/insert-external) + (define-key keymap "\C-v" 'mime-editor/insert-voice) + (define-key keymap "\C-y" 'mime-editor/insert-message) + (define-key keymap "\C-m" 'mime-editor/insert-mail) + (define-key keymap "\C-w" 'mime-editor/insert-signature) + (define-key keymap "\C-s" 'mime-editor/insert-signature) + (define-key keymap "\C-k" 'mime-editor/insert-key) + (define-key keymap "t" 'mime-editor/insert-tag) + (define-key keymap "a" 'mime-editor/enclose-alternative-region) + (define-key keymap "p" 'mime-editor/enclose-parallel-region) + (define-key keymap "m" 'mime-editor/enclose-mixed-region) + (define-key keymap "d" 'mime-editor/enclose-digest-region) + (define-key keymap "s" 'mime-editor/enclose-signed-region) + (define-key keymap "e" 'mime-editor/enclose-encrypted-region) + (define-key keymap "q" 'mime-editor/enclose-quote-region) + (define-key keymap "7" 'mime-editor/set-transfer-level-7bit) + (define-key keymap "8" 'mime-editor/set-transfer-level-8bit) + (define-key keymap "/" 'mime-editor/set-split) + (define-key keymap "v" 'mime-editor/set-sign) + (define-key keymap "h" 'mime-editor/set-encrypt) + (define-key keymap "\C-p" 'mime-editor/preview-message) + (define-key keymap "\C-z" 'mime-editor/exit) + (define-key keymap "?" 'mime-editor/help) + )) + +(mime-editor/define-keymap mime-editor/mime-map) + +(defun mime-editor/toggle-mode () + (interactive) + (if mime/editor-mode-flag + (mime-editor/exit 'nomime) + (mime/editor-mode) + )) + +(cond (running-xemacs + (defconst mime-editor/minor-mime-map nil "Keymap for MIME commands.") + (or mime-editor/minor-mime-map + (progn + (setq mime-editor/minor-mime-map + (make-sparse-keymap 'mime-editor/minor-mime-map)) + (define-key + mime-editor/minor-mime-map mime-prefix mime-editor/mime-map) + )) + (add-minor-mode 'mime/editor-mode-flag + '((" MIME-Edit " mime-editor/transfer-level-string)) + mime-editor/minor-mime-map + nil + 'mime-editor/toggle-mode) + ) + (t + (set-alist 'minor-mode-alist + 'mime/editor-mode-flag + '((" MIME-Edit " mime-editor/transfer-level-string)))) + ) + +(defconst mime-editor/menu-title "MIME-Edit") + +(defconst mime-editor/menu-list + '((mime-help "Describe MIME editor mode" mime-editor/help) + (file "Insert File" mime-editor/insert-file) + (external "Insert External" mime-editor/insert-external) + (voice "Insert Voice" mime-editor/insert-voice) + (message "Insert Message" mime-editor/insert-message) + (mail "Insert Mail" mime-editor/insert-mail) + (signature "Insert Signature" mime-editor/insert-signature) + (text "Insert Text" mime-editor/insert-text) + (tag "Insert Tag" mime-editor/insert-tag) + (alternative "Enclose as alternative" + mime-editor/enclose-alternative-region) + (parallel "Enclose as parallel" mime-editor/enclose-parallel-region) + (mixed "Enclose as serial" mime-editor/enclose-mixed-region) + (digest "Enclose as digest" mime-editor/enclose-digest-region) + (signed "Enclose as signed" mime-editor/enclose-signed-region) + (encrypted "Enclose as encrypted" mime-editor/enclose-encrypted-region) + (quote "Verbatim region" mime-editor/enclose-quote-region) + (key "Insert Public Key" mime-editor/insert-key) + (split "About split" mime-editor/set-split) + (sign "About sign" mime-editor/set-sign) + (encrypt "About encryption" mime-editor/set-encrypt) + (preview "Preview Message" mime-editor/preview-message) + (level "Toggle transfer-level" mime-editor/toggle-transfer-level) + ) + "MIME-edit menubar entry.") + +(defun mime-editor/define-menu-for-emacs19 () + "Define menu for Emacs 19." + (define-key (current-local-map) [menu-bar mime-edit] + (cons mime-editor/menu-title + (make-sparse-keymap mime-editor/menu-title))) + (mapcar (function + (lambda (item) + (define-key (current-local-map) + (vector 'menu-bar 'mime-edit (car item)) + (cons (nth 1 item)(nth 2 item)) + ) + )) + (reverse mime-editor/menu-list) + )) + +;;; modified by Pekka Marjola +;;; 1995/9/5 (c.f. [tm-en:69]) +(defun mime-editor/define-menu-for-xemacs () + "Define menu for Emacs 19." + (cond ((featurep 'menubar) + (make-local-variable 'current-menubar) + (set-buffer-menubar current-menubar) + (add-submenu nil + (cons mime-editor/menu-title + (mapcar (function + (lambda (item) + (vector (nth 1 item)(nth 2 item) + mime/editor-mode-flag) + )) + mime-editor/menu-list))) + ))) + +;;; modified by Steven L. Baur +;;; 1995/12/6 (c.f. [tm-en:209]) +(if (and running-xemacs (not (boundp 'mime-editor/popup-menu-for-xemacs))) + (setq mime-editor/popup-menu-for-xemacs + (append '("MIME Commands" "---") + (mapcar (function (lambda (item) + (vector (nth 1 item) + (nth 2 item) + t))) + mime-editor/menu-list))) + ) +;;; end + + +;;; @ functions +;;; + +;;;###autoload +(defun mime/editor-mode () + "MIME minor mode for editing the tagged MIME message. + +In this mode, basically, the message is composed in the tagged MIME +format. The message tag looks like: + + `--[[text/plain; charset=ISO-2022-JP][7bit]]'. + +The tag specifies the MIME content type, subtype, optional parameters +and transfer encoding of the message following the tag. Messages +without any tag are treated as `text/plain' by default. Charset and +transfer encoding are automatically defined unless explicitly +specified. Binary messages such as audio and image are usually hidden. +The messages in the tagged MIME format are automatically translated +into a MIME compliant message when exiting this mode. + +Available charsets depend on Emacs version being used. The following +lists the available charsets of each emacs. + +EMACS 18: US-ASCII is only available. +NEmacs: US-ASCII and ISO-2022-JP are available. +EMACS 19: US-ASCII and ISO-8859-1 (or other charset) are available. +XEmacs 19: US-ASCII and ISO-8859-1 (or other charset) are available. +Mule: US-ASCII, ISO-8859-* (except for ISO-8859-5), KOI8-R, + ISO-2022-JP, ISO-2022-JP-2, ISO-2022-KR, BIG5 and + ISO-2022-INT-1 are available. + +ISO-2022-JP-2 and ISO-2022-INT-1 charsets used in mule is expected to +be used to represent multilingual text in intermixed manner. Any +languages that has no registered charset are represented as either +ISO-2022-JP-2 or ISO-2022-INT-1 in mule. + +If you want to use non-ISO-8859-1 charset in EMACS 19 or XEmacs 19, +please set variable `default-mime-charset'. This variable must be +symbol of which name is a MIME charset. + +If you want to add more charsets in mule, please set variable +`charsets-mime-charset-alist'. This variable must be alist of which +key is list of leading-char/charset and value is symbol of MIME +charset. (leading-char is a term of MULE 1.* and 2.*. charset is a +term of XEmacs/mule, mule merged EMACS and MULE 3.*) If name of +coding-system is different as MIME charset, please set variable +`mime-charset-coding-system-alist'. This variable must be alist of +which key is MIME charset and value is coding-system. + +Following commands are available in addition to major mode commands: +\\[mime-editor/insert-text] insert a text message. +\\[mime-editor/insert-file] insert a (binary) file. +\\[mime-editor/insert-external] insert a reference to external body. +\\[mime-editor/insert-voice] insert a voice message. +\\[mime-editor/insert-message] insert a mail or news message. +\\[mime-editor/insert-mail] insert a mail message. +\\[mime-editor/insert-signature] insert a signature file at end. +\\[mime-editor/insert-tag] insert a new MIME tag. +\\[mime-editor/enclose-alternative-region] enclose as multipart/alternative. +\\[mime-editor/enclose-parallel-region] enclose as multipart/parallel. +\\[mime-editor/enclose-mixed-region] enclose as multipart/mixed. +\\[mime-editor/enclose-digest-region] enclose as multipart/digest. +\\[mime-editor/enclose-signed-region] enclose as PGP signed. +\\[mime-editor/enclose-encrypted-region] enclose as PGP encrypted. +\\[mime-editor/insert-key] insert PGP public key. +\\[mime-editor/preview-message] preview editing MIME message. +\\[mime-editor/exit] exit and translate into a MIME compliant message. +\\[mime-editor/maybe-translate] exit and translate if in MIME mode, then split. +\\[mime-editor/help] show this help. + +Additional commands are available in some major modes: +C-c C-c exit, translate and run the original command. +C-c C-s exit, translate and run the original command. + +The following is a message example written in the tagged MIME format. +TABs at the beginning of the line are not a part of the message: + + This is a conventional plain text. It should be translated + into text/plain. + --[[text/plain]] + This is also a plain text. But, it is explicitly specified as + is. + --[[text/plain; charset=ISO-2022-JP]] + $B$3$l$O(B charset $B$r(B ISO-2022-JP $B$K;XDj$7$?F|K\8l$N(B plain $B%F%-%9(B + $B%H$G$9(B. + --[[text/richtext]] +
This is a richtext.
+ --[[image/gif][base64]]^M...image encoded in base64 here... + --[[audio/basic][base64]]^M...audio encoded in base64 here... + +User customizable variables (not documented all of them): + mime-prefix + Specifies a key prefix for MIME minor mode commands. + + mime-ignore-preceding-spaces + Preceding white spaces in a message body are ignored if non-nil. + + mime-ignore-trailing-spaces + Trailing white spaces in a message body are ignored if non-nil. + + mime-auto-fill-header + Fill header fields that contain encoded-words if non-nil. + + mime-auto-hide-body + Hide a non-textual body message encoded in base64 after insertion + if non-nil. + + mime-editor/voice-recorder + Specifies a function to record a voice message and encode it. + The function `mime-editor/voice-recorder-for-sun' is for Sun + SparcStations. + + mime/editor-mode-hook + Turning on MIME mode calls the value of mime/editor-mode-hook, if + it is non-nil. + + mime-editor/translate-hook + The value of mime-editor/translate-hook is called just before translating + the tagged MIME format into a MIME compliant message if it is + non-nil. If the hook call the function mime-editor/insert-signature, + the signature file will be inserted automatically. + + mime-editor/exit-hook + Turning off MIME mode calls the value of mime-editor/exit-hook, if it is + non-nil." + (interactive) + (if mime/editor-mode-flag + (error "You are already editing a MIME message.") + (setq mime/editor-mode-flag t) + ;; Remember old key bindings. + (if running-xemacs + (use-local-map (or (current-local-map) (make-sparse-keymap))) + (make-local-variable 'mime/editor-mode-old-local-map) + (setq mime/editor-mode-old-local-map (current-local-map)) + ;; Add MIME commands to current local map. + (use-local-map (copy-keymap (or (current-local-map) + (make-sparse-keymap)))) + ) + (if (not (lookup-key (current-local-map) mime-prefix)) + (define-key (current-local-map) mime-prefix mime-editor/mime-map)) + + ;; Set transfer level into mode line + ;; + (setq mime-editor/transfer-level-string + (mime/encoding-name mime-editor/transfer-level 'not-omit)) + (force-mode-line-update) + + ;; Define menu. Menus for other emacs implementations are + ;; welcome. + (cond (running-xemacs + (mime-editor/define-menu-for-xemacs)) + ((>= emacs-major-version 19) + (mime-editor/define-menu-for-emacs19) + )) + ;; end + + (enable-invisible) + + ;; I don't care about saving these. + (setq paragraph-start + (regexp-or mime-editor/single-part-tag-regexp + paragraph-start)) + (setq paragraph-separate + (regexp-or mime-editor/single-part-tag-regexp + paragraph-separate)) + (run-hooks 'mime/editor-mode-hook) + (message + (substitute-command-keys + "Type \\[mime-editor/exit] to exit MIME mode, and type \\[mime-editor/help] to get help.")) + )) + +;;;###autoload +(defalias 'edit-mime 'mime/editor-mode) ; for convenience +(defalias 'mime-mode 'mime/editor-mode) ; for convenience + +(defun mime-editor/exit (&optional nomime no-error) + "Translate the tagged MIME message into a MIME compliant message. +With no argument encode a message in the buffer into MIME, otherwise +just return to previous mode." + (interactive "P") + (if (not mime/editor-mode-flag) + (if (null no-error) + (error "You aren't editing a MIME message.") + ) + (if (not nomime) + (progn + (run-hooks 'mime-editor/translate-hook) + (mime-editor/translate-buffer))) + ;; Restore previous state. + (setq mime/editor-mode-flag nil) + (cond (running-xemacs + (delete-menu-item (list mime-editor/menu-title))) + (t + (use-local-map mime/editor-mode-old-local-map))) + + (end-of-invisible) + (set-buffer-modified-p (buffer-modified-p)) + (run-hooks 'mime-editor/exit-hook) + (message "Exit MIME editor mode.") + )) + +(defun mime-editor/maybe-translate () + (interactive) + (mime-editor/exit nil t) + (call-interactively 'mime-editor/maybe-split-and-send) + ) + +(defun mime-editor/help () + "Show help message about MIME mode." + (interactive) + (with-output-to-temp-buffer "*Help*" + (princ "MIME editor mode:\n") + (princ (documentation 'mime/editor-mode)) + (print-help-return-message))) + +(defun mime-editor/insert-text () + "Insert a text message. +Charset is automatically obtained from the `mime/lc-charset-alist'." + (interactive) + (let ((ret (mime-editor/insert-tag "text" nil nil))) + (if ret + (progn + (if (looking-at mime-editor/single-part-tag-regexp) + (progn + ;; Make a space between the following message. + (insert "\n") + (forward-char -1) + )) + (if (and (member (second ret) '("enriched" "richtext")) + (fboundp 'enriched-mode) + ) + (enriched-mode t) + (if (boundp 'enriched-mode) + (enriched-mode nil) + )))))) + +(defun mime-editor/insert-file (file) + "Insert a message from a file." + (interactive "fInsert file as MIME message: ") + (let* ((guess (mime-find-file-type file)) + (pritype (nth 0 guess)) + (subtype (nth 1 guess)) + (parameters (nth 2 guess)) + (default (nth 3 guess)) ;Guess encoding from its file name. + (disposition-type (nth 4 guess)) + (disposition-params (nth 5 guess)) + (encoding + (if (not (interactive-p)) + default + (completing-read + (concat "What transfer encoding" + (if default + (concat " (default " + (if (string-equal default "") + "\"\"" + default) + ")" + )) + ": ") + mime-file-encoding-method-alist nil t nil)))) + (if (string-equal encoding "") + (setq encoding default)) + (if (or (consp parameters) (stringp disposition-type)) + (let ((rest parameters) cell attribute value) + (setq parameters "") + (while rest + (setq cell (car rest)) + (setq attribute (car cell)) + (setq value (cdr cell)) + (if (eq value 'file) + (setq value (std11-wrap-as-quoted-string + (file-name-nondirectory file))) + ) + (setq parameters (concat parameters "; " attribute "=" value)) + (setq rest (cdr rest)) + ) + (if disposition-type + (progn + (setq parameters + (concat parameters "\n" + "Content-Disposition: " disposition-type)) + (setq rest disposition-params) + (while rest + (setq cell (car rest)) + (setq attribute (car cell)) + (setq value (cdr cell)) + (if (eq value 'file) + (setq value (std11-wrap-as-quoted-string + (file-name-nondirectory file))) + ) + (setq parameters + (concat parameters "; " attribute "=" value)) + (setq rest (cdr rest)) + ) + )) + )) + (mime-editor/insert-tag pritype subtype parameters) + (mime-editor/insert-binary-file file encoding) + )) + +(defun mime-editor/insert-external () + "Insert a reference to external body." + (interactive) + (mime-editor/insert-tag "message" "external-body" nil ";\n\t") + ;;(forward-char -1) + ;;(insert "Content-Description: " (read-string "Content-Description: ") "\n") + ;;(forward-line 1) + (let* ((pritype (mime-prompt-for-type)) + (subtype (mime-prompt-for-subtype pritype)) + (parameters (mime-prompt-for-parameters pritype subtype ";\n\t"))) + (and pritype + subtype + (insert "Content-Type: " + pritype "/" subtype (or parameters "") "\n"))) + (if (and (not (eobp)) + (not (looking-at mime-editor/single-part-tag-regexp))) + (insert (mime-make-text-tag) "\n"))) + +(defun mime-editor/insert-voice () + "Insert a voice message." + (interactive) + (let ((encoding + (completing-read + "What transfer encoding: " + mime-file-encoding-method-alist nil t nil))) + (mime-editor/insert-tag "audio" "basic" nil) + (mime-editor/define-encoding encoding) + (save-restriction + (narrow-to-region (1- (point))(point)) + (unwind-protect + (funcall mime-editor/voice-recorder encoding) + (progn + (insert "\n") + (invisible-region (point-min)(point-max)) + (goto-char (point-max)) + ))))) + +(defun mime-editor/insert-signature (&optional arg) + "Insert a signature file." + (interactive "P") + (let ((signature-insert-hook + (function + (lambda () + (apply (function mime-editor/insert-tag) + (mime-find-file-type signature-file-name)) + ))) + ) + (insert-signature arg) + )) + + +;; Insert a new tag around a point. + +(defun mime-editor/insert-tag (&optional pritype subtype parameters delimiter) + "Insert new MIME tag and return a list of PRITYPE, SUBTYPE, and PARAMETERS. +If nothing is inserted, return nil." + (interactive) + (let ((p (point))) + (mime-editor/goto-tag) + (if (and (re-search-forward mime-editor/tag-regexp nil t) + (< (match-beginning 0) p) + (< p (match-end 0)) + ) + (goto-char (match-beginning 0)) + (goto-char p) + )) + (let ((oldtag nil) + (newtag nil) + (current (point)) + ) + (setq pritype + (or pritype + (mime-prompt-for-type))) + (setq subtype + (or subtype + (mime-prompt-for-subtype pritype))) + (setq parameters + (or parameters + (mime-prompt-for-parameters pritype subtype delimiter))) + ;; Make a new MIME tag. + (setq newtag (mime-make-tag pritype subtype parameters)) + ;; Find an current MIME tag. + (setq oldtag + (save-excursion + (if (mime-editor/goto-tag) + (buffer-substring (match-beginning 0) (match-end 0)) + ;; Assume content type is 'text/plan'. + (mime-make-tag "text" "plain") + ))) + ;; We are only interested in TEXT. + (if (and oldtag + (not (mime-test-content-type + (mime-editor/get-contype oldtag) "text"))) + (setq oldtag nil)) + ;; Make a new tag. + (if (or (not oldtag) ;Not text + (or mime-ignore-same-text-tag + (not (string-equal oldtag newtag)))) + (progn + ;; Mark the beginning of the tag for convenience. + (push-mark (point) 'nomsg) + (insert newtag "\n") + (list pritype subtype parameters) ;New tag is created. + ) + ;; Restore previous point. + (goto-char current) + nil ;Nothing is created. + ) + )) + +(defun mime-editor/insert-binary-file (file &optional encoding) + "Insert binary FILE at point. +Optional argument ENCODING specifies an encoding method such as base64." + (let* ((tagend (1- (point))) ;End of the tag + (hide-p (and mime-auto-hide-body + (stringp encoding) + (not + (let ((en (downcase encoding))) + (or (string-equal en "7bit") + (string-equal en "8bit") + (string-equal en "binary") + ))))) + ) + (save-restriction + (narrow-to-region tagend (point)) + (mime-insert-encoded-file file encoding) + (if hide-p + (progn + (invisible-region (point-min) (point-max)) + (goto-char (point-max)) + ) + (goto-char (point-max)) + )) + (or hide-p + (looking-at mime-editor/tag-regexp) + (= (point)(point-max)) + (mime-editor/insert-tag "text" "plain") + ) + ;; Define encoding even if it is 7bit. + (if (stringp encoding) + (save-excursion + (goto-char tagend) ; Make sure which line the tag is on. + (mime-editor/define-encoding encoding) + )) + )) + + +;; Commands work on a current message flagment. + +(defun mime-editor/goto-tag () + "Search for the beginning of the tagged MIME message." + (let ((current (point)) multipart) + (if (looking-at mime-editor/tag-regexp) + t + ;; At first, go to the end. + (cond ((re-search-forward mime-editor/beginning-tag-regexp nil t) + (goto-char (1- (match-beginning 0))) ;For multiline tag + ) + (t + (goto-char (point-max)) + )) + ;; Then search for the beginning. + (re-search-backward mime-editor/end-tag-regexp nil t) + (or (looking-at mime-editor/beginning-tag-regexp) + ;; Restore previous point. + (progn + (goto-char current) + nil + )) + ))) + +(defun mime-editor/content-beginning () + "Return the point of the beginning of content." + (save-excursion + (let ((beg (save-excursion + (beginning-of-line) (point)))) + (if (mime-editor/goto-tag) + (let ((top (point))) + (goto-char (match-end 0)) + (if (and (= beg top) + (= (following-char) ?\^M)) + (point) + (forward-line 1) + (point))) + ;; Default text/plain tag. + (goto-char (point-min)) + (re-search-forward + (concat "\n" (regexp-quote mail-header-separator) + (if mime-ignore-preceding-spaces + "[ \t\n]*\n" "\n")) nil 'move) + (point)) + ))) + +(defun mime-editor/content-end () + "Return the point of the end of content." + (save-excursion + (let ((beg (point))) + (if (mime-editor/goto-tag) + (let ((top (point))) + (goto-char (match-end 0)) + (if (invisible-p (point)) + (next-visible-point (point)) + ;; Move to the end of this text. + (if (re-search-forward mime-editor/tag-regexp nil 'move) + ;; Don't forget a multiline tag. + (goto-char (match-beginning 0)) + ) + (point) + )) + ;; Assume the message begins with text/plain. + (goto-char (mime-editor/content-beginning)) + (if (re-search-forward mime-editor/tag-regexp nil 'move) + ;; Don't forget a multiline tag. + (goto-char (match-beginning 0))) + (point)) + ))) + +(defun mime-editor/define-charset (charset) + "Set charset of current tag to CHARSET." + (save-excursion + (if (mime-editor/goto-tag) + (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert + (mime-create-tag + (mime-editor/set-parameter + (mime-editor/get-contype tag) + "charset" (upcase (symbol-name charset))) + (mime-editor/get-encoding tag))) + )))) + +(defun mime-editor/define-encoding (encoding) + "Set encoding of current tag to ENCODING." + (save-excursion + (if (mime-editor/goto-tag) + (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert (mime-create-tag (mime-editor/get-contype tag) encoding))) + ))) + +(defun mime-editor/choose-charset () + "Choose charset of a text following current point." + (detect-mime-charset-region (point) (mime-editor/content-end)) + ) + +(defun mime-make-text-tag (&optional subtype) + "Make a tag for a text after current point. +Subtype of text type can be specified by an optional argument SUBTYPE. +Otherwise, it is obtained from mime-content-types." + (let* ((pritype "text") + (subtype (or subtype + (car (car (cdr (assoc pritype mime-content-types))))))) + ;; Charset should be defined later. + (mime-make-tag pritype subtype))) + + +;; Tag handling functions + +(defun mime-make-tag (pritype subtype &optional parameters encoding) + "Make a tag of MIME message of PRITYPE, SUBTYPE and optional PARAMETERS." + (mime-create-tag (concat (or pritype "") "/" (or subtype "") + (or parameters "")) + encoding)) + +(defun mime-create-tag (contype &optional encoding) + "Make a tag with CONTENT-TYPE and optional ENCODING." + (format (if encoding mime-tag-format-with-encoding mime-tag-format) + contype encoding)) + +(defun mime-editor/get-contype (tag) + "Return Content-Type (including parameters) of TAG." + (and (stringp tag) + (or (string-match mime-editor/single-part-tag-regexp tag) + (string-match mime-editor/multipart-beginning-regexp tag) + (string-match mime-editor/multipart-end-regexp tag) + ) + (substring tag (match-beginning 1) (match-end 1)) + )) + +(defun mime-editor/get-encoding (tag) + "Return encoding of TAG." + (and (stringp tag) + (string-match mime-editor/single-part-tag-regexp tag) + (match-beginning 3) + (not (= (match-beginning 3) (match-end 3))) + (substring tag (match-beginning 3) (match-end 3)))) + +(defun mime-get-parameter (contype parameter) + "For given CONTYPE return value for PARAMETER. +Nil if no such parameter." + (if (string-match + (concat + ";[ \t\n]*" + (regexp-quote parameter) + "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\([ \t\n]*;\\|$\\)") + contype) + (substring contype (match-beginning 1) (match-end 1)) + nil ;No such parameter + )) + +(defun mime-editor/set-parameter (contype parameter value) + "For given CONTYPE set PARAMETER to VALUE." + (let (ctype opt-fields) + (if (string-match "\n[^ \t\n\r]+:" contype) + (setq ctype (substring contype 0 (match-beginning 0)) + opt-fields (substring contype (match-beginning 0))) + (setq ctype contype) + ) + (if (string-match + (concat + ";[ \t\n]*\\(" + (regexp-quote parameter) + "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\)[ \t\n]*\\(;\\|$\\)") + ctype) + ;; Change value + (concat (substring ctype 0 (match-beginning 1)) + parameter "=" value + (substring contype (match-end 1)) + opt-fields) + (concat ctype "; " parameter "=" value opt-fields) + ))) + +(defun mime-strip-parameters (contype) + "Return primary content-type and subtype without parameters for CONTYPE." + (if (string-match "^[ \t]*\\([^; \t\n]*\\)" contype) + (substring contype (match-beginning 1) (match-end 1)) nil)) + +(defun mime-test-content-type (contype type &optional subtype) + "Test if CONTYPE is a TYPE and an optional SUBTYPE." + (and (stringp contype) + (stringp type) + (string-match + (concat "^[ \t]*" (downcase type) "/" (downcase (or subtype ""))) + (downcase contype)))) + + +;; Basic functions + +(defun mime-find-file-type (file) + "Guess Content-Type, subtype, and parameters from FILE." + (let ((guess nil) + (guesses mime-file-types)) + (while (and (not guess) guesses) + (if (string-match (car (car guesses)) file) + (setq guess (cdr (car guesses)))) + (setq guesses (cdr guesses))) + guess + )) + +(defun mime-prompt-for-type () + "Ask for Content-type." + (let ((type "")) + ;; Repeat until primary content type is specified. + (while (string-equal type "") + (setq type + (completing-read "What content type: " + mime-content-types + nil + 'require-match ;Type must be specified. + nil + )) + (if (string-equal type "") + (progn + (message "Content type is required.") + (beep) + (sit-for 1) + )) + ) + type + )) + +(defun mime-prompt-for-subtype (pritype) + "Ask for Content-type subtype of Content-Type PRITYPE." + (let* ((default (car (car (cdr (assoc pritype mime-content-types))))) + (answer + (completing-read + (if default + (concat + "What content subtype: (default " default ") ") + "What content subtype: ") + (cdr (assoc pritype mime-content-types)) + nil + 'require-match ;Subtype must be specified. + nil + ))) + (if (string-equal answer "") default answer))) + +(defun mime-prompt-for-parameters (pritype subtype &optional delimiter) + "Ask for Content-type parameters of Content-Type PRITYPE and SUBTYPE. +Optional DELIMITER specifies parameter delimiter (';' by default)." + (let* ((delimiter (or delimiter "; ")) + (parameters + (mapconcat + (function identity) + (delq nil + (mime-prompt-for-parameters-1 + (cdr (assoc subtype + (cdr (assoc pritype mime-content-types)))))) + delimiter + ))) + (if (and (stringp parameters) + (not (string-equal parameters ""))) + (concat delimiter parameters) + "" ;"" if no parameters + ))) + +(defun mime-prompt-for-parameters-1 (optlist) + (apply (function append) + (mapcar (function mime-prompt-for-parameter) optlist))) + +(defun mime-prompt-for-parameter (parameter) + "Ask for PARAMETER. +Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." + (let* ((prompt (car parameter)) + (choices (mapcar (function + (lambda (e) + (if (consp e) e (list e)))) + (cdr parameter))) + (default (car (car choices))) + (answer nil)) + (if choices + (progn + (setq answer + (completing-read + (concat "What " prompt + ": (default " + (if (string-equal default "") "\"\"" default) + ") ") + choices nil nil "")) + ;; If nothing is selected, use default. + (if (string-equal answer "") + (setq answer default))) + (setq answer + (read-string (concat "What " prompt ": ")))) + (cons (if (and answer + (not (string-equal answer ""))) + (concat prompt "=" + ;; Note: control characters ignored! + (if (string-match mime-tspecials-regexp answer) + (concat "\"" answer "\"") answer))) + (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter))))) + )) + +(defun mime-flag-region (from to flag) + "Hides or shows lines from FROM to TO, according to FLAG. +If FLAG is `\\n' (newline character) then text is shown, +while if FLAG is `\\^M' (control-M) the text is hidden." + (let ((buffer-read-only nil) ;Okay even if write protected. + (modp (buffer-modified-p))) + (unwind-protect + (subst-char-in-region from to + (if (= flag ?\n) ?\^M ?\n) + flag t) + (set-buffer-modified-p modp)))) + + +;;; @ Translate the tagged MIME messages into a MIME compliant message. +;;; + +(defvar mime-editor/translate-buffer-hook + '(mime-editor/pgp-enclose-buffer + mime-editor/translate-header + mime-editor/translate-body)) + +(defun mime-editor/translate-header () + "Encode the message header into network representation." + (mime/encode-message-header 'code-conversion) + (run-hooks 'mime-editor/translate-header-hook) + ) + +(defun mime-editor/translate-buffer () + "Encode the tagged MIME message in current buffer in MIME compliant message." + (interactive) + (if (catch 'mime-editor/error + (save-excursion + (run-hooks 'mime-editor/translate-buffer-hook) + )) + (progn + (undo) + (error "Translation error!") + ))) + +(defun mime-editor/find-inmost () + (goto-char (point-min)) + (if (re-search-forward mime-editor/multipart-beginning-regexp nil t) + (let ((bb (match-beginning 0)) + (be (match-end 0)) + (type (buffer-substring (match-beginning 1)(match-end 1))) + end-exp eb ee) + (setq end-exp (format "--}-<<%s>>\n" type)) + (widen) + (if (re-search-forward end-exp nil t) + (progn + (setq eb (match-beginning 0)) + (setq ee (match-end 0)) + ) + (setq eb (point-max)) + (setq ee (point-max)) + ) + (narrow-to-region be eb) + (goto-char be) + (if (re-search-forward mime-editor/multipart-beginning-regexp nil t) + (let (ret) + (narrow-to-region (match-beginning 0)(point-max)) + (mime-editor/find-inmost) + ) + (widen) + (list type bb be eb) + )))) + +(defun mime-editor/process-multipart-1 (boundary) + (let ((ret (mime-editor/find-inmost))) + (if ret + (let ((type (car ret)) + (bb (nth 1 ret))(be (nth 2 ret)) + (eb (nth 3 ret)) + ) + (narrow-to-region bb eb) + (delete-region bb be) + (setq bb (point-min)) + (setq eb (point-max)) + (widen) + (goto-char eb) + (if (looking-at mime-editor/multipart-end-regexp) + (let ((beg (match-beginning 0)) + (end (match-end 0)) + ) + (delete-region beg end) + (or (looking-at mime-editor/beginning-tag-regexp) + (eobp) + (insert (concat (mime-make-text-tag) "\n")) + ))) + (cond ((string-equal type "quote") + (mime-editor/enquote-region bb eb) + ) + ((string-equal type "signed") + (cond ((eq mime-editor/signing-type 'pgp-elkins) + (mime-editor/sign-pgp-elkins bb eb boundary) + ) + ((eq mime-editor/signing-type 'pgp-kazu) + (mime-editor/sign-pgp-kazu bb eb boundary) + )) + ) + ((string-equal type "encrypted") + (cond ((eq mime-editor/encrypting-type 'pgp-elkins) + (mime-editor/encrypt-pgp-elkins bb eb boundary) + ) + ((eq mime-editor/encrypting-type 'pgp-kazu) + (mime-editor/encrypt-pgp-kazu bb eb boundary) + ))) + (t + (setq boundary + (nth 2 (mime-editor/translate-region bb eb + boundary t))) + (goto-char bb) + (insert + (format "--[[multipart/%s; + boundary=\"%s\"][7bit]]\n" + type boundary)) + )) + boundary)))) + +(defun mime-editor/enquote-region (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (while (re-search-forward mime-editor/single-part-tag-regexp nil t) + (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) + (replace-match (concat "- " (substring tag 1))) + ))))) + +(defun mime-editor/dequote-region (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (while (re-search-forward + mime-editor/quoted-single-part-tag-regexp nil t) + (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) + (replace-match (concat "-" (substring tag 2))) + ))))) + +(defun mime-editor/sign-pgp-elkins (beg end boundary) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (let* ((ret + (mime-editor/translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret)) + (parts (nth 3 ret)) + (pgp-boundary (concat "pgp-sign-" boundary)) + ) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (or (funcall mime-editor/pgp-sign-function + (point-min)(point-max) nil nil pgp-boundary) + (throw 'mime-editor/error 'pgp-error) + ) + )))) + +(defvar mime-editor/encrypt-recipient-fields-list '("To" "cc")) + +(defun mime-editor/make-encrypt-recipient-header () + (let* ((names mime-editor/encrypt-recipient-fields-list) + (values + (std11-field-bodies (cons "From" names) + nil mail-header-separator)) + (from (prog1 + (car values) + (setq values (cdr values)))) + (header (and (stringp from) + (if (string-equal from "") + "" + (format "From: %s\n" from) + ))) + recipients) + (while (and names values) + (let ((name (car names)) + (value (car values)) + ) + (and (stringp value) + (or (string-equal value "") + (progn + (setq header (concat header name ": " value "\n") + recipients (if recipients + (concat recipients " ," value) + value)) + )))) + (setq names (cdr names) + values (cdr values)) + ) + (vector from recipients header) + )) + +(defun mime-editor/encrypt-pgp-elkins (beg end boundary) + (save-excursion + (save-restriction + (let (from recipients header) + (let ((ret (mime-editor/make-encrypt-recipient-header))) + (setq from (aref ret 0) + recipients (aref ret 1) + header (aref ret 2)) + ) + (narrow-to-region beg end) + (let* ((ret + (mime-editor/translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret)) + (parts (nth 3 ret)) + (pgp-boundary (concat "pgp-" boundary)) + ) + (goto-char beg) + (insert header) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (or (funcall mime-editor/pgp-encrypt-function + recipients (point-min) (point-max) from) + (throw 'mime-editor/error 'pgp-error) + ) + (goto-char beg) + (insert (format "--[[multipart/encrypted; + boundary=\"%s\"; + protocol=\"application/pgp-encrypted\"][7bit]] +--%s +Content-Type: application/pgp-encrypted + +--%s +Content-Type: application/octet-stream +Content-Transfer-Encoding: 7bit + +" pgp-boundary pgp-boundary pgp-boundary)) + (goto-char (point-max)) + (insert (format "\n--%s--\n" pgp-boundary)) + ))))) + +(defun mime-editor/sign-pgp-kazu (beg end boundary) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (let* ((ret + (mime-editor/translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret)) + (parts (nth 3 ret)) + ) + (goto-char beg) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (or (as-binary-process + (funcall mime-editor/traditional-pgp-sign-function + beg (point-max))) + (throw 'mime-editor/error 'pgp-error) + ) + (goto-char beg) + (insert + "--[[application/pgp; format=mime][7bit]]\n") + )) + )) + +(defun mime-editor/encrypt-pgp-kazu (beg end boundary) + (save-excursion + (let (from recipients header) + (let ((ret (mime-editor/make-encrypt-recipient-header))) + (setq from (aref ret 0) + recipients (aref ret 1) + header (aref ret 2)) + ) + (save-restriction + (narrow-to-region beg end) + (let* ((ret + (mime-editor/translate-region beg end boundary)) + (ctype (car ret)) + (encoding (nth 1 ret)) + (parts (nth 3 ret)) + ) + (goto-char beg) + (insert header) + (insert (format "Content-Type: %s\n" ctype)) + (if encoding + (insert (format "Content-Transfer-Encoding: %s\n" encoding)) + ) + (insert "\n") + (or (as-binary-process + (funcall mime-editor/pgp-encrypt-function + recipients beg (point-max) nil 'maybe) + ) + (throw 'mime-editor/error 'pgp-error) + ) + (goto-char beg) + (insert + "--[[application/pgp; format=mime][7bit]]\n") + )) + ))) + +(defun mime-editor/translate-body () + "Encode the tagged MIME body in current buffer in MIME compliant message." + (interactive) + (save-excursion + (let ((boundary + (concat mime-multipart-boundary "_" + (replace-space-with-underline (current-time-string)) + )) + (i 1) + ret) + (while (mime-editor/process-multipart-1 + (format "%s-%d" boundary i)) + (setq i (1+ i)) + ) + (save-restriction + ;; We are interested in message body. + (let* ((beg + (progn + (goto-char (point-min)) + (re-search-forward + (concat "\n" (regexp-quote mail-header-separator) + (if mime-ignore-preceding-spaces + "[ \t\n]*\n" "\n")) nil 'move) + (point))) + (end + (progn + (goto-char (point-max)) + (and mime-ignore-trailing-spaces + (re-search-backward "[^ \t\n]\n" beg t) + (forward-char 1)) + (point)))) + (setq ret (mime-editor/translate-region + beg end + (format "%s-%d" boundary i))) + )) + (mime-editor/dequote-region (point-min)(point-max)) + (let ((contype (car ret)) ;Content-Type + (encoding (nth 1 ret)) ;Content-Transfer-Encoding + ) + ;; Make primary MIME headers. + (or (mail-position-on-field "Mime-Version") + (insert mime-editor/mime-version-value)) + ;; Remove old Content-Type and other fields. + (save-restriction + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil t) + (narrow-to-region (point-min) (point)) + (goto-char (point-min)) + (mime-delete-field "Content-Type") + (mime-delete-field "Content-Transfer-Encoding")) + ;; Then, insert Content-Type and Content-Transfer-Encoding fields. + (mail-position-on-field "Content-Type") + (insert contype) + (if encoding + (progn + (mail-position-on-field "Content-Transfer-Encoding") + (insert encoding))) + )))) + +(defun mime-editor/translate-single-part-tag (&optional prefix) + (if (re-search-forward mime-editor/single-part-tag-regexp nil t) + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (tag (buffer-substring beg end)) + ) + (delete-region beg end) + (setq contype (mime-editor/get-contype tag)) + (setq encoding (mime-editor/get-encoding tag)) + (insert (concat prefix "--" boundary "\n")) + (save-restriction + (narrow-to-region (point)(point)) + (insert "Content-Type: " contype "\n") + (if encoding + (insert "Content-Transfer-Encoding: " encoding "\n")) + (mime/encode-message-header) + ) + t))) + +(defun mime-editor/translate-region (beg end &optional boundary multipart) + (if (null boundary) + (setq boundary + (concat mime-multipart-boundary "_" + (replace-space-with-underline (current-time-string)))) + ) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (let ((tag nil) ;MIME tag + (contype nil) ;Content-Type + (encoding nil) ;Content-Transfer-Encoding + (nparts 0)) ;Number of body parts + ;; Normalize the body part by inserting appropriate message + ;; tags for every message contents. + (mime-editor/normalize-body) + ;; Counting the number of Content-Type. + (goto-char (point-min)) + (while (re-search-forward mime-editor/single-part-tag-regexp nil t) + (setq nparts (1+ nparts))) + ;; Begin translation. + (cond + ((and (<= nparts 1)(not multipart)) + ;; It's a singular message. + (goto-char (point-min)) + (while (re-search-forward + mime-editor/single-part-tag-regexp nil t) + (setq tag + (buffer-substring (match-beginning 0) (match-end 0))) + (delete-region (match-beginning 0) (1+ (match-end 0))) + (setq contype (mime-editor/get-contype tag)) + (setq encoding (mime-editor/get-encoding tag)) + )) + (t + ;; It's a multipart message. + (goto-char (point-min)) + (and (mime-editor/translate-single-part-tag) + (while (mime-editor/translate-single-part-tag "\n")) + ) + ;; Define Content-Type as "multipart/mixed". + (setq contype + (concat "multipart/mixed;\n boundary=\"" boundary "\"")) + ;; Content-Transfer-Encoding must be "7bit". + ;; The following encoding can be `nil', but is + ;; specified as is since there is no way that a user + ;; specifies it. + (setq encoding "7bit") + ;; Insert the trailer. + (goto-char (point-max)) + (insert "\n--" boundary "--\n") + )) + (list contype encoding boundary nparts) + )))) + +(defun mime-editor/normalize-body () + "Normalize the body part by inserting appropriate message tags." + ;; Insert the first MIME tags if necessary. + (goto-char (point-min)) + (if (not (looking-at mime-editor/single-part-tag-regexp)) + (insert (mime-make-text-tag) "\n")) + ;; Check each tag, and add new tag or correct it if necessary. + (goto-char (point-min)) + (while (re-search-forward mime-editor/single-part-tag-regexp nil t) + (let* ((tag (buffer-substring (match-beginning 0) (match-end 0))) + (contype (mime-editor/get-contype tag)) + (charset (mime-get-parameter contype "charset")) + (encoding (mime-editor/get-encoding tag))) + ;; Remove extra whitespaces after the tag. + (if (looking-at "[ \t]+$") + (delete-region (match-beginning 0) (match-end 0))) + (let ((beg (point)) + (end (mime-editor/content-end)) + ) + (if (= end (point-max)) + nil + (goto-char end) + (or (looking-at mime-editor/beginning-tag-regexp) + (eobp) + (insert (mime-make-text-tag) "\n") + )) + (visible-region beg end) + (goto-char beg) + ) + (cond + ((mime-test-content-type contype "message") + ;; Content-type "message" should be sent as is. + (forward-line 1) + ) + ((mime-test-content-type contype "text") + ;; Define charset for text if necessary. + (setq charset (if charset + (intern (downcase charset)) + (mime-editor/choose-charset))) + (mime-editor/define-charset charset) + (cond ((string-equal contype "text/x-rot13-47") + (save-excursion + (forward-line) + (set-mark (point)) + (goto-char (mime-editor/content-end)) + (tm:caesar-region) + )) + ((string-equal contype "text/enriched") + (save-excursion + (let ((beg (progn + (forward-line) + (point))) + (end (mime-editor/content-end)) + ) + ;; Patch for hard newlines + ;; (save-excursion + ;; (goto-char beg) + ;; (while (search-forward "\n" end t) + ;; (put-text-property (match-beginning 0) + ;; (point) + ;; 'hard t))) + ;; End patch for hard newlines + (enriched-encode beg end) + (goto-char beg) + (if (search-forward "\n\n") + (delete-region beg (match-end 0)) + ) + )))) + ;; Point is now on current tag. + ;; Define encoding and encode text if necessary. + (or encoding ;Encoding is not specified. + (let* ((encoding + (cdr + (assq charset + mime-editor/charset-default-encoding-alist) + )) + (beg (mime-editor/content-beginning)) + ) + (encode-mime-charset-region beg (mime-editor/content-end) + charset) + (mime-encode-region beg (mime-editor/content-end) encoding) + (mime-editor/define-encoding encoding) + )) + (goto-char (mime-editor/content-end)) + ) + ((null encoding) ;Encoding is not specified. + ;; Application, image, audio, video, and any other + ;; unknown content-type without encoding should be + ;; encoded. + (let* ((encoding "base64") ;Encode in BASE64 by default. + (beg (mime-editor/content-beginning)) + (end (mime-editor/content-end)) + (body (buffer-substring beg end)) + ) + (mime-encode-region beg end encoding) + (mime-editor/define-encoding encoding)) + (forward-line 1) + )) + ))) + +(defun mime-delete-field (field) + "Delete header FIELD." + (let ((regexp (format "^%s:[ \t]*" field))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point))) + ))) + + +;;; +;;; Platform dependent functions +;;; + +;; Sun implementations + +(defun mime-editor/voice-recorder-for-sun (encoding) + "Record voice in a buffer using Sun audio device, +and insert data encoded as ENCODING. [tm-edit.el]" + (message "Start the recording on %s. Type C-g to finish the recording..." + (system-name)) + (mime-insert-encoded-file "/dev/audio" encoding) + ) + + +;;; @ Other useful commands. +;;; + +;; Message forwarding commands as content-type "message/rfc822". + +(defun mime-editor/insert-message (&optional message) + (interactive) + (let ((inserter (assoc-value major-mode mime-editor/message-inserter-alist))) + (if (and inserter (fboundp inserter)) + (progn + (mime-editor/insert-tag "message" "rfc822") + (funcall inserter message) + ) + (message "Sorry, I don't have message inserter for your MUA.") + ))) + +(defun mime-editor/insert-mail (&optional message) + (interactive) + (let ((inserter (assoc-value major-mode mime-editor/mail-inserter-alist))) + (if (and inserter (fboundp inserter)) + (progn + (mime-editor/insert-tag "message" "rfc822") + (funcall inserter message) + ) + (message "Sorry, I don't have mail inserter for your MUA.") + ))) + +(defun mime-editor/inserted-message-filter () + (save-excursion + (save-restriction + (let ((header-start (point)) + (case-fold-search t) + beg end) + ;; for Emacs 18 + ;; (if (re-search-forward "^$" (marker-position (mark-marker))) + (if (re-search-forward "^$" (mark t)) + (narrow-to-region header-start (match-beginning 0)) + ) + (goto-char header-start) + (while (and (re-search-forward + mime-editor/yank-ignored-field-regexp nil t) + (setq beg (match-beginning 0)) + (setq end (1+ (std11-field-end))) + ) + (delete-region beg end) + ) + )))) + + +;;; @ multipart enclosure +;;; + +(defun mime-editor/enclose-region (type beg end) + (save-excursion + (goto-char beg) + (let ((current (point))) + (save-restriction + (narrow-to-region beg end) + (insert (format "--<<%s>>-{\n" type)) + (goto-char (point-max)) + (insert (format "--}-<<%s>>\n" type)) + (goto-char (point-max)) + ) + (or (looking-at mime-editor/beginning-tag-regexp) + (eobp) + (insert (mime-make-text-tag) "\n") + ) + ))) + +(defun mime-editor/enclose-quote-region (beg end) + (interactive "*r") + (mime-editor/enclose-region "quote" beg end) + ) + +(defun mime-editor/enclose-mixed-region (beg end) + (interactive "*r") + (mime-editor/enclose-region "mixed" beg end) + ) + +(defun mime-editor/enclose-parallel-region (beg end) + (interactive "*r") + (mime-editor/enclose-region "parallel" beg end) + ) + +(defun mime-editor/enclose-digest-region (beg end) + (interactive "*r") + (mime-editor/enclose-region "digest" beg end) + ) + +(defun mime-editor/enclose-alternative-region (beg end) + (interactive "*r") + (mime-editor/enclose-region "alternative" beg end) + ) + +(defun mime-editor/enclose-signed-region (beg end) + (interactive "*r") + (if mime-editor/signing-type + (mime-editor/enclose-region "signed" beg end) + (message "Please specify signing type.") + )) + +(defun mime-editor/enclose-encrypted-region (beg end) + (interactive "*r") + (if mime-editor/signing-type + (mime-editor/enclose-region "encrypted" beg end) + (message "Please specify encrypting type.") + )) + +(defun mime-editor/insert-key (&optional arg) + "Insert a pgp public key." + (interactive "P") + (mime-editor/insert-tag "application" "pgp-keys") + (mime-editor/define-encoding "7bit") + (funcall mime-editor/pgp-insert-public-key-function) + ) + + +;;; @ flag setting +;;; + +(defun mime-editor/set-split (arg) + (interactive + (list + (y-or-n-p "Do you want to enable split?") + )) + (setq mime-editor/split-message arg) + (if arg + (message "This message is enabled to split.") + (message "This message is not enabled to split.") + )) + +(defun mime-editor/toggle-transfer-level (&optional transfer-level) + "Toggle transfer-level is 7bit or 8bit through. + +Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8." + (interactive) + (if (numberp transfer-level) + (setq mime-editor/transfer-level transfer-level) + (if (< mime-editor/transfer-level 8) + (setq mime-editor/transfer-level 8) + (setq mime-editor/transfer-level 7) + )) + (setq mime-editor/charset-default-encoding-alist + (mime-editor/make-charset-default-encoding-alist + mime-editor/transfer-level)) + (message (format "Current transfer-level is %d bit" + mime-editor/transfer-level)) + (setq mime-editor/transfer-level-string + (mime/encoding-name mime-editor/transfer-level 'not-omit)) + (force-mode-line-update) + ) + +(defun mime-editor/set-transfer-level-7bit () + (interactive) + (mime-editor/toggle-transfer-level 7) + ) + +(defun mime-editor/set-transfer-level-8bit () + (interactive) + (mime-editor/toggle-transfer-level 8) + ) + + +;;; @ pgp +;;; + +(defun mime-editor/set-sign (arg) + (interactive + (list + (y-or-n-p "Do you want to sign?") + )) + (if arg + (if mime-editor/signing-type + (progn + (setq mime-editor/pgp-processing 'sign) + (message "This message will be signed.") + ) + (message "Please specify signing type.") + ) + (if (eq mime-editor/pgp-processing 'sign) + (setq mime-editor/pgp-processing nil) + ) + (message "This message will not be signed.") + )) + +(defun mime-editor/set-encrypt (arg) + (interactive + (list + (y-or-n-p "Do you want to encrypt?") + )) + (if arg + (if mime-editor/encrypting-type + (progn + (setq mime-editor/pgp-processing 'encrypt) + (message "This message will be encrypt.") + ) + (message "Please specify encrypting type.") + ) + (if (eq mime-editor/pgp-processing 'encrypt) + (setq mime-editor/pgp-processing nil) + ) + (message "This message will not be encrypt.") + )) + +(defvar mime-editor/pgp-processing nil) +(make-variable-buffer-local 'mime-editor/pgp-processing) + +(defun mime-editor/pgp-enclose-buffer () + (let ((beg (save-excursion + (goto-char (point-min)) + (if (search-forward (concat "\n" mail-header-separator "\n")) + (match-end 0) + ))) + (end (point-max)) + ) + (if beg + (cond ((eq mime-editor/pgp-processing 'sign) + (mime-editor/enclose-signed-region beg end) + ) + ((eq mime-editor/pgp-processing 'encrypt) + (mime-editor/enclose-encrypted-region beg end) + )) + ))) + + +;;; @ split +;;; + +(defun mime-editor/insert-partial-header + (fields subject id number total separator) + (insert fields) + (insert (format "Subject: %s (%d/%d)\n" subject number total)) + (insert (format "Mime-Version: 1.0 (split by %s)\n" + mime-editor/version-name)) + (insert (format "\ +Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" + id number total separator)) + ) + +(defun mime-editor/split-and-send + (&optional cmd lines mime-editor/message-max-length) + (interactive) + (or lines + (setq lines + (count-lines (point-min) (point-max))) + ) + (or mime-editor/message-max-length + (setq mime-editor/message-max-length + (or (cdr (assq major-mode mime-editor/message-max-lines-alist)) + mime-editor/message-default-max-lines)) + ) + (let* ((mime-editor/draft-file-name + (or (buffer-file-name) + (make-temp-name + (expand-file-name "tm-draft" mime/tmp-dir)))) + (separator mail-header-separator) + (id (concat "\"" + (replace-space-with-underline (current-time-string)) + "@" (system-name) "\""))) + (run-hooks 'mime-editor/before-split-hook) + (let ((the-buf (current-buffer)) + (copy-buf (get-buffer-create " *Original Message*")) + (header (std11-header-string-except + mime-editor/split-ignored-field-regexp separator)) + (subject (mail-fetch-field "subject")) + (total (+ (/ lines mime-editor/message-max-length) + (if (> (mod lines mime-editor/message-max-length) 0) + 1))) + (command + (or cmd + (cdr + (assq major-mode + mime-editor/split-message-sender-alist)) + (function + (lambda () + (interactive) + (error "Split sender is not specified for `%s'." major-mode) + )) + )) + (mime-editor/partial-number 1) + data) + (save-excursion + (set-buffer copy-buf) + (erase-buffer) + (insert-buffer the-buf) + (save-restriction + (if (re-search-forward + (concat "^" (regexp-quote separator) "$") nil t) + (let ((he (match-beginning 0))) + (replace-match "") + (narrow-to-region (point-min) he) + )) + (goto-char (point-min)) + (while (re-search-forward mime-editor/split-blind-field-regexp nil t) + (delete-region (match-beginning 0) + (1+ (std11-field-end))) + ))) + (while (< mime-editor/partial-number total) + (erase-buffer) + (save-excursion + (set-buffer copy-buf) + (setq data (buffer-substring + (point-min) + (progn + (goto-line mime-editor/message-max-length) + (point)) + )) + (delete-region (point-min)(point)) + ) + (mime-editor/insert-partial-header + header subject id mime-editor/partial-number total separator) + (insert data) + (save-excursion + (message (format "Sending %d/%d..." + mime-editor/partial-number total)) + (call-interactively command) + (message (format "Sending %d/%d... done" + mime-editor/partial-number total)) + ) + (setq mime-editor/partial-number + (1+ mime-editor/partial-number)) + ) + (erase-buffer) + (save-excursion + (set-buffer copy-buf) + (setq data (buffer-string)) + (erase-buffer) + ) + (mime-editor/insert-partial-header + header subject id mime-editor/partial-number total separator) + (insert data) + (save-excursion + (message (format "Sending %d/%d..." + mime-editor/partial-number total)) + (message (format "Sending %d/%d... done" + mime-editor/partial-number total)) + ) + ))) + +(defun mime-editor/maybe-split-and-send (&optional cmd) + (interactive) + (run-hooks 'mime-editor/before-send-hook) + (let ((mime-editor/message-max-length + (or (cdr (assq major-mode mime-editor/message-max-lines-alist)) + mime-editor/message-default-max-lines)) + (lines (count-lines (point-min) (point-max))) + ) + (if (and (> lines mime-editor/message-max-length) + mime-editor/split-message) + (mime-editor/split-and-send cmd lines mime-editor/message-max-length) + ))) + + +;;; @ preview message +;;; + +(defun mime-editor/preview-message () + "preview editing MIME message. [tm-edit.el]" + (interactive) + (let* ((str (buffer-string)) + (separator mail-header-separator) + (the-buf (current-buffer)) + (buf-name (buffer-name)) + (temp-buf-name (concat "*temp-article:" buf-name "*")) + (buf (get-buffer temp-buf-name)) + ) + (if buf + (progn + (switch-to-buffer buf) + (erase-buffer) + ) + (setq buf (get-buffer-create temp-buf-name)) + (switch-to-buffer buf) + ) + (insert str) + (setq major-mode 'mime/temporary-message-mode) + (make-local-variable 'mail-header-separator) + (setq mail-header-separator separator) + (make-local-variable 'mime/editing-buffer) + (setq mime/editing-buffer the-buf) + + (run-hooks 'mime-editor/translate-hook) + (mime-editor/translate-buffer) + (goto-char (point-min)) + (if (re-search-forward + (concat "^" (regexp-quote separator) "$")) + (replace-match "") + ) + (mime/viewer-mode) + )) + +(defun mime-editor/quitting-method () + (let ((temp mime::preview/article-buffer) + buf) + (mime-viewer/kill-buffer) + (set-buffer temp) + (setq buf mime/editing-buffer) + (kill-buffer temp) + (switch-to-buffer buf) + )) + +(set-alist 'mime-viewer/quitting-method-alist + 'mime/temporary-message-mode + (function mime-editor/quitting-method) + ) + + +;;; @ draft preview +;;; +;; by "OKABE Yasuo +;; Mon, 10 Apr 1995 20:03:07 +0900 + +(defvar mime-editor/draft-header-separator-alist + '((news-reply-mode . mail-header-separator) + (mh-letter-mode . mail-header-separator) + )) + +(defvar mime::article/draft-header-separator nil) + +(defun mime-editor/draft-preview () + (interactive) + (let ((sep (cdr (assq major-mode mime-editor/draft-header-separator-alist)))) + (or (stringp sep) (setq sep (eval sep))) + (make-variable-buffer-local 'mime::article/draft-header-separator) + (goto-char (point-min)) + (re-search-forward + (concat "^\\(" (regexp-quote sep) "\\)?$")) + (setq mime::article/draft-header-separator + (buffer-substring (match-beginning 0) (match-end 0))) + (replace-match "") + (mime/viewer-mode (current-buffer)) + (pop-to-buffer (current-buffer)) + )) + +(defun mime-viewer::quitting-method/draft-preview () + (let ((mother mime::preview/mother-buffer)) + (save-excursion + (switch-to-buffer mother) + (goto-char (point-min)) + (if (and + (re-search-forward + (concat "^\\(" + (regexp-quote mime::article/draft-header-separator) + "\\)?$") nil t) + (bolp)) + (progn + (insert mime::article/draft-header-separator) + (set-buffer-modified-p (buffer-modified-p)) + ))) + (mime-viewer/kill-buffer) + (pop-to-buffer mother) + )) + +(set-alist 'mime-viewer/quitting-method-alist + 'mh-letter-mode + (function mime-viewer::quitting-method/draft-preview) + ) + +(set-alist 'mime-viewer/quitting-method-alist + 'news-reply-mode + (function mime-viewer::quitting-method/draft-preview) + ) + + +;;; @ edit again +;;; + +(defun mime-editor::edit-again (code-conversion) + (save-excursion + (goto-char (point-min)) + (let ((ctl (mime/Content-Type))) + (if ctl + (let ((ctype (car ctl)) + (params (cdr ctl)) + type stype) + (if (string-match "/" ctype) + (progn + (setq type (substring ctype 0 (match-beginning 0))) + (setq stype (substring ctype (match-end 0))) + ) + (setq type ctype) + ) + (cond + ((string-equal type "multipart") + (let* ((boundary (assoc-value "boundary" params)) + (boundary-pat + (concat "\n--" (regexp-quote boundary) "[ \t]*\n")) + ) + (re-search-forward boundary-pat nil t) + (let ((bb (match-beginning 0)) eb tag) + (setq tag (format "\n--<<%s>>-{\n" stype)) + (goto-char bb) + (insert tag) + (setq bb (+ bb (length tag))) + (re-search-forward + (concat "\n--" (regexp-quote boundary) "--[ \t]*\n") + nil t) + (setq eb (match-beginning 0)) + (replace-match (format "--}-<<%s>>\n" stype)) + (save-restriction + (narrow-to-region bb eb) + (goto-char (point-min)) + (while (re-search-forward boundary-pat nil t) + (let ((beg (match-beginning 0)) + end) + (delete-region beg (match-end 0)) + (save-excursion + (if (re-search-forward boundary-pat nil t) + (setq end (match-beginning 0)) + (setq end (point-max)) + ) + (save-restriction + (narrow-to-region beg end) + (mime-editor::edit-again code-conversion) + (goto-char (point-max)) + )))) + )) + (goto-char (point-min)) + (or (= (point-min) 1) + (delete-region (point-min) + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-min) + ))) + )) + (t + (let* (charset + (pstr + (mapconcat (function + (lambda (attr) + (if (string-equal (car attr) + "charset") + (progn + (setq charset (cdr attr)) + "") + (concat ";" (car attr) + "=" (cdr attr)) + ) + )) + params "")) + encoding + encoded) + (save-excursion + (if (re-search-forward + "Content-Transfer-Encoding:" nil t) + (let ((beg (match-beginning 0)) + (hbeg (match-end 0)) + (end (std11-field-end))) + (setq encoding + (eliminate-top-spaces + (std11-unfold-string + (buffer-substring hbeg end)))) + (if (or charset (string-equal type "text")) + (progn + (delete-region beg (1+ end)) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (progn + (mime-decode-region + (match-end 0)(point-max) encoding) + (setq encoded t + encoding nil) + ))))))) + (if (or code-conversion encoded) + (decode-mime-charset-region + (point-min)(point-max) + (or charset default-mime-charset)) + ) + (let ((he + (if (re-search-forward "^$" nil t) + (match-end 0) + (point-min) + ))) + (if (= (point-min) 1) + (progn + (goto-char he) + (insert + (concat "\n" + (mime-create-tag + (concat type "/" stype pstr) encoding))) + ) + (delete-region (point-min) he) + (insert + (mime-create-tag + (concat type "/" stype pstr) encoding)) + )) + )))) + (if code-conversion + (decode-mime-charset-region (point-min) (point-max) + default-mime-charset) + ) + )))) + +(defun mime/edit-again (&optional code-conversion no-separator no-mode) + (interactive) + (mime-editor::edit-again code-conversion) + (goto-char (point-min)) + (save-restriction + (narrow-to-region + (point-min) + (if (re-search-forward + (concat "^\\(" (regexp-quote mail-header-separator) "\\)?$") + nil t) + (match-end 0) + (point-max) + )) + (goto-char (point-min)) + (while (re-search-forward + "^\\(Content-.*\\|Mime-Version\\):" nil t) + (delete-region (match-beginning 0) (1+ (std11-field-end))) + )) + (or no-separator + (and (re-search-forward "^$") + (replace-match mail-header-separator) + )) + (or no-mode + (mime/editor-mode) + )) + + +;;; @ end +;;; + +(provide 'tm-edit) + +(run-hooks 'tm-edit-load-hook) + +;;; tm-edit.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-ew-d.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-ew-d.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,249 @@ +;;; tm-ew-d.el --- RFC 2047 based encoded-word decoder for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: ENAMI Tsugutomo +;; MORIOKA Tomohiko +;; Maintainer: MORIOKA Tomohiko +;; Created: 1995/10/03 +;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'. +;; Renamed: 1993/06/03 to tiny-mime.el. +;; Renamed: 1995/10/03 from tiny-mime.el. (split off encoder) +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: encoded-word, MIME, multilingual, header, mail, news + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'emu) +(require 'std11) +(require 'mel) +(require 'tm-def) + + +;;; @ version +;;; + +(defconst tm-ew-d/RCS-ID + "$Id: tm-ew-d.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $") +(defconst mime/eword-decoder-version (get-version-string tm-ew-d/RCS-ID)) + + +;;; @ MIME encoded-word definition +;;; + +(defconst mime/encoded-text-regexp "[!->@-~]+") +(defconst mime/encoded-word-regexp (concat (regexp-quote "=?") + "\\(" + mime/charset-regexp + "\\)" + (regexp-quote "?") + "\\(B\\|Q\\)" + (regexp-quote "?") + "\\(" + mime/encoded-text-regexp + "\\)" + (regexp-quote "?="))) + + +;;; @ for string +;;; + +(defun mime-eword/decode-string (string &optional must-unfold) + "Decode MIME encoded-words in STRING. + +STRING is unfolded before decoding. + +If an encoded-word is broken or your emacs implementation can not +decode the charset included in it, it is not decoded. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-words (generated by bad manner MUA +such as a version of Net$cape). [tm-ew-d.el]" + (setq string (std11-unfold-string string)) + (let ((dest "")(ew nil) + beg end) + (while (and (string-match mime/encoded-word-regexp string) + (setq beg (match-beginning 0) + end (match-end 0)) + ) + (if (> beg 0) + (if (not + (and (eq ew t) + (string-match "^[ \t]+$" (substring string 0 beg)) + )) + (setq dest (concat dest (substring string 0 beg))) + ) + ) + (setq dest + (concat dest + (mime/decode-encoded-word + (substring string beg end) must-unfold) + )) + (setq string (substring string end)) + (setq ew t) + ) + (concat dest string) + )) + + +;;; @ for region +;;; + +(defun mime-eword/decode-region (start end &optional unfolding must-unfold) + "Decode MIME encoded-words in region between START and END. + +If UNFOLDING is not nil, it unfolds before decoding. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-words (generated by bad manner MUA +such as a version of Net$cape). [tm-ew-d.el]" + (interactive "*r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (if unfolding + (mime/unfolding) + ) + (goto-char (point-min)) + (while (re-search-forward "\\?=\\(\n*\\s +\\)+=\\?" nil t) + (replace-match "?==?") + ) + (goto-char (point-min)) + (let (charset encoding text) + (while (re-search-forward mime/encoded-word-regexp nil t) + (insert (mime/decode-encoded-word + (prog1 + (buffer-substring (match-beginning 0) (match-end 0)) + (delete-region (match-beginning 0) (match-end 0)) + ) must-unfold)) + )) + ))) + + +;;; @ for message header +;;; + +(defun mime/decode-message-header () + "Decode MIME encoded-words in message header. [tm-ew-d.el]" + (interactive "*") + (save-excursion + (save-restriction + (narrow-to-region (goto-char (point-min)) + (progn (re-search-forward "^$" nil t) (point))) + (mime-eword/decode-region (point-min) (point-max) t) + ))) + +(defun mime/unfolding () + (goto-char (point-min)) + (let (field beg end) + (while (re-search-forward std11-field-head-regexp nil t) + (setq beg (match-beginning 0) + end (std11-field-end)) + (setq field (buffer-substring beg end)) + (if (string-match mime/encoded-word-regexp field) + (save-restriction + (narrow-to-region (goto-char beg) end) + (while (re-search-forward "\n\\([ \t]\\)" nil t) + (replace-match + (match-string 1)) + ) + (goto-char (point-max)) + )) + ))) + + +;;; @ encoded-word decoder +;;; + +(defun mime/decode-encoded-word (word &optional must-unfold) + "Decode WORD if it is an encoded-word. + +If your emacs implementation can not decode the charset of WORD, it +returns WORD. Similarly the encoded-word is broken, it returns WORD. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-word (generated by bad manner MUA such +as a version of Net$cape). [tm-ew-d.el]" + (or (if (string-match mime/encoded-word-regexp word) + (let ((charset + (substring word (match-beginning 1) (match-end 1)) + ) + (encoding + (upcase + (substring word (match-beginning 2) (match-end 2)) + )) + (text + (substring word (match-beginning 3) (match-end 3)) + )) + (condition-case err + (mime/decode-encoded-text charset encoding text must-unfold) + (error nil)) + )) + word)) + + +;;; @ encoded-text decoder +;;; + +(defun mime/decode-encoded-text (charset encoding string &optional must-unfold) + "Decode STRING as an encoded-text. + +If your emacs implementation can not decode CHARSET, it returns nil. + +If ENCODING is not \"B\" or \"Q\", it occurs error. +So you should write error-handling code if you don't want break by errors. + +If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even +if there are in decoded encoded-text (generated by bad manner MUA such +as a version of Net$cape). [tm-ew-d.el]" + (let ((cs (mime-charset-to-coding-system charset))) + (if cs + (let ((dest + (cond ((and (string-equal "B" encoding) + (string-match mime/B-encoded-text-regexp string)) + (base64-decode-string string)) + ((and (string-equal "Q" encoding) + (string-match mime/Q-encoded-text-regexp string)) + (q-encoding-decode-string string)) + (t (message "Invalid encoded-word %s" encoding) + nil)))) + (if dest + (progn + (setq dest (decode-coding-string dest cs)) + (if must-unfold + (mapconcat (function + (lambda (chr) + (if (eq chr ?\n) + "" + (char-to-string chr) + ) + )) + (std11-unfold-string dest) + "") + dest) + )))))) + + +;;; @ end +;;; + +(provide 'tm-ew-d) + +;;; tm-ew-d.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-ew-e.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-ew-e.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,623 @@ +;;; tm-ew-e.el --- RFC 2047 based encoded-word encoder for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: encoded-word, MIME, multilingual, header, mail, news + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'mel) +(require 'std11) +(require 'tm-def) +(require 'tl-list) + + +;;; @ version +;;; + +(defconst tm-ew-e/RCS-ID + "$Id: tm-ew-e.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $") +(defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID)) + + +;;; @ variables +;;; + +(defvar mime/field-encoding-method-alist + (if (boundp 'mime/no-encoding-header-fields) + (nconc + (mapcar (function + (lambda (field-name) + (cons field-name 'default-mime-charset) + )) + mime/no-encoding-header-fields) + '((t . mime)) + ) + '(("X-Nsubject" . iso-2022-jp-2) + ("Newsgroups" . nil) + (t . mime) + )) + "*Alist to specify field encoding method. +Its key is field-name, value is encoding method. + +If method is `mime', this field will be encoded into MIME format. + +If method is a MIME-charset, this field will be encoded as the charset +when it must be convert into network-code. + +If method is `default-mime-charset', this field will be encoded as +variable `default-mime-charset' when it must be convert into +network-code. + +If method is nil, this field will not be encoded. [tm-ew-e.el]") + +(defvar mime/generate-X-Nsubject + (and (boundp 'mime/use-X-Nsubject) + mime/use-X-Nsubject) + "*If it is not nil, X-Nsubject field is generated +when Subject field is encoded by `mime/encode-message-header'. +\[tm-ew-e.el]") + +(defvar mime-eword/charset-encoding-alist + '((us-ascii . nil) + (iso-8859-1 . "Q") + (iso-8859-2 . "Q") + (iso-8859-3 . "Q") + (iso-8859-4 . "Q") + (iso-8859-5 . "Q") + (koi8-r . "Q") + (iso-8859-7 . "Q") + (iso-8859-8 . "Q") + (iso-8859-9 . "Q") + (iso-2022-jp . "B") + (iso-2022-kr . "B") + (euc-kr . "B") + (iso-2022-jp-2 . "B") + (iso-2022-int-1 . "B") + )) + +;;; @ encoded-text encoder +;;; + +(defun tm-eword::encode-encoded-text (charset encoding string &optional mode) + (let ((text + (cond ((string= encoding "B") + (base64-encode-string string)) + ((string= encoding "Q") + (q-encoding-encode-string string mode)) + ) + )) + (if text + (concat "=?" (upcase (symbol-name charset)) "?" + encoding "?" text "?=") + ))) + + +;;; @ leading char +;;; + +(defun tm-eword::char-type (chr) + (if (or (= chr 32)(= chr ?\t)) + nil + (char-charset chr) + )) + +(defun tm-eword::parse-lc-word (str) + (let* ((chr (sref str 0)) + (lc (tm-eword::char-type chr)) + (i (char-length chr)) + (len (length str)) + ) + (while (and (< i len) + (setq chr (sref str i)) + (eq lc (tm-eword::char-type chr)) + ) + (setq i (+ i (char-length chr))) + ) + (cons (cons lc (substring str 0 i)) (substring str i)) + )) + +(defun tm-eword::split-to-lc-words (str) + (let (ret dest) + (while (and (not (string= str "")) + (setq ret (tm-eword::parse-lc-word str)) + ) + (setq dest (cons (car ret) dest)) + (setq str (cdr ret)) + ) + (reverse dest) + )) + + +;;; @ word +;;; + +(defun tm-eword::parse-word (lcwl) + (let* ((lcw (car lcwl)) + (lc (car lcw)) + ) + (if (null lc) + lcwl + (let ((lcl (list lc)) + (str (cdr lcw)) + ) + (catch 'tag + (while (setq lcwl (cdr lcwl)) + (setq lcw (car lcwl)) + (setq lc (car lcw)) + (if (null lc) + (throw 'tag nil) + ) + (if (not (memq lc lcl)) + (setq lcl (cons lc lcl)) + ) + (setq str (concat str (cdr lcw))) + )) + (cons (cons lcl str) lcwl) + )))) + +(defun tm-eword::lc-words-to-words (lcwl) + (let (ret dest) + (while (setq ret (tm-eword::parse-word lcwl)) + (setq dest (cons (car ret) dest)) + (setq lcwl (cdr ret)) + ) + (reverse dest) + )) + + +;;; @ rule +;;; + +(defmacro tm-eword::make-rword (text charset encoding type) + (` (list (, text)(, charset)(, encoding)(, type)))) +(defmacro tm-eword::rword-text (rword) + (` (car (, rword)))) +(defmacro tm-eword::rword-charset (rword) + (` (car (cdr (, rword))))) +(defmacro tm-eword::rword-encoding (rword) + (` (car (cdr (cdr (, rword)))))) +(defmacro tm-eword::rword-type (rword) + (` (car (cdr (cdr (cdr (, rword))))))) + +(defun tm-eword::find-charset-rule (charsets) + (if charsets + (let* ((charset (charsets-to-mime-charset charsets)) + (encoding (cdr (assq charset mime-eword/charset-encoding-alist))) + ) + (list charset encoding) + ))) + +(defun tm-eword::words-to-ruled-words (wl &optional mode) + (mapcar (function + (lambda (word) + (let ((ret (tm-eword::find-charset-rule (car word)))) + (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode) + ))) + wl)) + +(defun tm-eword::space-process (seq) + (let (prev a ac b c cc) + (while seq + (setq b (car seq)) + (setq seq (cdr seq)) + (setq c (car seq)) + (setq cc (tm-eword::rword-charset c)) + (if (null (tm-eword::rword-charset b)) + (progn + (setq a (car prev)) + (setq ac (tm-eword::rword-charset a)) + (if (and (tm-eword::rword-encoding a) + (tm-eword::rword-encoding c)) + (cond ((eq ac cc) + (setq prev (cons + (cons (concat (car a)(car b)(car c)) + (cdr a)) + (cdr prev) + )) + (setq seq (cdr seq)) + ) + (t + (setq prev (cons + (cons (concat (car a)(car b)) + (cdr a)) + (cdr prev) + )) + )) + (setq prev (cons b prev)) + )) + (setq prev (cons b prev)) + )) + (reverse prev) + )) + +(defun tm-eword::split-string (str &optional mode) + (tm-eword::space-process + (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words + (tm-eword::split-to-lc-words str)) + mode))) + + +;;; @ length +;;; + +(defun tm-eword::encoded-word-length (rword) + (let ((string (tm-eword::rword-text rword)) + (charset (tm-eword::rword-charset rword)) + (encoding (tm-eword::rword-encoding rword)) + ret) + (setq ret + (cond ((string-equal encoding "B") + (setq string (encode-mime-charset-string string charset)) + (base64-encoded-length string) + ) + ((string-equal encoding "Q") + (setq string (encode-mime-charset-string string charset)) + (q-encoding-encoded-length string + (tm-eword::rword-type rword)) + ))) + (if ret + (cons (+ 7 (length (symbol-name charset)) ret) string) + ))) + + +;;; @ encode-string +;;; + +(defun tm-eword::encode-string-1 (column rwl) + (let* ((rword (car rwl)) + (ret (tm-eword::encoded-word-length rword)) + string len) + (if (null ret) + (cond ((and (setq string (car rword)) + (<= (setq len (+ (length string) column)) 76) + ) + (setq rwl (cdr rwl)) + ) + (t + (setq string "\n ") + (setq len 1) + )) + (cond ((and (setq len (car ret)) + (<= (+ column len) 76) + ) + (setq string + (tm-eword::encode-encoded-text + (tm-eword::rword-charset rword) + (tm-eword::rword-encoding rword) + (cdr ret) + (tm-eword::rword-type rword) + )) + (setq len (+ (length string) column)) + (setq rwl (cdr rwl)) + ) + (t + (setq string (car rword)) + (let* ((sl (length string)) + (p 0) np + (str "") nstr) + (while (and (< p len) + (progn + (setq np (+ p (char-length (sref string p)))) + (setq nstr (substring string 0 np)) + (setq ret (tm-eword::encoded-word-length + (cons nstr (cdr rword)) + )) + (setq nstr (cdr ret)) + (setq len (+ (car ret) column)) + (<= len 76) + )) + (setq str nstr + p np)) + (if (string-equal str "") + (setq string "\n " + len 1) + (setq rwl (cons (cons (substring string p) (cdr rword)) + (cdr rwl))) + (setq string + (tm-eword::encode-encoded-text + (tm-eword::rword-charset rword) + (tm-eword::rword-encoding rword) + str + (tm-eword::rword-type rword))) + (setq len (+ (length string) column)) + ) + ))) + ) + (list string len rwl) + )) + +(defun tm-eword::encode-rwl (column rwl) + (let (ret dest ps special str ew-f pew-f) + (while rwl + (setq ew-f (nth 2 (car rwl))) + (if (and pew-f ew-f) + (setq rwl (cons '(" ") rwl) + pew-f nil) + (setq pew-f ew-f) + ) + (setq ret (tm-eword::encode-string-1 column rwl)) + (setq str (car ret)) + (if (eq (elt str 0) ?\n) + (if (eq special ?\() + (progn + (setq dest (concat dest "\n (")) + (setq ret (tm-eword::encode-string-1 2 rwl)) + (setq str (car ret)) + )) + (cond ((eq special 32) + (if (string= str "(") + (setq ps t) + (setq dest (concat dest " ")) + (setq ps nil) + )) + ((eq special ?\() + (if ps + (progn + (setq dest (concat dest " (")) + (setq ps nil) + ) + (setq dest (concat dest "(")) + ) + ))) + (cond ((string= str " ") + (setq special 32) + ) + ((string= str "(") + (setq special ?\() + ) + (t + (setq special nil) + (setq dest (concat dest str)) + )) + (setq column (nth 1 ret) + rwl (nth 2 ret)) + ) + (list dest column) + )) + +(defun tm-eword::encode-string (column str &optional mode) + (tm-eword::encode-rwl column (tm-eword::split-string str mode)) + ) + + +;;; @ converter +;;; + +(defun tm-eword::phrase-to-rwl (phrase) + (let (token type dest str) + (while phrase + (setq token (car phrase)) + (setq type (car token)) + (cond ((eq type 'quoted-string) + (setq str (concat "\"" (cdr token) "\"")) + (setq dest + (append dest + (list + (let ((ret (tm-eword::find-charset-rule + (find-non-ascii-charset-string str)))) + (tm-eword::make-rword + str (car ret)(nth 1 ret) 'phrase) + ) + ))) + ) + ((eq type 'comment) + (setq dest + (append dest + '(("(" nil nil)) + (tm-eword::words-to-ruled-words + (tm-eword::lc-words-to-words + (tm-eword::split-to-lc-words (cdr token))) + 'comment) + '((")" nil nil)) + )) + ) + (t + (setq dest (append dest + (tm-eword::words-to-ruled-words + (tm-eword::lc-words-to-words + (tm-eword::split-to-lc-words (cdr token)) + ) 'phrase))) + )) + (setq phrase (cdr phrase)) + ) + (tm-eword::space-process dest) + )) + +(defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr) + (if (eq (car phrase-route-addr) 'phrase-route-addr) + (let ((phrase (nth 1 phrase-route-addr)) + (route (nth 2 phrase-route-addr)) + dest) + (if (eq (car (car phrase)) 'spaces) + (setq phrase (cdr phrase)) + ) + (setq dest (tm-eword::phrase-to-rwl phrase)) + (if dest + (setq dest (append dest '((" " nil nil)))) + ) + (append + dest + (list (list (concat "<" (std11-addr-to-string route) ">") nil nil)) + )))) + +(defun tm-eword::addr-spec-to-rwl (addr-spec) + (if (eq (car addr-spec) 'addr-spec) + (list (list (std11-addr-to-string (cdr addr-spec)) nil nil)) + )) + +(defun tm-eword::mailbox-to-rwl (mbox) + (let ((addr (nth 1 mbox)) + (comment (nth 2 mbox)) + dest) + (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr) + (tm-eword::addr-spec-to-rwl addr) + )) + (if comment + (setq dest + (append dest + '((" " nil nil) + ("(" nil nil)) + (tm-eword::split-string comment 'comment) + '((")" nil nil)) + ))) + dest)) + +(defun tm-eword::addresses-to-rwl (addresses) + (let ((dest (tm-eword::mailbox-to-rwl (car addresses)))) + (if dest + (while (setq addresses (cdr addresses)) + (setq dest (append dest + '(("," nil nil)) + '((" " nil nil)) + (tm-eword::mailbox-to-rwl (car addresses)) + )) + )) + dest)) + +(defun tm-eword::encode-address-list (column str) + (tm-eword::encode-rwl + column + (tm-eword::addresses-to-rwl (std11-parse-addresses-string str)) + )) + + +;;; @ application interfaces +;;; + +(defun mime/encode-field (str) + (setq str (std11-unfold-string str)) + (let ((ret (string-match std11-field-head-regexp str))) + (or (if ret + (let ((field-name (substring str 0 (1- (match-end 0)))) + (field-body (eliminate-top-spaces + (substring str (match-end 0)))) + fname) + (if (setq ret + (cond ((string-equal field-body "") "") + ((member (setq fname (downcase field-name)) + '("reply-to" "from" "sender" + "resent-reply-to" "resent-from" + "resent-sender" "to" "resent-to" + "cc" "resent-cc" + "bcc" "resent-bcc" "dcc") + ) + (car (tm-eword::encode-address-list + (+ (length field-name) 2) field-body)) + ) + (t + (car (tm-eword::encode-string + (+ (length field-name) 1) + field-body 'text)) + )) + ) + (concat field-name ": " ret) + ))) + (car (tm-eword::encode-string 0 str)) + ))) + +(defun mime/exist-encoded-word-in-subject () + (let ((str (std11-field-body "Subject"))) + (if (and str (string-match mime/encoded-word-regexp str)) + str))) + +(defun mime/encode-message-header (&optional code-conversion) + (interactive "*") + (save-excursion + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (let ((default-cs (mime-charset-to-coding-system default-mime-charset)) + beg end field-name) + (while (re-search-forward std11-field-head-regexp nil t) + (setq beg (match-beginning 0)) + (setq field-name (buffer-substring beg (1- (match-end 0)))) + (setq end (std11-field-end)) + (and (find-non-ascii-charset-region beg end) + (let ((ret (or (ASSOC (downcase field-name) + mime/field-encoding-method-alist + :test (function + (lambda (str1 str2) + (and (stringp str2) + (string= str1 + (downcase str2)) + )))) + (assq t mime/field-encoding-method-alist) + ))) + (if ret + (let ((method (cdr ret))) + (cond ((eq method 'mime) + (let ((field + (buffer-substring-no-properties beg end) + )) + (delete-region beg end) + (insert (mime/encode-field field)) + )) + (code-conversion + (let ((cs + (or (mime-charset-to-coding-system + method) + default-cs))) + (encode-coding-region beg end cs) + ))) + )) + )) + )) + (and mime/generate-X-Nsubject + (or (std11-field-body "X-Nsubject") + (let ((str (mime/exist-encoded-word-in-subject))) + (if str + (progn + (setq str + (mime-eword/decode-string + (std11-unfold-string str))) + (if code-conversion + (setq str + (encode-mime-charset-string + str + (or (cdr (ASSOC + "x-nsubject" + mime/field-encoding-method-alist + :test + (function + (lambda (str1 str2) + (and (stringp str2) + (string= str1 + (downcase str2)) + ))))) + 'iso-2022-jp-2))) + ) + (insert (concat "\nX-Nsubject: " str)) + ))))) + ))) + +(defun mime-eword/encode-string (str &optional column mode) + (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode))) + ) + + +;;; @ end +;;; + +(provide 'tm-ew-e) + +;;; tm-ew-e.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-file.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-file.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,103 @@ +;;; tm-file.el --- tm-view internal method for file extraction + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; modified by Shuhei KOBAYASHI +;; Version: $Id: tm-file.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, file, extract + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'tm-view) + +(defun mime-article/extract-file (beg end cal) + (goto-char beg) + (let* ((name + (save-restriction + (narrow-to-region beg end) + (mime-article/get-filename cal) + )) + (encoding (cdr (assq 'encoding cal))) + (filename + (if (and name (not (string-equal name ""))) + (expand-file-name name + (call-interactively + (function + (lambda (dir) + (interactive "DDirectory: ") + dir)))) + (call-interactively + (function + (lambda (file) + (interactive "FFilename: ") + (expand-file-name file)))))) + (the-buf (current-buffer)) + (tmp-buf (generate-new-buffer (file-name-nondirectory filename))) + ) + (if (file-exists-p filename) + (or (yes-or-no-p (format "File %s exists. Save anyway? " filename)) + (error ""))) + (re-search-forward "\n\n") + (append-to-buffer tmp-buf (match-end 0) end) + (save-excursion + (set-buffer tmp-buf) + (mime-decode-region (point-min)(point-max) encoding) + (let ((coding-system-for-write 'no-conversion) + (mc-flag nil) ; for Mule + (file-coding-system + (if (featurep 'mule) *noconv*)) + kanji-flag ; for NEmacs + (emx-binary-mode t) ; for OS/2 + jka-compr-compression-info-list ; for jka-compr + jam-zcat-filename-list ; for jam-zcat + require-final-newline) + (write-file filename) + ) + (kill-buffer tmp-buf) + ))) + + +;;; @ setup +;;; + +(set-atype 'mime/content-decoding-condition + '((type . "application/octet-stream") + (method . mime-article/extract-file) + ) + 'ignore '(method) + 'replacement) + +(set-atype 'mime/content-decoding-condition + '((mode . "extract") + (method . mime-article/extract-file) + ) + 'remove + '((method "tm-file" nil 'file 'type 'encoding 'mode 'name) + (mode . "extract")) + 'replacement) + + +;;; @ end +;;; + +(provide 'tm-file) + +;;; end of tm-file.el diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-ftp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-ftp.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,43 @@ +;;; +;;; tm-ftp: anonymous ftp processor for tm-view +;;; +;;; by MASUTANI Yasuhiro (1994/11/ 5) +;;; +;;; modified by MORIOKA Tomohiko (1994/11/ 8) +;;; and OKABE Yasuo (1994/11/11) +;;; +;;; $Id: tm-ftp.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; + +(require 'tm-view) +(require 'ange-ftp) + +(defvar mime/dired-function + (if mime/use-multi-frame + (function dired-other-frame) + (function dired) + )) + +(defun mime/decode-message/external-ftp (beg end cal) + (let ((access-type (cdr (assoc "access-type" cal))) + (site (cdr (assoc "site" cal))) + (directory (cdr (assoc "directory" cal))) + (name (cdr (assoc "name" cal))) + (mode (cdr (assoc "mode" cal))) + (pathname)) + (setq pathname + (concat "/anonymous@" site ":" directory)) + (message (concat "Accessing " pathname "/" name "...")) + (switch-to-buffer mime::article/preview-buffer) + (funcall mime/dired-function pathname) + (goto-char (point-min)) + (search-forward name) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "message/external-body") + ("access-type" . "anon-ftp") + (method . mime/decode-message/external-ftp) + )) + +(provide 'tm-ftp) diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-gd3.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-gd3.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,85 @@ +;;; +;;; tm-gd3.el --- tm-gnus module for GNUS 3.* and 4.* +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Maintainer: MORIOKA Tomohiko +;;; Created: 1995/05/23 (obsolete tm-ognus.el) +;;; Version: +;;; $Id: tm-gd3.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; Keywords: news, MIME, multimedia, multilingual, encoded-word +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'tm-ew-d) + + +;;; @ to decode subjects in mode-line +;;; +;; This function imported from gnus.el. +;; +;; New implementation in gnus 3.14.3 +;; + +(defun tm-gnus/article-set-mode-line () + "Set Article mode line string. +If you don't like it, define your own gnus-article-set-mode-line." + (let ((maxlen 15) ;Maximum subject length + (subject + (if gnus-current-headers + (mime-eword/decode-string + (nntp-header-subject gnus-current-headers)) + "") + )) + ;; The value must be a string to escape %-constructs because of subject. + (setq mode-line-buffer-identification + (format "GNUS: %s%s %s%s%s" + gnus-newsgroup-name + (if gnus-current-article + (format "/%d" gnus-current-article) "") + (truncate-string subject + (min (string-width subject) maxlen)) + (if (> (string-width subject) maxlen) "..." "") + (make-string (max 0 (- 17 (string-width subject))) ? ) + ))) + (set-buffer-modified-p t)) + + +;;; @ to decode subjects in Summary buffer +;;; + +(defun tm-gnus/decode-summary-subjects () + (mapcar (function + (lambda (header) + (let ((subj (or (gnus-header-subject header) ""))) + (nntp-set-header-subject + header (mime-eword/decode-string subj)) + ))) + gnus-newsgroup-headers) + ) + + +;;; @ end +;;; + +(provide 'tm-gd3) + +;;; tm-gd3.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-gnus.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-gnus.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,121 @@ +;;; +;;; tm-gnus.el --- MIME extension for GNUS +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1993 .. 1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; modified by KOBAYASHI Shuhei +;;; Maintainer: MORIOKA Tomohiko +;;; Created: 1993/11/20 (obsolete mol's gnus-mime.el) +;;; Version: +;;; $Id: tm-gnus.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $ +;;; Keywords: news, MIME, multimedia, encoded-word, multilingual +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'gnus) + + +;;; @ variables +;;; + +(defvar tm-gnus/startup-hook nil) + + +;;; @ set up +;;; + +(cond ((boundp 'gnus-original-article-buffer) + ;; for Gnus 5.2 or later + (require 'tm-gnus5) + ) + ((or (string-match + "^\\((ding) Gnus\\|Gnus v5\\|September Gnus\\)" gnus-version) + (fboundp 'mail-header-from)) + ;; for Gnus 5.0 .. 5.1.* + (require 'tm-gnus4) + (cond ((not (boundp 'nnheader-encoded-words-decoding)) + (require 'tm-ew-d) + (defun tm-gnus/decode-summary-from-and-subjects () + (mapcar (lambda (header) + (let ((from (mail-header-from header)) + (subj (mail-header-subject header)) + ) + (mail-header-set-from + header + (if from + (mime-eword/decode-string from) + "")) + (mail-header-set-subject + header + (if subj + (mime-eword/decode-string subj) + "")) + )) + gnus-newsgroup-headers)) + (add-hook 'gnus-select-group-hook + (function tm-gnus/decode-summary-from-and-subjects)) + )) + ) + ((fboundp 'gnus-article-prepare) + ;; for GNUS 3.15 .. 4.* + (require 'tm-gd3) + (require 'tm-gnus4) + (add-hook 'gnus-select-group-hook 'tm-gnus/decode-summary-subjects) + (fset 'gnus-article-set-mode-line + (function tm-gnus/article-set-mode-line)) + + (or (fboundp 'tm:gnus-article-delete-headers) + (fset 'tm:gnus-article-delete-headers + (symbol-function 'gnus-article-delete-headers)) + ) + (defun gnus-article-delete-headers () + (or tm-gnus/automatic-mime-preview + (tm:gnus-article-delete-headers) + )) + + (require 'gnuspost) + (or (fboundp 'tm-gnus/original-news-reply) + (fset 'tm-gnus/original-news-reply + (symbol-function 'gnus-news-reply)) + ) + (defun gnus-news-reply (&optional yank) + (if (eq major-mode 'mime/viewer-mode) + (let ((major-mode 'gnus-article-mode)) + (tm-gnus/original-news-reply yank) + ) + (tm-gnus/original-news-reply yank) + )) + ) + ((string-match "^GNUS 3" gnus-version) + ;; for GNUS 3.14.* + (require 'tm-gnus3) + (defvar gnus-article-buffer gnus-Article-buffer) + )) + + +;;; @ end +;;; + +(provide 'tm-gnus) + +(run-hooks 'tm-gnus-load-hook) + +;;; tm-gnus.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-gnus4.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-gnus4.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,310 @@ +;;; +;;; tm-gnus4.el --- tm-gnus module for GNUS 4, 5.0.* and 5.1.*. +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; modified by OKABE Yasuo +;;; Maintainer: MORIOKA Tomohiko +;;; and KOBAYASHI Shuhei +;;; Created: 1993/11/20 (merged tm-gnus5.el) +;;; Version: $Revision: 1.1.1.1 $ +;;; Keywords: news, MIME, multimedia, multilingual, encoded-word +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'tl-str) +(require 'tl-misc) + + +;;; @ version +;;; + +(defconst tm-gnus/RCS-ID + "$Id: tm-gnus4.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $") + +(defconst tm-gnus/version + (concat (get-version-string tm-gnus/RCS-ID) " for 3.15 .. 5.1.*")) + + +;;; @ variable +;;; + +(defvar tm-gnus/automatic-mime-preview t + "*If non-nil, show MIME processed article. +This variable is set to `gnus-show-mime'.") + +(defvar tm-gnus/original-article-buffer " *Original Article*") +(defvar gnus-original-article-buffer nil) + + +;;; @ for tm-view +;;; + +(autoload 'mime/viewer-mode "tm-view" "View MIME message." t) + +(defun tm-gnus/view-message (arg) + "MIME decode and play this message." + (interactive "P") + (let ((gnus-break-pages nil) + (gnus-show-mime nil)) + (gnus-summary-select-article t t) + ) + (pop-to-buffer gnus-article-buffer t) + (let ((str (buffer-string)) + (obuf (get-buffer tm-gnus/original-article-buffer)) + (pbuf (current-buffer)) + ) + (if obuf + (progn + (set-buffer obuf) + (setq buffer-read-only nil) + (erase-buffer) + ) + (setq obuf (get-buffer-create tm-gnus/original-article-buffer)) + (set-buffer obuf) + ) + (insert str) + (gnus-article-mode) + (set-buffer pbuf) + (make-local-variable 'tm:mother-button-dispatcher) + (setq tm:mother-button-dispatcher + (function gnus-article-push-button)) + (mime/viewer-mode + nil nil nil tm-gnus/original-article-buffer gnus-article-buffer) + (let (buffer-read-only) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + )) + +(defun tm-gnus/summary-scroll-down () + "Scroll down one line current article." + (interactive) + (gnus-summary-scroll-up -1) + ) + +(defun mime-viewer/quitting-method-for-gnus4 () + (if (not gnus-show-mime) + (mime-viewer/kill-buffer) + ) + (delete-other-windows) + (gnus-article-show-summary) + (if (or (not gnus-show-mime) + (null gnus-have-all-headers)) + (gnus-summary-select-article nil t) + )) + +(call-after-loaded + 'tm-view + (function + (lambda () + (set-alist 'mime-viewer/quitting-method-alist + 'gnus-article-mode + (function mime-viewer/quitting-method-for-gnus4)) + (set-alist 'mime-viewer/show-summary-method + 'gnus-article-mode + (function mime-viewer/quitting-method-for-gnus4)) + ))) + + +;;; @ for tm-edit +;;; + +;; suggested by OKABE Yasuo +;; 1995/11/08 (c.f. [tm ML:1067]) +(defun tm-gnus/insert-article (&optional message) + (interactive) + (let (;; for Emacs 19 + (mail-citation-hook '(mime-editor/inserted-message-filter)) + news-reply-header-hook + mail-yank-hooks + + ;; for Emacs 18 + (mail-yank-ignored-headers mime-editor/yank-ignored-field-regexp) + (news-make-reply-yank-header (function + (lambda (message-id from) "") + )) + (news-yank-original-quoting-indicator "") + + ;; select raw article buffer + (mail-reply-buffer + (save-excursion + (set-buffer gnus-article-buffer) + (if (eq major-mode 'mime/viewer-mode) + mime::preview/article-buffer + gnus-article-buffer))) + ) + (news-reply-yank-original 0) + )) + +;;; modified by Steven L. Baur +;;; 1995/12/6 (c.f. [tm-en:209]) +(defun mime-editor/attach-to-news-reply-menu () + "Arrange to attach MIME editor's popup menu to VM's" + (if (boundp 'news-reply-menu) + (progn + (setq news-reply-menu (append news-reply-menu + '("---") + mime-editor/popup-menu-for-xemacs)) + (remove-hook 'news-setup-hook + 'mime-editor/attach-to-news-reply-menu) + ))) + +(call-after-loaded + 'tm-edit + (function + (lambda () + (set-alist 'mime-editor/message-inserter-alist + 'news-reply-mode (function tm-gnus/insert-article)) + + (autoload 'tm-mail/insert-message "tm-mail") + (set-alist 'mime-editor/message-inserter-alist + 'mail-mode (function tm-mail/insert-message)) + (if (string-match "XEmacs\\|Lucid" emacs-version) + (add-hook 'news-setup-hook 'mime-editor/attach-to-news-reply-menu) + ) + + (set-alist 'mime-editor/split-message-sender-alist + 'news-reply-mode + (function gnus-inews-news)) + ))) + + +;;; @ for tm-partial +;;; + +(call-after-loaded + 'tm-partial + (function + (lambda () + (set-atype 'mime/content-decoding-condition + '((type . "message/partial") + (method . mime-article/grab-message/partials) + (major-mode . gnus-article-mode) + (summary-buffer-exp . gnus-summary-buffer) + )) + + (set-alist 'tm-partial/preview-article-method-alist + 'gnus-article-mode + (function + (lambda () + (tm-gnus/view-message (gnus-summary-article-number)) + ))) + ))) + + +;;; @ set up +;;; + +(define-key gnus-summary-mode-map "v" (function tm-gnus/view-message)) +(define-key gnus-summary-mode-map + "\e\r" (function tm-gnus/summary-scroll-down)) + +(defun tm-gnus/article-reset-variable () + (setq gnus-original-article-buffer nil) + (setq tm-gnus/automatic-mime-preview nil) + (gnus-article-mode) + (setq buffer-read-only nil) + ) + +(add-hook 'gnus-article-prepare-hook 'tm-gnus/article-reset-variable) + +(defun tm-gnus/decode-encoded-word-if-you-need () + (if (not gnus-have-all-headers) + (progn + (mime/decode-message-header) + (run-hooks 'tm-gnus/article-prepare-hook) + ))) + +(defun tm-gnus/preview-article-if-you-need () + (if (not gnus-have-all-headers) + (let ((str (buffer-string)) + (obuf (get-buffer tm-gnus/original-article-buffer)) + (pbuf (current-buffer)) + ) + (if obuf + (progn + (set-buffer obuf) + (setq buffer-read-only nil) + (erase-buffer) + ) + (setq obuf (get-buffer-create tm-gnus/original-article-buffer)) + (set-buffer obuf) + ) + (insert str) + (gnus-article-mode) + (set-buffer pbuf) + (make-local-variable 'tm:mother-button-dispatcher) + (setq tm:mother-button-dispatcher + (function gnus-article-push-button)) + (save-window-excursion + (mime/viewer-mode + nil nil nil tm-gnus/original-article-buffer gnus-article-buffer) + ) + (setq tm-gnus/automatic-mime-preview t) + (setq gnus-original-article-buffer tm-gnus/original-article-buffer) + (let (buffer-read-only) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + (if (featurep 'tm-gd3) + (setq buffer-read-only nil) + ) + ))) + +(setq gnus-show-mime-method + (if tm-gnus/automatic-mime-preview + (function tm-gnus/preview-article-if-you-need) + (function tm-gnus/decode-encoded-word-if-you-need) + )) + +(setq gnus-show-mime t) + + +;;; @ for BBDB +;;; + +(call-after-loaded + 'bbdb + (function + (lambda () + (require 'tm-bbdb) + ))) + +(autoload 'tm-bbdb/update-record "tm-bbdb") + +(defun tm-gnus/bbdb-setup () + (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook) + (progn + (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record) + ;;(add-hook 'tm-gnus/article-prepare-hook 'bbdb/gnus-update-record) + (add-hook 'gnus-article-display-hook 'tm-bbdb/update-record) + ))) + +(add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t) + +(tm-gnus/bbdb-setup) + + +;;; @ end +;;; + +(provide 'tm-gnus4) + +;;; tm-gnus4.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-gnus5.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-gnus5.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,403 @@ +;;; +;;; tm-gnus5.el --- MIME extender for Gnus 5.2 or later +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Maintainer: MORIOKA Tomohiko +;;; and KOBAYASHI Shuhei +;;; Created: 1995/09/24 +;;; Version: $Revision: 1.1.1.1 $ +;;; Keywords: news, MIME, multimedia, multilingual, encoded-word +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'tl-str) +(require 'tl-list) +(require 'tl-misc) +(require 'tm-view) +(require 'gnus) + +(eval-when-compile (require 'cl)) + + +;;; @ version +;;; + +(defconst tm-gnus/RCS-ID + "$Id: tm-gnus5.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $") + +(defconst tm-gnus/version + (concat (get-version-string tm-gnus/RCS-ID) " for Gnus 5.2 or later")) + + +;;; @ variables +;;; + +(defvar tm-gnus/automatic-mime-preview t + "*If non-nil, show MIME processed article. +This variable is set to `gnus-show-mime'.") + +(setq gnus-show-mime tm-gnus/automatic-mime-preview) + + +;;; @ command functions +;;; + +(defun tm-gnus/view-message (arg) + "MIME decode and play this message." + (interactive "P") + (let ((gnus-break-pages nil)) + (gnus-summary-select-article t t) + ) + (pop-to-buffer gnus-original-article-buffer t) + (let (buffer-read-only) + (if (text-property-any (point-min) (point-max) 'invisible t) + (remove-text-properties (point-min) (point-max) + gnus-hidden-properties) + )) + (mime/viewer-mode nil nil nil gnus-original-article-buffer + gnus-article-buffer) + ) + +(defun tm-gnus/summary-scroll-down () + "Scroll down one line current article." + (interactive) + (gnus-summary-scroll-up -1) + ) + +(defun tm-gnus/summary-toggle-header (&optional arg) + (interactive "P") + (if tm-gnus/automatic-mime-preview + (let* ((hidden + (save-excursion + (set-buffer gnus-article-buffer) + (text-property-any + (goto-char (point-min)) (search-forward "\n\n") + 'invisible t) + )) + (mime-viewer/redisplay t) + ) + (gnus-summary-select-article hidden t) + ) + (gnus-summary-toggle-header arg)) + ) + +(define-key gnus-summary-mode-map "v" (function tm-gnus/view-message)) +(define-key gnus-summary-mode-map + "\e\r" (function tm-gnus/summary-scroll-down)) +(substitute-key-definition + 'gnus-summary-toggle-header + 'tm-gnus/summary-toggle-header gnus-summary-mode-map) + + +;;; @ for tm-view +;;; + +(defun tm-gnus/content-header-filter () + (goto-char (point-min)) + (mime-preview/cut-header) + (decode-mime-charset-region (point-min)(point-max) default-mime-charset) + (mime/decode-message-header) + ) + +(set-alist 'mime-viewer/content-header-filter-alist + 'gnus-original-article-mode + (function tm-gnus/content-header-filter)) + +(set-alist 'mime-viewer/code-converter-alist + 'gnus-original-article-mode + (function mime-charset/decode-buffer)) + +(defun mime-viewer/quitting-method-for-gnus5 () + (if (not gnus-show-mime) + (mime-viewer/kill-buffer)) + (delete-other-windows) + (gnus-article-show-summary) + (if (or (not gnus-show-mime) + (null gnus-have-all-headers)) + (gnus-summary-select-article nil t) + )) + +(set-alist 'mime-viewer/quitting-method-alist + 'gnus-original-article-mode + (function mime-viewer/quitting-method-for-gnus5)) +(set-alist 'mime-viewer/show-summary-method + 'gnus-original-article-mode + (function mime-viewer/quitting-method-for-gnus5)) + + +;;; @ for tm-edit +;;; + +;; suggested by OKABE Yasuo +;; 1995/11/08 (c.f. [tm ML:1067]) +(defun tm-gnus/insert-article (&optional message) + (interactive) + (let ((message-cite-function 'mime-editor/inserted-message-filter) + (message-reply-buffer gnus-original-article-buffer) + ) + (message-yank-original nil) + )) + +;;; modified by Steven L. Baur +;;; 1995/12/6 (c.f. [tm-en:209]) +(defun mime-editor/attach-to-news-reply-menu () + "Arrange to attach MIME editor's popup menu to VM's" + (if (boundp 'news-reply-menu) + (progn + (setq news-reply-menu (append news-reply-menu + '("---") + mime-editor/popup-menu-for-xemacs)) + (remove-hook 'news-setup-hook + 'mime-editor/attach-to-news-reply-menu) + ))) + +(call-after-loaded + 'tm-edit + (function + (lambda () + (set-alist 'mime-editor/message-inserter-alist + 'message-mode (function tm-gnus/insert-article)) + (if (string-match "XEmacs\\|Lucid" emacs-version) + (add-hook 'news-setup-hook 'mime-editor/attach-to-news-reply-menu) + ) + + (set-alist 'mime-editor/split-message-sender-alist + 'message-mode + (lambda () + (interactive) + (let (message-send-hook + message-sent-message-via) + (message-send) + ))) + ))) + + +;;; @ for tm-partial +;;; + +(defun tm-gnus/partial-preview-function () + (tm-gnus/view-message (gnus-summary-article-number)) + ) + +(call-after-loaded + 'tm-partial + (lambda () + (set-atype 'mime/content-decoding-condition + '((type . "message/partial") + (method . mime-article/grab-message/partials) + (major-mode . gnus-original-article-mode) + (summary-buffer-exp . gnus-summary-buffer) + )) + (set-alist 'tm-partial/preview-article-method-alist + 'gnus-original-article-mode + 'tm-gnus/partial-preview-function) + )) + + +;;; @ article filter +;;; + +(defun tm-gnus/article-reset-variable () + (setq tm-gnus/automatic-mime-preview nil) + ) + +(add-hook 'gnus-article-prepare-hook 'tm-gnus/article-reset-variable) + +(defun tm-gnus/preview-article () + (make-local-variable 'tm:mother-button-dispatcher) + (setq tm:mother-button-dispatcher + (function gnus-article-push-button)) + (let ((mime-viewer/ignored-field-regexp "^:$") + (default-mime-charset + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)) + ) + (mime/viewer-mode nil nil nil gnus-original-article-buffer + gnus-article-buffer + gnus-article-mode-map) + ) + (setq tm-gnus/automatic-mime-preview t) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + +(setq gnus-show-mime-method (function tm-gnus/preview-article)) + +(defun tm-gnus/article-decode-encoded-word () + (decode-mime-charset-region (point-min)(point-max) + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)) + (mime/decode-message-header) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + +(setq gnus-decode-encoded-word-method + (function tm-gnus/article-decode-encoded-word)) + + +;;; @ for mule (Multilingual support) +;;; + +(defvar gnus-newsgroup-default-charset-alist nil) + +(defun gnus-set-newsgroup-default-charset (newsgroup charset) + "Set CHARSET for the NEWSGROUP as default MIME charset." + (set-alist 'gnus-newsgroup-default-charset-alist + (concat "^" (regexp-quote newsgroup) "\\($\\|\\.\\)") + charset)) + +(cond + ((featurep 'mule) + (cond ((boundp 'MULE) ; for MULE 1.* and 2.*. + (define-service-coding-system gnus-nntp-service nil *noconv*) + (if (and (boundp 'nntp-server-process) + (processp nntp-server-process) + ) + (set-process-coding-system nntp-server-process *noconv* *noconv*) + ) + ) + (running-xemacs-20 ; for XEmacs/mule. + (if (and (boundp 'nntp-server-process) + (processp nntp-server-process) + ) + (set-process-input-coding-system nntp-server-process 'noconv) + ) + )) + (call-after-loaded + 'nnheader + (lambda () + (defun nnheader-find-file-noselect (filename &optional nowarn rawfile) + (let ((file-coding-system-for-read *noconv*)) + (find-file-noselect filename nowarn rawfile) + )) + (defun nnheader-insert-file-contents-literally + (filename &optional visit beg end replace) + (let ((file-coding-system-for-read *noconv*)) + (insert-file-contents-literally filename visit beg end replace) + )) + )) + ;; Please use Gnus 5.2.10 or later if you use Mule. + (call-after-loaded + 'nnmail + (lambda () + (defun nnmail-find-file (file) + "Insert FILE in server buffer safely. [tm-gnus5.el]" + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((format-alist nil) + (after-insert-file-functions ; for jam-code-guess + (if (memq 'jam-code-guess-after-insert-file-function + after-insert-file-functions) + '(jam-code-guess-after-insert-file-function))) + (file-coding-system-for-read *noconv*)) + (condition-case () + (progn (insert-file-contents file) t) + (file-error nil)))) + )) + (defun tm-gnus/prepare-save-mail-function () + (setq file-coding-system *noconv*) + ) + (add-hook 'nnmail-prepare-save-mail-hook + 'tm-gnus/prepare-save-mail-function) + + (gnus-set-newsgroup-default-charset "alt.chinese" 'hz) + (gnus-set-newsgroup-default-charset "alt.chinese.text.big5" 'big5) + (gnus-set-newsgroup-default-charset "tw" 'big5) + (gnus-set-newsgroup-default-charset "hk" 'big5) + (gnus-set-newsgroup-default-charset "hkstar" 'big5) + (gnus-set-newsgroup-default-charset "han" 'euc-kr) + (gnus-set-newsgroup-default-charset "relcom" 'koi8-r) + )) + + +;;; @ summary filter +;;; + +(defun tm-gnus/decode-summary-from-and-subjects () + (let ((rest gnus-newsgroup-default-charset-alist) + cell) + (catch 'tag + (while (setq cell (car rest)) + (if (string-match (car cell) gnus-newsgroup-name) + (throw 'tag + (progn + (make-local-variable 'default-mime-charset) + (setq default-mime-charset (cdr cell)) + ))) + (setq rest (cdr rest)) + ))) + (mapcar + (lambda (header) + (let ((from (or (mail-header-from header) "")) + (subj (or (mail-header-subject header) "")) + (method (car gnus-current-select-method)) + ) + (if (eq method 'nntp) + (progn + (setq from + (decode-mime-charset-string from default-mime-charset)) + (setq subj + (decode-mime-charset-string subj default-mime-charset)) + )) + (mail-header-set-from + header (mime-eword/decode-string from)) + (mail-header-set-subject + header (mime-eword/decode-string subj)) + )) + gnus-newsgroup-headers)) + +(or (boundp 'nnheader-encoded-words-decoding) + (add-hook 'gnus-select-group-hook + 'tm-gnus/decode-summary-from-and-subjects) + ) + + +;;; @ for BBDB +;;; + +(call-after-loaded + 'bbdb + (lambda () + (require 'tm-bbdb) + )) + +(autoload 'tm-bbdb/update-record "tm-bbdb") + +(defun tm-gnus/bbdb-setup () + (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook) + (progn + (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record) + (add-hook 'gnus-article-display-hook 'tm-bbdb/update-record) + ))) + +(add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t) + +(tm-gnus/bbdb-setup) + + +;;; @ end +;;; + +(provide 'tm-gnus5) + +;;; tm-gnus5.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-html.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-html.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,74 @@ +;;; +;;; tm-html.el: a tm-view internal decoder for HTML +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Created: 1995/9/14 +;;; based on tm-latex.el by OKABE Yasuo +;;; Version: +;;; $Id: tm-html.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;;; Keywords: mail, news, MIME, multimedia, HTML, WWW +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'tm-view) + +(defun mime-article/decode-html (beg end cal) + (let* ((cur-buf (current-buffer)) + new-buf + (name (or (cdr (assoc "name" cal)) + (cdr (assoc "x-name" cal)) + (concat (make-temp-name "tm") ".html"))) + (encoding (cdr (assq 'encoding cal))) + ;; modified by Shuhei KOBAYASHI + ;; 1995/11/17 (cf. [tm-ja:1117]) + (html-helper-build-new-buffer nil) + ) + (switch-to-buffer mime::article/preview-buffer) + (funcall mime/find-file-function (expand-file-name name mime/tmp-dir)) + (if (or (<= (buffer-size) 0) + (y-or-n-p "Replace the existing buffer?")) + (progn + (erase-buffer) + (setq new-buf (current-buffer)) + (save-excursion + (set-buffer cur-buf) + (goto-char beg) + (re-search-forward "^$") + (append-to-buffer new-buf (+ (match-end 0) 1) end) + ))) + (mime-decode-region (point-min)(point-max) encoding) + (run-hooks 'mime-article/decode-html-hook) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "text/html") + (method . mime-article/decode-html) + (mode . "extract") + )) + + +;;; @ end +;;; + +(provide 'tm-html) + +;;; end of tm-html.el diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-image.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-image.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,292 @@ +;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers + +;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;; Copyright (C) 1996 Dan Rich + +;; Author: MORIOKA Tomohiko +;; Dan Rich +;; Maintainer: MORIOKA Tomohiko +;; Created: 1995/12/15 +;; Version: $Id: tm-image.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ + +;; Keywords: mail, news, MIME, multimedia, image, picture, X-Face + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with 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: +;; If you use this program with MULE, please install +;; etl8x16-bitmap.bdf font included in tl package. + +;;; Code: + +(require 'tm-view) + +(cond (running-xemacs + (require 'annotations) + + (set-alist 'mime-viewer/content-filter-alist + "image/jpeg" + (if (featurep 'jpeg) ; Use built-in suport if available + (function mime-preview/filter-for-inline-image) + (function mime-preview/filter-for-image) + )) + + (set-alist 'mime-viewer/content-filter-alist + "image/gif" + (if (featurep 'gif) ; Use built-in suport if available + (function mime-preview/filter-for-inline-image) + (function mime-preview/filter-for-image) + )) + + (set-alist 'mime-viewer/content-filter-alist + "image/x-xpixmap" + (if (featurep 'xpm) ; Use built-in suport if available + (function mime-preview/filter-for-inline-image) + (function mime-preview/filter-for-image) + )) + + (set-alist 'mime-viewer/content-filter-alist + "image/tiff" (function mime-preview/filter-for-image)) + (set-alist 'mime-viewer/content-filter-alist + "image/x-tiff" (function mime-preview/filter-for-image)) + + (set-alist 'mime-viewer/content-filter-alist + "image/x-pic" (function mime-preview/filter-for-image)) + + (set-alist 'mime-viewer/content-filter-alist + "image/x-mag" (function mime-preview/filter-for-image)) + + (defvar tm-image/inline-image-types + (if (featurep 'gif) + (nconc + '("image/jpeg" "image/gif" "image/tiff" + "image/x-tiff" "image/x-pic" "image/x-mag" + "image/x-xbm" "image/x-xpixmap") + (if (featurep 'gif) + '("application/postscript") + ) + ))) + + (defun bitmap-insert-xbm-file (file) + (let (gl) + (while (progn + (setq gl (make-glyph file)) + (eq (image-instance-type (glyph-image-instance gl)) + 'text) + )) + (make-annotation gl (point) 'text) + )) + + (defvar mime-viewer/image-converter-alist + '(("image/jpeg" . jpeg) + ("image/gif" . gif) + ("image/x-png" . png) + ("image/x-xpixmap" . xpm) + )) + + (defvar mime-preview/x-face-function + (function mime-preview/x-face-function-use-highlight-headers)) + + (autoload 'highlight-headers "highlight-headers") + + (defun mime-preview/x-face-function-use-highlight-headers () + (highlight-headers (point-min) (re-search-forward "^$" nil t) t) + ) + ) + ((featurep 'mule) + ;; for MULE 2.* or mule merged EMACS + (require 'x-face-mule) + + (defvar tm-image/inline-image-types '("image/x-mag" "image/x-xbm")) + + (defvar mime-preview/x-face-function + (function x-face-decode-message-header)) + )) + +(defvar mime-viewer/shell-command "/bin/sh") +(defvar mime-viewer/shell-arguments '("-c")) + +(defvar mime-viewer/ps-to-gif-command "pstogif") + +(defvar mime-viewer/graphic-converter-alist + '(("image/jpeg" . "djpeg -color 256 < %s | ppmtoxpm > %s") + ("image/gif" . "giftopnm < %s | ppmtoxpm > %s") + ("image/tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s") + ("image/x-tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s") + ("image/x-pic" . "pictoppm < %s | ppmquant 256 | ppmtoxpm > %s") + ("image/x-mag" . "magtoppm < %s | ppmtoxpm > %s") + )) + + +;;; @ X-Face +;;; + +(defvar mime-viewer/x-face-to-xbm-command + (concat mime-viewer/x-face-to-pbm-command " | pbmtoxbm")) + +(if mime-preview/x-face-function + (add-hook 'mime-viewer/content-header-filter-hook + mime-preview/x-face-function) + ) + + +;;; @ content filter for images +;;; +;; (for XEmacs 19.12 or later) + +(defun mime-preview/filter-for-image (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (filter (assoc-value ctype mime-viewer/graphic-converter-alist)) + ) + (if filter + (let* ((beg (point-min)) (end (point-max)) + (orig-file + (make-temp-name (expand-file-name "tm" mime/tmp-dir))) + (xbm-file (concat orig-file ".xbm")) + gl annot) + ;;(remove-text-properties beg end '(face nil)) + (mime-decode-region beg end encoding) + (write-region (point-min)(point-max) orig-file) + (delete-region (point-min)(point-max)) + (message "Now translating, please wait...") + (apply (function call-process) + mime-viewer/shell-command nil nil nil + (append mime-viewer/shell-arguments + (list (format filter orig-file xbm-file))) + ) + (setq gl (make-glyph xbm-file)) + (setq annot (make-annotation gl (point) 'text)) + (unwind-protect + (delete-file orig-file) + (condition-case nil + (delete-file xbm-file) + (error nil))) + (goto-char (point-max)) + (insert "\n") + (message "Translation done.") + ) + (message (format "%s is not supported." ctype)) + ))) + + +;;; @ content filter for xbm +;;; + +(defun mime-preview/filter-for-image/xbm (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (charset (assoc "charset" params)) + (beg (point-min)) (end (point-max)) + (xbm-file (make-temp-name (expand-file-name "tm" mime/tmp-dir))) + ) + (remove-text-properties beg end '(face nil)) + (mime-decode-region beg end encoding) + (write-region (point-min)(point-max) xbm-file) + (delete-region (point-min)(point-max)) + (bitmap-insert-xbm-file xbm-file) + (delete-file xbm-file) + )) + +(set-alist 'mime-viewer/content-filter-alist + "image/xbm" (function mime-preview/filter-for-image/xbm)) + +(set-alist 'mime-viewer/content-filter-alist + "image/x-xbm" (function mime-preview/filter-for-image/xbm)) + + +;;; @ content filter for support in-line image types +;;; +;; (for XEmacs 19.14 or later) + +(defun mime-preview/filter-for-inline-image (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (charset (assoc "charset" params)) + (beg (point-min)) (end (point-max)) + ) + (remove-text-properties beg end '(face nil)) + (mime-decode-region beg end encoding) + (let ((data (buffer-string)) + (minor (assoc-value ctype mime-viewer/image-converter-alist)) + gl) + (delete-region (point-min)(point-max)) + (while (progn + (setq gl (make-glyph (vector minor :data data))) + (eq (image-instance-type (glyph-image-instance gl)) + 'text) + )) + (make-annotation gl (point) 'text) + ) + (insert "\n") + )) + + +;;; @ content filter for Postscript +;;; +;; (for XEmacs 19.14 or later) + +(defun mime-preview/filter-for-application/postscript (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (beg (point-min)) (end (point-max)) + (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir))) + (ps-file (concat file-base ".ps")) + (gif-file (concat file-base ".gif")) + ) + (remove-text-properties beg end '(face nil)) + (mime-decode-region beg end encoding) + (write-region (point-min)(point-max) ps-file) + (delete-region (point-min)(point-max)) + (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file) + (let (gl) + (while (progn + (setq gl (make-glyph (vector 'gif :file gif-file))) + (eq (image-instance-type (glyph-image-instance gl)) + 'text) + )) + (make-annotation gl (point) 'text) + ) + (delete-file ps-file) + (delete-file gif-file) + )) + +(set-alist 'mime-viewer/content-filter-alist + "application/postscript" + (function mime-preview/filter-for-application/postscript)) + + +;;; @ setting +;;; + +(mapcar + (lambda (ctype) + (or (member ctype mime-viewer/default-showing-Content-Type-list) + (setq mime-viewer/default-showing-Content-Type-list + (cons ctype + mime-viewer/default-showing-Content-Type-list)) + )) + tm-image/inline-image-types) + + +;;; @ end +;;; + +(provide 'tm-image) + +;;; tm-image.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-latex.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-latex.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,50 @@ +;;; +;;; tm-latex: tm-view internal decoder for LaTeX +;;; +;;; by OKABE Yasuo (1994/11/11) +;;; +;;; modified by MORIOKA Tomohiko +;;; +;;; $Id: tm-latex.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;;; + +(require 'tm-view) + +(defun mime/decode-text/latex (beg end cal) + (let* ((cur-buf (current-buffer)) + new-buf + (name (or (cdr (assoc "name" cal)) + (cdr (assoc "x-name" cal)) + (concat (make-temp-name "tm") ".tex")))) + (switch-to-buffer mime::article/preview-buffer) + (funcall mime/find-file-function (expand-file-name name mime/tmp-dir)) + (if (or (<= (buffer-size) 0) + (y-or-n-p "Replace the existing buffer?")) + (progn + (erase-buffer) + (setq new-buf (current-buffer)) + (save-excursion + (set-buffer cur-buf) + (goto-char beg) + (re-search-forward "^$") + (append-to-buffer new-buf (+ (match-end 0) 1) end) + ))) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "text/x-latex") + (method . mime/decode-text/latex) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "application/x-latex") + (method . mime/decode-text/latex) + )) + +;(set-atype 'mime/content-decoding-condition +; '((type . "application/octet-stream") +; ("type" . "latex") +; (method . mime/decode-text/latex) +; )) + +(provide 'tm-latex) diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-mail.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-mail.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,87 @@ +;;; tm-mail.el --- mail-mode extension. + +;; Copyright (C) 1995,1996 KOBAYASHI Shuhei + +;; Author: KOBAYASHI Shuhei +;; modified by MORIOKA Tomohiko +;; and Neal Becker +;; Maintainer: KOBAYASHI Shuhei +;; Created: 1995/11/27 +;; Version: $Id: tm-mail.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;; Keywords: mail, MIME, multimedia + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with 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. + +;;; Code: + +(require 'tm-edit) + +(defun tm-mail/insert-message (&optional message) + (interactive) + (let* (mail-yank-hooks + (mail-citation-hook '(mime-editor/inserted-message-filter)) + ) + (cond + ((and (boundp 'vm-mail-buffer) vm-mail-buffer) + ;; called from VM. + (let ((mail-reply-buffer vm-mail-buffer)) + (if (null message) + (call-interactively 'vm-yank-message) + (vm-yank-message message))) + ) + ((boundp 'rmail-send-actions-rmail-buffer) + ;; called from RMAIL, emacs-19.29 or later. + (mail-yank-original nil) + ) + ((and (boundp 'gnus-article-buffer) (get-buffer gnus-article-buffer)) + ;; maybe called from Gnus. + (tm-gnus/insert-article) + ) + ((and (boundp 'mail-reply-buffer) mail-reply-buffer) + ;; maybe called from RMAIL. + (mail-yank-original nil) + ) + (t + (message "Sorry, I don't have message inserter for your MUA.") + )) + )) + +(defvar tm-mail/use-xemacs-popup-menu running-xemacs) + +(if (and running-xemacs tm-mail/use-xemacs-popup-menu) + (cond + (running-xemacs-19_14-or-later + (setq mail-menubar-menu + (append mail-menubar-menu + (list "---" + mime-editor/popup-menu-for-xemacs))) + ) + (t + (setq mail-mode-menu + (append mail-mode-menu + (list "---" + mime-editor/popup-menu-for-xemacs))) + ))) + + +;;; @ end +;;; + +(provide 'tm-mail) + +;;; tm-mail.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-mh-e.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-mh-e.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,417 @@ +;;; tm-mh-e.el --- MIME extension for mh-e + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; OKABE Yasuo +;; Maintainer: MORIOKA Tomohiko +;; Created: 1993/11/21 (obsolete mh-e-mime.el) +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'tl-str) +(require 'tl-misc) +(require 'mh-e) +(or (featurep 'mh-utils) + (require 'tm-mh-e3) + ) +(require 'tm-view) + +(or (fboundp 'mh-get-header-field) + (defalias 'mh-get-header-field 'mh-get-field) + ) +(or (boundp 'mh-temp-buffer) + (defconst mh-temp-buffer " *mh-temp*") + ) + + +;;; @ version +;;; + +(defconst tm-mh-e/RCS-ID + "$Id: tm-mh-e.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $") + +(defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID)) + + +;;; @ variable +;;; + +(defvar tm-mh-e/automatic-mime-preview t + "*If non-nil, show MIME processed message.") + +(defvar tm-mh-e/decode-encoded-word t + "*If non-nil, decode encoded-word when it is not MIME preview mode.") + + +;;; @ functions +;;; + +(defun mh-display-msg (msg-num folder &optional show-buffer mode) + (or mode + (setq mode tm-mh-e/automatic-mime-preview) + ) + ;; Display message NUMBER of FOLDER. + ;; Sets the current buffer to the show buffer. + (set-buffer folder) + (or show-buffer + (setq show-buffer mh-show-buffer)) + ;; Bind variables in folder buffer in case they are local + (let ((msg-filename (mh-msg-filename msg-num))) + (if (not (file-exists-p msg-filename)) + (error "Message %d does not exist" msg-num)) + (set-buffer show-buffer) + (cond ((not (equal msg-filename buffer-file-name)) + ;; Buffer does not yet contain message. + (clear-visited-file-modtime) + (unlock-buffer) + (setq buffer-file-name nil) ; no locking during setup + (setq buffer-read-only nil) + (erase-buffer) + (if mode + (let* ((aname (concat "article-" folder)) + (abuf (get-buffer aname)) + ) + (if abuf + (progn + (set-buffer abuf) + (setq buffer-read-only nil) + (erase-buffer) + ) + (setq abuf (get-buffer-create aname)) + (set-buffer abuf) + ) + (as-binary-input-file + (insert-file-contents msg-filename) + ;; (goto-char (point-min)) + (while (re-search-forward "\r$" nil t) + (replace-match "") + ) + ) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (setq buffer-file-name msg-filename) + (mh-show-mode) + (mime/viewer-mode nil nil nil + aname (concat "show-" folder)) + (goto-char (point-min)) + ) + (let ((clean-message-header mh-clean-message-header) + (invisible-headers mh-invisible-headers) + (visible-headers mh-visible-headers) + ) + ;; 1995/9/21 + ;; modified by ARIURA + ;; to support mhl. + (if mhl-formfile + (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" + (if (stringp mhl-formfile) + (list "-form" mhl-formfile)) + msg-filename) + (insert-file-contents msg-filename)) + ;; end + (goto-char (point-min)) + (cond (clean-message-header + (mh-clean-msg-header (point-min) + invisible-headers + visible-headers) + (goto-char (point-min))) + (t + (mh-start-of-uncleaned-message))) + (if tm-mh-e/decode-encoded-word + (mime/decode-message-header) + ) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (setq buffer-file-name msg-filename) + (mh-show-mode) + )) + (or (eq buffer-undo-list t) ;don't save undo info for prev msgs + (setq buffer-undo-list nil)) +;;; Added by itokon (02/19/96) + (setq buffer-file-name msg-filename) +;;; + (set-mark nil) + (setq mode-line-buffer-identification + (list (format mh-show-buffer-mode-line-buffer-id + folder msg-num))) + (set-buffer folder) + (setq mh-showing-with-headers nil))))) + +(defun tm-mh-e/view-message (&optional msg) + "MIME decode and play this message." + (interactive) + (if (or (null tm-mh-e/automatic-mime-preview) + (null (get-buffer mh-show-buffer)) + (save-excursion + (set-buffer mh-show-buffer) + (not (eq major-mode 'mime/viewer-mode)) + )) + (let ((tm-mh-e/automatic-mime-preview t)) + (mh-invalidate-show-buffer) + (mh-show-msg msg) + )) + (pop-to-buffer mh-show-buffer) + ) + +(defun tm-mh-e/toggle-decoding-mode (arg) + "Toggle MIME processing mode. +With arg, turn MIME processing on if arg is positive." + (interactive "P") + (setq tm-mh-e/automatic-mime-preview + (if (null arg) + (not tm-mh-e/automatic-mime-preview) + arg)) + (save-excursion + (set-buffer mh-show-buffer) + (if (null tm-mh-e/automatic-mime-preview) + (if (and mime::preview/article-buffer + (get-buffer mime::preview/article-buffer)) + (kill-buffer mime::preview/article-buffer) + ))) + (mh-invalidate-show-buffer) + (mh-show (mh-get-msg-num t)) + ) + +(defun tm-mh-e/show (&optional message) + (interactive) + (mh-invalidate-show-buffer) + (mh-show message) + ) + +(defun tm-mh-e/header-display () + (interactive) + (mh-invalidate-show-buffer) + (let ((mime-viewer/ignored-field-regexp "^:$") + tm-mh-e/decode-encoded-word) + (mh-header-display) + )) + +(defun tm-mh-e/raw-display () + (interactive) + (mh-invalidate-show-buffer) + (let (tm-mh-e/automatic-mime-preview + tm-mh-e/decode-encoded-word) + (mh-header-display) + )) + +(defun tm-mh-e/scroll-up-msg (&optional arg) + (interactive) + (mh-page-msg (or arg 1)) + ) + +(defun tm-mh-e/scroll-down-msg (&optional arg) + (interactive) + (mh-page-msg (- (or arg 1))) + ) + +(defun tm-mh-e/burst-multipart/digest () + "Burst apart the current message, which should be a multipart/digest. +The message is replaced by its table of contents and the letters from the +digest are inserted into the folder after that message." + (interactive) + (let ((digest (mh-get-msg-num t))) + (mh-process-or-undo-commands mh-current-folder) + (mh-set-folder-modified-p t) ; lock folder while bursting + (message "Bursting digest...") + (mh-exec-cmd "mhn" "-store" mh-current-folder digest) + (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num)) + (message "Bursting digest...done") + )) + + +;;; @ for tm-view +;;; + +(fset 'tm-mh-e/decode-charset-buffer + (symbol-function 'mime-charset/decode-buffer)) + +(set-alist 'mime-viewer/code-converter-alist + 'mh-show-mode + (function tm-mh-e/decode-charset-buffer)) + +(defun tm-mh-e/content-header-filter () + (goto-char (point-min)) + (mime-preview/cut-header) + (tm-mh-e/decode-charset-buffer default-mime-charset) + (mime/decode-message-header) + ) + +(set-alist 'mime-viewer/content-header-filter-alist + 'mh-show-mode + (function tm-mh-e/content-header-filter)) + +(defun tm-mh-e/quitting-method () + (let ((win (get-buffer-window + mime/output-buffer-name)) + (buf (current-buffer)) + ) + (if win + (delete-window win) + ) + (pop-to-buffer + (let ((name (buffer-name buf))) + (substring name 5) + )) + (if (not tm-mh-e/automatic-mime-preview) + (mh-invalidate-show-buffer) + ) + (mh-show (mh-get-msg-num t)) + )) + +(set-alist 'mime-viewer/quitting-method-alist + 'mh-show-mode + (function tm-mh-e/quitting-method)) +(set-alist 'mime-viewer/show-summary-method + 'mh-show-mode + (function tm-mh-e/quitting-method)) + +(defun tm-mh-e/following-method (buf) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (setq mh-show-buffer buf) + (apply (function mh-send) + (std11-field-bodies '("To" "cc" "Subject") "")) + (setq mh-sent-from-folder buf) + (setq mh-sent-from-msg 1) + (let ((last (point))) + (mh-yank-cur-msg) + (goto-char last) + ))) + +(set-alist 'mime-viewer/following-method-alist + 'mh-show-mode + (function tm-mh-e/following-method)) + + +;;; @@ for tm-partial +;;; + +(call-after-loaded + 'tm-partial + (function + (lambda () + (set-atype 'mime/content-decoding-condition + '((type . "message/partial") + (method . mime-article/grab-message/partials) + (major-mode . mh-show-mode) + (summary-buffer-exp + . (and (or (string-match "^article-\\(.+\\)$" article-buffer) + (string-match "^show-\\(.+\\)$" article-buffer)) + (substring article-buffer + (match-beginning 1) (match-end 1)) + )) + )) + (set-alist 'tm-partial/preview-article-method-alist + 'mh-show-mode + (function + (lambda () + (let ((tm-mh-e/automatic-mime-preview t)) + (tm-mh-e/show) + )))) + ))) + + +;;; @ set up +;;; + +(define-key mh-folder-mode-map "v" (function tm-mh-e/view-message)) +(define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode)) +(define-key mh-folder-mode-map "." (function tm-mh-e/show)) +(define-key mh-folder-mode-map "," (function tm-mh-e/header-display)) +(define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display)) +(define-key mh-folder-mode-map "\r" (function tm-mh-e/scroll-up-msg)) +(define-key mh-folder-mode-map "\e\r" (function tm-mh-e/scroll-down-msg)) +(define-key mh-folder-mode-map "\C-c\C-b" + (function tm-mh-e/burst-multipart/digest)) + +(defun tm-mh-e/summary-before-quit () + (let ((buf (get-buffer mh-show-buffer))) + (if buf + (let ((the-buf (current-buffer))) + (switch-to-buffer buf) + (if (and mime::article/preview-buffer + (setq buf (get-buffer mime::article/preview-buffer)) + ) + (progn + (switch-to-buffer the-buf) + (kill-buffer buf) + ) + (switch-to-buffer the-buf) + ) + )))) + +(add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit)) + + +;;; @@ for tmh-comp.el +;;; + +(autoload 'tm-mh-e/edit-again "tmh-comp" + "Clean-up a draft or a message previously sent and make it resendable." t) +(autoload 'tm-mh-e/extract-rejected-mail "tmh-comp" + "Extract a letter returned by the mail system and make it re-editable." t) +(autoload 'tm-mh-e/forward "tmh-comp" + "Forward a message or message sequence by MIME style." t) + +(call-after-loaded + 'mime-setup + (function + (lambda () + (substitute-key-definition + 'mh-edit-again 'tm-mh-e/edit-again mh-folder-mode-map) + (substitute-key-definition + 'mh-extract-rejected-mail 'tm-mh-e/extract-rejected-mail + mh-folder-mode-map) + (substitute-key-definition + 'mh-forward 'tm-mh-e/forward mh-folder-mode-map) + + (call-after-loaded + 'mh-comp + (function + (lambda () + (require 'tmh-comp) + )) + 'mh-letter-mode-hook) + ))) + + +;;; @ for BBDB +;;; + +(call-after-loaded + 'bbdb + (function + (lambda () + (require 'tm-bbdb) + ))) + + +;;; @ end +;;; + +(provide 'tm-mh-e) + +(run-hooks 'tm-mh-e-load-hook) + +;;; tm-mh-e.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-orig.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-orig.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,71 @@ +;;; +;;; tm-orig.el --- tm definitions depended on FSF Original Emacs +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1994,1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Version: +;;; $Id: tm-orig.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'emu) + + +;;; @ variables +;;; + +(defvar mime/default-coding-system nil) + +(defvar mime/lc-charset-alist + (list + (cons (list lc-ascii) "US-ASCII") + (cons (list lc-ascii lc-ltn1) "ISO-8859-1") + )) + +(defvar mime/unknown-charset "ISO-8859-1") + + +;;; @ functions +;;; + +(defun mime/convert-string-to-emacs (charset str) + (if (or (string= "US-ASCII" charset) + (string= "ISO-8859-1" charset)) + str)) + +(defun mime/convert-string-from-emacs (str charset) + (if (or (string= charset "US-ASCII") + (string= charset "ISO-8859-1")) + str)) + +(defun mime/code-convert-region-to-emacs (beg end charset &optional encoding) + ) + + +;;; @ end +;;; + +(provide 'tm-orig) + +(run-hooks 'tm-orig-load-hook) + +;;; tm-orig.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-parse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-parse.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,224 @@ +;;; tm-parse.el --- MIME message parser + +;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Id: tm-parse.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;; Keywords: mail, news, MIME, multimedia + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'tl-822) +(require 'tl-misc) +(require 'tm-def) + + +;;; @ field parser +;;; + +(defconst mime/content-parameter-value-regexp + (concat "\\(" + rfc822/quoted-string-regexp + "\\|[^; \t\n]*\\)")) + +(defconst mime::parameter-regexp + (concat "^[ \t]*\;[ \t]*\\(" mime/token-regexp "\\)" + "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)")) + +(defun mime/parse-parameter (str) + (if (string-match mime::parameter-regexp str) + (let ((e (match-end 2))) + (cons + (cons (downcase (substring str (match-beginning 1) (match-end 1))) + (std11-strip-quoted-string + (substring str (match-beginning 2) e)) + ) + (substring str e) + )))) + +(defconst mime::ctype-regexp (concat "^" mime/content-type-subtype-regexp)) + +(defun mime/parse-Content-Type (string) + "Parse STRING as field-body of Content-Type field. [tm-parse.el]" + (setq string (std11-unfold-string string)) + (if (string-match mime::ctype-regexp string) + (let* ((e (match-end 0)) + (ctype (downcase (substring string 0 e))) + ret dest) + (setq string (substring string e)) + (while (setq ret (mime/parse-parameter string)) + (setq dest (cons (car ret) dest) + string (cdr ret)) + ) + (cons ctype (nreverse dest)) + ))) + +(defconst mime::dtype-regexp (concat "^" mime/disposition-type-regexp)) + +(defun mime/parse-Content-Disposition (string) + "Parse STRING as field-body of Content-Disposition field. [tm-parse.el]" + (setq string (std11-unfold-string string)) + (if (string-match mime::dtype-regexp string) + (let* ((e (match-end 0)) + (ctype (downcase (substring string 0 e))) + ret dest) + (setq string (substring string e)) + (while (setq ret (mime/parse-parameter string)) + (setq dest (cons (car ret) dest) + string (cdr ret)) + ) + (cons ctype (nreverse dest)) + ))) + + +;;; @ field reader +;;; + +(defun mime/Content-Type () + "Read field-body of Content-Type field from current-buffer, +and return parsed it. [tm-parse.el]" + (let ((str (std11-field-body "Content-Type"))) + (if str + (mime/parse-Content-Type str) + ))) + +(defun mime/Content-Transfer-Encoding (&optional default-encoding) + "Read field-body of Content-Transfer-Encoding field from +current-buffer, and return it. +If is is not found, return DEFAULT-ENCODING. [tm-parse.el]" + (let ((str (std11-field-body "Content-Transfer-Encoding"))) + (if str + (progn + (if (string-match "[ \t\n\r]+$" str) + (setq str (substring str 0 (match-beginning 0))) + ) + (downcase str) + ) + default-encoding) + )) + +(defun mime/Content-Disposition () + "Read field-body of Content-Disposition field from current-buffer, +and return parsed it. [tm-parse.el]" + (let ((str (std11-field-body "Content-Disposition"))) + (if str + (mime/parse-Content-Disposition str) + ))) + + +;;; @ message parser +;;; + +(define-structure mime::content-info + rcnum point-min point-max type parameters encoding children) + + +(defun mime/parse-multipart (boundary ctype params encoding rcnum) + (goto-char (point-min)) + (let* ((dash-boundary (concat "--" boundary)) + (delimiter (concat "\n" (regexp-quote dash-boundary))) + (close-delimiter (concat delimiter "--[ \t]*$")) + (beg (point-min)) + (end (progn + (goto-char (point-max)) + (if (re-search-backward close-delimiter nil t) + (match-beginning 0) + (point-max) + ))) + (rsep (concat delimiter "[ \t]*\n")) + (dc-ctl + (if (string-equal ctype "multipart/digest") + '("message/rfc822") + '("text/plain") + )) + cb ce ct ret ncb children (i 0)) + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (re-search-forward rsep nil t) + (setq cb (match-end 0)) + (while (re-search-forward rsep nil t) + (setq ce (match-beginning 0)) + (setq ncb (match-end 0)) + (save-restriction + (narrow-to-region cb ce) + (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum))) + ) + (setq children (cons ret children)) + (goto-char (mime::content-info/point-max ret)) + (goto-char (setq cb ncb)) + (setq i (1+ i)) + ) + (setq ce (point-max)) + (save-restriction + (narrow-to-region cb ce) + (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum))) + ) + (setq children (cons ret children)) + ) + (mime::content-info/create rcnum beg (point-max) + ctype params encoding + (nreverse children)) + )) + +(defun mime/parse-message (&optional ctl encoding rcnum) + "Parse current-buffer as a MIME message. [tm-parse.el]" + (setq ctl (or (mime/Content-Type) ctl)) + (setq encoding (or (mime/Content-Transfer-Encoding) encoding)) + (let ((ctype (car ctl)) + (params (cdr ctl)) + ) + (let ((boundary (assoc "boundary" params))) + (cond (boundary + (setq boundary (std11-strip-quoted-string (cdr boundary))) + (mime/parse-multipart boundary ctype params encoding rcnum) + ) + ((or (string-equal ctype "message/rfc822") + (string-equal ctype "message/news") + ) + (goto-char (point-min)) + (mime::content-info/create rcnum + (point-min) (point-max) + ctype params encoding + (save-restriction + (narrow-to-region + (if (re-search-forward "^$" nil t) + (1+ (match-end 0)) + (point-min) + ) + (point-max)) + (list (mime/parse-message + nil nil (cons 0 rcnum))) + ) + ) + ) + (t + (mime::content-info/create rcnum (point-min) (point-max) + ctype params encoding nil) + )) + ))) + + +;;; @ end +;;; + +(provide 'tm-parse) + +;;; tm-parse.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-partial.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-partial.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,114 @@ +;;; tm-partial.el --- Grabbing all MIME "message/partial"s. + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: OKABE Yasuo @ Kyoto University +;; MORIOKA Tomohiko +;; Version: +;; $Id: tm-partial.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, message/partial + +;; This file is a part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with 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. + +;;; Code: + +(require 'tm-view) +(require 'tm-play) + +(defvar tm-partial/preview-article-method-alist nil) + +;; display Article at the cursor in Subject buffer. +(defun tm-partial/preview-article (target) + (let ((f (assq target tm-partial/preview-article-method-alist))) + (if f + (funcall (cdr f)) + (error "Fatal. Unsupported mode") + ))) + +(defun mime-article/grab-message/partials (beg end cal) + (interactive) + (let* ((id (cdr (assoc "id" cal))) + (buffer (generate-new-buffer id)) + (mother mime::article/preview-buffer) + (target (cdr (assq 'major-mode cal))) + (article-buffer (buffer-name (current-buffer))) + (subject-buf (eval (cdr (assq 'summary-buffer-exp cal)))) + subject-id + (root-dir (expand-file-name + (concat "m-prts-" (user-login-name)) mime/tmp-dir)) + full-file) + (setq root-dir (concat root-dir "/" (replace-as-filename id))) + (setq full-file (concat root-dir "/FULL")) + + (if (null target) + (error "%s is not supported. Sorry." target) + ) + + ;; if you can't parse the subject line, try simple decoding method + (if (or (file-exists-p full-file) + (not (y-or-n-p "Merge partials?")) + ) + (progn + (kill-buffer buffer) + (mime-article/decode-message/partial beg end cal) + ) + (let (cinfo the-id parameters) + (setq subject-id (std11-field-body "Subject")) + (if (string-match "[0-9\n]+" subject-id) + (setq subject-id (substring subject-id 0 (match-beginning 0))) + ) + (pop-to-buffer subject-buf) + (while (search-backward subject-id nil t) + ) + (catch 'tag + (while t + (tm-partial/preview-article target) + (pop-to-buffer article-buffer) + (switch-to-buffer mime::article/preview-buffer) + (setq cinfo + (mime::preview-content-info/content-info + (car mime::preview/content-list))) + (setq parameters (mime::content-info/parameters cinfo)) + (setq the-id (assoc-value "id" parameters)) + (if (equal the-id id) + (progn + (switch-to-buffer article-buffer) + (mime-article/decode-message/partial + (point-min)(point-max) parameters) + (if (file-exists-p full-file) + (throw 'tag nil) + ) + )) + (if (not (progn + (pop-to-buffer subject-buf) + (end-of-line) + (search-forward subject-id nil t) + )) + (error "not found") + ) + )))))) + + +;;; @ end +;;; + +(provide 'tm-partial) + +(run-hooks 'tm-partial-load-hook) + +;;; tm-partial.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-pgp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-pgp.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,333 @@ +;;; tm-pgp.el --- tm-view internal methods for PGP. + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Maintainer: MORIOKA Tomohiko +;; Created: 1995/12/7 +;; Version: $Id: tm-pgp.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, PGP, security + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module is based on 2 drafts about PGP MIME integration: + +;; - draft-elkins-pem-pgp-04.txt +;; ``MIME Security with Pretty Good Privacy (PGP)'' +;; by Michael Elkins (1996/6) +;; +;; - draft-kazu-pgp-mime-00.txt +;; ``PGP MIME Integration'' +;; by Kazuhiko Yamamoto (1995/10) +;; +;; These drafts may be contrary to each other. You should decide +;; which you support. + +;;; Code: + +(require 'mailcrypt) +(require 'tm-play) + + +;;; @ internal method for application/pgp +;;; +;;; It is based on draft-kazu-pgp-mime-00.txt + +(defun mime-article/view-application/pgp (beg end cal) + (let* ((cnum (mime-article/point-content-number beg)) + (cur-buf (current-buffer)) + (new-name (format "%s-%s" (buffer-name) cnum)) + (mother mime::article/preview-buffer) + (mode major-mode) + code-converter str) + (setq str (buffer-substring beg end)) + (switch-to-buffer new-name) + (erase-buffer) + (insert str) + (cond ((progn + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) + ) + (mc-verify) + (goto-char (point-min)) + (delete-region + (point-min) + (and + (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n") + (match-end 0)) + ) + (delete-region + (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+") + (match-beginning 0)) + (point-max) + ) + (goto-char (point-min)) + (while (re-search-forward "^- -" nil t) + (replace-match "-") + ) + (setq code-converter + (or + (cdr (assq mode mime-viewer/code-converter-alist)) + (function mime-viewer/default-code-convert-region))) + ) + ((progn + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t) + ) + (as-binary-process (mc-decrypt)) + (goto-char (point-min)) + (delete-region (point-min) + (and + (search-forward "\n\n") + (match-end 0))) + (setq code-converter (function mime-charset/decode-buffer)) + )) + (setq major-mode 'mime/show-message-mode) + (setq mime::article/code-converter code-converter) + (mime/viewer-mode mother) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "application/pgp") + (method . mime-article/view-application/pgp) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "text/x-pgp") + (method . mime-article/view-application/pgp) + )) + + +;;; @ Internal method for application/pgp-signature +;;; +;;; It is based on draft-elkins-pem-pgp-02.txt + +(defvar tm-pgp::default-language 'en + "*Symbol of language for pgp. +It should be ISO 639 2 letter language code such as en, ja, ...") + +(defvar tm-pgp::good-signature-regexp-alist + '((en . "Good signature from user.*$")) + "Alist of language vs regexp to detect ``Good signature''.") + +(defvar tm-pgp::key-expected-regexp-alist + '((en . "Key matching expected Key ID \\(\\S +\\) not found")) + "Alist of language vs regexp to detect ``Key expected''.") + +(defun mime::article/call-pgp-to-check-signature (output-buffer orig-file) + (save-excursion + (set-buffer output-buffer) + (erase-buffer) + ) + (let* ((lang (or tm-pgp::default-language 'en)) + (status + (call-process-region (point-min)(point-max) + "pgp" nil output-buffer nil orig-file + (format "+language=%s" lang) + )) + (regexp (cdr (assq lang tm-pgp::good-signature-regexp-alist))) + ) + (if (= status 0) + (save-excursion + (set-buffer output-buffer) + (goto-char (point-min)) + (message + (cond ((not (stringp regexp)) + "Please specify right regexp for specified language") + ((re-search-forward regexp nil t) + (buffer-substring (match-beginning 0) (match-end 0)) + ) + (t + "Bad signature" + ))) + )))) + +(defun mime-article/check-pgp-signature (beg end cal) + (let* ((encoding (cdr (assq 'encoding cal))) + (cnum (mime-article/point-content-number beg)) + (rcnum (reverse cnum)) + (rmcnum (cdr rcnum)) + (knum (car rcnum)) + (onum (if (> knum 0) + (1- knum) + (1+ knum))) + (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum) + mime::article/content-info)) + status str kbuf + (basename (expand-file-name "tm" mime/tmp-dir)) + (orig-file (make-temp-name basename)) + (sig-file (concat orig-file ".sig")) + ) + (save-excursion + (setq str (buffer-substring + (mime::content-info/point-min oinfo) + (mime::content-info/point-max oinfo) + )) + (set-buffer (get-buffer-create mime/temp-buffer-name)) + (insert str) + (goto-char (point-min)) + (while (re-search-forward "\n" nil t) + (replace-match "\r\n") + ) + (let ((mc-flag nil) ; for Mule + (file-coding-system *noconv*) + kanji-flag ; for NEmacs + (emx-binary-mode t) ; for OS/2 + jka-compr-compression-info-list ; for jka-compr + jam-zcat-filename-list ; for jam-zcat + require-final-newline) + (write-file orig-file) + ) + (kill-buffer (current-buffer)) + ) + (save-excursion + (mime-article/show-output-buffer) + ) + (save-excursion + (setq str (buffer-substring + (save-excursion + (goto-char beg) + (and (search-forward "\n\n") + (match-end 0))) + end)) + (set-buffer (setq kbuf (get-buffer-create mime/temp-buffer-name))) + (insert str) + (mime-decode-region (point-min)(point-max) encoding) + (let ((mc-flag nil) ; for Mule + (file-coding-system *noconv*) + kanji-flag ; for NEmacs + (emx-binary-mode t) ; for OS/2 + jka-compr-compression-info-list ; for jka-compr + jam-zcat-filename-list ; for jam-zcat + require-final-newline) + (write-file sig-file) + ) + ;;(get-buffer-create mime/output-buffer-name) + (or (mime::article/call-pgp-to-check-signature + mime/output-buffer-name orig-file) + (let (pgp-id) + (save-excursion + (set-buffer mime/output-buffer-name) + (goto-char (point-min)) + (let ((regexp (cdr (assq (or tm-pgp::default-language 'en) + tm-pgp::key-expected-regexp-alist)))) + (cond ((not (stringp regexp)) + (message + "Please specify right regexp for specified language") + ) + ((re-search-forward regexp nil t) + (setq pgp-id + (concat "0x" (buffer-substring-no-properties + (match-beginning 1) + (match-end 1)))) + )))) + (if (and pgp-id + (y-or-n-p + (format "Key %s not found; attempt to fetch? " pgp-id)) + ) + (progn + (mc-pgp-fetch-key (cons nil pgp-id)) + (mime::article/call-pgp-to-check-signature + mime/output-buffer-name orig-file) + )) + )) + (let ((other-window-scroll-buffer mime/output-buffer-name)) + (scroll-other-window 8) + ) + (kill-buffer kbuf) + (delete-file orig-file) + (delete-file sig-file) + ))) + +(set-atype 'mime/content-decoding-condition + '((type . "application/pgp-signature") + (method . mime-article/check-pgp-signature) + )) + + +;;; @ Internal method for application/pgp-encrypted +;;; +;;; It is based on draft-elkins-pem-pgp-02.txt + +(defun mime-article/decrypt-pgp (beg end cal) + (let* ((cnum (mime-article/point-content-number beg)) + (rcnum (reverse cnum)) + (rmcnum (cdr rcnum)) + (knum (car rcnum)) + (onum (if (> knum 0) + (1- knum) + (1+ knum))) + (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum) + mime::article/content-info)) + (obeg (mime::content-info/point-min oinfo)) + (oend (mime::content-info/point-max oinfo)) + ) + (mime-article/view-application/pgp obeg oend cal) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "application/pgp-encrypted") + (method . mime-article/decrypt-pgp) + )) + + +;;; @ Internal method for application/pgp-keys +;;; +;;; It is based on draft-elkins-pem-pgp-02.txt + +(autoload 'mc-snarf-keys "mc-toplev") + +(defun mime-article/add-pgp-keys (beg end cal) + (let* ((cnum (mime-article/point-content-number beg)) + (cur-buf (current-buffer)) + (new-name (format "%s-%s" (buffer-name) cnum)) + (mother mime::article/preview-buffer) + (charset (cdr (assoc "charset" cal))) + (encoding (cdr (assq 'encoding cal))) + (mode major-mode) + str) + (setq str (buffer-substring beg end)) + (switch-to-buffer new-name) + (setq buffer-read-only nil) + (erase-buffer) + (insert str) + (goto-char (point-min)) + (if (re-search-forward "^\n" nil t) + (delete-region (point-min) (match-end 0)) + ) + (mime-decode-region (point-min)(point-max) encoding) + (mc-snarf-keys) + (kill-buffer (current-buffer)) + )) + +(set-atype 'mime/content-decoding-condition + '((type . "application/pgp-keys") + (method . mime-article/add-pgp-keys) + )) + + +;;; @ end +;;; + +(provide 'tm-pgp) + +(run-hooks 'tm-pgp-load-hook) + +;;; tm-pgp.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-play.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-play.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,435 @@ +;;; tm-play.el --- decoder for tm-view.el + +;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/9/26 (separated from tm-view.el) +;; Version: $Id: tm-play.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;; Keywords: mail, news, MIME, multimedia + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'tm-view) + +(defvar mime-viewer/external-progs "/usr/local/share/tm" + "*Directory containing tm external methods.") + +(add-to-list 'exec-path mime-viewer/external-progs) + +(let ((paths (parse-colon-path (getenv "PATH")))) + (or (member mime-viewer/external-progs paths) + (setenv "PATH" + (mapconcat (function identity) + (append paths (list mime-viewer/external-progs)) + path-separator)) + )) + + +;;; @ content decoder +;;; + +(defvar mime-preview/after-decoded-position nil) + +(defun mime-preview/decode-content () + (interactive) + (let ((pc (mime-preview/point-pcinfo (point)))) + (if pc + (let ((the-buf (current-buffer))) + (setq mime-preview/after-decoded-position (point)) + (set-buffer (mime::preview-content-info/buffer pc)) + (mime-article/decode-content + (mime::preview-content-info/content-info pc)) + (if (eq (current-buffer) + (mime::preview-content-info/buffer pc)) + (progn + (set-buffer the-buf) + (goto-char mime-preview/after-decoded-position) + )) + )))) + +(defun mime-article/decode-content (cinfo) + (let ((beg (mime::content-info/point-min cinfo)) + (end (mime::content-info/point-max cinfo)) + (ctype (or (mime::content-info/type cinfo) "text/plain")) + (params (mime::content-info/parameters cinfo)) + (encoding (mime::content-info/encoding cinfo)) + ) + ;; Check for VM + (if (< beg (point-min)) + (setq beg (point-min)) + ) + (if (< (point-max) end) + (setq end (point-max)) + ) + (let (method cal ret) + (setq cal (list* (cons 'type ctype) + (cons 'encoding encoding) + (cons 'major-mode major-mode) + params)) + (if mime-viewer/decoding-mode + (setq cal (cons + (cons 'mode mime-viewer/decoding-mode) + cal)) + ) + (setq ret (mime/get-content-decoding-alist cal)) + (setq method (cdr (assq 'method ret))) + (cond ((and (symbolp method) + (fboundp method)) + (funcall method beg end ret) + ) + ((and (listp method)(stringp (car method))) + (mime-article/start-external-method-region beg end ret) + ) + (t + (mime-article/show-output-buffer + "No method are specified for %s\n" ctype) + )) + ) + )) + +(defun field-unifier-for-mode (a b) + (let ((va (cdr a))) + (if (if (consp va) + (member (cdr b) va) + (equal va (cdr b)) + ) + (list nil b nil) + ))) + +(defun mime/get-content-decoding-alist (al) + (get-unified-alist mime/content-decoding-condition al) + ) + + +;;; @ external decoder +;;; + +(defun mime-article/start-external-method-region (beg end cal) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (let ((method (cdr (assoc 'method cal))) + (name (mime-article/get-filename cal)) + ) + (if method + (let ((file (make-temp-name + (expand-file-name "TM" mime/tmp-dir))) + b args) + (if (nth 1 method) + (setq b beg) + (setq b + (if (re-search-forward "^$" nil t) + (1+ (match-end 0)) + (point-min) + )) + ) + (goto-char b) + (write-region b end file) + (message "External method is starting...") + (setq cal (put-alist + 'name (replace-as-filename name) cal)) + (setq cal (put-alist 'file file cal)) + (setq args (nconc + (list (car method) + mime/output-buffer-name (car method) + ) + (mime-article/make-method-args cal + (cdr (cdr method))) + )) + (apply (function start-process) args) + (mime-article/show-output-buffer) + )) + )))) + +(defun mime-article/make-method-args (cal format) + (mapcar (function + (lambda (arg) + (if (stringp arg) + arg + (let* ((item (eval arg)) + (ret (cdr (assoc item cal))) + ) + (if ret + ret + (if (eq item 'encoding) + "7bit" + "")) + )) + )) + format)) + +(defun mime-article/show-output-buffer (&rest forms) + (get-buffer-create mime/output-buffer-name) + (let ((the-win (selected-window)) + (win (get-buffer-window mime/output-buffer-name)) + ) + (or win + (if (and mime/output-buffer-window-is-shared-with-bbdb + (boundp 'bbdb-buffer-name) + (setq win (get-buffer-window bbdb-buffer-name)) + ) + (set-window-buffer win mime/output-buffer-name) + (select-window (get-buffer-window mime::article/preview-buffer)) + (setq win (split-window-vertically (/ (* (window-height) 3) 4))) + (set-window-buffer win mime/output-buffer-name) + )) + (select-window win) + (goto-char (point-max)) + (if forms + (insert (apply (function format) forms)) + ) + (select-window the-win) + )) + + +;;; @ file name +;;; + +(defvar mime-viewer/file-name-char-regexp "[A-Za-z0-9+_-]") + +(defvar mime-viewer/file-name-regexp-1 + (concat mime-viewer/file-name-char-regexp "+\\." + mime-viewer/file-name-char-regexp "+")) + +(defvar mime-viewer/file-name-regexp-2 + (concat (regexp-* mime-viewer/file-name-char-regexp) + "\\(\\." mime-viewer/file-name-char-regexp "+\\)*")) + +(defun mime-article/get-original-filename (param &optional encoding) + (or (mime-article/get-uu-filename param encoding) + (let (ret) + (or (if (or (and (setq ret (mime/Content-Disposition)) + (setq ret (assoc "filename" (cdr ret))) + ) + (setq ret (assoc "name" param)) + (setq ret (assoc "x-name" param)) + ) + (std11-strip-quoted-string (cdr ret)) + ) + (if (setq ret + (std11-find-field-body '("Content-Description" + "Subject"))) + (if (or (string-match mime-viewer/file-name-regexp-1 ret) + (string-match mime-viewer/file-name-regexp-2 ret)) + (substring ret (match-beginning 0)(match-end 0)) + )) + )) + )) + +(defun mime-article/get-filename (param) + (replace-as-filename (mime-article/get-original-filename param)) + ) + + +;;; @ mail/news message +;;; + +(defun mime-viewer/quitting-method-for-mime/show-message-mode () + (let ((mother mime::preview/mother-buffer) + (win-conf mime::preview/original-window-configuration) + ) + (kill-buffer + (mime::preview-content-info/buffer (car mime::preview/content-list))) + (mime-viewer/kill-buffer) + (set-window-configuration win-conf) + (pop-to-buffer mother) + ;;(goto-char (point-min)) + ;;(mime-viewer/up-content) + )) + +(defun mime-article/view-message/rfc822 (beg end cal) + (let* ((cnum (mime-article/point-content-number beg)) + (cur-buf (current-buffer)) + (new-name (format "%s-%s" (buffer-name) cnum)) + (mother mime::article/preview-buffer) + (code-converter + (or (cdr (assq major-mode mime-viewer/code-converter-alist)) + 'mime-viewer/default-code-convert-region)) + str) + (setq str (buffer-substring beg end)) + (switch-to-buffer new-name) + (erase-buffer) + (insert str) + (goto-char (point-min)) + (if (re-search-forward "^\n" nil t) + (delete-region (point-min) (match-end 0)) + ) + (setq major-mode 'mime/show-message-mode) + (setq mime::article/code-converter code-converter) + (mime/viewer-mode mother) + )) + + +;;; @ message/partial +;;; + +(defvar mime-article/coding-system-alist + (and (boundp 'MULE) + '((mh-show-mode . *noconv*) + (t . *ctext*) + ))) + +(defvar mime-article/kanji-code-alist + (and (boundp 'NEMACS) + '((mh-show-mode . nil) + (t . 2) + ))) + +(defun mime-article/decode-message/partial (beg end cal) + (goto-char beg) + (let* ((root-dir (expand-file-name + (concat "m-prts-" (user-login-name)) mime/tmp-dir)) + (id (cdr (assoc "id" cal))) + (number (cdr (assoc "number" cal))) + (total (cdr (assoc "total" cal))) + (the-buf (current-buffer)) + file + (mother mime::article/preview-buffer) + (win-conf (save-excursion + (set-buffer mother) + mime::preview/original-window-configuration)) + ) + (if (not (file-exists-p root-dir)) + (make-directory root-dir) + ) + (setq id (replace-as-filename id)) + (setq root-dir (concat root-dir "/" id)) + (if (not (file-exists-p root-dir)) + (make-directory root-dir) + ) + (setq file (concat root-dir "/FULL")) + (if (not (file-exists-p file)) + (progn + (re-search-forward "^$") + (goto-char (1+ (match-end 0))) + (setq file (concat root-dir "/" number)) + (let ((file-coding-system + (cdr + (or (assq major-mode mime-article/coding-system-alist) + (assq t mime-article/coding-system-alist) + ))) + (kanji-fileio-code + (cdr + (or (assq major-mode mime-article/kanji-code-alist) + (assq t mime-article/kanji-code-alist) + ))) + ) + (write-region (point) (point-max) file) + ) + (if (get-buffer mime/temp-buffer-name) + (kill-buffer mime/temp-buffer-name) + ) + (switch-to-buffer mime/temp-buffer-name) + (let ((i 1) + (max (string-to-int total)) + (file-coding-system-for-read (if (boundp 'MULE) + *noconv*)) + kanji-fileio-code) + (catch 'tag + (while (<= i max) + (setq file (concat root-dir "/" (int-to-string i))) + (if (not (file-exists-p file)) + (progn + (switch-to-buffer the-buf) + (throw 'tag nil) + )) + (insert-file-contents file) + (goto-char (point-max)) + (setq i (1+ i)) + ) + ;;(delete-other-windows) + (let ((buf (current-buffer))) + (write-file (concat root-dir "/FULL")) + (set-window-configuration win-conf) + (let ((win (get-buffer-window mother))) + (if win + (select-window win) + )) + (set-window-buffer (selected-window) buf) + ;;(set-window-buffer buf) + (setq major-mode 'mime/show-message-mode) + ) + (mime/viewer-mode mother) + (pop-to-buffer (current-buffer)) + )) + ) + (progn + ;;(delete-other-windows) + (set-window-configuration win-conf) + (select-window (or (get-buffer-window mother) + (get-buffer-window + (save-excursion + (set-buffer mother) + mime::preview/article-buffer)) + (get-largest-window) + )) + (as-binary-input-file + (set-buffer (get-buffer-create "FULL")) + (insert-file-contents file) + ) + (setq major-mode 'mime/show-message-mode) + (mime/viewer-mode mother) + ;;(pop-to-buffer (current-buffer)) + )) + )) + + +;;; @ rot13-47 +;;; + +(defun mime-article/decode-caesar (beg end cal) + (let* ((cnum (mime-article/point-content-number beg)) + (cur-buf (current-buffer)) + (new-name (format "%s-%s" (buffer-name) cnum)) + (mother mime::article/preview-buffer) + (charset (cdr (assoc "charset" cal))) + (encoding (cdr (assq 'encoding cal))) + (mode major-mode) + str) + (setq str (buffer-substring beg end)) + (switch-to-buffer new-name) + (setq buffer-read-only nil) + (erase-buffer) + (insert str) + (goto-char (point-min)) + (if (re-search-forward "^\n" nil t) + (delete-region (point-min) (match-end 0)) + ) + (let ((m (cdr (or (assq mode mime-viewer/code-converter-alist) + (assq t mime-viewer/code-converter-alist))))) + (and (functionp m) + (funcall m charset encoding) + )) + (save-excursion + (set-mark (point-min)) + (goto-char (point-max)) + (tm:caesar-region) + ) + (view-mode) + )) + + +;;; @ end +;;; + +(provide 'tm-play) + +;;; tm-play.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-rich.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-rich.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,100 @@ +;;; +;;; tm-rich.el --- text/enriched and text/richtext style +;;; richtext filter for tm-view +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Version: +;;; $Id: tm-rich.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;;; Keywords: mail, news, MIME, multimedia, richtext, enriched +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'tm-view) + +(defvar tm-rich/richtext-module + (if (or running-emacs-19_29-or-later + running-xemacs-20 + (and running-xemacs (>= emacs-minor-version 14))) + 'richtext + 'tinyrich)) + +(require tm-rich/richtext-module) + + +;;; @ content filters for tm-view +;;; + +(defun mime-viewer/filter-text/richtext (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (charset (assoc "charset" params)) + ;; 1995/9/21 (c.f. tm-eng:105), 1995/10/3 (c.f. tm-eng:121) + ;; modified by Eric Ding + (beg (point-min)) (end (point-max)) + ) + (remove-text-properties beg end '(face nil)) + (mime/decode-region encoding beg end) + (if (and m (fboundp (setq m (cdr m)))) + (funcall m beg (point-max) charset encoding) + (mime-viewer/default-code-convert-region beg (point-max) + charset encoding) + ) + (richtext-decode beg (point-max)) + )) + +(defun mime-viewer/filter-text/enriched (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (charset (assoc "charset" params)) + ;; 1995/9/21 (c.f. tm-eng:105), 1995/10/3 (c.f. tm-eng:121) + ;; modified by Eric Ding + (beg (point-min)) (end (point-max)) + ) + (remove-text-properties beg end '(face nil)) + (mime/decode-region encoding beg end) + (if (and m (fboundp (setq m (cdr m)))) + (funcall m beg (point-max) charset encoding) + (mime-viewer/default-code-convert-region beg (point-max) + charset encoding) + ) + (enriched-decode beg (point-max)) + )) + + +;;; @ setting +;;; + +(set-alist 'mime-viewer/content-filter-alist + "text/richtext" (function mime-viewer/filter-text/richtext)) + +(set-alist 'mime-viewer/content-filter-alist + "text/enriched" (function mime-viewer/filter-text/enriched)) + + +;;; @ end +;;; + +(provide 'tm-rich) + +(run-hooks 'tm-rich-load-hook) + +;;; tm-rich.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-rmail.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-rmail.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,388 @@ +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; modified by KOBAYASHI Shuhei +;;; Created: 1994/8/30 +;;; Version: +;;; $Revision: 1.1.1.1 $ +;;; Keywords: mail, MIME, multimedia, multilingual, encoded-word +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'tl-list) +(require 'tl-misc) +(require 'rmail) + +(autoload 'mime/viewer-mode "tm-view" "View MIME message." t) +(autoload 'mime/Content-Type "tm-view" "parse Content-Type field.") +(autoload 'mime/decode-message-header "tm-ew-d" "Decode MIME encoded-word." t) + + +;;; @ variables +;;; + +(defconst tm-rmail/RCS-ID + "$Id: tm-rmail.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $") +(defconst tm-rmail/version (get-version-string tm-rmail/RCS-ID)) + +(defvar tm-rmail/decode-all nil) + + +;;; @ message filter +;;; + +(setq rmail-message-filter + (function + (lambda () + (let ((mf (buffer-modified-p)) + (buffer-read-only nil)) + (mime/decode-message-header) + (set-buffer-modified-p mf) + )))) + + +;;; @ MIME preview +;;; + +(defun tm-rmail/show-all-header-p () + (save-restriction + (narrow-to-region (point-min) + (and (re-search-forward "^$" nil t) + (match-beginning 0))) + (goto-char (point-min)) + (re-search-forward rmail-ignored-headers nil t) + )) + +(defun tm-rmail/preview-message () + (interactive) + (setq tm-rmail/decode-all t) + (let ((ret (tm-rmail/get-Content-Type-and-Content-Transfer-Encoding))) + (narrow-to-region (point-min) + (save-excursion + (goto-char (point-max)) + (if (and (re-search-backward "^\n") + (eq (match-end 0)(point-max))) + (match-beginning 0) + (point-max) + ))) + (let ((abuf (current-buffer)) + (buf-name (format "*Preview-%s [%d/%d]*" + (buffer-name) + rmail-current-message rmail-total-messages)) + buf win) + (if (and mime::article/preview-buffer + (setq buf (get-buffer mime::article/preview-buffer)) + ) + (progn + (save-excursion + (set-buffer buf) + (rename-buffer buf-name) + ) + (if (setq win (get-buffer-window buf)) + (progn + (delete-window (get-buffer-window abuf)) + (set-window-buffer win abuf) + (set-buffer abuf) + )) + )) + (setq win (get-buffer-window abuf)) + (save-window-excursion + (mime/viewer-mode nil (car ret)(cdr ret) nil buf-name) + (or buf + (setq buf (current-buffer)) + ) + ) + (set-window-buffer win buf) + ))) + +(defun tm-rmail/preview-message-if-you-need () + (if tm-rmail/decode-all + (tm-rmail/preview-message) + )) + +(add-hook 'rmail-show-message-hook 'tm-rmail/preview-message-if-you-need) + +(cond ((fboundp 'rmail-summary-rmail-update) + ;; for Emacs 19 or later + (or (fboundp 'tm:rmail-summary-rmail-update) + (fset 'tm:rmail-summary-rmail-update + (symbol-function 'rmail-summary-rmail-update)) + ) + + (defun rmail-summary-rmail-update () + (tm:rmail-summary-rmail-update) + (if tm-rmail/decode-all + (let ((win (get-buffer-window rmail-buffer))) + (if win + (delete-window win) + ))) + ) + + (defun tm-rmail/get-Content-Type-and-Content-Transfer-Encoding () + (rmail-widen-to-current-msgbeg + (function + (lambda () + (cons (mime/Content-Type) + (mime/Content-Transfer-Encoding "7bit") + ))))) + ) + (t + ;; for Emacs 18 + (defun tm-rmail/get-Content-Type-and-Content-Transfer-Encoding () + (save-restriction + (rmail-widen-to-current-msgbeg + (function + (lambda () + (goto-char (point-min)) + (narrow-to-region (or (and (re-search-forward "^.+:" nil t) + (match-beginning 0)) + (point-min)) + (point-max)) + ))) + (cons (mime/Content-Type) + (mime/Content-Transfer-Encoding "7bit") + ))) + )) + +(define-key rmail-mode-map "v" (function tm-rmail/preview-message)) + +(defun tm-rmail/setup () + (local-set-key "v" (function + (lambda () + (interactive) + (set-buffer rmail-buffer) + (tm-rmail/preview-message) + ))) + ) + +(add-hook 'rmail-summary-mode-hook 'tm-rmail/setup) + + +;;; @ over-to-* and quitting methods +;;; + +(defun tm-rmail/quitting-method-to-summary () + (mime-viewer/kill-buffer) + (rmail-summary) + (delete-other-windows) + ) + +(defun tm-rmail/quitting-method-to-article () + (setq tm-rmail/decode-all nil) + (mime-viewer/kill-buffer) + ) + +(defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article) + + +(defun tm-rmail/over-to-previous-method () + (let (tm-rmail/decode-all) + (mime-viewer/quit) + ) + (if (not (eq (rmail-next-undeleted-message -1) t)) + (tm-rmail/preview-message) + ) + ) + +(defun tm-rmail/over-to-next-method () + (let (tm-rmail/decode-all) + (mime-viewer/quit) + ) + (if (not (eq (rmail-next-undeleted-message 1) t)) + (tm-rmail/preview-message) + ) + ) + +(defun tm-rmail/show-summary-method () + (save-excursion + (set-buffer mime::preview/article-buffer) + (rmail-summary) + )) + +(call-after-loaded + 'tm-view + (function + (lambda () + (set-alist 'mime-viewer/quitting-method-alist + 'rmail-mode + (function tm-rmail/quitting-method)) + + (set-alist 'mime-viewer/over-to-previous-method-alist + 'rmail-mode + (function tm-rmail/over-to-previous-method)) + + (set-alist 'mime-viewer/over-to-next-method-alist + 'rmail-mode + (function tm-rmail/over-to-next-method)) + + (set-alist 'mime-viewer/show-summary-method + 'rmail-mode + (function tm-rmail/show-summary-method)) + ))) + + +;;; @ for tm-partial +;;; + +(call-after-loaded + 'tm-partial + (function + (lambda () + (set-atype 'mime/content-decoding-condition + '((type . "message/partial") + (method . mime-article/grab-message/partials) + (major-mode . rmail-mode) + (summary-buffer-exp + . (progn + (rmail-summary) + (pop-to-buffer rmail-buffer) + rmail-summary-buffer)) + )) + (set-alist 'tm-partial/preview-article-method-alist + 'rmail-mode + (function + (lambda () + (rmail-summary-goto-msg (count-lines 1 (point))) + (pop-to-buffer rmail-buffer) + (tm-rmail/preview-message) + ))) + ))) + + +;;; @ for tm-edit +;;; + +(defun tm-rmail/forward () + "Forward current message in message/rfc822 content-type message +from rmail. The message will be appended if being composed." + (interactive) + ;;>> this gets set even if we abort. Can't do anything about it, though. + (rmail-set-attribute "forwarded" t) + (let ((initialized nil) + (beginning nil) + (msgnum rmail-current-message) + (rmail-buffer (current-buffer)) + (subject (concat "[" + (mail-strip-quoted-names + (mail-fetch-field "From")) + ": " (or (mail-fetch-field "Subject") "") "]"))) + ;; If only one window, use it for the mail buffer. + ;; Otherwise, use another window for the mail buffer + ;; so that the Rmail buffer remains visible + ;; and sending the mail will get back to it. + (setq initialized + (if (one-window-p t) + (mail nil nil subject) + (mail-other-window nil nil subject))) + (save-excursion + ;; following two variables are used in 19.29 or later. + (make-local-variable 'rmail-send-actions-rmail-buffer) + (make-local-variable 'rmail-send-actions-rmail-msg-number) + (make-local-variable 'mail-reply-buffer) + (setq rmail-send-actions-rmail-buffer rmail-buffer) + (setq rmail-send-actions-rmail-msg-number msgnum) + (setq mail-reply-buffer rmail-buffer) + (goto-char (point-max)) + (forward-line 1) + (setq beginning (point)) + (mime-editor/insert-tag "message" "rfc822") +;; (insert-buffer rmail-buffer)) +;; (mime-editor/inserted-message-filter)) + (tm-mail/insert-message)) + (if (not initialized) + (goto-char beginning)) + )) + +(defun gnus-mail-forward-using-mail-mime () + "Forward current article in message/rfc822 content-type message from +GNUS. The message will be appended if being composed." + (let ((initialized nil) + (beginning nil) + (forwarding-buffer (current-buffer)) + (subject + (concat "[" gnus-newsgroup-name "] " + ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": " + (or (gnus-fetch-field "Subject") "")))) + ;; If only one window, use it for the mail buffer. + ;; Otherwise, use another window for the mail buffer + ;; so that the Rmail buffer remains visible + ;; and sending the mail will get back to it. + (setq initialized + (if (one-window-p t) + (mail nil nil subject) + (mail-other-window nil nil subject))) + (save-excursion + (goto-char (point-max)) + (setq beginning (point)) + (mime-editor/insert-tag "message" "rfc822") + (insert-buffer forwarding-buffer) + ;; You have a chance to arrange the message. + (run-hooks 'gnus-mail-forward-hook) + ) + (if (not initialized) + (goto-char beginning)) + )) + +(call-after-loaded + 'mime-setup + (function + (lambda () + (substitute-key-definition + 'rmail-forward 'tm-rmail/forward rmail-mode-map) + + ;; (setq gnus-mail-forward-method 'gnus-mail-forward-using-mail-mime) + + (call-after-loaded + 'tm-edit + (function + (lambda () + (require 'tm-mail) + (set-alist 'mime-editor/message-inserter-alist + 'mail-mode (function tm-mail/insert-message)) + (set-alist 'mime-editor/split-message-sender-alist + 'mail-mode (function + (lambda () + (interactive) + (sendmail-send-it) + ))) + ))) + ))) + + +;;; @ for BBDB +;;; + +(call-after-loaded + 'bbdb + (function + (lambda () + (require 'tm-bbdb) + ))) + + +;;; @ end +;;; + +(provide 'tm-rmail) + +(run-hooks 'tm-rmail-load-hook) + +;;; tm-rmail.el ends here. diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-setup.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-setup.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,153 @@ +;;; tm-setup.el --- setup file for tm viewer. + +;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Id: tm-setup.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with 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. + +;;; Code: + +(require 'tl-misc) + + +;;; @ for tm-view +;;; + +(call-after-loaded + 'tm-view + (function + (lambda () + ;; for message/partial + (require 'tm-partial) + + ;; for anonymous ftp + (set-atype 'mime/content-decoding-condition + '((type . "message/external-body") + ("access-type" . "anon-ftp") + (method . mime/decode-message/external-ftp) + )) + (autoload 'mime/decode-message/external-ftp "tm-ftp") + + ;; for LaTeX + (set-atype 'mime/content-decoding-condition + '((type . "text/x-latex") + (method . mime/decode-text/latex) + )) + (set-atype 'mime/content-decoding-condition + '((type . "application/x-latex") + (method . mime/decode-text/latex) + )) + ;;(set-atype 'mime/content-decoding-condition + ;; '((type . "application/octet-stream") + ;; ("type" . "latex") + ;; (method . mime/decode-text/latex) + ;; )) + (autoload 'mime/decode-text/latex "tm-latex") + ))) + +;; for image/* and X-Face +(if running-xemacs + (call-after-loaded 'tm-view + (function + (lambda () + (require 'tm-image) + ))) + ) + +;; for PGP +(if (module-installed-p 'mailcrypt) + (call-after-loaded 'tm-view + (function + (lambda () + (require 'tm-pgp) + ))) + ) + + +;;; @ for RMAIL +;;; + +(call-after-loaded 'rmail + (function + (lambda () + (require 'tm-rmail) + )) + 'rmail-mode-hook) + + +;;; @ for mh-e +;;; + +(let ((le (function + (lambda () + (require 'tm-mh-e) + )) + )) + (call-after-loaded 'mh-e le 'mh-folder-mode-hook) + (if (not (featurep 'mh-e)) + (add-hook 'mh-letter-mode-hook le) + )) + + +;;; @ for GNUS and Gnus +;;; + +(if (featurep 'gnus) + (if (boundp 'gnus-load-hook) + (require 'gnus-mime) + (require 'tm-gnus) + ) + ;; for GNUS + (defvar tm-setup/use-gnusutil nil) + + (defun tm-setup/load-GNUS () + (require 'tm-gnus) + ) + + (if (and (boundp 'MULE) tm-setup/use-gnusutil) + (progn + (add-hook 'gnus-Group-mode-hook (function gnusutil-initialize)) + (add-hook 'gnus-group-mode-hook (function gnusutil-initialize)) + (autoload 'gnusutil-initialize "gnusutil") + (autoload 'gnusutil-add-group "gnusutil") + (add-hook 'gnusutil-initialize-hook 'tm-setup/load-GNUS) + ) + (add-hook 'gnus-Startup-hook 'tm-setup/load-GNUS 'append) + (add-hook 'gnus-startup-hook 'tm-setup/load-GNUS 'append) + ) + + ;; for Gnus + (defun tm-setup/load-gnus () + (let (gnus-load-hook) + (remove-hook 'gnus-startup-hook 'tm-setup/load-GNUS) + (require 'gnus-mime) + )) + + (add-hook 'gnus-load-hook 'tm-setup/load-gnus) + ) + + +;;; @ end +;;; + +(provide 'tm-setup) + +;;; tm-setup.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-sgnus.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-sgnus.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,400 @@ +;;; +;;; tm-sgnus.el --- MIME extender for Gnus 5.2 +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Maintainer: MORIOKA Tomohiko +;;; and KOBAYASHI Shuhei +;;; Created: 1995/09/24 +;;; Version: $Revision: 1.1.1.1 $ +;;; Keywords: news, MIME, multimedia, multilingual, encoded-word +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +(require 'tl-str) +(require 'tl-list) +(require 'tl-misc) +(require 'tm-view) +(require 'gnus) + +(eval-when-compile (require 'cl)) + + +;;; @ version +;;; + +(defconst tm-gnus/RCS-ID + "$Id: tm-sgnus.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $") + +(defconst tm-gnus/version + (concat (get-version-string tm-gnus/RCS-ID) " for September")) + + +;;; @ variables +;;; + +(defvar tm-gnus/automatic-mime-preview t + "*If non-nil, show MIME processed article. +This variable is set to `gnus-show-mime'.") + +(setq gnus-show-mime tm-gnus/automatic-mime-preview) + + +;;; @ command functions +;;; + +(defun tm-gnus/view-message (arg) + "MIME decode and play this message." + (interactive "P") + (let ((gnus-break-pages nil)) + (gnus-summary-select-article t t) + ) + (pop-to-buffer gnus-original-article-buffer t) + (let (buffer-read-only) + (if (text-property-any (point-min) (point-max) 'invisible t) + (remove-text-properties (point-min) (point-max) + gnus-hidden-properties) + )) + (mime/viewer-mode nil nil nil gnus-original-article-buffer + gnus-article-buffer) + ) + +(defun tm-gnus/summary-scroll-down () + "Scroll down one line current article." + (interactive) + (gnus-summary-scroll-up -1) + ) + +(defun tm-gnus/summary-toggle-header (&optional arg) + (interactive "P") + (if tm-gnus/automatic-mime-preview + (let* ((hidden + (save-excursion + (set-buffer gnus-article-buffer) + (text-property-any + (goto-char (point-min)) (search-forward "\n\n") + 'invisible t) + )) + (mime-viewer/redisplay t) + ) + (gnus-summary-select-article hidden t) + ) + (gnus-summary-toggle-header arg)) + ) + +(define-key gnus-summary-mode-map "v" (function tm-gnus/view-message)) +(define-key gnus-summary-mode-map + "\e\r" (function tm-gnus/summary-scroll-down)) +(substitute-key-definition + 'gnus-summary-toggle-header + 'tm-gnus/summary-toggle-header gnus-summary-mode-map) + + +;;; @ for tm-view +;;; + +(defun tm-gnus/content-header-filter () + (goto-char (point-min)) + (mime-preview/cut-header) + (mime-charset-decode-region (point-min)(point-max) + mime/default-coding-system) + (mime/decode-message-header) + ) + +(set-alist 'mime-viewer/content-header-filter-alist + 'gnus-original-article-mode + (function tm-gnus/content-header-filter)) + +(set-alist 'mime-viewer/code-converter-alist + 'gnus-original-article-mode + (function mime-charset-decode-region)) + +(defun mime-viewer/quitting-method-for-sgnus () + (if (not gnus-show-mime) + (mime-viewer/kill-buffer)) + (delete-other-windows) + (gnus-article-show-summary) + (if (or (not gnus-show-mime) + (null gnus-have-all-headers)) + (gnus-summary-select-article nil t) + )) + +(set-alist 'mime-viewer/quitting-method-alist + 'gnus-original-article-mode + (function mime-viewer/quitting-method-for-sgnus)) +(set-alist 'mime-viewer/show-summary-method + 'gnus-original-article-mode + (function mime-viewer/quitting-method-for-sgnus)) + + +;;; @ for tm-edit +;;; + +;; suggested by OKABE Yasuo +;; 1995/11/08 (c.f. [tm ML:1067]) +(defun tm-gnus/insert-article (&optional message) + (interactive) + (let ((message-cite-function 'mime-editor/inserted-message-filter) + (message-reply-buffer gnus-original-article-buffer) + ) + (message-yank-original nil) + )) + +;;; modified by Steven L. Baur +;;; 1995/12/6 (c.f. [tm-en:209]) +(defun mime-editor/attach-to-news-reply-menu () + "Arrange to attach MIME editor's popup menu to VM's" + (if (boundp 'news-reply-menu) + (progn + (setq news-reply-menu (append news-reply-menu + '("---") + mime-editor/popup-menu-for-xemacs)) + (remove-hook 'news-setup-hook + 'mime-editor/attach-to-news-reply-menu) + ))) + +(call-after-loaded + 'tm-edit + (function + (lambda () + (set-alist 'mime-editor/message-inserter-alist + 'message-mode (function tm-gnus/insert-article)) + (if (string-match "XEmacs\\|Lucid" emacs-version) + (add-hook 'news-setup-hook 'mime-editor/attach-to-news-reply-menu) + ) + + (set-alist 'mime-editor/split-message-sender-alist + 'message-mode + (lambda () + (interactive) + (let (message-send-hook + message-sent-message-via) + (message-send) + ))) + ))) + + +;;; @ for tm-partial +;;; + +(defun tm-gnus/partial-preview-function () + (tm-gnus/view-message (gnus-summary-article-number)) + ) + +(call-after-loaded + 'tm-partial + (lambda () + (set-atype 'mime/content-decoding-condition + '((type . "message/partial") + (method . mime-article/grab-message/partials) + (major-mode . gnus-original-article-mode) + (summary-buffer-exp . gnus-summary-buffer) + )) + (set-alist 'tm-partial/preview-article-method-alist + 'gnus-original-article-mode + 'tm-gnus/partial-preview-function) + )) + + +;;; @ article filter +;;; + +(defun tm-gnus/article-reset-variable () + (setq tm-gnus/automatic-mime-preview nil) + ) + +(add-hook 'gnus-article-prepare-hook 'tm-gnus/article-reset-variable) + +(defun tm-gnus/preview-article () + (make-local-variable 'tm:mother-button-dispatcher) + (setq tm:mother-button-dispatcher + (function gnus-article-push-button)) + (let ((mime-viewer/ignored-field-regexp "^:$") + (mime/default-coding-system + (save-excursion + (set-buffer gnus-summary-buffer) + mime/default-coding-system))) + (mime/viewer-mode nil nil nil gnus-original-article-buffer + gnus-article-buffer) + ) + (setq tm-gnus/automatic-mime-preview t) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + +(setq gnus-show-mime-method (function tm-gnus/preview-article)) + +(defun tm-gnus/article-decode-encoded-word () + (character-decode-region (point-min)(point-max) + (save-excursion + (set-buffer gnus-summary-buffer) + mime/default-coding-system)) + (mime/decode-message-header) + (run-hooks 'tm-gnus/article-prepare-hook) + ) + +(setq gnus-decode-encoded-word-method + (function tm-gnus/article-decode-encoded-word)) + + +;;; @ for MULE +;;; + +(defvar gnus-newsgroup-default-coding-system-alist nil) + +(defun gnus-set-newsgroup-default-coding-system (ng cs) + "Define CS as default coding system for newsgroup NG." + (set-alist 'gnus-newsgroup-default-coding-system-alist + (concat "^" (regexp-quote ng) "\\($\\|\\.\\)") + cs)) + +(cond + ((featurep 'mule) + (cond ((boundp 'MULE) + (define-service-coding-system gnus-nntp-service nil *noconv*) + (if (and (boundp 'nntp-server-process) + (processp nntp-server-process) + ) + (set-process-coding-system nntp-server-process *noconv* *noconv*) + ) + ) + (running-xemacs-20 + (if (and (boundp 'nntp-server-process) + (processp nntp-server-process) + ) + (set-process-input-coding-system nntp-server-process 'noconv) + ) + )) + (call-after-loaded + 'nnheader + (lambda () + (defun nnheader-find-file-noselect (filename &optional nowarn rawfile) + (let ((file-coding-system-for-read *noconv*)) + (find-file-noselect filename nowarn rawfile) + )) + (defun nnheader-insert-file-contents-literally + (filename &optional visit beg end replace) + (let ((file-coding-system-for-read *noconv*)) + (insert-file-contents-literally filename visit beg end replace) + )) + )) + ;; Please use Gnus 5.2.10 or later if you use Mule. + (call-after-loaded + 'nnmail + (lambda () + (defun nnmail-find-file (file) + "Insert FILE in server buffer safely. [tm-sgnus.el]" + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((format-alist nil) + (after-insert-file-functions ; for jam-code-guess + (if (memq 'jam-code-guess-after-insert-file-function + after-insert-file-functions) + '(jam-code-guess-after-insert-file-function))) + (file-coding-system-for-read *noconv*)) + (condition-case () + (progn (insert-file-contents file) t) + (file-error nil)))) + )) + (defun tm-gnus/prepare-save-mail-function () + (setq file-coding-system *noconv*) + ) + (add-hook 'nnmail-prepare-save-mail-hook + 'tm-gnus/prepare-save-mail-function) + + (gnus-set-newsgroup-default-coding-system "alt.chinese.text" *hz*) + (gnus-set-newsgroup-default-coding-system "alt.chinese.text.big5" *big5*) + (gnus-set-newsgroup-default-coding-system "han" *euc-kr*) + (and (boundp '*koi8*) + (gnus-set-newsgroup-default-coding-system "relcom" *koi8*)) + )) + + +;;; @ summary filter +;;; + +(defun tm-gnus/decode-summary-from-and-subjects () + (let ((rest gnus-newsgroup-default-coding-system-alist) + cell) + (catch 'tag + (while (setq cell (car rest)) + (if (string-match (car cell) gnus-newsgroup-name) + (throw 'tag + (progn + (make-local-variable 'mime/default-coding-system) + (setq mime/default-coding-system (cdr cell)) + ))) + (setq rest (cdr rest)) + ))) + (mapcar + (lambda (header) + (let ((from (or (mail-header-from header) "")) + (subj (or (mail-header-subject header) "")) + (method (car gnus-current-select-method)) + ) + (if (eq method 'nntp) + (progn + (setq from + (character-decode-string from mime/default-coding-system)) + (setq subj + (character-decode-string subj mime/default-coding-system)) + )) + (mail-header-set-from + header (mime-eword/decode-string from)) + (mail-header-set-subject + header (mime-eword/decode-string subj)) + )) + gnus-newsgroup-headers)) + +(or (boundp 'nnheader-encoded-words-decoding) + (add-hook 'gnus-select-group-hook + 'tm-gnus/decode-summary-from-and-subjects) + ) + + +;;; @ for BBDB +;;; + +(call-after-loaded + 'bbdb + (lambda () + (require 'tm-bbdb) + )) + +(autoload 'tm-bbdb/update-record "tm-bbdb") + +(defun tm-gnus/bbdb-setup () + (if (memq 'bbdb/gnus-update-record gnus-article-prepare-hook) + (progn + (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record) + (add-hook 'gnus-article-display-hook 'tm-bbdb/update-record) + ))) + +(add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t) + +(tm-gnus/bbdb-setup) + + +;;; @ end +;;; + +(provide 'tm-sgnus) + +;;; tm-sgnus.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-tar.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-tar.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,344 @@ +;;; +;;; $Id: tm-tar.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;;; +;;; tm-tar.el +;;; +;;; Internal viewer for +;;; - application/x-tar +;;; - application/x-gzip, type="tar" +;;; - aplication/octet-stream, type="tar" +;;; - aplication/octet-stream, type="tar+gzip" +;;; +;;; by Hiroshi Ueno +;;; modified by Tomohiko Morioka +;;; + +;;; @ required modules +;;; + +(require 'emu) +(require 'tm-view) + +;;; @ constants +;;; + +(defconst tm-tar/list-buffer "*tm-tar/List*") +(defconst tm-tar/view-buffer "*tm-tar/View*") +(defconst tm-tar/file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+") +(defconst tm-tar/popup-menu-title "Action Menu") + +;;; @ variables +;;; + +(defvar tm-tar/tar-program "gtar") +(defvar tm-tar/tar-decompress-arg '("-z")) +(defvar tm-tar/gzip-program "gzip") +(defvar tm-tar/mmencode-program "mmencode") +(defvar tm-tar/uudecode-program "uudecode") + +(defvar tm-tar/popup-menu-items + '(("View File" . tm-tar/view-file) + ("Key Help" . tm-tar/helpful-message) + ("Quit tm-tar Mode" . exit-recursive-edit) + )) + +(cond ((string-match "XEmacs\\|Lucid" emacs-version) + (defvar tm-tar/popup-menu + (cons tm-tar/popup-menu-title + (mapcar (function + (lambda (item) + (vector (car item)(cdr item) t) + )) + tm-tar/popup-menu-items))) + + (defun tm-tar/mouse-button-2 (event) + (popup-menu tm-tar/popup-menu) + ) + ) + ((>= emacs-major-version 19) + (defun tm-tar/mouse-button-2 (event) + (let ((menu + (cons tm-tar/popup-menu-title + (list (cons "Menu Items" tm-tar/popup-menu-items)) + ))) + (let ((func (x-popup-menu event menu))) + (if func + (funcall func) + )) + )) + )) + +(defvar tm-tar/tar-mode-map nil) +(if tm-tar/tar-mode-map + nil + (setq tm-tar/tar-mode-map (make-keymap)) + (suppress-keymap tm-tar/tar-mode-map) + (define-key tm-tar/tar-mode-map "\C-c" 'exit-recursive-edit) + (define-key tm-tar/tar-mode-map "q" 'exit-recursive-edit) + (define-key tm-tar/tar-mode-map "n" 'tm-tar/next-line) + (define-key tm-tar/tar-mode-map " " 'tm-tar/next-line) + (define-key tm-tar/tar-mode-map "\C-m" 'tm-tar/next-line) + (define-key tm-tar/tar-mode-map "p" 'tm-tar/previous-line) + (define-key tm-tar/tar-mode-map "\177" 'tm-tar/previous-line) + (define-key tm-tar/tar-mode-map "\C-\M-m" 'tm-tar/previous-line) + (define-key tm-tar/tar-mode-map "v" 'tm-tar/view-file) + (define-key tm-tar/tar-mode-map "\C-h" 'Helper-help) + (define-key tm-tar/tar-mode-map "?" 'tm-tar/helpful-message) + (if mouse-button-2 + (define-key tm-tar/tar-mode-map + mouse-button-2 'tm:button-dispatcher) + ) + ) + +;;; @@ tm-tar mode functions +;;; + +(defun tm-tar/tar-mode (&optional prev-buf) + "Major mode for listing the contents of a tar archive file." + (unwind-protect + (let ((buffer-read-only t) + (mode-name "tm-tar") + (mode-line-buffer-identification '("%17b")) + ) + (goto-char (point-min)) + (tm-tar/move-to-filename) + (catch 'tm-tar/tar-mode (tm-tar/command-loop)) + ) + (if prev-buf + (switch-to-buffer prev-buf) + ) + )) + +(defun tm-tar/command-loop () + (let ((old-local-map (current-local-map)) + ) + (unwind-protect + (progn + (use-local-map tm-tar/tar-mode-map) + (tm-tar/helpful-message) + (recursive-edit) + ) + (save-excursion + (use-local-map old-local-map) + )) + )) + +(defun tm-tar/next-line () + (interactive) + (next-line 1) + (tm-tar/move-to-filename) + ) + +(defun tm-tar/previous-line () + (interactive) + (previous-line 1) + (tm-tar/move-to-filename) + ) + +(defun tm-tar/view-file () + (interactive) + (let ((name (tm-tar/get-filename)) + ) + (save-excursion + (switch-to-buffer tm-tar/view-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (message "Reading a file from an archive. Please wait...") + (apply 'call-process tm-tar/tar-program + nil t nil (append tm-tar/view-args (list name))) + (goto-char (point-min)) + ) + (view-buffer tm-tar/view-buffer) + )) + +(defun tm-tar/get-filename () + (let (eol) + (save-excursion + (end-of-line) + (setq eol (point)) + (beginning-of-line) + (save-excursion + (if (re-search-forward "^d" eol t) + (error "Cannot view a directory")) + ) + (if (re-search-forward tm-tar/file-search-regexp eol t) + (progn (let ((beg (point)) + ) + (skip-chars-forward "^ \n") + (buffer-substring beg (point)) + )) + (error "No file on this line") + )) + )) + +(defun tm-tar/move-to-filename () + (let ((eol (progn (end-of-line) (point))) + ) + (beginning-of-line) + (re-search-forward tm-tar/file-search-regexp eol t) + )) + +(defun tm-tar/set-properties () + (if mouse-button-2 + (let ((beg (point-min)) + (end (point-max)) + ) + (goto-char beg) + (save-excursion + (while (re-search-forward tm-tar/file-search-regexp end t) + (tm:add-button (point) + (progn + (end-of-line) + (point)) + 'tm-tar/view-file) + )) + ))) + +(defun tm-tar/helpful-message () + (interactive) + (message "Type %s, %s, %s, %s, %s, %s." + (substitute-command-keys "\\[Helper-help] for help") + (substitute-command-keys "\\[tm-tar/helpful-message] for keys") + (substitute-command-keys "\\[tm-tar/next-line] to next") + (substitute-command-keys "\\[tm-tar/previous-line] to prev") + (substitute-command-keys "\\[tm-tar/view-file] to view") + (substitute-command-keys "\\[exit-recursive-edit] to quit") + )) + +(defun tm-tar/y-or-n-p (prompt) + (prog1 + (y-or-n-p prompt) + (message "") + )) + +;;; @@ tar message decoder +;; + +(defun mime/decode-message/tar (beg end cal) + (if (tm-tar/y-or-n-p "Do you want to enter tm-tar mode? ") + (let ((coding (cdr (assoc 'encoding cal))) + (cur-buf (current-buffer)) + (tm-tar/tar-file-name (expand-file-name (concat (make-temp-name + (expand-file-name "tm" mime/tmp-dir)) ".tar"))) + (tm-tar/tmp-file-name (expand-file-name (make-temp-name + (expand-file-name "tm" mime/tmp-dir)))) + new-buf + ) + (find-file tm-tar/tmp-file-name) + (setq new-buf (current-buffer)) + (setq buffer-read-only nil) + (erase-buffer) + (save-excursion + (set-buffer cur-buf) + (goto-char beg) + (re-search-forward "^$") + (append-to-buffer new-buf (+ (match-end 0) 1) end) + ) + (if (member coding mime-viewer/uuencode-encoding-name-list) + (progn + (goto-char (point-min)) + (if (re-search-forward "^begin [0-9]+ " nil t) + (progn + (kill-line) + (insert tm-tar/tar-file-name) + ) + (progn + (set-buffer-modified-p nil) + (kill-buffer new-buf) + (error "uuencode file signature was not found") + )))) + (save-buffer) + (kill-buffer new-buf) + (message "Listing the contents of an archive. Please wait...") + (cond ((string-equal coding "base64") + (call-process tm-tar/mmencode-program nil nil nil "-u" + "-o" tm-tar/tar-file-name tm-tar/tmp-file-name) + ) + ((string-equal coding "quoted-printable") + (call-process tm-tar/mmencode-program nil nil nil "-u" "-q" + "-o" tm-tar/tar-file-name tm-tar/tmp-file-name) + ) + ((member coding mime-viewer/uuencode-encoding-name-list) + (call-process tm-tar/uudecode-program nil nil nil + tm-tar/tmp-file-name) + ) + (t + (copy-file tm-tar/tmp-file-name tm-tar/tar-file-name t) + )) + (delete-file tm-tar/tmp-file-name) + (setq tm-tar/list-args (list "-tvf" tm-tar/tar-file-name)) + (setq tm-tar/view-args (list "-xOf" tm-tar/tar-file-name)) + (if (eq 0 (call-process tm-tar/gzip-program + nil nil nil "-t" tm-tar/tar-file-name)) + (progn + (setq tm-tar/list-args + (append tm-tar/tar-decompress-arg tm-tar/list-args)) + (setq tm-tar/view-args + (append tm-tar/tar-decompress-arg tm-tar/view-args)) + )) + (switch-to-buffer tm-tar/view-buffer) + (switch-to-buffer tm-tar/list-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (apply 'call-process tm-tar/tar-program + nil t nil tm-tar/list-args) + (if mouse-button-2 + (progn + (make-local-variable 'tm:mother-button-dispatcher) + (setq tm:mother-button-dispatcher 'tm-tar/mouse-button-2) + )) + (tm-tar/set-properties) + (tm-tar/tar-mode mime::article/preview-buffer) + (kill-buffer tm-tar/view-buffer) + (kill-buffer tm-tar/list-buffer) + (delete-file tm-tar/tar-file-name) + ) + )) + +;;; @@ program/buffer coding system +;;; + +(cond ((boundp 'MULE) + (define-program-coding-system tm-tar/view-buffer nil *autoconv*) + ) + ((boundp 'NEMACS) + (define-program-kanji-code tm-tar/view-buffer nil 1) + )) + +;;; @@ message types to use tm-tar +;;; + +(set-atype 'mime/content-decoding-condition + '((type . "application/octet-stream") + (method . mime/decode-message/tar) + (mode . "play") ("type" . "tar") + )) + +(set-atype 'mime/content-decoding-condition + '((type . "application/octet-stream") + (method . mime/decode-message/tar) + (mode . "play") ("type" . "tar+gzip") + )) + +(set-atype 'mime/content-decoding-condition + '((type . "application/x-gzip") + (method . mime/decode-message/tar) + (mode . "play") ("type" . "tar") + )) + +(set-atype 'mime/content-decoding-condition + '((type . "application/x-tar") + (method . mime/decode-message/tar) + (mode . "play") + )) + +;;; @ end +;;; + +(provide 'tm-tar) + +;;; Local Variables: +;;; mode: emacs-lisp +;;; mode: outline-minor +;;; outline-regexp: ";;; @+\\|(......" +;;; End: diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-text.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-text.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,116 @@ +;;; +;;; tm-text.el --- a content filter module of tm-view to display +;;; text/plain, text/richtext and text/enriched +;;; in Emacs buffers +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Version: +;;; $Id: tm-text.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;;; Keywords: mail, news, MIME, multimedia, text +;;; +;;; This file is part of tm (Tools for MIME). +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with This program. If not, write to the Free Software +;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; Code: + +;;; @ code conversion +;;; + +(defvar mime-viewer/code-converter-alist + '((mime/show-message-mode . mime-charset/decode-buffer) + (mime/temporary-message-mode . mime-charset/decode-buffer) + (t . mime-charset/maybe-decode-buffer) + )) + +(defun mime-charset/decode-buffer (charset &optional encoding) + (decode-mime-charset-region (point-min)(point-max) + (or charset default-mime-charset)) + ) + +(defun mime-charset/maybe-decode-buffer (charset &optional encoding) + (or (member encoding '(nil "7bit" "8bit" "binary")) + (mime-charset/decode-buffer charset) + )) + +(defun mime-preview/decode-text-buffer (charset encoding) + (mime-decode-region (point-min) (point-max) encoding) + (let* ((mode mime::preview/original-major-mode) + (m (or (save-excursion + (set-buffer mime::preview/article-buffer) + mime::article/code-converter) + (cdr (or (assq mode mime-viewer/code-converter-alist) + (assq t mime-viewer/code-converter-alist))) + )) + ) + (and (functionp m) + (funcall m charset encoding) + ))) + + +;;; @ content filters for tm-view +;;; + +(defun mime-preview/filter-for-text/plain (ctype params encoding) + (mime-preview/decode-text-buffer (cdr (assoc "charset" params)) encoding) + (goto-char (point-max)) + (if (not (eq (char-after (1- (point))) ?\n)) + (insert "\n") + ) + (if browse-url-browser-function + (progn + (goto-char (point-min)) + (while (re-search-forward tm:URL-regexp nil t) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (tm:add-button beg end + (function tm:browse-url) + (list (buffer-substring beg end)))) + ))) + (run-hooks 'mime-viewer/plain-text-preview-hook) + ) + +(defun mime-preview/filter-for-text/richtext (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (charset (cdr (assoc "charset" params))) + (beg (point-min)) + ) + (remove-text-properties beg (point-max) '(face nil)) + (mime-preview/decode-text-buffer charset encoding) + (richtext-decode beg (point-max)) + )) + +(defun mime-preview/filter-for-text/enriched (ctype params encoding) + (let* ((mode mime::preview/original-major-mode) + (m (assq mode mime-viewer/code-converter-alist)) + (charset (cdr (assoc "charset" params))) + (beg (point-min)) + ) + (remove-text-properties beg (point-max) '(face nil)) + (mime-preview/decode-text-buffer charset encoding) + (enriched-decode beg (point-max)) + )) + + +;;; @ end +;;; + +(provide 'tm-text) + +;;; tm-text.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-view.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-view.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,1175 @@ +;;; tm-view.el --- interactive MIME viewer for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1994/7/13 (1994/8/31 obsolete tm-body.el) +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: mail, news, MIME, multimedia + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'tl-str) +(require 'tl-list) +(require 'tl-atype) +(require 'tl-misc) +(require 'std11) +(require 'mel) +(require 'tm-ew-d) +(require 'tm-def) +(require 'tm-parse) +(require 'tm-text) + + +;;; @ version +;;; + +(defconst mime-viewer/RCS-ID + "$Id: tm-view.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $") + +(defconst mime-viewer/version (get-version-string mime-viewer/RCS-ID)) +(defconst mime/viewer-version mime-viewer/version) + + +;;; @ variables +;;; + +(defvar mime/content-decoding-condition + '(((type . "text/plain") + (method "tm-plain" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "text/html") + (method "tm-html" nil 'file 'type 'encoding 'mode 'name) + (mode . "play") + ) + ((type . "text/x-rot13-47") + (method . mime-article/decode-caesar) + (mode . "play") + ) + ((type . "audio/basic") + (method "tm-au" nil 'file 'type 'encoding 'mode 'name) + (mode . "play") + ) + + ((type . "image/jpeg") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "image/gif") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "image/tiff") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "image/x-tiff") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "image/x-xbm") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "image/x-pic") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "image/x-mag") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + + ((type . "video/mpeg") + (method "tm-mpeg" nil 'file 'type 'encoding 'mode 'name) + (mode . "play") + ) + + ((type . "application/postscript") + (method "tm-ps" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + ((type . "application/octet-stream") + (method "tm-file" nil 'file 'type 'encoding 'mode 'name) + (mode "play" "print") + ) + + ;;((type . "message/external-body") + ;; (method "xterm" nil + ;; "-e" "showexternal" + ;; 'file '"access-type" '"name" '"site" '"directory")) + ((type . "message/rfc822") + (method . mime-article/view-message/rfc822) + (mode . "play") + ) + ((type . "message/partial") + (method . mime-article/decode-message/partial) + (mode . "play") + ) + + ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file) + (mode . "play") + ) + ((method "tm-file" nil 'file 'type 'encoding 'mode 'name) + (mode . "extract") + ) + )) + +(defvar mime-viewer/childrens-header-showing-Content-Type-list + '("message/rfc822" "message/news")) + +(defvar mime-viewer/default-showing-Content-Type-list + '("text/plain" nil "text/richtext" "text/enriched" + "text/x-latex" "application/x-latex" + "message/delivery-status" + "application/pgp" "text/x-pgp" + "application/octet-stream" + "application/x-selection" "application/x-comment")) + +(defvar mime-viewer/content-button-ignored-ctype-list + '("application/x-selection")) + +(defvar mime-viewer/content-button-visible-ctype-list + '("application/pgp")) + +(defvar mime-viewer/uuencode-encoding-name-list '("x-uue" "x-uuencode")) + +(defvar mime-viewer/ignored-field-list + '(".*Received" ".*Path" ".*Id" "References" + "Replied" "Errors-To" + "Lines" "Sender" ".*Host" "Xref" + "Content-Type" "Precedence" + "Status" "X-VM-.*") + "All fields that match this list will be hidden in MIME preview buffer. +Each elements are regexp of field-name. [tm-view.el]") + +(defvar mime-viewer/ignored-field-regexp + (concat "^" + (apply (function regexp-or) mime-viewer/ignored-field-list) + ":")) + +(defvar mime-viewer/visible-field-list + '("Dnas.*" "Message-Id") + "All fields that match this list will be displayed in MIME preview buffer. +Each elements are regexp of field-name. [tm-view.el]") + +(defvar mime-viewer/visible-field-regexp + (concat "^" + (apply (function regexp-or) mime-viewer/visible-field-list) + ":")) + +(defvar mime-viewer/redisplay nil) + +(defvar mime-viewer/announcement-for-message/partial + (if (and (>= emacs-major-version 19) window-system) + "\ +\[[ This is message/partial style split message. ]] +\[[ Please press `v' key in this buffer ]] +\[[ or click here by mouse button-2. ]]" + "\ +\[[ This is message/partial style split message. ]] +\[[ Please press `v' key in this buffer. ]]" + )) + + +;;; @@ predicate functions +;;; + +(defun mime-viewer/header-visible-p (rcnum cinfo &optional ctype) + (or (null rcnum) + (progn + (setq ctype + (mime::content-info/type + (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo) + )) + (member ctype mime-viewer/childrens-header-showing-Content-Type-list) + ))) + +(defun mime-viewer/body-visible-p (rcnum cinfo &optional ctype) + (let (ccinfo) + (or ctype + (setq ctype + (mime::content-info/type + (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo)) + )) + ) + (and (member ctype mime-viewer/default-showing-Content-Type-list) + (if (string-equal ctype "application/octet-stream") + (progn + (or ccinfo + (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo)) + ) + (member (mime::content-info/encoding ccinfo) + '(nil "7bit" "8bit")) + ) + t)) + )) + + +;;; @@ content button +;;; + +(defun mime-preview/insert-content-button + (rcnum cinfo ctype params subj encoding) + (save-restriction + (narrow-to-region (point)(point)) + (let ((access-type (assoc "access-type" params)) + (charset (assoc "charset" params)) + (num (or (assoc-value "x-part-number" params) + (if (consp rcnum) + (mapconcat (function + (lambda (num) + (format "%s" (1+ num)) + )) + (reverse rcnum) ".") + "0")) + )) + (cond (access-type + (let ((server (assoc "server" params))) + (setq access-type (cdr access-type)) + (if server + (insert (format "[%s %s ([%s] %s)]\n" num subj + access-type (cdr server))) + (let ((site (assoc-value "site" params)) + (dir (assoc-value "directory" params)) + ) + (insert (format "[%s %s ([%s] %s:%s)]\n" num subj + access-type site dir)) + ))) + ) + (t + (insert (concat "[" num " " subj)) + (let ((rest + (if (setq charset (cdr charset)) + (if encoding + (format " <%s; %s (%s)>]\n" + ctype charset encoding) + (format " <%s; %s>]\n" ctype charset) + ) + (format " <%s>]\n" ctype) + ))) + (if (>= (+ (current-column)(length rest))(window-width)) + (setq rest (concat "\n\t" rest)) + ) + (insert rest) + )))) + (tm:add-button (point-min)(1- (point-max)) + (function mime-viewer/play-content)) + )) + +(defun mime-preview/default-content-button-function + (rcnum cinfo ctype params subj encoding) + (if (and (consp rcnum) + (not (member + ctype + mime-viewer/content-button-ignored-ctype-list))) + (mime-preview/insert-content-button + rcnum cinfo ctype params subj encoding) + )) + +(defvar mime-preview/content-button-function + (function mime-preview/default-content-button-function)) + + +;;; @@ content header filter +;;; + +(defun mime-preview/cut-header () + (goto-char (point-min)) + (while (and + (re-search-forward mime-viewer/ignored-field-regexp nil t) + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (name (buffer-substring beg end)) + ) + (if (not (string-match mime-viewer/visible-field-regexp name)) + (delete-region + beg + (save-excursion + (and + (re-search-forward "^\\([^ \t]\\|$\\)" nil t) + (match-beginning 0) + ))) + ) + t))) + ) + +(defun mime-viewer/default-content-header-filter () + (mime-preview/cut-header) + (mime/decode-message-header) + ) + +(defvar mime-viewer/content-header-filter-alist nil) + + +;;; @@ content filter +;;; + +(defvar mime-viewer/content-filter-alist + '(("text/enriched" . mime-preview/filter-for-text/enriched) + ("text/richtext" . mime-preview/filter-for-text/richtext) + (t . mime-preview/filter-for-text/plain) + )) + + +;;; @@ content separator +;;; + +(defun mime-preview/default-content-separator (rcnum cinfo ctype params subj) + (if (and (not (mime-viewer/header-visible-p rcnum cinfo ctype)) + (not (mime-viewer/body-visible-p rcnum cinfo ctype)) + ) + (progn + (goto-char (point-max)) + (insert "\n") + ))) + + +;;; @@ buffer local variables +;;; + +;; for XEmacs +(defvar mime::article/preview-buffer nil) +(defvar mime::article/code-converter nil) +(defvar mime::preview/article-buffer nil) + +(make-variable-buffer-local 'mime::article/content-info) +(make-variable-buffer-local 'mime::article/preview-buffer) +(make-variable-buffer-local 'mime::article/code-converter) + +(make-variable-buffer-local 'mime::preview/mother-buffer) +(make-variable-buffer-local 'mime::preview/content-list) +(make-variable-buffer-local 'mime::preview/article-buffer) +(make-variable-buffer-local 'mime::preview/original-major-mode) +(make-variable-buffer-local 'mime::preview/original-window-configuration) + + +;;; @@ quitting method +;;; + +(defvar mime-viewer/quitting-method-alist + '((mime/show-message-mode + . mime-viewer/quitting-method-for-mime/show-message-mode))) + +(defvar mime-viewer/over-to-previous-method-alist nil) +(defvar mime-viewer/over-to-next-method-alist nil) + +(defvar mime-viewer/show-summary-method nil) + + +;;; @@ following method +;;; + +(defvar mime-viewer/following-method-alist nil) + + +;;; @@ X-Face +;;; + +;; hack from Gnus 5.0.4. + +(defvar mime-viewer/x-face-to-pbm-command + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm") + +(defvar mime-viewer/x-face-command + (concat mime-viewer/x-face-to-pbm-command + " | xv -quit -") + "String to be executed to display an X-Face field. +The command will be executed in a sub-shell asynchronously. +The compressed face will be piped to this command.") + +(defun mime-viewer/x-face-function () + "Function to display X-Face field. You can redefine to customize." + ;; 1995/10/12 (c.f. tm-eng:130) + ;; fixed by Eric Ding + (save-restriction + (narrow-to-region (point-min) (re-search-forward "^$" nil t)) + ;; end + (goto-char (point-min)) + (if (re-search-forward "^X-Face:[ \t]*" nil t) + (let ((beg (match-end 0)) + (end (std11-field-end)) + ) + (call-process-region beg end "sh" nil 0 nil + "-c" mime-viewer/x-face-command) + )))) + + +;;; @@ utility +;;; + +(defun mime-preview/get-original-major-mode () + (if mime::preview/mother-buffer + (save-excursion + (set-buffer mime::preview/mother-buffer) + (mime-preview/get-original-major-mode) + ) + mime::preview/original-major-mode)) + + +;;; @ data structures +;;; + +;;; @@ preview-content-info +;;; + +(define-structure mime::preview-content-info + point-min point-max buffer content-info) + + +;;; @ buffer setup +;;; + +(defun mime-viewer/setup-buffer (&optional ctl encoding ibuf obuf) + (if ibuf + (progn + (get-buffer ibuf) + (set-buffer ibuf) + )) + (or mime-viewer/redisplay + (setq mime::article/content-info (mime/parse-message ctl encoding)) + ) + (let ((ret (mime-viewer/make-preview-buffer obuf))) + (setq mime::article/preview-buffer (car ret)) + ret)) + +(defun mime-viewer/make-preview-buffer (&optional obuf) + (let* ((cinfo mime::article/content-info) + (pcl (mime/flatten-content-info cinfo)) + (dest (make-list (length pcl) nil)) + (the-buf (current-buffer)) + (mode major-mode) + ) + (or obuf + (setq obuf (concat "*Preview-" (buffer-name the-buf) "*"))) + (set-buffer (get-buffer-create obuf)) + (setq buffer-read-only nil) + (widen) + (erase-buffer) + (setq mime::preview/article-buffer the-buf) + (setq mime::preview/original-major-mode mode) + (setq major-mode 'mime/viewer-mode) + (setq mode-name "MIME-View") + (let ((drest dest)) + (while pcl + (setcar drest + (mime-preview/display-content (car pcl) cinfo the-buf obuf)) + (setq pcl (cdr pcl) + drest (cdr drest)) + )) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (set-buffer the-buf) + (list obuf dest) + )) + +(defun mime-preview/display-content (content cinfo ibuf obuf) + (let* ((beg (mime::content-info/point-min content)) + (end (mime::content-info/point-max content)) + (ctype (mime::content-info/type content)) + (params (mime::content-info/parameters content)) + (encoding (mime::content-info/encoding content)) + (rcnum (mime::content-info/rcnum content)) + he e nb ne subj) + (set-buffer ibuf) + (goto-char beg) + (setq he (if (re-search-forward "^$" nil t) + (1+ (match-end 0)) + end)) + (if (> he end) + (setq he end) + ) + (save-restriction + (narrow-to-region beg end) + (setq subj + (mime-eword/decode-string + (mime-article/get-subject params encoding))) + ) + (set-buffer obuf) + (setq nb (point)) + (narrow-to-region nb nb) + (funcall mime-preview/content-button-function + rcnum cinfo ctype params subj encoding) + (if (mime-viewer/header-visible-p rcnum cinfo ctype) + (mime-preview/display-header beg he) + ) + (if (and (null rcnum) + (member + ctype mime-viewer/content-button-visible-ctype-list)) + (save-excursion + (goto-char (point-max)) + (mime-preview/insert-content-button + rcnum cinfo ctype params subj encoding) + )) + (cond ((mime-viewer/body-visible-p rcnum cinfo ctype) + (mime-preview/display-body he end + rcnum cinfo ctype params subj encoding) + ) + ((equal ctype "message/partial") + (mime-preview/display-message/partial) + ) + ((and (null rcnum) + (null (mime::content-info/children cinfo)) + ) + (goto-char (point-max)) + (mime-preview/insert-content-button + rcnum cinfo ctype params subj encoding) + )) + (mime-preview/default-content-separator rcnum cinfo ctype params subj) + (prog1 + (progn + (setq ne (point-max)) + (widen) + (mime::preview-content-info/create nb (1- ne) ibuf content) + ) + (goto-char ne) + ))) + +(defun mime-preview/display-header (beg end) + (save-restriction + (narrow-to-region (point)(point)) + (insert-buffer-substring mime::preview/article-buffer beg end) + (let ((f (cdr (assq mime::preview/original-major-mode + mime-viewer/content-header-filter-alist)))) + (if (functionp f) + (funcall f) + (mime-viewer/default-content-header-filter) + )) + (run-hooks 'mime-viewer/content-header-filter-hook) + )) + +(defun mime-preview/display-body (beg end + rcnum cinfo ctype params subj encoding) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (insert-buffer-substring mime::preview/article-buffer beg end) + (let ((f (cdr (or (assoc ctype mime-viewer/content-filter-alist) + (assq t mime-viewer/content-filter-alist))))) + (and (functionp f) + (funcall f ctype params encoding) + ) + ))) + +(defun mime-preview/display-message/partial () + (save-restriction + (goto-char (point-max)) + (if (not (search-backward "\n\n" nil t)) + (insert "\n") + ) + (let ((be (point-max))) + (narrow-to-region be be) + (insert mime-viewer/announcement-for-message/partial) + (tm:add-button (point-min)(point-max) + (function mime-viewer/play-content)) + ))) + +(defun mime-article/get-uu-filename (param &optional encoding) + (if (member (or encoding + (cdr (assq 'encoding param)) + ) + mime-viewer/uuencode-encoding-name-list) + (save-excursion + (or (if (re-search-forward "^begin [0-9]+ " nil t) + (if (looking-at ".+$") + (buffer-substring (match-beginning 0)(match-end 0)) + )) + "")) + )) + +(defun mime-article/get-subject (param &optional encoding) + (or (std11-find-field-body '("Content-Description" "Subject")) + (let (ret) + (if (or (and (setq ret (mime/Content-Disposition)) + (setq ret (assoc "filename" (cdr ret))) + ) + (setq ret (assoc "name" param)) + (setq ret (assoc "x-name" param)) + ) + (std11-strip-quoted-string (cdr ret)) + )) + (mime-article/get-uu-filename param encoding) + "")) + + +;;; @ content information +;;; + +(defun mime-article/point-content-number (p &optional cinfo) + (or cinfo + (setq cinfo mime::article/content-info) + ) + (let ((b (mime::content-info/point-min cinfo)) + (e (mime::content-info/point-max cinfo)) + (c (mime::content-info/children cinfo)) + ) + (if (and (<= b p)(<= p e)) + (or (let (co ret (sn 0)) + (catch 'tag + (while c + (setq co (car c)) + (setq ret (mime-article/point-content-number p co)) + (cond ((eq ret t) (throw 'tag (list sn))) + (ret (throw 'tag (cons sn ret))) + ) + (setq c (cdr c)) + (setq sn (1+ sn)) + ))) + t)))) + +(defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo) + (or cinfo + (setq cinfo mime::article/content-info) + ) + (find-if (function + (lambda (ci) + (equal (mime::content-info/rcnum ci) rcnum) + )) + (mime/flatten-content-info cinfo) + )) + +(defun mime-article/cnum-to-cinfo (cn &optional cinfo) + (or cinfo + (setq cinfo mime::article/content-info) + ) + (if (eq cn t) + cinfo + (let ((sn (car cn))) + (if (null sn) + cinfo + (let ((rc (nth sn (mime::content-info/children cinfo)))) + (if rc + (mime-article/cnum-to-cinfo (cdr cn) rc) + )) + )))) + +(defun mime/flatten-content-info (&optional cinfo) + (or cinfo + (setq cinfo mime::article/content-info) + ) + (let ((dest (list cinfo)) + (rcl (mime::content-info/children cinfo)) + ) + (while rcl + (setq dest (nconc dest (mime/flatten-content-info (car rcl)))) + (setq rcl (cdr rcl)) + ) + dest)) + +(defun mime-preview/point-pcinfo (p &optional pcl) + (or pcl + (setq pcl mime::preview/content-list) + ) + (catch 'tag + (let ((r pcl) cell) + (while r + (setq cell (car r)) + (if (and (<= (mime::preview-content-info/point-min cell) p) + (<= p (mime::preview-content-info/point-max cell)) + ) + (throw 'tag cell) + ) + (setq r (cdr r)) + )) + (car (last pcl)) + )) + + +;;; @ MIME viewer mode +;;; + +(defconst mime-viewer/menu-title "MIME-View") +(defconst mime-viewer/menu-list + '((up "Move to upper content" mime-viewer/up-content) + (previous "Move to previous content" mime-viewer/previous-content) + (next "Move to next content" mime-viewer/next-content) + (scroll-down "Scroll to previous content" mime-viewer/scroll-down-content) + (scroll-up "Scroll to next content" mime-viewer/scroll-up-content) + (play "Play Content" mime-viewer/play-content) + (extract "Extract Content" mime-viewer/extract-content) + (print "Print" mime-viewer/print-content) + (x-face "Show X Face" mime-viewer/display-x-face) + ) + "Menu for MIME Viewer") + +(if running-xemacs + (progn + (defvar mime-viewer/xemacs-popup-menu + (cons mime-viewer/menu-title + (mapcar (function + (lambda (item) + (vector (nth 1 item)(nth 2 item) t) + )) + mime-viewer/menu-list))) + (defun mime-viewer/xemacs-popup-menu (event) + "Popup the menu in the MIME Viewer buffer" + (interactive "e") + (select-window (event-window event)) + (set-buffer (event-buffer event)) + (popup-menu 'mime-viewer/xemacs-popup-menu)) + )) + +(defun mime-viewer/define-keymap (&optional mother) + (let ((mime/viewer-mode-map (if mother + (copy-keymap mother) + (make-keymap)))) + (suppress-keymap mime/viewer-mode-map) + (define-key mime/viewer-mode-map + "u" (function mime-viewer/up-content)) + (define-key mime/viewer-mode-map + "p" (function mime-viewer/previous-content)) + (define-key mime/viewer-mode-map + "n" (function mime-viewer/next-content)) + (define-key mime/viewer-mode-map + " " (function mime-viewer/scroll-up-content)) + (define-key mime/viewer-mode-map + "\M- " (function mime-viewer/scroll-down-content)) + (define-key mime/viewer-mode-map + "\177" (function mime-viewer/scroll-down-content)) + (define-key mime/viewer-mode-map + "\C-m" (function mime-viewer/next-line-content)) + (define-key mime/viewer-mode-map + "\C-\M-m" (function mime-viewer/previous-line-content)) + (define-key mime/viewer-mode-map + "v" (function mime-viewer/play-content)) + (define-key mime/viewer-mode-map + "e" (function mime-viewer/extract-content)) + (define-key mime/viewer-mode-map + "\C-c\C-p" (function mime-viewer/print-content)) + (define-key mime/viewer-mode-map + "x" (function mime-viewer/display-x-face)) + (define-key mime/viewer-mode-map + "a" (function mime-viewer/follow-content)) + (define-key mime/viewer-mode-map + "q" (function mime-viewer/quit)) + (define-key mime/viewer-mode-map + "h" (function mime-viewer/show-summary)) + (define-key mime/viewer-mode-map + "\C-c\C-x" (function mime-viewer/kill-buffer)) + (define-key mime/viewer-mode-map + "<" (function beginning-of-buffer)) + (define-key mime/viewer-mode-map + ">" (function end-of-buffer)) + (define-key mime/viewer-mode-map + "?" (function describe-mode)) + (if mouse-button-2 + (define-key mime/viewer-mode-map + mouse-button-2 (function tm:button-dispatcher)) + ) + (cond (running-xemacs + (define-key mime/viewer-mode-map + mouse-button-3 (function mime-viewer/xemacs-popup-menu)) + ) + ((>= emacs-major-version 19) + (define-key mime/viewer-mode-map [menu-bar mime-view] + (cons mime-viewer/menu-title + (make-sparse-keymap mime-viewer/menu-title))) + (mapcar (function + (lambda (item) + (define-key mime/viewer-mode-map + (vector 'menu-bar 'mime-view (car item)) + (cons (nth 1 item)(nth 2 item)) + ) + )) + (reverse mime-viewer/menu-list) + ) + )) + (use-local-map mime/viewer-mode-map) + (run-hooks 'mime-viewer/define-keymap-hook) + )) + +(defun mime/viewer-mode (&optional mother ctl encoding ibuf obuf + mother-keymap) + "Major mode for viewing MIME message. + +Here is a list of the standard keys for mime/viewer-mode. + +key feature +--- ------- + +u Move to upper content +p Move to previous content +n Move to next content +SPC Scroll up or move to next content +M-SPC Scroll down or move to previous content +DEL Scroll down or move to previous content +RET Move to next line +M-RET Move to previous line +v Decode current content as `play mode' +e Decode current content as `extract mode' +C-c C-p Decode current content as `print mode' +a Followup to current content. +x Display X-Face +q Quit +button-2 Move to point under the mouse cursor + and decode current content as `play mode' +" + (interactive) + (let ((buf (get-buffer mime/output-buffer-name))) + (if buf + (save-excursion + (set-buffer buf) + (erase-buffer) + ))) + (let ((ret (mime-viewer/setup-buffer ctl encoding ibuf obuf)) + (win-conf (current-window-configuration)) + ) + (prog1 + (switch-to-buffer (car ret)) + (setq mime::preview/original-window-configuration win-conf) + (if mother + (progn + (setq mime::preview/mother-buffer mother) + )) + (mime-viewer/define-keymap mother-keymap) + (setq mime::preview/content-list (nth 1 ret)) + (goto-char + (let ((ce (mime::preview-content-info/point-max + (car mime::preview/content-list) + )) + e) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (setq e (match-end 0)) + (if (<= e ce) + e + ce))) + (run-hooks 'mime/viewer-mode-hook) + ))) + +(defun mime-preview/point-content-number (point) + (save-window-excursion + (let ((pc (mime-preview/point-pcinfo (point))) + cinfo) + (switch-to-buffer (mime::preview-content-info/buffer pc)) + (setq cinfo (mime::preview-content-info/content-info pc)) + (mime-article/point-content-number (mime::content-info/point-min cinfo)) + ))) + +(defun mime-preview/cinfo-to-pcinfo (cinfo) + (let ((rpcl mime::preview/content-list) cell) + (catch 'tag + (while rpcl + (setq cell (car rpcl)) + (if (eq cinfo (mime::preview-content-info/content-info cell)) + (throw 'tag cell) + ) + (setq rpcl (cdr rpcl)) + )))) + +(autoload 'mime-preview/decode-content "tm-play") + +(defvar mime-viewer/decoding-mode "play" "MIME body decoding mode") + +(defun mime-viewer/play-content () + (interactive) + (let ((mime-viewer/decoding-mode "play")) + (mime-preview/decode-content) + )) + +(defun mime-viewer/extract-content () + (interactive) + (let ((mime-viewer/decoding-mode "extract")) + (mime-preview/decode-content) + )) + +(defun mime-viewer/print-content () + (interactive) + (let ((mime-viewer/decoding-mode "print")) + (mime-preview/decode-content) + )) + +(defun mime-viewer/follow-content () + (interactive) + (let ((root-cinfo + (mime::preview-content-info/content-info + (car mime::preview/content-list))) + pc p-beg p-end cinfo rcnum) + (let ((rest mime::preview/content-list) + b e cell len rc) + (if (catch 'tag + (while (setq cell (car rest)) + (setq b (mime::preview-content-info/point-min cell) + e (mime::preview-content-info/point-max cell)) + (setq rest (cdr rest)) + (if (and (<= b (point))(<= (point) e)) + (throw 'tag cell) + ) + )) + (progn + (setq pc cell + cinfo (mime::preview-content-info/content-info pc) + rcnum (mime::content-info/rcnum cinfo)) + (setq len (length rcnum)) + (setq p-beg (mime::preview-content-info/point-min pc) + p-end (mime::preview-content-info/point-max pc)) + (while (and (setq cell (car rest)) + (progn + (setq rc + (mime::content-info/rcnum + (mime::preview-content-info/content-info + cell))) + (equal rcnum + (nthcdr (- (length rc) len) rc)) + )) + (setq p-end (mime::preview-content-info/point-max cell)) + (setq rest (cdr rest)) + )))) + (if pc + (let* ((mode (mime-preview/get-original-major-mode)) + (new-name (format "%s-%s" (buffer-name) (reverse rcnum))) + new-buf + (the-buf (current-buffer)) + (a-buf mime::preview/article-buffer) + (hb (mime::content-info/point-min cinfo)) + (he (mime::content-info/point-max cinfo)) + fields from to cc reply-to subj mid f) + (save-excursion + (set-buffer (setq new-buf (get-buffer-create new-name))) + (erase-buffer) + (insert-buffer-substring the-buf p-beg p-end) + (goto-char (point-min)) + (if (mime-viewer/header-visible-p rcnum root-cinfo) + (delete-region (goto-char (point-min)) + (if (re-search-forward "^$" nil t) + (match-end 0) + (point-min))) + ) + (goto-char (point-min)) + (insert "\n") + (goto-char (point-min)) + (let ((rcnum (mime::content-info/rcnum cinfo)) ci str) + (while (progn + (setq str + (save-excursion + (set-buffer a-buf) + (setq ci (mime-article/rcnum-to-cinfo rcnum)) + (save-restriction + (narrow-to-region + (mime::content-info/point-min ci) + (mime::content-info/point-max ci) + ) + (std11-header-string-except + (concat "^" + (apply (function regexp-or) fields) + ":") "")))) + (if (string-equal (mime::content-info/type ci) + "message/rfc822") + nil + (if str + (insert str) + ) + rcnum)) + (setq fields (std11-collect-field-names) + rcnum (cdr rcnum)) + ) + ) + (mime/decode-message-header) + ) + (funcall (cdr (assq mode mime-viewer/following-method-alist)) + new-buf) + )))) + +(defun mime-viewer/display-x-face () + (interactive) + (save-window-excursion + (set-buffer mime::preview/article-buffer) + (mime-viewer/x-face-function) + )) + +(defun mime-viewer/up-content () + (interactive) + (let* ((pc (mime-preview/point-pcinfo (point))) + (cinfo (mime::preview-content-info/content-info pc)) + (rcnum (mime::content-info/rcnum cinfo)) + ) + (if rcnum + (let ((r (save-excursion + (set-buffer (mime::preview-content-info/buffer pc)) + (mime-article/rcnum-to-cinfo (cdr rcnum)) + )) + (rpcl mime::preview/content-list) + cell) + (while (and + (setq cell (car rpcl)) + (not (eq r (mime::preview-content-info/content-info cell))) + ) + (setq rpcl (cdr rpcl)) + ) + (goto-char (mime::preview-content-info/point-min cell)) + ) + (mime-viewer/quit) + ))) + +(defun mime-viewer/previous-content () + (interactive) + (let* ((pcl mime::preview/content-list) + (p (point)) + (i (- (length pcl) 1)) + beg) + (catch 'tag + (while (>= i 0) + (setq beg (mime::preview-content-info/point-min (nth i pcl))) + (if (> p beg) + (throw 'tag (goto-char beg)) + ) + (setq i (- i 1)) + ) + (let ((f (assq mime::preview/original-major-mode + mime-viewer/over-to-previous-method-alist))) + (if f + (funcall (cdr f)) + )) + ) + )) + +(defun mime-viewer/next-content () + (interactive) + (let ((pcl mime::preview/content-list) + (p (point)) + beg) + (catch 'tag + (while pcl + (setq beg (mime::preview-content-info/point-min (car pcl))) + (if (< p beg) + (throw 'tag (goto-char beg)) + ) + (setq pcl (cdr pcl)) + ) + (let ((f (assq mime::preview/original-major-mode + mime-viewer/over-to-next-method-alist))) + (if f + (funcall (cdr f)) + )) + ) + )) + +(defun mime-viewer/scroll-up-content (&optional h) + (interactive) + (or h + (setq h (- (window-height) 1)) + ) + (if (= (point) (point-max)) + (let ((f (assq mime::preview/original-major-mode + mime-viewer/over-to-next-method-alist))) + (if f + (funcall (cdr f)) + )) + (let ((pcl mime::preview/content-list) + (p (point)) + np beg) + (setq np + (or (catch 'tag + (while pcl + (setq beg (mime::preview-content-info/point-min (car pcl))) + (if (< p beg) + (throw 'tag beg) + ) + (setq pcl (cdr pcl)) + )) + (point-max))) + (forward-line h) + (if (> (point) np) + (goto-char np) + ) + ;;(show-subtree) + )) + ) + +(defun mime-viewer/scroll-down-content (&optional h) + (interactive) + (or h + (setq h (- (window-height) 1)) + ) + (if (= (point) (point-min)) + (let ((f (assq mime::preview/original-major-mode + mime-viewer/over-to-previous-method-alist))) + (if f + (funcall (cdr f)) + )) + (let ((pcl mime::preview/content-list) + (p (point)) + pp beg) + (setq pp + (or (let ((i (- (length pcl) 1))) + (catch 'tag + (while (> i 0) + (setq beg (mime::preview-content-info/point-min + (nth i pcl))) + (if (> p beg) + (throw 'tag beg) + ) + (setq i (- i 1)) + ))) + (point-min))) + (forward-line (- h)) + (if (< (point) pp) + (goto-char pp) + ))) + ) + +(defun mime-viewer/next-line-content () + (interactive) + (mime-viewer/scroll-up-content 1) + ) + +(defun mime-viewer/previous-line-content () + (interactive) + (mime-viewer/scroll-down-content 1) + ) + +(defun mime-viewer/quit () + (interactive) + (let ((r (save-excursion + (set-buffer (mime::preview-content-info/buffer + (mime-preview/point-pcinfo (point)))) + (assq major-mode mime-viewer/quitting-method-alist) + ))) + (if r + (funcall (cdr r)) + ))) + +(defun mime-viewer/show-summary () + (interactive) + (let ((r (save-excursion + (set-buffer + (mime::preview-content-info/buffer + (mime-preview/point-pcinfo (point))) + ) + (assq major-mode mime-viewer/show-summary-method) + ))) + (if r + (funcall (cdr r)) + ))) + +(defun mime-viewer/kill-buffer () + (interactive) + (kill-buffer (current-buffer)) + ) + + +;;; @ end +;;; + +(provide 'tm-view) + +(run-hooks 'tm-view-load-hook) + +;;; tm-view.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tm-vm.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tm-vm.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,1179 @@ +;;; tm-vm.el --- tm-MUA (MIME Extension module) for VM + +;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MASUTANI Yasuhiro +;; Kenji Wakamiya +;; MORIOKA Tomohiko +;; Shuhei KOBAYASHI +;; Oscar Figueiredo +;; Maintainer: Oscar Figueiredo +;; Created: 1994/10/29 +;; Version: $Revision: 1.1.1.1 $ +;; Keywords: mail, MIME, multimedia, multilingual, encoded-word + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Plese insert `(require 'tm-vm)' in your ~/.vm file. + +;;; Code: + +(require 'tm-view) +(require 'vm) +(eval-when-compile + (require 'ps-print)) + +(defconst tm-vm/RCS-ID + "$Id: tm-vm.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $") +(defconst tm-vm/version (get-version-string tm-vm/RCS-ID)) + +(define-key vm-mode-map "Z" 'tm-vm/view-message) +(define-key vm-mode-map "T" 'tm-vm/decode-message-header) +(define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode) + +(defvar tm-vm/use-original-url-button nil + "*If it is t, use original URL button instead of tm's.") + +(defvar tm-vm-load-hook nil + "*List of functions called after tm-vm is loaded.") + + +;;; @ for MIME encoded-words +;;; + +(defvar tm-vm/use-tm-patch nil + "Does not decode encoded-words in summary buffer if it is t. +If you use tiny-mime patch for VM (by RIKITAKE Kenji +), please set it t [tm-vm.el]") + +(or tm-vm/use-tm-patch + (progn +;;; +(defvar tm-vm/chop-full-name-function 'tm-vm/default-chop-full-name) +(setq vm-chop-full-name-function tm-vm/chop-full-name-function) + +(defun tm-vm/default-chop-full-name (address) + (let* ((ret (vm-default-chop-full-name address)) + (full-name (car ret)) + ) + (if (stringp full-name) + (cons (mime-eword/decode-string full-name) + (cdr ret)) + ret))) + +(require 'vm-summary) +(or (fboundp 'tm:vm-su-subject) + (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject)) + ) +(defun vm-su-subject (m) + (mime-eword/decode-string (tm:vm-su-subject m)) + ) + +(or (fboundp 'tm:vm-su-full-name) + (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name)) + ) +(defun vm-su-full-name (m) + (mime-eword/decode-string (tm:vm-su-full-name m)) + ) + +(or (fboundp 'tm:vm-su-to-names) + (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names)) + ) +(defun vm-su-to-names (m) + (mime-eword/decode-string (tm:vm-su-to-names m)) + ) +;;; +)) + +(defun tm-vm/decode-message-header (&optional count) + "Decode MIME header of current message. +Numeric prefix argument COUNT means to decode the current message plus +the next COUNT-1 messages. A negative COUNT means decode the current +message and the previous COUNT-1 messages. +When invoked on marked messages (via vm-next-command-uses-marks), +all marked messages are affected, other messages are ignored." + (interactive "p") + (or count (setq count 1)) + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (vm-error-if-folder-read-only) + (let ((mlist (vm-select-marked-or-prefixed-messages count)) + (realm nil) + (vlist nil) + (vbufs nil)) + (save-excursion + (while mlist + (setq realm (vm-real-message-of (car mlist))) + ;; Go to real folder of this message. + ;; But maybe this message is already real message... + (set-buffer (vm-buffer-of realm)) + (let ((buffer-read-only nil)) + (vm-save-restriction + (narrow-to-region (vm-headers-of realm) (vm-text-of realm)) + (mime/decode-message-header)) + (let ((vm-message-pointer (list realm)) + (last-command nil)) + (vm-discard-cached-data)) + ;; Mark each virtual and real message for later summary + ;; update. + (setq vlist (cons realm (vm-virtual-messages-of realm))) + (while vlist + (vm-mark-for-summary-update (car vlist)) + ;; Remember virtual and real folders related this message, + ;; for later display update. + (or (memq (vm-buffer-of (car vlist)) vbufs) + (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs))) + (setq vlist (cdr vlist))) + (if (eq vm-flush-interval t) + (vm-stuff-virtual-attributes realm) + (vm-set-modflag-of realm t))) + (setq mlist (cdr mlist))) + ;; Update mail-buffers and summaries. + (while vbufs + (set-buffer (car vbufs)) + (vm-preview-current-message) + (setq vbufs (cdr vbufs)))))) + + +;;; @ automatic MIME preview +;;; + +(defvar tm-vm/automatic-mime-preview t + "*If non-nil, automatically process and show MIME messages.") + +(defvar tm-vm/strict-mime t + "*If nil, do MIME processing even if there is no MIME-Version field.") + +(defvar tm-vm/select-message-hook nil + "*List of functions called every time a message is selected. +tm-vm uses `vm-select-message-hook', use this hook instead.") + +(defvar tm-vm/system-state nil) + +(setq mime-viewer/content-header-filter-alist + (append '((vm-mode . tm-vm/header-filter) + (vm-virtual-mode . tm-vm/header-filter)) + mime-viewer/content-header-filter-alist)) + +(defun tm-vm/header-filter () + "Filter headers in current buffer (assumed to be a message-like buffer) +according to vm-visible-headers and vm-invisible-header-regexp" + (goto-char (point-min)) + (let ((visible-headers vm-visible-headers)) + (if (or vm-use-lucid-highlighting + vm-display-xfaces) + (setq visible-headers (cons "X-Face:" vm-visible-headers))) + (vm-reorder-message-headers nil + visible-headers + vm-invisible-header-regexp) + (mime/decode-message-header))) + +(defun tm-vm/system-state () + (save-excursion + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer) + (vm-select-folder-buffer)) + tm-vm/system-state)) + +(defun tm-vm/sync-preview-buffer () + "Ensure that the MIME preview buffer, if it exists actually corresponds to +the current message. If no MIME Preview buffer is needed, delete it. If no +MIME Preview buffer exists nothing is done." + ;; Current buffer should be message buffer when calling this function + (let* ((mbuf (current-buffer)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (win (or (and pbuf (vm-get-buffer-window pbuf)) + (vm-get-buffer-window mbuf))) + (frame (selected-frame))) + (if pbuf + ;; Go to the frame where pbuf or mbuf is (frame-per-composition t) + (save-excursion + (if win + (vm-select-frame (vm-window-frame win))) + ;; Rebuild MIME Preview buffer to ensure it corresponds to + ;; current message + (save-window-excursion + (save-selected-window + (save-excursion + (set-buffer mbuf) + (setq mime::article/preview-buffer nil) + (if pbuf (kill-buffer pbuf))) + (tm-vm/view-message))) + ;; Return to previous frame + (vm-select-frame frame))))) + +(defun tm-vm/display-preview-buffer () + (let* ((mbuf (current-buffer)) + (mwin (vm-get-visible-buffer-window mbuf)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) + (if (and pbuf (tm-vm/system-state)) + ;; display preview buffer + (cond + ((and mwin pwin) + (vm-undisplay-buffer mbuf) + (tm-vm/show-current-message)) + ((and mwin (not pwin)) + (set-window-buffer mwin pbuf) + (tm-vm/show-current-message)) + (pwin + (tm-vm/show-current-message)) + (t + ;; don't display if neither mwin nor pwin was displayed before. + )) + ;; display folder buffer + (cond + ((and mwin pwin) + (vm-undisplay-buffer pbuf)) + ((and (not mwin) pwin) + (set-window-buffer pwin mbuf)) + (mwin + ;; folder buffer is already displayed. + ) + (t + ;; don't display if neither mwin nor pwin was displayed before. + ))) + (set-buffer mbuf))) + +(defun tm-vm/preview-current-message () + "Preview current message if it has MIME contents and +tm-vm/automatic-mime-preview is non nil. Installed on +vm-visit-folder-hook and vm-select-message-hook." + ;; assumed current buffer is folder buffer. + (setq tm-vm/system-state nil) + (if (get-buffer mime/output-buffer-name) + (vm-undisplay-buffer mime/output-buffer-name)) + (if (and vm-message-pointer tm-vm/automatic-mime-preview) + (if (or (not tm-vm/strict-mime) + (vm-get-header-contents (car vm-message-pointer) + "MIME-Version:")) + ;; do MIME processing. + (progn + ;; Consider message as shown => update its flags and store them + ;; in folder buffer before entering MIME viewer + (tm-vm/show-current-message) + (set (make-local-variable 'tm-vm/system-state) 'previewing) + (save-window-excursion + (vm-widen-page) + (goto-char (point-max)) + (widen) + (narrow-to-region (point) + (save-excursion + (goto-char + (vm-start-of (car vm-message-pointer)) + ) + (forward-line) + (point) + )) + + (mime/viewer-mode nil nil nil nil nil vm-mode-map) + ;; Highlight message (and display XFace if supported) + (if (or vm-highlighted-header-regexp + (and (vm-xemacs-p) vm-use-lucid-highlighting)) + (vm-highlight-headers)) + ;; Energize URLs and buttons + (if (and tm-vm/use-original-url-button + vm-use-menus (vm-menu-support-possible-p)) + (progn + (vm-energize-urls) + (vm-energize-headers))) + (goto-char (point-min)) + (narrow-to-region (point) (search-forward "\n\n" nil t)) + )) + ;; don't do MIME processing. decode header only. + (let (buffer-read-only) + (mime/decode-message-header)) + ) + ;; don't preview; do nothing. + ) + (tm-vm/display-preview-buffer) + (run-hooks 'tm-vm/select-message-hook)) + +(defun tm-vm/show-current-message () + "Update current message display and summary. Remove 'unread' and 'new' flags. " + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer) + (vm-select-folder-buffer)) + (if mime::article/preview-buffer + (save-excursion + (set-buffer mime::article/preview-buffer) + (goto-char (point-min)) + (widen))) + (if (or (and mime::article/preview-buffer + (vm-get-visible-buffer-window mime::article/preview-buffer)) + (vm-get-visible-buffer-window (current-buffer))) + (progn + (setq tm-vm/system-state 'reading) + (if (vm-new-flag (car vm-message-pointer)) + (vm-set-new-flag (car vm-message-pointer) nil)) + (if (vm-unread-flag (car vm-message-pointer)) + (vm-set-unread-flag (car vm-message-pointer) nil)) + (vm-update-summary-and-mode-line) + (tm-vm/howl-if-eom)) + (vm-update-summary-and-mode-line))) + +(defun tm-vm/toggle-preview-mode () + "Toggle automatic MIME preview on or off. In automatic MIME Preview mode +each newly selected article is MIME processed if it has MIME content without +need for an explicit request from the user. This behaviour is controlled by the +variable tm-vm/automatic-mime-preview." + (interactive) + (if tm-vm/automatic-mime-preview + (progn + (tm-vm/quit-view-message) + (setq tm-vm/automatic-mime-preview nil) + (message "Automatic MIME Preview is now disabled.")) + ;; Enable Automatic MIME Preview + (tm-vm/view-message) + (setq tm-vm/automatic-mime-preview t) + (message "Automatic MIME Preview is now enabled.") + )) + +(add-hook 'vm-select-message-hook 'tm-vm/preview-current-message) +(add-hook 'vm-visit-folder-hook 'tm-vm/preview-current-message) + +;;; tm-vm move commands +;;; + +(defmacro tm-vm/save-window-excursion (&rest forms) + (list 'let '((tm-vm/selected-window (selected-window))) + (list 'unwind-protect + (cons 'progn forms) + '(if (window-live-p tm-vm/selected-window) + (select-window tm-vm/selected-window))))) + +;;; based on vm-scroll-forward [vm-page.el] +(defun tm-vm/scroll-forward (&optional arg) + (interactive "P") + (let ((this-command 'vm-scroll-forward)) + (if (not (tm-vm/system-state)) + (progn + (vm-scroll-forward arg) + (tm-vm/display-preview-buffer)) + (let* ((mp-changed (vm-follow-summary-cursor)) + (mbuf (or (vm-select-folder-buffer) (current-buffer))) + (mwin (vm-get-buffer-window mbuf)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (pwin (and pbuf (vm-get-buffer-window pbuf))) + (was-invisible (and (null mwin) (null pwin))) + ) + ;; now current buffer is folder buffer. + (tm-vm/save-window-excursion + (if (or mp-changed was-invisible) + (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) + (list this-command 'reading-message))) + (tm-vm/display-preview-buffer) + (setq mwin (vm-get-buffer-window mbuf) + pwin (and pbuf (vm-get-buffer-window pbuf))) + (cond + ((or mp-changed was-invisible) + nil + ) + ((null pbuf) + ;; preview buffer is killed. + (tm-vm/preview-current-message) + (vm-update-summary-and-mode-line)) + ((eq (tm-vm/system-state) 'previewing) + (tm-vm/show-current-message)) + (t + (select-window pwin) + (set-buffer pbuf) + (if (pos-visible-in-window-p (point-max) pwin) + (tm-vm/next-message) + ;; not end of message. scroll preview buffer only. + (scroll-up) + (tm-vm/howl-if-eom) + (set-buffer mbuf)) + )))) + ))) + +;;; based on vm-scroll-backward [vm-page.el] +(defun tm-vm/scroll-backward (&optional arg) + (interactive "P") + (let ((this-command 'vm-scroll-backward)) + (if (not (tm-vm/system-state)) + (vm-scroll-backward arg) + (let* ((mp-changed (vm-follow-summary-cursor)) + (mbuf (or (vm-select-folder-buffer) (current-buffer))) + (mwin (vm-get-buffer-window mbuf)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (pwin (and pbuf (vm-get-buffer-window pbuf))) + (was-invisible (and (null mwin) (null pwin))) + ) + ;; now current buffer is folder buffer. + (if (or mp-changed was-invisible) + (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) + (list this-command 'reading-message))) + (tm-vm/save-window-excursion + (tm-vm/display-preview-buffer) + (setq mwin (vm-get-buffer-window mbuf) + pwin (and pbuf (vm-get-buffer-window pbuf))) + (cond + (was-invisible + nil + ) + ((null pbuf) + ;; preview buffer is killed. + (tm-vm/preview-current-message) + (vm-update-summary-and-mode-line)) + ((eq (tm-vm/system-state) 'previewing) + (tm-vm/show-current-message)) + (t + (select-window pwin) + (set-buffer pbuf) + (if (pos-visible-in-window-p (point-min) pwin) + nil + ;; scroll preview buffer only. + (scroll-down) + (set-buffer mbuf)) + )))) + ))) + +;;; based on vm-beginning-of-message [vm-page.el] +(defun tm-vm/beginning-of-message () + "Moves to the beginning of the current message." + (interactive) + (if (not (tm-vm/system-state)) + (progn + (setq this-command 'vm-beginning-of-message) + (vm-beginning-of-message)) + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (let ((mbuf (current-buffer)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)))) + (if (null pbuf) + (progn + (tm-vm/preview-current-message) + (setq pbuf (get-buffer mime::article/preview-buffer)) + )) + (vm-display mbuf t '(vm-beginning-of-message) + '(vm-beginning-of-message reading-message)) + (tm-vm/display-preview-buffer) + (set-buffer pbuf) + (tm-vm/save-window-excursion + (select-window (vm-get-buffer-window pbuf)) + (push-mark) + (goto-char (point-min)) + )))) + +;;; based on vm-end-of-message [vm-page.el] +(defun tm-vm/end-of-message () + "Moves to the end of the current message." + (interactive) + (if (not (tm-vm/system-state)) + (progn + (setq this-command 'vm-end-of-message) + (vm-end-of-message)) + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (let ((mbuf (current-buffer)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)))) + (if (null pbuf) + (progn + (tm-vm/preview-current-message) + (setq pbuf (get-buffer mime::article/preview-buffer)) + )) + (vm-display mbuf t '(vm-end-of-message) + '(vm-end-of-message reading-message)) + (tm-vm/display-preview-buffer) + (set-buffer pbuf) + (tm-vm/save-window-excursion + (select-window (vm-get-buffer-window pbuf)) + (push-mark) + (goto-char (point-max)) + )))) + +;;; based on vm-howl-if-eom [vm-page.el] +(defun tm-vm/howl-if-eom () + (let* ((pbuf (or mime::article/preview-buffer (current-buffer))) + (pwin (and (vm-get-visible-buffer-window pbuf)))) + (and pwin + (save-excursion + (save-window-excursion + (condition-case () + (let ((next-screen-context-lines 0)) + (select-window pwin) + (save-excursion + (save-window-excursion + (let ((scroll-in-place-replace-original nil)) + (scroll-up)))) + nil) + (error t)))) + (tm-vm/emit-eom-blurb) + ))) + +;;; based on vm-emit-eom-blurb [vm-page.el] +(defun tm-vm/emit-eom-blurb () + (save-excursion + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (vm-emit-eom-blurb))) + +;;; based on vm-quit [vm-folder.el] +(defun tm-vm/quit () + "Quit VM saving the folder buffer and killing the MIME Preview buffer if any" + (interactive) + (save-excursion + (vm-select-folder-buffer) + (if (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)) + (kill-buffer mime::article/preview-buffer))) + (vm-quit)) + +(defun tm-vm/quit-no-change () + "Quit VM without saving the folder buffer but killing the MIME Preview buffer +if any" + (interactive) + (save-excursion + (vm-select-folder-buffer) + (if (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)) + (kill-buffer mime::article/preview-buffer))) + (vm-quit-no-change)) + +;;; based on vm-next-message [vm-motion.el] +(defun tm-vm/next-message () + (set-buffer mime::preview/article-buffer) + (let ((this-command 'vm-next-message) + (owin (selected-window)) + (vm-preview-lines nil) + ) + (vm-next-message 1 nil t) + (if (window-live-p owin) + (select-window owin)))) + +;;; based on vm-previous-message [vm-motion.el] +(defun tm-vm/previous-message () + (set-buffer mime::preview/article-buffer) + (let ((this-command 'vm-previous-message) + (owin (selected-window)) + (vm-preview-lines nil) + ) + (vm-previous-message 1 nil t) + (if (window-live-p owin) + (select-window owin)))) + +(set-alist 'mime-viewer/over-to-previous-method-alist + 'vm-mode 'tm-vm/previous-message) +(set-alist 'mime-viewer/over-to-next-method-alist + 'vm-mode 'tm-vm/next-message) +(set-alist 'mime-viewer/over-to-previous-method-alist + 'vm-virtual-mode 'tm-vm/previous-message) +(set-alist 'mime-viewer/over-to-next-method-alist + 'vm-virtual-mode 'tm-vm/next-message) + +;;; @@ vm-yank-message +;;; +;; 1996/3/28 by Oscar Figueiredo + +(require 'vm-reply) + +(defvar tm-vm/yank:message-to-restore nil + "For internal use by tm-vm only.") + +(defun vm-yank-message (&optional message) + "Yank message number N into the current buffer at point. +When called interactively N is always read from the minibuffer. When +called non-interactively the first argument is expected to be a +message struct. + +This function originally provided by vm-reply has been patched for TM +in order to provide better citation of MIME messages : if a MIME +Preview buffer exists for the message then its contents are inserted +instead of the raw message. + +This command is meant to be used in VM created Mail mode buffers; the +yanked message comes from the mail buffer containing the message you +are replying to, forwarding, or invoked VM's mail command from. + +All message headers are yanked along with the text. Point is +left before the inserted text, the mark after. Any hook +functions bound to mail-citation-hook are run, after inserting +the text and setting point and mark. For backward compatibility, +if mail-citation-hook is set to nil, `mail-yank-hooks' is run +instead. + +If mail-citation-hook and mail-yank-hooks are both nil, this +default action is taken: the yanked headers are trimmed as +specified by vm-included-text-headers and +vm-included-text-discard-header-regexp, and the value of +vm-included-text-prefix is prepended to every yanked line." + (interactive + (list + ;; What we really want for the first argument is a message struct, + ;; but if called interactively, we let the user type in a message + ;; number instead. + (let (mp default + (result 0) + prompt + (last-command last-command) + (this-command this-command)) + (if (bufferp vm-mail-buffer) + (save-excursion + (vm-select-folder-buffer) + (setq default (and vm-message-pointer + (vm-number-of (car vm-message-pointer))) + prompt (if default + (format "Yank message number: (default %s) " + default) + "Yank message number: ")) + (while (zerop result) + (setq result (read-string prompt)) + (and (string= result "") default (setq result default)) + (setq result (string-to-int result))) + (if (null (setq mp (nthcdr (1- result) vm-message-list))) + (error "No such message.")) + (setq tm-vm/yank:message-to-restore (string-to-int default)) + (save-selected-window + (vm-goto-message result)) + (car mp)) + nil)))) + (if (null message) + (if mail-reply-buffer + (tm-vm/yank-content) + (error "This is not a VM Mail mode buffer.")) + (if (null (buffer-name vm-mail-buffer)) + (error "The folder buffer containing message %d has been killed." + (vm-number-of message))) + (vm-display nil nil '(vm-yank-message) + '(vm-yank-message composing-message)) + (let ((b (current-buffer)) (start (point)) end) + (save-restriction + (widen) + (save-excursion + (set-buffer (vm-buffer-of message)) + (let* ((mbuf (current-buffer)) + pbuf) + (tm-vm/sync-preview-buffer) + (setq pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (if (and pbuf + (not (eq this-command 'tm-vm/forward-message))) + (if running-xemacs + (let ((tmp (generate-new-buffer "tm-vm/tmp"))) + (set-buffer pbuf) + (append-to-buffer tmp (point-min) (point-max)) + (set-buffer tmp) + (map-extents + '(lambda (ext maparg) + (set-extent-property ext 'begin-glyph nil))) + (append-to-buffer b (point-min) (point-max)) + (setq end (vm-marker + (+ start (length (buffer-string))) b)) + (kill-buffer tmp)) + (set-buffer pbuf) + (append-to-buffer b (point-min) (point-max)) + (setq end (vm-marker + (+ start (length (buffer-string))) b))) + (save-restriction + (setq message (vm-real-message-of message)) + (set-buffer (vm-buffer-of message)) + (widen) + (append-to-buffer + b (vm-headers-of message) (vm-text-end-of message)) + (setq end + (vm-marker (+ start (- (vm-text-end-of message) + (vm-headers-of message))) b)))))) + (push-mark end) + (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) + (mail-yank-hooks (run-hooks 'mail-yank-hooks)) + (t (vm-mail-yank-default message))) + )) + (if tm-vm/yank:message-to-restore + (save-selected-window + (vm-goto-message tm-vm/yank:message-to-restore) + (setq tm-vm/yank:message-to-restore nil))) + )) + + +;;; @ for tm-view +;;; + +;;; based on vm-do-reply [vm-reply.el] +(defun tm-vm/do-reply (buf to-all include-text) + (save-excursion + (set-buffer buf) + (let ((dir default-directory) + to cc subject mp in-reply-to references newsgroups) + (cond ((setq to + (let ((reply-to (std11-field-body "Reply-To"))) + (if (vm-ignored-reply-to reply-to) + nil + reply-to)))) + ((setq to (std11-field-body "From"))) + ;; (t (error "No From: or Reply-To: header in message")) + ) + (if to-all + (setq cc (delq nil (cons cc (std11-field-bodies '("To" "Cc")))) + cc (mapconcat 'identity cc ",")) + ) + (setq subject (std11-field-body "Subject")) + (and subject vm-reply-subject-prefix + (let ((case-fold-search t)) + (not + (equal + (string-match (regexp-quote vm-reply-subject-prefix) + subject) + 0))) + (setq subject (concat vm-reply-subject-prefix subject))) + (setq in-reply-to (std11-field-body "Message-Id") + references (nconc + (std11-field-bodies '("References" "In-Reply-To")) + (list in-reply-to)) + newsgroups (list (or (and to-all + (std11-field-body "Followup-To")) + (std11-field-body "Newsgroups")))) + (setq to (vm-parse-addresses to) + cc (vm-parse-addresses cc)) + (if vm-reply-ignored-addresses + (setq to (vm-strip-ignored-addresses to) + cc (vm-strip-ignored-addresses cc))) + (setq to (vm-delete-duplicates to nil t)) + (setq cc (vm-delete-duplicates + (append (vm-delete-duplicates cc nil t) + to (copy-sequence to)) + t t)) + (and to (setq to (mapconcat 'identity to ",\n "))) + (and cc (setq cc (mapconcat 'identity cc ",\n "))) + (and (null to) (setq to cc cc nil)) + (setq references (delq nil references) + references (mapconcat 'identity references " ") + references (vm-parse references "[^<]*\\(<[^>]+>\\)") + references (vm-delete-duplicates references) + references (if references (mapconcat 'identity references "\n\t"))) + (setq newsgroups (delq nil newsgroups) + newsgroups (mapconcat 'identity newsgroups ",") + newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") + newsgroups (vm-delete-duplicates newsgroups) + newsgroups (if newsgroups (mapconcat 'identity newsgroups ","))) + (vm-mail-internal + (if to + (format "reply to %s%s" + (std11-full-name-string + (car (std11-parse-address-string to))) + (if cc ", ..." ""))) + to subject in-reply-to cc references newsgroups) + (setq mail-reply-buffer buf + ;; vm-system-state 'replying + default-directory dir)) + (if include-text + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search nil)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") nil 0)) + (forward-char 1) + (tm-vm/yank-content))) + (run-hooks 'vm-reply-hook) + (run-hooks 'vm-mail-mode-hook) + )) + +(defun tm-vm/following-method (buf) + (tm-vm/do-reply buf 'to-all 'include-text) + ) + +(defun tm-vm/yank-content () + (interactive) + (let ((this-command 'vm-yank-message)) + (vm-display nil nil '(vm-yank-message) + '(vm-yank-message composing-message)) + (save-restriction + (narrow-to-region (point)(point)) + (insert-buffer mail-reply-buffer) + (goto-char (point-max)) + (push-mark) + (goto-char (point-min))) + (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) + (mail-yank-hooks (run-hooks 'mail-yank-hooks)) + (t (mail-indent-citation))) + )) + +(set-alist 'mime-viewer/following-method-alist + 'vm-mode + (function tm-vm/following-method)) +(set-alist 'mime-viewer/following-method-alist + 'vm-virtual-mode + (function tm-vm/following-method)) + + +(defun tm-vm/quit-view-message () + "Quit MIME-Viewer and go back to normal VM. MIME Preview buffer +is killed. This function is called by `mime-viewer/quit' command +via `mime-viewer/quitting-method-alist'." + (if (get-buffer mime/output-buffer-name) + (vm-undisplay-buffer mime/output-buffer-name)) + (vm-select-folder-buffer) + (let* ((mbuf (current-buffer)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) + (kill-buffer pbuf) + (and pwin + (select-window pwin) + (switch-to-buffer mbuf))) + (setq tm-vm/system-state nil) + (vm-display (current-buffer) t (list this-command) + (list 'reading-message)) + ) + +(defun tm-vm/view-message () + "Decode and view a MIME encoded message under VM. +A MIME Preview buffer using mime/viewer-mode is created. +See mime/viewer-mode for more information" + (interactive) + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (vm-display (current-buffer) t '(tm-vm/view-message + tm-vm/toggle-preview-mode) + '(tm-vm/view-message reading-message)) + (let ((tm-vm/automatic-mime-preview t)) + (tm-vm/preview-current-message)) +) + +(set-alist 'mime-viewer/quitting-method-alist + 'vm-mode + 'tm-vm/quit-view-message) + +(set-alist 'mime-viewer/quitting-method-alist + 'vm-virtual-mode + 'tm-vm/quit-view-message) + + +;;; @ for tm-partial +;;; + +(call-after-loaded + 'tm-partial + (function + (lambda () + (set-atype 'mime/content-decoding-condition + '((type . "message/partial") + (method . mime-article/grab-message/partials) + (major-mode . vm-mode) + (summary-buffer-exp . vm-summary-buffer) + )) + (set-alist 'tm-partial/preview-article-method-alist + 'vm-mode + (function + (lambda () + (tm-vm/view-message) + ))) + ))) + + +;;; @ for tm-edit +;;; + +;;; @@ for multipart/digest +;;; + +(defvar tm-vm/forward-message-hook nil + "*List of functions called after a Mail mode buffer has been +created to forward a message in message/rfc822 type format. +If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this +hook instead of `vm-forward-message-hook'.") + +(defvar tm-vm/send-digest-hook nil + "*List of functions called after a Mail mode buffer has been +created to send a digest in multipart/digest type format. +If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook +instead of `vm-send-digest-hook'.") + +(defun tm-vm/enclose-messages (mlist &optional preamble) + "Enclose the messages in MLIST as multipart/digest. +The resulting digest is inserted at point in the current buffer. + +MLIST should be a list of message structs (real or virtual). +These are the messages that will be enclosed." + (if mlist + (let ((digest (consp (cdr mlist))) + (mp mlist) + m) + (save-restriction + (narrow-to-region (point) (point)) + (while mlist + (setq m (vm-real-message-of (car mlist))) + (mime-editor/insert-tag "message" "rfc822") + (tm-mail/insert-message m) + (goto-char (point-max)) + (setq mlist (cdr mlist))) + (if preamble + (progn + (goto-char (point-min)) + (mime-editor/insert-tag "text" "plain") + (vm-unsaved-message "Building digest preamble...") + (while mp + (let ((vm-summary-uninteresting-senders nil)) + (insert + (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")) + (if vm-digest-center-preamble + (progn + (forward-char -1) + (center-line) + (forward-char 1))) + (setq mp (cdr mp))))) + (if digest + (mime-editor/enclose-digest-region (point-min) (point-max))) + )))) + +(defun tm-vm/forward-message () + "Forward the current message to one or more recipients. +You will be placed in a Mail mode buffer as you would with a +reply, but you must fill in the To: header and perhaps the +Subject: header manually." + (interactive) + (if (not (equal vm-forwarding-digest-type "rfc1521")) + (vm-forward-message) + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (if (eq last-command 'vm-next-command-uses-marks) + (let ((vm-digest-send-type vm-forwarding-digest-type)) + (setq this-command 'vm-next-command-uses-marks) + (command-execute 'tm-vm/send-digest)) + (let ((dir default-directory) + (mp vm-message-pointer)) + (save-restriction + (widen) + (vm-mail-internal + (format "forward of %s's note re: %s" + (vm-su-full-name (car vm-message-pointer)) + (vm-su-subject (car vm-message-pointer))) + nil + (and vm-forwarding-subject-format + (let ((vm-summary-uninteresting-senders nil)) + (vm-sprintf 'vm-forwarding-subject-format (car mp))))) + (make-local-variable 'vm-forward-list) + (setq vm-system-state 'forwarding + vm-forward-list (list (car mp)) + default-directory dir) + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil 0) + (tm-vm/enclose-messages vm-forward-list) + (mail-position-on-field "To")) + (run-hooks 'tm-vm/forward-message-hook) + (run-hooks 'vm-mail-mode-hook))))) + +(defun tm-vm/send-digest (&optional arg) + "Send a digest of all messages in the current folder to recipients. +The type of the digest is specified by the variable vm-digest-send-type. +You will be placed in a Mail mode buffer as is usual with replies, but you +must fill in the To: and Subject: headers manually. + +If invoked on marked messages (via vm-next-command-uses-marks), +only marked messages will be put into the digest." + (interactive "P") + (if (not (equal vm-digest-send-type "rfc1521")) + (vm-send-digest arg) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (let ((dir default-directory) + (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks) + (vm-select-marked-or-prefixed-messages 0) + vm-message-list)) + start) + (save-restriction + (widen) + (vm-mail-internal (format "digest from %s" (buffer-name))) + (setq vm-system-state 'forwarding + default-directory dir) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) + "\n")) + (goto-char (match-end 0)) + (vm-unsaved-message "Building %s digest..." vm-digest-send-type) + (tm-vm/enclose-messages vm-forward-list arg) + (mail-position-on-field "To") + (message "Building %s digest... done" vm-digest-send-type))) + (run-hooks 'tm-vm/send-digest-hook) + (run-hooks 'vm-mail-mode-hook))) + +(substitute-key-definition 'vm-forward-message + 'tm-vm/forward-message vm-mode-map) +(substitute-key-definition 'vm-send-digest + 'tm-vm/send-digest vm-mode-map) + + +;;; @@ setting +;;; + +(defvar tm-vm/use-xemacs-popup-menu t) + +;;; modified by Steven L. Baur +;;; 1995/12/6 (c.f. [tm-en:209]) +(defun mime-editor/attach-to-vm-mode-menu () + "Arrange to attach MIME editor's popup menu to VM's" + (if (boundp 'vm-menu-mail-menu) + (progn + (setq vm-menu-mail-menu + (append vm-menu-mail-menu + (list "----" + mime-editor/popup-menu-for-xemacs))) + (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu) + ))) + +(call-after-loaded + 'tm-edit + (function + (lambda () + (autoload 'tm-mail/insert-message "tm-mail") + (set-alist 'mime-editor/message-inserter-alist + 'mail-mode (function tm-mail/insert-message)) + (set-alist 'mime-editor/split-message-sender-alist + 'mail-mode (function + (lambda () + (interactive) + (sendmail-send-it) + ))) + (if (and (string-match "XEmacs\\|Lucid" emacs-version) + tm-vm/use-xemacs-popup-menu) + (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu) + ) + ))) + +(call-after-loaded + 'mime-setup + (function + (lambda () + (setq vm-forwarding-digest-type "rfc1521") + (setq vm-digest-send-type "rfc1521") + ))) + + +;;; @ for BBDB +;;; + +(call-after-loaded + 'bbdb + (function + (lambda () + (require 'bbdb-vm) + (require 'tm-bbdb) + (defun tm-bbdb/vm-update-record (&optional offer-to-create) + (vm-select-folder-buffer) + (if (and (tm-vm/system-state) + mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)) + (let ((tm-bbdb/auto-create-p bbdb/mail-auto-create-p)) + (tm-bbdb/update-record offer-to-create)) + (or (bbdb/vm-update-record offer-to-create) + (delete-windows-on (get-buffer "*BBDB*"))) + )) + (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record) + (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record) + (add-hook 'tm-vm/select-message-hook 'tm-bbdb/vm-update-record) + ))) + +;;; @ for ps-print (Suggestted by Anders Stenman ) +;;; + +(defvar tm-vm/use-ps-print (not (or running-mule-merged-emacs + running-xemacs-with-mule)) + "*Use Postscript printing (ps-print) to print MIME messages.") + +(if tm-vm/use-ps-print + (progn + (require 'ps-print) + (add-hook 'vm-mode-hook 'tm-vm/ps-print-setup) + (add-hook 'mime-viewer/define-keymap-hook 'tm-vm/ps-print-setup) + (fset 'vm-toolbar-print-command 'tm-vm/print-message))) + +(defun tm-vm/ps-print-setup () + "Set things up for printing MIME messages with ps-print. Set binding to +the [Print Screen] key." + (local-set-key (ps-prsc) 'tm-vm/print-message) + (setq ps-header-lines 3) + (setq ps-left-header + (list 'ps-article-subject 'ps-article-author 'buffer-name))) + +(defun tm-vm/print-message () + "Print current message with ps-print if it's a MIME message. +Value of tm-vm/strict-mime is also taken into consideration." + (interactive) + (vm-follow-summary-cursor) + (let* ((mbuf (or (vm-select-folder-buffer) (current-buffer))) + pbuf) + (tm-vm/sync-preview-buffer) + (setq pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (if pbuf + (save-excursion + (set-buffer pbuf) + (require 'ps-print) + (ps-print-buffer-with-faces)) + (vm-print-message)))) + + +;;; @ Substitute VM bindings and menus +;;; + +(substitute-key-definition 'vm-scroll-forward + 'tm-vm/scroll-forward vm-mode-map) +(substitute-key-definition 'vm-scroll-backward + 'tm-vm/scroll-backward vm-mode-map) +(substitute-key-definition 'vm-beginning-of-message + 'tm-vm/beginning-of-message vm-mode-map) +(substitute-key-definition 'vm-end-of-message + 'tm-vm/end-of-message vm-mode-map) +(substitute-key-definition 'vm-forward-message + 'tm-vm/forward-message vm-mode-map) +(substitute-key-definition 'vm-quit + 'tm-vm/quit vm-mode-map) +(substitute-key-definition 'vm-quit-no-change + 'tm-vm/quit-no-change vm-mode-map) + +;; The following function should be modified and called on vm-menu-setup-hook +;; but VM 5.96 does not run that hook on XEmacs +(require 'vm-menu) +(if running-xemacs + (condition-case nil + (aset (car (find-menu-item vm-menu-dispose-menu '("Forward"))) + 1 + 'tm-vm/forward-message) + (t nil))) + +;;; @ end +;;; + +(provide 'tm-vm) + +(run-hooks 'tm-vm-load-hook) + +;;; tm-vm.el ends here. + diff -r 30df88044ec6 -r b82b59fe008d lisp/tm/tmh-comp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/tm/tmh-comp.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,523 @@ +;;; tm-mh-e.el --- tm-mh-e functions for composing messages + +;; Copyright (C) 1993,1994,1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; OKABE Yasuo +;; Maintainer: MORIOKA Tomohiko +;; Created: 1996/2/29 (separated from tm-mh-e.el) +;; Version: $Id: tmh-comp.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $ +;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual + +;; This file is part of tm (Tools for MIME). + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(require 'mh-comp) +(require 'tm-edit) + + +;;; @ variable +;;; + +(defvar tm-mh-e/forwcomps "forwcomps" + "Name of file to be used as a skeleton for forwarding messages. +Default is \"forwcomps\". If not a complete path name, the file +is searched for first in the user's MH directory, then in the +system MH lib directory.") + +(defvar tm-mh-e/message-yank-function 'mh-yank-cur-msg) + + +;;; @ for tm-edit +;;; + +(defun tm-mh-e::make-message (folder number) + (vector folder number) + ) + +(defun tm-mh-e::message/folder (message) + (elt message 0) + ) + +(defun tm-mh-e::message/number (message) + (elt message 1) + ) + +(defun tm-mh-e::message/file-name (message) + (expand-file-name + (tm-mh-e::message/number message) + (mh-expand-file-name (tm-mh-e::message/folder message)) + )) + +;;; modified by OKABE Yasuo +;;; 1995/11/14 (cf. [tm-ja:1096]) +(defun tm-mh-e/prompt-for-message (prompt folder &optional default) + (let* ((files + (directory-files (mh-expand-file-name folder) nil "^[0-9]+$") + ) + (folder-buf (get-buffer folder)) + (default + (if folder-buf + (save-excursion + (set-buffer folder-buf) + (let* ((show-buffer (get-buffer mh-show-buffer)) + (show-buffer-file-name + (buffer-file-name show-buffer))) + (if show-buffer-file-name + (file-name-nondirectory show-buffer-file-name))))))) + (if (or (null default) + (not (string-match "^[0-9]+$" default))) + (setq default + (if (and (string= folder mh-sent-from-folder) + mh-sent-from-msg) + (int-to-string mh-sent-from-msg) + (save-excursion + (let (cur-msg) + (if (and + (= 0 (mh-exec-cmd-quiet nil "pick" folder "cur")) + (set-buffer mh-temp-buffer) + (setq cur-msg (buffer-string)) + (string-match "^[0-9]+$" cur-msg)) + (substring cur-msg 0 (match-end 0)) + (car files))))))) + (completing-read prompt + (let ((i 0)) + (mapcar (function + (lambda (file) + (setq i (+ i 1)) + (list file i) + )) + files) + ) nil nil default) + )) + +;;; modified by OKABE Yasuo +;;; 1995/11/14 (cf. [tm-ja:1096]) +(defun tm-mh-e/query-message (&optional message) + (let (folder number) + (if message + (progn + (setq folder (tm-mh-e::message/folder message)) + (setq number (tm-mh-e::message/number message)) + )) + (or (stringp folder) + (setq folder (mh-prompt-for-folder + "Message from" + (if (and (stringp mh-sent-from-folder) + (string-match "^\\+" mh-sent-from-folder)) + mh-sent-from-folder "+inbox") + nil))) + (setq number + (if (numberp number) + (number-to-string number) + (tm-mh-e/prompt-for-message "Message number: " folder) + )) + (tm-mh-e::make-message folder number) + )) + +(defun tm-mh-e/insert-message (&optional message) + ;; always ignores message + (let ((article-buffer + (if (not (and (stringp mh-sent-from-folder) + (numberp mh-sent-from-msg) + )) + (cond ((and (boundp 'gnus-original-article-buffer) + (bufferp mh-sent-from-folder) + (get-buffer gnus-original-article-buffer) + ) + gnus-original-article-buffer) + ((and (boundp 'gnus-article-buffer) + (get-buffer gnus-article-buffer) + (bufferp mh-sent-from-folder) + ) + (save-excursion + (set-buffer gnus-article-buffer) + (if (eq major-mode 'mime/viewer-mode) + mime::preview/article-buffer + (current-buffer) + ))) + )))) + (if (null article-buffer) + (tm-mh-e/insert-mail + (tm-mh-e::make-message mh-sent-from-folder mh-sent-from-msg) + ) + (insert-buffer article-buffer) + (mime-editor/inserted-message-filter) + ) + )) + +(defun tm-mh-e/insert-mail (&optional message) + (save-excursion + (save-restriction + (let ((message-file + (tm-mh-e::message/file-name (tm-mh-e/query-message message)))) + (narrow-to-region (point) (point)) + (insert-file-contents message-file) + (push-mark (point-max)) + (mime-editor/inserted-message-filter) + )))) + +(set-alist 'mime-editor/message-inserter-alist + 'mh-letter-mode (function tm-mh-e/insert-message)) +(set-alist 'mime-editor/mail-inserter-alist + 'mh-letter-mode (function tm-mh-e/insert-mail)) +(set-alist 'mime-editor/mail-inserter-alist + 'news-reply-mode (function tm-mh-e/insert-mail)) +(set-alist + 'mime-editor/split-message-sender-alist + 'mh-letter-mode + (function + (lambda (&optional arg) + (interactive "P") + (write-region (point-min) (point-max) + mime-editor/draft-file-name nil 'no-message) + (cond (arg + (pop-to-buffer "MH mail delivery") + (erase-buffer) + (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" + "-nodraftfolder" + mh-send-args + mime-editor/draft-file-name) + (goto-char (point-max)) ; show the interesting part + (recenter -1) + (sit-for 1)) + (t + (apply 'mh-exec-cmd-quiet t mh-send-prog + (mh-list-to-string + (list "-nopush" "-nodraftfolder" + "-noverbose" "-nowatch" + mh-send-args mime-editor/draft-file-name))))) + ))) + + +;;; @ commands using tm-edit features +;;; + +(defun tm-mh-e/edit-again (msg) + "Clean-up a draft or a message previously sent and make it resendable. +Default is the current message. +The variable mh-new-draft-cleaned-headers specifies the headers to remove. +See also documentation for `\\[mh-send]' function." + (interactive (list (mh-get-msg-num t))) + (catch 'tag + (let* ((from-folder mh-current-folder) + (config (current-window-configuration)) + code-conversion + (draft + (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) + (let ((name (format "draft-%d" msg))) + (if (get-buffer name) + (throw 'tag (pop-to-buffer name)) + ) + (let ((file-coding-system-for-read *noconv*) + (filename + (mh-msg-filename msg mh-draft-folder) + )) + (set-buffer (get-buffer-create name)) + (insert-file-contents filename) + (setq buffer-file-name filename) + (setq code-conversion t) + ) + (pop-to-buffer name) + (if (re-search-forward "^-+$" nil t) + (replace-match "") + ) + name)) + (t + (prog1 + (let ((file-coding-system-for-read *noconv*)) + (mh-read-draft "clean-up" (mh-msg-filename msg) nil) + ) + (setq code-conversion t) + )))) + ) + (goto-char (point-min)) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) + (if code-conversion + (let ((cs (detect-coding-region (point-min)(point-max)))) + (set-buffer-file-coding-system + (if (listp cs) + (car cs) + cs)) + )) + (save-buffer) + (mime/edit-again code-conversion t t) + (goto-char (point-min)) + (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil + config) + ))) + +;;; by OKABE Yasuo +;;; 1996/2/29 (cf. [tm-ja:1643]) +(defun tm-mh-e/extract-rejected-mail (msg) + "Extract a letter returned by the mail system and make it re-editable. +Default is the current message. The variable mh-new-draft-cleaned-headers +gives the headers to clean out of the original message." + (interactive (list (mh-get-msg-num t))) + (let ((from-folder mh-current-folder) + (config (current-window-configuration)) + (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) + (setq buffer-read-only nil) + (goto-char (point-min)) + (cond + ((and + (re-search-forward + (concat "^\\($\\|[Cc]ontent-[Tt]ype:[ \t]+multipart/\\)") nil t) + (not (bolp)) + (re-search-forward "boundary=\"\\([^\"]+\\)\"" nil t)) + (let ((case-fold-search t) + (boundary (buffer-substring (match-beginning 1) (match-end 1)))) + (cond + ((re-search-forward + (concat "^--" boundary "\n" + "content-type:[ \t]+" + "\\(message/rfc822\\|text/rfc822-headers\\)\n" + "\\(.+\n\\)*\n") nil t) + (delete-region (point-min) (point)) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) + (search-forward + (concat "\n--" boundary "--\n") nil t) + (delete-region (match-beginning 0) (point-max))) + (t + (message "Seems no message/rfc822 part."))))) + ((re-search-forward mh-rejected-letter-start nil t) + (skip-chars-forward " \t\n") + (delete-region (point-min) (point)) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)) + (t + (message "Does not appear to be a rejected letter."))) + (goto-char (point-min)) + (if (re-search-forward "^-+$" nil t) + (replace-match "") + ) + (mime/edit-again nil t t) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (mh-compose-and-send-mail draft "" from-folder msg + (mh-get-header-field "To:") + (mh-get-header-field "From:") + (mh-get-header-field "Cc:") + nil nil config))) + +;;; by OKABE Yasuo +;;; 1995/11/14 (cf. [tm-ja:1099]) +(defun tm-mh-e/forward (to cc &optional msg-or-seq) + "Forward a message or message sequence as MIME message/rfc822. +Defaults to displayed message. If optional prefix argument provided, +then prompt for the message sequence. See also documentation for +`\\[mh-send]' function." + (interactive (list (mh-read-address "To: ") + (mh-read-address "Cc: ") + (if current-prefix-arg + (mh-read-seq-default "Forward" t) + (mh-get-msg-num t) + ))) + (or msg-or-seq + (setq msg-or-seq (mh-get-msg-num t))) + (let* ((folder mh-current-folder) + (config (current-window-configuration)) + ;; uses "draft" for compatibility with forw. + ;; forw always leaves file in "draft" since it doesn't have -draft + (draft-name (expand-file-name "draft" mh-user-path)) + (draft (cond ((or (not (file-exists-p draft-name)) + (y-or-n-p "The file `draft' exists. Discard it? ")) + (mh-exec-cmd "comp" + "-noedit" "-nowhatnowproc" + "-form" tm-mh-e/forwcomps + "-nodraftfolder") + (prog1 + (mh-read-draft "" draft-name t) + (mh-insert-fields "To:" to "Cc:" cc) + (set-buffer-modified-p nil))) + (t + (mh-read-draft "" draft-name nil))))) + (let ((msubtype "digest") + orig-from orig-subject multipart-flag + (tag-regexp + (concat "^" + (regexp-quote (mime-make-tag "message" "rfc822")))) + ) + (goto-char (point-min)) + (save-excursion + (save-restriction + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")) + (let ((beg (point))) + (narrow-to-region beg beg) + (mh-exec-cmd-output "pick" nil folder msg-or-seq) + (if (> (count-lines (point) (point-max)) 1) + (setq multipart-flag t) + ) + (while (re-search-forward "^\\([0-9]+\\)\n" nil t) + (let ((forw-msg + (buffer-substring (match-beginning 1) (match-end 1))) + (beg (match-beginning 0)) + (end (match-end 0)) + ) + (save-restriction + (narrow-to-region beg end) + ;; modified for Emacs 18 + (delete-region beg end) + (insert-file-contents + (mh-expand-file-name forw-msg + (mh-expand-file-name folder)) + ) + (save-excursion + (push-mark (point-max)) + (mime-editor/inserted-message-filter)) + (goto-char (point-max)) + ) + (save-excursion + (goto-char beg) + (mime-editor/insert-tag "message" "rfc822") + ))) + (delete-region (point) (point-max)) + (if multipart-flag + (mime-editor/enclose-region "digest" beg (point)) + )))) + (re-search-forward tag-regexp) + (forward-line 1) + (save-restriction + (narrow-to-region (point) (point-max)) + (setq orig-from (mime-eword/decode-string + (mh-get-header-field "From:"))) + (setq orig-subject (mime-eword/decode-string + (mh-get-header-field "Subject:"))) + ) + (let ((forw-subject + (mh-forwarded-letter-subject orig-from orig-subject))) + (mh-insert-fields "Subject:" forw-subject) + (goto-char (point-min)) + (re-search-forward tag-regexp) + (forward-line -1) + (delete-other-windows) + (if (numberp msg-or-seq) + (mh-add-msgs-to-seq msg-or-seq 'forwarded t) + (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t)) + (mh-compose-and-send-mail draft "" folder msg-or-seq + to forw-subject cc + mh-note-forw "Forwarded:" + config))))) + +(cond ((not (featurep 'mh-utils)) + (defun tm-mh-e::insert-letter (folder number verbatim) + (mh-insert-letter verbatim folder number) + ) + ) + ((and (boundp 'mh-e-version) + (string-lessp mh-e-version "5")) + (defun tm-mh-e::insert-letter (folder number verbatim) + (mh-insert-letter number folder verbatim) + ) + ) + (t + (defalias 'tm-mh-e::insert-letter 'mh-insert-letter) + )) + +(defun tm-mh-e/insert-letter (verbatim) + "Interface to mh-insert-letter." + (interactive "P") + (let* + ((folder (mh-prompt-for-folder + "Message from" + (if (and (stringp mh-sent-from-folder) + (string-match "^\\+" mh-sent-from-folder)) + mh-sent-from-folder "+inbox") + nil)) + (number (tm-mh-e/prompt-for-message "Message number: " folder))) + (tm-mh-e::insert-letter folder number verbatim))) + +(defun tm-mh-e/yank-cur-msg-with-no-filter () + "Insert the current message into the draft buffer. +This function makes new show-buffer from article-buffer to disable +variable `mime-viewer/plain-text-preview-hook'. If you don't want to +use text filters for replying message, please set it to +`tm-mh-e/message-yank-function'. +Prefix each non-blank line in the message with the string in +`mh-ins-buf-prefix'. The entire message will be inserted if +`mh-yank-from-start-of-msg' is non-nil. If this variable is nil, the +portion of the message following the point will be yanked. If +`mh-delete-yanked-msg-window' is non-nil, any window displaying the +yanked message will be deleted." + (interactive) + (if (and mh-sent-from-folder mh-sent-from-msg) + (let ((to-point (point)) + (to-buffer (current-buffer))) + (set-buffer mh-sent-from-folder) + (if mh-delete-yanked-msg-window + (delete-windows-on mh-show-buffer)) + (set-buffer mh-show-buffer) ; Find displayed message + (let ((mh-ins-str + (let (mime-viewer/plain-text-preview-hook buf) + (prog1 + (save-window-excursion + (set-buffer mime::preview/article-buffer) + (setq buf (mime/viewer-mode)) + (buffer-string) + ) + (kill-buffer buf))))) + (set-buffer to-buffer) + (save-restriction + (narrow-to-region to-point to-point) + (push-mark) + (insert mh-ins-str) + (mh-insert-prefix-string mh-ins-buf-prefix) + (insert "\n")))) + (error "There is no current message"))) + +(defun tm-mh-e/yank-current-message () + "Insert the current message into the draft buffer. +It uses variable `tm-mh-e/message-yank-function' +to select message yanking function." + (interactive) + (let ((mh-sent-from-folder mh-sent-from-folder) + (mh-sent-from-msg mh-sent-from-msg)) + (if (and (not (stringp mh-sent-from-folder)) + (boundp 'gnus-article-buffer) + (get-buffer gnus-article-buffer) + (bufferp mh-sent-from-folder) + ) ; might be called from GNUS + (if (boundp 'gnus-article-copy) ; might be sgnus + (save-excursion + (gnus-copy-article-buffer) + (setq mh-sent-from-folder gnus-article-copy) + (set-buffer mh-sent-from-folder) + (setq mh-show-buffer gnus-article-copy) + ) + (save-excursion + (setq mh-sent-from-folder gnus-article-buffer) + (set-buffer gnus-article-buffer) + (setq mh-show-buffer (current-buffer)) + ))) + (funcall tm-mh-e/message-yank-function) + )) + +(substitute-key-definition + 'mh-yank-cur-msg 'tm-mh-e/yank-current-message mh-letter-mode-map) +(substitute-key-definition + 'mh-insert-letter 'tm-mh-e/insert-letter mh-letter-mode-map) + + +;;; @ end +;;; + +(provide 'tmh-comp) +(require 'tm-mh-e) + +;;; tmh-comp.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/utils/elp.el --- a/lisp/utils/elp.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/utils/elp.el Mon Aug 13 08:46:56 2007 +0200 @@ -2,11 +2,11 @@ ;; Copyright (C) 1994 Free Software Foundation, Inc. -;; Author: 1994-1995 Barry A. Warsaw -;; Maintainer: tools-help@merlin.cnri.reston.va.us +;; Author: 1994-1996 Barry A. Warsaw +;; Maintainer: tools-help@python.org ;; Created: 26-Feb-1994 -;; Version: 2.32 -;; Last Modified: 1995/07/12 18:53:17 +;; Version: 2.37 +;; Last Modified: 1996/10/23 04:06:58 ;; Keywords: debugging lisp tools ;; This file is part of GNU Emacs. @@ -25,12 +25,6 @@ ;; along with GNU Emacs; 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. -;;; In typical "What the hell?" fashion, the version distributed -;;; with FSF 19.30 claims to be version 2.33 while ours is version 2.32, -;;; but ours is actually more recent. Is this another example of -;;; FSFmacs version corruption? - ;;; Commentary: ;; ;; If you want to profile a bunch of functions, set elp-function-list @@ -81,16 +75,6 @@ ;; elp-restore-function. The other instrument, restore, and reset ;; functions are provided for symmetry. -;; Note that there are plenty of factors that could make the times -;; reported unreliable, including the accuracy and granularity of your -;; system clock, and the overhead spent in lisp calculating and -;; recording the intervals. The latter I figure is pretty constant -;; so, while the times may not be entirely accurate, I think they'll -;; give you a good feel for the relative amount of work spent in the -;; various lisp routines you are profiling. Note further that times -;; are calculated using wall-clock time, so other system load will -;; affect accuracy too. - ;; Here is a list of variable you can use to customize elp: ;; elp-function-list ;; elp-reset-after-results @@ -145,11 +129,6 @@ ;; Make this act like a real profiler, so that it records time spent ;; in all branches of execution. -;; LCD Archive Entry: -;; elp|Barry A. Warsaw|tools-help@merlin.cnri.reston.va.us| -;; Emacs Lisp Profiler| -;; 1995/07/12 18:53:17|2.32|~/misc/elp.el.Z| - ;;; Code: @@ -198,10 +177,10 @@ ;; end of user configuration variables -(defconst elp-version "2.32" +(defconst elp-version "2.37" "ELP version number.") -(defconst elp-help-address "tools-help@merlin.cnri.reston.va.us" +(defconst elp-help-address "tools-help@python.org" "Address accepting submissions of bug reports and questions.") (defvar elp-results-buffer "*ELP Profiling Results*" @@ -226,15 +205,30 @@ "Instrument FUNSYM for profiling. FUNSYM must be a symbol of a defined function." (interactive "aFunction to instrument: ") - ;; raise an error if the function is already instrumented - (and (get funsym elp-timer-info-property) - (error "Symbol `%s' is already instrumented for profiling." funsym)) + ;; restore the function. this is necessary to avoid infinite + ;; recursion of already instrumented functions (i.e. elp-wrapper + ;; calling elp-wrapper ad infinitum). it is better to simply + ;; restore the function than to throw an error. this will work + ;; properly in the face of eval-defun because if the function was + ;; redefined, only the timer info will be nil'd out since + ;; elp-restore-function is smart enough not to trash the new + ;; definition. + (elp-restore-function funsym) (let* ((funguts (symbol-function funsym)) (infovec (vector 0 0 funguts)) (newguts '(lambda (&rest args)))) ;; we cannot profile macros (and (eq (car-safe funguts) 'macro) - (error "ELP cannot profile macro %s" funsym)) + (error "ELP cannot profile macro: %s" funsym)) + ;; TBD: at some point it might be better to load the autoloaded + ;; function instead of throwing an error. if we do this, then we + ;; probably want elp-instrument-package to be updated with the + ;; newly loaded list of functions. i'm not sure it's smart to do + ;; the autoload here, since that could have side effects, and + ;; elp-instrument-function is similar (in my mind) to defun-ish + ;; type functionality (i.e. it shouldn't execute the function). + (and (eq (car-safe funguts) 'autoload) + (error "ELP cannot profile autoloaded function: %s" funsym)) ;; put rest of newguts together (if (commandp funsym) (setq newguts (append newguts '((interactive))))) @@ -300,10 +294,12 @@ ;; because its possible the function got un-instrumented due to ;; circumstances beyond our control. Also, check to make sure ;; that the current function symbol points to elp-wrapper. If - ;; not, then the user probably did an eval-defun while the - ;; function was instrumented and we don't want to destroy the new - ;; definition. + ;; not, then the user probably did an eval-defun, or loaded a + ;; byte-compiled version, while the function was instrumented and + ;; we don't want to destroy the new definition. can it ever be + ;; the case that a lisp function can be compiled instrumented? (and info + (not (compiled-function-p (symbol-function funsym))) (assq 'elp-wrapper (symbol-function funsym)) (fset funsym (aref info 2))))) @@ -313,13 +309,7 @@ Use optional LIST if provided instead." (interactive "PList of functions to instrument: ") (let ((list (or list elp-function-list))) - (mapcar - (function - (lambda (funsym) - (condition-case nil - (elp-instrument-function funsym) - (error nil)))) - list))) + (mapcar 'elp-instrument-function list))) ;;;###autoload (defun elp-instrument-package (prefix) @@ -597,5 +587,4 @@ (provide 'elp) - ;; elp.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/utils/flow-ctrl.el --- a/lisp/utils/flow-ctrl.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/utils/flow-ctrl.el Mon Aug 13 08:46:56 2007 +0200 @@ -21,27 +21,28 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.28. +;;; Synched up with: FSF 19.34. ;;; Commentary: -;;;; Terminals that use XON/XOFF flow control can cause problems with -;;;; GNU Emacs users. This file contains Emacs Lisp code that makes it -;;;; easy for a user to deal with this problem, when using such a -;;;; terminal. -;;;; -;;;; To invoke these adjustments, a user need only invoke the function -;;;; enable-flow-control-on with a list of terminal types in his/her own -;;;; .emacs file. As arguments, give it the names of one or more terminal -;;;; types in use by that user which require flow control adjustments. -;;;; Here's an example: -;;;; -;;;; (enable-flow-control-on "vt200" "vt300" "vt101" "vt131") +;; Terminals that use XON/XOFF flow control can cause problems with +;; GNU Emacs users. This file contains Emacs Lisp code that makes it +;; easy for a user to deal with this problem, when using such a +;; terminal. +;; +;; To invoke these adjustments, a user need only invoke the function +;; enable-flow-control-on with a list of terminal types in his/her own +;; .emacs file. As arguments, give it the names of one or more terminal +;; types in use by that user which require flow control adjustments. +;; Here's an example: +;; +;; (enable-flow-control-on "vt200" "vt300" "vt101" "vt131") -;;; Portability note: This uses (getenv "TERM"), and therefore probably -;;; won't work outside of UNIX-like environments. +;; Portability note: This uses (getenv "TERM"), and therefore probably +;; won't work outside of UNIX-like environments. ;;; Code: @@ -50,6 +51,8 @@ (defvar flow-control-c-q-replacement ?\036 "Character that replaces C-q, when flow control handling is enabled.") +;(put 'keyboard-translate-table 'char-table-extra-slots 0) + ;;;###autoload (defun enable-flow-control (&optional argument) "Toggle flow control handling. @@ -64,6 +67,7 @@ (progn ;; Turn flow control off, and stop exchanging chars. (set-input-mode t nil (nth 2 (current-input-mode))) + ;; XEmacs (keyboard-translate flow-control-c-s-replacement nil) (keyboard-translate ?\^s nil) (keyboard-translate flow-control-c-q-replacement nil) @@ -73,6 +77,7 @@ (set-input-mode nil t (nth 2 (current-input-mode))) ;; Initialize translate table, saving previous mappings, if any. ;; Swap C-s and C-\ + ;; XEmacs (keyboard-translate flow-control-c-s-replacement ?\^s) (keyboard-translate ?\^s flow-control-c-s-replacement) ;; Swap C-q and C-^ @@ -97,12 +102,18 @@ The tty terminal type is determined from the TERM environment variable. Trailing hyphens and everything following is stripped, so a TERM value of \"vt100-nam\" is treated the same as \"vt100\"." - (and - (eq (device-type) 'tty) - (getenv "TERM") - (member (replace-in-string (getenv "TERM") "[-_].*$" "") - losing-terminal-types) - (enable-flow-control))) + (let ((term (getenv "TERM")) + hyphend) + ;; Look for TERM in LOSING-TERMINAL-TYPES. + ;; If we don't find it literally, try stripping off words + ;; from the end, one by one. + (while (and term (not (member term losing-terminal-types))) + ;; Strip off last hyphen and what follows, then try again. + (if (setq hyphend (string-match "[-_][^-_]+$" term)) + (setq term (substring term 0 hyphend)) + (setq term nil))) + (if term + (enable-flow-control)))) (provide 'flow-ctrl) diff -r 30df88044ec6 -r b82b59fe008d lisp/utils/forms.el --- a/lisp/utils/forms.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/utils/forms.el Mon Aug 13 08:46:56 2007 +0200 @@ -1,8 +1,8 @@ -;;; forms.el --- Forms mode: edit a file as a form to fill in. +;;; forms.el --- Forms mode: edit a file as a form to fill in -;;; Copyright (C) 1991, 1993 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1994, 1995, 1996 Free Software Foundation, Inc. -;; Author: Johan Vromans +;; Author: Johan Vromans ;; Version: Revision: 2.10 ;; Keywords: extensions ;; hacked on by jwz for XEmacs @@ -21,260 +21,277 @@ ;; 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. +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. -;;; Synched up with: FSF 19.28. +;;; Synched up with: FSF 19.34. ;;; Commentary: -;;; Visit a file using a form. -;;; -;;; === Naming conventions -;;; -;;; The names of all variables and functions start with 'forms-'. -;;; Names which start with 'forms--' are intended for internal use, and -;;; should *NOT* be used from the outside. -;;; -;;; All variables are buffer-local, to enable multiple forms visits -;;; simultaneously. -;;; Variable `forms--mode-setup' is local to *ALL* buffers, for it -;;; controls if forms-mode has been enabled in a buffer. -;;; -;;; === How it works === -;;; -;;; Forms mode means visiting a data file which is supposed to consist -;;; of records each containing a number of fields. The records are -;;; separated by a newline, the fields are separated by a user-defined -;;; field separater (default: TAB). -;;; When shown, a record is transferred to an Emacs buffer and -;;; presented using a user-defined form. One record is shown at a -;;; time. -;;; -;;; Forms mode is a composite mode. It involves two files, and two -;;; buffers. -;;; The first file, called the control file, defines the name of the -;;; data file and the forms format. This file buffer will be used to -;;; present the forms. -;;; The second file holds the actual data. The buffer of this file -;;; will be buried, for it is never accessed directly. -;;; -;;; Forms mode is invoked using M-x forms-find-file control-file . -;;; Alternativily `forms-find-file-other-window' can be used. -;;; -;;; You may also visit the control file, and switch to forms mode by hand -;;; with M-x forms-mode . -;;; -;;; Automatic mode switching is supported if you specify -;;; "-*- forms -*-" in the first line of the control file. -;;; -;;; The control file is visited, evaluated using `eval-current-buffer', -;;; and should set at least the following variables: -;;; -;;; forms-file [string] -;;; The name of the data file. -;;; -;;; forms-number-of-fields [integer] -;;; The number of fields in each record. -;;; -;;; forms-format-list [list] -;;; Formatting instructions. -;;; -;;; `forms-format-list' should be a list, each element containing -;;; -;;; - a string, e.g. "hello". The string is inserted in the forms -;;; "as is". -;;; -;;; - an integer, denoting a field number. -;;; The contents of this field are inserted at this point. -;;; Fields are numbered starting with number one. -;;; -;;; - a function call, e.g. (insert "text"). -;;; This function call is dynamically evaluated and should return a -;;; string. It should *NOT* have side-effects on the forms being -;;; constructed. The current fields are available to the function -;;; in the variable `forms-fields', they should *NOT* be modified. -;;; -;;; - a lisp symbol, that must evaluate to one of the above. -;;; -;;; Optional variables which may be set in the control file: -;;; -;;; forms-field-sep [string, default TAB] -;;; The field separator used to separate the -;;; fields in the data file. It may be a string. -;;; -;;; forms-read-only [bool, default nil] -;;; Non-nil means that the data file is visited -;;; read-only (view mode) as opposed to edit mode. -;;; If no write access to the data file is -;;; possible, view mode is enforced. -;;; -;;; forms-multi-line [string, default "^K"] -;;; If non-null the records of the data file may -;;; contain fields that can span multiple lines in -;;; the form. -;;; This variable denotes the separator character -;;; to be used for this purpose. Upon display, all -;;; occurrencies of this character are translated -;;; to newlines. Upon storage they are translated -;;; back to the separator character. -;;; -;;; forms-forms-scroll [bool, default nil] -;;; Non-nil means: rebind locally the commands that -;;; perform `scroll-up' or `scroll-down' to use -;;; `forms-next-field' resp. `forms-prev-field'. -;;; -;;; forms-forms-jump [bool, default nil] -;;; Non-nil means: rebind locally the commands that -;;; perform `beginning-of-buffer' or `end-of-buffer' -;;; to perform `forms-first-field' resp. `forms-last-field'. -;;; -;;; forms-read-file-filter [symbol, default nil] -;;; If not nil: this should be the name of a -;;; function that is called after the forms data file -;;; has been read. It can be used to transform -;;; the contents of the file into a format more suitable -;;; for forms-mode processing. -;;; -;;; forms-write-file-filter [symbol, default nil] -;;; If not nil: this should be the name of a -;;; function that is called before the forms data file -;;; is written (saved) to disk. It can be used to undo -;;; the effects of `forms-read-file-filter', if any. -;;; -;;; forms-new-record-filter [symbol, default nil] -;;; If not nil: this should be the name of a -;;; function that is called when a new -;;; record is created. It can be used to fill in -;;; the new record with default fields, for example. -;;; -;;; forms-modified-record-filter [symbol, default nil] -;;; If not nil: this should be the name of a -;;; function that is called when a record has -;;; been modified. It is called after the fields -;;; are parsed. It can be used to register -;;; modification dates, for example. -;;; -;;; forms-use-extents [bool, see text for default] -;;; forms-use-text-properties [bool, see text for default] -;;; These variables control if forms mode should use -;;; text properties or extents to protect the form text -;;; from being modified (using text-property `read-only'). -;;; Also, the read-write fields are shown using a -;;; distinct face, if possible. -;;; One of these variables defaults to t if running -;;; FSF or Lucid Emacs 19. -;;; -;;; forms-ro-face [symbol, default 'default] -;;; This is the face that is used to show -;;; read-only text on the screen.If used, this -;;; variable should be set to a symbol that is a -;;; valid face. -;;; E.g. -;;; (make-face 'my-face) -;;; (setq forms-ro-face 'my-face) -;;; -;;; forms-rw-face [symbol, default 'region] -;;; This is the face that is used to show -;;; read-write text on the screen. -;;; -;;; After evaluating the control file, its buffer is cleared and used -;;; for further processing. -;;; The data file (as designated by `forms-file') is visited in a buffer -;;; `forms--file-buffer' which will not normally be shown. -;;; Great malfunctioning may be expected if this file/buffer is modified -;;; outside of this package while it is being visited! -;;; -;;; Normal operation is to transfer one line (record) from the data file, -;;; split it into fields (into `forms--the-record-list'), and display it -;;; using the specs in `forms-format-list'. -;;; A format routine `forms--format' is built upon startup to format -;;; the records according to `forms-format-list'. -;;; -;;; When a form is changed the record is updated as soon as this form -;;; is left. The contents of the form are parsed using information -;;; obtained from `forms-format-list', and the fields which are -;;; deduced from the form are modified. Fields not shown on the forms -;;; retain their origional values. The newly formed record then -;;; replaces the contents of the old record in `forms--file-buffer'. -;;; A parse routine `forms--parser' is built upon startup to parse -;;; the records. -;;; -;;; Two exit functions exist: `forms-exit' and `forms-exit-no-save'. -;;; `forms-exit' saves the data to the file, if modified. -;;; `forms-exit-no-save` does not. However, if `forms-exit-no-save' -;;; is executed and the file buffer has been modified, Emacs will ask -;;; questions anyway. -;;; -;;; Other functions provided by forms mode are: -;;; -;;; paging (forward, backward) by record -;;; jumping (first, last, random number) -;;; searching -;;; creating and deleting records -;;; reverting the form (NOT the file buffer) -;;; switching edit <-> view mode v.v. -;;; jumping from field to field -;;; -;;; As an documented side-effect: jumping to the last record in the -;;; file (using forms-last-record) will adjust forms--total-records if -;;; needed. -;;; -;;; The forms buffer can be in on eof two modes: edit mode or view -;;; mode. View mode is a read-only mode, you cannot modify the -;;; contents of the buffer. -;;; -;;; Edit mode commands: -;;; -;;; TAB forms-next-field -;;; \C-c TAB forms-next-field -;;; \C-c < forms-first-record -;;; \C-c > forms-last-record -;;; \C-c ? describe-mode -;;; \C-c \C-k forms-delete-record -;;; \C-c \C-q forms-toggle-read-only -;;; \C-c \C-o forms-insert-record -;;; \C-c \C-l forms-jump-record -;;; \C-c \C-n forms-next-record -;;; \C-c \C-p forms-prev-record -;;; \C-c \C-s forms-search -;;; \C-c \C-x forms-exit -;;; -;;; Read-only mode commands: -;;; -;;; SPC forms-next-record -;;; DEL forms-prev-record -;;; ? describe-mode -;;; \C-q forms-toggle-read-only -;;; l forms-jump-record -;;; n forms-next-record -;;; p forms-prev-record -;;; s forms-search -;;; x forms-exit -;;; -;;; Of course, it is also possible to use the \C-c prefix to obtain the -;;; same command keys as in edit mode. -;;; -;;; The following bindings are available, independent of the mode: -;;; -;;; [next] forms-next-record -;;; [prior] forms-prev-record -;;; [begin] forms-first-record -;;; [end] forms-last-record -;;; [S-TAB] forms-prev-field -;;; [backtab] forms-prev-field -;;; -;;; For convenience, TAB is always bound to `forms-next-field', so you -;;; don't need the C-c prefix for this command. -;;; -;;; As mentioned above (see `forms-forms-scroll' and `forms-forms-jump') -;;; the bindings of standard functions `scroll-up', `scroll-down', -;;; `beginning-of-buffer' and `end-of-buffer' can be locally replaced with -;;; forms mode functions next/prev record and first/last -;;; record. -;;; -;;; `local-write-file hook' is defined to save the actual data file -;;; instead of the buffer data, `revert-file-hook' is defined to -;;; revert a forms to original. +;; Visit a file using a form. +;; +;; === Naming conventions +;; +;; The names of all variables and functions start with 'forms-'. +;; Names which start with 'forms--' are intended for internal use, and +;; should *NOT* be used from the outside. +;; +;; All variables are buffer-local, to enable multiple forms visits +;; simultaneously. +;; Variable `forms--mode-setup' is local to *ALL* buffers, for it +;; controls if forms-mode has been enabled in a buffer. +;; +;; === How it works === +;; +;; Forms mode means visiting a data file which is supposed to consist +;; of records each containing a number of fields. The records are +;; separated by a newline, the fields are separated by a user-defined +;; field separator (default: TAB). +;; When shown, a record is transferred to an Emacs buffer and +;; presented using a user-defined form. One record is shown at a +;; time. +;; +;; Forms mode is a composite mode. It involves two files, and two +;; buffers. +;; The first file, called the control file, defines the name of the +;; data file and the forms format. This file buffer will be used to +;; present the forms. +;; The second file holds the actual data. The buffer of this file +;; will be buried, for it is never accessed directly. +;; +;; Forms mode is invoked using M-x forms-find-file control-file . +;; Alternatively `forms-find-file-other-window' can be used. +;; +;; You may also visit the control file, and switch to forms mode by hand +;; with M-x forms-mode . +;; +;; Automatic mode switching is supported if you specify +;; "-*- forms -*-" in the first line of the control file. +;; +;; The control file is visited, evaluated using `eval-current-buffer', +;; and should set at least the following variables: +;; +;; forms-file [string] +;; The name of the data file. +;; +;; forms-number-of-fields [integer] +;; The number of fields in each record. +;; +;; forms-format-list [list] +;; Formatting instructions. +;; +;; `forms-format-list' should be a list, each element containing +;; +;; - a string, e.g. "hello". The string is inserted in the forms +;; "as is". +;; +;; - an integer, denoting a field number. +;; The contents of this field are inserted at this point. +;; Fields are numbered starting with number one. +;; +;; - a function call, e.g. (insert "text"). +;; This function call is dynamically evaluated and should return a +;; string. It should *NOT* have side-effects on the forms being +;; constructed. The current fields are available to the function +;; in the variable `forms-fields', they should *NOT* be modified. +;; +;; - a lisp symbol, that must evaluate to one of the above. +;; +;; Optional variables which may be set in the control file: +;; +;; forms-field-sep [string, default TAB] +;; The field separator used to separate the +;; fields in the data file. It may be a string. +;; +;; forms-read-only [bool, default nil] +;; Non-nil means that the data file is visited +;; read-only (view mode) as opposed to edit mode. +;; If no write access to the data file is +;; possible, view mode is enforced. +;; +;; forms-check-number-of-fields [bool, default t] +;; If non-nil, a warning will be issued whenever +;; a record is found that does not have the number +;; of fields specified by `forms-number-of-fields'. +;; +;; forms-multi-line [string, default "^K"] +;; If non-null the records of the data file may +;; contain fields that can span multiple lines in +;; the form. +;; This variable denotes the separator character +;; to be used for this purpose. Upon display, all +;; occurrences of this character are translated +;; to newlines. Upon storage they are translated +;; back to the separator character. +;; +;; forms-forms-scroll [bool, default nil] +;; Non-nil means: rebind locally the commands that +;; perform `scroll-up' or `scroll-down' to use +;; `forms-next-field' resp. `forms-prev-field'. +;; +;; forms-forms-jump [bool, default nil] +;; Non-nil means: rebind locally the commands that +;; perform `beginning-of-buffer' or `end-of-buffer' +;; to perform `forms-first-field' and `forms-last-field'. +;; +;; forms-insert-after [bool, default nil] +;; Non-nil means: inserts of new records go after +;; current record, also initial position is at last +;; record. +;; +;; forms-read-file-filter [symbol, default nil] +;; If not nil: this should be the name of a +;; function that is called after the forms data file +;; has been read. It can be used to transform +;; the contents of the file into a format more suitable +;; for forms-mode processing. +;; +;; forms-write-file-filter [symbol, default nil] +;; If not nil: this should be the name of a +;; function that is called before the forms data file +;; is written (saved) to disk. It can be used to undo +;; the effects of `forms-read-file-filter', if any. +;; +;; forms-new-record-filter [symbol, default nil] +;; If not nil: this should be the name of a +;; function that is called when a new +;; record is created. It can be used to fill in +;; the new record with default fields, for example. +;; +;; forms-modified-record-filter [symbol, default nil] +;; If not nil: this should be the name of a +;; function that is called when a record has +;; been modified. It is called after the fields +;; are parsed. It can be used to register +;; modification dates, for example. +;; +;; forms-use-extents [bool, see text for default] +;; forms-use-text-properties [bool, see text for default] +;; These variables control if forms mode should use +;; text properties or extents to protect the form text +;; from being modified (using text-property `read-only'). +;; Also, the read-write fields are shown using a +;; distinct face, if possible. +;; As of emacs 19.29, the `intangible' text property +;; is used to prevent moving into read-only fields. +;; This variable defaults to t if running Emacs 19 +;; with text properties. +;; The default face to show read-write fields is +;; copied from face `region'. +;; +;; forms-ro-face [symbol, default 'default] +;; This is the face that is used to show +;; read-only text on the screen.If used, this +;; variable should be set to a symbol that is a +;; valid face. +;; E.g. +;; (make-face 'my-face) +;; (setq forms-ro-face 'my-face) +;; +;; forms-rw-face [symbol, default 'region] +;; This is the face that is used to show +;; read-write text on the screen. +;; +;; After evaluating the control file, its buffer is cleared and used +;; for further processing. +;; The data file (as designated by `forms-file') is visited in a buffer +;; `forms--file-buffer' which will not normally be shown. +;; Great malfunctioning may be expected if this file/buffer is modified +;; outside of this package while it is being visited! +;; +;; Normal operation is to transfer one line (record) from the data file, +;; split it into fields (into `forms--the-record-list'), and display it +;; using the specs in `forms-format-list'. +;; A format routine `forms--format' is built upon startup to format +;; the records according to `forms-format-list'. +;; +;; When a form is changed the record is updated as soon as this form +;; is left. The contents of the form are parsed using information +;; obtained from `forms-format-list', and the fields which are +;; deduced from the form are modified. Fields not shown on the forms +;; retain their original values. The newly formed record then +;; replaces the contents of the old record in `forms--file-buffer'. +;; A parse routine `forms--parser' is built upon startup to parse +;; the records. +;; +;; Two exit functions exist: `forms-exit' and `forms-exit-no-save'. +;; `forms-exit' saves the data to the file, if modified. +;; `forms-exit-no-save` does not. However, if `forms-exit-no-save' +;; is executed and the file buffer has been modified, Emacs will ask +;; questions anyway. +;; +;; Other functions provided by forms mode are: +;; +;; paging (forward, backward) by record +;; jumping (first, last, random number) +;; searching +;; creating and deleting records +;; reverting the form (NOT the file buffer) +;; switching edit <-> view mode v.v. +;; jumping from field to field +;; +;; As an documented side-effect: jumping to the last record in the +;; file (using forms-last-record) will adjust forms--total-records if +;; needed. +;; +;; The forms buffer can be in on eof two modes: edit mode or view +;; mode. View mode is a read-only mode, you cannot modify the +;; contents of the buffer. +;; +;; Edit mode commands: +;; +;; TAB forms-next-field +;; \C-c TAB forms-next-field +;; \C-c < forms-first-record +;; \C-c > forms-last-record +;; \C-c ? describe-mode +;; \C-c \C-k forms-delete-record +;; \C-c \C-q forms-toggle-read-only +;; \C-c \C-o forms-insert-record +;; \C-c \C-l forms-jump-record +;; \C-c \C-n forms-next-record +;; \C-c \C-p forms-prev-record +;; \C-c \C-r forms-search-backward +;; \C-c \C-s forms-search-forward +;; \C-c \C-x forms-exit +;; +;; Read-only mode commands: +;; +;; SPC forms-next-record +;; DEL forms-prev-record +;; ? describe-mode +;; \C-q forms-toggle-read-only +;; l forms-jump-record +;; n forms-next-record +;; p forms-prev-record +;; r forms-search-backward +;; s forms-search-forward +;; x forms-exit +;; +;; Of course, it is also possible to use the \C-c prefix to obtain the +;; same command keys as in edit mode. +;; +;; The following bindings are available, independent of the mode: +;; +;; [next] forms-next-record +;; [prior] forms-prev-record +;; [begin] forms-first-record +;; [end] forms-last-record +;; [S-TAB] forms-prev-field +;; [backtab] forms-prev-field +;; +;; For convenience, TAB is always bound to `forms-next-field', so you +;; don't need the C-c prefix for this command. +;; +;; As mentioned above (see `forms-forms-scroll' and `forms-forms-jump') +;; the bindings of standard functions `scroll-up', `scroll-down', +;; `beginning-of-buffer' and `end-of-buffer' can be locally replaced with +;; forms mode functions next/prev record and first/last +;; record. +;; +;; `local-write-file hook' is defined to save the actual data file +;; instead of the buffer data, `revert-file-hook' is defined to +;; revert a forms to original. ;;; Code: @@ -283,10 +300,10 @@ (provide 'forms) ;;; official (provide 'forms-mode) ;;; for compatibility -(defconst forms-version (substring "!Revision: 2.10 !" 11 -2) +(defconst forms-version (substring "$Revision: 1.1.1.2 $" 11 -2) "The version number of forms-mode (as string). The complete RCS id is: - !Id: forms.el,v 2.10 1994/07/26 21:31:13 rms Exp !") + $Id: forms.el,v 1.1.1.2 1996/12/18 03:54:04 steve Exp $") (defvar forms-mode-hooks nil "Hook functions to be run upon entering Forms mode.") @@ -304,6 +321,9 @@ ;;; Optional variables with default values. +(defvar forms-check-number-of-fields t + "*If non-nil, warn about records with wrong number of fields.") + (defvar forms-field-sep "\t" "Field separator character (default TAB).") @@ -347,10 +367,14 @@ Defaults to t if this emacs is capable of handling text properties.") (defvar forms-use-text-properties (and (fboundp 'set-text-properties) - (not forms-use-extents)) + (not forms-use-extents)) ; XEmacs "*Non-nil means: use emacs-19 text properties. Defaults to t if this emacs is capable of handling text properties.") +(defvar forms-insert-after nil + "*Non-nil means: inserts of new records go after current record. +Also, initial position is at last record.") + (defvar forms-ro-face (if (string-match "XEmacs" emacs-version) 'forms-label-face 'default) @@ -391,7 +415,7 @@ "List of strings of the current record, as parsed from the file.") (defvar forms--search-regexp nil - "Last regexp used by forms-search.") + "Last regexp used by forms-search functions.") (defvar forms--format nil "Formatting routine.") @@ -414,27 +438,27 @@ (defvar forms--rw-face nil "Face used to represent read-write data on the screen.") - ;;;###autoload (defun forms-mode (&optional primary) "Major mode to visit files in a field-structured manner using a form. Commands: Equivalent keys in read-only mode: - - TAB forms-next-field TAB - C-c TAB forms-next-field - C-c < forms-first-record < - C-c > forms-last-record > - C-c ? describe-mode ? - C-c C-k forms-delete-record - C-c C-q forms-toggle-read-only q - C-c C-o forms-insert-record - C-c C-l forms-jump-record l - C-c C-n forms-next-record n - C-c C-p forms-prev-record p - C-c C-s forms-search s - C-c C-x forms-exit x" + TAB forms-next-field TAB + \\C-c TAB forms-next-field + \\C-c < forms-first-record < + \\C-c > forms-last-record > + \\C-c ? describe-mode ? + \\C-c \\C-k forms-delete-record + \\C-c \\C-q forms-toggle-read-only q + \\C-c \\C-o forms-insert-record + \\C-c \\C-l forms-jump-record l + \\C-c \\C-n forms-next-record n + \\C-c \\C-p forms-prev-record p + \\C-c \\C-r forms-search-backward r + \\C-c \\C-s forms-search-forward s + \\C-c \\C-x forms-exit x +" (interactive) ;; This is not a simple major mode, as usual. Therefore, forms-mode @@ -465,6 +489,7 @@ (make-local-variable 'forms-multi-line) (make-local-variable 'forms-forms-scroll) (make-local-variable 'forms-forms-jump) + (make-local-variable 'forms-insert-after) ;; (make-local-variable 'forms-use-text-properties) ;; Filter functions. @@ -479,7 +504,7 @@ (setq forms-new-record-filter nil) (setq forms-modified-record-filter nil) - (if forms--lemacs-p + (if forms--lemacs-p ; XEmacs (progn ;; forms-field-face defaults to bold. ;; forms-label-face defaults to no attributes @@ -577,8 +602,7 @@ (make-local-variable 'forms--dynamic-text) ;; Prevent accidental overwrite of the control file and autosave. - (setq buffer-file-name nil) - (auto-save-mode nil) + (set-visited-file-name nil) ;; Prepare this buffer for further processing. (setq buffer-read-only nil) @@ -620,6 +644,10 @@ ;;(message "forms: building keymap... done.") ) + ;; set the major mode indicator + (setq major-mode 'forms-mode) + (setq mode-name "Forms") + ;; find the data file (setq forms--file-buffer (find-file-noselect forms-file)) @@ -629,9 +657,10 @@ (if read-file-filter (save-excursion (set-buffer forms--file-buffer) - (let ((inhibit-read-only t)) - (run-hooks 'read-file-filter)) - (set-buffer-modified-p nil) + (let ((inhibit-read-only t) + (file-modified (buffer-modified-p))) + (run-hooks 'read-file-filter) + (if (not file-modified) (set-buffer-modified-p nil))) (if write-file-filter (progn (make-variable-buffer-local 'local-write-file-hooks) @@ -640,7 +669,8 @@ (save-excursion (set-buffer forms--file-buffer) (make-variable-buffer-local 'local-write-file-hooks) - (setq local-write-file-hooks write-file-filter))))) + ;; (setq local-write-file-hooks (list write-file-filter)))))) + (add-hook 'local-write-file-hooks 'write-file-filter))))) ;; count the number of records, and set see if it may be modified (let (ro) @@ -659,9 +689,6 @@ (setq forms-read-only t))) ;;(message "forms: proceeding setup...") - ;; set the major mode indicator - (setq major-mode 'forms-mode) - (setq mode-name "Forms") ;; Since we aren't really implementing a minor mode, we hack the modeline ;; directly to get the text " View " into forms-read-only form buffers. For @@ -683,8 +710,8 @@ (insert "GNU Emacs Forms Mode version " forms-version "\n\n" (if (file-exists-p forms-file) - (concat "No records available in file \"" forms-file "\".\n\n") - (format "Creating new file \"%s\"\nwith %d field%s per record.\n\n" + (concat "No records available in file `" forms-file "'\n\n") + (format "Creating new file `%s'\nwith %d field%s per record\n\n" forms-file forms-number-of-fields (if (= 1 forms-number-of-fields) "" "s"))) "Use " (substitute-command-keys "\\[forms-insert-record]") @@ -699,6 +726,10 @@ (forms-jump-record forms--current-record) ) + (if forms-insert-after + (forms-last-record) + (forms-first-record)) + ;; user customising ;;(message "forms: proceeding setup (user hooks)...") (run-hooks 'forms-mode-hooks) @@ -716,7 +747,7 @@ ;; of the fields on the display. This array is used by ;; `forms--parser-using-text-properties' to extract the fields data ;; from the form on the screen. - ;; Upon completion, `forms-format-list' is garanteed correct, so + ;; Upon completion, `forms-format-list' is guaranteed correct, so ;; `forms--make-format' and `forms--make-parser' do not need to perform ;; any checks. @@ -788,8 +819,8 @@ ;; Validate. (or (fboundp (car-safe el)) (error (concat "Forms format error: " - "not a function " - (prin1-to-string (car-safe el))))) + "not a function %S") + (car-safe el))) ;; Shift. (if prev-item @@ -800,8 +831,8 @@ ;; else (t (error (concat "Forms format error: " - "invalid element " - (prin1-to-string el))))) + "invalid element %S") + el))) ;; Advance to next element of the list. (setq the-list rem))) @@ -909,12 +940,12 @@ (,@ (if (numberp (car forms-format-list)) nil '((add-text-properties (point-min) (1+ (point-min)) - '(front-sticky (read-only)))))) + '(front-sticky (read-only intangible)))))) ;; Prevent insertion after the last text. (remove-text-properties (1- (point)) (point) '(rear-nonsticky))) (setq forms--iif-start nil))) - (if forms-use-extents + (if forms-use-extents ; XEmacs version (` (lambda (arg) (,@ (apply 'append (mapcar 'forms--make-format-elt-using-extents @@ -1037,8 +1068,10 @@ (point)) (list 'face forms--ro-face ; read-only appearance 'read-only (,@ (list (1+ forms--marker))) + 'intangible t 'insert-in-front-hooks '(forms--iif-hook) - 'rear-nonsticky '(face read-only insert-in-front-hooks)))))) + 'rear-nonsticky '(face read-only insert-in-front-hooks + intangible)))))) ((numberp el) (` ((let ((here (point))) @@ -1064,12 +1097,15 @@ (point)) (list 'face forms--ro-face 'read-only (,@ (list (1+ forms--marker))) + 'intangible t 'insert-in-front-hooks '(forms--iif-hook) - 'rear-nonsticky '(read-only face insert-in-front-hooks)))))) + 'rear-nonsticky '(read-only face insert-in-front-hooks + intangible)))))) ;; end of cond )) +;; XEmacs (defun forms--make-format-elt-using-extents (el) "Helper routine to generate format function." @@ -1237,9 +1273,9 @@ (if (setq there (next-single-property-change here 'read-only)) (aset forms--recordv (aref forms--elements i) - (buffer-substring here there)) + (buffer-substring-no-properties here there)) (aset forms--recordv (aref forms--elements i) - (buffer-substring here (point-max))))) + (buffer-substring-no-properties here (point-max))))) (setq i (1+ i))))) (defun forms--make-parser-elt (el) @@ -1261,7 +1297,7 @@ ;; (setq here (point)) ;; (if (not (search-forward "\nmore text: " nil t nil)) ;; (error "Parse error: cannot find \"\\nmore text: \"")) - ;; (aset forms--recordv 5 (buffer-substring here (- (point) 12))) + ;; (aset forms--recordv 5 (buffer-substring-no-properties here (- (point) 12))) ;; ;; ;; (tocol 40) ;; (let ((forms--dyntext (car-safe forms--dynamic-text))) @@ -1271,7 +1307,7 @@ ;; (setq forms--dynamic-text (cdr-safe forms--dynamic-text))) ;; ... ;; ;; final flush (due to terminator sentinel, see below) - ;; (aset forms--recordv 7 (buffer-substring (point) (point-max))) + ;; (aset forms--recordv 7 (buffer-substring-no-properties (point) (point-max))) (cond ((stringp el) @@ -1297,7 +1333,7 @@ ((null el) (if forms--field (` ((aset forms--recordv (, (1- forms--field)) - (buffer-substring (point) (point-max))))))) + (buffer-substring-no-properties (point) (point-max))))))) ((listp el) (prog1 (if forms--field @@ -1306,7 +1342,7 @@ (if (not (search-forward forms--dyntext nil t nil)) (error "Parse error: cannot find \"%s\"" forms--dyntext)) (aset forms--recordv (, (1- forms--field)) - (buffer-substring here + (buffer-substring-no-properties here (- (point) (length forms--dyntext))))))) (` ((let ((forms--dyntext (aref forms--dyntexts (, forms--dyntext)))) (if (not (looking-at (regexp-quote forms--dyntext))) @@ -1382,11 +1418,12 @@ (define-key forms-mode-map "\C-l" 'forms-jump-record) (define-key forms-mode-map "\C-n" 'forms-next-record) (define-key forms-mode-map "\C-p" 'forms-prev-record) - (define-key forms-mode-map "\C-s" 'forms-search) + (define-key forms-mode-map "\C-r" 'forms-search-backward) + (define-key forms-mode-map "\C-s" 'forms-search-forward) (define-key forms-mode-map "\C-x" 'forms-exit) (define-key forms-mode-map "<" 'forms-first-record) (define-key forms-mode-map ">" 'forms-last-record) - (define-key forms-mode-map "?" 'describe-mode) + (define-key forms-mode-map "?" 'describe-mode) ; XEmacs (define-key forms-mode-map "\C-?" 'forms-prev-record) ;; `forms-mode-ro-map' replaces the local map when in read-only mode. @@ -1398,24 +1435,120 @@ (define-key forms-mode-ro-map "l" 'forms-jump-record) (define-key forms-mode-ro-map "n" 'forms-next-record) (define-key forms-mode-ro-map "p" 'forms-prev-record) - (define-key forms-mode-ro-map "s" 'forms-search) + (define-key forms-mode-ro-map "r" 'forms-search-backward) + (define-key forms-mode-ro-map "s" 'forms-search-forward) (define-key forms-mode-ro-map "x" 'forms-exit) (define-key forms-mode-ro-map "<" 'forms-first-record) (define-key forms-mode-ro-map ">" 'forms-last-record) (define-key forms-mode-ro-map "?" 'describe-mode) (define-key forms-mode-ro-map " " 'forms-next-record) (forms--mode-commands1 forms-mode-ro-map) + (forms--mode-menu-ro forms-mode-ro-map) ;; This is the normal, local map. (setq forms-mode-edit-map (make-keymap)) (define-key forms-mode-edit-map "\t" 'forms-next-field) (define-key forms-mode-edit-map "\C-c" forms-mode-map) (forms--mode-commands1 forms-mode-edit-map) + (forms--mode-menu-edit forms-mode-edit-map) ) -(defun forms--mode-commands1 (map) +(defun forms--mode-menu-ro (map) +;;; Menu initialisation +; (define-key map [menu-bar] (make-sparse-keymap)) + (define-key map [menu-bar forms] + (cons "Forms" (make-sparse-keymap "Forms"))) + (define-key map [menu-bar forms menu-forms-exit] + '("Exit Forms Mode" . forms-exit)) + (define-key map [menu-bar forms menu-forms-sep1] + '("----")) + (define-key map [menu-bar forms menu-forms-save] + '("Save Data" . forms-save-buffer)) + (define-key map [menu-bar forms menu-forms-print] + '("Print Data" . forms-print)) + (define-key map [menu-bar forms menu-forms-describe] + '("Describe Mode" . describe-mode)) + (define-key map [menu-bar forms menu-forms-toggle-ro] + '("Toggle View/Edit" . forms-toggle-read-only)) + (define-key map [menu-bar forms menu-forms-jump-record] + '("Jump" . forms-jump-record)) + (define-key map [menu-bar forms menu-forms-search-backward] + '("Search Backward" . forms-search-backward)) + (define-key map [menu-bar forms menu-forms-search-forward] + '("Search Forward" . forms-search-forward)) + (define-key map [menu-bar forms menu-forms-delete-record] + '("Delete" . forms-delete-record)) + (define-key map [menu-bar forms menu-forms-insert-record] + '("Insert" . forms-insert-record)) + (define-key map [menu-bar forms menu-forms-sep2] + '("----")) + (define-key map [menu-bar forms menu-forms-last-record] + '("Last Record" . forms-last-record)) + (define-key map [menu-bar forms menu-forms-first-record] + '("First Record" . forms-first-record)) + (define-key map [menu-bar forms menu-forms-prev-record] + '("Previous Record" . forms-prev-record)) + (define-key map [menu-bar forms menu-forms-next-record] + '("Next Record" . forms-next-record)) + (define-key map [menu-bar forms menu-forms-sep3] + '("----")) + (define-key map [menu-bar forms menu-forms-prev-field] + '("Previous Field" . forms-prev-field)) + (define-key map [menu-bar forms menu-forms-next-field] + '("Next Field" . forms-next-field)) + (put 'forms-insert-record 'menu-enable '(not forms-read-only)) + (put 'forms-delete-record 'menu-enable '(not forms-read-only)) +) +(defun forms--mode-menu-edit (map) +;;; Menu initialisation +; (define-key map [menu-bar] (make-sparse-keymap)) + (define-key map [menu-bar forms] + (cons "Forms" (make-sparse-keymap "Forms"))) + (define-key map [menu-bar forms menu-forms-edit--exit] + '("Exit" . forms-exit)) + (define-key map [menu-bar forms menu-forms-edit-sep1] + '("----")) + (define-key map [menu-bar forms menu-forms-edit-save] + '("Save Data" . forms-save-buffer)) + (define-key map [menu-bar forms menu-forms-edit-print] + '("Print Data" . forms-print)) + (define-key map [menu-bar forms menu-forms-edit-describe] + '("Describe Mode" . describe-mode)) + (define-key map [menu-bar forms menu-forms-edit-toggle-ro] + '("Toggle View/Edit" . forms-toggle-read-only)) + (define-key map [menu-bar forms menu-forms-edit-jump-record] + '("Jump" . forms-jump-record)) + (define-key map [menu-bar forms menu-forms-edit-search-backward] + '("Search Backward" . forms-search-backward)) + (define-key map [menu-bar forms menu-forms-edit-search-forward] + '("Search Forward" . forms-search-forward)) + (define-key map [menu-bar forms menu-forms-edit-delete-record] + '("Delete" . forms-delete-record)) + (define-key map [menu-bar forms menu-forms-edit-insert-record] + '("Insert" . forms-insert-record)) + (define-key map [menu-bar forms menu-forms-edit-sep2] + '("----")) + (define-key map [menu-bar forms menu-forms-edit-last-record] + '("Last Record" . forms-last-record)) + (define-key map [menu-bar forms menu-forms-edit-first-record] + '("First Record" . forms-first-record)) + (define-key map [menu-bar forms menu-forms-edit-prev-record] + '("Previous Record" . forms-prev-record)) + (define-key map [menu-bar forms menu-forms-edit-next-record] + '("Next Record" . forms-next-record)) + (define-key map [menu-bar forms menu-forms-edit-sep3] + '("----")) + (define-key map [menu-bar forms menu-forms-edit-prev-field] + '("Previous Field" . forms-prev-field)) + (define-key map [menu-bar forms menu-forms-edit-next-field] + '("Next Field" . forms-next-field)) + (put 'forms-insert-record 'menu-enable '(not forms-read-only)) + (put 'forms-delete-record 'menu-enable '(not forms-read-only)) +) + +(defun forms--mode-commands1 (map) "Helper routine to define keys." - (if forms--lemacs-p + (if forms--lemacs-p ; XEmacs (progn (define-key map [tab] 'forms-next-field) (define-key map [(shift tab)] 'forms-prev-field)) @@ -1439,11 +1572,11 @@ (progn (substitute-key-definition 'scroll-up 'forms-next-record (current-local-map) - ;;(current-global-map) + ;;(current-global-map) ; FSF ) (substitute-key-definition 'scroll-down 'forms-prev-record (current-local-map) - ;;(current-global-map) + ;;(current-global-map) ; FSF ))) ;; ;; beginning-of-buffer -> forms-first-record @@ -1452,11 +1585,11 @@ (progn (substitute-key-definition 'beginning-of-buffer 'forms-first-record (current-local-map) - ;;(current-global-map) + ;;(current-global-map) ; FSF ) (substitute-key-definition 'end-of-buffer 'forms-last-record (current-local-map) - ;;(current-global-map) + ;;(current-global-map) ;FSF ))) ;; ;; Save buffer @@ -1470,7 +1603,7 @@ (defun forms--help () "Initial help for Forms mode." - (message (substitute-command-keys (concat + (message "%s" (substitute-command-keys (concat "\\[forms-next-record]:next" " \\[forms-prev-record]:prev" " \\[forms-first-record]:first" @@ -1518,7 +1651,7 @@ (let ((here (point))) (prog2 (end-of-line) - (buffer-substring here (point)) + (buffer-substring-no-properties here (point)) (goto-char here)))) (defun forms--show-record (the-record) @@ -1549,9 +1682,11 @@ ;; Verify the number of fields, extend forms--the-record-list if needed. (if (= (length forms--the-record-list) forms-number-of-fields) nil - (beep) - (message "Warning: this record has %d fields instead of %d" - (length forms--the-record-list) forms-number-of-fields) + (if (null forms-check-number-of-fields) + nil + (beep) + (message "Warning: this record has %d fields instead of %d" + (length forms--the-record-list) forms-number-of-fields)) (if (< (length forms--the-record-list) forms-number-of-fields) (setq forms--the-record-list (append forms--the-record-list @@ -1569,7 +1704,7 @@ (set-buffer-modified-p nil) (setq buffer-read-only forms-read-only) (setq mode-line-process - (format " %d/%d" forms--current-record forms--total-records))) + (concat " " forms--current-record "/" forms--total-records))) (defun forms--parse-form () "Parse contents of form into list of strings." @@ -1760,7 +1895,7 @@ (defun forms-toggle-read-only (arg) "Toggles read-only mode of a forms mode buffer. With an argument, enables read-only mode if the argument is positive. -Otherwise enables edit mode if the visited file is writeable." +Otherwise enables edit mode if the visited file is writable." (interactive "P") @@ -1777,7 +1912,7 @@ buffer-read-only) (progn (setq forms-read-only t) - (message "No write access to \"%s\"" forms-file) + (message "No write access to `%s'" forms-file) (beep)) (setq forms-read-only nil)) (if (equal ro forms-read-only) @@ -1803,15 +1938,21 @@ "Create a new record before the current one. With ARG: store the record after the current one. If `forms-new-record-filter' contains the name of a function, -it is called to fill (some of) the fields with default values." +it is called to fill (some of) the fields with default values. +If `forms-insert-after is non-nil, the default behavior is to insert +after the current record." (interactive "P") (if forms-read-only (error "")) - (let ((ln (if arg (1+ forms--current-record) forms--current-record)) - the-list the-record) + (let (ln the-list the-record) + + (if (or (and arg forms-insert-after) + (and (not arg) (not forms-insert-after))) + (setq ln forms--current-record) + (setq ln (1+ forms--current-record))) (forms--checkmod) (if forms-new-record-filter @@ -1864,10 +2005,10 @@ (forms-jump-record forms--current-record))) (message "")) -(defun forms-search (regexp) - "Search REGEXP in file buffer." +(defun forms-search-forward (regexp) + "Search forward for record containing REGEXP." (interactive - (list (read-string (concat "Search for" + (list (read-string (concat "Search forward for" (if forms--search-regexp (concat " (" forms--search-regexp @@ -1886,7 +2027,39 @@ (if (null (re-search-forward regexp nil t)) (progn (goto-char here) - (message (concat "\"" regexp "\" not found.")) + (message "\"%s\" not found" regexp) + nil) + (setq the-record (forms--get-record)) + (setq the-line (1+ (count-lines (point-min) (point)))))) + (progn + (setq forms--current-record the-line) + (forms--show-record the-record) + (re-search-forward regexp nil t)))) + (setq forms--search-regexp regexp)) + +(defun forms-search-backward (regexp) + "Search backward for record containing REGEXP." + (interactive + (list (read-string (concat "Search backward for" + (if forms--search-regexp + (concat " (" + forms--search-regexp + ")")) + ": ")))) + (if (equal "" regexp) + (setq regexp forms--search-regexp)) + (forms--checkmod) + + (let (the-line the-record here + (fld-sep forms-field-sep)) + (if (save-excursion + (set-buffer forms--file-buffer) + (setq here (point)) + (beginning-of-line) + (if (null (re-search-backward regexp nil t)) + (progn + (goto-char here) + (message "\"%s\" not found" regexp) nil) (setq the-record (forms--get-record)) (setq the-line (1+ (count-lines (point-min) (point)))))) @@ -1928,7 +2101,8 @@ (let ((i 0) (here (point)) there - (cnt 0)) + (cnt 0) + (inhibit-point-motion-hooks t)) (if (zerop arg) (setq cnt 1) @@ -1954,7 +2128,8 @@ (let ((i (length forms--markers)) (here (point)) there - (cnt 0)) + (cnt 0) + (inhibit-point-motion-hooks t)) (if (zerop arg) (setq cnt 1) @@ -1972,13 +2147,39 @@ (throw 'done t)))))) nil (goto-char (aref forms--markers (1- (length forms--markers))))))) + +(defun forms-print () + "Send the records to the printer with 'print-buffer', one record per page." + (interactive) + (let ((inhibit-read-only t) + (save-record forms--current-record) + (nb-record 1) + (record nil)) + (while (<= nb-record forms--total-records) + (forms-jump-record nb-record) + (setq record (buffer-string)) + (save-excursion + (set-buffer (get-buffer-create "*forms-print*")) + (goto-char (buffer-end 1)) + (insert record) + (setq buffer-read-only nil) + (if (< nb-record forms--total-records) + (insert "\n \n"))) + (setq nb-record (1+ nb-record))) + (save-excursion + (set-buffer "*forms-print*") + (print-buffer) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (forms-jump-record save-record))) + ;;; ;;; Special service ;;; (defun forms-enumerate (the-fields) "Take a quoted list of symbols, and set their values to sequential numbers. The first symbol gets number 1, the second 2 and so on. -It returns the higest number. +It returns the highest number. Usage: (setq forms-number-of-fields (forms-enumerate diff -r 30df88044ec6 -r b82b59fe008d lisp/utils/id-select.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/id-select.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,1218 @@ +;;!emacs +;; +;; LCD-ENTRY: id-select.el|InfoDock Associates|elisp@infodock.com|Syntactical region selecting|12/02/96|1.4.3| +;; +;; FILE: id-select.el +;; SUMMARY: Select larger and larger syntax-driven regions in a buffer. +;; USAGE: XEmacs and Emacs Lisp Library +;; KEYWORDS: matching, mouse +;; +;; AUTHOR: Bob Weiner +;; +;; ORG: InfoDock Associates. We sell corporate support and development +;; contracts for InfoDock, Emacs and XEmacs. +;; E-mail: Web: http://www.infodock.com +;; Tel: +1 408-243-3300 +;; +;; ORIG-DATE: 19-Oct-96 at 02:25:27 +;; LAST-MOD: 2-Dec-96 at 19:45:28 by Bob Weiner +;; +;; Copyright (C) 1996 InfoDock Associates +;; +;; This file is part of InfoDock. +;; It is available for use and distribution under the terms of the GNU Public +;; License. +;; +;; DESCRIPTION: +;; +;; This is a radically cool, drop in mouse and keyboard-based library for +;; selecting successively bigger syntactical regions within a buffer. +;; Simply load this library and you are ready to try it out by +;; double-clicking on various kinds of characters in different buffer major +;; modes. You'll quickly get the hang of it. (It also provides a command +;; to jump between beginning and end tags within HTML and SGML buffers.) +;; +;; A great deal of smarts are built-in so that it does the right thing +;; almost all of the time; many other attempts at similar behavior such as +;; thing.el fail to deal with many file format complexities. +;; +;; Double clicks of the Selection Key (left mouse key) at the same point +;; will select bigger and bigger regions with each successive use. The +;; first double click selects a region based upon the character at the +;; point of the click. For example, with the point over an opening or +;; closing grouping character, such as { or }, the whole grouping is +;; selected, e.g. a C function. When on an _ or - within a programming +;; language variable name, the whole name is selected. The type of +;; selection is displayed in the minibuffer as feedback. When using a +;; language based mainly on indenting, like Bourne shell, a double click on +;; the first alpha character of a line, such as an if statement, selects +;; the whole statement. +;; +;; --------------- +;; +;; This whole package is driven by a single function, available in mouse +;; and keyboard forms, that first marks a region based on the syntax +;; category of the character following point. Successive invocations mark +;; larger and larger regions until the whole buffer is marked. See the +;; documentation for the function, id-select-syntactical-region, for the +;; kinds of syntax categories handled. +;; +;; Loading this package automatically installs its functionalty on +;; double-clicks (or higher) of the left mouse key. (See the documentation +;; for the variable, mouse-track-click-hook, for how this is done.) A +;; single click of the left button will remove the region and reset point. +;; +;; The function, id-select-thing, may be bound to a key, {C-c s}, seems to +;; be a reasonable choice, to provide the same syntax-driven region +;; selection functionality. Use {C-g} to unmark the region when done. +;; Use, id-select-thing-with-mouse, if you want to bind this to a mouse key +;; and thereby use single clicks instead of double clicks. +;; +;; Three other commands are also provided: +;; id-select-and-copy-thing - mark and copy the syntactical unit to the +;; kill ring +;; id-select-and-kill-thing - kill the syntactical unit at point +;; id-select-goto-matching-tag - In HTML and SGML modes (actually any +;; listed in the variable, `id-select-markup-modes'), moves point to the +;; start of the tag paired with the closest tag that point is within or +;; which it precedes, so you can quickly jump back and forth between +;; open and close tags. +;; +;; --------------- +;; SETUP: +;; +;; To autoload this package under XEmacs or InfoDock via mouse usage, add +;; the following line to one of your initialization files. (Don't do this +;; for GNU Emacs.) +;; +;; (add-hook 'mouse-track-click-hook 'id-select-double-click-hook) +;; +;; For any version of Emacs you should add the following autoload entries +;; at your site: +;; +;; (autoload 'id-select-and-kill-thing +;; "id-select" "Kill syntactical region selection" t) +;; (autoload 'id-select-and-copy-thing +;; "id-select" "Select and copy syntactical region" t) +;; (autoload 'id-select-double-click-hook +;; "id-select" "Double mouse click syntactical region selection" nil) +;; (autoload 'id-select-thing +;; "id-select" "Keyboard-driven syntactical region selection" t) +;; (autoload 'id-select-thing-with-mouse +;; "id-select" "Single mouse click syntactical region selection" t) +;; +;; If you want to be able to select C++ and Java methods and classes by +;; double-clicking on the first character of a definition or on its opening +;; or closing brace, you may need the following setting (all +;; because Sun programmers can't put their opening braces in the first +;; column): +;; +;; (add-hook 'java-mode-hook +;; (function +;; (lambda () +;; (setq defun-prompt-regexp +;; "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f]*\\)+\\)?\\s-*")))) +;; +;; (add-hook 'c++-mode-hook +;; (function +;; (lambda () +;; (setq defun-prompt-regexp +;; "^[ \t]*\\(template[ \t\n\r]*<[^>;.{}]+>[ \t\n\r]*\\)?\\(\\(\\(auto\\|const\\|explicit\\|extern[ \t\n\r]+\"[^\"]+\"\\|extern\\|friend\\|inline\\|mutable\\|overload\\|register\\|static\\|typedef\\|virtual\\)[ \t\n\r]+\\)*\\(\\([[a-zA-Z0-9 ,]+>[ \t\n\r]*[*&]*\\|[[a-zA-Z0-9]*\\(::[[a-zA-Z0-9]+\\)?[ \t\n\r]*[*&]*\\)[*& \t\n\r]+\\)\\)?\\(\\(::\\|[[;{}]+>[ \t\n\r]*[*&]*::\\|[[a-zA-Z0-9]*[ \t\n\r]*[*&]*::\\)[ \t\n\r]*\\)?\\(operator[ \t\n\r]*[^ \t\n\r:;.,?~{}]+\\([ \t\n\r]*\\[\\]\\)?\\|[_~;{}]+[ \t\n\r>]*>\\|[_~a-zA-Z0-9]*\\)\\)[ \t\n\r]*\\(([^{;]*)\\(\\([ \t\n\r]+const\\|[ \t\n\r]+mutable\\)?\\([ \t\n\r]*[=:][^;{]+\\)?\\)?\\)\\s-*")))) +;; +;; If you want tags, comments, sentences and text blocks to be selectable +;; in HTML mode, you need to add the following to your personal +;; initializations (You would do something similar for SGML mode.): +;; +;; ;; Make tag begin and end delimiters act like grouping characters, +;; ;; for easy syntactical selection of tags. +;; (add-hook 'html-mode-hook +;; (function +;; (lambda () +;; (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) +;; (make-local-variable 'comment-start) +;; (make-local-variable 'comment-end) +;; (setq comment-start "") +;; (make-local-variable 'sentence-end) +;; (setq sentence-end "\\([^ \t\n\r>]<\\|>\\(<[^>]*>\\)*\\|[.?!][]\"')}]*\\($\\| $\\|\t\\| \\)\\)[ \t\n]*") +;; +;; (define-key html-mode-map "\C-c." 'id-select-goto-matching-tag) +;; ))) +;; +;; DESCRIP-END. + +;;; ************************************************************************ +;;; Public variables +;;; ************************************************************************ + +(defvar id-select-brace-modes + '(c++-mode c-mode java-mode objc-mode perl-mode tcl-mode) + "*List of language major modes which define things with brace delimiters.") + +(defvar id-select-markup-modes + '(html-mode sgml-mode) + "*List of markup language modes that use SGML-style pairs.") + +(defvar id-select-text-modes + '(fundamental-mode kotl-mode indented-text-mode Info-mode outline-mode text-mode) + "*List of textual modes where paragraphs may be outdented or indented.") + +(defvar id-select-indent-modes + (append '(asm-mode csh-mode eiffel-mode ksh-mode python-mode pascal-mode + sather-mode) + id-select-text-modes) + "*List of language major modes which use mostly indentation to define syntactic structure.") + +(defvar id-select-indent-non-end-regexp-alist + '((csh-mode "\\(\\|then\\|elsif\\|else\\)[ \t]*$") + (eiffel-mode "\\(\\|then\\|else if\\|else\\)[ \t]*$") + (ksh-mode "\\(\\|then\\|elif\\|else\\)[ \t]*$") + (pascal-mode "\\(\\|then\\|else\\)[ \t]*$") + (python-mode "[ \t]*$") + (sather-mode "\\(\\|then\\|else if\\|else\\)[ \t]*$") + ;; + (fundamental-mode "[^ \t\n]") + (kotl-mode "[^ \t\n]") + (indented-text-mode "[^ \t\n]") + (Info-mode "[^ \t\n]") + (outline-mode "[^\\*]") + (text-mode "[^ \t\n]") + ) + "List of (major-mode . non-terminator-line-regexp) elements used to avoid early dropoff when marking indented code.") + +(defvar id-select-indent-end-regexp-alist + '((csh-mode "end\\|while") + (eiffel-mode "end") + (ksh-mode "\\(fi\\|esac\\|until\\|done\\)[ \t\n]") + (pascal-mode "end") + (sather-mode "end") + ;; + (fundamental-mode "[ \t]*$") + (indented-text-mode "[ \t]*$") + (Info-mode "[ \t]*$") + (text-mode "[ \t]*$") + ) + "List of (major-mode . terminator-line-regexp) elements used to include a final line when marking indented code.") + +(defvar id-select-char-p t + "*If t, return single character boundaries when all else fails.") + +(defvar id-select-display-type t + "*If t, display the thing selected with each mouse click.") + +(defvar id-select-whitespace t + "*If t, groups of whitespace are considered as things.") + +(if (string-match "XEmacs" emacs-version) + (add-hook 'mouse-track-click-hook 'id-select-double-click-hook) + (if (string-match "^19\\." emacs-version) + (progn (transient-mark-mode 1) + (global-set-key [mouse-1] 'mouse-set-point) + (global-set-key [double-mouse-1] 'id-select-thing-with-mouse) + (global-set-key [triple-mouse-1] 'id-select-thing-with-mouse)))) + +;;; ************************************************************************ +;;; Public functions +;;; ************************************************************************ + +;; +;; Commands +;; + +;;;###autoload +(defun id-select-thing () + "Mark the region selected by the syntax of the thing at point. +If invoked repeatedly, selects bigger and bigger things. +If `id-select-display-type' is non-nil, the type of selection is displayed in +the minibuffer." + (interactive + (cond ((and (fboundp 'region-active-p) (region-active-p)) + nil) + ((and (boundp 'transient-mark-mode) transient-mark-mode mark-active) + nil) + (t + ;; Reset selection based on the syntax of character at point. + (id-select-reset) + nil))) + (let ((region (id-select-boundaries (point)))) + (if region + (progn (goto-char (car region)) + (set-mark (cdr region)) + (if (fboundp 'activate-region) (activate-region)) + (if (and (boundp 'transient-mark-mode) + transient-mark-mode) + (setq mark-active t)) + (and (interactive-p) id-select-display-type + (message "%s" id-select-previous)) + (run-hooks 'id-select-thing-hook) + t)))) + +;;;###autoload +(defun id-select-thing-with-mouse (event) + "Select a region based on the syntax of the character from a mouse click. +If the click occurs at the same point as the last click, select +the next larger syntactic structure. If `id-select-display-type' is non-nil, +the type of selection is displayed in the minibuffer." + (interactive "@e") + (cond ((and (eq id-select-prior-point (point)) + (eq id-select-prior-buffer (current-buffer))) + ;; Prior click was at the same point as before, so enlarge + ;; selection to the next bigger item. + (if (and (id-select-bigger-thing) id-select-display-type) + (progn + ;; Conditionally, save selected region for pasting. + (cond + ;; XEmacs + ((fboundp 'x-store-cutbuffer) + (x-store-cutbuffer (buffer-substring (point) (mark)))) + ;; Emacs 19 + ((and (boundp 'interprogram-cut-function) + interprogram-cut-function) + (x-set-selection 'PRIMARY (buffer-substring (point) (mark))))) + (message "%s" id-select-previous))) + t) + (t (setq this-command 'mouse-start-selection) + (id-select-reset) + (id-select-thing-with-mouse event)))) + +;;;###autoload +(defun id-select-goto-matching-tag () + "If in a major mode listed in `id-select-markup-modes,' moves point to the start of the tag paired with the closest tag that point is within or precedes. +Returns t if point is moved, else nil. +Signals an error if no tag is found following point or if the closing tag +does not have a `>' terminator character." + (interactive) + (if (not (memq major-mode id-select-markup-modes)) + nil + (let ((result) + ;; Assume case of tag names is irrelevant. + (case-fold-search t) + (opoint (point)) + (tag) + end-point + start-regexp + end-regexp) + + ;; Leave point at the start of the tag that point is within or that + ;; follows point. + (cond + ;; Point is at the start of a tag. + ((looking-at "<[^<> \t\n\r]")) + ;; Point was within a tag. + ((and (re-search-backward "[<>]" nil t) + (looking-at "<[^<> \t\n\r]"))) + ;; Move to following tag. + ((and (re-search-forward "<" nil t) + (progn (backward-char 1) + (looking-at "<[^<> \t\n\r]")))) + ;; No tag follows point. + (t (error "(id-select-goto-matching-tag): No tag found after point."))) + + (if (catch 'done + (cond + ;; Beginning of a tag pair + ((looking-at "<[^/][^<> \t\n\r]*") + (setq tag (buffer-substring (match-beginning 0) (match-end 0)) + start-regexp (regexp-quote tag) + end-regexp (concat "= count 0) + (re-search-forward regexp nil t)) + (setq match-point (match-beginning 0)) + (if (/= (char-after (1+ (match-beginning 0))) ?/) + ;; Start tag + (setq count (1+ count)) + ;; End tag + (setq end-point (point)) + (if (or (not (re-search-forward "[<>]" nil t)) + (= (preceding-char) ?<)) + ;; No terminator character `>' for end tag + (progn (setq result end-point) + (throw 'done nil))) + (setq count (1- count)) + (if (= count 0) + (progn + (goto-char match-point) + (setq result t) + (throw 'done result))))))) + ;; + ;; End of a tag pair + ((or (looking-at " \t\n\r]+") + (and (skip-chars-backward "<") + (looking-at " \t\n\r]+"))) + (goto-char (match-end 0)) + (setq tag (buffer-substring (match-beginning 0) (match-end 0)) + end-regexp (regexp-quote tag) + start-regexp (concat "<" (substring end-regexp 2))) + (setq end-point (point)) + (if (or (not (re-search-forward "[<>]" nil t)) + (= (preceding-char) ?<)) + ;; No terminator character `>' for end tag + (progn (setq result end-point) + (throw 'done nil))) + ;; Skip over nested tags. + (let ((count 0) + (regexp (concat start-regexp "\\|" end-regexp))) + (while (and (>= count 0) + (re-search-backward regexp nil t)) + (if (= (char-after (1+ (point))) ?/) + ;; End tag + (setq count (1+ count)) + ;; Start tag + (setq count (1- count)) + (if (= count 0) + (progn + (setq result t) + (throw 'done t))))))))) + nil + ;; Didn't find matching tag. + (goto-char opoint)) + + (cond ((integerp result) + (goto-char result) + (error "(id-select-goto-matching-tag): Add a terminator character for this end ")) + ((null tag) + (error "(id-select-goto-matching-tag): No following point")) + ((null result) + (if (interactive-p) + (progn + (beep) + (message "(id-select-goto-matching-tag): No matching tag for %s>" + tag) + result))) + (t result))))) + +;;;###autoload +(defun id-select-and-copy-thing () + "Copy the region surrounding the syntactical unit at point." + (interactive) + (let ((bounds (id-select-boundaries (point)))) + (if bounds (copy-region-as-kill (car bounds) (cdr bounds))))) + +;;;###autoload +(defun id-select-and-kill-thing () + "Kill the region surrounding the syntactical unit at point." + (interactive "*") + (let ((bounds (id-select-boundaries (point)))) + (if bounds (kill-region (car bounds) (cdr bounds))))) + + +;; +;; Functions +;; + +(defun id-select-boundaries (pos) + "Return the (start . end) of a syntactically defined region based upon the last region selected or on position POS. +The character at POS is selected if no other thing is matched." + (interactive) + (setq zmacs-region-stays t) + (setcar id-select-old-region (car id-select-region)) + (setcdr id-select-old-region (cdr id-select-region)) + (let ((prior-type id-select-previous)) + (cond + ((eq id-select-previous 'char) + (id-select-syntactical-region pos)) + ((and (car id-select-old-region) + (memq id-select-previous + '(sexp sexp-start sexp-end sexp-up)) + (id-select-sexp-up pos) + (id-select-region-bigger-p id-select-old-region id-select-region)) + id-select-region) + ;; + ;; In the general case, we can't know ahead of time what the next + ;; biggest type of thing to select is, so we test them all and choose + ;; the best fit. This means that dynamically, the order of type + ;; selection will change based on the buffer context. + (t (let ((min-region (1+ (- (point-max) (point-min)))) + (result) + region region-size) + (mapcar + (function + (lambda (sym-func) + (setq region + (if (car (cdr sym-func)) + (funcall (car (cdr sym-func)) pos))) + (if (and region (car region) + (id-select-region-bigger-p + id-select-old-region region) + (setq region-size + (- (cdr region) (car region))) + (< region-size min-region)) + (setq min-region region-size + result + (list;; The actual selection type is + ;; sometimes different than the one we + ;; originally tried, so recompute it here. + (car (assq id-select-previous + id-select-bigger-alist)) + (car region) (cdr region)))))) + id-select-bigger-alist) + (if result + ;; Returns id-select-region + (progn (setq id-select-previous (car result)) + (id-select-set-region (nth 1 result) (nth 2 result))) + ;; + ;; Restore prior selection type since we failed to find a + ;; new one. + (setq id-select-previous prior-type) + (beep) + (message + "(id-select-boundaries): `%s' is the largest selectable region" + id-select-previous) + nil)))))) + +;;;###autoload +(defun id-select-double-click-hook (event click-count) + "Select a region based on the syntax of the character wherever the mouse is double-clicked. +If the double-click occurs at the same point as the last double-click, select +the next larger syntactic structure. If `id-select-display-type' is non-nil, +the type of selection is displayed in the minibuffer." + (cond ((/= click-count 2) + ;; Return nil so any other hooks are performed. + nil) + (t (id-select-thing-with-mouse event)))) + +(defun id-select-syntactical-region (pos) + "Return the (start . end) of a syntactically defined region based upon the buffer position POS. +Uses `id-select-syntax-alist' and the current buffer's syntax table to +determine syntax groups. + +Typically: + Open or close grouping character syntax marks an s-expression. + Double quotes mark strings. + The end of a line marks the line, including its trailing newline. + Word syntax marks the current word. + Symbol syntax (such as _) marks a symbol. + Whitespace marks a span of whitespace. + Comment start or end syntax marks the comment. + Punctuation syntax marks the words on both sides of the punctuation. + The fallback default is to mark the character at POS. + +If an error occurs during syntax scanning, it returns nil." + (interactive "d") + (setq id-select-previous 'char) + (if (save-excursion (goto-char pos) (eolp)) + (id-select-line pos) + (let* ((syntax (char-syntax (if (eobp) (preceding-char) (char-after pos)))) + (pair (assq syntax id-select-syntax-alist))) + (cond ((and pair + (or id-select-whitespace + (not (eq (car (cdr pair)) 'thing-whitespace)))) + (funcall (car (cdr pair)) pos)) + (id-select-char-p + (setq id-select-previous 'char) + (id-select-set-region pos (1+ pos))) + (t + nil))))) + +;;; ************************************************************************ +;;; Private functions +;;; ************************************************************************ + +(defun id-select-at-blank-line-or-comment () + "Return non-nil if on a blank line or a comment start or end line. +Assumes point is befor any non-whitespace character on the line." + (let ((comment-end-p (and (stringp comment-end) + (not (string-equal comment-end ""))))) + (if (looking-at + (concat "\\s-*$\\|\\s-*\\(//\\|/\\*\\|.*\\*/" + (if comment-start + (concat + "\\|" (regexp-quote comment-start))) + (if comment-end-p + (concat + "\\|.*" (regexp-quote comment-end))) + "\\)")) + (or (not (and comment-start comment-end-p)) + ;; Ignore start and end of comments that + ;; follow non-commented text. + (not (looking-at + (format ".*\\S-.*%s.*%s" + (regexp-quote comment-start) + (regexp-quote comment-end)))))))) + +(defun id-select-region-bigger-p (old-region new-region) + "Return t if OLD-REGION is smaller than NEW-REGION and NEW-REGION partially overlaps OLD-REGION, or if OLD-REGION is uninitialized." + (if (null (car old-region)) + t + (and (> (abs (- (cdr new-region) (car new-region))) + (abs (- (cdr old-region) (car old-region)))) + ;; Ensure the two regions intersect. + (or (and (<= (min (cdr new-region) (car new-region)) + (min (cdr old-region) (car old-region))) + (> (max (cdr new-region) (car new-region)) + (min (cdr old-region) (car old-region)))) + (and (> (min (cdr new-region) (car new-region)) + (min (cdr old-region) (car old-region))) + (<= (min (cdr new-region) (car new-region)) + (max (cdr old-region) (car old-region)))))))) + +(defun id-select-bigger-thing () + "Select a bigger object where point is." + (prog1 + (id-select-thing) + (setq this-command 'select-thing))) + +(defun id-select-reset () + ;; Reset syntactic selection. + (setq id-select-prior-point (point) + id-select-prior-buffer (current-buffer) + id-select-previous 'char) + (id-select-set-region nil nil)) + +(defun id-select-set-region (beginning end) + "Set the cons cell held by the variable `id-select-region' to (BEGINNING . END). +Return the updated cons cell." + (setcar id-select-region beginning) + (setcdr id-select-region end) + (if (and (null beginning) (null end)) + (progn (setcar id-select-old-region nil) + (setcdr id-select-old-region nil))) + (if (and (not (eq id-select-previous 'buffer)) + (integerp beginning) (integerp end) + (= beginning (point-min)) (= end (point-max))) + ;; If we selected the whole buffer, make sure that 'thing' type is 'buffer'. + nil + id-select-region)) + +(defun id-select-string-p (&optional start-delim end-delim) + "Returns (start . end) of string whose first line point is within or immediately before. +Positions include delimiters. String is delimited by double quotes unless +optional START-DELIM and END-DELIM (strings) are given. +Returns nil if not within a string." + (let ((opoint (point)) + (count 0) + bol start delim-regexp start-regexp end-regexp) + (or start-delim (setq start-delim "\"")) + (or end-delim (setq end-delim "\"")) + ;; Special case for the empty string. + (if (looking-at (concat (regexp-quote start-delim) + (regexp-quote end-delim))) + (id-select-set-region (point) (match-end 0)) + (setq start-regexp (concat "\\(^\\|[^\\]\\)\\(" + (regexp-quote start-delim) "\\)") + end-regexp (concat "[^\\]\\(" (regexp-quote end-delim) "\\)") + delim-regexp (concat start-regexp "\\|" end-regexp)) + (save-excursion + (beginning-of-line) + (setq bol (point)) + (while (re-search-forward delim-regexp opoint t) + (setq count (1+ count)) + ;; This is so we don't miss the closing delimiter of an empty + ;; string. + (if (and (= (point) (1+ bol)) + (looking-at (regexp-quote end-delim))) + (setq count (1+ count)) + (if (bobp) nil (backward-char 1)))) + (goto-char opoint) + ;; If found an even # of starting and ending delimiters before + ;; opoint, then opoint is at the start of a string, where we want it. + (if (zerop (mod count 2)) + (if (bobp) nil (backward-char 1)) + (re-search-backward start-regexp nil t)) + ;; Point is now before the start of the string. + (if (re-search-forward start-regexp nil t) + (progn + (setq start (match-beginning 2)) + (if (re-search-forward end-regexp nil t) + (id-select-set-region start (point))))))))) + +;;; +;;; Code selections +;;; + +(defun id-select-brace-def-or-declaration (pos) + "If POS is at the first character, opening brace or closing brace of a brace delimited language definition, return (start . end) region, else nil. +The major mode for each supported brace language must be included in the +list, id-select-brace-modes." + (interactive) + (if (not (and (featurep 'cc-mode) (memq major-mode id-select-brace-modes))) + nil + (save-excursion + (goto-char pos) + (let ((at-def-brace + (or (looking-at "^{") (looking-at "^}") + ;; Handle stupid old C-style and new Java + ;; style of putting braces at the end of + ;; lines. + (and (= (following-char) ?{) + (stringp defun-prompt-regexp) + (save-excursion + (beginning-of-line) + (looking-at defun-prompt-regexp))) + (and (= (following-char) ?}) + (stringp defun-prompt-regexp) + (condition-case () + (progn + ;; Leave point at opening brace. + (goto-char + (scan-sexps (1+ (point)) -1)) + ;; Test if these are defun braces. + (save-excursion + (beginning-of-line) + (looking-at defun-prompt-regexp))) + (error nil))))) + eod) + (if (or at-def-brace + ;; At the start of a definition: + ;; Must be at the first non-whitespace character in the line. + (and (= (point) (save-excursion (back-to-indentation) (point))) + ;; Must be on an alpha or symbol-constituent character. + ;; Also allow ~ for C++ destructors. + (looking-at "[a-zA-z~]\\|\\s_") + ;; Previous line, if any, must be blank or a comment + ;; start or end or `defun-prompt-regexp' must be defined + ;; for this mode. + (or (stringp defun-prompt-regexp) + (save-excursion + (if (/= (forward-line -1) 0) + t + (id-select-at-blank-line-or-comment)))))) + (progn + (setq id-select-previous 'brace-def-or-declaration) + ;; Handle declarations and definitions embedded within classes. + (if (and (= (following-char) ?{) + (/= (point) (save-excursion (back-to-indentation) (point)))) + (setq at-def-brace nil)) + ;; + (if at-def-brace nil (beginning-of-line)) + (if (and (not at-def-brace) + (stringp defun-prompt-regexp) + (looking-at defun-prompt-regexp)) + ;; Mark the declaration or definition + (id-select-set-region + (point) + (progn (goto-char (match-end 0)) + (if (= (following-char) ?{) + (forward-list 1) + (search-forward ";" nil t)) + (skip-chars-forward " \t") + (skip-chars-forward "\n") + (if (looking-at "^\\s-*$") + (forward-line 1)) + (point))) + ;; Mark function definitions only + (setq eod (save-excursion + (condition-case () + (progn + (end-of-defun) + (if (looking-at "^\\s-*$") + (forward-line 1)) + (point)) + (error (point-max))))) + (if (= (following-char) ?}) + ;; Leave point at opening brace. + (goto-char (scan-sexps (1+ (point)) -1))) + (if (= (following-char) ?{) + (progn + (while (and (zerop (forward-line -1)) + (not (id-select-at-blank-line-or-comment)))) + (if (id-select-at-blank-line-or-comment) + (forward-line 1)))) + ;; Mark the whole definition + (setq id-select-previous 'brace-def-or-declaration) + (id-select-set-region (point) eod)))))))) + +(defun id-select-indent-def (pos) + "If POS is at the first alpha character on a line, return (start . end) region, + +The major mode for each supported indented language must be included in the +list, id-select-indent-modes." + (interactive) + (if (not (memq major-mode id-select-indent-modes)) + nil + (save-excursion + (goto-char pos) + (if (and + ;; Use this function only if point is on the first non-blank + ;; character of a block, whatever a block is for the current + ;; mode. + (cond ((eq major-mode 'kotl-mode) + (and (looking-at "[1-9*]") (not (kview:valid-position-p)))) + ((or (eq major-mode 'outline-mode) selective-display) + (save-excursion (beginning-of-line) + (looking-at outline-regexp))) + ;; After indent in any other mode, must be on an alpha + ;; or symbol-constituent character. + (t (looking-at "[a-zA-z]\\|\\s_"))) + ;; Must be at the first non-whitespace character in the line. + (= (point) (save-excursion (back-to-indentation) (point)))) + (let* ((start-col (current-column)) + (opoint (if (eq major-mode 'kotl-mode) + (progn (kotl-mode:to-valid-position) (point)) + (beginning-of-line) (point)))) + (while + (and (zerop (forward-line 1)) + (bolp) + (or (progn (back-to-indentation) + (> (current-column) start-col)) + ;; If in a text mode, allow outdenting, otherwise + ;; only include special lines here indented to the + ;; same point as the original line. + (and (or (memq major-mode id-select-text-modes) + (= (current-column) start-col)) + (looking-at + (or (car (cdr + (assq + major-mode + id-select-indent-non-end-regexp-alist))) + "\\'")))))) + (if (and (looking-at + (or (car (cdr (assq major-mode + id-select-indent-end-regexp-alist))) + "\\'")) + (or (memq major-mode id-select-text-modes) + (= (current-column) start-col))) + (forward-line 1)) + (beginning-of-line) + ;; Mark the whole definition + (setq id-select-previous 'indent-def) + (id-select-set-region opoint (point))))))) + +(defun id-select-symbol (pos) + "Return (start . end) of a symbol at POS." + (or (id-select-markup-pair pos) + ;; Test for indented def here since might be on an '*' representing + ;; an outline entry, in which case we mark entries as indented blocks. + (id-select-indent-def pos) + (save-excursion + (if (memq (char-syntax (if (eobp) (preceding-char) (char-after pos))) + '(?w ?_)) + (progn (setq id-select-previous 'symbol) + (condition-case () + (let ((end (scan-sexps pos 1))) + (id-select-set-region + (min pos (scan-sexps end -1)) end)) + (error nil))))))) + +(defun id-select-sexp-start (pos) + "Return (start . end) of sexp starting at POS." + (or (id-select-markup-pair pos) + (id-select-brace-def-or-declaration pos) + (save-excursion + (setq id-select-previous 'sexp-start) + (condition-case () + (id-select-set-region pos (scan-sexps pos 1)) + (error nil))))) + +(defun id-select-sexp-end (pos) + "Return (start . end) of sexp ending at POS." + (or (id-select-brace-def-or-declaration pos) + (save-excursion + (setq id-select-previous 'sexp-end) + (condition-case () + (id-select-set-region (scan-sexps (1+ pos) -1) (1+ pos)) + (error nil))))) + +(defun id-select-sexp (pos) + "Return (start . end) of the sexp that POS is within." + (setq id-select-previous 'sexp) + (save-excursion + (goto-char pos) + (condition-case () + (id-select-set-region (progn (backward-up-list 1) (point)) + (progn (forward-list 1) (point))) + (error nil)))) + +(defun id-select-sexp-up (pos) + "Return (start . end) of the sexp enclosing the selected area or nil." + (setq id-select-previous 'sexp-up) + ;; Keep going up and backward in sexps. This means that id-select-sexp-up + ;; can only be called after id-select-sexp or after itself. + (setq pos (or (car id-select-region) pos)) + (save-excursion + (goto-char pos) + (condition-case () + (id-select-set-region (progn (backward-up-list 1) (point)) + (progn (forward-list 1) (point))) + (error nil)))) + +(defun id-select-preprocessor-def (pos) + "Return (start . end) of a preprocessor #definition starting at POS, if any. +The major mode for each language that uses # preprocessor notation must be +included in the list, id-select-brace-modes." + ;; Only applies in brace modes (strictly, this should apply in a subset + ;; of brace modes, but doing it this way permits for configurability. In + ;; other modes, one doesn't have to use the function on a # symbol. + (if (not (memq major-mode id-select-brace-modes)) + nil + (setq id-select-previous 'preprocessor-def) + (save-excursion + (goto-char pos) + (if (and (= (following-char) ?#) + ;; Must be at the first non-whitespace character in the line. + (= (point) (save-excursion (back-to-indentation) (point)))) + (progn + ;; Skip past continuation lines that end with a backslash. + (while (and (looking-at ".*\\\\\\s-*$") + (zerop (forward-line 1)))) + (forward-line 1) + ;; Include one trailing blank line, if any. + (if (looking-at "^[ \t\n\r]*$") (forward-line 1)) + (id-select-set-region pos (point))))))) + +;; Allow punctuation marks not followed by white-space to include +;; the previous and subsequent sexpression. Useful in contexts such as +;; 'foo.bar'. +(defun id-select-punctuation (pos) + "Return (start . end) region including sexpressions before and after POS, when at a punctuation character." + (or (id-select-comment pos) + (id-select-preprocessor-def pos) + (id-select-brace-def-or-declaration pos) ;; Might be on a C++ ;; destructor ~. + (save-excursion + (setq id-select-previous 'punctuation) + (goto-char (min (1+ pos) (point-max))) + (if (= (char-syntax (if (eobp) (preceding-char) (char-after (point)))) + ?\ ) + (id-select-set-region pos (1+ pos)) + (goto-char pos) + (id-select-set-region + (save-excursion (backward-sexp) (point)) + (progn (forward-sexp) (point))))))) + +(defun id-select-comment (pos) + "Return rest of line from POS to newline." + (setq id-select-previous 'comment) + (save-excursion + (goto-char pos) + (let ((start-regexp (if (stringp comment-start) + (regexp-quote comment-start))) + (end-regexp (if (stringp comment-end) + (regexp-quote comment-end))) + bolp) + (cond + ;; Beginning of a comment + ((and (stringp comment-start) + (or (looking-at start-regexp) + (and (skip-chars-backward comment-start) + (looking-at start-regexp)))) + (skip-chars-backward " \t") + (setq bolp (bolp) + pos (point)) + (if (equal comment-end "") + (progn (end-of-line) + (id-select-set-region pos (point))) + (if (stringp comment-end) + ;; Skip over nested comments. + (let ((count 0) + (regexp (concat start-regexp "\\|" end-regexp))) + (catch 'done + (while (re-search-forward regexp nil t) + (if (string-equal + (buffer-substring (match-beginning 0) (match-end 0)) + comment-start) + (setq count (1+ count)) + ;; End comment + (setq count (1- count)) + (if (= count 0) + (progn + (if (looking-at "[ \t]*[\n\r]") + ;; Don't include final newline unless the + ;; comment is first thing on its line. + (goto-char (if bolp (match-end 0) + (1- (match-end 0))))) + (throw 'done (id-select-set-region + pos (point)))))))))))) + ;; End of a comment + ((and (stringp comment-end) + (not (string-equal comment-end "")) + (or (looking-at end-regexp) + (and (skip-chars-backward comment-end) + (looking-at end-regexp)))) + (goto-char (match-end 0)) + (if (looking-at "[ \t]*[\n\r]") + (goto-char (match-end 0))) + (setq pos (point)) + (skip-chars-forward " \t") + ;; Skip over nested comments. + (let ((count 0) + (regexp (concat start-regexp "\\|" end-regexp))) + (catch 'done + (while (re-search-backward regexp nil t) + (if (string-equal + (buffer-substring (match-beginning 0) (match-end 0)) + comment-end) + (setq count (1+ count)) + ;; Begin comment + (setq count (1- count)) + (if (= count 0) + (progn + (skip-chars-backward " \t") + ;; Don't include final newline unless the comment is + ;; first thing on its line. + (if (bolp) nil (setq pos (1- pos))) + (throw 'done (id-select-set-region + (point) pos))))))))))))) + +;;; +;;; Textual selections +;;; + +(defun id-select-word (pos) + "Return (start . end) of word at POS." + (or (id-select-brace-def-or-declaration pos) + (id-select-indent-def pos) + (progn (setq id-select-previous 'word) + (save-excursion + (goto-char pos) + (forward-word 1) + (let ((end (point))) + (forward-word -1) + (id-select-set-region (point) end)))))) + +(defun id-select-string (pos) + "Returns (start . end) of string at POS or nil. Pos include delimiters. +Delimiters may be single, double or open and close quotes." + (setq id-select-previous 'string) + (save-excursion + (goto-char pos) + (if (and (memq major-mode id-select-markup-modes) + (/= (following-char) ?\") + (save-excursion + (and (re-search-backward "[<>]" nil t) + (= (following-char) ?>)))) + (progn (setq id-select-previous 'text) + (search-backward ">" nil t) + (id-select-set-region + (1+ (point)) + (progn (if (search-forward "<" nil 'end) + (1- (point)) + (point))))) + (or (id-select-string-p) (id-select-string-p "'" "'") + (id-select-string-p "`" "'"))))) + +(defun id-select-sentence (pos) + "Return (start . end) of the sentence at POS." + (setq id-select-previous 'sentence) + (save-excursion + (goto-char pos) + (condition-case () + (id-select-set-region (progn (backward-sentence) (point)) + (progn (forward-sentence) (point))) + (error nil)))) + +(defun id-select-whitespace (pos) + "Return (start . end) of all but one char of whitespace POS, unless +there is only one character of whitespace or this is leading whitespace on +the line. Then return all of it." + (setq id-select-previous 'whitespace) + (save-excursion + (goto-char pos) + (if (= (following-char) ?\^L) + (id-select-page pos) + (let ((end (progn (skip-chars-forward " \t") (point))) + (start (progn (skip-chars-backward " \t") (point)))) + (if (looking-at "[ \t]") + (if (or (bolp) (= (1+ start) end)) + (id-select-set-region start end) + (id-select-set-region (1+ start) end))))))) + +(defun id-select-markup-pair (pos) + "Return (start . end) of region between the opening and closing of an HTML or SGML tag pair, one of which is at POS. +The major mode for each language that uses such tags must be included in the +list, id-select-markup-modes." + (if (not (memq major-mode id-select-markup-modes)) + nil + (setq id-select-previous 'markup-pair) + (let ((pos-with-space) + ;; Assume case of tag names is irrelevant. + (case-fold-search t) + (result) + start-regexp + end-regexp + bolp + opoint) + (save-excursion + (catch 'done + (goto-char pos) + (cond + ;; Beginning of a tag pair + ((looking-at "<[^/][^<> \t\n\r]*") + (setq start-regexp (regexp-quote (buffer-substring + (match-beginning 0) (match-end 0))) + end-regexp (concat "= count 0) + (re-search-forward regexp nil t)) + (if (/= (char-after (1+ (match-beginning 0))) ?/) + ;; Start tag + (setq count (1+ count)) + ;; Move past end tag terminator + (setq opoint (point)) + (if (or (not (re-search-forward "[<>]" nil t)) + (= (preceding-char) ?<)) + (progn (setq result opoint) + (throw 'done nil))) + (setq count (1- count)) + (if (= count 0) + (progn + (if (looking-at "[ \t]*[\n\r]") + ;; Don't include final newline unless the + ;; start tag was the first thing on its line. + (if bolp + (progn (goto-char (match-end 0)) + ;; Include leading space since the + ;; start and end tags begin and end + ;; lines. + (setq pos pos-with-space)) + (goto-char (1- (match-end 0))))) + (setq result (id-select-set-region pos (point))) + (throw 'done nil))))))) + ;; + ;; End of a tag pair + ((or (looking-at " \t\n\r]+") + (and (skip-chars-backward "<") + (looking-at " \t\n\r]+"))) + (goto-char (match-end 0)) + (setq end-regexp (regexp-quote (buffer-substring + (match-beginning 0) (match-end 0))) + start-regexp (concat "<" (substring end-regexp 2))) + (setq opoint (point)) + (if (or (not (re-search-forward "[<>]" nil t)) + (= (preceding-char) ?<)) + (progn (setq result opoint) + (throw 'done nil))) + (setq pos (point)) + (if (looking-at "[ \t]*[\n\r]") + (setq pos-with-space (match-end 0))) + ;; Skip over nested tags. + (let ((count 0) + (regexp (concat start-regexp "\\|" end-regexp))) + (while (and (>= count 0) + (re-search-backward regexp nil t)) + (if (= (char-after (1+ (point))) ?/) + ;; End tag + (setq count (1+ count)) + ;; Start tag + (setq count (1- count)) + (if (= count 0) + (progn + (if pos-with-space + ;; Newline found after original end tag. + (progn + (skip-chars-backward " \t") + (if (bolp) + ;; Don't include final newline unless the + ;; start tag is the first thing on its line. + (setq pos pos-with-space) + (setq pos (1- pos-with-space)) + ;; Don't include non-leading space. + (skip-chars-forward " \t")))) + (setq result (id-select-set-region (point) pos)) + (throw 'done nil)))))))))) + (if (integerp result) + (progn (goto-char result) + (error "(id-select-markup-pair): Add a terminator character for this end tag")) + result)))) + +;;; +;;; Document selections +;;; + +(defun id-select-line (pos) + "Return (start . end) of the whole line POS is in, with newline unless at end of buffer." + (setq id-select-previous 'line) + (save-excursion + (goto-char pos) + (let* ((start (progn (beginning-of-line 1) (point))) + (end (progn (forward-line 1) (point)))) + (id-select-set-region start end)))) + +(defun id-select-paragraph (pos) + "Return (start . end) of the paragraph at POS." + (setq id-select-previous 'paragraph) + (save-excursion + (goto-char pos) + (id-select-set-region (progn (backward-paragraph) (point)) + (progn (forward-paragraph) (point))))) + +(defun id-select-page (pos) + "Return (start . end) of the page preceding POS." + (setq id-select-previous 'page) + (save-excursion + (goto-char pos) + (id-select-set-region (progn (backward-page) (point)) + (progn (forward-page) (point))))) + +(defun id-select-buffer (pos) + "Return (start . end) of the buffer at POS." + (setq id-select-previous 'buffer) + (id-select-set-region (point-min) (point-max))) + +;;; ************************************************************************ +;;; Private variables +;;; ************************************************************************ + +(defvar id-select-bigger-alist + '((char nil) + (whitespace id-select-whitespace) + (word id-select-word) + (symbol id-select-symbol) + (punctuation nil) + (string id-select-string) + (text nil) + (comment id-select-comment) + (markup-pair nil) + (preprocessor-def nil) + (sexp id-select-sexp) + (sexp-start nil) + (sexp-end nil) + (sexp-up id-select-sexp-up) + (line id-select-line) + (sentence id-select-sentence) + (brace-def-or-declaration id-select-brace-def-or-declaration) + (indent-def id-select-indent-def) + (paragraph id-select-paragraph) + (page id-select-page) + (buffer id-select-buffer) + ) + "List of (REGION-TYPE-SYMBOL REGION-SELECTION-FUNCTION) pairs. +Used to go from one thing to a bigger thing. See id-select-bigger-thing. +Nil value for REGION-SELECTION-FUNCTION means that region type is skipped +over when trying to grow the region and is only used when a selection is made +with point on a character that triggers that type of selection. Ordering of +entries is largely irrelevant to any code that uses this list.") + + +(defvar id-select-prior-buffer nil) +(defvar id-select-prior-point nil) + +(defvar id-select-previous 'char + "Most recent type of selection. Must be set by all id-select functions.") + +(defvar id-select-region (cons 'nil 'nil) + "Cons cell that contains a region ( . ). +The function `id-select-set-region' updates and returns it.") + +(defvar id-select-old-region (cons 'nil 'nil) + "Cons cell that contains a region ( . ).") + +(defvar id-select-syntax-alist + '((?w id-select-word) + (?_ id-select-symbol) + (?\" id-select-string) + (?\( id-select-sexp-start) + (?\$ id-select-sexp-start) + (?' id-select-sexp-start) + (?\) id-select-sexp-end) + (? id-select-whitespace) + (?< id-select-comment) + (?. id-select-punctuation)) + "*List of pairs of the form (SYNTAX-CHAR FUNCTION) used by the function `id-select-syntactical-region'. +Each FUNCTION takes a single position argument and returns a region +(start . end) delineating the boundaries of the thing at that position. +Ordering of entries is largely irrelevant to any code that uses this list.") + + +(provide 'id-select) diff -r 30df88044ec6 -r b82b59fe008d lisp/utils/smtpmail.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/smtpmail.el Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,527 @@ +;; Simple SMTP protocol (RFC 821) for sending mail + +;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. + +;; Author: Tomoji Kagatani +;; Maintainer: Brian D. Carlstrom +;; Keywords: mail + +;; 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: + +;; Send Mail to smtp host from smtpmail temp buffer. + +;; Please add these lines in your .emacs(_emacs). +;; +;;(setq send-mail-function 'smtpmail-send-it) +;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") +;;(setq smtpmail-smtp-service "smtp") +;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") +;;(setq smtpmail-debug-info t) +;;(load-library "smtpmail") +;;(setq smtpmail-code-conv-from nil) +;;(setq user-full-name "YOUR NAME HERE") + +;;; Code: + +(require 'sendmail) + +;;; +(defvar smtpmail-default-smtp-server nil + "*Specify default SMTP server.") + +(defvar smtpmail-smtp-server + (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) + "*The name of the host running SMTP server.") + +(defvar smtpmail-smtp-service 25 + "*SMTP service port number. smtp or 25 .") + +(defvar smtpmail-local-domain nil + "*Local domain name without a host name. +If the function (system-name) returns the full internet address, +don't define this value.") + +(defvar smtpmail-debug-info nil + "*smtpmail debug info printout. messages and process buffer.") + +(defvar smtpmail-code-conv-from nil ;; *junet* + "*smtpmail code convert from this code to *internal*..for tiny-mime..") + +;;; +;;; +;;; + +(defun smtpmail-send-it () + (require 'mail-utils) + (let ((errbuf (if mail-interactive + (generate-new-buffer " smtpmail errors") + 0)) + (tembuf (generate-new-buffer " smtpmail temp")) + (case-fold-search nil) + resend-to-addresses + delimline + (mailbuf (current-buffer))) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (erase-buffer) + (insert-buffer-substring mailbuf) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) +;; (sendmail-synch-aliases) + (if (and mail-aliases (fboundp expand-mail-aliases)) ; XEmacs + (expand-mail-aliases (point-min) delimline)) + (goto-char (point-min)) + ;; ignore any blank lines in the header + (while (and (re-search-forward "\n\n\n*" delimline t) + (< (point) delimline)) + (replace-match "\n")) + (let ((case-fold-search t)) + (goto-char (point-min)) + (goto-char (point-min)) + (while (re-search-forward "^Resent-to:" delimline t) + (setq resend-to-addresses + (save-restriction + (narrow-to-region (point) + (save-excursion + (end-of-line) + (point))) + (append (mail-parse-comma-list) + resend-to-addresses)))) +;;; Apparently this causes a duplicate Sender. +;;; ;; If the From is different than current user, insert Sender. +;;; (goto-char (point-min)) +;;; (and (re-search-forward "^From:" delimline t) +;;; (progn +;;; (require 'mail-utils) +;;; (not (string-equal +;;; (mail-strip-quoted-names +;;; (save-restriction +;;; (narrow-to-region (point-min) delimline) +;;; (mail-fetch-field "From"))) +;;; (user-login-name)))) +;;; (progn +;;; (forward-line 1) +;;; (insert "Sender: " (user-login-name) "\n"))) + ;; Don't send out a blank subject line + (goto-char (point-min)) + (if (re-search-forward "^Subject:[ \t]*\n" delimline t) + (replace-match "")) + ;; Put the "From:" field in unless for some odd reason + ;; they put one in themselves. + (goto-char (point-min)) + (if (not (re-search-forward "^From:" delimline t)) + (let* ((login user-mail-address) + (fullname (user-full-name))) + (cond ((eq mail-from-style 'angles) + (insert "From: " fullname) + (let ((fullname-start (+ (point-min) 6)) + (fullname-end (point-marker))) + (goto-char fullname-start) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" + fullname-end 1) + (progn + ;; Quote fullname, escaping specials. + (goto-char fullname-start) + (insert "\"") + (while (re-search-forward "[\"\\]" + fullname-end 1) + (replace-match "\\\\\\&" t)) + (insert "\"")))) + (insert " <" login ">\n")) + ((eq mail-from-style 'parens) + (insert "From: " login " (") + (let ((fullname-start (point))) + (insert fullname) + (let ((fullname-end (point-marker))) + (goto-char fullname-start) + ;; RFC 822 says \ and nonmatching parentheses + ;; must be escaped in comments. + ;; Escape every instance of ()\ ... + (while (re-search-forward "[()\\]" fullname-end 1) + (replace-match "\\\\\\&" t)) + ;; ... then undo escaping of matching parentheses, + ;; including matching nested parentheses. + (goto-char fullname-start) + (while (re-search-forward + "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" + fullname-end 1) + (replace-match "\\1(\\3)" t) + (goto-char fullname-start)))) + (insert ")\n")) + ((null mail-from-style) + (insert "From: " login "\n"))))) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (if (eval mail-mailer-swallows-blank-line) + (newline)) + ;; Find and handle any FCC fields. + (goto-char (point-min)) + (if (re-search-forward "^FCC:" delimline t) + (mail-do-fcc delimline)) + (if mail-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + ;; + ;; + ;; + (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) + (setq smtpmail-recipient-address-list + (or resend-to-addresses + (smtpmail-deduce-address-list tembuf (point-min) delimline))) + (kill-buffer smtpmail-address-buffer) + + (smtpmail-do-bcc delimline) + + (if (not (null smtpmail-recipient-address-list)) + (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf)) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")) + ) + (kill-buffer tembuf) + (if (bufferp errbuf) + (kill-buffer errbuf))))) + + +;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) + +(defun smtpmail-fqdn () + (if smtpmail-local-domain + (concat (system-name) "." smtpmail-local-domain) + (system-name))) + +(defun smtpmail-via-smtp (recipient smtpmail-text-buffer) + (let ((process nil) + (host smtpmail-smtp-server) + (port smtpmail-smtp-service) + response-code + greeting + process-buffer) + (unwind-protect + (catch 'done + ;; get or create the trace buffer + (setq process-buffer + (get-buffer-create (format "*trace of SMTP session to %s*" host))) + + ;; clear the trace buffer of old output + (save-excursion + (set-buffer process-buffer) + (erase-buffer)) + + ;; open the connection to the server + (setq process (open-network-stream "SMTP" process-buffer host port)) + (and (null process) (throw 'done nil)) + + ;; set the send-filter + (set-process-filter process 'smtpmail-process-filter) + + (save-excursion + (set-buffer process-buffer) + (make-local-variable 'smtpmail-read-point) + (setq smtpmail-read-point (point-min)) + + + (if (or (null (car (setq greeting (smtpmail-read-response process)))) + (not (integerp (car greeting))) + (>= (car greeting) 400)) + (throw 'done nil) + ) + + ;; HELO + (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn))) + + (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + + ;; MAIL FROM: +; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) + (smtpmail-send-command process (format "MAIL FROM: <%s>" user-mail-address)) + + (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + + ;; RCPT TO: + (let ((n 0)) + (while (not (null (nth n recipient))) + (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient))) + (setq n (1+ n)) + + (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + )) + + ;; DATA + (smtpmail-send-command process "DATA") + + (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + + ;; Mail contents + (smtpmail-send-data process smtpmail-text-buffer) + + ;;DATA end "." + (smtpmail-send-command process ".") + + (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil) + ) + + ;;QUIT +; (smtpmail-send-command process "QUIT") +; (and (null (car (smtpmail-read-response process))) +; (throw 'done nil)) + t )) + (if process + (save-excursion + (set-buffer (process-buffer process)) + (smtpmail-send-command process "QUIT") + (smtpmail-read-response process) + +; (if (or (null (car (setq response-code (smtpmail-read-response process)))) +; (not (integerp (car response-code))) +; (>= (car response-code) 400)) +; (throw 'done nil) +; ) + (delete-process process)))))) + + +(defun smtpmail-process-filter (process output) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert output))) + +(defun smtpmail-read-response (process) + (let ((case-fold-search nil) + (response-string nil) + (response-continue t) + (return-value '(nil "")) + match-end) + +; (setq response-string nil) +; (setq response-continue t) +; (setq return-value '(nil "")) + + (while response-continue + (goto-char smtpmail-read-point) + (while (not (search-forward "\r\n" nil t)) + (accept-process-output process) + (goto-char smtpmail-read-point)) + + (setq match-end (point)) + (if (null response-string) + (setq response-string + (buffer-substring smtpmail-read-point (- match-end 2)))) + + (goto-char smtpmail-read-point) + (if (looking-at "[0-9]+ ") + (progn (setq response-continue nil) +; (setq return-value response-string) + + (if smtpmail-debug-info + (message response-string)) + + (setq smtpmail-read-point match-end) + (setq return-value + (cons (string-to-int + (buffer-substring (match-beginning 0) (match-end 0))) + response-string))) + + (if (looking-at "[0-9]+-") + (progn (setq smtpmail-read-point match-end) + (setq response-continue t)) + (progn + (setq smtpmail-read-point match-end) + (setq response-continue nil) + (setq return-value + (cons nil response-string)) + ) + ))) + (setq smtpmail-read-point match-end) + return-value)) + + +(defun smtpmail-send-command (process command) + (goto-char (point-max)) + (if (= (aref command 0) ?P) + (insert "PASS \r\n") + (insert command "\r\n")) + (setq smtpmail-read-point (point)) + (process-send-string process command) + (process-send-string process "\r\n")) + +(defun smtpmail-send-data-1 (process data) + (goto-char (point-max)) + + (if (not (null smtpmail-code-conv-from)) + (setq data (code-convert-string data smtpmail-code-conv-from *internal*))) + + (if smtpmail-debug-info + (insert data "\r\n")) + + (setq smtpmail-read-point (point)) + ;; Escape "." at start of a line + (if (eq (string-to-char data) ?.) + (process-send-string process ".")) + (process-send-string process data) + (process-send-string process "\r\n") + ) + +(defun smtpmail-send-data (process buffer) + (let + ((data-continue t) + (sending-data nil) + this-line + this-line-end) + + (save-excursion + (set-buffer buffer) + (goto-char (point-min))) + + (while data-continue + (save-excursion + (set-buffer buffer) + (beginning-of-line) + (setq this-line (point)) + (end-of-line) + (setq this-line-end (point)) + (setq sending-data nil) + (setq sending-data (buffer-substring this-line this-line-end)) + (if (/= (forward-line 1) 0) + (setq data-continue nil))) + + (smtpmail-send-data-1 process sending-data) + ) + ) + ) + + +(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) + "Get address list suitable for smtp RCPT TO:
." + (require 'mail-utils) ;; pick up mail-strip-quoted-names + (let + ((case-fold-search t) + (simple-address-list "") + this-line + this-line-end + addr-regexp) + + (unwind-protect + (save-excursion + ;; + (set-buffer smtpmail-address-buffer) (erase-buffer) + (insert-buffer-substring smtpmail-text-buffer header-start header-end) + (goto-char (point-min)) + ;; RESENT-* fields should stop processing of regular fields. + (save-excursion + (if (re-search-forward "^RESENT-TO:" header-end t) + (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)") + (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)"))) + + (while (re-search-forward addr-regexp header-end t) + (replace-match "") + (setq this-line (match-beginning 0)) + (forward-line 1) + ;; get any continuation lines + (while (and (looking-at "^[ \t]+") (< (point) header-end)) + (forward-line 1)) + (setq this-line-end (point-marker)) + (setq simple-address-list + (concat simple-address-list " " + (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) + ) + (erase-buffer) + (insert-string " ") + (insert-string simple-address-list) + (insert-string "\n") + (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank + (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank + (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank + + (goto-char (point-min)) + ;; tidyness in case hook is not robust when it looks at this + (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) + + (goto-char (point-min)) + (let (recipient-address-list) + (while (re-search-forward " \\([^ ]+\\) " (point-max) t) + (backward-char 1) + (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) + recipient-address-list)) + ) + (setq smtpmail-recipient-address-list recipient-address-list)) + + ) + ) + ) + ) + + +(defun smtpmail-do-bcc (header-end) + "Delete BCC: and their continuation lines from the header area. +There may be multiple BCC: lines, and each may have arbitrarily +many continuation lines." + (let ((case-fold-search t)) + (save-excursion (goto-char (point-min)) + ;; iterate over all BCC: lines + (while (re-search-forward "^BCC:" header-end t) + (delete-region (match-beginning 0) (progn (forward-line 1) (point))) + ;; get rid of any continuation lines + (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) + (replace-match "")) + ) + ) ;; save-excursion + ) ;; let + ) + + + +(provide 'smtpmail) + +;; smtpmail.el ends here diff -r 30df88044ec6 -r b82b59fe008d lisp/version.el --- a/lisp/version.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/version.el Mon Aug 13 08:46:56 2007 +0200 @@ -26,7 +26,7 @@ (defconst emacs-version "19.15" "\ Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta2)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta3)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r 30df88044ec6 -r b82b59fe008d lisp/x11/x-font-menu.el --- a/lisp/x11/x-font-menu.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/x11/x-font-menu.el Mon Aug 13 08:46:56 2007 +0200 @@ -452,6 +452,10 @@ (or weight from-weight) (or size from-size) default-name)) + (setq save-options-font-hack (list 'font-menu-set-font + (or family from-family) + (or weight from-weight) + (or size from-size))) (while faces (cond ((face-font-instance (car faces)) (message "Changing font of `%s'..." (car faces)) diff -r 30df88044ec6 -r b82b59fe008d lisp/x11/x-init.el --- a/lisp/x11/x-init.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/x11/x-init.el Mon Aug 13 08:46:56 2007 +0200 @@ -150,10 +150,18 @@ (if (featurep 'toolbar) (init-x-toolbar)) ;; these are only ever called if zmacs-regions is true. - (add-hook 'zmacs-deactivate-region-hook 'x-disown-selection) - (add-hook 'zmacs-activate-region-hook 'x-activate-region-as-selection) - (add-hook 'zmacs-update-region-hook 'x-activate-region-as-selection) - + (add-hook 'zmacs-deactivate-region-hook + (lambda () + (if (console-on-window-system-p) + (x-disown-selection)))) + (add-hook 'zmacs-activate-region-hook + (lambda () + (if (console-on-window-system-p) + (x-activate-region-as-selection)))) + (add-hook 'zmacs-update-region-hook + (lambda () + (if (console-on-window-system-p) + (x-activate-region-as-selection)))) ;; Motif-ish bindings ;; The following two were generally unliked. ;;(define-key global-map '(shift delete) 'x-kill-primary-selection) diff -r 30df88044ec6 -r b82b59fe008d lisp/x11/x-menubar.el --- a/lisp/x11/x-menubar.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/x11/x-menubar.el Mon Aug 13 08:46:56 2007 +0200 @@ -923,6 +923,7 @@ ;;; The Options menu +(defvar save-options-font-hack nil) (defconst options-menu-saved-forms ;; This is really quite a kludge, but it gets the job done. @@ -1062,7 +1063,7 @@ (face-property ',face ',property) ',(save-options-specifier-spec-list face property)))) - built-in-face-specifiers))) +p built-in-face-specifiers))) (face-list)))) )) @@ -1167,6 +1168,25 @@ (prin1 var)))) (if var (princ "\n"))) options-menu-saved-forms) + (when save-options-font-hack + (princ "(require 'x-font-menu)\n") + (princ "(setq save-options-font-hack '(") + (princ (car save-options-font-hack)) + (princ " ") + (prin1 (cadr save-options-font-hack)) + (princ " ") + (prin1 (caddr save-options-font-hack)) + (princ " ") + (prin1 (format "%d" (cadddr save-options-font-hack))) + (princ "))\n(") + (princ (car save-options-font-hack)) + (princ " ") + (prin1 (cadr save-options-font-hack)) + (princ " ") + (prin1 (caddr save-options-font-hack)) + (princ " ") + (prin1 (format "%d" (cadddr save-options-font-hack))) + (princ ")\n")) )) (set-marker options-output-marker nil) (save-excursion diff -r 30df88044ec6 -r b82b59fe008d lisp/x11/x-toolbar.el --- a/lisp/x11/x-toolbar.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/x11/x-toolbar.el Mon Aug 13 08:46:56 2007 +0200 @@ -100,17 +100,21 @@ ) (defvar compile-command) +(defvar toolbar-compile-already-run nil) (defun toolbar-compile () "Run compile without having to touch the keyboard." (interactive) (require 'compile) - (popup-dialog-box - `(,(concat "Compile:\n " compile-command) - ["Compile" (compile compile-command) t] - ["Edit command" compile t] - nil - ["Cancel" (message "Quit") t]))) + (if toolbar-compile-already-run + (compile compile-command) + (setq toolbar-compile-already-run t) + (popup-dialog-box + `(,(concat "Compile:\n " compile-command) + ["Compile" (compile compile-command) t] + ["Edit command" compile t] + nil + ["Cancel" (message "Quit") t])))) ;; ;; toolbar news variables and defuns @@ -138,6 +142,29 @@ (select-frame toolbar-news-frame) (raise-frame toolbar-news-frame)) +;; +;; toolbar printing variable and defun +;; +(defvar toolbar-print-command 'lpr-buffer + "Command to run when the Print Icon is selected from the toolbar. +Set this to `ps-print-buffer-with-faces' if you primarily print with +a postscript printer.") + +(defun toolbar-print () + "Print current buffer." + (funcall toolbar-print-command)) + +;; +;; toolbar replacement variable and defun +;; +(defvar toolbar-replace-command 'query-replace + "Command to run when the Replace Icon is selected from the toolbar. +One possibility for a different value would be `query-replace-regexp'.") + +(defun toolbar-replace () + "Run a query-replace -type function on the current buffer." + (funcall toolbar-replace-command)) + (defvar toolbar-last-win-icon nil "A `last-win' icon set.") (defvar toolbar-next-win-icon nil "A `next-win' icon set.") (defvar toolbar-file-icon nil "A `file' icon set.") @@ -226,14 +253,14 @@ [toolbar-file-icon find-file t "Open a file" ] [toolbar-folder-icon dired t "View directory"] [toolbar-disk-icon save-buffer t "Save buffer" ] - [toolbar-printer-icon lpr-buffer t "Print buffer" ] + [toolbar-printer-icon toolbar-print t "Print buffer" ] [toolbar-cut-icon x-kill-primary-selection t "Kill region"] [toolbar-copy-icon x-copy-primary-selection t "Copy region"] [toolbar-paste-icon x-yank-clipboard-selection t "Paste from clipboard"] [toolbar-undo-icon undo t "Undo edit" ] [toolbar-spell-icon toolbar-ispell t "Spellcheck" ] - [toolbar-replace-icon query-replace t "Replace text" ] + [toolbar-replace-icon toolbar-replace t "Replace text" ] [toolbar-mail-icon toolbar-mail t "Mail" ] [toolbar-info-icon toolbar-info t "Information" ] [toolbar-compile-icon toolbar-compile t "Compile" ] diff -r 30df88044ec6 -r b82b59fe008d lisp/x11/x-win-xfree86.el --- a/lisp/x11/x-win-xfree86.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/x11/x-win-xfree86.el Mon Aug 13 08:46:56 2007 +0200 @@ -55,6 +55,6 @@ (while mods (let ((k1 (vector (append (car mods) foo))) (k2 (vector (append (car mods) bar)))) - (define-key global-map k1 k2)) + (define-key key-translation-map k1 k2)) (setq mods (cdr mods)))) (setq mapping (cdr mapping))))) diff -r 30df88044ec6 -r b82b59fe008d src/Makefile.in.in --- a/src/Makefile.in.in Mon Aug 13 08:46:35 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 08:46:56 2007 +0200 @@ -1149,8 +1149,9 @@ ${lispdir}prim/paragraphs.elc ${lispdir}modes/lisp-mode.elc \ ${lispdir}modes/text-mode.elc ${lispdir}prim/fill.elc \ ${lispdir}prim/isearch-mode.elc ${lispdir}prim/misc.elc \ - ${lispdir}modes/cc-mode.elc ${lispdir}packages/vc-hooks.elc \ + ${lispdir}packages/vc-hooks.elc \ ${lispdir}prim/replace.elc ${lispdir}prim/specifier.elc \ + ${lispdir}packages/scroll-in-place.elc \ ${lispdir}modes/auto-show.elc SUNPRO_LISP TTY_LISP \ ${lispdir}bytecomp/bytecomp-runtime.elc FLOAT_LISP EPOCH_LISP \ ${lispdir}prim/itimer.elc ${lispdir}ediff/ediff-hook.elc \ diff -r 30df88044ec6 -r b82b59fe008d src/event-stream.c --- a/src/event-stream.c Mon Aug 13 08:46:35 2007 +0200 +++ b/src/event-stream.c Mon Aug 13 08:46:56 2007 +0200 @@ -74,6 +74,9 @@ /* Hook run when XEmacs is about to be idle. */ Lisp_Object Qpre_idle_hook, Vpre_idle_hook; +/* Control gratuitous keyboard focus throwing. */ +int focus_follows_mouse; + #ifdef ILL_CONCEIVED_HOOK /* Hook run after a command if there's no more input soon. */ Lisp_Object Qpost_command_idle_hook, Vpost_command_idle_hook; @@ -1636,6 +1639,7 @@ in emacs_handle_focus_change_final() is based on the _FOR_HOOKS value, we need to do so too. */ if (!NILP (sel_frame) && + !focus_follows_mouse && !EQ (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d), sel_frame) && !NILP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d)) && !EQ (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d), sel_frame)) @@ -4158,6 +4162,13 @@ */ ); Vpre_idle_hook = Qnil; + DEFVAR_BOOL ("focus-follows-mouse", &focus_follows_mouse /* +Variable to control XEmacs behavior with respect to focus changing. +If this variable is set to t, then XEmacs will not gratuitously change +the keyboard focus. +*/ ); + focus_follows_mouse = 0; + #ifdef ILL_CONCEIVED_HOOK /* Ill-conceived because it's not run in all sorts of cases where XEmacs is blocking. That's what `pre-idle-hook' diff -r 30df88044ec6 -r b82b59fe008d src/frame-x.c --- a/src/frame-x.c Mon Aug 13 08:46:35 2007 +0200 +++ b/src/frame-x.c Mon Aug 13 08:46:56 2007 +0200 @@ -617,7 +617,7 @@ { Atom encoding = XA_STRING; String new_XtValue = (String) value; - String old_XtValue; + String old_XtValue = NULL; Bufbyte *ptr; Arg av[2]; diff -r 30df88044ec6 -r b82b59fe008d src/puresize.h --- a/src/puresize.h Mon Aug 13 08:46:35 2007 +0200 +++ b/src/puresize.h Mon Aug 13 08:46:56 2007 +0200 @@ -32,9 +32,9 @@ things configured in. */ #if (LONGBITS == 64) -# define BASE_PURESIZE 912000 +# define BASE_PURESIZE 944000 #else -# define BASE_PURESIZE 552000 +# define BASE_PURESIZE 584000 #endif /* If any particular systems need to change the base puresize, they diff -r 30df88044ec6 -r b82b59fe008d src/redisplay.c --- a/src/redisplay.c Mon Aug 13 08:46:35 2007 +0200 +++ b/src/redisplay.c Mon Aug 13 08:46:56 2007 +0200 @@ -473,6 +473,7 @@ Lisp_Object Vuse_left_overflow, Vuse_right_overflow; Lisp_Object Vtext_cursor_visible_p; +int column_number_start_at_one; /***************************************************************************/ /* */ @@ -5699,7 +5700,7 @@ /* print the current column */ case 'c': { - int col = current_column (b); + int col = current_column (b) + (column_number_start_at_one != 0); int temp = col; int size = 2; char *buf; @@ -8278,6 +8279,11 @@ See `set-window-redisplay-end-trigger'. */ ); Vredisplay_end_trigger_functions = Qnil; + + DEFVAR_BOOL ("column-number-start-at-one", &column_number_start_at_one /* +Non-nil means column display number starts at 1. +*/ ); + column_number_start_at_one = 1; } void @@ -8377,4 +8383,5 @@ text_cursor_visible_p), text_cursor_visible_p_changed, 0, 0); + } diff -r 30df88044ec6 -r b82b59fe008d src/s/hpux10-shr.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/s/hpux10-shr.h Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,29 @@ +/* Synched up with: FSF 19.31. */ + +/* For building XEmacs under HPUX 10.0 with dynamic libraries. */ + +#define ORDINARY_LINK + +/* XEmacs change */ +/* Only support for hp9000s300 currently */ +#if !defined(__hp9000s300) +#define HPUX_USE_SHLIBS +#endif /* !hp9000s300 */ + +/* XEmacs: */ +/* Don't tell the linker to link statically */ +#ifdef NOT_C_CODE +#define START_FILES +#define LINKER $(CC) +#endif /* THIS IS YMAKEFILE */ + +/* get call to brk() when rerunning XEmacs */ +#define RUN_TIME_REMAP + +#include "hpux10.h" + +/* We must turn off -g since it forces -static. */ +#ifdef __GNUC__ +#undef C_DEBUG_SWITCH +#define C_DEBUG_SWITCH +#endif diff -r 30df88044ec6 -r b82b59fe008d src/s/hpux10shr.h --- a/src/s/hpux10shr.h Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -/* Synched up with: FSF 19.31. */ - -/* For building XEmacs under HPUX 10.0 with dynamic libraries. */ - -#define ORDINARY_LINK - -/* XEmacs change */ -/* Only support for hp9000s300 currently */ -#if !defined(__hp9000s300) -#define HPUX_USE_SHLIBS -#endif /* !hp9000s300 */ - -/* XEmacs: */ -/* Don't tell the linker to link statically */ -#ifdef NOT_C_CODE -#define START_FILES -#define LINKER $(CC) -#endif /* THIS IS YMAKEFILE */ - -/* get call to brk() when rerunning XEmacs */ -#define RUN_TIME_REMAP - -#include "hpux10.h" - -/* We must turn off -g since it forces -static. */ -#ifdef __GNUC__ -#undef C_DEBUG_SWITCH -#define C_DEBUG_SWITCH -#endif diff -r 30df88044ec6 -r b82b59fe008d src/s/hpux8-shr.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/s/hpux8-shr.h Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,19 @@ +/* Synched up with: Not in FSF. */ + +/* For building XEmacs under HPUX 8.0 with dynamic libraries. */ + +/* Don't tell the linker to link statically */ +#ifdef NOT_C_CODE +/* now done in hpux8.h */ +/* #define LD_SWITCH_SYSTEM -L/usr/lib/X11R4 -L/usr/lib/Motif1.1 */ +#ifdef __GNUC__ +#define LIB_STANDARD +#endif +#endif /* THIS IS YMAKEFILE */ + +/* get call to brk() when rerunning XEmacs */ +#define RUN_TIME_REMAP + +#define HPUX_USE_SHLIBS + +#include "hpux8.h" diff -r 30df88044ec6 -r b82b59fe008d src/s/hpux8shr.h --- a/src/s/hpux8shr.h Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,19 +0,0 @@ -/* Synched up with: Not in FSF. */ - -/* For building XEmacs under HPUX 8.0 with dynamic libraries. */ - -/* Don't tell the linker to link statically */ -#ifdef NOT_C_CODE -/* now done in hpux8.h */ -/* #define LD_SWITCH_SYSTEM -L/usr/lib/X11R4 -L/usr/lib/Motif1.1 */ -#ifdef __GNUC__ -#define LIB_STANDARD -#endif -#endif /* THIS IS YMAKEFILE */ - -/* get call to brk() when rerunning XEmacs */ -#define RUN_TIME_REMAP - -#define HPUX_USE_SHLIBS - -#include "hpux8.h" diff -r 30df88044ec6 -r b82b59fe008d src/s/hpux9-shr.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/s/hpux9-shr.h Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,37 @@ +/* Synched up with: FSF 19.31. */ + +/* For building XEmacs under HPUX 9.0 with dynamic libraries. */ + +#define ORDINARY_LINK + +/* XEmacs change */ +/* Only support for hp9000s700 currently */ +#if !defined(__hp9000s300) +/* #ifndef USE_GCC */ +#define HPUX_USE_SHLIBS +/* #endif */ +#endif /* !hp9000s300 */ + +/* XEmacs: */ +/* Don't tell the linker to link statically */ +#ifdef NOT_C_CODE +#define START_FILES +#define LINKER $(CC) +/* now done in hpux8.h */ +/* #define LD_SWITCH_SYSTEM -L/usr/lib/X11R5 -L/usr/lib/Motif1.2 */ +#endif /* THIS IS YMAKEFILE */ + +/* get call to brk() when rerunning XEmacs */ +/* #ifndef USE_GCC */ +#define RUN_TIME_REMAP +/* #endif */ + +#include "hpux9.h" + +#if 0 /* No longer needed, since in current GCC -g no longer does that. */ +/* We must turn off -g since it forces -static. */ +#ifdef __GNUC__ +#undef C_DEBUG_SWITCH +#define C_DEBUG_SWITCH +#endif +#endif diff -r 30df88044ec6 -r b82b59fe008d src/s/hpux9shr.h --- a/src/s/hpux9shr.h Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -/* Synched up with: FSF 19.31. */ - -/* For building XEmacs under HPUX 9.0 with dynamic libraries. */ - -#define ORDINARY_LINK - -/* XEmacs change */ -/* Only support for hp9000s700 currently */ -#if !defined(__hp9000s300) -/* #ifndef USE_GCC */ -#define HPUX_USE_SHLIBS -/* #endif */ -#endif /* !hp9000s300 */ - -/* XEmacs: */ -/* Don't tell the linker to link statically */ -#ifdef NOT_C_CODE -#define START_FILES -#define LINKER $(CC) -/* now done in hpux8.h */ -/* #define LD_SWITCH_SYSTEM -L/usr/lib/X11R5 -L/usr/lib/Motif1.2 */ -#endif /* THIS IS YMAKEFILE */ - -/* get call to brk() when rerunning XEmacs */ -/* #ifndef USE_GCC */ -#define RUN_TIME_REMAP -/* #endif */ - -#include "hpux9.h" - -#if 0 /* No longer needed, since in current GCC -g no longer does that. */ -/* We must turn off -g since it forces -static. */ -#ifdef __GNUC__ -#undef C_DEBUG_SWITCH -#define C_DEBUG_SWITCH -#endif -#endif diff -r 30df88044ec6 -r b82b59fe008d src/s/linux.h --- a/src/s/linux.h Mon Aug 13 08:46:35 2007 +0200 +++ b/src/s/linux.h Mon Aug 13 08:46:56 2007 +0200 @@ -60,7 +60,7 @@ people are using newer mailers that have heard of flock. Change this if you need to. */ -/* #define MAIL_USE_FLOCK*/ +/* #define MAIL_USE_FLOCK */ /* Here, on a separate page, add any special hacks needed to make Emacs work on this system. For example, diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-0-shr.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/s/sunos4-0-shr.h Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,63 @@ +/* Synched up with: FSF 19.31. (Split off from sunos4shr.h.) */ + +/* This file permits building Emacs with a shared libc on Sunos 4. + To make this work, you must completely replace your C shared library + using one of the SunOS 4.1.x jumbo replacement patches from Sun. + Here are the patch numbers for Sunos 4.1.3: + 100890-10 SunOS 4.1.3: domestic libc jumbo patch + 100891-10 SunOS 4.1.3: international libc jumbo patch */ + + +#include "sunos4-0.h" + +/* Say that the text segment of a.out includes the header; + the header actually occupies the first few bytes of the text segment + and is counted in hdr.a_text. */ + +/* Misleading! Actually gets loaded after crt0.o */ +#undef START_FILES +#define START_FILES pre-crt0.o + +/* + * Kludge! can't get at symbol "start" in std crt0.o + * Who the #$%&* decided to remove the __ characters! + * Someone needs to fix this in sysdep.c with an #ifdef BROKEN_START in + * sysdep.c. We do not use this address so any value should do really. Still + * may need it in the future? + */ +#define BROKEN_START +#ifndef TEXT_START +#define TEXT_START 0x2020 +#endif + +#undef UNEXEC +#define UNEXEC unexsunos4.o +#ifndef RUN_TIME_REMAP +#define RUN_TIME_REMAP +#endif +#define ORDINARY_LINK +#define SUNOS4_SHARED_LIBRARIES + +#undef LD_SWITCH_SYSTEM + +#undef SYSTEM_MALLOC +#ifndef GNU_MALLOC +#define GNU_MALLOC +#endif +#ifndef REL_ALLOC +#define REL_ALLOC +#endif + +#undef USE_DL_STUBS + +#ifndef HAVE_X11R6 +/* With X11R5 it was reported that linking -lXmu dynamically + did not work. With X11R6, it does work; and since normally + only the dynamic libraries are available, we should use them. */ +#ifdef __GNUC__ +#define LIBXMU -Xlinker -Bstatic -lXmu -Xlinker -Bdynamic +#else +#define LIBXMU -Bstatic -lXmu -Bdynamic +#endif + +#endif /* not HAVE_X11R6 */ diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-0shr.h --- a/src/s/sunos4-0shr.h Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -/* Synched up with: FSF 19.31. (Split off from sunos4shr.h.) */ - -/* This file permits building Emacs with a shared libc on Sunos 4. - To make this work, you must completely replace your C shared library - using one of the SunOS 4.1.x jumbo replacement patches from Sun. - Here are the patch numbers for Sunos 4.1.3: - 100890-10 SunOS 4.1.3: domestic libc jumbo patch - 100891-10 SunOS 4.1.3: international libc jumbo patch */ - - -#include "sunos4-0.h" - -/* Say that the text segment of a.out includes the header; - the header actually occupies the first few bytes of the text segment - and is counted in hdr.a_text. */ - -/* Misleading! Actually gets loaded after crt0.o */ -#undef START_FILES -#define START_FILES pre-crt0.o - -/* - * Kludge! can't get at symbol "start" in std crt0.o - * Who the #$%&* decided to remove the __ characters! - * Someone needs to fix this in sysdep.c with an #ifdef BROKEN_START in - * sysdep.c. We do not use this address so any value should do really. Still - * may need it in the future? - */ -#define BROKEN_START -#ifndef TEXT_START -#define TEXT_START 0x2020 -#endif - -#undef UNEXEC -#define UNEXEC unexsunos4.o -#ifndef RUN_TIME_REMAP -#define RUN_TIME_REMAP -#endif -#define ORDINARY_LINK -#define SUNOS4_SHARED_LIBRARIES - -#undef LD_SWITCH_SYSTEM - -#undef SYSTEM_MALLOC -#ifndef GNU_MALLOC -#define GNU_MALLOC -#endif -#ifndef REL_ALLOC -#define REL_ALLOC -#endif - -#undef USE_DL_STUBS - -#ifndef HAVE_X11R6 -/* With X11R5 it was reported that linking -lXmu dynamically - did not work. With X11R6, it does work; and since normally - only the dynamic libraries are available, we should use them. */ -#ifdef __GNUC__ -#define LIBXMU -Xlinker -Bstatic -lXmu -Xlinker -Bdynamic -#else -#define LIBXMU -Bstatic -lXmu -Bdynamic -#endif - -#endif /* not HAVE_X11R6 */ diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-1-2-shr.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/s/sunos4-1-2-shr.h Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,14 @@ +/* Synched up with: Not in FSF. */ + +/* For building XEmacs under SunOS 4.1.* with dynamic libraries. */ + +#ifdef NOT_C_CODE +# ifdef USE_GCC + /* of course gcc has to take different args than the rest of the universe */ +# define LD_SWITCH_SYSTEM -dynamic +# else +# define LD_SWITCH_SYSTEM -Bdynamic +# endif +#endif + +#include "sunos4-1-2.h" diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-1-2shr.h --- a/src/s/sunos4-1-2shr.h Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -/* Synched up with: Not in FSF. */ - -/* For building XEmacs under SunOS 4.1.* with dynamic libraries. */ - -#ifdef NOT_C_CODE -# ifdef USE_GCC - /* of course gcc has to take different args than the rest of the universe */ -# define LD_SWITCH_SYSTEM -dynamic -# else -# define LD_SWITCH_SYSTEM -Bdynamic -# endif -#endif - -#include "sunos4-1-2.h" diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-1-3-shr.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/s/sunos4-1-3-shr.h Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,14 @@ +/* Synched up with: Not in FSF. */ + +/* For building XEmacs under SunOS 4.1.* with dynamic libraries. */ + +#ifdef NOT_C_CODE +# ifdef USE_GCC + /* of course gcc has to take different args than the rest of the universe */ +# define LD_SWITCH_SYSTEM -dynamic +# else +# define LD_SWITCH_SYSTEM -Bdynamic +# endif +#endif + +#include "sunos4-1-3.h" diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-1-3shr.h --- a/src/s/sunos4-1-3shr.h Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -/* Synched up with: Not in FSF. */ - -/* For building XEmacs under SunOS 4.1.* with dynamic libraries. */ - -#ifdef NOT_C_CODE -# ifdef USE_GCC - /* of course gcc has to take different args than the rest of the universe */ -# define LD_SWITCH_SYSTEM -dynamic -# else -# define LD_SWITCH_SYSTEM -Bdynamic -# endif -#endif - -#include "sunos4-1-3.h" diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-1-shr.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/s/sunos4-1-shr.h Mon Aug 13 08:46:56 2007 +0200 @@ -0,0 +1,14 @@ +/* Synched up with: Not in FSF. */ + +/* For building XEmacs under SunOS 4.1.* with dynamic libraries. */ + +#ifdef NOT_C_CODE +# ifdef USE_GCC + /* of course gcc has to take different args than the rest of the universe */ +# define LD_SWITCH_SYSTEM -dynamic +# else +# define LD_SWITCH_SYSTEM -Bdynamic +# endif +#endif + +#include "sunos4-1.h" diff -r 30df88044ec6 -r b82b59fe008d src/s/sunos4-1shr.h --- a/src/s/sunos4-1shr.h Mon Aug 13 08:46:35 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -/* Synched up with: Not in FSF. */ - -/* For building XEmacs under SunOS 4.1.* with dynamic libraries. */ - -#ifdef NOT_C_CODE -# ifdef USE_GCC - /* of course gcc has to take different args than the rest of the universe */ -# define LD_SWITCH_SYSTEM -dynamic -# else -# define LD_SWITCH_SYSTEM -Bdynamic -# endif -#endif - -#include "sunos4-1.h"