# HG changeset patch # User cvs # Date 1186987722 -7200 # Node ID 9ee227acff299c12f9e2204ee696a1bca234e917 # Parent 13c6d0aaafe513a1416bdeea05a865a555010133 Import from CVS: tag r19-15b90 diff -r 13c6d0aaafe5 -r 9ee227acff29 CHANGES-beta --- a/CHANGES-beta Mon Aug 13 08:48:18 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 08:48:42 2007 +0200 @@ -1,4 +1,13 @@ -*- indented-text -*- +to 19.15 beta90 +-- ediff-2.64 +-- viper-2.92 +-- bench.el-1.2 +-- Degenerate extent insertion speedup courtesy of David Moore +-- decipher.el (from Emacs 19.34) +-- w3-3.0.43 +-- Miscellaneous bug fixes + to 19.15 beta7 -- backup-dir 2.0 courtesy of Greg Klanderman -- lazy-lock-1.15 diff -r 13c6d0aaafe5 -r 9ee227acff29 configure --- a/configure Mon Aug 13 08:48:18 2007 +0200 +++ b/configure Mon Aug 13 08:48:42 2007 +0200 @@ -1532,6 +1532,20 @@ ### Eric Raymond says we should accept strings like "sysvr4" to mean ### "System V Release 4"; he writes, "The old convention encouraged ### confusion between `system' and `release' levels'." +### +### We rely on cpp to generate makefiles from Makefile.in.in templates. +### There is at least one drawback to that. Since cpp generally has +### built-in macro definitions like `#define unix' or `#define i386', +### we must be careful to prevent it from substituting these occurences +### in certain places in the makefiles. Pathnames for architecture- +### specific files come to mind. +### This is where CPPFLAGS_MAKEFILEGEN comes in. We try to selectively +### disable (potentially) predefined macros that we find to be part of +### the configuration string. +### This is but a poor method to help us fight off cpp, but it covers +### those cases that used to bite me. + +CPPFLAGS_MAKEFILEGEN="" # we normally do not need any extra flags machine='' opsys='' unported=no need_dynodump=no case "${canonical}" in @@ -1808,13 +1822,13 @@ machine=hp800 opsys=hpux NON_GNU_CPP="cc -Aa -E" NON_GNU_CC="cc -Aa" ;; hppa*-hp-hpux8*shr* ) - machine=hp800 opsys=hpux8-shr NON_GNU_CPP="cc -Aa -E" NON_GNU_CC="cc -Aa" + machine=hp800 opsys=hpux8*shr NON_GNU_CPP="cc -Aa -E" NON_GNU_CC="cc -Aa" ;; hppa*-hp-hpux8* ) machine=hp800 opsys=hpux8 NON_GNU_CPP="cc -Aa -E" NON_GNU_CC="cc -Aa" ;; hppa*-hp-hpux9*shr* ) - machine=hp800 opsys=hpux9-shr NON_GNU_CPP="cc -Aa -E" NON_GNU_CC="cc -Aa" + machine=hp800 opsys=hpux9*shr NON_GNU_CPP="cc -Aa -E" NON_GNU_CC="cc -Aa" ;; hppa*-hp-hpux9* ) machine=hp800 opsys=hpux9 NON_GNU_CPP="cc -Aa -E" NON_GNU_CC="cc -Aa" @@ -2260,6 +2274,7 @@ ## Intel 386 machines where we don't care about the manufacturer i[3-9]86-*-* ) machine=intel386 + CPPFLAGS_MAKEFILEGEN="${CPPFLAGS_MAKEFILEGEN} -Ui386" case "${canonical}" in *-isc1.* | *-isc2.[01]* ) opsys=386-ix ;; *-isc2.2* ) opsys=isc2-2 ;; @@ -2290,8 +2305,8 @@ else NON_GNU_CPP="/lib/cpp -D_XOPEN_SOURCE" ; fi ;; - *-386bsd* ) opsys=386bsd ;; - *-freebsd* ) opsys=freebsd ;; + *-386bsd* ) opsys=386bsd ;; + *-freebsd* ) opsys=freebsd ;; *-nextstep* ) opsys=nextstep ;; ## Otherwise, we'll fall through to the generic opsys code at the bottom. esac @@ -2544,8 +2559,9 @@ #### Some systems specify a CPP to use unless we are using GCC. #### Now that we know whether we are using GCC, we can decide whether #### to use that one. -if [ "x$NON_GNU_CPP" = x ] || [ x$GCC = x1 ] -then true + +if [ "x$GCC" = x1 ] || [ "x$NON_GNU_CPP" = x ] ; then + true else if [ "x$CPP" = x ]; then if [ "${with_lcc}" = "yes" ] && [ "${NON_GNU_CPP}" = "yes" ] ; then @@ -3937,7 +3953,9 @@ if test -d /usr/X386/include; then HAVE_XFREE386=yes test -z "${C_SWITCH_X_SITE}" && C_SWITCH_X_SITE="-I/usr/X386/include" - elif test -d /usr/X11R6/include; then + elif test -f /etc/XF86Config -o \ + -f /etc/X11/XF86Config -o \ + -f /usr/X11R6/lib/X11/XF86Config; then HAVE_XFREE386=yes test -z "${C_SWITCH_X_SITE}" && C_SWITCH_X_SITE="-I/usr/X11R6/include" else @@ -8496,7 +8514,7 @@ ( cd ./src; rm -f junk.c; sed -e '\''s/^# Generated.*//'\'' -e '\''s%/\*\*/#.*%%'\'' < Makefile.in > junk.c; - eval `echo ${CPP} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; + eval `echo ${CPP} ${CPPFLAGS_MAKEFILEGEN} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; < junk.cpp '\ ' sed -e '\''s/^#.*//'\'' '\ ' -e '\''s/^[ \f\t][ \f\t]*$//'\'' '\ @@ -8513,7 +8531,7 @@ ( cd ./lwlib; rm -f junk.c; sed -e '\''s/^# Generated.*//'\'' -e '\''s%/\*\*/#.*%%'\'' < Makefile.in > junk.c; - eval `echo ${CPP} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; + eval `echo ${CPP} ${CPPFLAGS_MAKEFILEGEN} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; < junk.cpp '\ ' sed -e '\''s/^#.*//'\'' '\ ' -e '\''s/^[ \f\t][ \f\t]*$//'\'' '\ @@ -8530,7 +8548,7 @@ ( cd ./lib-src; rm -f junk.c; sed -e '\''s/^# Generated.*//'\'' -e '\''s%/\*\*/#.*%%'\'' < Makefile.in > junk.c; - eval `echo ${CPP} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; + eval `echo ${CPP} ${CPPFLAGS_MAKEFILEGEN} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; < junk.cpp '\ ' sed -e '\''s/^#.*//'\'' '\ ' -e '\''s/^[ \f\t][ \f\t]*$//'\'' '\ @@ -8547,7 +8565,7 @@ ( cd ./dynodump; rm -f junk.c; sed -e '\''s/^# Generated.*//'\'' -e '\''s%/\*\*/#.*%%'\'' < Makefile.in > junk.c; - eval `echo ${CPP} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; + eval `echo ${CPP} ${CPPFLAGS_MAKEFILEGEN} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; < junk.cpp '\ ' sed -e '\''s/^#.*//'\'' '\ ' -e '\''s/^[ \f\t][ \f\t]*$//'\'' '\ @@ -8565,7 +8583,7 @@ ( cd ./lwlib/energize; rm -f junk.c; sed -e '\''s/^# Generated.*//'\'' -e '\''s%/\*\*/#.*%%'\'' < Makefile.in > junk.c; - eval `echo ${CPP} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; + eval `echo ${CPP} ${CPPFLAGS_MAKEFILEGEN} -I. -I${topsrcdir}/src ${CPPFLAGS} junk.c \>junk.cpp`; < junk.cpp '\ ' sed -e '\''s/^#.*//'\'' '\ ' -e '\''s/^[ \f\t][ \f\t]*$//'\'' '\ diff -r 13c6d0aaafe5 -r 9ee227acff29 configure.in --- a/configure.in Mon Aug 13 08:48:18 2007 +0200 +++ b/configure.in Mon Aug 13 08:48:42 2007 +0200 @@ -3047,7 +3047,9 @@ if test -d /usr/X386/include; then HAVE_XFREE386=yes test -z "${C_SWITCH_X_SITE}" && C_SWITCH_X_SITE="-I/usr/X386/include" - elif test -d /usr/X11R6/include; then + elif test -f /etc/XF86Config -o \ + -f /etc/X11/XF86Config -o \ + -f /usr/X11R6/lib/X11/XF86Config; then HAVE_XFREE386=yes test -z "${C_SWITCH_X_SITE}" && C_SWITCH_X_SITE="-I/usr/X11R6/include" else diff -r 13c6d0aaafe5 -r 9ee227acff29 dynodump/Makefile.in.in --- a/dynodump/Makefile.in.in Mon Aug 13 08:48:18 2007 +0200 +++ b/dynodump/Makefile.in.in Mon Aug 13 08:48:42 2007 +0200 @@ -95,7 +95,7 @@ #endif dynodump.so: ${srcdir}/_dynodump.h $(OBJS) - PATH=/usr/ccs/bin:/bin:$PATH ld -o dynodump.so -G $(OBJS) -lelf -lmapmalloc + PATH=/usr/ccs/bin:/bin:$$PATH ld -o dynodump.so -G $(OBJS) -lelf -lmapmalloc _relocate.o: ${srcdir}/$(ARCH)/_relocate.c $(CC) -c $(ALL_CFLAGS) ${srcdir}/$(ARCH)/_relocate.c diff -r 13c6d0aaafe5 -r 9ee227acff29 etc/sample.emacs --- a/etc/sample.emacs Mon Aug 13 08:48:18 2007 +0200 +++ b/etc/sample.emacs Mon Aug 13 08:48:42 2007 +0200 @@ -569,24 +569,6 @@ (resize-minibuffer-mode) (setq resize-minibuffer-window-exactly nil) -;; Create a single detached minibuffer used by all frames. -;; Uncomment to try this out. -;(when running-xemacs -; (setq initial-frame-plist '(minibuffer nil)) -; (setq default-frame-plist '(minibuffer nil)) -; (setq default-minibuffer-frame -; (make-frame -; '(minibuffer only -; width 86 -; height 1 -; menubar-visible-p nil -; default-toolbar-visible-p nil -; name "minibuffer" -; top -2 -; left -2 -; has-modeline-p nil))) -; (frame-notice-user-settings)) - ;;; ******************** ;;; W3 is a browser for the World Wide Web, and takes advantage of the very ;;; latest redisplay features in XEmacs. You can access it simply by typing diff -r 13c6d0aaafe5 -r 9ee227acff29 etc/viperCard.tex --- a/etc/viperCard.tex Mon Aug 13 08:48:18 2007 +0200 +++ b/etc/viperCard.tex Mon Aug 13 08:48:42 2007 +0200 @@ -82,7 +82,7 @@ are preserved on all copies. For copies of the GNU Emacs manual, write to the Free Software -Foundation, Inc., 1000 Massachusetts Ave, Cambridge MA 02138. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. \endgroup} diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/Makefile.in.in --- a/lib-src/Makefile.in.in Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/Makefile.in.in Mon Aug 13 08:48:42 2007 +0200 @@ -21,13 +21,13 @@ /* Note: FSF Makefile.in.in does something weird so that the comments above a certain point in this file are in shell format instead of - in C format. I don't know how the hell this is supposed to work. */ + in C format. I do not know how the hell this is supposed to work. */ -/* Avoid trouble on systems where the `SHELL' variable might be +/* Avoid trouble on systems where the $SHELL variable might be inherited from the environment. */ SHELL = /bin/sh -/* Some people use these in paths they define. We don't want their paths +/* Some people use these in paths they define. We do not want their paths getting changed on them. */ #undef sparc #undef sun @@ -36,7 +36,7 @@ #undef NeXT #undef mips -/* ==================== Things `configure' will edit ==================== */ +/* ==================== Things "configure" will edit ==================== */ CC=@CC@ CFLAGS=@CFLAGS@ @@ -52,28 +52,28 @@ subdirectories of this directory. The default values for many of the variables below are expressed in terms of this one, so you may not need to change them. This is set with the --prefix option to - `../configure'. */ + "../configure". */ prefix=@prefix@ -/* Like `prefix', but used for architecture-specific files. This is - set with the --exec-prefix option to `../configure'. */ +/* Like "prefix", but used for architecture-specific files. This is + set with the --exec-prefix option to "../configure". */ exec_prefix=@exec_prefix@ /* Where to install Emacs and other binaries that people will want to run directly (like etags). This is set with the --bindir option - to `../configure'. */ + to "../configure". */ bindir=@bindir@ /* Where to install and expect executable files to be run by Emacs rather than directly by users, and other architecture-dependent data. ${archlibdir} is usually below this. This is set with the - --libdir option to `../configure'. */ + --libdir option to "../configure". */ libdir=@libdir@ /* Where to find the source code. This is set by the configure - script's `--srcdir' option. However, the value of ${srcdir} in + "--srcdir" option. However, the value of ${srcdir} in this makefile is not identical to what was specified with --srcdir, - since the variable here has `/lib-src' added at the end. */ + since the variable here has "/lib-src" added at the end. */ srcdir=@srcdir@ /* ==================== Emacs-specific directories ==================== */ @@ -85,7 +85,7 @@ This path usually includes the Emacs version and configuration name, so that multiple configurations for multiple versions of Emacs may be installed at once. This can be set with the --archlibdir option - to `../configure'. */ + to "../configure". */ archlibdir=@archlibdir@ /* ==================== Utility Programs for the Build ================= */ @@ -106,11 +106,12 @@ which should not be installed in bindir. */ UTILITIES= make-path wakeup profile make-docfile digest-doc \ sorted-doc movemail cvtmail fakemail yow emacsserver hexl \ - gnuserv + gnuserv mmencode -/* Like UTILITIES, but they're not system-dependent, and should not be +/* Like UTILITIES, but they are not system-dependent, and should not be deleted by the distclean target. */ -SCRIPTS= rcs2log vcdiff +TM_SCRIPTS=tm-au tm-file tm-html tm-image tm-mpeg tm-plain tm-ps tmdecode +SCRIPTS= rcs2log vcdiff $(TM_SCRIPTS) EXECUTABLES= ${UTILITIES} ${INSTALLABLES} ${SCRIPTS} ${INSTALLABLE_SCRIPTS} @@ -135,22 +136,22 @@ in-place location, it will not get recompiled in the not-in-place location. - The GNU Make `vpath' directive continues this tradition, but at + The GNU Make "vpath" directive continues this tradition, but at least lets you restrict the classes of files that it applies to. This allows us to kludge around the problem. */ #ifdef USE_GNU_MAKE vpath %.c @srcdir@ vpath %.h @srcdir@ /* now list files that should NOT be searched in the srcdir. - This includes any .c or .h that's built from something else + This includes any .c or .h that is built from something else (e.g. a .in file). */ /* none here */ #else VPATH=@srcdir@ #endif -/* We won't really call alloca; - don't let the file name alloca.c get messed up. */ +/* We will not really call alloca; + do not let the file name alloca.c get messed up. */ #ifdef alloca #undef alloca #endif @@ -233,8 +234,8 @@ -I. -I../src -I${srcdir} -I${srcdir}/../src ${LDFLAGS} ${CFLAGS} CPP_CFLAGS = C_SWITCH_SYSTEM C_SWITCH_MACHINE -Demacs -DHAVE_CONFIG_H \ -I. -I../src -I${srcdir} -I${srcdir}/../src ${CPPFLAGS} ${CFLAGS} -/* Formerly -Demacs was missing, but it's needed to suppress the - defining of malloc to xmalloc. [Yes it's fucked up. Blame FSF +/* Formerly -Demacs was missing, but it is needed to suppress the + defining of malloc to xmalloc. [Yes it is fucked up. Blame FSF for this.] */ ALLOCA_CFLAGS = C_SWITCH_SYSTEM C_SWITCH_MACHINE -Demacs -DHAVE_CONFIG_H \ -I. -I../src -I${srcdir} -I${srcdir}/../src ${CPPFLAGS} ${CFLAGS} @@ -275,7 +276,7 @@ maybe-blessmail: BLESSMAIL #ifdef MOVEMAIL_NEEDS_BLESSING -/* Don't charge ahead and do it! Let the installer decide. +/* Do not charge ahead and do it! Let the installer decide. ./blessmail ${archlibdir}/movemail */ @if [ `wc -l +#include +#include +#include + +static void +output64chunk(int c1, int c2, int c3, int pads, FILE *outfile); + +static char basis_64[] = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; + +static char index_64[128] = { + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,62, -1,-1,-1,63, + 52,53,54,55, 56,57,58,59, 60,61,-1,-1, -1,-1,-1,-1, + -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 11,12,13,14, + 15,16,17,18, 19,20,21,22, 23,24,25,-1, -1,-1,-1,-1, + -1,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40, + 41,42,43,44, 45,46,47,48, 49,50,51,-1, -1,-1,-1,-1 +}; + +#define char64(c) (((c) < 0 || (c) > 127) ? -1 : index_64[(c)]) + +/* +char64(c) +char c; +{ + char *s = (char *) strchr(basis_64, c); + if (s) return(s-basis_64); + return(-1); +} +*/ + +/* the following gets a character, but fakes it properly into two chars if there's a newline character */ +static int InNewline=0; + +static int +nextcharin(infile, PortableNewlines) +FILE *infile; +int PortableNewlines; +{ + int c; + +#ifndef NEWLINE_CHAR + return(getc(infile)); +#else + if (!PortableNewlines) return(getc(infile)); + if (InNewline) { + InNewline = 0; + return(10); /* LF */ + } + c = getc(infile); + if (c == NEWLINE_CHAR) { + InNewline = 1; + return(13); /* CR */ + } + return(c); +#endif +} + +static void +to64(FILE *infile, FILE *outfile, int PortableNewlines) +{ + int c1, c2, c3, ct=0; + InNewline = 0; /* always reset it */ + while ((c1 = nextcharin(infile, PortableNewlines)) != EOF) { + c2 = nextcharin(infile, PortableNewlines); + if (c2 == EOF) { + output64chunk(c1, 0, 0, 2, outfile); + } else { + c3 = nextcharin(infile, PortableNewlines); + if (c3 == EOF) { + output64chunk(c1, c2, 0, 1, outfile); + } else { + output64chunk(c1, c2, c3, 0, outfile); + } + } + ct += 4; + if (ct > 71) { + putc('\n', outfile); + ct = 0; + } + } + if (ct) putc('\n', outfile); + fflush(outfile); +} + +static void +output64chunk(int c1, int c2, int c3, int pads, FILE *outfile) +{ + putc(basis_64[c1>>2], outfile); + putc(basis_64[((c1 & 0x3)<< 4) | ((c2 & 0xF0) >> 4)], outfile); + if (pads == 2) { + putc('=', outfile); + putc('=', outfile); + } else if (pads) { + putc(basis_64[((c2 & 0xF) << 2) | ((c3 & 0xC0) >>6)], outfile); + putc('=', outfile); + } else { + putc(basis_64[((c2 & 0xF) << 2) | ((c3 & 0xC0) >>6)], outfile); + putc(basis_64[c3 & 0x3F], outfile); + } +} + +static int +PendingBoundary(char *s, char **Boundaries, int *BoundaryCt) +{ + int i, len; + + if (s[0] != '-' || s[1] != '-') return(0); + + + for (i=0; i < *BoundaryCt; ++i) { + len = strlen(Boundaries[i]); + if (!strncmp(s, Boundaries[i], len)) { + if (s[len] == '-' && s[len+1] == '-') *BoundaryCt = i; + return(1); + } + } + return(0); +} + +/* If we're in portable newline mode, we have to convert CRLF to the + local newline convention on output */ + +static int CRpending = 0; + +#ifdef NEWLINE_CHAR +static void +almostputc(int c, FILE *outfile, int PortableNewlines) +{ + if (CRpending) { + if (c == 10) { + putc(NEWLINE_CHAR, outfile); + CRpending = 0; + } else { + putc(13, outfile); + if (c != 13) { + putc(c, outfile); + CRpending = 0; + } + } + } else { + if (PortableNewlines && c == 13) { + CRpending = 1; + } else { + putc(c, outfile); + } + } +} +#else +static void +almostputc(int c, FILE *outfile, int PortableNewlines) +{ + putc(c, outfile); +} +#endif + +static void +from64(FILE *infile, FILE *outfile, + char **boundaries, int *boundaryct, int PortableNewlines) +{ + int c1, c2, c3, c4; + int newline = 1, DataDone = 0; + + /* always reinitialize */ + CRpending = 0; + while ((c1 = getc(infile)) != EOF) { + if (isspace(c1)) { + if (c1 == '\n') { + newline = 1; + } else { + newline = 0; + } + continue; + } + if (newline && boundaries && c1 == '-') { + char Buf[200]; + /* a dash is NOT base 64, so all bets are off if NOT a boundary */ + ungetc(c1, infile); + fgets(Buf, sizeof(Buf), infile); + if (boundaries + && (Buf[0] == '-') + && (Buf[1] == '-') + && PendingBoundary(Buf, boundaries, boundaryct)) { + return; + } + fprintf(stderr, "Ignoring unrecognized boundary line: %s\n", Buf); + continue; + } + if (DataDone) continue; + newline = 0; + do { + c2 = getc(infile); + } while (c2 != EOF && isspace(c2)); + do { + c3 = getc(infile); + } while (c3 != EOF && isspace(c3)); + do { + c4 = getc(infile); + } while (c4 != EOF && isspace(c4)); + if (c2 == EOF || c3 == EOF || c4 == EOF) { + fprintf(stderr, "Warning: base64 decoder saw premature EOF!\n"); + return; + } + if (c1 == '=' || c2 == '=') { + DataDone=1; + continue; + } + c1 = char64(c1); + c2 = char64(c2); + almostputc(((c1<<2) | ((c2&0x30)>>4)), outfile, PortableNewlines); + if (c3 == '=') { + DataDone = 1; + } else { + c3 = char64(c3); + almostputc((((c2&0XF) << 4) | ((c3&0x3C) >> 2)), outfile, PortableNewlines); + if (c4 == '=') { + DataDone = 1; + } else { + c4 = char64(c4); + almostputc((((c3&0x03) <<6) | c4), outfile, PortableNewlines); + } + } + } + if (CRpending) putc(13, outfile); /* Don't drop a lone trailing char 13 */ +} + +static char basis_hex[] = "0123456789ABCDEF"; +static char index_hex[128] = { + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1, -1,-1,-1,-1, + -1,10,11,12, 13,14,15,-1, -1,-1,-1,-1, -1,-1,-1,-1, + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, + -1,10,11,12, 13,14,15,-1, -1,-1,-1,-1, -1,-1,-1,-1, + -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1, -1,-1,-1,-1 +}; + +/* The following version generated complaints on Solaris. */ +/* #define hexchar(c) (((c) < 0 || (c) > 127) ? -1 : index_hex[(c)]) */ +/* Since we're no longer ever calling it with anything signed, this should work: */ +#define hexchar(c) (((c) > 127) ? -1 : index_hex[(c)]) + +/* +hexchar(c) +char c; +{ + char *s; + if (islower(c)) c = toupper(c); + s = (char *) strchr(basis_hex, c); + if (s) return(s-basis_hex); + return(-1); +} +*/ + +static void +toqp(FILE *infile, FILE *outfile) +{ + int c, ct=0, prevc=255; + while ((c = getc(infile)) != EOF) { + if ((c < 32 && (c != '\n' && c != '\t')) + || (c == '=') + || (c >= 127) + /* Following line is to avoid single periods alone on lines, + which messes up some dumb smtp implementations, sigh... */ + || (ct == 0 && c == '.')) { + putc('=', outfile); + putc(basis_hex[c>>4], outfile); + putc(basis_hex[c&0xF], outfile); + ct += 3; + prevc = 'A'; /* close enough */ + } else if (c == '\n') { + if (prevc == ' ' || prevc == '\t') { + putc('=', outfile); /* soft & hard lines */ + putc(c, outfile); + } + putc(c, outfile); + ct = 0; + prevc = c; + } else { + if (c == 'F' && prevc == '\n') { + /* HORRIBLE but clever hack suggested by MTR for sendmail-avoidance */ + c = getc(infile); + if (c == 'r') { + c = getc(infile); + if (c == 'o') { + c = getc(infile); + if (c == 'm') { + c = getc(infile); + if (c == ' ') { + /* This is the case we are looking for */ + fputs("=46rom", outfile); + ct += 6; + } else { + fputs("From", outfile); + ct += 4; + } + } else { + fputs("Fro", outfile); + ct += 3; + } + } else { + fputs("Fr", outfile); + ct += 2; + } + } else { + putc('F', outfile); + ++ct; + } + ungetc(c, infile); + prevc = 'x'; /* close enough -- printable */ + } else { /* END horrible hack */ + putc(c, outfile); + ++ct; + prevc = c; + } + } + if (ct > 72) { + putc('=', outfile); + putc('\n', outfile); + ct = 0; + prevc = '\n'; + } + } + if (ct) { + putc('=', outfile); + putc('\n', outfile); + } +} + +static void +fromqp(FILE *infile, FILE *outfile, char **boundaries, int *boundaryct) +{ + unsigned int c1, c2; + int sawnewline = 1, neednewline = 0; + /* The neednewline hack is necessary because the newline leading into + a multipart boundary is part of the boundary, not the data */ + + while ((c1 = getc(infile)) != EOF) { + if (sawnewline && boundaries && (c1 == '-')) { + char Buf[200]; + unsigned char *s; + + ungetc(c1, infile); + fgets(Buf, sizeof(Buf), infile); + if (boundaries + && (Buf[0] == '-') + && (Buf[1] == '-') + && PendingBoundary(Buf, boundaries, boundaryct)) { + return; + } + /* Not a boundary, now we must treat THIS line as q-p, sigh */ + if (neednewline) { + putc('\n', outfile); + neednewline = 0; + } + for (s=(unsigned char *) Buf; *s; ++s) { + if (*s == '=') { + if (!*++s) break; + if (*s == '\n') { + /* ignore it */ + sawnewline = 1; + } else { + c1 = hexchar(*s); + if (!*++s) break; + c2 = hexchar(*s); + putc(c1<<4 | c2, outfile); + } + } else { +#ifdef MSDOS + if (*s == '\n') + putc('\r', outfile); /* insert CR for binary-mode write */ +#endif + putc(*s, outfile); + } + } + } else { + if (neednewline) { + putc('\n', outfile); + neednewline = 0; + } + if (c1 == '=') { + sawnewline = 0; + c1 = getc(infile); + if (c1 == '\n') { + /* ignore it */ + sawnewline = 1; + } else { + c2 = getc(infile); + c1 = hexchar(c1); + c2 = hexchar(c2); + putc(c1<<4 | c2, outfile); + if (c2 == '\n') sawnewline = 1; + } + } else { + if (c1 == '\n') { + sawnewline = 1; + neednewline = 1; + } else { + sawnewline = 0; + putc(c1, outfile); + } + } + } + } + if (neednewline) { + putc('\n', outfile); + neednewline = 0; + } +} + + +/* +Copyright (c) 1991 Bell Communications Research, Inc. (Bellcore) + +Permission to use, copy, modify, and distribute this material +for any purpose and without fee is hereby granted, provided +that the above copyright notice and this permission notice +appear in all copies, and that the name of Bellcore not be +used in advertising or publicity pertaining to this +material without the specific, prior written permission +of an authorized representative of Bellcore. BELLCORE +MAKES NO REPRESENTATIONS ABOUT THE ACCURACY OR SUITABILITY +OF THIS MATERIAL FOR ANY PURPOSE. IT IS PROVIDED "AS IS", +WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. +*/ +#ifdef MSDOS +#include +#endif + +#define BASE64 1 +#define QP 2 /* quoted-printable */ + +int main(int argc, char *argv[]) +{ + int encode = 1, which = BASE64, i, portablenewlines = 0; + FILE *fp = stdin; + FILE *fpo = stdout; + + for (i=1; i= argc) { + fprintf(stderr, "mimencode: -o requires a file name.\n"); + exit(-1); + } + fpo = fopen(argv[i], "w"); + if (!fpo) { + perror(argv[i]); + exit(-1); + } + break; + case 'u': + encode = 0; + break; + case 'q': + which = QP; + break; + case 'p': + portablenewlines = 1; + break; + case 'b': + which = BASE64; + break; + default: + fprintf(stderr, + "Usage: mmencode [-u] [-q] [-b] [-p] [-o outputfile] [file name]\n"); + exit(-1); + } + } else { +#ifdef MSDOS + if (encode) + fp = fopen(argv[i], "rb"); + else + { + fp = fopen(argv[i], "rt"); + setmode(fileno(fpo), O_BINARY); + } /* else */ +#else + fp = fopen(argv[i], "r"); +#endif /* MSDOS */ + if (!fp) { + perror(argv[i]); + exit(-1); + } + } + } +#ifdef MSDOS + if (fp == stdin) setmode(fileno(fp), O_BINARY); +#endif /* MSDOS */ + if (which == BASE64) { + if (encode) { + to64(fp, fpo, portablenewlines); + } else { + from64(fp,fpo, (char **) NULL, (int *) 0, portablenewlines); + } + } else { + if (encode) toqp(fp, fpo); else fromqp(fp, fpo, NULL, 0); + } + return(0); +} + diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/tm-au --- a/lib-src/tm-au Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/tm-au Mon Aug 13 08:48:42 2007 +0200 @@ -1,8 +1,10 @@ #!/bin/sh - # -# $Id: tm-au,v 1.2 1996/12/29 00:14:55 steve Exp $ +# $Id: tm-au,v 1.3 1997/01/11 22:09:59 steve Exp $ # +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH + if [ "$TM_TMP_DIR" = "" ]; then TM_TMP_DIR=/tmp export TM_TMP_DIR diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/tm-file --- a/lib-src/tm-file Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/tm-file Mon Aug 13 08:48:42 2007 +0200 @@ -1,8 +1,10 @@ #!/bin/sh - # -# $Id: tm-file,v 1.2 1996/12/29 00:14:55 steve Exp $ +# $Id: tm-file,v 1.3 1997/01/11 22:09:59 steve Exp $ # +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH + if [ "$TM_TMP_DIR" = "" ]; then TM_TMP_DIR=/tmp export TM_TMP_DIR diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/tm-html --- a/lib-src/tm-html Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/tm-html Mon Aug 13 08:48:42 2007 +0200 @@ -1,8 +1,10 @@ #!/bin/sh # -# $Id: tm-html,v 1.2 1996/12/29 00:14:55 steve Exp $ +# $Id: tm-html,v 1.3 1997/01/11 22:09:59 steve Exp $ # +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH + if [ "$TM_TMP_DIR" = "" ]; then TM_TMP_DIR=/tmp export TM_TMP_DIR diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/tm-mpeg --- a/lib-src/tm-mpeg Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/tm-mpeg Mon Aug 13 08:48:42 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-mpeg,v 1.2 1996/12/29 00:14:55 steve Exp $ +# $Id: tm-mpeg,v 1.3 1997/01/11 22:09:59 steve Exp $ # # Copyright 1994, 1995, 1996 Free Software Foundation, Inc. @@ -19,6 +19,8 @@ # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH + if [ "$TM_TMP_DIR" = "" ]; then TM_TMP_DIR=/tmp export TM_TMP_DIR diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/tm-ps --- a/lib-src/tm-ps Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/tm-ps Mon Aug 13 08:48:42 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-ps,v 1.2 1996/12/29 00:14:56 steve Exp $ +# $Id: tm-ps,v 1.3 1997/01/11 22:10:00 steve Exp $ # # Copyright 1994, 1995, 1996 Free Software Foundation, Inc. @@ -19,6 +19,8 @@ # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH + if [ "$TM_TMP_DIR" = "" ]; then TM_TMP_DIR=/tmp export TM_TMP_DIR diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/tmdecode --- a/lib-src/tmdecode Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/tmdecode Mon Aug 13 08:48:42 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tmdecode,v 1.2 1996/12/29 00:14:56 steve Exp $ +# $Id: tmdecode,v 1.3 1997/01/11 22:10:00 steve Exp $ # # Copyright 1994, 1995, 1996 Free Software Foundation, Inc. @@ -19,6 +19,8 @@ # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH + trap 'rm -f $2' 0 1 2 3 13 15 case "$3" in diff -r 13c6d0aaafe5 -r 9ee227acff29 lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 08:48:18 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 08:48:42 2007 +0200 @@ -54,7 +54,7 @@ REAL=`cd \`dirname $EMACS\` ; pwd | sed 's|^/tmp_mnt||'`/`basename $EMACS` -BYTECOMP="$REAL -batch -q -no-site-file -l bytecomp" +BYTECOMP="$REAL -batch -q -no-site-file " echo "Recompiling in `pwd|sed 's|^/tmp_mnt||'`" echo " with $REAL..." @@ -114,7 +114,6 @@ \!/tm/!d \!/tl/!d \!/mel/!d -\!/url/!d \!/viper/!d \!/vm/!d \!/w3/!d @@ -153,11 +152,6 @@ ( cd lisp/gnus ; make EMACS=$REAL some ) echo Gnus done. -# This is really part of w3. -echo Compiling URL... -( cd lisp/url ; make EMACS=$REAL ) -echo URL done. - # and gee w3 has its own makefile as well # (no especial need to use it, though) echo Compiling W3... diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/comint/telnet.el --- a/lisp/comint/telnet.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/comint/telnet.el Mon Aug 13 08:48:42 2007 +0200 @@ -73,7 +73,7 @@ (defvar telnet-program "telnet" "Program to run to open a telnet connection.") -(defvar telnet-initial-count -50 +(defvar telnet-initial-count -75 "Initial value of `telnet-count'. Should be set to the negative of the number of terminal writes telnet will make setting up the host connection.") @@ -130,29 +130,31 @@ (setq comint-prompt-regexp telnet-prompt-pattern)) (defun telnet-initial-filter (proc string) - ;For reading up to and including password; also will get machine type. - (cond ((string-match "No such host" string) - (kill-buffer (process-buffer proc)) - (error "No such host.")) - ((string-match "passw" string) - (telnet-filter proc string) - (let ((password (comint-read-noecho "Password: " t))) - (setq telnet-count 0) - (process-send-string proc (concat password telnet-new-line)))) - (t (telnet-check-software-type-initialize string) + (let ((case-fold-search t)) + ;For reading up to and including password; also will get machine type. + (cond ((string-match "No such host" string) + (kill-buffer (process-buffer proc)) + (error "No such host.")) + ((string-match "passw" string) (telnet-filter proc string) - (cond ((> telnet-count telnet-maximum-count) - ;; (set-process-filter proc 'telnet-filter) - ;; Kludge for shell-fonts -- this is the only mode that - ;; actually changes what its process filter is at run time, - ;; which confuses shell-font. So we special-case that here. - ;; #### Danger, knows an internal shell-font variable name. - (let ((old-filter (process-filter proc))) - (if (eq old-filter 'shell-font-process-filter) - (set (make-local-variable 'shell-font-process-filter) - 'telnet-filter) - (set-process-filter proc 'telnet-filter)))) - (t (setq telnet-count (1+ telnet-count))))))) + (let ((password (comint-read-noecho "Password: " t))) + (setq telnet-count 0) + (process-send-string proc (concat password telnet-new-line)))) + (t (telnet-check-software-type-initialize string) + (telnet-filter proc string) + (cond ((> telnet-count telnet-maximum-count) + ;; (set-process-filter proc 'telnet-filter) Kludge + ;; for shell-fonts -- this is the only mode that + ;; actually changes what its process filter is at + ;; run time, which confuses shell-font. So we + ;; special-case that here. + ;; #### Danger, knows an internal shell-font variable name. + (let ((old-filter (process-filter proc))) + (if (eq old-filter 'shell-font-process-filter) + (set (make-local-variable 'shell-font-process-filter) + 'telnet-filter) + (set-process-filter proc 'telnet-filter)))) + (t (setq telnet-count (1+ telnet-count)))))))) ;; Identical to comint-simple-send, except that it sends telnet-new-line ;; instead of "\n". diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/Makefile --- a/lisp/ediff/Makefile Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/Makefile Mon Aug 13 08:48:42 2007 +0200 @@ -34,10 +34,6 @@ ediff-ptch.elc ediff.elc ediff-hook.elc # ediff-tbar.elc -PRELOADS = -l ./ediff-init.el -l ./ediff-help.el -l ./ediff-diff.el \ - -l ./ediff-wind.el -l ./ediff-merg.el -l ./ediff-mult.el \ - -l ./ediff-util.el -l ./ediff.el -# -l ./ediff-tbar.el all: hello elc goodbye dvi info @@ -80,39 +76,39 @@ ediff-tbar.elc: ediff-tbar.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-tbar.el + $(EMACS) -batch -f batch-byte-compile ediff-tbar.el ediff-diff.elc: ediff-init.el ediff-diff.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-diff.el + $(EMACS) -batch -f batch-byte-compile ediff-diff.el ediff-merg.elc: ediff-init.el ediff-merg.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-merg.el + $(EMACS) -batch -f batch-byte-compile ediff-merg.el ediff-mult.elc: ediff-init.el ediff-mult.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-mult.el + $(EMACS) -batch -f batch-byte-compile ediff-mult.el ediff-vers.elc: ediff-init.el ediff-vers.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-vers.el + $(EMACS) -batch -f batch-byte-compile ediff-vers.el ediff-ptch.elc: ediff-init.el ediff-ptch.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-ptch.el + $(EMACS) -batch -f batch-byte-compile ediff-ptch.el ediff.elc: ediff-init.el ediff.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff.el + $(EMACS) -batch -f batch-byte-compile ediff.el ediff-util.elc: ediff-init.el ediff-util.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-util.el + $(EMACS) -batch -f batch-byte-compile ediff-util.el ediff-wind.elc: ediff-init.el ediff-wind.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile ediff-wind.el + $(EMACS) -batch -f batch-byte-compile ediff-wind.el ediff.dvi: ediff.texi @echo "" @@ -156,7 +152,7 @@ rm -f ediff*.elc *~ core distclean: clean - + realclean: clean rm -f *.dvi ediff.info* rm -f ediff.aux ediff.cp ediff.cps ediff.fn ediff.fns ediff.ky \ diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/README --- a/lisp/ediff/README Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/README Mon Aug 13 08:48:42 2007 +0200 @@ -12,6 +12,7 @@ ediff.el -- Ediff Emacs Lisp code ediff-init.el -- Ediff Emacs Lisp code +ediff-help.el -- Ediff Emacs Lisp code ediff-wind.el -- Ediff Emacs Lisp code ediff-util.el -- Ediff Emacs Lisp code ediff-diff.el -- Ediff Emacs Lisp code diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-diff.el --- a/lisp/ediff/ediff-diff.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-diff.el Mon Aug 13 08:48:42 2007 +0200 @@ -23,6 +23,20 @@ ;;; Code: +(provide 'ediff-diff) + +;; compiler pacifier +(defvar ediff-default-variant) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-util) + (load "ediff-util.el" nil nil 'nosuffix)) + )) +;; end pacifier + (require 'ediff-init) @@ -1204,7 +1218,5 @@ ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: -(provide 'ediff-diff) - ;; ediff-diff.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-help.el --- a/lisp/ediff/ediff-help.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-help.el Mon Aug 13 08:48:42 2007 +0200 @@ -22,17 +22,21 @@ ;; Boston, MA 02111-1307, USA. ;;; Code: - -(require 'ediff-init) + +(provide 'ediff-help) ;; Compiler pacifier start (defvar ediff-multiframe) -(and noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (load-file "ediff-init.el")))) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + )) ;; end pacifier +(require 'ediff-init) + ;; Help messages (defconst ediff-long-help-message-head @@ -178,8 +182,7 @@ "Explain Ediff commands in more detail." (interactive) (ediff-barf-if-not-control-buffer) - (let ((ctl-buf (current-buffer)) - (pos (ediff-event-point last-command-event)) + (let ((pos (ediff-event-point last-command-event)) overl cmd) (if ediff-xemacs-p @@ -306,6 +309,5 @@ ediff-brief-help-message)) (run-hooks 'ediff-display-help-hook)) -(provide 'ediff-help) ;;; ediff-help.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-hook.el --- a/lisp/ediff/ediff-hook.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-hook.el Mon Aug 13 08:48:42 2007 +0200 @@ -38,24 +38,31 @@ (defvar epatch-menu) ;; end pacifier +;; allow menus to be set up without ediff-wind.el being loaded +(defvar ediff-window-setup-function) + (defun ediff-xemacs-init-menus () + (setq ediff-window-setup-function + (if (console-on-window-system-p) + 'ediff-setup-windows-multiframe + 'ediff-setup-windows-plain)) (if (featurep 'menubar) (progn -;; (add-menu-button -;; '("Tools") -;; ["Use separate frame for Ediff control buffer" -;; ediff-toggle-multiframe -;; :style toggle -;; :selected (eq ediff-window-setup-function 'ediff-setup-windows-multiframe)] -;; "00-Browser...") -;; (add-menu-button -;; '("Tools") -;; ["Use a toolbar with Ediff control buffer" -;; ediff-menu-toggle-use-toolbar -;; :style toggle -;; :selected (ediff-use-toolbar-p)] -;; "00-Browser...") + (add-menu-button + '("Tools") + ["Use separate frame for Ediff control buffer" + ediff-toggle-multiframe + :style toggle + :selected (eq ediff-window-setup-function 'ediff-setup-windows-multiframe)] + "00-Browser...") + ;;(add-menu-button + ;; '("Tools") + ;; ["Use a toolbar with Ediff control buffer" + ;; ediff-toggle-use-toolbar + ;; :style toggle + ;; :selected (ediff-use-toolbar-p)] + ;; "00-Browser...") (add-submenu '("Tools") ediff-menu "OO-Browser...") (add-submenu @@ -144,8 +151,8 @@ (define-key menu-bar-ediff-menu [ediff-doc] '("Ediff Manual..." . ediff-documentation)) (define-key menu-bar-ediff-menu [emultiframe] - '("Toggle separate control buffer frame..." - . ediff-toggle-multiframe)) + '("Toggle separate control buffer frame..." + . ediff-toggle-multiframe)) (define-key menu-bar-ediff-menu [eregistry] '("List Ediff Sessions..." . ediff-show-registry)) (define-key menu-bar-ediff-menu [separator-ediff-manual] '("--")) @@ -184,8 +191,8 @@ (define-key menu-bar-ediff-merge-menu [ediff-doc2] '("Ediff Manual..." . ediff-documentation)) (define-key menu-bar-ediff-merge-menu [emultiframe2] - '("Toggle separate control buffer frame..." - . ediff-toggle-multiframe)) + '("Toggle separate control buffer frame..." + . ediff-toggle-multiframe)) (define-key menu-bar-ediff-merge-menu [eregistry2] '("List Ediff Sessions..." . ediff-show-registry)) (define-key @@ -226,10 +233,10 @@ (define-key menu-bar-epatch-menu [ediff-doc3] '("Ediff Manual..." . ediff-documentation)) (define-key menu-bar-epatch-menu [emultiframe3] - '("Toggle separate control buffer frame..." - . ediff-toggle-multiframe)) + '("Toggle separate control buffer frame..." + . ediff-toggle-multiframe)) (define-key menu-bar-epatch-menu [eregistry3] - '("List Ediff Sessions..." . ediff-show-registry)) + '("List Ediff Sessions..." . ediff-show-registry)) (define-key menu-bar-epatch-menu [separator-epatch] '("--")) (define-key menu-bar-epatch-menu [ediff-patch-buffer] '("To a Buffer..." . ediff-patch-buffer)) @@ -338,11 +345,13 @@ "ediff-util" "Toggle the use of separate frame for Ediff control buffer." t) -;;(if (string-match "XEmacs" emacs-version) -;; (autoload 'ediff-toggle-use-toolbar -;; "ediff-tbar" -;; "Toggle the use of Ediff toolbar." -;; t)) + (condition-case nil + (if (string-match "XEmacs" emacs-version) + (autoload 'ediff-toggle-use-toolbar + "ediff-tbar" + "Toggle the use of Ediff toolbar." + t)) + (error)) ) ; if purify-flag diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-init.el --- a/lisp/ediff/ediff-init.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-init.el Mon Aug 13 08:48:42 2007 +0200 @@ -63,7 +63,7 @@ (ediff-emacs-p (memq (ediff-device-type) '(pc))) (ediff-xemacs-p (memq (ediff-device-type) '(tty pc))))) - + ;; Defines SYMBOL as an advertised local variable. ;; Performs a defvar, then executes `make-variable-buffer-local' on ;; the variable. Also sets the `permanent-local' property, @@ -513,7 +513,7 @@ ;; Buffer-local variables to be saved then restored during Ediff sessions ;; Buffer-local variables to be saved then restored during Ediff sessions (defconst ediff-protected-variables '( - ;;buffer-read-only + ;;buffer-read-only mode-line-format)) ;; Vector of differences between the variants. Each difference is @@ -1157,6 +1157,7 @@ (car (if ediff-xemacs-p (ange-ftp-ftp-path file-name) (ange-ftp-ftp-name file-name)))) + (defsubst ediff-frame-unsplittable-p (frame) (cdr (assq 'unsplittable (frame-parameters frame)))) @@ -1173,6 +1174,14 @@ (if (ediff-buffer-live-p buf) (kill-buffer (get-buffer buf)))) +(defsubst ediff-background-face (buf-type dif-num) + ;; The value of dif-num is always 1- the one that user sees. + ;; This is why even face is used when dif-num is odd. + (intern (format (if (ediff-odd-p dif-num) + "ediff-even-diff-face-%S" + "ediff-odd-diff-face-%S") + buf-type))) + ;; activate faces on diff regions in buffer (defun ediff-paint-background-regions-in-one-buffer (buf-type unhighlight) @@ -1183,11 +1192,13 @@ (lambda (rec) (setq overl (ediff-get-diff-overlay-from-diff-record rec) diff-num (ediff-overlay-get overl 'ediff-diff-num)) - (ediff-set-overlay-face - overl - (if (not unhighlight) - (ediff-background-face buf-type diff-num)) - ))) + (if (ediff-overlay-buffer overl) + ;; only if overlay is alive + (ediff-set-overlay-face + overl + (if (not unhighlight) + (ediff-background-face buf-type diff-num)))) + )) diff-vector))) @@ -1237,7 +1248,7 @@ ) (ediff-move-overlay current-diff-overlay 1 1) - + ;; rehighlight the overlay in the background of the ;; current difference region (ediff-set-overlay-face @@ -1259,6 +1270,7 @@ (ediff-delete-overlay current-diff-overlay)) (set current-diff-overlay-var nil) ))) + (defsubst ediff-highlight-diff (n) "Put face on diff N. Invoked for X displays only." @@ -1285,14 +1297,6 @@ (ediff-unhighlight-diffs-totally-in-one-buffer 'Ancestor) ) -(defsubst ediff-background-face (buf-type dif-num) - ;; The value of dif-num is always 1- the one that user sees. - ;; This is why even face is used when dif-num is odd. - (intern (format (if (ediff-odd-p dif-num) - "ediff-even-diff-face-%S" - "ediff-odd-diff-face-%S") - buf-type))) - ;; arg is a record for a given diff in a difference vector ;; this record is itself a vector @@ -1417,6 +1421,18 @@ ;; Some overlay functions +(defsubst ediff-overlay-start (overl) + (if (ediff-overlayp overl) + (if ediff-emacs-p + (overlay-start overl) + (extent-start-position overl)))) + +(defsubst ediff-overlay-end (overl) + (if (ediff-overlayp overl) + (if ediff-emacs-p + (overlay-end overl) + (extent-end-position overl)))) + (defsubst ediff-empty-overlay-p (overl) (= (ediff-overlay-start overl) (ediff-overlay-end overl))) @@ -1592,17 +1608,17 @@ (defun ediff-convert-standard-filename (fname) - (if ediff-emacs-p + (if (fboundp 'convert-standard-filename) (convert-standard-filename fname) - ;; hopefully, XEmacs adds this functionality fname)) + ;;; Local Variables: ;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) ;;; eval: (put 'ediff-eval-in-buffer 'lisp-indent-hook 1) ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: - + (provide 'ediff-init) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-merg.el --- a/lisp/ediff/ediff-merg.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-merg.el Mon Aug 13 08:48:42 2007 +0200 @@ -23,6 +23,24 @@ ;;; Code: +(provide 'ediff-merg) + +;; compiler pacifier +(defvar ediff-window-A) +(defvar ediff-window-B) +(defvar ediff-window-C) +(defvar ediff-merge-window-share) +(defvar ediff-window-config-saved) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-util) + (load "ediff-util.el" nil nil 'nosuffix)) + )) +;; end pacifier + (require 'ediff-init) @@ -270,6 +288,4 @@ ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: -(provide 'ediff-merg) - ;; ediff-merg.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-mult.el --- a/lisp/ediff/ediff-mult.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-mult.el Mon Aug 13 08:48:42 2007 +0200 @@ -26,7 +26,7 @@ ;; Users are encouraged to add functionality to this file. ;; The present file contains all the infrastructure needed for that. ;; -;; Generally, to implement a new multisession capability within Ediff, +;; Generally, to to implement a new multisession capability within Ediff, ;; you need to tell it ;; ;; 1. How to display the session group buffer. @@ -90,7 +90,20 @@ ;;; Code: +(provide 'ediff-mult) + +;; compiler pacifier +(eval-when-compile + (let ((load-path (cons (expand-file-name ".") load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-util) + (load "ediff-util.el" nil nil 'nosuffix)) + )) +;; end pacifier + (require 'ediff-init) +(require 'ediff-util) ;; meta-buffer (ediff-defvar-local ediff-meta-buffer nil "") @@ -366,7 +379,7 @@ (ediff-add-slash-if-directory auxdir1 elt))) lis1) auxdir2 (file-name-as-directory dir2) - lis2 (mapcar + lis2 (mapcar (function (lambda (elt) (ediff-add-slash-if-directory auxdir2 elt))) @@ -374,7 +387,7 @@ (if (stringp dir3) (setq auxdir3 (file-name-as-directory dir3) - lis3 (mapcar + lis3 (mapcar (function (lambda (elt) (ediff-add-slash-if-directory auxdir3 elt))) @@ -732,7 +745,7 @@ (feq (ediff-get-file-eqstatus fileinfo)) file-modtime file-size) - (cond ((not (stringp fname)) (setq file-size -2)) ; file doesn't exist + (cond ((not (stringp fname)) (setq file-size -2)) ; file doesn't exits ((not (ediff-file-remote-p fname)) (if (file-exists-p fname) ;; set real size and modtime @@ -1017,7 +1030,6 @@ (meta-buf (ediff-event-buffer last-command-event)) ;; ediff-get-meta-info gives error if meta-buf or pos are invalid (info (ediff-get-meta-info meta-buf pos)) - merge-autostore-dir (session-buf (ediff-get-session-buffer info))) (if (eq (ediff-get-session-status info) ?H) @@ -1198,6 +1210,7 @@ (meta-buf (ediff-event-buffer last-command-event)) ;; ediff-get-meta-info gives error if meta-buf or pos are invalid (info (ediff-get-meta-info meta-buf pos)) + merge-autostore-dir session-buf file1 file2 file3 regexp) (setq session-buf (ediff-get-session-buffer info) @@ -1718,7 +1731,4 @@ ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: -(provide 'ediff-mult) -(require 'ediff-util) - ;;; ediff-mult.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-ptch.el --- a/lisp/ediff/ediff-ptch.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-ptch.el Mon Aug 13 08:48:42 2007 +0200 @@ -23,6 +23,26 @@ ;;; Code: + +(provide 'ediff-ptch) + +;; compiler pacifier +(defvar ediff-window-A) +(defvar ediff-window-B) +(defvar ediff-window-C) +(defvar ediff-use-last-dir) +(defvar ediff-shell) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff) + (load "ediff.el" nil nil 'nosuffix)) + (or (featurep 'ange-ftp) + (load "ange-ftp" 'noerror)) + )) +;; end pacifier (require 'ediff-init) @@ -540,7 +560,7 @@ (select-window aux-wind) (bury-buffer))) (error "Patch appears to have failed"))) - + ;; If black magic is involved, apply patch to a temp copy of the ;; file. Otherwise, apply patch to the orig copy. If patch is applied ;; to temp copy, we name the result old-name_patched for local files @@ -571,11 +591,11 @@ ;; arrange that the temp copy of orig will be deleted (rename-file (concat true-source-filename ediff-backup-extension) true-source-filename t)) - + ;; make orig buffer read-only (setq startup-hooks (cons 'ediff-set-read-only-in-buf-A startup-hooks)) - + ;; set up a buf for the patched file (setq target-buf (find-file-noselect target-filename)) @@ -625,6 +645,4 @@ ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: -(provide 'ediff-ptch) - ;;; ediff-ptch.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-util.el --- a/lisp/ediff/ediff-util.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-util.el Mon Aug 13 08:48:42 2007 +0200 @@ -22,27 +22,51 @@ ;; Boston, MA 02111-1307, USA. ;;; Code: + +(provide 'ediff-util) -;; Pacify compiler and avoid the need in checking for boundp -(defvar ediff-patch-diagnostics nil) -(defvar ediff-patchbufer nil) -(and noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (load-file "ediff-init.el") - (load-file "ediff-help.el")))) +;; Compiler pacifier +(defvar ediff-patch-diagnostics) +(defvar ediff-patchbufer) +(defvar ediff-toolbar) +(defvar mark-active) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-help) + (load "ediff-help.el" nil nil 'nosuffix)) + (or (featurep 'ediff-mult) + (load "ediff-mult.el" nil nil 'nosuffix)) + (or (featurep 'ediff-wind) + (load "ediff-wind.el" nil nil 'nosuffix)) + (or (featurep 'ediff-diff) + (load "ediff-diff.el" nil nil 'nosuffix)) + (or (featurep 'ediff-merg) + (load "ediff-merg.el" nil nil 'nosuffix)) + (or (featurep 'ediff) + (load "ediff.el" nil nil 'nosuffix)) + (or (featurep 'ediff-tbar) + (load "ediff-tbar.el" 'noerror nil 'nosuffix)) + )) ;; end pacifier (require 'ediff-init) (require 'ediff-help) (require 'ediff-mult) +(require 'ediff-wind) +(require 'ediff-diff) +(require 'ediff-merg) -;;(if ediff-xemacs-p -;; (require 'ediff-tbar) -;; (defun ediff-use-toolbar-p () nil)) -;; -;; for the time being -(defun ediff-use-toolbar-p () nil) + +;; be careful with ediff-tbar +(if ediff-xemacs-p + (condition-case nil + (require 'ediff-tbar) + (error + (defun ediff-use-toolbar-p () nil))) + (defun ediff-use-toolbar-p () nil)) ;;; Functions @@ -83,9 +107,6 @@ (run-hooks 'ediff-mode-hook)) -(require 'ediff-diff) -(require 'ediff-merg) - ;;; Build keymaps @@ -218,8 +239,6 @@ ;;; Setup functions -(require 'ediff-wind) - ;; No longer needed: XEmacs has surrogate minibuffers now. ;;(or (boundp 'synchronize-minibuffers) ;; (defvar synchronize-minibuffers nil)) @@ -501,7 +520,7 @@ (goto-char (point-min)) (skip-chars-forward ediff-whitespace))) - + ;;; Commands for working with Ediff @@ -1159,36 +1178,47 @@ (ediff-eval-in-buffer ctl-buf (setq ediff-window-B nil) ; force update of window config (ediff-recenter 'no-rehighlight))))) - + ;;;###autoload (defun ediff-toggle-multiframe () "Switch from the multiframe display to single-frame display and back. For a permanent change, set the variable `ediff-window-setup-function', which see." (interactive) - (let (set-func) - (or (ediff-window-display-p) - (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) + (let (set-func window-setup-func) + (or (ediff-window-display-p) + (error "%sEmacs is not running as a window application" + (if ediff-emacs-p "" "X"))) - (setq set-func (if (ediff-in-control-buffer-p) 'setq 'setq-default)) + ;;(setq set-func (if (ediff-in-control-buffer-p) 'setq 'setq-default)) (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe) - (eval - (list - set-func - 'ediff-window-setup-function ''ediff-setup-windows-plain))) + ;; (eval + ;; (list + ;; set-func + ;; 'ediff-window-setup-function ''ediff-setup-windows-plain)) + (setq window-setup-func 'ediff-setup-windows-plain) + ) ((eq ediff-window-setup-function 'ediff-setup-windows-plain) (if (ediff-in-control-buffer-p) (ediff-kill-bottom-toolbar)) - (eval - (list - set-func - 'ediff-window-setup-function ''ediff-setup-windows-multiframe)))) + ;;(eval + ;; (list + ;; set-func + ;; 'ediff-window-setup-function 'ediff-setup-windows-multiframe)) + (setq window-setup-func 'ediff-setup-windows-multiframe) + )) + + ;; change default + (setq-default ediff-window-setup-function window-setup-func) + ;; change in all active ediff sessions + (mapcar (function (lambda(buf) + (ediff-eval-in-buffer buf + (setq ediff-window-setup-function window-setup-func + ediff-window-B nil)))) + ediff-session-registry) (if (ediff-in-control-buffer-p) - (progn - (setq ediff-window-B nil) - (ediff-recenter 'no-rehighlight))))) + (ediff-recenter 'no-rehighlight)))) ;; if was using toolbar, kill it (defun ediff-kill-bottom-toolbar () @@ -1266,7 +1296,7 @@ (narrow-to-region (ediff-overlay-start overl-B) (ediff-overlay-end overl-B))) - (if ediff-3way-comparison-job + (if ediff-3way-job (ediff-eval-in-buffer ediff-buffer-C (narrow-to-region (ediff-overlay-start overl-C) (ediff-overlay-end overl-C)))) @@ -1516,6 +1546,7 @@ (+ ediff-current-difference arg))) regexp-skip) + (ediff-visible-region) (or (>= n ediff-number-of-differences) (setq regexp-skip (funcall ediff-skip-diff-region-function n)) (ediff-install-fine-diff-if-necessary n)) @@ -1552,6 +1583,7 @@ (let ((n (max -1 (- ediff-current-difference arg))) regexp-skip) + (ediff-visible-region) (or (< n 0) (setq regexp-skip (funcall ediff-skip-diff-region-function n)) (ediff-install-fine-diff-if-necessary n)) @@ -2319,9 +2351,10 @@ (ediff-kill-buffer-carefully ediff-fine-diff-buffer) (ediff-kill-buffer-carefully ediff-tmp-buffer) (ediff-kill-buffer-carefully ediff-error-buffer) - (ediff-kill-buffer-carefully ediff-patch-diagnostics) (ediff-kill-buffer-carefully ediff-msg-buffer) (ediff-kill-buffer-carefully ediff-debug-buffer) + (if (boundp 'ediff-patch-diagnostics) + (ediff-kill-buffer-carefully ediff-patch-diagnostics)) (if (and (ediff-window-display-p) (frame-live-p ctl-frame)) (delete-frame ctl-frame)) @@ -2445,8 +2478,9 @@ (buf-A-wind (ediff-get-visible-buffer-window buf-A)) (buf-B-wind (ediff-get-visible-buffer-window buf-B)) (buf-C-wind (ediff-get-visible-buffer-window buf-C)) - (buf-patch ediff-patchbufer) - (buf-patch-diag ediff-patch-diagnostics) + (buf-patch (if (boundp 'ediff-patchbufer) ediff-patchbufer nil)) + (buf-patch-diag (if (boundp 'ediff-patch-diagnostics) + ediff-patch-diagnostics nil)) (buf-err ediff-error-buffer) (buf-diff ediff-diff-buffer) (buf-custom-diff ediff-custom-diff-buffer) @@ -2467,20 +2501,28 @@ (select-window buf-A-wind) (delete-other-windows) (bury-buffer)) - (if (ediff-buffer-live-p buf-A) (bury-buffer buf-A))) + (if (ediff-buffer-live-p buf-A) + (progn + (set-buffer buf-A) + (bury-buffer)))) (if (window-live-p buf-B-wind) (progn (select-window buf-B-wind) (delete-other-windows) (bury-buffer)) - (if (ediff-buffer-live-p buf-B) (bury-buffer buf-B))) + (if (ediff-buffer-live-p buf-B) + (progn + (set-buffer buf-B) + (bury-buffer)))) (if (window-live-p buf-C-wind) (progn (select-window buf-C-wind) (delete-other-windows) (bury-buffer)) - (if (ediff-buffer-live-p buf-C) (bury-buffer buf-C))) - + (if (ediff-buffer-live-p buf-C) + (progn + (set-buffer buf-C) + (bury-buffer)))) )) @@ -2906,16 +2948,19 @@ (let ((answer "") (possibilities (list ?A ?B ?C)) (zmacs-regions t) + (ctl-buf (current-buffer)) quit-now begA begB endA endB bufA bufB) (cond ((ediff-merge-job) (setq bufB ediff-buffer-C) - (while (cond ((memq answer '(?A ?a)) - (setq bufA ediff-buffer-A) + (while (cond ((eq answer ?A) + (setq bufA ediff-buffer-A + possibilities '(?B)) nil) - ((memq answer '(?B ?b)) - (setq bufA ediff-buffer-B) + ((eq answer ?B) + (setq bufA ediff-buffer-B + possibilities '(?A)) nil) ((equal answer "")) (t (beep 1) @@ -2924,7 +2969,7 @@ t)) (let ((cursor-in-echo-area t)) (message "Which buffer to compare to the merge buffer (A/B)? ") - (setq answer (read-char-exclusive))))) + (setq answer (capitalize (read-char-exclusive)))))) ((ediff-3way-comparison-job) (while (cond ((memq answer possibilities) @@ -2964,7 +3009,8 @@ (setq answer (capitalize (read-char-exclusive)))))) (t ; 2way comparison (setq bufA ediff-buffer-A - bufB ediff-buffer-B))) + bufB ediff-buffer-B + possibilities nil))) (ediff-eval-in-buffer bufA (or (mark t) @@ -3010,8 +3056,21 @@ ) ;; (sit-for 0) + ;; At this point, possibilities contains either the window char A/B/C + ;; that was not selected, or it is nil. We delete the window that is not + ;; selected. + (if possibilities + (ediff-eval-in-buffer ctl-buf + (let* ((wind-to-delete (eval + (intern + (format + "ediff-window-%c" (car possibilities))))) + (frame (window-frame wind-to-delete))) + (delete-window wind-to-delete) + (select-frame frame) + (balance-windows)))) (or (y-or-n-p - "Please check the selected regions. Continue? ") + "Please check regions selected for comparison. Continue? ") (setq quit-now t)) (ediff-eval-in-buffer bufA @@ -3019,7 +3078,10 @@ (ediff-eval-in-buffer bufB (widen)) (if quit-now - (error "Thank you. Come back another day...")) + (ediff-eval-in-buffer ctl-buf + (ediff-recenter) + (sit-for 0) + (error "All right. Make up your mind and come back..."))) (ediff-regions-internal bufA begA endA bufB begB endB @@ -3027,7 +3089,8 @@ 'ediff-regions-linewise ; job name nil) ; no word mode )) - + + (defun ediff-remove-flags-from-buffer (buffer overlay) (ediff-eval-in-buffer buffer @@ -3183,18 +3246,6 @@ (ediff-overlay-put overl 'ediff-diff-num 0) overl)))) -(defsubst ediff-overlay-start (overl) - (if (ediff-overlayp overl) - (if ediff-emacs-p - (overlay-start overl) - (extent-start-position overl)))) - -(defsubst ediff-overlay-end (overl) - (if (ediff-overlayp overl) - (if ediff-emacs-p - (overlay-end overl) - (extent-end-position overl)))) - ;; Like other-buffer, but prefers visible buffers and ignores temporary or ;; other insignificant buffers (those beginning with "^[ *]"). @@ -3593,6 +3644,4 @@ ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: -(provide 'ediff-util) - ;;; ediff-util.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-vers.el --- a/lisp/ediff/ediff-vers.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-vers.el Mon Aug 13 08:48:42 2007 +0200 @@ -30,13 +30,13 @@ (defvar cvs-shell) (defvar cvs-program) (defvar cvs-cookie-handle) +(defvar ediff-temp-file-prefix) -(and noninteractive - (eval-when-compile - (load "pcl-cvs" 'noerror) - (load "rcs" 'noerror) - (load "generic-sc" 'noerror) - (load "vc" 'noerror))) +(eval-when-compile + (load "pcl-cvs" 'noerror) + (load "rcs" 'noerror) + (load "generic-sc" 'noerror) + (load "vc" 'noerror)) ;; end pacifier ;; VC.el support @@ -67,7 +67,7 @@ 'ediff-revision))) ;; RCS.el support -(defun ediff-rcs-view-revision (&optional rev) +(defun rcs-ediff-view-revision (&optional rev) ;; View previous RCS revision of current file. ;; With prefix argument, prompts for a revision name. (interactive (list (if current-prefix-arg diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff-wind.el --- a/lisp/ediff/ediff-wind.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff-wind.el Mon Aug 13 08:48:42 2007 +0200 @@ -22,11 +22,8 @@ ;; Boston, MA 02111-1307, USA. ;;; Code: - -(require 'ediff-init) -;;(if ediff-xemacs-p -;; (nil) (require 'ediff-tbar) -(defun ediff-compute-toolbar-width () 0) + +(provide 'ediff-wind) ;; Compiler pacifier (defvar icon-title-format) @@ -38,8 +35,31 @@ (defvar right-toolbar-width) (defvar default-menubar) (defvar frame-icon-title-format) +(defvar ediff-diff-status) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-help) + (load "ediff-help.el" nil nil 'nosuffix)) + (or (featurep 'ediff-util) + (load "ediff-util.el" nil nil 'nosuffix)) + (or (featurep 'ediff-tbar) + (load "ediff-tbar.el" 'noerror nil 'nosuffix)) + )) ;; end pacifier +(require 'ediff-init) + +;; be careful with ediff-tbar +(if ediff-xemacs-p + (condition-case nil + (require 'ediff-tbar) + (error + (defun ediff-compute-toolbar-width () 0))) + (defun ediff-compute-toolbar-width () 0)) + (defvar ediff-window-setup-function (if (ediff-window-display-p) 'ediff-setup-windows-multiframe @@ -895,7 +915,7 @@ (modify-frame-parameters ctl-frame adjusted-parameters) (make-frame-visible ctl-frame) (ediff-make-bottom-toolbar) ; no effect if the toolbar is not requested - + ;; This works around a bug in 19.25 and earlier. There, if frame gets ;; iconified, the current buffer changes to that of the frame that ;; becomes exposed as a result of this iconification. @@ -1204,7 +1224,4 @@ ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: -(provide 'ediff-wind) - - ;;; ediff-wind.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/ediff/ediff.el --- a/lisp/ediff/ediff.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/ediff/ediff.el Mon Aug 13 08:48:42 2007 +0200 @@ -6,8 +6,8 @@ ;; Created: February 2, 1994 ;; Keywords: comparing, merging, patching, version control. -(defconst ediff-version "2.63" "The current version of Ediff") -(defconst ediff-date "September 12, 1996" "Date of last update") +(defconst ediff-version "2.64" "The current version of Ediff") +(defconst ediff-date "January 3, 1997" "Date of last update") ;; This file is part of GNU Emacs. @@ -106,17 +106,26 @@ ;;; Code: -(require 'ediff-init) -;; ediff-mult is always required, because of the registry stuff -(require 'ediff-mult) +(provide 'ediff) -(and noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (load-library "dired") - (load-file "ediff-ptch.el") - (load-file "ediff-vers.el") - (load "pcl-cvs" 'noerror)))) +;; Compiler pacifier +(eval-when-compile + (let ((load-path (cons "." load-path))) + (load "dired") + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-mult) + (load "ediff-mult.el" nil nil 'nosuffix)) + (or (featurep 'ediff-ptch) + (load "ediff-ptch.el" nil nil 'nosuffix)) + (or (featurep 'ediff-vers) + (load "ediff-vers.el" nil nil 'nosuffix)) + (load "pcl-cvs" 'noerror) + )) +;; end pacifier + +(require 'ediff-init) +(require 'ediff-mult) ; required because of the registry stuff (defvar ediff-use-last-dir nil "*If t, Ediff uses previous directory as default when reading file name.") @@ -693,7 +702,7 @@ (or (y-or-n-p "Directory for saving merges is the same as directory A. Sure? ") (error "Merge of directory revisions aborted"))) - + (setq file-list (ediff-get-directory-files-under-revision jobname regexp dir1 merge-autostore-dir)) @@ -1101,7 +1110,7 @@ ;;;###autoload (defun ediff-merge-revisions-with-ancestor (&optional file startup-hooks) "Run Ediff by merging two revisions of a file with a common ancestor. -The file is the optional FILE argument or the file visited by the current +The file is the the optional FILE argument or the file visited by the current buffer." (interactive) (if (stringp file) (find-file file)) @@ -1273,7 +1282,6 @@ ;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) ;;; End: -(provide 'ediff) (require 'ediff-util) ;;; ediff.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/games/decipher.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/games/decipher.el Mon Aug 13 08:48:42 2007 +0200 @@ -0,0 +1,1051 @@ +;;; decipher.el --- Cryptanalyze monoalphabetic substitution ciphers +;; +;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. +;; +;; Author: Christopher J. Madsen +;; Keywords: games +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Quick Start: +;; +;; To decipher a message, type or load it into a buffer and type +;; `M-x decipher'. This will format the buffer and place it into +;; Decipher mode. You can save your work to a file with the normal +;; Emacs save commands; when you reload the file it will automatically +;; enter Decipher mode. +;; +;; I'm not going to discuss how to go about breaking a cipher; try +;; your local library for a book on cryptanalysis. One book you might +;; find is: +;; Cryptanalysis: A study of ciphers and their solution +;; Helen Fouche Gaines +;; ISBN 0-486-20097-3 + +;;; Commentary: +;; +;; This package is designed to help you crack simple substitution +;; ciphers where one letter stands for another. It works for ciphers +;; with or without word divisions. (You must set the variable +;; decipher-ignore-spaces for ciphers without word divisions.) +;; +;; First, some quick definitions: +;; ciphertext The encrypted message (what you start with) +;; plaintext The decrypted message (what you are trying to get) +;; +;; Decipher mode displays ciphertext in uppercase and plaintext in +;; lowercase. You must enter the plaintext in lowercase; uppercase +;; letters are interpreted as commands. The ciphertext may be entered +;; in mixed case; `M-x decipher' will convert it to uppercase. +;; +;; Decipher mode depends on special characters in the first column of +;; each line. The command `M-x decipher' inserts these characters for +;; you. The characters and their meanings are: +;; ( The plaintext & ciphertext alphabets on the first line +;; ) The ciphertext & plaintext alphabets on the second line +;; : A line of ciphertext (with plaintext below) +;; > A line of plaintext (with ciphertext above) +;; % A comment +;; Each line in the buffer MUST begin with one of these characters (or +;; be left blank). In addition, comments beginning with `%!' are reserved +;; for checkpoints; see decipher-make-checkpoint & decipher-restore-checkpoint +;; for more information. +;; +;; While the cipher message may contain digits or punctuation, Decipher +;; mode will ignore these characters. +;; +;; The buffer is made read-only so it can't be modified by normal +;; Emacs commands. +;; +;; Decipher supports Font Lock mode. To use it, you can also add +;; (add-hook 'decipher-mode-hook 'turn-on-font-lock) +;; See the variable `decipher-font-lock-keywords' if you want to customize +;; the faces used. I'd like to thank Simon Marshall for his help in making +;; Decipher work well with Font Lock. + +;;; Things To Do: +;; +;; Email me if you have any suggestions or would like to help. +;; But be aware that I work on Decipher only sporadically. +;; +;; 1. The consonant-line shortcut +;; 2. More functions for analyzing ciphertext + +;;;=================================================================== +;;; Variables: +;;;=================================================================== + +(eval-when-compile + (require 'cl)) + +(defvar decipher-force-uppercase t + "*Non-nil means to convert ciphertext to uppercase. +Nil means the case of the ciphertext is preserved. +This variable must be set before typing `\\[decipher]'.") + +(defvar decipher-ignore-spaces nil + "*Non-nil means to ignore spaces and punctuation when counting digrams. +You should set this to `nil' if the cipher message is divided into words, +or `t' if it is not. +This variable is buffer-local.") +(make-variable-buffer-local 'decipher-ignore-spaces) + +(defvar decipher-undo-limit 5000 + "The maximum number of entries in the undo list. +When the undo list exceeds this number, 100 entries are deleted from +the tail of the list.") + +;; End of user modifiable variables +;;-------------------------------------------------------------------- + +(defvar decipher-font-lock-keywords + '(("^:.*" . font-lock-keyword-face) + ("^>.*" . font-lock-string-face) + ("^%!.*" . font-lock-reference-face) + ("^%.*" . font-lock-comment-face) + ("\\`(\\([a-z]+\\) +\\([A-Z]+\\)" + (1 font-lock-string-face) + (2 font-lock-keyword-face)) + ("^)\\([A-Z ]+\\)\\([a-z ]+\\)" + (1 font-lock-keyword-face) + (2 font-lock-string-face))) + "Expressions to fontify in Decipher mode. +Ciphertext uses `font-lock-keyword-face', plaintext uses +`font-lock-string-face', comments use `font-lock-comment-face', and +checkpoints use `font-lock-reference-face'. You can customize the +display by changing these variables. For best results, I recommend +that all faces use the same background color. +For example, to display ciphertext in the `bold' face, use + (add-hook 'decipher-mode-hook + (lambda () (set (make-local-variable 'font-lock-keyword-face) + 'bold))) +in your `.emacs' file.") + +(defvar decipher-mode-map nil + "Keymap for Decipher mode.") +(if (not decipher-mode-map) + (progn + (setq decipher-mode-map (make-keymap)) + (suppress-keymap decipher-mode-map) + (define-key decipher-mode-map "A" 'decipher-show-alphabet) + (define-key decipher-mode-map "C" 'decipher-complete-alphabet) + (define-key decipher-mode-map "D" 'decipher-digram-list) + (define-key decipher-mode-map "F" 'decipher-frequency-count) + (define-key decipher-mode-map "M" 'decipher-make-checkpoint) + (define-key decipher-mode-map "N" 'decipher-adjacency-list) + (define-key decipher-mode-map "R" 'decipher-restore-checkpoint) + (define-key decipher-mode-map "U" 'decipher-undo) + (define-key decipher-mode-map " " 'decipher-keypress) + (substitute-key-definition 'undo 'decipher-undo + decipher-mode-map global-map) + (substitute-key-definition 'advertised-undo 'decipher-undo + decipher-mode-map global-map) + (let ((key ?a)) + (while (<= key ?z) + (define-key decipher-mode-map (vector key) 'decipher-keypress) + (incf key))))) + +(defvar decipher-stats-mode-map nil + "Keymap for Decipher-Stats mode.") +(if (not decipher-stats-mode-map) + (progn + (setq decipher-stats-mode-map (make-keymap)) + (suppress-keymap decipher-stats-mode-map) + (define-key decipher-stats-mode-map "D" 'decipher-digram-list) + (define-key decipher-stats-mode-map "F" 'decipher-frequency-count) + (define-key decipher-stats-mode-map "N" 'decipher-adjacency-list) + )) + +(defvar decipher-mode-syntax-table nil + "Decipher mode syntax table") + +(if decipher-mode-syntax-table + () + (let ((table (make-syntax-table)) + (c ?0)) + (while (<= c ?9) + (modify-syntax-entry c "_" table) ;Digits are not part of words + (incf c)) + (setq decipher-mode-syntax-table table))) + +(defvar decipher-alphabet nil) +;; This is an alist containing entries (PLAIN-CHAR . CIPHER-CHAR), +;; where PLAIN-CHAR runs from ?a to ?z and CIPHER-CHAR is an uppercase +;; letter or space (which means no mapping is known for that letter). +;; This *must* contain entries for all lowercase characters. +(make-variable-buffer-local 'decipher-alphabet) + +(defvar decipher-stats-buffer nil + "The buffer which displays statistics for this ciphertext. +Do not access this variable directly, use the function +`decipher-stats-buffer' instead.") +(make-variable-buffer-local 'decipher-stats-buffer) + +(defvar decipher-undo-list-size 0 + "The number of entries in the undo list.") +(make-variable-buffer-local 'decipher-undo-list-size) + +(defvar decipher-undo-list nil + "The undo list for this buffer. +Each element is either a cons cell (PLAIN-CHAR . CIPHER-CHAR) or a +list of such cons cells.") +(make-variable-buffer-local 'decipher-undo-list) + +(defvar decipher-pending-undo-list nil) + +;; The following variables are used by the analysis functions +;; and are defined here to avoid byte-compiler warnings. +;; Don't mess with them unless you know what you're doing. +(defvar decipher-char nil + "See the functions decipher-loop-with-breaks and decipher-loop-no-breaks.") +(defvar decipher--prev-char) +(defvar decipher--digram) +(defvar decipher--digram-list) +(defvar decipher--before) +(defvar decipher--after) +(defvar decipher--freqs) + +;;;=================================================================== +;;; Code: +;;;=================================================================== +;; Main entry points: +;;-------------------------------------------------------------------- + +;;;###autoload +(defun decipher () + "Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." + (interactive) + ;; Make sure the buffer ends in a newline: + (goto-char (point-max)) + (or (bolp) + (insert "\n")) + ;; See if it's already in decipher format: + (goto-char (point-min)) + (if (looking-at "^(abcdefghijklmnopqrstuvwxyz \ +ABCDEFGHIJKLMNOPQRSTUVWXYZ -\\*-decipher-\\*-\n)") + (message "Buffer is already formatted, entering Decipher mode...") + ;; Add the alphabet at the beginning of the file + (insert "(abcdefghijklmnopqrstuvwxyz \ +ABCDEFGHIJKLMNOPQRSTUVWXYZ -*-decipher-*-\n)\n\n") + ;; Add lines for the solution: + (let (begin) + (while (not (eobp)) + (if (looking-at "^%") + (forward-line) ;Leave comments alone + (delete-horizontal-space) + (if (eolp) + (forward-line) ;Just leave blank lines alone + (insert ":") ;Mark ciphertext line + (setq begin (point)) + (forward-line) + (if decipher-force-uppercase + (upcase-region begin (point))) ;Convert ciphertext to uppercase + (insert ">\n"))))) ;Mark plaintext line + (delete-blank-lines) ;Remove any blank lines + (delete-blank-lines)) ; at end of buffer + (goto-line 4) + (decipher-mode)) + +;;;###autoload +(defun decipher-mode () + "Major mode for decrypting monoalphabetic substitution ciphers. +Lower-case letters enter plaintext. +Upper-case letters are commands. + +The buffer is made read-only so that normal Emacs commands cannot +modify it. + +The most useful commands are: +\\ +\\[decipher-digram-list] Display a list of all digrams & their frequency +\\[decipher-frequency-count] Display the frequency of each ciphertext letter +\\[decipher-adjacency-list]\ + Show adjacency list for current letter (lists letters appearing next to it) +\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) +\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" + (interactive) + (kill-all-local-variables) + (setq buffer-undo-list t ;Disable undo + indent-tabs-mode nil ;Do not use tab characters + major-mode 'decipher-mode + mode-name "Decipher") + (if decipher-force-uppercase + (setq case-fold-search nil)) ;Case is significant when searching + (use-local-map decipher-mode-map) + (set-syntax-table decipher-mode-syntax-table) + (decipher-read-alphabet) + (set (make-local-variable 'font-lock-defaults) + '(decipher-font-lock-keywords t)) + ;; Make the buffer writable when we exit Decipher mode: + (make-local-hook 'change-major-mode-hook) + (add-hook 'change-major-mode-hook + (lambda () (setq buffer-read-only nil + buffer-undo-list nil)) + nil t) + (run-hooks 'decipher-mode-hook) + (setq buffer-read-only t)) +(put 'decipher-mode 'mode-class 'special) + +;;-------------------------------------------------------------------- +;; Normal key handling: +;;-------------------------------------------------------------------- + +(defmacro decipher-last-command-char () + ;; Return the char which ran this command (for compatibility with XEmacs) + (if (fboundp 'event-to-character) + '(event-to-character last-command-event) + 'last-command-event)) + +(defun decipher-keypress () + "Enter a plaintext or ciphertext character." + (interactive) + (let ((decipher-function 'decipher-set-map) + buffer-read-only) ;Make buffer writable + (save-excursion + (or (save-excursion + (beginning-of-line) + (let ((first-char (following-char))) + (cond + ((= ?: first-char) + t) + ((= ?> first-char) + nil) + ((= ?\( first-char) + (setq decipher-function 'decipher-alphabet-keypress) + t) + ((= ?\) first-char) + (setq decipher-function 'decipher-alphabet-keypress) + nil) + (t + (error "Bad location"))))) + (let (goal-column) + (previous-line 1))) + (let ((char-a (following-char)) + (char-b (decipher-last-command-char))) + (or (and (not (= ?w (char-syntax char-a))) + (= char-b ?\ )) ;Spacebar just advances on non-letters + (funcall decipher-function char-a char-b))))) + (forward-char)) + +(defun decipher-alphabet-keypress (a b) + ;; Handle keypresses in the alphabet lines. + ;; A is the character in the alphabet row (which starts with '(') + ;; B is the character pressed + (cond ((and (>= a ?A) (<= a ?Z)) + ;; If A is uppercase, then it is in the ciphertext alphabet: + (decipher-set-map a b)) + ((and (>= a ?a) (<= a ?z)) + ;; If A is lowercase, then it is in the plaintext alphabet: + (if (= b ?\ ) + ;; We are clearing the association (if any): + (if (/= ?\ (setq b (cdr (assoc a decipher-alphabet)))) + (decipher-set-map b ?\ )) + ;; Associate the plaintext char with the char pressed: + (decipher-set-map b a))) + (t + ;; If A is not a letter, that's a problem: + (error "Bad character")))) + +;;-------------------------------------------------------------------- +;; Undo: +;;-------------------------------------------------------------------- + +(defun decipher-undo () + "Undo a change in Decipher mode." + (interactive) + ;; If we don't get all the way thru, make last-command indicate that + ;; for the following command. + (setq this-command t) + (or (eq major-mode 'decipher-mode) + (error "This buffer is not in Decipher mode")) + (or (eq last-command 'decipher-undo) + (setq decipher-pending-undo-list decipher-undo-list)) + (or decipher-pending-undo-list + (error "No further undo information")) + (let ((undo-rec (pop decipher-pending-undo-list)) + buffer-read-only ;Make buffer writable + redo-map redo-rec undo-map) + (or (consp (car undo-rec)) + (setq undo-rec (list undo-rec))) + (while (setq undo-map (pop undo-rec)) + (setq redo-map (decipher-get-undo (cdr undo-map) (car undo-map))) + (if redo-map + (setq redo-rec + (if (consp (car redo-map)) + (append redo-map redo-rec) + (cons redo-map redo-rec)))) + (decipher-set-map (cdr undo-map) (car undo-map) t)) + (decipher-add-undo redo-rec)) + (setq this-command 'decipher-undo) + (message "Undo!")) + +(defun decipher-add-undo (undo-rec) + "Add UNDO-REC to the undo list." + (if undo-rec + (progn + (push undo-rec decipher-undo-list) + (incf decipher-undo-list-size) + (if (> decipher-undo-list-size decipher-undo-limit) + (let ((new-size (- decipher-undo-limit 100))) + ;; Truncate undo list to NEW-SIZE elements: + (setcdr (nthcdr (1- new-size) decipher-undo-list) nil) + (setq decipher-undo-list-size new-size)))))) + +(defun decipher-get-undo (cipher-char plain-char) + ;; Return an undo record that will undo the result of + ;; (decipher-set-map CIPHER-CHAR PLAIN-CHAR) + ;; We must use copy-list because the original cons cells will be + ;; modified using setcdr. + (let ((cipher-map (copy-list (rassoc cipher-char decipher-alphabet))) + (plain-map (copy-list (assoc plain-char decipher-alphabet)))) + (cond ((equal ?\ plain-char) + cipher-map) + ((equal cipher-char (cdr plain-map)) + nil) ;We aren't changing anything + ((equal ?\ (cdr plain-map)) + (or cipher-map (cons ?\ cipher-char))) + (cipher-map + (list plain-map cipher-map)) + (t + plain-map)))) + +;;-------------------------------------------------------------------- +;; Mapping ciphertext and plaintext: +;;-------------------------------------------------------------------- + +(defun decipher-set-map (cipher-char plain-char &optional no-undo) + ;; Associate a ciphertext letter with a plaintext letter + ;; CIPHER-CHAR must be an uppercase or lowercase letter + ;; PLAIN-CHAR must be a lowercase letter (or a space) + ;; NO-UNDO if non-nil means do not record undo information + ;; Any existing associations for CIPHER-CHAR or PLAIN-CHAR will be erased. + (setq cipher-char (upcase cipher-char)) + (or (and (>= cipher-char ?A) (<= cipher-char ?Z)) + (error "Bad character")) ;Cipher char must be uppercase letter + (or no-undo + (decipher-add-undo (decipher-get-undo cipher-char plain-char))) + (let ((cipher-string (char-to-string cipher-char)) + (plain-string (char-to-string plain-char)) + case-fold-search ;Case is significant + mapping bound) + (save-excursion + (goto-char (point-min)) + (if (setq mapping (rassoc cipher-char decipher-alphabet)) + (progn + (setcdr mapping ?\ ) + (search-forward-regexp (concat "^([a-z]*" + (char-to-string (car mapping)))) + (decipher-insert ?\ ) + (beginning-of-line))) + (if (setq mapping (assoc plain-char decipher-alphabet)) + (progn + (if (/= ?\ (cdr mapping)) + (decipher-set-map (cdr mapping) ?\ t)) + (setcdr mapping cipher-char) + (search-forward-regexp (concat "^([a-z]*" plain-string)) + (decipher-insert cipher-char) + (beginning-of-line))) + (search-forward-regexp (concat "^([a-z]+ [A-Z]*" cipher-string)) + (decipher-insert plain-char) + (setq case-fold-search t ;Case is not significant + cipher-string (downcase cipher-string)) + (let ((font-lock-fontify-region-function 'ignore)) + ;; insert-and-inherit will pick the right face automatically + (while (search-forward-regexp "^:" nil t) + (setq bound (save-excursion (end-of-line) (point))) + (while (search-forward cipher-string bound 'end) + (decipher-insert plain-char))))))) + +(defun decipher-insert (char) + ;; Insert CHAR in the row below point. It replaces any existing + ;; character in that position. + (let ((col (1- (current-column)))) + (save-excursion + (forward-line) + (or (= ?\> (following-char)) + (= ?\) (following-char)) + (error "Bad location")) + (move-to-column col t) + (or (eolp) + (delete-char 1)) + (insert-and-inherit char)))) + +;;-------------------------------------------------------------------- +;; Checkpoints: +;;-------------------------------------------------------------------- +;; A checkpoint is a comment of the form: +;; %!ABCDEFGHIJKLMNOPQRSTUVWXYZ! Description +;; Such comments are usually placed at the end of the buffer following +;; this header (which is inserted by decipher-make-checkpoint): +;; %--------------------------- +;; % Checkpoints: +;; % abcdefghijklmnopqrstuvwxyz +;; but this is not required; checkpoints can be placed anywhere. +;; +;; The description is optional; all that is required is the alphabet. + +(defun decipher-make-checkpoint (desc) + "Checkpoint the current cipher alphabet. +This records the current alphabet so you can return to it later. +You may have any number of checkpoints. +Type `\\[decipher-restore-checkpoint]' to restore a checkpoint." + (interactive "sCheckpoint description: ") + (or (stringp desc) + (setq desc "")) + (let (alphabet + buffer-read-only ;Make buffer writable + mapping) + (goto-char (point-min)) + (re-search-forward "^)") + (move-to-column 27 t) + (setq alphabet (buffer-substring-no-properties (- (point) 26) (point))) + (if (re-search-forward "^%![A-Z ]+!" nil 'end) + nil ; Add new checkpoint with others + (if (re-search-backward "^% *Local Variables:" nil t) + ;; Add checkpoints before local variables list: + (progn (forward-line -1) + (or (looking-at "^ *$") + (progn (forward-line) (insert ?\n) (forward-line -1))))) + (insert "\n%" (make-string 69 ?\-) + "\n% Checkpoints:\n% abcdefghijklmnopqrstuvwxyz\n")) + (beginning-of-line) + (insert "%!" alphabet "! " desc ?\n))) + +(defun decipher-restore-checkpoint () + "Restore the cipher alphabet from a checkpoint. +If point is not on a checkpoint line, moves to the first checkpoint line. +If point is on a checkpoint, restores that checkpoint. + +Type `\\[decipher-make-checkpoint]' to make a checkpoint." + (interactive) + (beginning-of-line) + (if (looking-at "%!\\([A-Z ]+\\)!") + ;; Restore this checkpoint: + (let ((alphabet (match-string 1)) + buffer-read-only) ;Make buffer writable + (goto-char (point-min)) + (re-search-forward "^)") + (or (eolp) + (delete-region (point) (progn (end-of-line) (point)))) + (insert alphabet) + (decipher-resync)) + ;; Move to the first checkpoint: + (goto-char (point-min)) + (if (re-search-forward "^%![A-Z ]+!" nil t) + (message "Select the checkpoint to restore and type `%s'" + (substitute-command-keys "\\[decipher-restore-checkpoint]")) + (error "No checkpoints in this buffer")))) + +;;-------------------------------------------------------------------- +;; Miscellaneous commands: +;;-------------------------------------------------------------------- + +(defun decipher-complete-alphabet () + "Complete the cipher alphabet. +This fills any blanks in the cipher alphabet with the unused letters +in alphabetical order. Use this when you have a keyword cipher and +you have determined the keyword." + (interactive) + (let ((cipher-char ?A) + (ptr decipher-alphabet) + buffer-read-only ;Make buffer writable + plain-map undo-rec) + (while (setq plain-map (pop ptr)) + (if (equal ?\ (cdr plain-map)) + (progn + (while (rassoc cipher-char decipher-alphabet) + ;; Find the next unused letter + (incf cipher-char)) + (push (cons ?\ cipher-char) undo-rec) + (decipher-set-map cipher-char (car plain-map) t)))) + (decipher-add-undo undo-rec))) + +(defun decipher-show-alphabet () + "Display the current cipher alphabet in the message line." + (interactive) + (message + (mapconcat (lambda (a) + (concat + (char-to-string (car a)) + (char-to-string (cdr a)))) + decipher-alphabet + ""))) + +(defun decipher-resync () + "Reprocess the buffer using the alphabet from the top. +This regenerates all deciphered plaintext and clears the undo list. +You should use this if you edit the ciphertext." + (interactive) + (message "Reprocessing buffer...") + (let (alphabet + buffer-read-only ;Make buffer writable + mapping) + (save-excursion + (decipher-read-alphabet) + (setq alphabet decipher-alphabet) + (goto-char (point-min)) + (and (re-search-forward "^).+" nil t) + (replace-match ")" nil nil)) + (while (re-search-forward "^>.+" nil t) + (replace-match ">" nil nil)) + (decipher-read-alphabet) + (while (setq mapping (pop alphabet)) + (or (equal ?\ (cdr mapping)) + (decipher-set-map (cdr mapping) (car mapping)))))) + (setq decipher-undo-list nil + decipher-undo-list-size 0) + (message "Reprocessing buffer...done")) + +;;-------------------------------------------------------------------- +;; Miscellaneous functions: +;;-------------------------------------------------------------------- + +(defun decipher-read-alphabet () + "Build the decipher-alphabet from the alphabet line in the buffer." + (save-excursion + (goto-char (point-min)) + (search-forward-regexp "^)") + (move-to-column 27 t) + (setq decipher-alphabet nil) + (let ((plain-char ?z)) + (while (>= plain-char ?a) + (backward-char) + (push (cons plain-char (following-char)) decipher-alphabet) + (decf plain-char))))) + +;;;=================================================================== +;;; Analyzing ciphertext: +;;;=================================================================== + +(defun decipher-frequency-count () + "Display the frequency count in the statistics buffer." + (interactive) + (decipher-analyze) + (decipher-display-regexp "^A" "^[A-Z][A-Z]")) + +(defun decipher-digram-list () + "Display the list of digrams in the statistics buffer." + (interactive) + (decipher-analyze) + (decipher-display-regexp "[A-Z][A-Z] +[0-9]" "^$")) + +(defun decipher-adjacency-list (cipher-char) + "Display the adjacency list for the letter at point. +The adjacency list shows all letters which come next to CIPHER-CHAR. + +An adjacency list (for the letter X) looks like this: + 1 1 1 1 1 3 2 1 3 8 +X: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z * 11 14 9% + 1 1 1 2 1 1 2 5 7 +This says that X comes before D once, and after B once. X begins 5 +words, and ends 3 words (`*' represents a space). X comes before 8 +different letters, after 7 differerent letters, and is next to a total +of 11 different letters. It occurs 14 times, making up 9% of the +ciphertext." + (interactive (list (upcase (following-char)))) + (decipher-analyze) + (let (start end) + (save-excursion + (set-buffer (decipher-stats-buffer)) + (goto-char (point-min)) + (or (re-search-forward (format "^%c: " cipher-char) nil t) + (error "Character `%c' is not used in ciphertext." cipher-char)) + (forward-line -1) + (setq start (point)) + (forward-line 3) + (setq end (point))) + (decipher-display-range start end))) + +;;-------------------------------------------------------------------- +(defun decipher-analyze () + "Perform frequency analysis on the current buffer if necessary." + (cond + ;; If this is the statistics buffer, do nothing: + ((eq major-mode 'decipher-stats-mode)) + ;; If this is the Decipher buffer, see if the stats buffer exists: + ((eq major-mode 'decipher-mode) + (or (and (bufferp decipher-stats-buffer) + (buffer-name decipher-stats-buffer)) + (decipher-analyze-buffer))) + ;; Otherwise: + (t (error "This buffer is not in Decipher mode")))) + +;;-------------------------------------------------------------------- +(defun decipher-display-range (start end) + "Display text between START and END in the statistics buffer. +START and END are positions in the statistics buffer. Makes the +statistics buffer visible and sizes the window to just fit the +displayed text, but leaves the current window selected." + (let ((stats-buffer (decipher-stats-buffer)) + (current-window (selected-window)) + (pop-up-windows t)) + (or (eq (current-buffer) stats-buffer) + (pop-to-buffer stats-buffer)) + (goto-char start) + (or (one-window-p t) + (enlarge-window (- (1+ (count-lines start end)) (window-height)))) + (recenter 0) + (select-window current-window))) + +(defun decipher-display-regexp (start-regexp end-regexp) + "Display text between two regexps in the statistics buffer. + +START-REGEXP matches the first line to display. +END-REGEXP matches the line after that which ends the display. +The ending line is included in the display unless it is blank." + (let (start end) + (save-excursion + (set-buffer (decipher-stats-buffer)) + (goto-char (point-min)) + (re-search-forward start-regexp) + (beginning-of-line) + (setq start (point)) + (re-search-forward end-regexp) + (beginning-of-line) + (or (looking-at "^ *$") + (forward-line 1)) + (setq end (point))) + (decipher-display-range start end))) + +;;-------------------------------------------------------------------- +(defun decipher-loop-with-breaks (func) + "Loop through ciphertext, calling FUNC once for each letter & word division. + +FUNC is called with no arguments, and its return value is unimportant. +It may examine `decipher-char' to see the current ciphertext +character. `decipher-char' contains either an uppercase letter or a space. + +FUNC is called exactly once between words, with `decipher-char' set to +a space. + +See `decipher-loop-no-breaks' if you do not care about word divisions." + (let ((decipher-char ?\ ) + (decipher--loop-prev-char ?\ )) + (save-excursion + (goto-char (point-min)) + (funcall func) ;Space marks beginning of first word + (while (search-forward-regexp "^:" nil t) + (while (not (eolp)) + (setq decipher-char (upcase (following-char))) + (or (and (>= decipher-char ?A) (<= decipher-char ?Z)) + (setq decipher-char ?\ )) + (or (and (equal decipher-char ?\ ) + (equal decipher--loop-prev-char ?\ )) + (funcall func)) + (setq decipher--loop-prev-char decipher-char) + (forward-char)) + (or (equal decipher-char ?\ ) + (progn + (setq decipher-char ?\ ; + decipher--loop-prev-char ?\ ) + (funcall func))))))) + +(defun decipher-loop-no-breaks (func) + "Loop through ciphertext, calling FUNC once for each letter. + +FUNC is called with no arguments, and its return value is unimportant. +It may examine `decipher-char' to see the current ciphertext letter. +`decipher-char' contains an uppercase letter. + +Punctuation and spacing in the ciphertext are ignored. +See `decipher-loop-with-breaks' if you care about word divisions." + (let (decipher-char) + (save-excursion + (goto-char (point-min)) + (while (search-forward-regexp "^:" nil t) + (while (not (eolp)) + (setq decipher-char (upcase (following-char))) + (and (>= decipher-char ?A) + (<= decipher-char ?Z) + (funcall func)) + (forward-char)))))) + +;;-------------------------------------------------------------------- +;; Perform the analysis: +;;-------------------------------------------------------------------- + +(defun decipher-insert-frequency-counts (freq-list total) + "Insert frequency counts in current buffer. +Each element of FREQ-LIST is a list (LETTER FREQ ...). +TOTAL is the total number of letters in the ciphertext." + (let ((i 4) temp-list) + (while (> i 0) + (setq temp-list freq-list) + (while temp-list + (insert (caar temp-list) + (format "%4d%3d%% " + (cadar temp-list) + (/ (* 100 (cadar temp-list)) total))) + (setq temp-list (nthcdr 4 temp-list))) + (insert ?\n) + (setq freq-list (cdr freq-list) + i (1- i))))) + +(defun decipher--analyze () + ;; Perform frequency analysis on ciphertext. + ;; + ;; This function is called repeatedly with decipher-char set to each + ;; character of ciphertext. It uses decipher--prev-char to remember + ;; the previous ciphertext character. + ;; + ;; It builds several data structures, which must be initialized + ;; before the first call to decipher--analyze. The arrays are + ;; indexed with A = 0, B = 1, ..., Z = 25, SPC = 26 (if used). + ;; decipher--after: (initialize to zeros) + ;; A vector of 26 vectors of 27 integers. The first vector + ;; represents the number of times A follows each character, the + ;; second vector represents B, and so on. + ;; decipher--before: (initialize to zeros) + ;; The same as decipher--after, but representing the number of + ;; times the character precedes each other character. + ;; decipher--digram-list: (initialize to nil) + ;; An alist with an entry for each digram (2-character sequence) + ;; encountered. Each element is a cons cell (DIGRAM . FREQ), + ;; where DIGRAM is a 2 character string and FREQ is the number + ;; of times it occurs. + ;; decipher--freqs: (initialize to zeros) + ;; A vector of 26 integers, counting the number of occurrences + ;; of the corresponding characters. + (setq decipher--digram (format "%c%c" decipher--prev-char decipher-char)) + (incf (cdr (or (assoc decipher--digram decipher--digram-list) + (car (push (cons decipher--digram 0) + decipher--digram-list))))) + (and (>= decipher--prev-char ?A) + (incf (aref (aref decipher--before (- decipher--prev-char ?A)) + (if (equal decipher-char ?\ ) + 26 + (- decipher-char ?A))))) + (and (>= decipher-char ?A) + (incf (aref decipher--freqs (- decipher-char ?A))) + (incf (aref (aref decipher--after (- decipher-char ?A)) + (if (equal decipher--prev-char ?\ ) + 26 + (- decipher--prev-char ?A))))) + (setq decipher--prev-char decipher-char)) + +(defun decipher--digram-counts (counts) + "Generate the counts for an adjacency list." + (let ((total 0)) + (concat + (mapconcat (lambda (x) + (cond ((> x 99) (incf total) "XX") + ((> x 0) (incf total) (format "%2d" x)) + (t " "))) + counts + "") + (format "%4d" (if (> (aref counts 26) 0) + (1- total) ;Don't count space + total))))) + +(defun decipher--digram-total (before-count after-count) + "Count the number of different letters a letter appears next to." + ;; We do not include spaces (word divisions) in this count. + (let ((total 0) + (i 26)) + (while (>= (decf i) 0) + (if (or (> (aref before-count i) 0) + (> (aref after-count i) 0)) + (incf total))) + total)) + +(defun decipher-analyze-buffer () + "Perform frequency analysis and store results in statistics buffer. +Creates the statistics buffer if it doesn't exist." + (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\*)) + (decipher--before (make-vector 26 nil)) + (decipher--after (make-vector 26 nil)) + (decipher--freqs (make-vector 26 0)) + (total-chars 0) + decipher--digram decipher--digram-list freq-list) + (message "Scanning buffer...") + (let ((i 26)) + (while (>= (decf i) 0) + (aset decipher--before i (make-vector 27 0)) + (aset decipher--after i (make-vector 27 0)))) + (if decipher-ignore-spaces + (progn + (decipher-loop-no-breaks 'decipher--analyze) + ;; The first character of ciphertext was marked as following a space: + (let ((i 26)) + (while (>= (decf i) 0) + (aset (aref decipher--after i) 26 0)))) + (decipher-loop-with-breaks 'decipher--analyze)) + (message "Processing results...") + (setcdr (last decipher--digram-list 2) nil) ;Delete the phony "* " digram + ;; Sort the digram list by frequency and alphabetical order: + (setq decipher--digram-list (sort (sort decipher--digram-list + (lambda (a b) (string< (car a) (car b)))) + (lambda (a b) (> (cdr a) (cdr b))))) + ;; Generate the frequency list: + ;; Each element is a list of 3 elements (LETTER FREQ DIFFERENT), + ;; where LETTER is the ciphertext character, FREQ is the number + ;; of times it occurs, and DIFFERENT is the number of different + ;; letters it appears next to. + (let ((i 26)) + (while (>= (decf i) 0) + (setq freq-list + (cons (list (+ i ?A) + (aref decipher--freqs i) + (decipher--digram-total (aref decipher--before i) + (aref decipher--after i))) + freq-list) + total-chars (+ total-chars (aref decipher--freqs i))))) + (save-excursion + ;; Switch to statistics buffer, creating it if necessary: + (set-buffer (decipher-stats-buffer t)) + ;; This can't happen, but it never hurts to double-check: + (or (eq major-mode 'decipher-stats-mode) + (error "Buffer %s is not in Decipher-Stats mode" (buffer-name))) + (setq buffer-read-only nil) + (erase-buffer) + ;; Display frequency counts for letters A-Z: + (decipher-insert-frequency-counts freq-list total-chars) + (insert ?\n) + ;; Display frequency counts for letters in order of frequency: + (setq freq-list (sort freq-list + (lambda (a b) (> (second a) (second b))))) + (decipher-insert-frequency-counts freq-list total-chars) + ;; Display letters in order of frequency: + (insert ?\n (mapconcat (lambda (a) (char-to-string (car a))) + freq-list nil) + "\n\n") + ;; Display list of digrams in order of frequency: + (let* ((rows (floor (+ (length decipher--digram-list) 9) 10)) + (i rows) + temp-list) + (while (> i 0) + (setq temp-list decipher--digram-list) + (while temp-list + (insert (caar temp-list) + (format "%3d " + (cdar temp-list))) + (setq temp-list (nthcdr rows temp-list))) + (delete-horizontal-space) + (insert ?\n) + (setq decipher--digram-list (cdr decipher--digram-list) + i (1- i)))) + ;; Display adjacency list for each letter, sorted in descending + ;; order of the number of adjacent letters: + (setq freq-list (sort freq-list + (lambda (a b) (> (third a) (third b))))) + (let ((temp-list freq-list) + entry i) + (while (setq entry (pop temp-list)) + (if (equal 0 (second entry)) + nil ;This letter was not used + (setq i (- (car entry) ?A)) + (insert ?\n " " + (decipher--digram-counts (aref decipher--before i)) ?\n + (car entry) + ": A B C D E F G H I J K L M N O P Q R S T U V W X Y Z *" + (format "%4d %4d %3d%%\n " + (third entry) (second entry) + (/ (* 100 (second entry)) total-chars)) + (decipher--digram-counts (aref decipher--after i)) ?\n)))) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + )) + (message nil)) + +;;==================================================================== +;; Statistics Buffer: +;;==================================================================== + +(defun decipher-stats-mode () + "Major mode for displaying ciphertext statistics." + (interactive) + (kill-all-local-variables) + (setq buffer-read-only t + buffer-undo-list t ;Disable undo + case-fold-search nil ;Case is significant when searching + indent-tabs-mode nil ;Do not use tab characters + major-mode 'decipher-stats-mode + mode-name "Decipher-Stats") + (use-local-map decipher-stats-mode-map) + (run-hooks 'decipher-stats-mode-hook)) +(put 'decipher-stats-mode 'mode-class 'special) + +;;-------------------------------------------------------------------- + +(defun decipher-display-stats-buffer () + "Make the statistics buffer visible, but do not select it." + (let ((stats-buffer (decipher-stats-buffer)) + (current-window (selected-window))) + (or (eq (current-buffer) stats-buffer) + (progn + (pop-to-buffer stats-buffer) + (select-window current-window))))) + +(defun decipher-stats-buffer (&optional create) + "Return the buffer used for decipher statistics. +If CREATE is non-nil, create the buffer if it doesn't exist. +This is guaranteed to return a buffer in Decipher-Stats mode; +if it can't, it signals an error." + (cond + ;; We may already be in the statistics buffer: + ((eq major-mode 'decipher-stats-mode) + (current-buffer)) + ;; See if decipher-stats-buffer exists: + ((and (bufferp decipher-stats-buffer) + (buffer-name decipher-stats-buffer)) + (or (save-excursion + (set-buffer decipher-stats-buffer) + (eq major-mode 'decipher-stats-mode)) + (error "Buffer %s is not in Decipher-Stats mode" + (buffer-name decipher-stats-buffer))) + decipher-stats-buffer) + ;; Create a new buffer if requested: + (create + (let ((stats-name (concat "*" (buffer-name) "*"))) + (setq decipher-stats-buffer + (if (eq 'decipher-stats-mode + (cdr-safe (assoc 'major-mode + (buffer-local-variables + (get-buffer stats-name))))) + ;; We just lost track of the statistics buffer: + (get-buffer stats-name) + (generate-new-buffer stats-name)))) + (save-excursion + (set-buffer decipher-stats-buffer) + (decipher-stats-mode)) + decipher-stats-buffer) + ;; Give up: + (t (error "No statistics buffer")))) + +;;==================================================================== + +(provide 'decipher) + +;;;(defun decipher-show-undo-list () +;;; "Display the undo list (for debugging purposes)." +;;; (interactive) +;;; (with-output-to-temp-buffer "*Decipher Undo*" +;;; (let ((undo-list decipher-undo-list) +;;; undo-rec undo-map) +;;; (save-excursion +;;; (set-buffer "*Decipher Undo*") +;;; (while (setq undo-rec (pop undo-list)) +;;; (or (consp (car undo-rec)) +;;; (setq undo-rec (list undo-rec))) +;;; (insert ?\() +;;; (while (setq undo-map (pop undo-rec)) +;;; (insert (cdr undo-map) (car undo-map) ?\ )) +;;; (delete-backward-char 1) +;;; (insert ")\n")))))) + +;;; decipher.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/modes/make-mode.el --- a/lisp/modes/make-mode.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/modes/make-mode.el Mon Aug 13 08:48:42 2007 +0200 @@ -161,6 +161,12 @@ IMPORTANT: Please note that enabling this option causes makefile-mode to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \'it seems necessary\'.") +;;; those suspicious line warnings are really annoying and +;;; seem to be generated for every makefile I've ever seen. +;;; add a simple mechanism to disable them. -gk +(defvar makefile-warn-suspicious-lines-p t + "In non-nil, warn about suspicious lines when saving the makefile") + (defvar makefile-browser-hook '()) ;; @@ -619,7 +625,13 @@ (makefile-pickup-macros) (if (bolp) (call-interactively 'makefile-insert-macro) - (self-insert-command arg))) + (self-insert-command arg) + ;; from here down is new -- if they inserted a macro without using + ;; the electric behavior, pick it up anyway -gk + (save-excursion + (beginning-of-line) + (if (looking-at makefile-macroassign-regex) + (makefile-add-this-line-macro))))) (defun makefile-insert-macro (macro-name) "Prepare definition of a new macro." @@ -719,7 +731,9 @@ (if (not makefile-need-macro-pickup) nil (setq makefile-need-macro-pickup nil) - (setq makefile-macro-table nil) + ;; changed the nil in the next line to makefile-runtime-macros-list + ;; so you don't have to confirm on every runtime macro entered... -gk + (setq makefile-macro-table makefile-runtime-macros-list) (save-excursion (goto-char (point-min)) (while (re-search-forward makefile-macroassign-regex (point-max) t) @@ -1220,7 +1234,8 @@ (defun makefile-warn-suspicious-lines () (let ((dont-save nil)) - (if (eq major-mode 'makefile-mode) + (if (and (eq major-mode 'makefile-mode) + makefile-warn-suspicious-lines-p) ; -gk (let ((suspicious (save-excursion (goto-char (point-min)) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/mu/latex-math-symbol.el --- a/lisp/mu/latex-math-symbol.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -;;; latex-math-symbol.el --- LaTeX math symbol decoder - -;; Copyright (C) 1996 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Created: 1996/7/1 -;; Version: -;; $Id: latex-math-symbol.el,v 1.2 1996/12/29 00:14:59 steve Exp $ -;; Keywords: LaTeX, math, mule - -;; This file is part of MU (Message Utilities). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with 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 -;; bytecompile this file and copy it to the apropriate directory. -;; - How to use -;; If you use tm, please put following to your ~/.emacs: -;; (autoload 'latex-math-decode-buffer "latex-math-symbol" nil t) -;; (add-hook 'mime-viewer/plain-text-preview-hook -;; 'latex-math-decode-buffer) -;; Of course, it may be available for other hooks to filter messages. - -;;; Code: - -(defvar latex-math-symbol-table-alist - '(("\\pi" . "$B&P(B") - - ("\\{" . "$B!P(B")("\\}" . "$B!Q(B") - - ("\\cdot" . "$B!&(B") - ("\\times" . "$B!_(B") - ("\\cap" . "$B"A(B")("\\cup" . "$B"@(B") - - ("\\leq" . "$(C!B(B")("\\geq" . "$(C!C(B") - ("\\le" . "$(C!B(B")("\\ge" . "$(C!C(B") - ("\\subseteq" . "$B"<(B")("\\supseteq" . "$B"=(B") - ("\\subset" . "$B">(B")("\\supset" . "$B"?(B") - ("\\in" . "$B":(B")("\\ni" . "$B";(B") - ("\\mid" . "$B!C(B") - ("\\neq" . "$B!b(B")("\\ne" . "$B!b(B") - - ("\\forall" . "$B"O(B") - - ("\\leftarrow" . "$B"+(B")("\\rightarrow" . "$B"*(B") - ("\\gets" . "$B"+(B")("\\to" . "$B"*(B") - - ("^1" . ",A9(B") - ("^2" . ",A2(B") - ("^3" . ",A3(B") - )) - -(defun latex-math-decode-region (beg end) - (interactive "r") - (save-restriction - (narrow-to-region beg end) - (let ((rest latex-math-symbol-table-alist) - cell) - (while rest - (setq cell (car rest)) - (goto-char beg) - (while (search-forward (car cell) nil t) - (replace-match (cdr cell)) - ) - (setq rest (cdr rest)) - )))) - -(defun latex-math-decode-buffer () - (interactive) - (latex-math-decode-region (point-min)(point-max)) - ) - - -;;; @ end -;;; - -(provide 'latex-math-symbol) - -;;; latex-math-symbol.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/packages/avoid.el --- a/lisp/packages/avoid.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/packages/avoid.el Mon Aug 13 08:48:42 2007 +0200 @@ -72,6 +72,7 @@ (provide 'avoid) +;;;###autoload (defvar mouse-avoidance-mode nil "Value is t or a symbol if the mouse pointer should avoid the cursor. See function `mouse-avoidance-mode' for possible values. Changing this @@ -366,4 +367,4 @@ ;;;###autoload (add-minor-mode 'mouse-avoidance-mode " Avoid") -;;; End of avoid.el +;;; avoid.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 08:48:42 2007 +0200 @@ -1246,7 +1246,7 @@ (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 +The file is the the optional FILE argument or the file visited by the current buffer." t nil) (autoload 'run-ediff-from-cvs-buffer "ediff" "\ @@ -1683,6 +1683,29 @@ ;;;*** +;;;### (autoloads (decipher-mode decipher) "decipher" "games/decipher.el") + +(autoload 'decipher "decipher" "\ +Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." t nil) + +(autoload 'decipher-mode "decipher" "\ +Major mode for decrypting monoalphabetic substitution ciphers. +Lower-case letters enter plaintext. +Upper-case letters are commands. + +The buffer is made read-only so that normal Emacs commands cannot +modify it. + +The most useful commands are: +\\ +\\[decipher-digram-list] Display a list of all digrams & their frequency +\\[decipher-frequency-count] Display the frequency of each ciphertext letter +\\[decipher-adjacency-list] Show adjacency list for current letter (lists letters appearing next to it) +\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) +\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" t nil) + +;;;*** + ;;;### (autoloads (dissociated-press) "dissociate" "games/dissociate.el") (autoload 'dissociated-press "dissociate" "\ @@ -3540,7 +3563,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.2 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.3 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -4757,7 +4780,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.2 $ +vhdl-mode $Revision: 1.3 $ To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a vhdl-mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the @@ -5137,6 +5160,12 @@ ;;;### (autoloads (mouse-avoidance-mode) "avoid" "packages/avoid.el") +(defvar mouse-avoidance-mode nil "\ +Value is t or a symbol if the mouse pointer should avoid the cursor. +See function `mouse-avoidance-mode' for possible values. Changing this +variable is NOT the recommended way to change modes; use that function +instead.") + (autoload 'mouse-avoidance-mode "avoid" "\ Set cursor avoidance mode to MODE. MODE should be one of the symbols `banish', `exile', `jump', `animate', @@ -8214,59 +8243,6 @@ ;;;*** -;;;### (autoloads (url-retrieve url-cache-expired url-popup-info url-get-url-at-point url-buffer-visiting url-normalize-url url-file-attributes) "url" "url/url.el") - -(autoload 'url-file-attributes "url" "\ -Return a list of attributes of URL. -Value is nil if specified file cannot be opened. -Otherwise, list elements are: - 0. t for directory, string (name linked to) for symbolic link, or nil. - 1. Number of links to file. - 2. File uid. - 3. File gid. - 4. Last access time, as a list of two integers. - First integer has high-order 16 bits of time, second has low 16 bits. - 5. Last modification time, likewise. - 6. Last status change time, likewise. - 7. Size in bytes. (-1, if number is out of range). - 8. File modes, as a string of ten letters or dashes as in ls -l. - If URL is on an http server, this will return the content-type if possible. - 9. t iff file's gid would change if file were deleted and recreated. -10. inode number. -11. Device number. - -If file does not exist, returns nil." nil nil) - -(autoload 'url-normalize-url "url" "\ -Return a 'normalized' version of URL. This strips out default port -numbers, etc." nil nil) - -(autoload 'url-buffer-visiting "url" "\ -Return the name of a buffer (if any) that is visiting URL." nil nil) - -(autoload 'url-get-url-at-point "url" "\ -Get the URL closest to point, but don't change your -position. Has a preference for looking backward when not -directly on a symbol." nil nil) - -(autoload 'url-popup-info "url" "\ -Retrieve the HTTP/1.0 headers and display them in a temp buffer." nil nil) - -(autoload 'url-cache-expired "url" "\ -Return t iff a cached file has expired." nil nil) - -(autoload 'url-retrieve "url" "\ -Retrieve a document over the World Wide Web. -The document should be specified by its fully specified -Uniform Resource Locator. No parsing is done, just return the -document as the server sent it. The document is left in the -buffer specified by url-working-buffer. url-working-buffer is killed -immediately before starting the transfer, so that no buffer-local -variables interfere with the retrieval. HTTP/1.0 redirection will -be honored before this function exits." nil nil) - -;;;*** - ;;;### (autoloads (defadvice ad-add-advice) "advice" "utils/advice.el") (defvar ad-redefinition-action 'warn "\ @@ -9262,6 +9238,59 @@ ;;;*** +;;;### (autoloads (url-retrieve url-cache-expired url-popup-info url-get-url-at-point url-buffer-visiting url-normalize-url url-file-attributes) "url" "w3/url.el") + +(autoload 'url-file-attributes "url" "\ +Return a list of attributes of URL. +Value is nil if specified file cannot be opened. +Otherwise, list elements are: + 0. t for directory, string (name linked to) for symbolic link, or nil. + 1. Number of links to file. + 2. File uid. + 3. File gid. + 4. Last access time, as a list of two integers. + First integer has high-order 16 bits of time, second has low 16 bits. + 5. Last modification time, likewise. + 6. Last status change time, likewise. + 7. Size in bytes. (-1, if number is out of range). + 8. File modes, as a string of ten letters or dashes as in ls -l. + If URL is on an http server, this will return the content-type if possible. + 9. t iff file's gid would change if file were deleted and recreated. +10. inode number. +11. Device number. + +If file does not exist, returns nil." nil nil) + +(autoload 'url-normalize-url "url" "\ +Return a 'normalized' version of URL. This strips out default port +numbers, etc." nil nil) + +(autoload 'url-buffer-visiting "url" "\ +Return the name of a buffer (if any) that is visiting URL." nil nil) + +(autoload 'url-get-url-at-point "url" "\ +Get the URL closest to point, but don't change your +position. Has a preference for looking backward when not +directly on a symbol." nil nil) + +(autoload 'url-popup-info "url" "\ +Retrieve the HTTP/1.0 headers and display them in a temp buffer." nil nil) + +(autoload 'url-cache-expired "url" "\ +Return t iff a cached file has expired." nil nil) + +(autoload 'url-retrieve "url" "\ +Retrieve a document over the World Wide Web. +The document should be specified by its fully specified +Uniform Resource Locator. No parsing is done, just return the +document as the server sent it. The document is left in the +buffer specified by url-working-buffer. url-working-buffer is killed +immediately before starting the transfer, so that no buffer-local +variables interfere with the retrieval. HTTP/1.0 redirection will +be honored before this function exits." nil nil) + +;;;*** + ;;;### (autoloads (w3-use-hotlist) "w3-hot" "w3/w3-hot.el") (autoload 'w3-use-hotlist "w3-hot" "\ @@ -9362,6 +9391,36 @@ ;;;*** +;;;### (autoloads (widget-delete widget-create) "widget-edit" "w3/widget-edit.el") + +(autoload 'widget-create "widget-edit" "\ +Create widget of TYPE. +The optional ARGS are additional keyword arguments." nil nil) + +(autoload 'widget-delete "widget-edit" "\ +Delete WIDGET." nil nil) + +;;;*** + +;;;### (autoloads (define-widget) "widget" "w3/widget.el") + +(autoload 'define-widget "widget" "\ +Define a new widget type named NAME from CLASS. + +NAME and CLASS should both be symbols, CLASS should be one of the +existing widget types, or nil to create the widget from scratch. + +After the new widget has been defined, the following two calls will +create identical widgets: + +* (widget-create NAME) + +* (apply 'widget-create CLASS ARGS) + +The third argument DOC is a documentation string for the widget." nil nil) + +;;;*** + ;;;### (autoloads (font-menu-weight-constructor font-menu-size-constructor font-menu-family-constructor reset-device-font-menus) "x-font-menu" "x11/x-font-menu.el") (defvar font-menu-ignore-scaled-fonts t "\ diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/prim/help.el --- a/lisp/prim/help.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/prim/help.el Mon Aug 13 08:48:42 2007 +0200 @@ -180,11 +180,12 @@ (define-key help-mode-map "q" 'help-mode-quit) (defun help-mode-quit () - "Exits from help mode, possiblely restoring the previous window configuration." + "Exits from help mode, possibly restoring the previous window configuration." (interactive) (cond ((local-variable-p 'help-window-config (current-buffer)) (let ((config help-window-config)) (kill-local-variable 'help-window-config) + (bury-buffer) (set-window-configuration config))) ((one-window-p) (bury-buffer)) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/prim/simple.el --- a/lisp/prim/simple.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 08:48:42 2007 +0200 @@ -1084,7 +1084,7 @@ ;; (message "Read only text copied to kill ring") (setq this-command 'kill-region) (barf-if-buffer-read-only) - (signal 'text-read-only (list (current-buffer)))) + (signal 'buffer-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. diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/psgml/psgml-parse.el --- a/lisp/psgml/psgml-parse.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/psgml/psgml-parse.el Mon Aug 13 08:48:42 2007 +0200 @@ -1,5 +1,5 @@ ;;;; psgml-parse.el --- Parser for SGML-editing mode with parsing support -;; $Id: psgml-parse.el,v 1.2 1997/01/04 21:20:07 steve Exp $ +;; $Id: psgml-parse.el,v 1.3 1997/01/11 22:10:17 steve Exp $ ;; Copyright (C) 1994, 1995 Lennart Staflin @@ -1206,7 +1206,7 @@ (sgml-pop-entity) (erase-buffer) ;; For XEmacs-20.0/Mule - (setq file-coding-system 'noconv) + (setq file-coding-system 'no-conversion) (sgml-write-dtd sgml-dtd-info to-file) t)) @@ -1234,7 +1234,7 @@ "Merge the binary coded dtd in the current buffer with the current dtd. The current dtd is the variable sgml-dtd-info. Return t if mereged was successfull or nil if failed." - (setq file-coding-system 'noconv) + (setq file-coding-system 'no-conversion) (goto-char (point-min)) (sgml-read-sexp) ; skip filev (let ((dependencies (sgml-read-sexp)) @@ -2368,7 +2368,7 @@ ;; (reported by Jeffrey Friedl ) (setq mc-flag nil) ;; For XEmacs 20.0/Mule - (setq file-coding-system 'noconv) + (setq file-coding-system 'no-conversion) (when (eq sgml-scratch-buffer (default-value 'sgml-scratch-buffer)) (make-local-variable 'sgml-scratch-buffer) (setq sgml-scratch-buffer nil)) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/tm/tm-ew-d.el --- a/lisp/tm/tm-ew-d.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/tm/tm-ew-d.el Mon Aug 13 08:48:42 2007 +0200 @@ -9,7 +9,7 @@ ;; 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.2 $ +;; Version: $Revision: 1.3 $ ;; Keywords: encoded-word, MIME, multilingual, header, mail, news ;; This file is part of tm (Tools for MIME). @@ -35,13 +35,14 @@ (require 'std11) (require 'mel) (require 'tm-def) +(require 'tl-str) ;;; @ version ;;; (defconst tm-ew-d/RCS-ID - "$Id: tm-ew-d.el,v 1.2 1996/12/22 00:29:39 steve Exp $") + "$Id: tm-ew-d.el,v 1.3 1997/01/11 22:10:18 steve Exp $") (defconst mime/eword-decoder-version (get-version-string tm-ew-d/RCS-ID)) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/ChangeLog --- a/lisp/url/ChangeLog Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1106 +0,0 @@ -Thu Aug 1 13:26:02 1996 William Perry - -* url.el: made url-insert-file-contents interactive - -* url-sysdp.el: -added data-directory to sysdep version of x-library-search-path for -emacs under windows 95/nt - -Tue Jul 23 00:19:22 1996 William Perry - -* url.el: fix for no_proxy checking for local files - -Mon Jul 22 03:22:52 1996 William Perry - -* url-sysdp.el: added stub for make-local-hook - more Emacs 19.2x lossage. - -Sun Jul 21 20:10:42 1996 William Perry - -* url-vars.el: Created version 1.0.40 - -* url.el: -In url-after-change-function, don't change buffers if its been killed. - -Fri Jul 19 04:39:08 1996 William Perry - -* url-vars.el: Created version 1.0.39 - -Thu Jul 18 14:06:54 1996 William Perry - -* url-vars.el: duh - make url-current-server buffer local. - -Fri Jul 12 06:10:02 1996 William Perry - -* url.el: Only match against the hostname in the URL for the no_proxy checking - -* url-hash.el: removed old aliases for w3-*hash functions - -Thu Jul 11 05:10:47 1996 William Perry - -* url-sysdp.el: version of valid-color-name-p and device-class for the OS/2 -presentation manager. - -* url.el, url-file.el: handle : in filenames gracefully - -* url-vars.el: Created version 1.0.38 - -Wed Jul 10 23:33:39 1996 William Perry - -* dist.Makefile: fixed install target - duh - -* url-irc.el: fixed bad variable name - -* mm.el: require cl to avoid stupid compiler errors - -* url.el: new function url-remove-compressed-extensions - -* url-vars.el, mm.el: *** empty log message *** - -* url-cookie.el, url-vars.el: -can now control when/how/if an HTTP cookie is accepted - -Tue Jul 9 21:01:15 1996 William Perry - -* url-sysdp.el: added more overlay functions - -* url-vars.el: Created version 1.0.37 - -* url-vars.el, dist.Makefile, mm.el: *** empty log message *** - -* url.el: autoload url-nfs - -* url-http.el: *** empty log message *** - -* mm.el: Fixed mm-save-binary-file - -* url-vars.el: fix for mule stuff Emacs vs. XEmacs - -* url-wais.el: *** empty log message *** - -* url.el: turn off url-download-minor-mode stuff - -Mon Jul 1 15:32:13 1996 William Perry - -* url-sysdp.el: Added stub for buffer-substring-no-properties - -* url-sysdp.el: Fix to device-or-frame-type to work under Emacs 19.28 - -* url-sysdp.el: Added in stubs for plist-put and plist-get, and an Emacs 19.2x -specific version of facep. everything almost works in 19.28 now. - -Sun Jun 30 18:12:20 1996 William Perry - -* url-sysdp.el: Changed email address info - -Fri Jun 28 16:08:08 1996 William Perry - -* mm.el: Fix for stupid problem in mm-copy-tree - -Wed Jun 26 16:37:12 1996 William Perry - -* url-news.el, url.el: -Patch from Darrell Kindred for news problems - 1. nnheader-init-server-buffer isn't called, so the - first call to nntp-open-server fails. (Patch inserts - a call to nnheader-init-server-buffer in url-news-open-host.) - 2. The `&', '<', and '>' characters don't get turned into - entities in news from lines, subject, body, etc. The result - is that "William Perry " shows up - as "William Perry @monolith.spry.com>". (The patch moves - w3-insert-entities-in-string to url.el and renames it to - url-insert-entities-in-string, then calls it from url-format-news. - 3. When displayed, news articles get an extra, empty - "References" entry. (Patch inserts a `(delete "" ...)' - to remove the trailing empty reference from the list.) - -Tue Jun 25 18:44:30 1996 William Perry - -* mm.el: Potential fix for cl's version of copy-tree fucking things up in mm.el - -* url-sysdp.el: Added bogus definition of set-marker-insertion-type - -Fri Jun 14 17:45:16 1996 William Perry - -* url-cookie.el: fixed bug in cookie support - -* url-cookie.el: Require cl for the def. of assoc* - -* url-vars.el, url.el: -Fixes for mule from MORIOKA Tomohiko - -Thu Jun 13 00:20:04 1996 William Perry - -* url-misc.el, url.el: fixed asynch stuff through a proxy - -Wed Jun 12 04:00:39 1996 William Perry - -* url-nfs.el: Initial revision - -* url.el: Added 'nfs' url type as per the WebNFS specification - -Tue Jun 11 17:28:53 1996 William Perry - -* url-vars.el: *** empty log message *** - -* url-irc.el: Fixed bug when no channel was specified in the URL - -* url.el: Added IRC loader - -* url-irc.el: Initial revision - -Mon Jun 10 18:58:03 1996 William Perry - -* md5.el: compilation warnings removed - -* md5.el: -New version of md5.el that actually incorporates an md5 implementation -in lisp! Whoah. - -Sun Jun 9 17:32:55 1996 William Perry - -* url-http.el: -protect against malformed HTTP URLs getting passed in via url-retrieve - -* url.el: fixed problem with writing out a history file for the first time - -* url-file.el: fixed problem with ftp links - -* url-sysdp.el, dist.Makefile: Initial revision - -* base64.el, descrip.mms, docomp.el, md5.el, mm.el, ssl.el, url-cookie.el, url-file.el, url-gopher.el, url-hash.el, url-http.el, url-mail.el, url-misc.el, url-news.el, url-parse.el, url-pgp.el, url-vars.el, url-wais.el, url.el, urlauth.el: -Initial rev - -Wed Jun 5 14:31:40 1996 William Perry - -* url-cookie.el: added :test to list of keywords url-cookie provides - -Mon Jun 3 15:04:57 1996 William Perry - -* url-vars.el, url-mail.el: -Added stub url-mail function that is just a wrapper around `mail' that -will signal an error if the user says no to cancelling an unsent -message. - -Thu May 30 14:05:07 1996 William Perry - -* url-sysdp.el: Added symbol-value-in-buffer - -* url.el: made url-insert-file-contents never be asynch... duh - -* url-sysdp.el: Added insert-file-contents-literally function - -Wed May 29 18:10:31 1996 William Perry - -* url.el: -New 'minor mode' for displaying whether you are downloading a url in the background - -* url-news.el: few fixes - -* url-http.el: *** empty log message *** - -* url-http.el, url-vars.el, url.el: -Few fixes for not sending the user-agent at all if url-privacy-level -dictates so - -* url.el: Make 'nntp' url type synonymous w/'news' - -Tue May 28 04:36:55 1996 William Perry - -* url.el: *** empty log message *** - -* mm.el, url-file.el, url-vars.el, url.el: -Standardize MULE checking between Emacs and XEmacs - use featurep 'mule - -* url.el: fixed problem with detection of process-(get|put) - -* ssl.el: Changed the way to specify the ssl program - -Sat May 25 14:42:53 1996 William Perry - -* url.el: fixed problem in url-open-stream where it would always abort the -connection - have to hate bad variable initialization. - -Fri May 24 18:17:17 1996 William Perry - -* url.el: Asynch callbacks work for file downloads - -* url.el: Changed sit-for to sleep-for to make sure it actually SITS! - -* url.el: Retry connection automatically if you get the infamous 'address -already in use' error. - -* url.el, url-wais.el, url-pgp.el, url-file.el, mm.el: -No longer use mm-insert-file-contents lossage - -* url-file.el: Fix for url-host-is-local-p for urls like file:///blahblah/ - -Thu May 23 14:18:45 1996 William Perry - -* url-sysdp.el: synching up with XEmacs 19.14's version - -* url-sysdp.el: Added lots more device functions - -* url.el: Fixed url-extract-from-cache so that it wouldn't say 'loading blah' - -Wed May 22 17:07:25 1996 William Perry - -* url.el: Fixed problems with asynch image loading in emacs-w3 - -Sun May 19 02:13:46 1996 William Perry - -* url-vars.el: *** empty log message *** - -Fri May 17 14:55:16 1996 William Perry - -* url.el, url-vars.el, url-http.el: -No longer do Session-ID - subsumed by the cookie support - -Mon May 13 15:20:18 1996 William Perry - -* url-mail.el: *** empty log message *** - -* url.el: If the user does not have a history file already, always default to -using the Emacs-style history instead of prompting for it. - -Fri May 10 23:06:34 1996 William Perry - -* url.el: duh - -* url.el: New url-list-processes function - -Thu May 2 21:34:50 1996 William Perry - -* url.el: When stripping off data from a URL for viewing, leave some indication -that a query was removed if necessary - -* url-http.el: Always send off the attributes of URLs to the http server... - -Wed May 1 15:52:10 1996 William Perry - -* url-vars.el: fixed docstring of url-inhibit-uncompression - -* mm.el: *** empty log message *** - -* url-http.el: -No longer conditionalize some stuff on after-change-functions - all -Emacs19s support this. - -Tue Apr 30 16:51:07 1996 William Perry - -* url-sysdp.el: Added definition of alist-to-plist - -* url-cookie.el: Don't downcase the cookie name stuff - -* mm.el: changed calling of mm-parse-args... 3rd arg now specifies whether or -not to never downcase the name portion of the name/value pairs. - -Tue Apr 23 16:38:24 1996 William Perry - -* url-cookie.el: Added in the security measures outlined in the cookie spec. - -Mon Apr 22 16:28:00 1996 William Perry - -* url.el: renamed url-cookies.el to url-cookie -now shrinks the error window down if it cannot make a connection, and -kills the buffer afterwards - -* url-http.el, url-cookie.el, dist.Makefile: -renamed url-cookies.el to url-cookie - -* base64.el: Much faster version of base64-decode-region, courtesy of Francesco -Potorti` - -Fri Apr 12 03:51:20 1996 William Perry - -* url-sysdp.el, url-http.el: *** empty log message *** - -Thu Apr 11 21:34:18 1996 William Perry - -* url-cookie.el: Now cleans up the cookie database when it writes it to disk - -* url.el: *** empty log message *** - -* url-cookie.el: Fixed bad logic in finding matching paths for cookies. - -* url-http.el, url-cookie.el: Now supports netscape-style cookies - -Wed Apr 10 14:52:43 1996 William Perry - -* dist.Makefile, url-cookie.el: Beginnings of netscape-style cookie support - -* url-cookie.el: Initial revision - -* url-news.el: *** empty log message *** - -* url-file.el: -file:// hrefs now understand using your local hostname instead of -localhost to mean local file access. Sheesh. - -* url-file.el: -Fix for local/remote files with ':' in them getting parsed as full URLs. - -Tue Apr 9 20:44:07 1996 William Perry - -* url.el: -url-truncate-url-for-viewing can now take an optional width parameter. -If an unknown URL type is found, put quotes around it in the error -message so that its easier to know what exactly wasn't recognized. - -Fri Apr 5 14:52:42 1996 William Perry - -* url.el, url-http.el: removed excess whitespace from user-agent line - -Wed Apr 3 15:55:16 1996 William Perry - -* url.el, url-vars.el: *** empty log message *** - -* url-http.el: Now supports proxy authentication - -Tue Apr 2 17:16:23 1996 William Perry - -* url-sysdp.el: Some extent functions for emacs19 - -Sun Mar 31 02:38:41 1996 William Perry - -* base64.el: added data the the LCD stuff - -* dist.Makefile: Initial revision - -* mm.el: *** empty log message *** - -Wed Mar 27 19:51:08 1996 William Perry - -* url.el: Can now read and write the NCSA global history format version 2. - -* base64.el: Fixed _stupid_ problem in base64-decode-region - -Mon Mar 25 14:53:56 1996 William Perry - -* url-sysdp.el: Changed some pointers to ben wing and pearl software. - -Wed Mar 20 14:01:04 1996 William Perry - -* url.el: url-file-attributes will no longer signal an error - -Sun Mar 3 01:59:59 1996 William Perry - -* base64.el: added base64-decode-region - -Fri Feb 23 01:58:21 1996 William Perry - -* url-sysdp.el: *** empty log message *** - -Thu Feb 22 14:14:12 1996 William Perry - -* url.el: -Fixed problem writing mosaic and netscape style history lists. D'ohh! - -Wed Feb 21 15:35:04 1996 William Perry - -* url-sysdp.el: Added stub for add-minor-mode - -* url-sysdp.el: -Few fixes for #%!@ damn emacsen that don't sanely deal with make-face et. al -on a TTY interface. - -Sun Feb 18 06:26:03 1996 William Perry - -* url-news.el: *** empty log message *** - -Sat Feb 17 06:10:51 1996 William Perry - -* url.el: Some url expansion problems fixed - -* url.el: fixed autoload for url-news - -* url.el, mm.el: *** empty log message *** - -* url.el: Fixed problem with unescaped . in url-remove-relative-links - D'ohh! - -Tue Jan 23 13:47:43 1996 William Perry - -* url.el: Don't choke and die if you can't find ange-ftp - -Sun Jan 14 22:41:43 1996 William Perry - -* url-news.el: Fixed possible problem in recognizing new versions of GNUS - -Fri Jan 5 17:45:31 1996 William Perry - -* url-parse.el: -Fixed some ftp problems that arose when url-generic-parse-url left a -trailing ':' on the hostname sometimes. - -Wed Jan 3 18:40:54 1996 William Perry - -* url-vars.el: Fixed doc buglet in url-privacy-level - -* url.el: *** empty log message *** - -* url.el: Now no longer barfs on writing netscape/mosaic history files - -Wed Dec 20 15:08:24 1995 William Perry - -* url.el: No longer cache viewer information to disk... bad bad bad - -Tue Dec 12 15:21:13 1995 William Perry - -* url-sysdp.el: -Added stubs for make-face set-face-foreground and set-face-background -for non-X emacsen - -Sun Dec 10 16:27:41 1995 William Perry - -* url-sysdp.el: Added stubs for face-property and set-face-property - -Fri Dec 8 15:55:20 1995 William Perry - -* url.el: Now correctly trims down urls like http://foo.bar.com/../x/y/z - -Wed Dec 6 14:28:43 1995 William Perry - -* url.el: Fixed problem in url-handle-no-scheme - -* url.el: Added in stuff to do automatic link conversion from something like -'spry' to 'http://www.spry.com/' when typing in links by hand. - -Sun Dec 3 19:06:00 1995 William Perry - -* url.el: -url-view-url now returns nil instead of "" for documents that don't have -a URL associated with them. - -* url-news.el: Now checks to make sure that you have a correct version of GNUS -installed and reports error messages instead of choking and dying. - -* url-news.el: The news support now requires (ding) GNUS - -Sat Dec 2 16:46:15 1995 William Perry - -* url-file.el, url-gopher.el, url-news.el: -Removed bogus use of in generated HTML - -Wed Nov 29 15:06:58 1995 William Perry - -* url-sysdp.el: Define x-font-regexp-foundry-and-family for Emacs 19 - -Fri Nov 24 22:54:09 1995 William Perry - -* url.texi: -Lots of changes and restructuring - will not compile at all right now - -Sun Nov 19 22:35:20 1995 William Perry - -* docomp.el: *** empty log message *** - -* mm.el, url-misc.el: Fixed some problems with MULE and code conversion - -* urlauth.el: -Removed bogus call/definition of 'warn' instead of using url-warn. Bleah. - -Fri Nov 17 18:48:16 1995 William Perry - -* url.el: Fixed writing of the emacs-style global history file - -* url-hash.el: -Fixed hashtable stuff under XEmacs - the key of a hashtable must be -able to compare with 'eq', not 'equal', so had to change it to use -symbols instead of the url string. - -* url.el: Default to using user-mail-address for url-pgp/pem-entity and -url-personal-mail-address - -* url-parse.el: Fixed problem with parsing url fragments - -Wed Nov 15 16:49:31 1995 William Perry - -* url-file.el: -Fixed some bad HTML that made the new parser break when it implied a - tag - -Tue Nov 14 01:23:13 1995 William Perry - -* url-vars.el, url.el: Trying to make OS/2 happy with our CRLF handling - -Fri Nov 10 17:41:39 1995 William Perry - -* url-gopher.el: Fixed possible screwup in url-grok-gopher-line - -Wed Nov 1 15:21:39 1995 William Perry - -* url-http.el: -Always default to basic authentication if no www-authenticate header was returned - -* url.el: -Don't leave backup copies of w3-hotlist-file or url-global-history-file - -Sun Oct 29 02:38:49 1995 William Perry - -* url.el: Don't do cacheing if doing asynchronous retrieval - -* url-parse.el: *** empty log message *** - -* url-file.el: Fixed a typo - -* url-parse.el: Now unescapes the hostname part of a URL if necessary - -Sat Oct 28 04:01:56 1995 William Perry - -* url-vars.el, url.el: -Now only saves the history list to disk via the timer if the list has -changed since the last time. - -* url.el: *** empty log message *** - -* url-parse.el: Now correctly handles the ;xx=yy attributes on URLs, etc. - -* mm.el: Added some new content-transfer-encodings ala the HTTP/1.1 draft - -Wed Oct 25 22:50:55 1995 William Perry - -* url.el: Extended url-truncate-url-for-viewing to actually do something. -Really long URLs should no longer look like shit for V/v or mouse -tracking viewing. Could be fairly expensive string/GC wise - -* url-parse.el: -Fixed problem in parsing xxx@yyy hostnames in url-generic-parse-url - -Sun Oct 15 22:17:06 1995 William Perry - -* url-http.el: *** empty log message *** - -* url-parse.el: No longer hangs on really fucking long URLs - -* url-hash.el: *** empty log message *** - -* url-vars.el: Fixed regexp so it won't blow up in emacs18 - -* url-http.el: *** empty log message *** - -* url-gopher.el: Fixed problem with tn3270 and telnet links from a gopher page. - -* url-misc.el: -Fixed problem with telnet/tn3270/rlogin URLs popping up a bogus `Unkown' buffer - -Tue Oct 10 13:28:40 1995 William Perry - -* url-mail.el, url-http.el, url-file.el: Fixed header lines - -Mon Oct 9 02:54:32 1995 William Perry - -* mm.el: *** empty log message *** - -Sun Oct 8 23:27:54 1995 William Perry - -* mm.el: Fixed bug in mm-parse-args where it would (almost) always tack an -empty/unneeded ("") at the end of the list or argument/value pairs - -* url-sysdp.el: *** empty log message *** - -Mon Oct 2 13:02:40 1995 William Perry - -* url-http.el: Now sends the "Server" header on all requests, ala HTTP/1.1 - -* url.el: *** empty log message *** - -Thu Sep 28 13:18:17 1995 William Perry - -* url-file.el, url.el: *** empty log message *** - -Sun Sep 24 17:13:14 1995 William Perry - -* url-sysdp.el: Added def of find-face - -* url-vars.el: -New variable url-extensions-header that is the list of http extensions -we support - -* url-http.el: *** empty log message *** - -* url-http.el: -Improved url-parse-viewer-types to only stick something in the accept -list once - -Sat Sep 23 23:13:29 1995 William Perry - -* docomp.el, url.texi, descrip.mms, url-file.el, url-gopher.el, url-http.el, url-mail.el, url-misc.el, url-news.el, url-pgp.el, url-wais.el, url.el, urlauth.el: -*** empty log message *** - -* url-parse.el: Initial revision - -* url.el, docomp.el: *** empty log message *** - -* docomp.el, url-gopher.el, url-hash.el, url-http.el, url-mail.el, url-misc.el, url-news.el, url-pgp.el, url-vars.el, url-wais.el, url.el, urlauth.el, url-file.el: -Initial revision - -* descrip.mms: *** empty log message *** - -Wed Sep 20 13:46:55 1995 William Perry - -* url-sysdp.el: *** empty log message *** - -Mon Sep 18 18:13:14 1995 William Perry - -* url-sysdp.el: *** empty log message *** - -Sun Sep 17 16:54:09 1995 William Perry - -* url-sysdp.el: *** empty log message *** - -* url-sysdp.el: -make-hashtable now finds the next highest prime for the initial size. - -* url-sysdp.el: Added def of clrhash - -* url-sysdp.el: *** empty log message *** - -* url-sysdp.el: Added hashtable functions - -Sat Sep 16 01:37:18 1995 William Perry - -* mm.el: Some MULE stuff - -* mm.el: *** empty log message *** - -Mon Sep 11 14:32:40 1995 William Perry - -* url-sysdp.el: *** empty log message *** - -Sun Sep 10 23:26:47 1995 William Perry - -* url-sysdp.el: Added defvar for x-library-search-path - -Sun Sep 3 18:56:21 1995 William Perry - -* mm.el: put in appropriate test clauses for the bulitin viewers that have a -'needsx11' tag present. - -* url-sysdp.el: fixed typo in device-mm-width - -Wed Aug 30 20:25:26 1995 William Perry - -* mm.el: Applied patch from jbw@cs.bu.edu (Joe Wells) for handling invalid -mailcap entries gracefully - -Sat Aug 26 06:21:20 1995 William Perry - -* url-sysdp.el: Added split-string - -Fri Aug 25 18:56:55 1995 William Perry - -* url-sysdp.el: Added definition of try-font-name - -* url-sysdp.el: *** empty log message *** - -Wed Aug 23 19:51:43 1995 William Perry - -* mm.el: Added a default mpeg audio player - -Sat Aug 19 23:26:18 1995 William Perry - -* mm.el: *** empty log message *** - -* mm.el: Some MULE fixes for mm-insert-file-contents - -* mm.el: -Added image/* -> open %s mapping for external viewer if running under NS - -Sat Aug 12 00:54:10 1995 William Perry - -* mm.el: -Always set coding-system to *noconv* in MULE when inserting file contents - -Tue Aug 1 15:54:26 1995 William Perry - -* mm.el: *** empty log message *** - -Mon Jul 31 04:21:42 1995 William Perry - -* mm.el: Some NeXT viewers added - -Sun Jul 23 17:12:46 1995 William Perry - -* mm.el: Moved some less standard extensions (.ai -> postscript, etc) to the -end of the list so that they won'tbe picked up as the default -extension when viewing files. - -Thu Jun 29 14:55:14 1995 William Perry - -* mm.el: -Various patches from Katsumi Yamaoka Katsumi Yamaoka for MULE stuff -] - -Tue Jun 27 04:18:13 1995 William Perry - -* mm.el: *** empty log message *** - -Sun Jun 25 20:03:18 1995 William Perry - -* mm.el: *** empty log message *** - -* url-sysdp.el: Some more device-* functions - -* url-sysdp.el: More NS problems resolved - -* url-sysdp.el: Fixed problem in w3-device-class on NeXTstep - -* mm.el, url-sysdp.el: -Continue movement to using w3-sysdp.el defined functions instead of -url-* funcs - -Mon Jun 19 12:46:46 1995 William Perry - -* url-sysdp.el: *** empty log message *** - -* url-sysdp.el: Fixed problem in device-class with arg not being optional - -Sun Jun 18 21:41:36 1995 William Perry - -* url-sysdp.el: -Fixed bug in emacs-19 version of device-class on non-color displays - -* url-sysdp.el: Rewrote device-class -Added device-pixel-width and device-pixel-height - -* url-sysdp.el: *** empty log message *** - -Sat Jun 17 16:35:46 1995 William Perry - -* url-sysdp.el: Few more bugfixes - -* url-sysdp.el: Fixes for nextstep - -* url-sysdp.el: -Fixed definition of device-class so that it won't choke and die under -NeXTstep. - -Fri Jun 16 01:10:44 1995 William Perry - -* url-sysdp.el: Removed scrollbar functions. - -Wed Jun 14 23:30:43 1995 William Perry - -* url-sysdp.el: -Changed sysdep-defalias to make sure that 'def' is fboundp if its a -symbol, so that bogus defs of make-frame, etc, are not created in -emacs18 - -* url-sysdp.el: More functions added - -* mm.el: Few things to get a nice clean compile using w3-sysdp - -Tue Jun 13 15:38:32 1995 William Perry - -* url-sysdp.el: *** empty log message *** - -Mon Jun 12 15:09:51 1995 William Perry - -* descrip.mms: -Added back in the requiring of w3-wemac - just too much different -stuff between it and even 19.10. - -* descrip.mms: -Added the VMS build file from Richard Levitte - -* descrip.mms: Initial revision - -Mon May 29 18:10:13 1995 William Perry - -* mm.el: Removed lots of function documentation and left it as comments. These -functions are not meant to be seen by everyone, and this saves space -in the .elc files. - -Thu May 25 16:55:24 1995 William Perry - -* mm.el: Added in a bunch of new file extensions. -VRML stuff turned on by default. - -Mon May 8 16:20:30 1995 William Perry - -* ssl.el: Initial revision - -Sun May 7 15:58:25 1995 William Perry - -* mm.el: Fixed typo that made mm-play-sound-file always show up as the sound -player. Ack. - -* base64.el: Made a few performance tweaks (macros) - -* mm.el: mm-parse-args can now take an 'allow-math' flag, so that name/value -pairs can look like '*=', etc. - -* base64.el: Removed dependency on url.el - -* mm.el: Now uses the base64.el package to do decoding - -* base64.el: Initial revision - -Sat May 6 17:14:12 1995 William Perry - -* mm.el: Reorded text/plain viewers again - -Tue Apr 25 17:39:48 1995 William Perry - -* mm.el: More content-transfer-encodings - -* mm.el: New function to decode quoted printable - -Wed Apr 19 03:25:01 1995 William Perry - -* url-sysdp.el: Updated to latest version from XEmacs - -* url-sysdp.el: Removed keywords - -Sun Apr 16 05:14:10 1995 William Perry - -* mm.el: Changes to mm-parse-args to make it more rfc822-y. - -Fri Apr 14 23:48:49 1995 William Perry - -* mm.el: Changed keywords - -* md5.el: Added keywords - -* mm.el: Reverse 'passed' list in mm-mime-info to get it back in the original -order. Because the loop through the main list puts them in reversed -order. - -* mm.el: Replaced stupid mistake of using w3-dump-to-disk as a function - -Tue Apr 11 23:11:58 1995 William Perry - -* url-sysdp.el: Added some more stuff from chuck - -Mon Apr 10 21:31:13 1995 William Perry - -* mm.el: MM will now play sounds internally if in XEmacs and nas-sound or -native-sound is compiled in. - -Tue Mar 28 15:19:18 1995 William Perry - -* mm.el: Fixed concat'ing of ints - -Sun Mar 26 05:24:03 1995 William Perry - -* mm.el: Added default dumper for application/octet-stream - -Sat Mar 25 22:23:46 1995 William Perry - -* mm.el: Fixes for emacs 18.59 - -* url-sysdp.el: A few new functions for the latest and greatest beta - -Thu Mar 16 16:56:59 1995 William Perry - -* mm.el: *** empty log message *** - -* mm.el: Fixed viewers once and for all. - -* mm.el: -Fixed unencoding of mime viewers when requesting the entire viewer data. - -* md5.el: Initial revision - -Mon Mar 13 05:51:41 1995 William Perry - -* mm.el: Lots and lots of doc fixes to meet FSF/GNU guidelines. - -* mm.el: Few doc string fixes - -Sat Mar 11 21:41:47 1995 William Perry - -* mm.el: -Fixed mm-mime-info so that it returns the correctly unescaped mime viewer - -Wed Mar 1 16:22:46 1995 William Perry - -* url-sysdp.el: Removed function call causing problems - -Sat Feb 25 22:23:46 1995 William Perry - -* url-sysdp.el: -Removed anonymous lambda without 'function' wrapper for WinEmacs and -early versoins of lucid emacs. - -Sat Feb 18 19:15:37 1995 William Perry - -* mm.el: Fixed a few compilation warnings. - -* url-sysdp.el: Initial revision - -Sun Feb 5 17:12:25 1995 William Perry - -* mm.el: *** empty log message *** - -* mm.el: Rewrote how viewers are chosen if more than one passes its test. Use -sort, with funky function. Basically, fully-specified MIME types with -lisp viewers take precedence, then lisp-viewers, then fully-specified. - -* mm.el: Added a few more default viewers - -Sat Jan 28 06:49:34 1995 William Perry - -* mm.el: Added headers for finder package - -Thu Jan 26 04:56:08 1995 William Perry - -* mm.el: Removed some more dependencies on w3. - -Mon Jan 23 16:15:15 1995 William Perry - -* mm.el: Few changes to how it writes into mm-mime-data - -Sat Jan 21 17:50:04 1995 William Perry - -* mm.el: replaced all occurances of htmlplus with html - -Mon Dec 26 05:15:28 1994 William Perry - -* url.texi: *** empty log message *** - -* mm.el: Updated copyright notices for 1995 - -Sun Dec 25 18:36:53 1994 William Perry - -* mm.el: Added default viewer for text/enriched. - -* mm.el: Added in checks for windows-nt system-type when figuring out the path -separator char. - -Sat Dec 24 20:11:57 1994 William Perry - -* url.texi: *** empty log message *** - -Mon Dec 12 05:25:46 1994 William Perry - -* mm.el: Changed lots of the version variables so that they don't rely on -having the RCS headers in them. - -Sun Dec 11 07:18:44 1994 William Perry - -* mm.el: Added new function mm-type-to-file that will take a MIME-type as its -argument and return the file spec. - -Mon Nov 28 17:11:38 1994 William Perry - -* mm.el: More misc. name changes - -Wed Nov 2 17:02:24 1994 William Perry - -* url.texi: *** empty log message *** - -* mm.el: Let the variable shell-file-name take precedence over environment -variables and guessing - -* url.texi: Initial revision - -Fri Sep 16 17:18:03 1994 William Perry - -* mm.el: Lots of little fixes - -Sun Aug 21 14:20:50 1994 William Perry - -* mm.el: Fixed problem on ms-dos/ms-windows systems where I was still using : -as the path separator instead of ; - -Sun Aug 14 20:11:45 1994 William Perry - -* mm.el: More fixes to work under DOS/Windows - -Sat Aug 6 15:51:17 1994 William Perry - -* mm.el: *** empty log message *** - -* mm.el: New viewer for multipart/* messages. - -Mon Aug 1 13:43:43 1994 William Perry - -* mm.el: Lots more default mime viewers - -Sun Jul 24 19:32:43 1994 William Perry - -* mm.el: New defaults for x-gzip and a few multipart styles. - -* mm.el: Changed mm-possible-viewers to return a sorted list. Favors exact -matches (text/html) before wildcard (text/h* or text/*) - -* mm.el: Changed all references to wmperry@indiana.edu to use w3-bug-address -instead. Changed all copyright notices to use my new email address -also. - -* mm.el: Don't show messages about 'couldn't read xxx' - -Sat Jul 23 19:49:05 1994 William Perry - -* mm.el: Fixed problem with 'test' clause of mm-mime-info - -Thu Jul 14 03:16:00 1994 William Perry - -* mm.el: *** empty log message *** - -Wed Jul 13 05:07:38 1994 William Perry - -* mm.el: *** empty log message *** - -Mon Jul 11 05:27:46 1994 William Perry - -* mm.el: *** empty log message *** - -Sun Jul 10 18:52:08 1994 William Perry - -* mm.el: Changed where ~/.mailcap comes in the default MAILCAPS entry, so that -it takes precedence over the others in mm-mime-data - -Mon Jul 4 17:38:52 1994 William Perry - -* mm.el: Various patches from Alastair Burt - -Sat May 28 12:03:42 1994 William Perry - -* mm.el: mm-mime-info now favors the embedded lisp functions/lists when -retrieving mailcap data. This way things will go into -w3-prepare-buffer even if text/html is redefined in the mailcap file. - -Fri May 27 13:44:56 1994 William Perry - -* mm.el: Fixed problem with mm-unescape-mime-test when it tried to take a -symbol or list as a parameter. - -Wed May 25 11:48:20 1994 William Perry - -* mm.el: Downcase a file extension before looking in the assoc list for it. - -* mm.el: Always add new viewers onto the list, but don't replace them. - -Wed May 18 18:53:17 1994 William Perry - -* mm.el: Fixed problem with passing nil to mm-mime-info - -Tue May 17 20:55:51 1994 William Perry - -* mm.el: Properly unescape \; in viewers/composers/etc. - -* mm.el: Lots of changes, especially regarding mm-unescape-mime-tester - -Sun May 15 18:50:37 1994 William Perry - -* mm.el: *** empty log message *** - -* mm.el: Added a few more default content-type bindings - -* mm.el: Added in extension-to-mime parsing/mapping. Also put in some decent -defaults for the common mime types. - -* mm.el: *** empty log message *** - -* mm.el: Correctly checks for the default info if no viewer is matching -content-type is found - -Sat May 14 20:33:50 1994 William Perry - -* mm.el: Lots of little tweaks. - -Fri May 13 22:06:10 1994 William Perry - -* mm.el: Initial revision - diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/Makefile --- a/lisp/url/Makefile Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -# Temp file to use to build .elc files -ELISP-TO-COMPILE = /tmp/elc-url-${USER} - -# what emacs is called on your system -EMACS = emacs - -# where the Info file should go -INFODIR = . - -# where the lisp files will be installed. -LISPDIR = $$HOME/lisp - -# Change this to be where your .emacs file is stored -DOTEMACS = $$HOME/.emacs - -# Change this to be how to convert texinfo files into info files -# examples: -# MAKEINFO = $(EMACS) -batch -q -f batch-texinfo-format -# MAKEINFO = makeinfo -MAKEINFO = makeinfo - -# Where your version of 'install' lives -INSTALL = install - -# Various other stuff used -RM = rm -f -CP = cp -############## no user servicable parts beyond this point ################### -MAJOR=1 -MINOR=0 - -# Have to preload a few things to get a nice clean compile -DEPS = -l ./url-vars.el -l ./docomp.el - -# compile with noninteractive and relatively clean environment -BATCHFLAGS = -batch -q -no-site-file - -# What type of version this is - beta or normal -VTYPE = p -DIRNAME = url - -.SUFFIXES: .elc .el .el,v - -.el.elc: - $(EMACS) $(BATCHFLAGS) $(DEPS) -f batch-byte-compile $< - -OBJECTS = \ - url-file.elc \ - url-nfs.elc \ - url-cookie.elc \ - url-irc.elc \ - url-parse.elc \ - url-gopher.elc \ - url-hash.elc \ - url-http.elc \ - url-mail.elc \ - url-misc.elc \ - url-news.elc \ - url-pgp.elc \ - url-vars.elc \ - url-wais.elc \ - urlauth.elc \ - mm.elc \ - md5.elc \ - ssl.elc \ - base64.elc \ - url.elc - -SOURCES = \ - docomp.el \ - url-nfs.el \ - url-sysdp.el \ - url-file.el \ - url-cookie.el \ - url-parse.el \ - url-irc.el \ - url-gopher.el \ - url-hash.el \ - url-http.el \ - url-mail.el \ - url-misc.el \ - url-news.el \ - url-pgp.el \ - url-vars.el \ - url-wais.el \ - urlauth.el \ - mm.el \ - md5.el \ - ssl.el \ - base64.el \ - url.el - -DISTFILES = $(SOURCES) descrip.mms - -url: docomp.el $(OBJECTS) - @echo Build of url complete... - -clean: - rm -f $(OBJECTS) - -url.html: url.texi - @texi2html -menu -split_node -verbose url.texi - -url.info: url.texi - @$(MAKEINFO) url.texi - -url.dvi: url.texi - @tex url.texi - @texindex url.cp url.fn url.ky url.pg url.tp url.vr - @tex url.texi - @rm -f url.cp url.fn url.ky url.pg url.tp url.vr \ - url.cps url.fns url.kys url.pgs url.tps url.vrs \ - url.log url.toc url.aux - -install: url - @echo Installing in $(LISPDIR) - $(INSTALL) -d $(LISPDIR) - $(INSTALL) -m 644 $(SOURCES) $(OBJECTS) $(LISPDIR) -# $(INSTALL) -d $(INFODIR) -# $(INSTALL) -m 644 url.info* $(INFODIR) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/base64.el --- a/lisp/url/base64.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,171 +0,0 @@ -;;; base64.el,v --- Base64 encoding functions -;; Author: wmperry -;; Created: 1996/04/22 15:08:08 -;; Version: 1.7 -;; Keywords: extensions - -;;; LCD Archive Entry: -;;; base64.el|William M. Perry|wmperry@spry.com| -;;; Package for encoding/decoding base64 data (MIME)| -;;; 1996/04/22 15:08:08|1.7|Location Undetermined -;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Base 64 encoding functions -;;; This code was converted to lisp code by me from the C code in -;;; ftp://cs.utk.edu/pub/MIME/b64encode.c -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar base64-code-string - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" - "Character set used for base64 decoding") - -(defvar base64-decode-vector - (let ((vec (make-vector 256 nil)) - (i 0) - (case-fold-search nil)) - (while (< i 256) - (aset vec i (string-match (regexp-quote (char-to-string i)) - base64-code-string)) - (setq i (1+ i))) - vec)) - -(defvar base64-max-line-length 64) - -;(defun b0 (x) (aref base64-code-string (logand (lsh x -18) 63))) -;(defun b1 (x) (aref base64-code-string (logand (lsh x -12) 63))) -;(defun b2 (x) (aref base64-code-string (logand (lsh x -6) 63))) -;(defun b3 (x) (aref base64-code-string (logand x 63))) - -(defmacro b0 (x) (` (aref base64-code-string (logand (lsh (, x) -18) 63)))) -(defmacro b1 (x) (` (aref base64-code-string (logand (lsh (, x) -12) 63)))) -(defmacro b2 (x) (` (aref base64-code-string (logand (lsh (, x) -6) 63)))) -(defmacro b3 (x) (` (aref base64-code-string (logand (, x) 63)))) - -(defun base64-encode (str) - "Do base64 encoding on string STR and return the encoded string. -This code was converted to lisp code by me from the C code in -ftp://cs.utk.edu/pub/MIME/b64encode.c. Returns a string that is -broken into `base64-max-line-length' byte lines." - (or str (setq str (buffer-string))) - (let ((x (base64-encode-internal str)) - (y "")) - (while (> (length x) base64-max-line-length) - (setq y (concat y (substring x 0 base64-max-line-length) "\n") - x (substring x base64-max-line-length nil))) - (setq y (concat y x)) - y)) - -(defun base64-encode-internal (str) - "Do base64 encoding on string STR and return the encoded string. -This code was converted to lisp code by me from the C code in -ftp://cs.utk.edu/pub/MIME/b64encode.c. Returns the entire string, -not broken up into `base64-max-line-length' byte lines." - (let ( - (word 0) ; The word to translate - w1 w2 w3 - ) - (cond - ((> (length str) 3) - (concat - (base64-encode-internal (substring str 0 3)) - (base64-encode-internal (substring str 3 nil)))) - ((= (length str) 3) - (setq w1 (aref str 0) - w2 (aref str 1) - w3 (aref str 2) - word (logior - (lsh (logand w1 255) 16) - (lsh (logand w2 255) 8) - (logand w3 255))) - (format "%c%c%c%c" (b0 word) (b1 word) (b2 word) (b3 word))) - ((= (length str) 2) - (setq w1 (aref str 0) - w2 (aref str 1) - word (logior - (lsh (logand w1 255) 16) - (lsh (logand w2 255) 8) - 0)) - (format "%c%c%c=" (b0 word) (b1 word) (b2 word))) - ((= (length str) 1) - (setq w1 (aref str 0) - word (logior - (lsh (logand w1 255) 16) - 0)) - (format "%c%c==" (b0 word) (b1 word))) - (t "")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Base64 decoding functions -;;; Most of the decoding code is courtesy Francesco Potorti` -;;; -;;; this is much faster than my original code - thanks! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun base64-decode-region (beg end) - (interactive "r") - (barf-if-buffer-read-only) - (let - ((exchange (= (point) beg)) - (endchars 0) - (list) (code)) - (goto-char beg) - (while (< (point) end) - (setq list (mapcar - (function - (lambda (c) - (cond - ((aref base64-decode-vector c)) - ((char-equal c ?=) - (setq endchars (1+ endchars)) - 0) - (nil - (error - "Character %c does not match Mime base64 coding" c))))) - (buffer-substring (point) (+ (point) 4)))) - (setq code (+ (nth 3 list) (lsh (nth 2 list) 6) - (lsh (nth 1 list) 12) (lsh (car list) 18))) - (delete-char 4) - (cond - ((zerop endchars) - (insert (% (lsh code -16) 256) (% (lsh code -8) 256) (% code 256))) - ((= endchars 1) - (insert (% (lsh code -16) 256) (% (lsh code -8) 256)) - (setq end (point))) - ((= endchars 2) - (insert (% (lsh code -16) 256)) - (setq end (point)))) - (if (char-equal (following-char) ?\n) - (progn (delete-char 1) - (setq end (- end 2))) - (setq end (1- end)))) - )) -; (if exchange -; (exchange-point-and-mark)))) - -(defun base64-decode (st &optional nd) - "Do base64 decoding on string STR and return the original string. -If given buffer positions, destructively decodes that area of the -current buffer." - (let ((replace-p nil) - (retval nil)) - (if (stringp st) - nil - (setq st (prog1 - (buffer-substring st (or nd (point-max))) - (delete-region st (or nd (point-max)))) - replace-p t)) - (setq retval - (save-excursion - (set-buffer (get-buffer-create " *b64decode*")) - (erase-buffer) - (insert st) - (goto-char (point-min)) - (while (re-search-forward "\r*\n" nil t) - (replace-match "")) - (goto-char (point-min)) - (base64-decode-region (point-min) (point-max)) - (buffer-string))) - (if replace-p (insert retval)) - retval)) - -(provide 'base64) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/docomp.el --- a/lisp/url/docomp.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -(setq load-path (cons (expand-file-name "./") load-path)) - -(defun url-declare-variables (&rest args) - (while args - (eval (list 'defvar (car args) nil "")) - (setq args (cdr args)))) - -;; Various internals -(url-declare-variables 'proxy-info 'mm-mime-data - 'mm-content-transfer-encodings) - -;; For Emacs 19 -(url-declare-variables 'track-mouse 'menu-bar-help-menu) - -;; For MULE -(url-declare-variables '*noconv* '*autoconv* '*euc-japan* '*internal* - 'file-coding-system-for-read 'file-coding-system) - -;; For Mailcrypt -(url-declare-variables 'mc-pgp-path 'mc-pgp-key-begin-line 'mc-ripem-pubkeyfile - 'mc-default-scheme 'mc-flag) - -;; For NNTP -(url-declare-variables 'nntp-server-buffer 'nntp-server-process - 'nntp/connection 'gnus-nntp-server - 'nntp-server-name 'nntp-version - 'gnus-default-nntp-server) - -;; For ps-print -(url-declare-variables 'ps-bold-faces 'ps-italic-faces 'ps-print-version) - -;; For xpm-button -(url-declare-variables 'x-library-search-path) - -(url-declare-variables 'command-line-args-left 'standard-display-table) - -(load "bytecomp" t t nil) -;; Emacs 19 byte compiler complains about too much stuff by default. -;; Turn off most of the warnings here. -(setq byte-compile-warnings '(free-vars)) - -(require 'url-vars) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/md5.el --- a/lisp/url/md5.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,409 +0,0 @@ -;;; md5.el -- MD5 Message Digest Algorithm -;;; Gareth Rees - -;; LCD Archive Entry: -;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| -;; MD5 cryptographic message digest algorithm| -;; 13-Nov-95|1.0|~/misc/md5.el.Z| - -;;; Details: ------------------------------------------------------------------ - -;; This is a direct translation into Emacs LISP of the reference C -;; implementation of the MD5 Message-Digest Algorithm written by RSA -;; Data Security, Inc. -;; -;; The algorithm takes a message (that is, a string of bytes) and -;; computes a 16-byte checksum or "digest" for the message. This digest -;; is supposed to be cryptographically strong in the sense that if you -;; are given a 16-byte digest D, then there is no easier way to -;; construct a message whose digest is D than to exhaustively search the -;; space of messages. However, the robustness of the algorithm has not -;; been proven, and a similar algorithm (MD4) was shown to be unsound, -;; so treat with caution! -;; -;; The C algorithm uses 32-bit integers; because GNU Emacs -;; implementations provide 28-bit integers (with 24-bit integers on -;; versions prior to 19.29), the code represents a 32-bit integer as the -;; cons of two 16-bit integers. The most significant word is stored in -;; the car and the least significant in the cdr. The algorithm requires -;; at least 17 bits of integer representation in order to represent the -;; carry from a 16-bit addition. - -;;; Usage: -------------------------------------------------------------------- - -;; To compute the MD5 Message Digest for a message M (represented as a -;; string or as a vector of bytes), call -;; -;; (md5-encode M) -;; -;; which returns the message digest as a vector of 16 bytes. If you -;; need to supply the message in pieces M1, M2, ... Mn, then call -;; -;; (md5-init) -;; (md5-update M1) -;; (md5-update M2) -;; ... -;; (md5-update Mn) -;; (md5-final) - -;;; Copyright and licence: ---------------------------------------------------- - -;; Copyright (C) 1995 by Gareth Rees -;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm -;; -;; md5.el is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by the -;; Free Software Foundation; either version 2, or (at your option) any -;; later version. -;; -;; md5.el is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -;; for more details. -;; -;; The original copyright notice is given below, as required by the -;; licence for the original code. This code is distributed under *both* -;; RSA's original licence and the GNU General Public Licence. (There -;; should be no problems, as the former is more liberal than the -;; latter). - -;;; Original copyright notice: ------------------------------------------------ - -;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. -;; -;; License to copy and use this software is granted provided that it is -;; identified as the "RSA Data Security, Inc. MD5 Message- Digest -;; Algorithm" in all material mentioning or referencing this software or -;; this function. -;; -;; License is also granted to make and use derivative works provided -;; that such works are identified as "derived from the RSA Data -;; Security, Inc. MD5 Message-Digest Algorithm" in all material -;; mentioning or referencing the derived work. -;; -;; RSA Data Security, Inc. makes no representations concerning either -;; the merchantability of this software or the suitability of this -;; software for any particular purpose. It is provided "as is" without -;; express or implied warranty of any kind. -;; -;; These notices must be retained in any copies of any part of this -;; documentation and/or software. - -;;; Code: --------------------------------------------------------------------- - -(defvar md5-program "md5" - "*Program that reads a message on its standard input and writes an -MD5 digest on its output.") - -(defvar md5-maximum-internal-length 4096 - "*The maximum size of a piece of data that should use the MD5 routines -written in lisp. If a message exceeds this, it will be run through an -external filter for processing. Also see the `md5-program' variable. -This variable has no effect if you call the md5-init|update|final -functions - only used by the `md5' function's simpler interface.") - -(defvar md5-bits (make-vector 4 0) - "Number of bits handled, modulo 2^64. -Represented as four 16-bit numbers, least significant first.") -(defvar md5-buffer (make-vector 4 '(0 . 0)) - "Scratch buffer (four 32-bit integers).") -(defvar md5-input (make-vector 64 0) - "Input buffer (64 bytes).") - -(defun md5-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - -(defun md5-encode (message) - "Encodes MESSAGE using the MD5 message digest algorithm. -MESSAGE must be a string or an array of bytes. -Returns a vector of 16 bytes containing the message digest." - (if (<= (length message) md5-maximum-internal-length) - (progn - (md5-init) - (md5-update message) - (md5-final)) - (save-excursion - (set-buffer (get-buffer-create " *md5-work*")) - (erase-buffer) - (insert message) - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t (current-buffer) nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (let ((data (buffer-substring (point-min) (+ (point-min) 32))) - (vec (make-vector 16 0)) - (ctr 0)) - (while (< ctr 16) - (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) - (md5-unhex (aref data (1+ (* ctr 2)))))) - (setq ctr (1+ ctr))))))) - -(defsubst md5-add (x y) - "Return 32-bit sum of 32-bit integers X and Y." - (let ((m (+ (car x) (car y))) - (l (+ (cdr x) (cdr y)))) - (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) - -;; FF, GG, HH and II are basic MD5 functions, providing transformations -;; for rounds 1, 2, 3 and 4 respectively. Each function follows this -;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x -;; by y bits to the left): -;; -;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b -;; -;; so we use the macro `md5-make-step' to construct each one. The -;; helper functions F, G, H and I operate on 16-bit numbers; the full -;; operation splits its inputs, operates on the halves separately and -;; then puts the results together. - -(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) -(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) -(defsubst md5-H (x y z) (logxor x y z)) -(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) - -(defmacro md5-make-step (name func) - (` - (defun (, name) (a b c d x s ac) - (let* - ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) - (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) - (m2 (logand 65535 (+ m1 (lsh l1 -16)))) - (l2 (logand 65535 l1)) - (m3 (logand 65535 (if (> s 15) - (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) - (+ (lsh m2 s) (lsh l2 (- s 16)))))) - (l3 (logand 65535 (if (> s 15) - (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) - (+ (lsh l2 s) (lsh m2 (- s 16))))))) - (md5-add (cons m3 l3) b))))) - -(md5-make-step md5-FF md5-F) -(md5-make-step md5-GG md5-G) -(md5-make-step md5-HH md5-H) -(md5-make-step md5-II md5-I) - -(defun md5-init () - "Initialise the state of the message-digest routines." - (aset md5-bits 0 0) - (aset md5-bits 1 0) - (aset md5-bits 2 0) - (aset md5-bits 3 0) - (aset md5-buffer 0 '(26437 . 8961)) - (aset md5-buffer 1 '(61389 . 43913)) - (aset md5-buffer 2 '(39098 . 56574)) - (aset md5-buffer 3 '( 4146 . 21622))) - -(defun md5-update (string) - "Update the current MD5 state with STRING (an array of bytes)." - (let ((len (length string)) - (i 0) - (j 0)) - (while (< i len) - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Store this byte (truncating to 8 bits to be sure) - (aset md5-input j (logand 255 (aref string i))) - - ;; Update number of bits by 8 (modulo 2^64) - (let ((c 8) (k 0)) - (while (and (> c 0) (< k 4)) - (let ((b (aref md5-bits k))) - (aset md5-bits k (logand 65535 (+ b c))) - (setq c (if (> b (- 65535 c)) 1 0) - k (1+ k))))) - - ;; Increment number of bytes processed - (setq i (1+ i)) - - ;; When 64 bytes accumulated, pack them into sixteen 32-bit - ;; integers in the array `in' and then tranform them. - (if (= j 63) - (let ((in (make-vector 16 (cons 0 0))) - (k 0) - (kk 0)) - (while (< k 16) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4))) - (md5-transform in)))))) - -(defun md5-pack (array i) - "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." - (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) - (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) - -(defun md5-byte (array n b) - "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." - (let ((e (aref array n))) - (cond ((eq b 0) (logand 255 (cdr e))) - ((eq b 1) (lsh (cdr e) -8)) - ((eq b 2) (logand 255 (car e))) - ((eq b 3) (lsh (car e) -8))))) - -(defun md5-final () - (let ((in (make-vector 16 (cons 0 0))) - (j 0) - (digest (make-vector 16 0)) - (padding)) - - ;; Save the number of bits in the message - (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) - (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) - - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Pad out computation to 56 bytes modulo 64 - (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) - (aset padding 0 128) - (md5-update padding) - - ;; Append length in bits and transform - (let ((k 0) (kk 0)) - (while (< k 14) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4)))) - (md5-transform in) - - ;; Store the results in the digest - (let ((k 0) (kk 0)) - (while (< k 4) - (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) - (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) - (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) - (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) - (setq k (+ k 1) kk (+ kk 4)))) - - ;; Return digest - digest)) - -;; It says in the RSA source, "Note that if the Mysterious Constants are -;; arranged backwards in little-endian order and decrypted with the DES -;; they produce OCCULT MESSAGES!" Security through obscurity? - -(defun md5-transform (in) - "Basic MD5 step. Transform md5-buffer based on array IN." - (let ((a (aref md5-buffer 0)) - (b (aref md5-buffer 1)) - (c (aref md5-buffer 2)) - (d (aref md5-buffer 3))) - (setq - a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) - d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) - c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) - b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) - a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) - d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) - c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) - b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) - a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) - d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) - c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) - b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) - a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) - d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) - c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) - b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) - a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) - d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) - c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) - b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) - a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) - d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) - c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) - b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) - a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) - d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) - c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) - b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) - a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) - d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) - c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) - b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) - a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) - d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) - c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) - b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) - a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) - d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) - c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) - b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) - a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) - d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) - c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) - b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) - a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) - d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) - c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) - b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) - a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) - d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) - c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) - b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) - a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) - d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) - c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) - b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) - a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) - d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) - c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) - b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) - a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) - d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) - c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) - b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) - - (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) - (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) - (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) - (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Here begins the merger with the XEmacs API and the md5.el from the URL -;;; package. Courtesy wmperry@spry.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun md5 (object &optional start end) - "Return the MD5 (a secure message digest algorithm) of an object. -OBJECT is either a string or a buffer. -Optional arguments START and END denote buffer positions for computing the -hash of a portion of OBJECT." - (let ((buffer nil)) - (unwind-protect - (save-excursion - (setq buffer (generate-new-buffer " *md5-work*")) - (set-buffer buffer) - (cond - ((bufferp object) - (insert-buffer-substring object start end)) - ((stringp object) - (insert (if (or start end) - (substring object start end) - object))) - (t nil)) - (prog1 - (if (<= (point-max) md5-maximum-internal-length) - (mapconcat - (function (lambda (node) (format "%02x" node))) - (md5-encode (buffer-string)) - "") - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t buffer nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (buffer-substring (point-min) (+ (point-min) 32))) - (kill-buffer buffer))) - (and buffer (kill-buffer buffer) nil)))) - -(provide 'md5) - -;;; md5.el ends here ---------------------------------------------------------- diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/mm.el --- a/lisp/url/mm.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1270 +0,0 @@ -;;; mm.el,v --- Mailcap parsing routines, and MIME handling -;; Author: wmperry -;; Created: 1996/05/28 02:46:51 -;; Version: 1.96 -;; Keywords: mail, news, hypermedia - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Copyright (c) 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Generalized mailcap parsing and access routines -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Data structures -;;; --------------- -;;; The mailcap structure is an assoc list of assoc lists. -;;; 1st assoc list is keyed on the major content-type -;;; 2nd assoc list is keyed on the minor content-type (which can be a regexp) -;;; -;;; Which looks like: -;;; ----------------- -;;; ( -;;; ("application" -;;; ("postscript" . ) -;;; ) -;;; ("text" -;;; ("plain" . ) -;;; ) -;;; ) -;;; -;;; Where is another assoc list of the various information -;;; related to the mailcap RFC. This is keyed on the lowercase -;;; attribute name (viewer, test, etc). This looks like: -;;; (("viewer" . viewerinfo) -;;; ("test" . testinfo) -;;; ("xxxx" . "string") -;;; ) -;;; -;;; Where viewerinfo specifies how the content-type is viewed. Can be -;;; a string, in which case it is run through a shell, with -;;; appropriate parameters, or a symbol, in which case the symbol is -;;; funcall'd, with the buffer as an argument. -;;; -;;; testinfo is a list of strings, or nil. If nil, it means the -;;; viewer specified is always valid. If it is a list of strings, -;;; these are used to determine whether a viewer passes the 'test' or -;;; not. -;;; -;;; The main interface to this code is: -;;; -;;; To set everything up: -;;; -;;; (mm-parse-mailcaps [path]) -;;; -;;; Where PATH is a unix-style path specification (: separated list -;;; of strings). If PATH is nil, the environment variable MAILCAPS -;;; will be consulted. If there is no environment variable, then a -;;; default list of paths is used. -;;; -;;; To retrieve the information: -;;; (mm-mime-info st [nd] [request]) -;;; -;;; Where st and nd are positions in a buffer that contain the -;;; content-type header information of a mail/news/whatever message. -;;; st can optionally be a string that contains the content-type -;;; information. -;;; -;;; Third argument REQUEST specifies what information to return. If -;;; it is nil or the empty string, the viewer (second field of the -;;; mailcap entry) will be returned. If it is a string, then the -;;; mailcap field corresponding to that string will be returned -;;; (print, description, whatever). If a number, then all the -;;; information for this specific viewer is returned. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Variables, etc -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(eval-and-compile - (require 'cl)) - -(defconst mm-version (let ((x "1.96")) - (if (string-match "Revision: \\([^ \t\n]+\\)" x) - (substring x (match-beginning 1) (match-end 1)) - x)) - "Version # of MM package") - -(defvar mm-parse-args-syntax-table - (copy-syntax-table emacs-lisp-mode-syntax-table) - "A syntax table for parsing sgml attributes.") - -(modify-syntax-entry ?' "\"" mm-parse-args-syntax-table) -(modify-syntax-entry ?` "\"" mm-parse-args-syntax-table) -(modify-syntax-entry ?{ "(" mm-parse-args-syntax-table) -(modify-syntax-entry ?} ")" mm-parse-args-syntax-table) - -;;; This is so we can use a consistent method of checking for mule support -;;; Emacs-based mule uses (boundp 'MULE), but XEmacs-based mule uses -;;; (featurep 'mule) - I choose to use the latter. - -(if (boundp 'MULE) - (provide 'mule)) - -(defvar mm-mime-data - '( - ("multipart" . ( - ("alternative". (("viewer" . mm-multipart-viewer) - ("type" . "multipart/alternative"))) - ("mixed" . (("viewer" . mm-multipart-viewer) - ("type" . "multipart/mixed"))) - (".*" . (("viewer" . mm-save-binary-file) - ("type" . "multipart/*"))) - ) - ) - ("application" . ( - ("octet-stream" . (("viewer" . mm-save-binary-file) - ("type" ."application/octet-stream"))) - ("dvi" . (("viewer" . "open %s") - ("type" . "application/dvi") - ("test" . (eq (device-type) 'ns)))) - ("dvi" . (("viewer" . "xdvi %s") - ("test" . (eq (device-type) 'x)) - ("needsx11") - ("type" . "application/dvi"))) - ("dvi" . (("viewer" . "dvitty %s") - ("test" . (not (getenv "DISPLAY"))) - ("type" . "application/dvi"))) - ("emacs-lisp" . (("viewer" . mm-maybe-eval) - ("type" . "application/emacs-lisp"))) -; ("x-tar" . (("viewer" . tar-mode) -; ("test" . (fboundp 'tar-mode)) -; ("type" . "application/x-tar"))) - ("x-tar" . (("viewer" . mm-save-binary-file) - ("type" . "application/x-tar"))) - ("x-latex" . (("viewer" . tex-mode) - ("test" . (fboundp 'tex-mode)) - ("type" . "application/x-latex"))) - ("x-tex" . (("viewer" . tex-mode) - ("test" . (fboundp 'tex-mode)) - ("type" . "application/x-tex"))) - ("latex" . (("viewer" . tex-mode) - ("test" . (fboundp 'tex-mode)) - ("type" . "application/latex"))) - ("tex" . (("viewer" . tex-mode) - ("test" . (fboundp 'tex-mode)) - ("type" . "application/tex"))) - ("texinfo" . (("viewer" . texinfo-mode) - ("test" . (fboundp 'texinfo-mode)) - ("type" . "application/tex"))) - ("zip" . (("viewer" . mm-save-binary-file) - ("type" . "application/zip") - ("copiousoutput"))) - ("pdf" . (("viewer" . "acroread %s") - ("type" . "application/pdf"))) - ("postscript" . (("viewer" . "open %s") - ("type" . "application/postscript") - ("test" . (eq (device-type) 'ns)))) - ("postscript" . (("viewer" . "ghostview %s") - ("type" . "application/postscript") - ("test" . (eq (device-type) 'x)) - ("needsx11"))) - ("postscript" . (("viewer" . "ps2ascii %s") - ("type" . "application/postscript") - ("test" . (not (getenv "DISPLAY"))) - ("copiousoutput"))) - ("x-www-pem-reply" . - (("viewer" . (w3-decode-pgp/pem "pem")) - ("test" . (fboundp 'w3-decode-pgp/pem)) - ("type" . "application/x-www-pem-reply") - )) - ("x-www-pgp-reply" . - (("viewer" . (w3-decode-pgp/pem "pgp")) - ("test" . (fboundp 'w3-decode-pgp/pem)) - ("type" . "application/x-www-pgp-reply"))) - )) - ("audio" . ( - ("x-mpeg" . (("viewer" . "maplay %s") - ("type" . "audio/x-mpeg"))) - (".*" . (("viewer" . mm-play-sound-file) - ("test" . (or (featurep 'nas-sound) - (featurep 'native-sound))) - ("type" . "audio/*"))) - (".*" . (("viewer" . "showaudio") - ("type" . "audio/*"))) - )) - ("message" . ( - ("rfc-*822" . (("viewer" . vm-mode) - ("test" . (fboundp 'vm-mode)) - ("type" . "message/rfc-822"))) - ("rfc-*822" . (("viewer" . w3-mode) - ("test" . (fboundp 'w3-mode)) - ("type" . "message/rfc-822"))) - ("rfc-*822" . (("viewer" . view-mode) - ("test" . (fboundp 'view-mode)) - ("type" . "message/rfc-822"))) - ("rfc-*822" . (("viewer" . fundamental-mode) - ("type" . "message/rfc-822"))) - )) - ("image" . ( - ("x-xwd" . (("viewer" . "xwud -in %s") - ("type" . "image/x-xwd") - ("compose" . "xwd -frame > %s") - ("test" . (eq (device-type) 'x)) - ("needsx11"))) - ("x11-dump" . (("viewer" . "xwud -in %s") - ("type" . "image/x-xwd") - ("compose" . "xwd -frame > %s") - ("test" . (eq (device-type) 'x)) - ("needsx11"))) - ("windowdump" . (("viewer" . "xwud -in %s") - ("type" . "image/x-xwd") - ("compose" . "xwd -frame > %s") - ("test" . (eq (device-type) 'x)) - ("needsx11"))) - (".*" . (("viewer" . "open %s") - ("type" . "image/*") - ("test" . (eq (device-type) 'ns)))) - (".*" . (("viewer" . "xv -perfect %s") - ("type" . "image/*") - ("test" . (eq (device-type) 'x)) - ("needsx11"))) - )) - ("text" . ( - ("plain" . (("viewer" . w3-mode) - ("test" . (fboundp 'w3-mode)) - ("type" . "text/plain"))) - ("plain" . (("viewer" . view-mode) - ("test" . (fboundp 'view-mode)) - ("type" . "text/plain"))) - ("plain" . (("viewer" . fundamental-mode) - ("type" . "text/plain"))) - ("enriched" . (("viewer" . enriched-decode-region) - ("test" . (fboundp - 'enriched-decode-region)) - ("type" . "text/enriched"))) - ("html" . (("viewer" . w3-prepare-buffer) - ("test" . (fboundp 'w3-prepare-buffer)) - ("type" . "text/html"))) - )) - ("video" . ( - ("mpeg" . (("viewer" . "mpeg_play %s") - ("type" . "video/mpeg") - ("test" . (eq (device-type) 'x)) - ("needsx11"))) - )) - ("x-world" . ( - ("x-vrml" . (("viewer" . "webspace -remote %s -URL %u") - ("type" . "x-world/x-vrml") - ("description" - "VRML document"))))) - ("archive" . ( - ("tar" . (("viewer" . tar-mode) - ("type" . "archive/tar") - ("test" . (fboundp 'tar-mode)))) - )) - ) - "*The mailcap structure is an assoc list of assoc lists. -1st assoc list is keyed on the major content-type -2nd assoc list is keyed on the minor content-type (which can be a regexp) - -Which looks like: ------------------ -( - (\"application\" - (\"postscript\" . ) - ) - (\"text\" - (\"plain\" . ) - ) -) - -Where is another assoc list of the various information -related to the mailcap RFC. This is keyed on the lowercase -attribute name (viewer, test, etc). This looks like: -((\"viewer\" . viewerinfo) - (\"test\" . testinfo) - (\"xxxx\" . \"string\") -) - -Where viewerinfo specifies how the content-type is viewed. Can be -a string, in which case it is run through a shell, with -appropriate parameters, or a symbol, in which case the symbol is -funcall'd, with the buffer as an argument. - -testinfo is a list of strings, or nil. If nil, it means the -viewer specified is always valid. If it is a list of strings, -these are used to determine whether a viewer passes the 'test' or -not.") - -(defvar mm-content-transfer-encodings - '(("base64" . base64-decode) - ("7bit" . ignore) - ("8bit" . ignore) - ("binary" . ignore) - ("x-compress" . ("uncompress" "-c")) - ("x-gzip" . ("gzip" "-dc")) - ("compress" . ("uncompress" "-c")) - ("gzip" . ("gzip" "-dc")) - ("x-hqx" . ("mcvert" "-P" "-s" "-S")) - ("quoted-printable" . mm-decode-quoted-printable) - ) - "*An assoc list of content-transfer-encodings and how to decode them.") - -(defvar mm-download-directory nil - "*Where downloaded files should go by default.") - -(defvar mm-temporary-directory "/tmp" - "*Where temporary files go.") - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; A few things from w3 and url, just in case this is used without them -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun mm-generate-unique-filename (&optional fmt) - "Generate a unique filename in mm-temporary-directory" - (if (not fmt) - (let ((base (format "mm-tmp.%d" (user-real-uid))) - (fname "") - (x 0)) - (setq fname (format "%s%d" base x)) - (while (file-exists-p - (expand-file-name fname mm-temporary-directory)) - (setq x (1+ x) - fname (concat base (int-to-string x)))) - (expand-file-name fname mm-temporary-directory)) - (let ((base (concat "mm" (int-to-string (user-real-uid)))) - (fname "") - (x 0)) - (setq fname (format fmt (concat base (int-to-string x)))) - (while (file-exists-p - (expand-file-name fname mm-temporary-directory)) - (setq x (1+ x) - fname (format fmt (concat base (int-to-string x))))) - (expand-file-name fname mm-temporary-directory)))) - -(if (and (fboundp 'copy-tree) - (subrp (symbol-function 'copy-tree))) - (fset 'mm-copy-tree 'copy-tree) - (defun mm-copy-tree (tree) - (if (consp tree) - (cons (mm-copy-tree (car tree)) - (mm-copy-tree (cdr tree))) - (if (vectorp tree) - (let* ((new (copy-sequence tree)) - (i (1- (length new)))) - (while (>= i 0) - (aset new i (mm-copy-tree (aref new i))) - (setq i (1- i))) - new) - tree)))) - -(if (not (fboundp 'w3-save-binary-file)) - (defun mm-save-binary-file () - ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select - ;; a URL that gets saved via this function, read-file-name will pop up a - ;; dialog box for file selection. For some reason which buffer we are in - ;; gets royally screwed (even with save-excursions and the whole nine - ;; yards). SO, we just keep the old buffer name around and away we go. - (let ((old-buff (current-buffer)) - (file (read-file-name "Filename to save as: " - (or mm-download-directory "~/") - (file-name-nondirectory (url-view-url t)) - nil - (file-name-nondirectory (url-view-url t)))) - (require-final-newline nil)) - (set-buffer old-buff) - (if (featurep 'mule) - (let ((mc-flag t)) - (write-region (point-min) (point-max) file nil nil *noconv*)) - (write-region (point-min) (point-max) file)) - (kill-buffer (current-buffer)))) - (fset 'mm-save-binary-file 'w3-save-binary-file)) - -(if (not (fboundp 'w3-maybe-eval)) - (defun mm-maybe-eval () - "Maybe evaluate a buffer of emacs lisp code" - (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ") - (eval-buffer (current-buffer)) - (emacs-lisp-mode))) - (fset 'mm-maybe-eval 'w3-maybe-eval)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The mailcap parser -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-viewer-unescape (format &optional filename url) - (save-excursion - (set-buffer (get-buffer-create " *mm-parse*")) - (erase-buffer) - (insert format) - (goto-char (point-min)) - (while (re-search-forward "%\\(.\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (case escape - (?% (insert "%")) - (?s (insert (or filename "\"\""))) - (?u (insert (or url "\"\"")))))) - (buffer-string))) - -(defun mm-in-assoc (elt list) - ;; Check to see if ELT matches any of the regexps in the car elements of LIST - (let (rslt) - (while (and list (not rslt)) - (and (car (car list)) - (string-match (car (car list)) elt) - (setq rslt (car list))) - (setq list (cdr list))) - rslt)) - -(defun mm-replace-regexp (regexp to-string) - ;; Quiet replace-regexp. - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (replace-match to-string t nil))) - -(defun mm-parse-mailcaps (&optional path) - ;; Parse out all the mailcaps specified in a unix-style path string PATH - (cond - (path nil) - ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) - ((memq system-type '(ms-dos ms-windows windows-nt)) - (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap") - ";"))) - (t (setq path (concat "/etc/mailcap:/usr/etc/mailcap:" - "/usr/local/etc/mailcap:" - (expand-file-name "~/.mailcap"))))) - (let ((fnames (mm-string-to-tokens path - (if (memq system-type - '(ms-dos ms-windows windows-nt)) - ?; - ?:))) fname) - (while fnames - (setq fname (car fnames)) - (if (and (file-exists-p fname) (file-readable-p fname)) - (mm-parse-mailcap (car fnames))) - (setq fnames (cdr fnames))))) - -(defun mm-parse-mailcap (fname) - ;; Parse out the mailcap file specified by FNAME - (let (major ; The major mime type (image/audio/etc) - minor ; The minor mime type (gif, basic, etc) - save-pos ; Misc saved positions used in parsing - viewer ; How to view this mime type - info ; Misc info about this mime type - ) - (save-excursion - (set-buffer (get-buffer-create " *mailcap*")) - (erase-buffer) - (insert-file-contents fname) - (set-syntax-table mm-parse-args-syntax-table) - (mm-replace-regexp "#.*" "") ; Remove all comments - (mm-replace-regexp "\n+" "\n") ; And blank lines - (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces - (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "") - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (delete-region (point) (point-max)) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n") - (setq save-pos (point) - info nil) - (skip-chars-forward "^/;") - (downcase-region save-pos (point)) - (setq major (buffer-substring save-pos (point))) - (skip-chars-forward "/ \t\n") - (setq save-pos (point)) - (skip-chars-forward "^;") - (downcase-region save-pos (point)) - (setq minor - (cond - ((= ?* (or (char-after save-pos) 0)) ".*") - ((= (point) save-pos) ".*") - (t (buffer-substring save-pos (point))))) - (skip-chars-forward "; \t\n") - ;;; Got the major/minor chunks, now for the viewers/etc - ;;; The first item _must_ be a viewer, according to the - ;;; RFC for mailcap files (#1343) - (skip-chars-forward "; \t\n") - (setq save-pos (point)) - (skip-chars-forward "^;\n") - (if (= (or (char-after save-pos) 0) ?') - (setq viewer (progn - (narrow-to-region (1+ save-pos) (point)) - (goto-char (point-min)) - (prog1 - (read (current-buffer)) - (goto-char (point-max)) - (widen)))) - (setq viewer (buffer-substring save-pos (point)))) - (setq save-pos (point)) - (end-of-line) - (setq info (nconc (list (cons "viewer" viewer) - (cons "type" (concat major "/" - (if (string= minor ".*") - "*" minor)))) - (mm-parse-mailcap-extras save-pos (point)))) - (mm-mailcap-entry-passes-test info) - (mm-add-mailcap-entry major minor info))))) - -(defun mm-parse-mailcap-extras (st nd) - ;; Grab all the extra stuff from a mailcap entry - (let ( - name ; From name= - value ; its value - results ; Assoc list of results - name-pos ; Start of XXXX= position - val-pos ; Start of value position - done ; Found end of \'d ;s? - ) - (save-restriction - (narrow-to-region st nd) - (goto-char (point-min)) - (skip-chars-forward " \n\t;") - (while (not (eobp)) - (setq done nil) - (skip-chars-forward " \";\n\t") - (setq name-pos (point)) - (skip-chars-forward "^ \n\t=") - (downcase-region name-pos (point)) - (setq name (buffer-substring name-pos (point))) - (skip-chars-forward " \t\n") - (if (/= (or (char-after (point)) 0) ?=) ; There is no value - (setq value nil) - (skip-chars-forward " \t\n=") - (setq val-pos (point)) - (if (memq (char-after val-pos) '(?\" ?')) - (progn - (setq val-pos (1+ val-pos)) - (condition-case nil - (progn - (forward-sexp 1) - (backward-char 1)) - (error (goto-char (point-max))))) - (while (not done) - (skip-chars-forward "^;") - (if (= (or (char-after (1- (point))) 0) ?\\ ) - (progn - (subst-char-in-region (1- (point)) (point) ?\\ ? ) - (skip-chars-forward ";")) - (setq done t)))) - (setq value (buffer-substring val-pos (point)))) - (setq results (cons (cons name value) results))) - results))) - -(defun mm-string-to-tokens (str &optional delim) - "Return a list of words from the string STR" - (setq delim (or delim ? )) - (let (results y) - (mapcar - (function - (lambda (x) - (cond - ((and (= x delim) y) (setq results (cons y results) y nil)) - ((/= x delim) (setq y (concat y (char-to-string x)))) - (t nil)))) str) - (nreverse (cons y results)))) - -(defun mm-mailcap-entry-passes-test (info) - ;; Return t iff a mailcap entry passes its test clause or no test - ;; clause is present. - (let (status ; Call-process-regions return value - (test (assoc "test" info)); The test clause - ) - (setq status (and test (mm-string-to-tokens (cdr test)))) - (if (and (assoc "needsx11" info) (not (getenv "DISPLAY"))) - (setq status nil) - (cond - ((and (equal (nth 0 status) "test") - (equal (nth 1 status) "-n") - (or (equal (nth 2 status) "$DISPLAY") - (equal (nth 2 status) "\"$DISPLAY\""))) - (setq status (if (getenv "DISPLAY") t nil))) - ((and (equal (nth 0 status) "test") - (equal (nth 1 status) "-z") - (or (equal (nth 2 status) "$DISPLAY") - (equal (nth 2 status) "\"$DISPLAY\""))) - (setq status (if (getenv "DISPLAY") nil t))) - (test nil) - (t nil))) - (and test (listp test) (setcdr test status)))) - -(defun mm-parse-args (st &optional nd nodowncase) - ;; Return an assoc list of attribute/value pairs from an RFC822-type string - (let ( - name ; From name= - value ; its value - results ; Assoc list of results - name-pos ; Start of XXXX= position - val-pos ; Start of value position - ) - (save-excursion - (if (stringp st) - (progn - (set-buffer (get-buffer-create " *mm-temp*")) - (set-syntax-table mm-parse-args-syntax-table) - (erase-buffer) - (insert st) - (setq st (point-min) - nd (point-max))) - (set-syntax-table mm-parse-args-syntax-table)) - (save-restriction - (narrow-to-region st nd) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "; \n\t") - (setq name-pos (point)) - (skip-chars-forward "^ \n\t=;") - (if (not nodowncase) - (downcase-region name-pos (point))) - (setq name (buffer-substring name-pos (point))) - (skip-chars-forward " \t\n") - (if (/= (or (char-after (point)) 0) ?=) ; There is no value - (setq value nil) - (skip-chars-forward " \t\n=") - (setq val-pos (point) - value - (cond - ((or (= (or (char-after val-pos) 0) ?\") - (= (or (char-after val-pos) 0) ?')) - (buffer-substring (1+ val-pos) - (condition-case () - (prog2 - (forward-sexp 1) - (1- (point)) - (skip-chars-forward "\"")) - (error - (skip-chars-forward "^ \t\n") - (point))))) - (t - (buffer-substring val-pos - (progn - (skip-chars-forward "^;") - (skip-chars-backward " \t") - (point))))))) - (setq results (cons (cons name value) results)) - (skip-chars-forward "; \n\t")) - results)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The action routines. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-possible-viewers (major minor) - ;; Return a list of possible viewers from MAJOR for minor type MINOR - (let ((exact '()) - (wildcard '())) - (while major - (cond - ((equal (car (car major)) minor) - (setq exact (cons (cdr (car major)) exact))) - ((string-match (car (car major)) minor) - (setq wildcard (cons (cdr (car major)) wildcard)))) - (setq major (cdr major))) - (nconc (nreverse exact) (nreverse wildcard)))) - -(defun mm-unescape-mime-test (test type-info) - (let ((buff (get-buffer-create " *unescape*")) - save-pos save-chr subst) - (cond - ((symbolp test) test) - ((and (listp test) (symbolp (car test))) test) - ((or (stringp test) - (and (listp test) (stringp (car test)) - (setq test (mapconcat 'identity test " ")))) - (save-excursion - (set-buffer buff) - (erase-buffer) - (insert test) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^%") - (if (/= (- (point) - (progn (skip-chars-backward "\\\\") - (point))) - 0) ; It is an escaped % - (progn - (delete-char 1) - (skip-chars-forward "%.")) - (setq save-pos (point)) - (skip-chars-forward "%") - (setq save-chr (char-after (point))) - (cond - ((null save-chr) nil) - ((= save-chr ?t) - (delete-region save-pos (progn (forward-char 1) (point))) - (insert (or (cdr (assoc "type" type-info)) "\"\""))) - ((= save-chr ?M) - (delete-region save-pos (progn (forward-char 1) (point))) - (insert "\"\"")) - ((= save-chr ?n) - (delete-region save-pos (progn (forward-char 1) (point))) - (insert "\"\"")) - ((= save-chr ?F) - (delete-region save-pos (progn (forward-char 1) (point))) - (insert "\"\"")) - ((= save-chr ?{) - (forward-char 1) - (skip-chars-forward "^}") - (downcase-region (+ 2 save-pos) (point)) - (setq subst (buffer-substring (+ 2 save-pos) (point))) - (delete-region save-pos (1+ (point))) - (insert (or (cdr (assoc subst type-info)) "\"\""))) - (t nil)))) - (buffer-string))) - (t (error "Bad value to mm-unescape-mime-test. %s" test))))) - -(defun mm-viewer-passes-test (viewer-info type-info) - ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its - ;; test clause (if any). - (let* ((test-info (assoc "test" viewer-info)) - (test (cdr test-info)) - (viewer (cdr (assoc "viewer" viewer-info))) - status - parsed-test - ) - (cond - ((not test-info) t) ; No test clause - ((not test) nil) ; Already failed test - ((eq test t) t) ; Already passed test - ((and (symbolp test) ; Lisp function as test - (fboundp test)) - (funcall test type-info)) - ((and (symbolp test) ; Lisp variable as test - (boundp test)) - (symbol-value test)) - ((and (listp test) ; List to be eval'd - (symbolp (car test))) - (eval test)) - (t - (setq test (mm-unescape-mime-test test type-info) - test (list "/bin/sh" nil nil nil "-c" test) - status (apply 'call-process test)) - (= 0 status))))) - -(defun mm-add-mailcap-entry (major minor info) - (let ((old-major (assoc major mm-mime-data))) - (if (null old-major) ; New major area - (setq mm-mime-data - (cons (cons major (list (cons minor info))) - mm-mime-data)) - (let ((cur-minor (assoc minor old-major))) - (cond - ((or (null cur-minor) ; New minor area, or - (assoc "test" info)) ; Has a test, insert at beginning - (setcdr old-major (cons (cons minor info) (cdr old-major)))) - ((and (not (assoc "test" info)); No test info, replace completely - (not (assoc "test" cur-minor))) - (setcdr cur-minor info)) - (t - (setcdr old-major (cons (cons minor info) (cdr old-major))))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The main whabbo -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-viewer-lessp (x y) - ;; Return t iff viewer X is more desirable than viewer Y - (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) ""))) - (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) ""))) - (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) "")))) - (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) ""))))) - (cond - ((and x-lisp (not y-lisp)) - t) - ((and (not y-lisp) x-wild (not y-wild)) - t) - ((and (not x-wild) y-wild) - t) - (t nil)))) - -(defun mm-mime-info (st &optional nd request) - "Get the mime viewer command for HEADERLINE, return nil if none found. -Expects a complete content-type header line as its argument. This can -be simple like text/html, or complex like text/plain; charset=blah; foo=bar - -Third argument REQUEST specifies what information to return. If it is -nil or the empty string, the viewer (second field of the mailcap -entry) will be returned. If it is a string, then the mailcap field -corresponding to that string will be returned (print, description, -whatever). If a number, then all the information for this specific -viewer is returned." - (let ( - major ; Major encoding (text, etc) - minor ; Minor encoding (html, etc) - info ; Other info - save-pos ; Misc. position during parse - major-info ; (assoc major mm-mime-data) - minor-info ; (assoc minor major-info) - test ; current test proc. - viewers ; Possible viewers - passed ; Viewers that passed the test - viewer ; The one and only viewer - ) - (save-excursion - (cond - ((null st) - (set-buffer (get-buffer-create " *mimeparse*")) - (erase-buffer) - (insert "text/plain") - (setq st (point-min))) - ((stringp st) - (set-buffer (get-buffer-create " *mimeparse*")) - (erase-buffer) - (insert st) - (setq st (point-min))) - ((null nd) - (narrow-to-region st (progn (goto-char st) (end-of-line) (point)))) - (t (narrow-to-region st nd))) - (goto-char st) - (skip-chars-forward ": \t\n") - (buffer-enable-undo) - (setq viewer - (catch 'mm-exit - (setq save-pos (point)) - (skip-chars-forward "^/") - (downcase-region save-pos (point)) - (setq major (buffer-substring save-pos (point))) - (if (not (setq major-info (cdr (assoc major mm-mime-data)))) - (throw 'mm-exit nil)) - (skip-chars-forward "/ \t\n") - (setq save-pos (point)) - (skip-chars-forward "^ \t\n;") - (downcase-region save-pos (point)) - (setq minor (buffer-substring save-pos (point))) - (if (not - (setq viewers (mm-possible-viewers major-info minor))) - (throw 'mm-exit nil)) - (skip-chars-forward "; \t") - (if (eolp) - nil ; No qualifiers - (setq save-pos (point)) - (end-of-line) - (setq info (mm-parse-args save-pos (point))) - ) - (while viewers - (if (mm-viewer-passes-test (car viewers) info) - (setq passed (cons (car viewers) passed))) - (setq viewers (cdr viewers))) - (setq passed (sort (nreverse passed) 'mm-viewer-lessp)) - (car passed))) - (if (and (stringp (cdr (assoc "viewer" viewer))) - passed) - (setq viewer (car passed))) - (widen) - (cond - ((and (null viewer) (not (equal major "default"))) - (mm-mime-info "default" nil request)) - ((or (null request) (equal request "")) - (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info)) - ((stringp request) - (if (or (string= request "test") (string= request "viewer")) - (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info))) - (t - ;; MUST make a copy *sigh*, else we modify mm-mime-data - (setq viewer (mm-copy-tree viewer)) - (let ((view (assoc "viewer" viewer)) - (test (assoc "test" viewer))) - (if view (setcdr view (mm-unescape-mime-test (cdr view) info))) - (if test (setcdr test (mm-unescape-mime-test (cdr test) info)))) - viewer))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Experimental MIME-types parsing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar mm-mime-extensions - '( - ("" . "text/plain") - (".abs" . "audio/x-mpeg") - (".aif" . "audio/aiff") - (".aifc" . "audio/aiff") - (".aiff" . "audio/aiff") - (".ano" . "application/x-annotator") - (".au" . "audio/ulaw") - (".avi" . "video/x-msvideo") - (".bcpio" . "application/x-bcpio") - (".bin" . "application/octet-stream") - (".cdf" . "application/x-netcdr") - (".cpio" . "application/x-cpio") - (".csh" . "application/x-csh") - (".dvi" . "application/x-dvi") - (".el" . "application/emacs-lisp") - (".eps" . "application/postscript") - (".etx" . "text/x-setext") - (".exe" . "application/octet-stream") - (".fax" . "image/x-fax") - (".gif" . "image/gif") - (".hdf" . "application/x-hdf") - (".hqx" . "application/mac-binhex40") - (".htm" . "text/html") - (".html" . "text/html") - (".icon" . "image/x-icon") - (".ief" . "image/ief") - (".jpg" . "image/jpeg") - (".macp" . "image/x-macpaint") - (".man" . "application/x-troff-man") - (".me" . "application/x-troff-me") - (".mif" . "application/mif") - (".mov" . "video/quicktime") - (".movie" . "video/x-sgi-movie") - (".mp2" . "audio/x-mpeg") - (".mp2a" . "audio/x-mpeg2") - (".mpa" . "audio/x-mpeg") - (".mpa2" . "audio/x-mpeg2") - (".mpe" . "video/mpeg") - (".mpeg" . "video/mpeg") - (".mpega" . "audio/x-mpeg") - (".mpegv" . "video/mpeg") - (".mpg" . "video/mpeg") - (".mpv" . "video/mpeg") - (".ms" . "application/x-troff-ms") - (".nc" . "application/x-netcdf") - (".nc" . "application/x-netcdf") - (".oda" . "application/oda") - (".pbm" . "image/x-portable-bitmap") - (".pdf" . "application/pdf") - (".pgm" . "image/portable-graymap") - (".pict" . "image/pict") - (".pnm" . "image/x-portable-anymap") - (".ppm" . "image/portable-pixmap") - (".ps" . "application/postscript") - (".qt" . "video/quicktime") - (".ras" . "image/x-raster") - (".rgb" . "image/x-rgb") - (".rtf" . "application/rtf") - (".rtx" . "text/richtext") - (".sh" . "application/x-sh") - (".sit" . "application/x-stuffit") - (".snd" . "audio/basic") - (".src" . "application/x-wais-source") - (".tar" . "archive/tar") - (".tcl" . "application/x-tcl") - (".tcl" . "application/x-tcl") - (".tex" . "application/x-tex") - (".texi" . "application/texinfo") - (".tga" . "image/x-targa") - (".tif" . "image/tiff") - (".tiff" . "image/tiff") - (".tr" . "application/x-troff") - (".troff" . "application/x-troff") - (".tsv" . "text/tab-separated-values") - (".txt" . "text/plain") - (".vbs" . "video/mpeg") - (".vox" . "audio/basic") - (".vrml" . "x-world/x-vrml") - (".wav" . "audio/x-wav") - (".wrl" . "x-world/x-vrml") - (".xbm" . "image/xbm") - (".xpm" . "image/x-pixmap") - (".xwd" . "image/windowdump") - (".zip" . "application/zip") - (".ai" . "application/postscript") - (".jpe" . "image/jpeg") - (".jpeg" . "image/jpeg") - ) - "*An assoc list of file extensions and the MIME content-types they -correspond to.") - -(defun mm-parse-mimetypes (&optional path) - ;; Parse out all the mimetypes specified in a unix-style path string PATH - (cond - (path nil) - ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES"))) - ((memq system-type '(ms-dos ms-windows windows-nt)) - (setq path (mapconcat 'expand-file-name - '("~/mime.typ" "~/etc/mime.typ") ";"))) - (t (setq path (concat (expand-file-name "~/.mime-types") ":" - "/etc/mime-types:/usr/etc/mime-types:" - "/usr/local/etc/mime-types:" - "/usr/local/www/conf/mime-types")))) - (let ((fnames (mm-string-to-tokens path - (if (memq system-type - '(ms-dos ms-windows windows-nt)) - ?; - ?:))) fname) - (while fnames - (setq fname (car fnames)) - (if (and (file-exists-p fname) (file-readable-p fname)) - (mm-parse-mimetype-file (car fnames))) - (setq fnames (cdr fnames))))) - -(defun mm-parse-mimetype-file (fname) - ;; Parse out a mime-types file - (let (type ; The MIME type for this line - extns ; The extensions for this line - save-pos ; Misc. saved buffer positions - ) - (save-excursion - (set-buffer (get-buffer-create " *mime-types*")) - (erase-buffer) - (insert-file-contents fname) - (mm-replace-regexp "#.*" "") - (mm-replace-regexp "\n+" "\n") - (mm-replace-regexp "[ \t]+$" "") - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (delete-region (point) (point-max)) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n") - (setq save-pos (point)) - (skip-chars-forward "^ \t") - (downcase-region save-pos (point)) - (setq type (buffer-substring save-pos (point))) - (while (not (eolp)) - (skip-chars-forward " \t") - (setq save-pos (point)) - (skip-chars-forward "^ \t\n") - (setq extns (cons (buffer-substring save-pos (point)) extns))) - (while extns - (setq mm-mime-extensions - (cons - (cons (if (= (string-to-char (car extns)) ?.) - (car extns) - (concat "." (car extns))) type) mm-mime-extensions) - extns (cdr extns))))))) - -(defun mm-extension-to-mime (extn) - "Return the MIME content type of the file extensions EXTN" - (if (and (stringp extn) - (not (= (string-to-char extn) ?.))) - (setq extn (concat "." extn))) - (cdr (assoc (downcase extn) mm-mime-extensions))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Editing/Composition of body parts -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-compose-type (type) - ;; Compose a body section of MIME-type TYPE. - (let* ((info (mm-mime-info type nil 5)) - (fnam (mm-generate-unique-filename)) - (comp (or (cdr (assoc "compose" info)))) - (ctyp (cdr (assoc "composetyped" info))) - (buff (get-buffer-create " *mimecompose*")) - (typeit (not ctyp)) - (retval "") - (usef nil)) - (setq comp (mm-unescape-mime-test (or comp ctyp) info)) - (while (string-match "\\([^\\\\]\\)%s" comp) - (setq comp (concat (substring comp 0 (match-end 1)) fnam - (substring comp (match-end 0) nil)) - usef t)) - (call-process (or shell-file-name - (getenv "ESHELL") (getenv "SHELL") "/bin/sh") - nil (if usef nil buff) nil "-c" comp) - (setq retval - (concat - (if typeit (concat "Content-type: " type "\r\n\r\n") "") - (if usef - (save-excursion - (set-buffer buff) - (erase-buffer) - (insert-file-contents fnam) - (buffer-string)) - (save-excursion - (set-buffer buff) - (buffer-string))) - "\r\n")) - retval)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Misc. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-type-to-file (type) - "Return the file extension for content-type TYPE" - (rassoc type mm-mime-extensions)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Miscellaneous MIME viewers written in elisp -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-play-sound-file (&optional buff) - "Play a sound file in buffer BUFF (defaults to current buffer)" - (setq buff (or buff (current-buffer))) - (let ((fname (mm-generate-unique-filename "%s.au")) - (synchronous-sounds t)) ; Play synchronously - (if (featurep 'mule) - (write-region (point-min) (point-max) fname nil nil *noconv*) - (write-region (point-min) (point-max) fname)) - (kill-buffer (current-buffer)) - (play-sound-file fname) - (condition-case () - (delete-file fname) - (error nil)))) - -(defun mm-parse-mime-headers (&optional no-delete) - "Return a list of the MIME headers at the top of this buffer. If -optional argument NO-DELETE is non-nil, don't delete the headers." - (let* ((st (point-min)) - (nd (progn - (goto-char (point-min)) - (skip-chars-forward " \t\n") - (if (re-search-forward "^\r*$" nil t) - (1+ (point)) - (point-max)))) - save-pos - status - hname - hvalu - result - ) - (narrow-to-region st nd) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n\r") - (setq save-pos (point)) - (skip-chars-forward "^:\n\r") - (downcase-region save-pos (point)) - (setq hname (buffer-substring save-pos (point))) - (skip-chars-forward ": \t ") - (setq save-pos (point)) - (skip-chars-forward "^\n\r") - (setq hvalu (buffer-substring save-pos (point)) - result (cons (cons hname hvalu) result))) - (or no-delete (delete-region st nd)) - result)) - -(defun mm-find-available-multiparts (separator &optional buf) - "Return a list of mime-headers for the various body parts of a -multipart message in buffer BUF with separator SEPARATOR. -The different multipart specs are put in `mm-temporary-directory'." - (let ((sep (concat "^--" separator "\r*$")) - headers - fname - results) - (save-excursion - (and buf (set-buffer buf)) - (goto-char (point-min)) - (while (re-search-forward sep nil t) - (let ((st (set-marker (make-marker) - (progn - (forward-line 1) - (beginning-of-line) - (point)))) - (nd (set-marker (make-marker) - (if (re-search-forward sep nil t) - (1- (match-beginning 0)) - (point-max))))) - (narrow-to-region st nd) - (goto-char st) - (if (looking-at "^\r*$") - (insert "Content-type: text/plain\n" - "Content-length: " (int-to-string (- nd st)) "\n")) - (setq headers (mm-parse-mime-headers) - fname (mm-generate-unique-filename)) - (let ((x (or (cdr (assoc "content-type" headers)) "text/plain"))) - (if (string-match "name=\"*\\([^ \"]+\\)\"*" x) - (setq fname (expand-file-name - (substring x (match-beginning 1) - (match-end 1)) - mm-temporary-directory)))) - (widen) - (if (assoc "content-transfer-encoding" headers) - (let ((coding (cdr - (assoc "content-transfer-encoding" headers))) - (cmd nil)) - (setq coding (and coding (downcase coding)) - cmd (or (cdr (assoc coding - mm-content-transfer-encodings)) - (read-string - (concat "How shall I decode " coding "? ") - "cat"))) - (if (string= cmd "") (setq cmd "cat")) - (if (stringp cmd) - (shell-command-on-region st nd cmd t) - (funcall cmd st nd)) - (set-marker nd (point)))) - (write-region st nd fname nil 5) - (delete-region st nd) - (setq results (cons - (cons - (cons "mm-filename" fname) headers) results))))) - results)) - -(defun mm-format-multipart-as-html (&optional buf type) - (if buf (set-buffer buf)) - (let* ((boundary (if (string-match - "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)" - type) - (regexp-quote - (substring type (match-beginning 1) (match-end 1))))) - (parts (mm-find-available-multiparts boundary))) - (erase-buffer) - (insert "\n" - " \n" - " Multipart Message\n" - " \n" - " \n" - "

Multipart message encountered

\n" - "

I have encountered a multipart MIME message.\n" - " The following parts have been detected. Please\n" - " select which one you want to view.\n" - "

\n" - " \n" - " \n" - "\n" - "\n"))) - -(defun mm-multipart-viewer () - (mm-format-multipart-as-html - (current-buffer) - (cdr (assoc "content-type" url-current-mime-headers))) - (let ((w3-working-buffer (current-buffer))) - (w3-prepare-buffer))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Transfer encodings we can decrypt automatically -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm-decode-quoted-printable (&optional st nd) - (interactive) - (setq st (or st (point-min)) - nd (or nd (point-max))) - (save-restriction - (narrow-to-region st nd) - (save-excursion - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t) - (replace-match - (char-to-string - (+ - (* 16 (mm-hex-char-to-integer - (char-after (1+ (match-beginning 0))))) - (mm-hex-char-to-integer - (char-after (1- (match-end 0)))))))))))) - -;; Taken from hexl.el. -(defun mm-hex-char-to-integer (character) - "Take a char and return its value as if it was a hex digit." - (if (and (>= character ?0) (<= character ?9)) - (- character ?0) - (let ((ch (logior character 32))) - (if (and (>= ch ?a) (<= ch ?f)) - (- ch (- ?a 10)) - (error (format "Invalid hex digit `%c'." ch)))))) - - -(require 'base64) -(provide 'mm) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/ssl.el --- a/lisp/url/ssl.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,56 +0,0 @@ -;;; ssl.el,v --- ssl functions for emacsen without them builtin -;; Author: wmperry -;; Created: 1996/05/28 01:20:06 -;; Version: 1.2 -;; Keywords: comm - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar ssl-program-name "ssl %s %s" - "*The program to run in a subprocess to open an SSL connection. -This is run through `format' with two strings, the hostname and port # -to connect to.") - -(defun open-ssl-stream (name buffer host service) - "Open a SSL connection for a service to a host. -Returns a subprocess-object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST SERVICE. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or buffer-name) to associate with the process. - Process output goes at end of that buffer, unless you specify - an output stream or filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg SERVICE is name of the service desired, or an integer - specifying a port number to connect to." - (let ((proc (start-process name buffer - "/bin/sh" - "-c" - (format ssl-program-name host - (if (stringp service) - service - (int-to-string service)))))) - (process-kill-without-query proc) - proc)) - -(provide 'ssl) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-cookie.el --- a/lisp/url/url-cookie.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,350 +0,0 @@ -;;; url-cookie.el,v --- Netscape Cookie support -;; Author: wmperry -;; Created: 1996/06/05 14:31:40 -;; Version: 1.9 -;; Keywords: comm, data, processes, hypermedia - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1996 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1996 by William M. Perry (wmperry@spry.com) ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'timezone) -(require 'cl) - -(let ((keywords - '(:name :value :expires :path :domain :test :secure))) - (while keywords - (or (boundp (car keywords)) - (set (car keywords) (car keywords))) - (setq keywords (cdr keywords)))) - -;; See http://home.netscape.com/newsref/std/cookie_spec.html for the -;; 'open standard' defining this crap. -;; -;; A cookie is stored internally as a vector of 7 slots -;; [ 'cookie name value expires path domain secure ] - -(defsubst url-cookie-name (cookie) (aref cookie 1)) -(defsubst url-cookie-value (cookie) (aref cookie 2)) -(defsubst url-cookie-expires (cookie) (aref cookie 3)) -(defsubst url-cookie-path (cookie) (aref cookie 4)) -(defsubst url-cookie-domain (cookie) (aref cookie 5)) -(defsubst url-cookie-secure (cookie) (aref cookie 6)) - -(defsubst url-cookie-set-name (cookie val) (aset cookie 1 val)) -(defsubst url-cookie-set-value (cookie val) (aset cookie 2 val)) -(defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val)) -(defsubst url-cookie-set-path (cookie val) (aset cookie 4 val)) -(defsubst url-cookie-set-domain (cookie val) (aset cookie 5 val)) -(defsubst url-cookie-set-secure (cookie val) (aset cookie 6 val)) -(defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args))) - -(defsubst url-cookie-create (&rest args) - (let ((retval (make-vector 7 nil))) - (aset retval 0 'cookie) - (url-cookie-set-name retval (url-cookie-retrieve-arg :name args)) - (url-cookie-set-value retval (url-cookie-retrieve-arg :value args)) - (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args)) - (url-cookie-set-path retval (url-cookie-retrieve-arg :path args)) - (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args)) - (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args)) - retval)) - -(defvar url-cookie-storage nil "Where cookies are stored.") -(defvar url-cookie-secure-storage nil "Where secure cookies are stored.") -(defvar url-cookie-file nil "*Where cookies are stored on disk.") - -(defun url-cookie-p (obj) - (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie))) - -(defun url-cookie-parse-file (&optional fname) - (setq fname (or fname url-cookie-file)) - (condition-case () - (load fname nil t) - (error (message "Could not load cookie file %s" fname)))) - -(defun url-cookie-clean-up (&optional secure) - (let* ( - (var (if secure 'url-cookie-secure-storage 'url-cookie-storage)) - (val (symbol-value var)) - (cur nil) - (new nil) - (cookies nil) - (cur-cookie nil) - (new-cookies nil) - ) - (while val - (setq cur (car val) - val (cdr val) - new-cookies nil - cookies (cdr cur)) - (while cookies - (setq cur-cookie (car cookies) - cookies (cdr cookies)) - (if (or (not (url-cookie-p cur-cookie)) - (url-cookie-expired-p cur-cookie) - (null (url-cookie-expires cur-cookie))) - nil - (setq new-cookies (cons cur-cookie new-cookies)))) - (if (not new-cookies) - nil - (setcdr cur new-cookies) - (setq new (cons cur new)))) - (set var new))) - -(defun url-cookie-write-file (&optional fname) - (setq fname (or fname url-cookie-file)) - (url-cookie-clean-up) - (url-cookie-clean-up t) - (save-excursion - (set-buffer (get-buffer-create " *cookies*")) - (erase-buffer) - (fundamental-mode) - (insert ";; Emacs-W3 HTTP cookies file\n" - ";; Automatically generated file!!! DO NOT EDIT!!!\n\n" - "(setq url-cookie-storage\n '") - (pp url-cookie-storage (current-buffer)) - (insert ")\n(setq url-cookie-secure-storage\n '") - (pp url-cookie-secure-storage (current-buffer)) - (insert ")\n") - (write-file fname) - (kill-buffer (current-buffer)))) - -(defun url-cookie-store (name value &optional expires domain path secure) - "Stores a netscape-style cookie" - (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage)) - (tmp storage) - (cur nil) - (found-domain nil)) - - ;; First, look for a matching domain - (setq found-domain (assoc domain storage)) - - (if found-domain - ;; Need to either stick the new cookie in existing domain storage - ;; or possibly replace an existing cookie if the names match. - (progn - (setq storage (cdr found-domain) - tmp nil) - (while storage - (setq cur (car storage) - storage (cdr storage)) - (if (and (equal path (url-cookie-path cur)) - (equal name (url-cookie-name cur))) - (progn - (url-cookie-set-expires cur expires) - (url-cookie-set-value cur value) - (setq tmp t)))) - (if (not tmp) - ;; New cookie - (setcdr found-domain (cons - (url-cookie-create :name name - :value value - :expires expires - :domain domain - :path path - :secure secure) - (cdr found-domain))))) - ;; Need to add a new top-level domain - (setq tmp (url-cookie-create :name name - :value value - :expires expires - :domain domain - :path path - :secure secure)) - (cond - (storage - (setcdr storage (cons (list domain tmp) (cdr storage)))) - (secure - (setq url-cookie-secure-storage (list (list domain tmp)))) - (t - (setq url-cookie-storage (list (list domain tmp)))))))) - -(defun url-cookie-expired-p (cookie) - (let* ( - (exp (url-cookie-expires cookie)) - (cur-date (and exp (timezone-parse-date (current-time-string)))) - (exp-date (and exp (timezone-parse-date exp))) - (cur-greg (and cur-date (timezone-absolute-from-gregorian - (string-to-int (aref cur-date 1)) - (string-to-int (aref cur-date 2)) - (string-to-int (aref cur-date 0))))) - (exp-greg (and exp (timezone-absolute-from-gregorian - (string-to-int (aref exp-date 1)) - (string-to-int (aref exp-date 2)) - (string-to-int (aref exp-date 0))))) - (diff-in-days (and exp (- cur-greg exp-greg))) - ) - (cond - ((not exp) nil) ; No expiry == expires at browser quit - ((< diff-in-days 0) nil) ; Expires sometime after today - ((> diff-in-days 0) t) ; Expired before today - (t ; Expires sometime today, check times - (let* ((cur-time (timezone-parse-time (aref cur-date 3))) - (exp-time (timezone-parse-time (aref exp-date 3))) - (cur-norm (+ (* 360 (string-to-int (aref cur-time 2))) - (* 60 (string-to-int (aref cur-time 1))) - (* 1 (string-to-int (aref cur-time 0))))) - (exp-norm (+ (* 360 (string-to-int (aref exp-time 2))) - (* 60 (string-to-int (aref exp-time 1))) - (* 1 (string-to-int (aref exp-time 0)))))) - (> (- cur-norm exp-norm) 1)))))) - -(defun url-cookie-retrieve (host path &optional secure) - "Retrieves all the netscape-style cookies for a specified HOST and PATH" - (let ((storage (if secure - (append url-cookie-secure-storage url-cookie-storage) - url-cookie-storage)) - (case-fold-search t) - (cookies nil) - (cur nil) - (retval nil) - (path-regexp nil)) - (while storage - (setq cur (car storage) - storage (cdr storage) - cookies (cdr cur)) - (if (and (car cur) - (string-match (concat "^.*" (regexp-quote (car cur)) "$") host)) - ;; The domains match - a possible hit! - (while cookies - (setq cur (car cookies) - cookies (cdr cookies) - path-regexp (concat "^" (regexp-quote - (url-cookie-path cur)))) - (if (and (string-match path-regexp path) - (not (url-cookie-expired-p cur))) - (setq retval (cons cur retval)))))) - retval)) - -(defun url-cookie-generate-header-lines (host path secure) - (let* ((cookies (url-cookie-retrieve host path secure)) - (retval nil) - (cur nil) - (chunk nil)) - ;; Have to sort this for sending most specific cookies first - (setq cookies (and cookies - (sort cookies - (function - (lambda (x y) - (> (length (url-cookie-path x)) - (length (url-cookie-path y)))))))) - (while cookies - (setq cur (car cookies) - cookies (cdr cookies) - chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur)) - retval (if (< 80 (+ (length retval) (length chunk) 4)) - (concat retval "\r\nCookie: " chunk) - (if retval - (concat retval "; " chunk) - (concat "Cookie: " chunk))))) - (if retval - (concat retval "\r\n") - ""))) - -(defvar url-cookie-two-dot-domains - (concat "\\.\\(" - (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int") - "\\|") - "\\)$") - "A regular expression of top-level domains that only require two matching -'.'s in the domain name in order to set a cookie.") - -(defun url-cookie-host-can-set-p (host domain) - (let ((numdots 0) - (tmp domain) - (last nil) - (case-fold-search t) - (mindots 3)) - (while (setq last (string-match "\\." host last)) - (setq numdots (1+ numdots) - last (1+ last))) - (if (string-match url-cookie-two-dot-domains domain) - (setq mindots 2)) - (cond - ((string= host domain) ; Apparently netscape lets you do this - t) - ((< numdots mindots) ; Not enough dots in domain name! - nil) - (t - (string-match (concat (regexp-quote domain) "$") host))))) - -(defun url-header-comparison (x y) - (string= (downcase x) (downcase y))) - -(defun url-cookie-handle-set-cookie (str) - (let* ((args (mm-parse-args str nil t)) ; Don't downcase names - (case-fold-search t) - (secure (and (assoc* "secure" args :test 'url-header-comparison) t)) - (domain (or (cdr-safe (assoc* "domain" args :test - 'url-header-comparison)) - url-current-server)) - (expires (cdr-safe (assoc* "expires" args :test - 'url-header-comparison))) - (path (or (cdr-safe (assoc* "path" args :test - 'url-header-comparison)) - (file-name-directory url-current-file))) - (rest nil)) - (while args - (if (not (member (downcase (car (car args))) - '("secure" "domain" "expires" "path"))) - (setq rest (cons (car args) rest))) - (setq args (cdr args))) - - ;; Sometimes we get dates that the timezone package cannot handle very - ;; gracefully - take care of this here, instead of in url-cookie-expired-p - ;; to speed things up. - (if (and expires - (string-match - (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +" - "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$") - expires)) - (setq expires (concat (url-match expires 1) " " - (url-match expires 2) " " - (url-match expires 3) " " - (url-match expires 4) " [" - (url-match expires 5) "]"))) - (cond - ((and (listp url-privacy-level) (memq 'cookies url-privacy-level)) - ;; user never wants cookies - nil) - ((and url-cookie-confirmation - (not (funcall url-confirmation-func - (format "Allow %s to set a cookie? " - url-current-server)))) - ;; user wants to be asked, and declined. - nil) - ((url-cookie-host-can-set-p url-current-server domain) - ;; Cookie is accepted by the user, and passes our security checks - (while rest - (url-cookie-store (car (car rest)) (cdr (car rest)) - expires domain path secure) - (setq rest (cdr rest)))) - (t - (url-warn 'url (format - (concat "%s tried to set a cookie for domain %s\n" - "Permission denied - cookie rejected.\n" - "Set-Cookie: %s") - url-current-server domain str)))))) - -(provide 'url-cookie) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-file.el --- a/lisp/url/url-file.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,313 +0,0 @@ -;;; url-file.el,v --- File retrieval code -;; Author: wmperry -;; Created: 1996/05/28 02:46:51 -;; Version: 1.12 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) - -(defun url-insert-possibly-compressed-file (fname &rest args) - ;; Insert a file into a buffer, checking for compressed versions. - (let ((compressed nil) - ;; - ;; F*** *U** **C* ***K!!! - ;; We cannot just use insert-file-contents-literally here, because - ;; then we would lose big time with ange-ftp. *sigh* - (crypt-encoding-alist nil) - (jka-compr-compression-info-list nil) - (jam-zcat-filename-list nil) - (file-coding-system-for-read - (if (featurep 'mule) - *noconv*))) - (setq compressed - (cond - ((file-exists-p fname) nil) - ((file-exists-p (concat fname ".Z")) - (setq fname (concat fname ".Z"))) - ((file-exists-p (concat fname ".gz")) - (setq fname (concat fname ".gz"))) - ((file-exists-p (concat fname ".z")) - (setq fname (concat fname ".z"))) - (t - (error "File not found %s" fname)))) - (if (or (not compressed) url-inhibit-uncompression) - (apply 'insert-file-contents fname args) - (let* ((extn (url-file-extension fname)) - (code (cdr-safe (assoc extn url-uncompressor-alist))) - (decoder (cdr-safe (assoc code mm-content-transfer-encodings)))) - (cond - ((null decoder) - (apply 'insert-file-contents fname args)) - ((stringp decoder) - (apply 'insert-file-contents fname args) - (message "Decoding...") - (call-process-region (point-min) (point-max) decoder t t nil) - (message "Decoding... done.")) - ((listp decoder) - (apply 'call-process-region (point-min) (point-max) - (car decoder) t t t (cdr decoder))) - ((and (symbolp decoder) (fboundp decoder)) - (apply 'insert-file-contents fname args) - (message "Decoding...") - (funcall decoder (point-min) (point-max)) - (message "Decoding... done.")) - (t - (error "Malformed entry for %s in `mm-content-transfer-encodings'" - code)))))) - (set-buffer-modified-p nil)) - -(defun url-format-directory (dir) - ;; Format the files in DIR into hypertext - (let ((files (directory-files dir nil)) file - div attr mod-time size typ title) - (if (and url-directory-index-file - (file-exists-p (expand-file-name url-directory-index-file dir)) - (file-readable-p (expand-file-name url-directory-index-file dir))) - (save-excursion - (set-buffer url-working-buffer) - (erase-buffer) - (insert-file-contents-literally - (expand-file-name url-directory-index-file dir))) - (save-excursion - (if (string-match "/\\([^/]+\\)/$" dir) - (setq title (concat ".../" (url-match dir 1) "/")) - (setq title "/")) - (setq div (1- (length files))) - (set-buffer url-working-buffer) - (erase-buffer) - (insert "\n" - " \n" - " " title "\n" - " \n" - " \n" - "
\n" - "

Index of " title "

\n" - (if url-forms-based-ftp - "
\n" - "") - " 
\n"
-		"       Name                     Last modified                Size\n
" - "
\n 
\n")
-	(while files
-	  (url-lazy-message "Building directory list... (%d%%)"
-			    (/ (* 100 (- div (length files))) div))
-	  (setq file (expand-file-name (car files) dir)
-		attr (file-attributes file)
-		file (car files)
-		mod-time (nth 5 attr)
-		size (nth 7 attr)
-		typ (or (mm-extension-to-mime (url-file-extension file)) ""))
-	  (setq file (url-hexify-string file))
-	  (if (equal '(0 0) mod-time) ; Set to null if unknown or
-	      (setq mod-time "Unknown                 ")
-	    (setq mod-time (current-time-string mod-time)))
-	  (if (or (equal size 0) (equal size -1) (null size))
-	      (setq size "   -")
-	    (setq size
-		  (cond
-		   ((< size 1024) (concat "   " "1K"))
-		   ((< size 1048576) (concat "   "
-					     (int-to-string
-					      (max 1 (/ size 1024))) "K"))
-		   (t
-		    (let* ((megs (max 1 (/ size 1048576)))
-			   (kilo (/ (- size (* megs 1048576)) 1024)))
-		      (concat "   "  (int-to-string megs)
-			      (if (> kilo 0)
-				  (concat "." (int-to-string kilo))
-				"") "M"))))))
-	  (cond
-	   ((or (equal "." (car files))
-		(equal "/.." (car files)))
-	    nil)
-	   ((equal ".." (car files))
-	    (if (not (= ?/ (aref file (1- (length file)))))
-		(setq file (concat file "/")))
-	    (insert (if url-forms-based-ftp "   " "")
-		    "[DIR] Parent directory\n"))
-	   ((stringp (nth 0 attr))	; Symbolic link handling
-	    (insert (if url-forms-based-ftp "   " "")
-		    "[LNK] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((nth 0 attr)		; Directory handling
-	    (insert (if url-forms-based-ftp "   " "")
-		    "[DIR] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "image" typ)
-	    (insert (if url-forms-based-ftp
-			(concat "")
-		      "")
-		    "[IMG] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "application" typ)
-	    (insert (if url-forms-based-ftp
-			(concat "")
-		      "")
-		    "[APP] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "text" typ)
-	    (insert (if url-forms-based-ftp
-			(concat "")
-		      "")
-		    "[TXT] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   (t
-	    (insert (if url-forms-based-ftp
-			(concat "")
-		      "")
-		    "[UNK] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n")))
-	  (setq files (cdr files)))
-	(insert "
\n" - (if url-forms-based-ftp - (concat " \n" - "
\n") - "") - "
\n" - " \n" - "\n" - "\n"))))) - -(defun url-host-is-local-p (host) - "Return t iff HOST references our local machine." - (let ((case-fold-search t)) - (or - (null host) - (string= "" host) - (equal (downcase host) (downcase (system-name))) - (and (string-match "^localhost$" host) t) - (and (not (string-match (regexp-quote ".") host)) - (equal (downcase host) (if (string-match (regexp-quote ".") - (system-name)) - (substring (system-name) 0 - (match-beginning 0)) - (system-name))))))) - -(defun url-file (url) - ;; Find a file - (let* ((urlobj (url-generic-parse-url url)) - (user (url-user urlobj)) - (site (url-host urlobj)) - (file (url-unhex-string (url-filename urlobj))) - (dest (url-target urlobj)) - (filename (if (or user (not (url-host-is-local-p site))) - (concat "/" (or user "anonymous") "@" site ":" file) - file))) - - (if (and file (url-host-is-local-p site) - (memq system-type '(ms-windows ms-dos windows-nt os2))) - (let ((x (1- (length file))) - (y 0)) - (while (<= y x) - (if (= (aref file y) ?\\ ) - (aset file y ?/)) - (setq y (1+ y))))) - - (url-clear-tmp-buffer) - (cond - ((file-directory-p filename) - (if url-use-hypertext-dired - (progn - (if (string-match "/$" filename) - nil - (setq filename (concat filename "/"))) - (if (string-match "/$" file) - nil - (setq file (concat file "/"))) - (url-set-filename urlobj file) - (url-format-directory filename)) - (progn - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (find-file filename)))) - ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk)) - (cond - ((file-exists-p filename) nil) - ((file-exists-p (concat filename ".Z")) - (setq filename (concat filename ".Z"))) - ((file-exists-p (concat filename ".gz")) - (setq filename (concat filename ".gz"))) - ((file-exists-p (concat filename ".z")) - (setq filename (concat filename ".z"))) - (t - (error "File not found %s" filename))) - (cond - ((url-host-is-local-p site) - (copy-file - filename - (read-file-name "Save to: " nil (url-basepath filename t)) t)) - ((featurep 'ange-ftp) - (ange-ftp-copy-file-internal - filename - (expand-file-name - (read-file-name "Save to: " nil (url-basepath filename t))) t - nil t nil t)) - ((or (featurep 'efs) (featurep 'efs-auto)) - (let ((new (expand-file-name - (read-file-name "Save to: " nil - (url-basepath filename t))))) - (efs-copy-file-internal filename (efs-ftp-path filename) - new (efs-ftp-path new) - t nil 0 nil 0 nil))) - (t (copy-file - filename - (read-file-name "Save to: " nil (url-basepath filename t)) t))) - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer))) - (t - (let ((viewer (mm-mime-info - (mm-extension-to-mime (url-file-extension file)))) - (errobj nil)) - (if (or url-source ; Need it in a buffer - (and (symbolp viewer) - (not (eq viewer 'w3-default-local-file))) - (stringp viewer)) - (condition-case errobj - (url-insert-possibly-compressed-file filename t) - (error - (url-save-error errobj) - (url-retrieve (concat "www://error/nofile/" file)))))))) - (setq url-current-type (if site "ftp" "file") - url-current-object urlobj - url-find-this-link dest - url-current-user user - url-current-server site - url-current-mime-type (mm-extension-to-mime - (url-file-extension file)) - url-current-file file))) - -(fset 'url-ftp 'url-file) - -(provide 'url-file) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-gopher.el --- a/lisp/url/url-gopher.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,476 +0,0 @@ -;;; url-gopher.el,v --- Gopher Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1995/12/02 16:46:12 -;; Version: 1.5 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) - -(defun url-grok-gopher-href (url) - "Return a list of attributes from a gopher url. List is of the -type: host port selector-string MIME-type extra-info" - (let (host ; host name - port ; Port # - selector ; String to send to gopher host - type ; MIME type - extra ; Extra information - x ; Temporary storage for host/port - y ; Temporary storage for selector - ylen - ) - (or (string-match "gopher:/*\\([^/]+\\)\\(/*\\)" url) - (error "Can't understand url %s" url)) - (setq x (url-match url 1) ; The host (and possible port #) - ylen (- (length url) (match-end 2)) - y (if (= ylen 0) ; The selector (and possible type) - "" - (url-unhex-string (substring url (- ylen))))) - - ;First take care of the host/port/gopher+ information from the url - ;A + after the port # (host:70+) specifies a gopher+ link - ;A ? after the port # (host:70?) specifies a gopher+ ask block - (if (string-match "^\\([^:]+\\):\\([0-9]+\\)\\([?+]*\\)" x) - (setq host (url-match x 1) - port (url-match x 2) - extra (url-match x 3)) - (setq host x - port "70" - extra nil)) - (cond - ((equal extra "") (setq extra nil)) - ((equal extra "?") (setq extra 'ask-block)) - ((equal extra "+") (setq extra 'gopher+))) - - ; Next, get the type/get rid of the Mosaic double-typing. Argh. - (setq x (string-to-char y) ; Get gopher type - selector (if (or url-use-hypertext-gopher - (< 3 (length y))) - y ; Get the selector string - (substring y 1 nil)) - type (cdr (assoc x url-gopher-to-mime))) - (list host port (or selector "") type extra))) - - -(defun url-convert-ask-to-form (ask) - ;; Convert a Gopher+ ASK block into a form. Returns a string to be - ;; inserted into a buffer to create the form." - (let ((form (concat "
\n" - "
    \n")) - (type "") - (x 0) - (parms "")) - (while (string-match "^\\([^:]+\\): +\\(.*\\)" ask) - (setq parms (url-match ask 2) - type (url-strip-leading-spaces (downcase (url-match ask 1))) - x (1+ x) - ask (substring ask (if (= (length ask) (match-end 0)) - (match-end 0) (1+ (match-end 0))) nil)) - (cond - ((string= "note" type) (setq form (concat form parms))) - ((or (string= "ask" type) - (string= "askf" type) - (string= "choosef" type)) - (setq parms (url-string-to-tokens parms ?\t) - form (format "%s\n
  • %s" - form (or (nth 0 parms) "Text:") - x (or (nth 1 parms) "")))) - ((string= "askp" type) - (setq parms (mapcar 'car (nreverse (url-split parms "\t"))) - form (format - "%s\n
  • %s" - form ; Earlier string - (or (nth 0 parms) "Password:") ; Prompt - x ; Name - (or (nth 1 parms) "") ; Default value - ))) - ((string= "askl" type) - (setq parms (url-string-to-tokens parms ?\t) - form (format "%s\n
  • %s" - form ; Earlier string - (or (nth 0 parms) "") ; Prompt string - x ; Name - (or (nth 1 parms) "") ; Default value - ))) - ((or (string= "select" type) - (string= "choose" type)) - (setq parms (url-string-to-tokens parms ?\t) - form (format "%s\n
  • %s"))))) - (concat form "\n
"))) - -(defun url-grok-gopher-line () - "Return a list of link attributes from a gopher string. Order is: -title, type, selector string, server, port, gopher-plus?" - (let (type selector server port gopher+ st nd) - (beginning-of-line) - (setq st (point)) - (end-of-line) - (setq nd (point)) - (save-excursion - (mapcar (function - (lambda (var) - (goto-char st) - (skip-chars-forward "^\t\n" nd) - (set-variable var (buffer-substring st (point))) - (setq st (min (point-max) (1+ (point)))))) - '(type selector server port)) - (setq gopher+ (and (/= (1- st) nd) (buffer-substring st nd))) - (list type (concat (substring type 0 1) selector) server port gopher+)))) - -(defun url-format-gopher-link (gophobj) - ;; Insert a gopher link as an tag - (let ((title (nth 0 gophobj)) - (ref (nth 1 gophobj)) - (type (if (> (length (nth 0 gophobj)) 0) - (substring (nth 0 gophobj) 0 1) "")) - (serv (nth 2 gophobj)) - (port (nth 3 gophobj)) - (plus (nth 4 gophobj)) - (desc nil)) - (if (and (equal type "") - (> (length title) 0)) - (setq type (substring title 0 1))) - (setq title (and title (substring title 1 nil)) - title (mapconcat - (function - (lambda (x) - (cond - ((= x ?&) "&") - ((= x ?<) "<"); - ((= x ?>) ">"); - (t (char-to-string x))))) title "") - desc (or (cdr (assoc type url-gopher-labels)) "(UNK)")) - (cond - ((null ref) "") - ((equal type "8") - (format "
  • %s %s\n" - desc serv port title)) - ((equal type "T") - (format "
  • %s %s\n" - desc serv port title)) - (t (format "
  • %s %s\n" - desc type serv (concat port plus) - (url-hexify-string ref) title))))) - -(defun url-gopher-clean-text (&optional buffer) - "Decode text transmitted by gopher. -0. Delete status line. -1. Delete `^M' at end of line. -2. Delete `.' at end of buffer (end of text mark). -3. Delete `.' at beginning of line. (does gopher want this?)" - (set-buffer (or buffer url-working-buffer)) - ;; Insert newline at end of buffer. - (goto-char (point-max)) - (if (not (bolp)) - (insert "\n")) - ;; Delete `^M' at end of line. - (goto-char (point-min)) - (while (re-search-forward "\r[^\n]*$" nil t) - (replace-match "")) -; (goto-char (point-min)) -; (while (not (eobp)) -; (end-of-line) -; (if (= (preceding-char) ?\r) -; (delete-char -1)) -; (forward-line 1) -; ) - ;; Delete `.' at end of buffer (end of text mark). - (goto-char (point-max)) - (forward-line -1) ;(beginning-of-line) - (while (looking-at "^\\.$") - (delete-region (point) (progn (forward-line 1) (point))) - (forward-line -1)) - ;; Replace `..' at beginning of line with `.'. - (goto-char (point-min)) - ;; (replace-regexp "^\\.\\." ".") - (while (search-forward "\n.." nil t) - (delete-char -1)) - ) - -(defun url-parse-gopher (&optional buffer) - (save-excursion - (set-buffer (or buffer url-working-buffer)) - (url-replace-regexp "^\r*$\n" "") - (url-replace-regexp "^\\.\r*$\n" "") - (url-gopher-clean-text (current-buffer)) - (goto-char (point-max)) - (skip-chars-backward "\n\r\t ") - (delete-region (point-max) (point)) - (insert "\n") - (goto-char (point-min)) - (skip-chars-forward " \t\n") - (delete-region (point-min) (point)) - (let* ((len (count-lines (point-min) (point-max))) - (objs nil) - (i 0)) - (while (not (eobp)) - (setq objs (cons (url-grok-gopher-line) objs) - i (1+ i)) - (url-lazy-message "Converting gopher listing... %d/%d (%d%%)" - i len (url-percentage i len)) - - (forward-line 1)) - (setq objs (nreverse objs)) - (erase-buffer) - (insert "" - (cond - ((or (string= "" url-current-file) - (string= "1/" url-current-file) - (string= "1" url-current-file)) - (concat "Gopher root at " url-current-server)) - ((string-match (format "^[%s]+/" url-gopher-types) - url-current-file) - (substring url-current-file 2 nil)) - (t url-current-file)) - "
      " - (mapconcat 'url-format-gopher-link objs "") - "
    ")))) - -(defun url-gopher-retrieve (host port selector &optional wait-for) - ;; Fetch a gopher object and don't mess with it at all - (let ((proc (url-open-stream "*gopher*" url-working-buffer - host (if (stringp port) (string-to-int port) - port))) - (len nil) - (parsed nil)) - (url-clear-tmp-buffer) - (setq url-current-file selector - url-current-port port - url-current-server host - url-current-type "gopher") - (if (> (length selector) 0) - (setq selector (substring selector 1 nil))) - (if (stringp proc) - (message "%s" proc) - (save-excursion - (process-send-string proc (concat selector "\r\n")) - (while (and (or (not wait-for) - (progn - (goto-char (point-min)) - (not (re-search-forward wait-for nil t)))) - (memq (url-process-status proc) '(run open))) - (if (not parsed) - (cond - ((and (eq ?+ (char-after 1)) - (memq (char-after 2) - (list ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))) - (setq parsed (copy-marker 2) - len (read parsed)) - (delete-region (point-min) parsed)) - ((and (eq ?+ (char-after 1)) - (eq ?- (char-after 2))) - (setq len nil - parsed t) - (goto-char (point-min)) - (delete-region (point-min) (progn - (end-of-line) - (point)))) - ((and (eq ?- (char-after 1)) - (eq ?- (char-after 2))) - (setq parsed t - len nil) - (goto-char (point-min)) - (delete-region (point-min) (progn - (end-of-line) - (point)))))) - (if len (url-lazy-message "Read %d of %d bytes (%d%%)" (point-max) - len - (url-percentage (point-max) len)) - (url-lazy-message "Read %d bytes." (point-max))) - (url-accept-process-output proc)) - (condition-case () - (url-kill-process proc) - (error nil)) - (url-replace-regexp "\n*Connection closed.*\n*" "") - (url-replace-regexp "\n*Process .*gopher.*\n*" "") - (while (looking-at "\r") (delete-char 1)))))) - -(defun url-do-gopher-cso-search (descr) - ;; Do a gopher CSO search and return a plaintext document - (let ((host (nth 0 descr)) - (port (nth 1 descr)) - (file (nth 2 descr)) - search-type search-term) - (string-match "search-by=\\([^&]+\\)" file) - (setq search-type (url-match file 1)) - (string-match "search-term=\\([^&]+\\)" file) - (setq search-term (url-match file 1)) - (url-gopher-retrieve host port (format "2query %s=%s" - search-type search-term) "^[2-9]") - (goto-char (point-min)) - (url-replace-regexp "^-[0-9][0-9][0-9]:[0-9]*:" "") - (url-replace-regexp "^[^15][0-9][0-9]:.*" "") - (url-replace-regexp "^[15][0-9][0-9]:\\(.*\\)" "

    \\1

     
    ")
-    (goto-char (point-min))
-    (insert "Results of CSO search\n"
-	    "
    " search-type " = " search-term "
    \n")
-    (goto-char (point-max))
-    (insert "
    "))) - -(defun url-do-gopher (descr) - ;; Fetch a gopher object - (let ((host (nth 0 descr)) - (port (nth 1 descr)) - (file (nth 2 descr)) - (type (nth 3 descr)) - (extr (nth 4 descr)) - parse-gopher) - (cond - ((and ; Gopher CSO search - (equal type "www/gopher-cso-search") - (string-match "search-by=" file)) ; With a search term in it - (url-do-gopher-cso-search descr) - (setq type "text/html")) - ((equal type "www/gopher-cso-search") ; Blank CSO search - (url-clear-tmp-buffer) - (insert "\n" - " \n" - " CSO Search\n" - " \n" - " \n" - "
    \n" - "

    This is a CSO search

    \n" - "
    \n" - "
    \n" - "
      \n" - "
    • Search by: \n" - "
    • Search for: \n" - "
    • \n" - "
    \n" - "
    \n" - "
    \n" - " \n" - "\n" - "\n") - (setq type "text/html" - parse-gopher t)) - ((and - (equal type "www/gopher-search") ; Ack! Mosaic-style search href - (string-match "\t" file)) ; and its got a search term in it! - (url-gopher-retrieve host port file) - (setq type "www/gopher" - parse-gopher t)) - ((and - (equal type "www/gopher-search") ; Ack! Mosaic-style search href - (string-match "\\?" file)) ; and its got a search term in it! - (setq file (concat (substring file 0 (match-beginning 0)) "\t" - (substring file (match-end 0) nil))) - (url-gopher-retrieve host port file) - (setq type "www/gopher" - parse-gopher t)) - ((equal type "www/gopher-search") ; Ack! Mosaic-style search href - (setq type "text/html" - parse-gopher t) - (url-clear-tmp-buffer) - (insert "\n" - " \n" - " Gopher Server\n" - " \n" - " \n" - "
    \n" - "

    Searchable Gopher Index

    \n" - "
    \n" - "

    \n" - " Enter the search keywords below\n" - "

    " - "
    \n" - " \n" - "
    \n" - "
    \n" - "
    \n" - " \n" - "\n" - "\n")) - ((null extr) ; Normal Gopher link - (url-gopher-retrieve host port file) - (setq parse-gopher t)) - ((eq extr 'gopher+) ; A gopher+ link - (url-gopher-retrieve host port (concat file "\t+")) - (setq parse-gopher t)) - ((eq extr 'ask-block) ; A gopher+ interactive query - (url-gopher-retrieve host port (concat file "\t!")) ; Fetch the info - (goto-char (point-min)) - (cond - ((re-search-forward "^\\+ASK:[ \t\r]*" nil t) ; There is an ASK - (let ((x (buffer-substring (1+ (point)) - (or (re-search-forward "^\\+[^:]+:" nil t) - (point-max))))) - (erase-buffer) - (insert (url-convert-ask-to-form x)) - (setq type "text/html" parse-gopher t))) - (t (setq parse-gopher t))))) - (if (or (equal type "www/gopher") - (equal type "text/plain") - (equal file "") - (equal type "text/html")) - (url-gopher-clean-text)) - (if (and parse-gopher (or (equal type "www/gopher") - (equal file ""))) - (progn - (url-parse-gopher) - (setq type "text/html" - url-current-mime-viewer (mm-mime-info type nil 5)))) - (setq url-current-mime-type (or type "text/plain") - url-current-mime-viewer (mm-mime-info type nil 5) - url-current-file file - url-current-port port - url-current-server host - url-current-type "gopher"))) - -(defun url-gopher (url) - ;; Handle gopher URLs - (let ((descr (url-grok-gopher-href url))) - (cond - ((or (not (member (nth 1 descr) url-bad-port-list)) - (funcall - url-confirmation-func - (format "Warning! Trying to connect to port %s - continue? " - (nth 1 descr)))) - (if url-use-hypertext-gopher - (url-do-gopher descr) - (gopher-dispatch-object (vector (if (= 0 - (string-to-char (nth 2 descr))) - ?1 - (string-to-char (nth 2 descr))) - (nth 2 descr) (nth 2 descr) - (nth 0 descr) - (string-to-int (nth 1 descr))) - (current-buffer)))) - (t - (ding) - (url-warn 'security "Aborting connection to bad port..."))))) - -(provide 'url-gopher) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-hash.el --- a/lisp/url/url-hash.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,114 +0,0 @@ -;;; url-hash.el,v --- Hashtable functions -;; Author: wmperry -;; Created: 1995/11/17 16:43:12 -;; Version: 1.3 -;; Keywords: lisp - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Hash tables -(cond - ((and (fboundp 'maphash) (subrp (symbol-function 'maphash))) - ;; Builtins! - (defun url-puthash (key val table) - (let ((sym (if (stringp key) (intern key) key))) - (puthash sym val table))) - - (defun url-gethash (key table &optional default) - (let ((sym (if (stringp key) (intern-soft key) key))) - (if (not sym) - default - (gethash sym table)))) - - (mapcar (function - (lambda (sym) - (let ((new-sym (intern (format "url-%s" sym)))) - (defalias new-sym sym)))) - '(make-hashtable - make-key-weak-hashtable - make-value-weak-hashtable - make-weak-hashtable - hashtablep - clrhash - maphash - copy-hashtable))) - (t - (defconst url-hashtable-primes - '(13 29 37 47 59 71 89 107 131 163 197 239 293 353 431 521 631 761 919 - 1103 1327 1597 1931 2333 2801 3371 4049 4861 5839 7013 8419 10103 - 12143 14591 17519 21023 25229 30293 36353 43627 52361 62851 75431 - 90523 108631 130363 156437 187751 225307 270371 324449 389357 467237 - 560689 672827 807403 968897 1162687 1395263 1674319 2009191 2411033 - 2893249) - "A list of some good prime #s to use as sizes for hashtables.") - - (defun url-make-hashtable (size) - "Make a hashtable of initial size SIZE" - (if (not size) (setq size 37)) - (if (not (memq size url-hashtable-primes)) - ;; Find a suitable prime # to use as the hashtable size - (let ((primes url-hashtable-primes)) - (while (<= (car primes) size) - (setq primes (cdr primes))) - (setq size (car primes)))) - (make-vector (or size 2893249) 0)) - - (fset 'url-make-key-weak-hashtable 'url-make-hashtable) - (fset 'url-make-value-weak-hashtable 'url-make-hashtable) - (fset 'url-make-weak-hashtable 'url-make-hashtable) - - (defun url-hashtablep (obj) - "Return t if OBJ is a hashtable, else nil." - (vectorp obj)) - - (defun url-puthash (key val table) - "Hash KEY to VAL in TABLE." - (let ((sym (intern (if (stringp key) key (prin1-to-string key)) table))) - (put sym 'val val) - (put sym 'key key))) - - (defun url-gethash (key table &optional default) - "Find hash value for KEY in TABLE. -If there is no corresponding value, return DEFAULT (defaults to nil)." - (let ((sym (intern-soft (if (stringp key) key (prin1-to-string key)) table))) - (and sym (get sym 'val)))) - - (put 'url-gethash 'sysdep-defined-this t) - - (defun url-clrhash (table) - "Flush TABLE" - (fillarray table 0)) - - (defun url-maphash (function table) - "Map FUNCTION over entries in TABLE, calling it with two args, -each key and value in the table." - (mapatoms - (function - (lambda (sym) - (funcall function (get sym 'key) (get sym 'val)))) table)) - - (defun url-copy-hashtable (old-table) - "Make a new hashtable which contains the same keys and values -as the given table. The keys and values will not themselves be copied." - (copy-sequence old-table)) - )) - -(provide 'url-hash) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-http.el --- a/lisp/url/url-http.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,634 +0,0 @@ -;;; url-http.el,v --- HTTP Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1996/05/29 15:07:01 -;; Version: 1.19 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) -(require 'url-cookie) -(require 'timezone) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for HTTP/1.0 MIME messages -;;; ---------------------------------- -;;; These functions are the guts of the HTTP/0.9 and HTTP/1.0 transfer -;;; protocol, handling access authorization, format negotiation, the -;;; whole nine yards. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-parse-viewer-types () - "Create a string usable for an Accept: header from mm-mime-data" - (let ((tmp mm-mime-data) - label mjr mnr cur-mnr (str "")) - (while tmp - (setq mnr (cdr (car tmp)) - mjr (car (car tmp)) - tmp (cdr tmp)) - (while mnr - (setq cur-mnr (car mnr) - label (concat mjr "/" (if (string= ".*" (car cur-mnr)) - "*" - (car cur-mnr)))) - (cond - ((string-match (regexp-quote label) str) nil) - ((> (+ (% (length str) 60) - (length (concat ", " mjr "/" (car cur-mnr)))) 60) - (setq str (format "%s\r\nAccept: %s" str label))) - (t - (setq str (format "%s, %s" str label)))) - (setq mnr (cdr mnr)))) - (substring str 2 nil))) - -(defun url-create-multipart-request (file-list) - "Create a multi-part MIME request for all files in FILE-LIST" - (let ((separator (current-time-string)) - (content "message/http-request") - (ref-url nil)) - (setq separator - (concat "separator-" - (mapconcat - (function - (lambda (char) - (if (memq char url-mime-separator-chars) - (char-to-string char) ""))) separator ""))) - (cons separator - (concat - (mapconcat - (function - (lambda (file) - (concat "--" separator "\nContent-type: " content "\n\n" - (url-create-mime-request file ref-url)))) file-list - "\n") - "--" separator)))) - -(defun url-create-message-id () - "Generate a string suitable for the Message-ID field of a request" - (concat "<" (url-create-unique-id) "@" (system-name) ">")) - -(defun url-create-unique-id () - ;; Generate unique ID from user name and current time. - (let* ((date (current-time-string)) - (name (user-login-name)) - (dateinfo (and date (timezone-parse-date date))) - (timeinfo (and date (timezone-parse-time (aref dateinfo 3))))) - (if (and dateinfo timeinfo) - (concat (upcase name) "." - (aref dateinfo 0) ; Year - (aref dateinfo 1) ; Month - (aref dateinfo 2) ; Day - (aref timeinfo 0) ; Hour - (aref timeinfo 1) ; Minute - (aref timeinfo 2) ; Second - ) - (error "Cannot understand current-time-string: %s." date)) - )) - -(defun url-http-user-agent-string () - (if (or (eq url-privacy-level 'paranoid) - (and (listp url-privacy-level) - (memq 'agent url-privacy-level))) - "" - (format "User-Agent: %s/%s URL/%s%s\r\n" - url-package-name url-package-version - url-version - (cond - ((and url-os-type url-system-type) - (concat " (" url-os-type "; " url-system-type ")")) - ((or url-os-type url-system-type) - (concat " (" (or url-system-type url-os-type) ")")) - (t ""))))) - -(defun url-create-mime-request (fname ref-url) - "Create a MIME request for fname, referred to by REF-URL." - (let* ((extra-headers) - (request nil) - (url (url-view-url t)) - (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers))) - (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization" - url-request-extra-headers)) - (not (boundp 'proxy-info))) - nil - (let ((url-basic-auth-storage - url-proxy-basic-authentication)) - (url-get-authentication url nil 'any nil)))) - (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers)) - nil - (url-get-authentication (or - (and (boundp 'proxy-info) - proxy-info) - url) nil 'any nil)))) - (setq no-cache (and no-cache (string-match "no-cache" no-cache))) - (if auth - (setq auth (concat "Authorization: " auth "\r\n"))) - (if proxy-auth - (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n"))) - - (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil") - (string= ref-url ""))) - (setq ref-url nil)) - - (if (or (memq url-privacy-level '(low high paranoid)) - (and (listp url-privacy-level) - (memq 'lastloc url-privacy-level))) - (setq ref-url nil)) - - (setq extra-headers (mapconcat - (function (lambda (x) - (concat (car x) ": " (cdr x)))) - url-request-extra-headers "\r\n")) - (if (not (equal extra-headers "")) - (setq extra-headers (concat extra-headers "\r\n"))) - (setq request - (format - (concat - "%s %s HTTP/1.0\r\n" ; The request - "MIME-Version: 1.0\r\n" ; Version of MIME we speaketh - "Extension: %s\r\n" ; HTTP extensions we support - "Host: %s\r\n" ; Who we want to talk to - "%s" ; Who its from - "Accept-encoding: %s\r\n" ; Encodings we understand - "Accept-language: %s\r\n" ; Languages we understand - "Accept: %s\r\n" ; Types we understand - "%s" ; User agent - "%s" ; Authorization - "%s" ; Cookies - "%s" ; Proxy Authorization - "%s" ; If-modified-since - "%s" ; Where we came from - "%s" ; Any extra headers - "%s" ; Any data - "\r\n") ; End request - (or url-request-method "GET") - fname - (or url-extensions-header "none") - (or url-current-server "UNKNOWN.HOST.NAME") - (if url-personal-mail-address - (concat "From: " url-personal-mail-address "\r\n") - "") - url-mime-encoding-string - url-mime-language-string - url-mime-accept-string - (url-http-user-agent-string) - (or auth "") - (url-cookie-generate-header-lines url-current-server - fname - (string-match "https" - url-current-type)) - (or proxy-auth "") - (if (and (not no-cache) - (member url-request-method '("GET" nil))) - (let ((tm (url-is-cached url))) - (if tm - (concat "If-modified-since: " - (url-get-normalized-date tm) "\r\n") - "")) - "") - (if ref-url (concat "Referer: " ref-url "\r\n") "") - extra-headers - (if url-request-data - (format "Content-length: %d\r\n\r\n%s" - (length url-request-data) url-request-data) - ""))) - request)) - -(defun url-setup-reload-timer (url must-be-viewing &optional time) - ;; Set up a timer to load URL at optional TIME. If TIME is unspecified, - ;; default to 5 seconds. Only loads document if MUST-BE-VIEWING is the - ;; current URL when the timer expires." - (or time (setq time 5)) - (let ((func - (` (lambda () - (if (equal (url-view-url t) (, must-be-viewing)) - (let ((w3-reuse-buffers 'no)) - (if (equal (, url) (url-view-url t)) - (kill-buffer (current-buffer))) - (w3-fetch (, url)))))))) - (cond - ((featurep 'itimer) - (start-itimer "reloader" func time)) - ((fboundp 'run-at-time) - (run-at-time time nil func)) - (t - (url-warn 'url "Cannot set up timer for automatic reload, sorry!"))))) - -(defun url-handle-refresh-header (reload) - (if (and reload - url-honor-refresh-requests - (or (eq url-honor-refresh-requests t) - (funcall url-confirmation-func "Honor refresh request? "))) - (let ((uri (url-view-url t))) - (if (string-match ";" reload) - (progn - (setq uri (substring reload (match-end 0) nil) - reload (substring reload 0 (match-beginning 0))) - (if (string-match - "ur[li][ \t]*=[ \t]*\"*\\([^ \t\"]+\\)\"*" - uri) - (setq uri (url-match uri 1))) - (setq uri (url-expand-file-name uri (url-view-url t))))) - (url-setup-reload-timer uri (url-view-url t) - (string-to-int (or reload "5")))))) - -(defun url-parse-mime-headers (&optional no-delete switch-buff) - ;; Parse mime headers and remove them from the html - (and switch-buff (set-buffer url-working-buffer)) - (let* ((st (point-min)) - (nd (progn - (goto-char (point-min)) - (skip-chars-forward " \t\n") - (if (re-search-forward "^\r*$" nil t) - (1+ (point)) - (point-max)))) - save-pos - status - class - hname - hvalu - result - ) - (narrow-to-region st (min nd (point-max))) - (goto-char (point-min)) - (skip-chars-forward " \t\n") ; Get past any blank crap - (skip-chars-forward "^ \t") ; Skip over the HTTP/xxx - (setq status (read (current-buffer)); Quicker than buffer-substring, etc. - result (cons (cons "status" status) result)) - (end-of-line) - (while (not (eobp)) - (skip-chars-forward " \t\n\r") - (setq save-pos (point)) - (skip-chars-forward "^:\n\r") - (downcase-region save-pos (point)) - (setq hname (buffer-substring save-pos (point))) - (skip-chars-forward ": \t ") - (setq save-pos (point)) - (skip-chars-forward "^\n\r") - (setq hvalu (buffer-substring save-pos (point)) - result (cons (cons hname hvalu) result)) - (if (string= hname "set-cookie") - (url-cookie-handle-set-cookie hvalu))) - (or no-delete (delete-region st (min nd (point)))) - (setq url-current-mime-type (cdr (assoc "content-type" result)) - url-current-mime-encoding (cdr (assoc "content-encoding" result)) - url-current-mime-viewer (mm-mime-info url-current-mime-type nil t) - url-current-mime-headers result - url-current-can-be-cached - (not (string-match "no-cache" - (or (cdr-safe (assoc "pragma" result)) "")))) - (url-handle-refresh-header (cdr-safe (assoc "refresh" result))) - (if (and url-request-method - (not (string= url-request-method "GET"))) - (setq url-current-can-be-cached nil)) - (let ((expires (cdr-safe (assoc "expires" result)))) - (if (and expires url-current-can-be-cached (featurep 'timezone)) - (progn - (if (string-match - (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +" - "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$") - expires) - (setq expires (concat (url-match expires 1) " " - (url-match expires 2) " " - (url-match expires 3) " " - (url-match expires 4) " [" - (url-match expires 5) "]"))) - (setq expires - (let ((d1 (mapcar - (function - (lambda (s) (and s (string-to-int s)))) - (timezone-parse-date - (current-time-string)))) - (d2 (mapcar - (function (lambda (s) (and s (string-to-int s)))) - (timezone-parse-date expires)))) - (- (timezone-absolute-from-gregorian - (nth 1 d1) (nth 2 d1) (car d1)) - (timezone-absolute-from-gregorian - (nth 1 d2) (nth 2 d2) (car d2)))) - url-current-can-be-cached (/= 0 expires))))) - (setq class (/ status 100)) - (cond - ;; Classes of response codes - ;; - ;; 5xx = Server Error - ;; 4xx = Client Error - ;; 3xx = Redirection - ;; 2xx = Successful - ;; 1xx = Informational - ;; - ((= class 2) ; Successful in some form or another - (cond - ((or (= status 206) ; Partial content - (= status 205)) ; Reset content - (setq url-current-can-be-cached nil)) - ((= status 204) ; No response - leave old document - (kill-buffer url-working-buffer)) - (t nil)) ; All others indicate success - ) - ((= class 3) ; Redirection of some type - (cond - ((or (= status 301) ; Moved - retry with Location: header - (= status 302) ; Found - retry with Location: header - (= status 303)) ; Method - retry with location/method - (let ((x (url-view-url t)) - (redir (or (cdr (assoc "uri" result)) - (cdr (assoc "location" result)))) - (redirmeth (upcase (or (cdr (assoc "method" result)) - url-request-method - "get")))) - (if (and redir (string-match "\\([^ \t]+\\)[ \t]" redir)) - (setq redir (url-match redir 1))) - (if (and redir (string-match "^<\\(.*\\)>$" redir)) - (setq redir (url-match redir 1))) - - ;; As per Roy Fielding, 303 maps _any_ method to a 'GET' - (if (= 303 status) - (setq redirmeth "GET")) - - ;; As per Roy Fielding, 301, 302 use the same method as the - ;; original request, but if != GET, user interaction is - ;; required. - (if (and (not (string= "GET" redirmeth)) - (not (funcall - url-confirmation-func - (concat - "Honor redirection with non-GET method " - "(possible security risks)? ")))) - (progn - (url-warn 'url - (format - "The URL %s tried to issue a redirect to %s using a method other than -GET, which can open up various security holes. Please see the -HTTP/1.0 specification for more details." x redir) 'error) - (if (funcall url-confirmation-func - "Continue (with method of GET)? ") - (setq redirmeth "GET") - (error "Transaction aborted.")))) - - (if (not (equal x redir)) - (let ((url-request-method redirmeth)) - (url-maybe-relative redir)) - (progn - (goto-char (point-max)) - (insert "
    Error! This URL tried to redirect me to itself!

    " - "Please notify the server maintainer."))))) - ((= status 304) ; Cached document is newer - (message "Extracting from cache...") - (url-extract-from-cache (url-create-cached-filename (url-view-url t)))) - ((= status 305) ; Use proxy in Location: header - nil))) - ((= class 4) ; Client error - (cond - ((and (= status 401) ; Unauthorized access, retry w/auth. - (< url-current-passwd-count url-max-password-attempts)) - (setq url-current-passwd-count (1+ url-current-passwd-count)) - (let* ((y (or (cdr (assoc "www-authenticate" result)) "basic")) - (url (url-view-url t)) - (type (downcase (if (string-match "[ \t]" y) - (substring y 0 (match-beginning 0)) - y)))) - (cond - ((or (equal "pem" type) (equal "pgp" type)) - (if (string-match "entity=\"\\([^\"]+\\)\"" y) - (url-fetch-with-pgp url-current-file - (url-match y 1) (intern type)) - (error "Could not find entity in %s!" type))) - ((url-auth-registered type) - (let ((args y) - (ctr (1- (length y))) - auth - (url-request-extra-headers url-request-extra-headers)) - (while (/= 0 ctr) - (if (= ?, (aref args ctr)) - (aset args ctr ?\;)) - (setq ctr (1- ctr))) - (setq args (mm-parse-args y) - auth (url-get-authentication url - (cdr-safe - (assoc "realm" args)) - type t args)) - (if auth - (setq url-request-extra-headers - (cons (cons "Authorization" auth) - url-request-extra-headers))) - (url-retrieve url t))) - (t - (widen) - (goto-char (point-max)) - (setq url-current-can-be-cached nil) - (insert "

    Sorry, but I do not know how to handle " y - " authentication. If you'd like to write it," - " send it to " url-bug-address ".
    "))))) - ((= status 407) ; Proxy authentication required - (let* ((y (or (cdr (assoc "proxy-authenticate" result)) "basic")) - (url (url-view-url t)) - (url-basic-auth-storage url-proxy-basic-authentication) - (type (downcase (if (string-match "[ \t]" y) - (substring y 0 (match-beginning 0)) - y)))) - (cond - ((or (equal "pem" type) (equal "pgp" type)) - (if (string-match "entity=\"\\([^\"]+\\)\"" y) - (url-fetch-with-pgp url-current-file - (url-match y 1) (intern type)) - (error "Could not find entity in %s!" type))) - ((url-auth-registered type) - (let ((args y) - (ctr (1- (length y))) - auth - (url-request-extra-headers url-request-extra-headers)) - (while (/= 0 ctr) - (if (= ?, (aref args ctr)) - (aset args ctr ?\;)) - (setq ctr (1- ctr))) - (setq args (mm-parse-args y) - auth (url-get-authentication (or url-using-proxy url) - (cdr-safe - (assoc "realm" args)) - type t args)) - (if auth - (setq url-request-extra-headers - (cons (cons "Proxy-Authorization" auth) - url-request-extra-headers))) - (setq url-proxy-basic-authentication url-basic-auth-storage) - (url-retrieve url t))) - (t - (widen) - (goto-char (point-max)) - (setq url-current-can-be-cached nil) - (insert "
    Sorry, but I do not know how to handle " y - " authentication. If you'd like to write it," - " send it to " url-bug-address ".
    "))))) - ;;((= status 400) nil) ; Bad request - syntax - ;;((= status 401) nil) ; Tried too many times - ;;((= status 402) nil) ; Payment required, retry w/Chargeto: - ;;((= status 403) nil) ; Access is forbidden - ;;((= status 404) nil) ; Not found... - ;;((= status 405) nil) ; Method not allowed - ;;((= status 406) nil) ; None acceptable - ;;((= status 408) nil) ; Request timeout - ;;((= status 409) nil) ; Conflict - ;;((= status 410) nil) ; Document is gone - ;;((= status 411) nil) ; Length required - ;;((= status 412) nil) ; Unless true - (t ; All others mena something hosed - (setq url-current-can-be-cached nil)))) - ((= class 5) -;;; (= status 504) ; Gateway timeout -;;; (= status 503) ; Service unavailable -;;; (= status 502) ; Bad gateway -;;; (= status 501) ; Facility not supported -;;; (= status 500) ; Internal server error - (setq url-current-can-be-cached nil)) - ((= class 1) - (cond - ((or (= status 100) ; Continue - (= status 101)) ; Switching protocols - nil))) - (t - (setq url-current-can-be-cached nil))) - (widen) - status)) - -(defun url-mime-response-p (&optional switch-buff) - ;; Determine if the current buffer is a MIME response - (and switch-buff (set-buffer url-working-buffer)) - (goto-char (point-min)) - (skip-chars-forward " \t\n") - (and (looking-at "^HTTP/.+"))) - -(defsubst url-recreate-with-attributes (obj) - (if (url-attributes obj) - (concat (url-filename obj) ";" - (mapconcat - (function - (lambda (x) - (if (cdr x) - (concat (car x) "=" (cdr x)) - (car x)))) (url-attributes obj) ";")) - (url-filename obj))) - -(defun url-http (url &optional proxy-info) - ;; Retrieve URL via http. - (let* ((urlobj (url-generic-parse-url url)) - (ref-url (or url-current-referer (url-view-url t)))) - (url-clear-tmp-buffer) - (setq url-current-type (if (boundp 'url-this-is-ssl) - "https" "http")) - (let* ((server (url-host urlobj)) - (port (url-port urlobj)) - (file (or proxy-info (url-recreate-with-attributes urlobj))) - (dest (url-target urlobj)) - request) - (if (equal port "") (setq port "80")) - (if (equal file "") (setq file "/")) - (if (not server) - (progn - (url-warn - 'url - (eval-when-compile - (concat - "Malformed URL got passed into url-retrieve.\n" - "Either `url-expand-file-name' is broken in some\n" - "way, or an incorrect URL was manually entered (more likely)." - ))) - (error "Malformed URL: `%s'" url))) - (if proxy-info - (let ((x (url-generic-parse-url url))) - (setq url-current-server (url-host urlobj) - url-current-port (url-port urlobj) - url-current-file (url-filename urlobj) - url-find-this-link (url-target urlobj) - request (url-create-mime-request file ref-url))) - (setq url-current-server server - url-current-port port - url-current-file file - url-find-this-link dest - request (url-create-mime-request file ref-url))) - (if (or (not (member port url-bad-port-list)) - (funcall url-confirmation-func - (concat - "Warning! Trying to connect to port " - port - " - continue? "))) - (progn - (url-lazy-message "Contacting %s:%s" server port) - (let ((process - (url-open-stream "WWW" url-working-buffer server - (string-to-int port)))) - (if (stringp process) - (progn - (set-buffer url-working-buffer) - (erase-buffer) - (setq url-current-mime-type "text/html" - url-current-mime-viewer - (mm-mime-info "text/html" nil 5)) - (insert "ERROR\n" - "

    ERROR - Could not establish connection

    " - "

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

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

    " (url-view-url t))) - (message "%s" process)) - (progn - (process-kill-without-query process) - (process-send-string process request) - (url-lazy-message "Request sent, waiting for response...") - (if url-show-http2-transfer - (progn - (make-local-variable 'after-change-functions) - (add-hook 'after-change-functions - 'url-after-change-function))) - (if url-be-asynchronous - (set-process-sentinel process 'url-sentinel) - (unwind-protect - (save-excursion - (set-buffer url-working-buffer) - (while (memq (url-process-status process) - '(run open)) - (url-accept-process-output process))) - (condition-case () - (url-kill-process process) - (error nil)))) - (if url-be-asynchronous - nil - (message "Retrieval complete.") - (remove-hook 'after-change-functions - 'url-after-change-function)))))) - (progn - (ding) - (url-warn 'security "Aborting connection to bad port...")))))) - -(defun url-shttp (url) - ;; Retrieve a URL via Secure-HTTP - (error "Secure-HTTP not implemented yet.")) - -(defun url-https (url) - ;; Retrieve a URL via SSL - (condition-case () - (require 'ssl) - (error (error "Not configured for SSL, please read the info pages."))) - (let ((url-this-is-ssl t) - (url-gateway-method 'ssl)) - (url-http url))) - -(provide 'url-http) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-irc.el --- a/lisp/url/url-irc.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -;;; url-irc.el --- IRC URL interface -;; Author: wmperry -;; Created: 1996/05/29 15:07:01 -;; Version: 1.19 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1996 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) - -(defvar url-irc-function 'url-irc-zenirc - "*Function to actually open an IRC connection. -Should be a function that takes several argument: - HOST - the hostname of the IRC server to contact - PORT - the port number of the IRC server to contact - CHANNEL - What channel on the server to visit right away (can be nil) - USER - What username to use -PASSWORD - What password to use") - -(defun url-irc-zenirc (host port channel user password) - (let ((zenirc-buffer-name (if (and user host port) - (format "%s@%s:%d" user host port) - (format "%s:%d" host port))) - (zenirc-server-alist - (list - (list host port password nil user)))) - (zenirc) - (goto-char (point-max)) - (if (not channel) - nil - (insert "/join " channel) - (zenirc-send-line)))) - -(defun url-irc (url) - (let* ((urlobj (url-generic-parse-url url)) - (host (url-host urlobj)) - (port (string-to-int (url-port urlobj))) - (pass (url-password urlobj)) - (user (url-user urlobj)) - (chan (url-filename urlobj))) - (if (url-target urlobj) - (setq chan (concat chan "#" (url-target urlobj)))) - (and (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (if (string-match "^/" chan) - (setq chan (substring chan 1 nil))) - (if (= (length chan) 0) - (setq chan nil)) - (funcall url-irc-function host port chan user pass))) - diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-mail.el --- a/lisp/url/url-mail.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,151 +0,0 @@ -;;; url-mail.el,v --- Mail Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1996/06/03 15:04:49 -;; Version: 1.5 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) - -(defmacro url-mailserver-skip-chunk () - (` (while (and (not (looking-at "/")) - (not (eobp))) - (forward-sexp 1)))) - -(defun url-mail (&rest args) - (interactive "P") - (or (apply 'mail args) - (error "Mail aborted"))) - -(defun url-mailto (url) - ;; Send mail to someone - (if (not (string-match "mailto:/*\\(.*\\)" url)) - (error "Malformed mailto link: %s" url)) - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (let ((to (url-unhex-string - (substring url (match-beginning 1) (match-end 1)))) - (url (url-view-url t))) - (if (fboundp url-mail-command) (funcall url-mail-command) (mail)) - (mail-to) - (insert (concat to "\nX-URL-From: " url)) - (mail-subject) - (if (not url-request-data) - nil ; Not automatic posting - (insert "Automatic submission from " - url-package-name "/" url-package-version) - (if url-request-extra-headers - (progn - (goto-char (point-min)) - (insert - (mapconcat - (function - (lambda (x) - (concat (capitalize (car x)) ": " (cdr x) "\n"))) - url-request-extra-headers "")))) - (goto-char (point-max)) - (insert url-request-data) - (mail-send-and-exit nil)))) - -(defun url-mailserver (url) - ;; Send mail to someone, much cooler/functional than mailto - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (set-buffer (get-buffer-create " *mailserver*")) - (erase-buffer) - (insert url) - (goto-char (point-min)) - (set-syntax-table url-mailserver-syntax-table) - (skip-chars-forward "^:") ; Get past mailserver - (skip-chars-forward ":") ; Get past : - ;; Handle some ugly malformed URLs, but bitch about it. - (if (looking-at "/") - (progn - (url-warn 'url "Invalid mailserver URL... attempting to cope.") - (skip-chars-forward "/"))) - - (let ((save-pos (point)) - (url (url-view-url t)) - (rfc822-addr nil) - (subject nil) - (body nil)) - (url-mailserver-skip-chunk) - (setq rfc822-addr (buffer-substring save-pos (point))) - (forward-char 1) - (setq save-pos (point)) - (url-mailserver-skip-chunk) - (setq subject (buffer-substring save-pos (point))) - (if (not (eobp)) - (progn ; There is some text to use - (forward-char 1) ; as the body of the message - (setq body (buffer-substring (point) (point-max))))) - (if (fboundp url-mail-command) (funcall url-mail-command) (mail)) - (mail-to) - (insert (concat rfc822-addr - (if (and url (not (string= url ""))) - (concat "\nX-URL-From: " url) "") - "\nX-User-Agent: " url-package-name "/" - url-package-version)) - (mail-subject) - ;; Massage the subject from URLEncoded garbage - ;; Note that we do not allow any newlines in the subject, - ;; as recommended by the Internet Draft on the mailserver - ;; URL - this means the document author cannot spoof additional - ;; header lines, which is a 'Good Thing' - (if subject - (progn - (setq subject (url-unhex-string subject)) - (let ((x (1- (length subject))) - (y 0)) - (while (<= y x) - (if (memq (aref subject y) '(?\r ?\n)) - (aset subject y ? )) - (setq y (1+ y)))))) - (insert subject) - (if url-request-extra-headers - (progn - (goto-char (point-min)) - (insert - (mapconcat - (function - (lambda (x) - (concat (capitalize (car x)) ": " (cdr x) "\n"))) - url-request-extra-headers "")))) - (goto-char (point-max)) - ;; Massage the body from URLEncoded garbage - (if body - (let ((x (1- (length body))) - (y 0)) - (while (<= y x) - (if (= (aref body y) ?/) - (aset body y ?\n)) - (setq y (1+ y))) - (setq body (url-unhex-string body)))) - (and body (insert body)) - (and url-request-data (insert url-request-data)) - (if (and (or body url-request-data) - (funcall url-confirmation-func - (concat "Send message to " rfc822-addr "? "))) - (mail-send-and-exit nil)))) - -(provide 'url-mail) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-misc.el --- a/lisp/url/url-misc.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,312 +0,0 @@ -;;; url-misc.el,v --- Misc Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1995/11/19 18:46:45 -;; Version: 1.4 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) -(autoload 'Info-goto-node "info" "" t) - -(defun url-info (url) - ;; Fetch an info node - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (let* ((data (url-generic-parse-url url)) - (fname (url-filename data)) - (node (or (url-target data) "Top"))) - (if (and fname node) - (Info-goto-node (concat "(" fname ")" node)) - (error "Malformed url: %s" url)))) - -(defun url-finger (url) - ;; Find a finger reference - (setq url-current-mime-headers '(("content-type" . "text/html")) - url-current-mime-type "text/html") - (set-buffer (get-buffer-create url-working-buffer)) - (let* ((urlobj (if (vectorp url) url - (url-generic-parse-url url))) - (host (or (url-host urlobj) "localhost")) - (port (or (url-port urlobj) - (cdr-safe (assoc "finger" url-default-ports)))) - (user (url-unhex-string (url-filename urlobj))) - (proc (url-open-stream "finger" url-working-buffer host - (string-to-int port)))) - (if (stringp proc) - (message "%s" proc) - (process-kill-without-query proc) - (if (= (string-to-char user) ?/) - (setq user (substring user 1 nil))) - (goto-char (point-min)) - (insert "\n" - " \n" - " Finger information for " user "@" host "\n" - " \n" - " \n" - "

    Finger information for " user "@" host "

    \n" - "
    \n" - " 
    \n")
-      (process-send-string proc (concat user "\r\n"))
-      (while (memq (url-process-status proc) '(run open))
-	(url-after-change-function)
-	(url-accept-process-output proc))
-      (goto-char (point-min))
-      (url-replace-regexp "^Process .* exited .*code .*$" "")
-      (goto-char (point-max))
-      (insert "
    \n" - " \n" - "\n")))) - -(defun url-rlogin (url) - ;; Open up an rlogin connection - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (or (string-match "rlogin:/*\\(.*@\\)*\\([^/]*\\)/*" url) - (error "Malformed RLOGIN URL.")) - (let* ((server (substring url (match-beginning 2) (match-end 2))) - (name (if (match-beginning 1) - (substring url (match-beginning 1) (1- (match-end 1))) - nil)) - (title (format "%s%s" (if name (concat name "@") "") server)) - (thebuf (string-match ":" server)) - (port (if thebuf - (prog1 - (substring server (1+ thebuf) nil) - (setq server (substring server 0 thebuf))) "23"))) - (cond - ((not (eq (device-type) 'tty)) - (apply 'start-process - "htmlsub" - nil - (url-string-to-tokens - (format url-xterm-command title - (if (and url-gateway-local-host-regexp - (string-match url-gateway-local-host-regexp - server)) - url-local-rlogin-prog - url-remote-rlogin-prog) server - (concat "-l " name)) ? ))) - (url-use-transparent - (require 'transparent) - (sit-for 1) - (transparent-window (get-buffer-create - (format "%s%s:%s" (if name (concat name "@") "") - server port)) - (if (and url-gateway-local-host-regexp - (string-match url-gateway-local-host-regexp - server)) - url-local-rlogin-prog - url-remote-rlogin-prog) - (list server "-l" name) nil - "Press any key to return to emacs")) - (t - (terminal-emulator - (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "") - server port)) - (if (and url-gateway-local-host-regexp - (string-match url-gateway-local-host-regexp - server)) - url-local-rlogin-prog - url-remote-rlogin-prog) - (list server "-l" name)))))) - -(defun url-telnet (url) - ;; Open up a telnet connection - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (or (string-match "telnet:/*\\(.*@\\)*\\([^/]*\\)/*" url) - (error "Malformed telnet URL: %s" url)) - (let* ((server (substring url (match-beginning 2) (match-end 2))) - (name (if (match-beginning 1) - (substring url (match-beginning 1) (1- (match-end 1))) - nil)) - (title (format "%s%s" (if name (concat name "@") "") server)) - (thebuf (string-match ":" server)) - (port (if thebuf - (prog1 - (substring server (1+ thebuf) nil) - (setq server (substring server 0 thebuf))) "23"))) - (cond - ((not (eq (device-type) 'tty)) - (apply 'start-process - "htmlsub" - nil - (url-string-to-tokens - (format url-xterm-command title - (if (and url-gateway-local-host-regexp - (string-match url-gateway-local-host-regexp - server)) - url-local-telnet-prog - url-remote-telnet-prog) server port) ? )) - (if name (message "Please log in as %s" name))) - (url-use-transparent - (require 'transparent) - (if name (message "Please log in as %s" name)) - (sit-for 1) - (transparent-window (get-buffer-create - (format "%s%s:%s" (if name (concat name "@") "") - server port)) - (if (and url-gateway-local-host-regexp - (string-match url-gateway-local-host-regexp - server)) - url-local-telnet-prog - url-remote-telnet-prog) - (list server port) nil - "Press any key to return to emacs")) - (t - (terminal-emulator - (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "") - server port)) - (if (and url-gateway-local-host-regexp - (string-match url-gateway-local-host-regexp - server)) - url-local-telnet-prog - url-remote-telnet-prog) - (list server port)) - (if name (message "Please log in as %s" name)))))) - -(defun url-tn3270 (url) - ;; Open up a tn3270 connection - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (string-match "tn3270:/*\\(.*@\\)*\\([^/]*\\)/*" url) - (let* ((server (substring url (match-beginning 2) (match-end 2))) - (name (if (match-beginning 1) - (substring url (match-beginning 1) (1- (match-end 1))) - nil)) - (thebuf (string-match ":" server)) - (title (format "%s%s" (if name (concat name "@") "") server)) - (port (if thebuf - (prog1 - (substring server (1+ thebuf) nil) - (setq server (substring server 0 thebuf))) "23"))) - (cond - ((not (eq (device-type) 'tty)) - (start-process "htmlsub" nil url-xterm-command - "-title" title - "-ut" "-e" url-tn3270-emulator server port) - (if name (message "Please log in as %s" name))) - (url-use-transparent - (require 'transparent) - (if name (message "Please log in as %s" name)) - (sit-for 1) - (transparent-window (get-buffer-create - (format "%s%s:%s" (if name (concat name "@") "") - server port)) - url-tn3270-emulator - (list server port) nil - "Press any key to return to emacs")) - (t - (terminal-emulator - (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "") - server port)) - url-tn3270-emulator - (list server port)) - (if name (message "Please log in as %s" name)))))) - -(defun url-proxy (url) - ;; Retrieve URL from a proxy. - ;; Expects `url-using-proxy' to be bound to the specific proxy to use." - (let ( - (urlobj (url-generic-parse-url url)) - (proxyobj (url-generic-parse-url url-using-proxy))) - (url-http url-using-proxy url) - (setq url-current-type (url-type urlobj) - url-current-user (url-user urlobj) - url-current-port (or (url-port urlobj) - (cdr-safe (assoc url-current-type - url-default-ports))) - url-current-server (url-host urlobj) - url-current-file (url-filename urlobj)))) - -(defun url-x-exec (url) - ;; Handle local execution of scripts. - (set-buffer (get-buffer-create url-working-buffer)) - (erase-buffer) - (string-match "x-exec:/+\\([^/]+\\)\\(/.*\\)" url) - (let ((process-environment process-environment) - (executable (url-match url 1)) - (path-info (url-match url 2)) - (query-string nil) - (safe-paths url-local-exec-path) - (found nil) - (y nil) - ) - (setq url-current-server executable - url-current-file path-info) - (if (string-match "\\(.*\\)\\?\\(.*\\)" path-info) - (setq query-string (url-match path-info 2) - path-info (url-match path-info 1))) - (while (and safe-paths (not found)) - (setq y (expand-file-name executable (car safe-paths)) - found (and (file-exists-p y) (file-executable-p y) y) - safe-paths (cdr safe-paths))) - (if (not found) - (url-retrieve (concat "www://error/nofile/" executable)) - (setq process-environment - (append - (list - "SERVER_SOFTWARE=x-exec/1.0" - (concat "SERVER_NAME=" (system-name)) - "GATEWAY_INTERFACE=CGI/1.1" - "SERVER_PROTOCOL=HTTP/1.0" - "SERVER_PORT=" - (concat "REQUEST_METHOD=" url-request-method) - (concat "HTTP_ACCEPT=" - (mapconcat - (function - (lambda (x) - (cond - ((= x ?\n) (setq y t) "") - ((= x ?:) (setq y nil) ",") - (t (char-to-string x))))) url-mime-accept-string - "")) - (concat "PATH_INFO=" (url-unhex-string path-info)) - (concat "PATH_TRANSLATED=" (url-unhex-string path-info)) - (concat "SCRIPT_NAME=" executable) - (concat "QUERY_STRING=" (url-unhex-string query-string)) - (concat "REMOTE_HOST=" (system-name))) - (if (assoc "content-type" url-request-extra-headers) - (concat "CONTENT_TYPE=" (cdr - (assoc "content-type" - url-request-extra-headers)))) - (if url-request-data - (concat "CONTENT_LENGTH=" (length url-request-data))) - process-environment)) - (and url-request-data (insert url-request-data)) - (setq y (call-process-region (point-min) (point-max) found t t)) - (goto-char (point-min)) - (delete-region (point) (progn (skip-chars-forward " \t\n") (point))) - (cond - ((url-mime-response-p) nil) ; Its already got an HTTP/1.0 header - ((null y) ; Weird exit status, whassup? - (insert "HTTP/1.0 404 Not Found\n" - "Server: " url-package-name "/x-exec\n")) - ((= 0 y) ; The shell command was successful - (insert "HTTP/1.0 200 Document follows\n" - "Server: " url-package-name "/x-exec\n")) - (t ; Non-zero exit status is bad bad bad - (insert "HTTP/1.0 404 Not Found\n" - "Server: " url-package-name "/x-exec\n")))))) - -(provide 'url-misc) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-news.el --- a/lisp/url/url-news.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,290 +0,0 @@ -;;; url-news.el,v --- News Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1996/05/29 15:48:29 -;; Version: 1.9 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) - -(defun url-format-news () - (url-clear-tmp-buffer) - (insert "HTTP/1.0 200 Retrieval OK\r\n" - (save-excursion - (set-buffer nntp-server-buffer) - (buffer-string))) - (url-parse-mime-headers) - (let* ((from (cdr (assoc "from" url-current-mime-headers))) - (qfrom (if from (url-insert-entities-in-string from) nil)) - (subj (cdr (assoc "subject" url-current-mime-headers))) - (qsubj (if subj (url-insert-entities-in-string subj) nil)) - (org (cdr (assoc "organization" url-current-mime-headers))) - (qorg (if org (url-insert-entities-in-string org) nil)) - (typ (or (cdr (assoc "content-type" url-current-mime-headers)) - "text/plain")) - (qgrps (mapcar 'car - (url-split - (url-insert-entities-in-string - (or (cdr (assoc "newsgroups" - url-current-mime-headers)) - "")) - "[ \t\n,]+"))) - (qrefs (delete "" - (mapcar - 'url-insert-entities-in-string - (mapcar 'car - (url-split - (or (cdr (assoc "references" - url-current-mime-headers)) - "") - "[ \t,\n<>]+"))))) - (date (cdr (assoc "date" url-current-mime-headers)))) - (setq url-current-file "" - url-current-type "") - (if (or (not (string-match "text/" typ)) - (string-match "text/html" typ)) - nil ; Let natural content-type take over - (insert "\n" - " \n" - " " qsubj "\n" - " \n" - " \n" - " \n" - "
    \n" - "

    " qsubj "

    \n" - "

    \n" - " From: " qfrom "
    \n" - " Newsgroups: " - (mapconcat - (function - (lambda (grp) - (concat "" grp ""))) qgrps ", ") - "
    \n" - (if org - (concat - " Organization: " qorg "
    \n") - "") - " Date: " date "
    \n" - "

    \n" - (if (null qrefs) - "" - (concat - "

    References\n" - "

      \n" - (mapconcat - (function - (lambda (ref) - (concat "
    1. " - ref "
      2. \n"))) - qrefs "") - "
    \n" - "

    \n" - "
    \n")) - " \n" - "
    " - " 
    \n")
-      (let ((s (buffer-substring (point) (point-max))))
-	(delete-region (point) (point-max))
-	(insert (url-insert-entities-in-string s)))
-      (goto-char (point-max))
-      (setq url-current-mime-type "text/html"
- 	    url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5))
-      (let ((x (assoc "content-type" url-current-mime-headers)))
- 	(if x
- 	    (setcdr x "text/html")
- 	  (setq url-current-mime-headers (cons (cons "content-type"
- 						     "text/html")
- 					       url-current-mime-headers))))
-      (insert "\n"
- 	      "
    \n" - "
    \n" - " \n" - "\n" - "")))) - -(defun url-check-gnus-version () - (require 'nntp) - (condition-case () - (require 'gnus) - (error (setq gnus-version "GNUS not found"))) - (if (or (not (boundp 'gnus-version)) - (string-match "v5.[.0-9]+$" gnus-version) - (string-match "September" gnus-version)) - nil - (url-warn 'url (concat - "The version of GNUS found on this system is too old and does\n" - "not support the necessary functionality for the URL package.\n" - "Please upgrade to version 5.x of GNUS. This is bundled by\n" - "default with Emacs 19.30 and XEmacs 19.14 and later.\n\n" - "This version of GNUS is: " gnus-version "\n")) - (fset 'url-news 'url-news-version-too-old)) - (fset 'url-check-gnus-version 'ignore)) - -(defun url-news-version-too-old (article) - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-mime-headers '(("content-type" . "text/html")) - url-current-mime-type "text/html") - (insert "\n" - " \n" - " News Error\n" - " \n" - " \n" - "

    News Error - too old

    \n" - "

    \n" - " The version of GNUS found on this system is too old and does\n" - " not support the necessary functionality for the URL package.\n" - " Please upgrade to version 5.x of GNUS. This is bundled by\n" - " default with Emacs 19.30 and XEmacs 19.14 and later.\n\n" - " This version of GNUS is: " gnus-version "\n" - "

    \n" - " \n" - "\n")) - -(defun url-news-open-host (host port user pass) - (if (fboundp 'nnheader-init-server-buffer) - (nnheader-init-server-buffer)) - (nntp-open-server host (list (string-to-int port))) - (if (and user pass) - (progn - (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user) - (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass) - (if (not (nntp-server-opened host)) - (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed" - host user)))))) - -(defun url-news-fetch-article-number (newsgroup article) - (nntp-request-group newsgroup) - (nntp-request-article article)) - -(defun url-news-fetch-message-id (host port message-id) - (if (eq ?> (aref article (1- (length article)))) - nil - (setq message-id (concat "<" message-id ">"))) - (if (nntp-request-article message-id) - (url-format-news) - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-can-be-cached nil) - (insert "\n" - " \n" - " Error\n" - " \n" - " \n" - "
    \n" - "

    Error requesting article...

    \n" - "

    \n" - " The status message returned by the NNTP server was:" - "

    \n" - " \n" - (nntp-status-message) - " \n" - "

    \n" - "

    \n" - " If you If you feel this is an error, send me mail\n" - "

    \n" - "
    \n" - " \n" - "\n" - "\n" - ))) - -(defun url-news-fetch-newsgroup (newsgroup) - (if (string-match "^/+" newsgroup) - (setq newsgroup (substring newsgroup (match-end 0)))) - (if (string-match "/+$" newsgroup) - (setq newsgroup (substring newsgroup 0 (match-beginning 0)))) - - ;; This saves a bogus 'Untitled' buffer by Emacs-W3 - (kill-buffer url-working-buffer) - - ;; This saves us from checking new news if GNUS is already running - (if (or (not (get-buffer gnus-group-buffer)) - (save-excursion - (set-buffer gnus-group-buffer) - (not (eq major-mode 'gnus-group-mode)))) - (gnus)) - (set-buffer gnus-group-buffer) - (goto-char (point-min)) - (gnus-group-read-ephemeral-group newsgroup (list 'nntp host) - nil - (cons (current-buffer) 'browse))) - -(defun url-news (article) - ;; Find a news reference - (url-check-gnus-version) - (let* ((urlobj (url-generic-parse-url article)) - (host (or (url-host urlobj) url-news-server)) - (port (or (url-port urlobj) - (cdr-safe (assoc "news" url-default-ports)))) - (article-brackets nil) - (article (url-filename urlobj))) - (url-news-open-host host port (url-user urlobj) (url-password urlobj)) - (cond - ((string-match "@" article) ; Its a specific article - (url-news-fetch-message-id host port article)) - ((string= article "") ; List all newsgroups - (gnus) - (kill-buffer url-working-buffer)) - (t ; Whole newsgroup - (url-news-fetch-newsgroup article))) - (setq url-current-type "news" - url-current-server host - url-current-user (url-user urlobj) - url-current-port port - url-current-file article))) - -(defun url-nntp (url) - ;; Find a news reference - (url-check-gnus-version) - (let* ((urlobj (url-generic-parse-url url)) - (host (or (url-host urlobj) url-news-server)) - (port (or (url-port urlobj) - (cdr-safe (assoc "nntp" url-default-ports)))) - (article-brackets nil) - (article (url-filename urlobj))) - (url-news-open-host host port (url-user urlobj) (url-password urlobj)) - (cond - ((string-match "@" article) ; Its a specific article - (url-news-fetch-message-id host port article)) - ((string-match "/\\([0-9]+\\)$" article) - (url-news-fetch-article-number (substring article 0 - (match-beginning 0)) - (match-string 1 article))) - - ((string= article "") ; List all newsgroups - (gnus) - (kill-buffer url-working-buffer)) - (t ; Whole newsgroup - (url-news-fetch-newsgroup article))) - (setq url-current-type "news" - url-current-server host - url-current-user (url-user urlobj) - url-current-port port - url-current-file article))) - -(provide 'url-news) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-nfs.el --- a/lisp/url/url-nfs.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -;;; url-nfs.el --- NFS URL interface -;; Author: wmperry -;; Created: 1996/05/29 15:07:01 -;; Version: 1.19 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1996 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) -(require 'cl) - -(defvar url-nfs-automounter-directory-spec - "file:/net/%h%f" - "*How to invoke the NFS automounter. Certain % sequences are recognized. - -%h -- the hostname of the NFS server -%n -- the port # of the NFS server -%u -- the username to use to authenticate -%p -- the password to use to authenticate -%f -- the filename on the remote server -%% -- a literal % - -Each can be used any number of times.") - -(defun url-nfs-unescape (format host port user pass file) - (save-excursion - (set-buffer (get-buffer-create " *nfs-parse*")) - (erase-buffer) - (insert format) - (goto-char (point-min)) - (while (re-search-forward "%\\(.\\)" nil t) - (let ((escape (aref (match-string 1) 0))) - (replace-match "" t t) - (case escape - (?% (insert "%")) - (?h (insert host)) - (?n (insert (or port ""))) - (?u (insert (or user ""))) - (?p (insert (or pass ""))) - (?f (insert (or file "/")))))) - (buffer-string))) - -(defun url-nfs (url) - (let* ((urlobj (url-generic-parse-url url)) - (host (url-host urlobj)) - (port (string-to-int (url-port urlobj))) - (pass (url-password urlobj)) - (user (url-user urlobj)) - (file (url-filename urlobj))) - (url-retrieve (url-nfs-unescape url-nfs-automounter-directory-spec - host port user pass file)))) - diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-parse.el --- a/lisp/url/url-parse.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -;;; url-parse.el,v --- Uniform Resource Locator parser -;; Author: wmperry -;; Created: 1996/01/05 17:45:31 -;; Version: 1.8 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmacro url-type (urlobj) - (` (aref (, urlobj) 0))) - -(defmacro url-user (urlobj) - (` (aref (, urlobj) 1))) - -(defmacro url-password (urlobj) - (` (aref (, urlobj) 2))) - -(defmacro url-host (urlobj) - (` (aref (, urlobj) 3))) - -(defmacro url-port (urlobj) - (` (or (aref (, urlobj) 4) - (if (url-fullness (, urlobj)) - (cdr-safe (assoc (url-type (, urlobj)) url-default-ports)))))) - -(defmacro url-filename (urlobj) - (` (aref (, urlobj) 5))) - -(defmacro url-target (urlobj) - (` (aref (, urlobj) 6))) - -(defmacro url-attributes (urlobj) - (` (aref (, urlobj) 7))) - -(defmacro url-fullness (urlobj) - (` (aref (, urlobj) 8))) - -(defmacro url-set-type (urlobj type) - (` (aset (, urlobj) 0 (, type)))) - -(defmacro url-set-user (urlobj user) - (` (aset (, urlobj) 1 (, user)))) - -(defmacro url-set-password (urlobj pass) - (` (aset (, urlobj) 2 (, pass)))) - -(defmacro url-set-host (urlobj host) - (` (aset (, urlobj) 3 (, host)))) - -(defmacro url-set-port (urlobj port) - (` (aset (, urlobj) 4 (, port)))) - -(defmacro url-set-filename (urlobj file) - (` (aset (, urlobj) 5 (, file)))) - -(defmacro url-set-target (urlobj targ) - (` (aset (, urlobj) 6 (, targ)))) - -(defmacro url-set-attributes (urlobj targ) - (` (aset (, urlobj) 7 (, targ)))) - -(defmacro url-set-full (urlobj val) - (` (aset (, urlobj) 8 (, val)))) - -(defun url-recreate-url (urlobj) - (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "") - (if (url-user urlobj) - (concat (url-user urlobj) - (if (url-password urlobj) - (concat ":" (url-password urlobj))) - "@")) - (url-host urlobj) - (if (and (url-port urlobj) - (not (equal (url-port urlobj) - (cdr-safe (assoc (url-type urlobj) - url-default-ports))))) - (concat ":" (url-port urlobj))) - (or (url-filename urlobj) "/") - (if (url-target urlobj) - (concat "#" (url-target urlobj))) - (if (url-attributes urlobj) - (concat ";" - (mapconcat - (function - (lambda (x) - (if (cdr x) - (concat (car x) "=" (cdr x)) - (car x)))) (url-attributes urlobj) ";"))))) - -(defun url-generic-parse-url (url) - "Return a vector of the parts of URL. -Format is [protocol username password hostname portnumber file reference]" - (cond - ((null url) - (make-vector 9 nil)) - ((or (not (string-match url-nonrelative-link url)) - (= ?/ (string-to-char url))) - (let ((retval (make-vector 9 nil))) - (url-set-filename retval url) - (url-set-full retval nil) - retval)) - (t - (save-excursion - (set-buffer (get-buffer-create " *urlparse*")) - (erase-buffer) - (insert url) - (goto-char (point-min)) - (set-syntax-table url-mailserver-syntax-table) - (let ((save-pos (point)) - (prot nil) - (user nil) - (pass nil) - (host nil) - (port nil) - (file nil) - (refs nil) - (attr nil) - (full nil)) - (if (not (looking-at "//")) - (progn - (skip-chars-forward "a-zA-Z+.\\-") - (downcase-region save-pos (point)) - (setq prot (buffer-substring save-pos (point))) - (skip-chars-forward ":") - (setq save-pos (point)))) - - ;; We are doing a fully specified URL, with hostname and all - (if (looking-at "//") - (progn - (setq full t) - (forward-char 2) - (setq save-pos (point)) - (skip-chars-forward "^/") - (downcase-region save-pos (point)) - (setq host (buffer-substring save-pos (point))) - (if (string-match "^\\([^@]+\\)@" host) - (setq user (url-match host 1) - host (substring host (match-end 0) nil))) - (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user)) - (setq pass (url-match user 2) - user (url-match user 1))) - (if (string-match ":\\([0-9+]+\\)" host) - (setq port (url-match host 1) - host (substring host 0 (match-beginning 0)))) - (if (string-match ":$" host) - (setq host (substring host 0 (match-beginning 0)))) - (setq save-pos (point)))) - ;; Now check for references - (setq save-pos (point)) - (skip-chars-forward "^#") - (if (eobp) - nil - (delete-region - (point) - (progn - (skip-chars-forward "#") - (setq refs (buffer-substring (point) (point-max))) - (point-max)))) - (goto-char save-pos) - (skip-chars-forward "^;") - (if (not (eobp)) - (setq attr (mm-parse-args (point) (point-max)) - attr (nreverse attr))) - (setq file (buffer-substring save-pos (point))) - (and port (string= port (or (cdr-safe (assoc prot url-default-ports)) - "")) - (setq port nil)) - (if (and host (string-match "%[0-9][0-9]" host)) - (setq host (url-unhex-string host))) - (vector prot user pass host port file refs attr full)))))) - -(provide 'url-parse) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-pgp.el --- a/lisp/url/url-pgp.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,173 +0,0 @@ -;;; url-pgp.el,v --- PGP Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1996/05/24 15:27:10 -;; Version: 1.3 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; UUencoding -;;; ---------- -;;; These functions are needed for the (RI)PEM encoding. PGP can -;;; handle binary data, but (RI)PEM requires that it be uuencoded -;;; first, or it will barf severely. How rude. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-uuencode-buffer (&optional buff) - "UUencode buffer BUFF, with a default of the current buffer." - (setq buff (or buff (current-buffer))) - (save-excursion - (set-buffer buff) - (url-lazy-message "UUencoding...") - (call-process-region (point-min) (point-max) - url-uuencode-program t t nil "url-temp-file") - (url-lazy-message "UUencoding... done."))) - -(defun url-uudecode-buffer (&optional buff) - "UUdecode buffer BUFF, with a default of the current buffer." - (setq buff (or buff (current-buffer))) - (let ((newname (url-generate-unique-filename))) - (save-excursion - (set-buffer buff) - (goto-char (point-min)) - (re-search-forward "^begin [0-9][0-9][0-9] \\(.*\\)$" nil t) - (replace-match (concat "begin 600 " newname)) - (url-lazy-message "UUdecoding...") - (call-process-region (point-min) (point-max) url-uudecode-program) - (url-lazy-message "UUdecoding...") - (erase-buffer) - (insert-file-contents-literally newname) - (url-lazy-message "UUdecoding... done.") - (condition-case () - (delete-file newname) - (error nil))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Decoding PGP/PEM responses -;;; -------------------------- -;;; A PGP/PEM encrypted/signed response contains all the real headers, -;;; so this is just a quick decrypt-then-reparse hack. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-decode-pgp/pem (arg) - "Decode a pgp/pem response from an HTTP/1.0 server. -This expects the decoded message to contain all the necessary HTTP/1.0 headers -to correctly act on the decoded message (new content-type, etc)." - (mc-decrypt-message) - (url-parse-mime-headers)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; PGP/PEM Encryption -;;; ------------------ -;;; This implements the highly secure PGP/PEM encrypted requests, as -;;; specified by NCSA and CERN. -;;; -;;; The complete online spec of this scheme was done by Tony Sanders -;;; , and can be seen at -;;; http://www.bsdi.com/HTTP:TNG/ripem-http.txt -;;; -;;; This section of code makes use of the EXCELLENT mailcrypt.el -;;; package by Jin S Choi (jsc@mit.edu) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun url-public-key-exists (entity scheme) - "Return t iff a key for ENTITY exists using public key system SCHEME. -ENTITY is the username/hostname combination we are checking for. -SCHEME is a symbol representing what public key encryption program to use. - Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are - recognized." - (let (retval) - (save-excursion - (cond - ((eq 'pgp scheme) ; PGP encryption - (set-buffer (get-buffer-create " *keytmp*")) - (erase-buffer) - (call-process mc-pgp-path nil t nil "+batchmode" "-kxaf" entity) - (goto-char (point-min)) - (setq retval (search-forward mc-pgp-key-begin-line nil t))) - ((eq 'pem scheme) ; PEM encryption - (set-buffer (find-file-noselect mc-ripem-pubkeyfile)) - (goto-char (point-min)) - (setq retval (search-forward entity nil t))) - (t - (url-warn 'security - (format - "Bad value for SCHEME in url-public-key-exists %s" - scheme)))) - (kill-buffer (current-buffer))) - retval)) - -(defun url-get-server-keys (entity &optional scheme) - "Make sure the key for ENTITY exists using SCHEME. -ENTITY is the username/hostname combination to get the info for. - This should be a string you could pass to 'finger'. -SCHEME is a symbol representing what public key encryption program to use. - Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are - recognized." - (or scheme (setq scheme mc-default-scheme)) - (save-excursion - (cond - ((url-public-key-exists entity scheme) nil) - (t - (string-match "\\([^@]+\\)@\\(.*\\)" entity) - (let ((url-working-buffer " *url-get-keys*")) - (url-retrieve (format "gopher://%s:79/0%s/w" (url-match entity 1) - (url-match entity 2))) - (mc-snarf-keys) - (kill-buffer url-working-buffer)))))) - -(defun url-fetch-with-pgp (url recipient type) - "Retrieve a document with public-key authentication. - URL is the url to request from the server. -RECIPIENT is the server's entity name (usually webmaster@host) - TYPE is a symbol representing what public key encryption program to use. - Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are - recognized." - (or noninteractive (require 'mailcrypt)) - (let ((request (url-create-mime-request url "PGP-Redirect")) - (url-request-data nil) - (url-request-extra-headers nil)) - (save-excursion - (url-get-server-keys recipient type) - (set-buffer (get-buffer-create " *url-encryption*")) - (erase-buffer) - (insert "\n\n" mail-header-separator "\n" request) - (mc-encrypt-message recipient type) - (goto-char (point-min)) - (if (re-search-forward (concat "\n" mail-header-separator "\n") nil t) - (delete-region (point-min) (point))) - (setq url-request-data (buffer-string) - url-request-extra-headers - (list (cons "Authorized" (format "%s entity=\"%s\"" - (cond - ((eq type 'pgp) "PGP") - ((eq type 'pem) "PEM")) - url-pgp/pem-entity)) - (cons "Content-type" (format "application/x-www-%s-reply" - (cond - ((eq type 'pgp) "pgp") - ((eq type 'pem) "pem"))))))) - (kill-buffer " *url-encryption*") - (url-retrieve (url-expand-file-name "/") t))) - -(provide 'url-pgp) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-sysdp.el --- a/lisp/url/url-sysdp.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,986 +0,0 @@ -;;; sysdep.el --- consolidate Emacs-version dependencies in one file. - -;; Copyright (C) 1995 Ben Wing. - -;; Author: Ben Wing -;; Keywords: lisp, tools -;; Version: 0.001 - -;; The purpose of this file is to eliminate the cruftiness that -;; would otherwise be required of packages that want to run on multiple -;; versions of Emacs. The idea is that we make it look like we're running -;; the latest version of XEmacs (currently 19.12) by emulating all the -;; missing functions. - -;; #### This file does not currently do any advising but should. -;; Unfortunately, advice.el is a hugely big package. Is any such -;; thing as `advice-lite' possible? - -;; #### - This package is great, but its role needs to be thought out a bit -;; more. Sysdep will not permit programs written for the old XEmacs API to -;; run on new versions of XEmacs. Sysdep is a backward-compatibility -;; package for the latest and greatest XEmacs API. It permits programmers -;; to use the latest XEmacs functionality and still have their programs run -;; on older versions of XEmacs...perhaps even on FSF Emacs. It should NEVER -;; ever need to be loaded in the newest XEmacs. It doesn't even make sense -;; to put it in the lisp/utils part of the XEmacs distribution because it's -;; real purpose is to be distributed with packages like w3 which take -;; advantage of the latest and greatest features of XEmacs but still need to -;; be run on older versions. --Stig - -;; Any packages that wish to use this file should load it using -;; `load-library'. It will not load itself if a version of sysdep.el -;; that is at least as recent has already been loaded, but will -;; load over an older version of sysdep.el. It will attempt to -;; not redefine functions that have already been custom-redefined, -;; but will redefine a function if the supplied definition came from -;; an older version of sysdep.el. - -;; Packages such as w3 that wish to include this file with the package -;; should rename it to something unique, such as `w3-sysdep.el', and -;; load it with `load-library'. That will ensure that no conflicts -;; arise if more than one package in the load path provides a version -;; of sysdep.el. If multiple packages load sysdep.el, the most recent -;; version will end up loaded; as long as I'm careful not to -;; introduce bugs in previously working definitions, this should work -;; fine. - -;; You may well discover deficiencies in this file as you use it. -;; The preferable way of dealing with this is to send me a patch -;; to sysdep.el; that way, the collective body of knowledge gets -;; increased. - -;; DO NOT load this file with `require'. -;; DO NOT put a `provide' statement in this file. - -;; IMPORTANT: leave the version string in the format X.XXX (e.g. 1.001) -;; so that string comparisons to other versions work properly. - -(defconst sysdep-potential-version "0.002") - -(if (and (boundp 'sysdep-version) - (not (string-lessp sysdep-version sysdep-potential-version))) - ;; if a more recent version of sysdep was already loaded, - ;; or if the same package is loaded again, don't load. - nil - -(defconst sysdep-version sysdep-potential-version) - -;; this macro means: define the function, but only if either it -;; wasn't bound before, or the supplied binding comes from an older -;; version of sysdep.el. That way, user-supplied bindings don't -;; get overridden. - -;; note: sysdep-defalias is often more useful than this function, -;; esp. since you can do load-time conditionalizing and can -;; optionally leave the function undefined. (e.g. frame functions -;; in v18.) - -(defmacro sysdep-defun (function &rest everything-else) - (` (cond ((or (not (fboundp (quote (, function)))) - (get (quote (, function)) 'sysdep-defined-this)) - (put (quote (, function)) 'sysdep-defined-this t) - (defun (, function) (,@ everything-else)))))) - -(defmacro sysdep-defvar (function &rest everything-else) - (` (cond ((or (not (boundp (quote (, function)))) - (get (quote (, function)) 'sysdep-defined-this)) - (put (quote (, function)) 'sysdep-defined-this t) - (defvar (, function) (,@ everything-else)))))) - -(defmacro sysdep-defconst (function &rest everything-else) - (` (cond ((or (not (boundp (quote (, function)))) - (get (quote (, function)) 'sysdep-defined-this)) - (put (quote (, function)) 'sysdep-defined-this t) - (defconst (, function) (,@ everything-else)))))) - -;; similar for fset and defalias. No need to quote as the argument -;; is already quoted. - -(defmacro sysdep-fset (function def) - (` (cond ((and (or (not (fboundp (, function))) - (get (, function) 'sysdep-defined-this)) - (, def)) - (put (, function) 'sysdep-defined-this t) - (fset (, function) (, def)))))) - -(defmacro sysdep-defalias (function def) - (` (cond ((and (or (not (fboundp (, function))) - (get (, function) 'sysdep-defined-this)) - (, def) - (or (listp (, def)) - (and (symbolp (, def)) - (fboundp (, def))))) - (put (, function) 'sysdep-defined-this t) - (defalias (, function) (, def)))))) - -;; bootstrapping: defalias and define-function don't exist -;; in older versions of lemacs - -(sysdep-fset 'defalias 'fset) -(sysdep-defalias 'define-function 'defalias) - -;; useful ways of determining what version is running -;; emacs-major-version and emacs-minor-version are -;; already defined in recent versions of FSF Emacs and XEmacs - -(sysdep-defconst emacs-major-version - ;; will string-match ever fail? If so, assume 19.0. - ;; (should we assume 18.something?) - (if (string-match "^[0-9]+" emacs-version) - (string-to-int - (substring emacs-version - (match-beginning 0) (match-end 0))) - 19)) - -(sysdep-defconst emacs-minor-version - (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) - (string-to-int - (substring emacs-version - (match-beginning 1) (match-end 1))) - 0)) - -(sysdep-defconst sysdep-running-xemacs - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - -(sysdep-defconst window-system nil) -(sysdep-defconst window-system-version 0) - -(sysdep-defvar list-buffers-directory nil) -(sysdep-defvar x-library-search-path (` - ("/usr/X11R6/lib/X11/" - "/usr/X11R5/lib/X11/" - "/usr/lib/X11R6/X11/" - "/usr/lib/X11R5/X11/" - "/usr/local/X11R6/lib/X11/" - "/usr/local/X11R5/lib/X11/" - "/usr/local/lib/X11R6/X11/" - "/usr/local/lib/X11R5/X11/" - "/usr/X11/lib/X11/" - "/usr/lib/X11/" - "/usr/local/lib/X11/" - "/usr/X386/lib/X11/" - "/usr/x386/lib/X11/" - "/usr/XFree86/lib/X11/" - "/usr/unsupported/lib/X11/" - "/usr/athena/lib/X11/" - "/usr/local/x11r5/lib/X11/" - "/usr/lpp/Xamples/lib/X11/" - "/usr/openwin/lib/X11/" - "/usr/openwin/share/lib/X11/" - (, data-directory) - ) - ) - "Search path used for X11 libraries.") - -;; frame-related stuff. - -(sysdep-defalias 'buffer-dedicated-frame 'buffer-dedicated-screen) -(sysdep-defalias 'deiconify-frame - (cond ((fboundp 'deiconify-screen) 'deiconify-screen) - ;; make-frame-visible will be defined as necessary - (t 'make-frame-visible))) -(sysdep-defalias 'delete-frame 'delete-screen) -(sysdep-defalias 'event-frame 'event-screen) -(sysdep-defalias 'event-glyph-extent 'event-glyph) -(sysdep-defalias 'find-file-other-frame 'find-file-other-screen) -(sysdep-defalias 'find-file-read-only-other-frame - 'find-file-read-only-other-screen) -(sysdep-defalias 'frame-height 'screen-height) -(sysdep-defalias 'frame-iconified-p 'screen-iconified-p) -(sysdep-defalias 'frame-left-margin-width 'screen-left-margin-width) -(sysdep-defalias 'frame-list 'screen-list) -(sysdep-defalias 'frame-live-p - (cond ((fboundp 'screen-live-p) 'screen-live-p) - ((fboundp 'live-screen-p) 'live-screen-p) - ;; #### not sure if this is correct (this is for Epoch) - ;; but gnuserv.el uses it this way - ((fboundp 'screenp) 'screenp))) -(sysdep-defalias 'frame-name 'screen-name) -(sysdep-defalias 'frame-parameters 'screen-parameters) -(sysdep-defalias 'frame-pixel-height 'screen-pixel-height) -(sysdep-defalias 'frame-pixel-width 'screen-pixel-width) -(sysdep-defalias 'frame-right-margin-width 'screen-right-margin-width) -(sysdep-defalias 'frame-root-window 'screen-root-window) -(sysdep-defalias 'frame-selected-window 'screen-selected-window) -(sysdep-defalias 'frame-totally-visible-p 'screen-totally-visible-p) -(sysdep-defalias 'frame-visible-p 'screen-visible-p) -(sysdep-defalias 'frame-width 'screen-width) -(sysdep-defalias 'framep 'screenp) -(sysdep-defalias 'get-frame-for-buffer 'get-screen-for-buffer) -(sysdep-defalias 'get-frame-for-buffer-noselect 'get-screen-for-buffer-noselect) -(sysdep-defalias 'get-other-frame 'get-other-screen) -(sysdep-defalias 'iconify-frame 'iconify-screen) -(sysdep-defalias 'lower-frame 'lower-screen) -(sysdep-defalias 'mail-other-frame 'mail-other-screen) - -(sysdep-defalias 'make-frame - (cond ((fboundp 'make-screen) - (function (lambda (&optional parameters device) - (make-screen parameters)))) - ((fboundp 'x-create-screen) - (function (lambda (&optional parameters device) - (x-create-screen parameters)))))) - -(sysdep-defalias 'make-frame-invisible 'make-screen-invisible) -(sysdep-defalias 'make-frame-visible - (cond ((fboundp 'make-screen-visible) 'make-screen-visible) - ((fboundp 'mapraised-screen) 'mapraised-screen) - ((fboundp 'x-remap-window) - (lambda (&optional x) - (x-remap-window) - (accept-process-output))))) -(sysdep-defalias 'modify-frame-parameters 'modify-screen-parameters) -(sysdep-defalias 'new-frame 'new-screen) -(sysdep-defalias 'next-frame 'next-screen) -(sysdep-defalias 'next-multiframe-window 'next-multiscreen-window) -(sysdep-defalias 'other-frame 'other-screen) -(sysdep-defalias 'previous-frame 'previous-screen) -(sysdep-defalias 'previous-multiframe-window 'previous-multiscreen-window) -(sysdep-defalias 'raise-frame - (cond ((fboundp 'raise-screen) 'raise-screen) - ((fboundp 'mapraise-screen) 'mapraise-screen))) -(sysdep-defalias 'redraw-frame 'redraw-screen) -(sysdep-defalias 'select-frame 'select-screen) -(sysdep-defalias 'selected-frame 'selected-screen) -(sysdep-defalias 'set-buffer-dedicated-frame 'set-buffer-dedicated-screen) -(sysdep-defalias 'set-frame-height 'set-screen-height) -(sysdep-defalias 'set-frame-left-margin-width 'set-screen-left-margin-width) -(sysdep-defalias 'set-frame-position 'set-screen-position) -(sysdep-defalias 'set-frame-right-margin-width 'set-screen-right-margin-width) -(sysdep-defalias 'set-frame-size 'set-screen-size) -(sysdep-defalias 'set-frame-width 'set-screen-width) -(sysdep-defalias 'show-temp-buffer-in-current-frame 'show-temp-buffer-in-current-screen) -(sysdep-defalias 'switch-to-buffer-other-frame 'switch-to-buffer-other-screen) -(sysdep-defalias 'visible-frame-list 'visible-screen-list) -(sysdep-defalias 'window-frame 'window-screen) -(sysdep-defalias 'x-create-frame 'x-create-screen) -(sysdep-defalias 'x-set-frame-icon-pixmap 'x-set-screen-icon-pixmap) -(sysdep-defalias 'x-set-frame-pointer 'x-set-screen-pointer) -(sysdep-defalias 'x-display-color-p 'x-color-display-p) -(sysdep-defalias 'x-display-grayscale-p 'x-grayscale-display-p) -(sysdep-defalias 'menu-event-p 'misc-user-event-p) - -(sysdep-defun add-submenu (menu-path submenu &optional before) - "Add a menu to the menubar or one of its submenus. -If the named menu exists already, it is changed. -MENU-PATH identifies the menu under which the new menu should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". - If MENU-PATH is nil, then the menu will be added to the menubar itself. -SUBMENU is the new menu to add. - See the documentation of `current-menubar' for the syntax. -BEFORE, if provided, is the name of a menu before which this menu should - be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." - (add-menu menu-path (car submenu) (cdr submenu) before)) - -(sysdep-defun add-menu-button (menu-path menu-leaf &optional before) - "Add a menu item to some menu, creating the menu first if necessary. -If the named item exists already, it is changed. -MENU-PATH identifies the menu under which the new menu item should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". -MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. -BEFORE, if provided, is the name of a menu item before which this item should - be added, if this item is not on the menu already. If the item is already - present, it will not be moved." - (add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1) - (aref menu-leaf 2) before)) - -(sysdep-defun make-glyph (&optional spec-list) - (if (and spec-list (cdr-safe (assq 'x spec-list))) - (make-pixmap (cdr-safe (assq 'x spec-list))))) - -(sysdep-defalias 'face-list 'list-faces) - -(sysdep-defun facep (face) - "Return t if X is a face name or an internal face vector." - ;; CAUTION!!! This is Emacs 19.x, for x <= 28, specific - ;; I know of no version of Lucid Emacs or XEmacs that did not have - ;; facep. Even if they did, they are unsupported, so big deal. - (and (or (internal-facep face) - (and (symbolp face) (assq face global-face-data))) - t)) - -(sysdep-defun set-face-property (face property value &optional locale - tag-set how-to-add) - "Change a property of FACE." - (and (symbolp face) - (put face property value))) - -(sysdep-defun face-property (face property &optional locale tag-set exact-p) - "Return FACE's value of the given PROPERTY." - (and (symbolp face) (get face property))) - -;; Property list functions -;; -(sysdep-defun plist-put (plist prop val) - "Change value in PLIST of PROP to VAL. -PLIST is a property list, which is a list of the form -(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. -If PROP is already a property on the list, its value is set to VAL, -otherwise the new PROP VAL pair is added. The new plist is returned; -use `(setq x (plist-put x prop val))' to be sure to use the new value. -The PLIST is modified by side effects." - (let ((node (memq prop plist))) - (if node - (setcar (cdr node) val) - (setq plist (cons prop (cons val plist)))) - plist)) - -(sysdep-defun plist-get (plist prop) - "Extract a value from a property list. -PLIST is a property list, which is a list of the form -(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value -corresponding to the given PROP, or nil if PROP is not -one of the properties on the list." - (car-safe (cdr-safe (memq prop plist)))) - -;; Device functions -;; By wmperry@cs.indiana.edu -;; This is a complete implementation of all the device-* functions found in -;; XEmacs 19.14. A 'device' for Emacs 19 is just a frame, from which we can -;; determine the connection to an X display, etc. - -(sysdep-defalias 'selected-device 'ignore) -(sysdep-defalias 'device-or-frame-p 'framep) -(sysdep-defalias 'device-console 'ignore) -(sysdep-defalias 'device-sound-enabled-p 'ignore) -(sysdep-defalias 'device-live-p 'frame-live-p) -(sysdep-defalias 'devicep 'framep) -(sysdep-defalias 'frame-device 'identity) -(sysdep-defalias 'redisplay-device 'redraw-frame) -(sysdep-defalias 'redraw-device 'redraw-frame) -(sysdep-defalias 'select-device 'select-frame) -(sysdep-defalias 'set-device-class 'ignore) - -(sysdep-defun make-device (type connection &optional props) - "Create a new device of type TYPE, attached to connection CONNECTION. - -The valid values for CONNECTION are device-specific; however, -CONNECTION is generally a string. (Specifically, for X devices, -CONNECTION should be a display specification such as \"foo:0\", and -for TTY devices, CONNECTION should be the filename of a TTY device -file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard -input/output.) - -PROPS, if specified, should be a plist of properties controlling -device creation. - -If CONNECTION specifies an already-existing device connection, that -device is simply returned; no new device is created, and PROPS -have no effect." - (cond - ((and (eq type 'x) connection) - (make-frame-on-display display props)) - ((eq type 'x) - (make-frame props)) - ((eq type 'tty) - nil) - (t - (error "Unsupported device-type: %s" type)))) - -(sysdep-defun make-frame-on-device (type connection &optional props) - "Create a frame of type TYPE on CONNECTION. -TYPE should be a symbol naming the device type, i.e. one of - -x An X display. CONNECTION should be a standard display string - such as \"unix:0\", or nil for the display specified on the - command line or in the DISPLAY environment variable. Only if - support for X was compiled into XEmacs. -tty A standard TTY connection or terminal. CONNECTION should be - a TTY device name such as \"/dev/ttyp2\" (as determined by - the Unix command `tty') or nil for XEmacs' standard input - and output (usually the TTY in which XEmacs started). Only - if support for TTY's was compiled into XEmacs. -ns A connection to a machine running the NeXTstep windowing - system. Not currently implemented. -win32 A connection to a machine running Microsoft Windows NT or - Windows 95. Not currently implemented. -pc A direct-write MS-DOS frame. Not currently implemented. - -PROPS should be an plist of properties, as in the call to `make-frame'. - -If a connection to CONNECTION already exists, it is reused; otherwise, -a new connection is opened." - (make-device type connection props)) - -(sysdep-defun make-tty-device (&optional tty terminal-type) - "Create a new device on TTY. - TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under -SunOS et al.), as returned by the `tty' command. A value of nil means -use the stdin and stdout as passed to XEmacs from the shell. - If TERMINAL-TYPE is non-nil, it should be a string specifying the -type of the terminal attached to the specified tty. If it is nil, -the terminal type will be inferred from the TERM environment variable." - (make-device 'tty tty (list 'terminal-type terminal-type))) - -(sysdep-defun make-x-device (&optional display) - (make-device 'x display)) - -(sysdep-defun set-device-selected-frame (device frame) - "Set the selected frame of device object DEVICE to FRAME. -If DEVICE is nil, the selected device is used. -If DEVICE is the selected device, this makes FRAME the selected frame." - (select-frame frame)) - -(sysdep-defun set-device-baud-rate (device rate) - "Set the output baud rate of DEVICE to RATE. -On most systems, changing this value will affect the amount of padding -and other strategic decisions made during redisplay." - (setq baud-rate rate)) - -(sysdep-defun dfw-device (obj) - "Given a device, frame, or window, return the associated device. -Return nil otherwise." - (cond - ((windowp obj) - (window-frame obj)) - ((framep obj) - obj) - (t - nil))) - -(sysdep-defun event-device (event) - "Return the device that EVENT occurred on. -This will be nil for some types of events (e.g. keyboard and eval events)." - (dfw-device (posn-window (event-start event)))) - -(sysdep-defun find-device (connection &optional type) - "Look for an existing device attached to connection CONNECTION. -Return the device if found; otherwise, return nil. - -If TYPE is specified, only return devices of that type; otherwise, -return devices of any type. (It is possible, although unlikely, -that two devices of different types could have the same connection -name; in such a case, the first device found is returned.)" - (let ((devices (device-list)) - (retval nil)) - (while (and devices (not nil)) - (if (equal connection (device-connection (car devices))) - (setq retval (car devices))) - (setq devices (cdr devices))) - retval)) - -(sysdep-defalias 'get-device 'find-device) - -(sysdep-defun device-baud-rate (&optional device) - "Return the output baud rate of DEVICE." - baud-rate) - -(sysdep-defun device-on-window-system-p (&optional device) - "Return non-nil if DEVICE is on a window system. -This generally means that there is support for the mouse, the menubar, -the toolbar, glyphs, etc." - (and (cdr-safe (assq 'display (frame-parameters device))) t)) - -(sysdep-defun device-name (&optional device) - "Return the name of the specified device." - ;; doesn't handle the 19.29 multiple X display stuff yet - ;; doesn't handle NeXTStep either - (cond - ((null window-system) "stdio") - ((getenv "DISPLAY") - (let ((str (getenv "DISPLAY")) - (x (1- (length (getenv "DISPLAY")))) - (y 0)) - (while (/= y x) - (if (or (= (aref str y) ?:) - (= (aref str y) ?.)) - (aset str y ?-)) - (setq y (1+ y))) - str)) - (t "stdio"))) - -(sysdep-defun device-connection (&optional device) - "Return the connection of the specified device. -DEVICE defaults to the selected device if omitted" - (or (cdr-safe (assq 'display (frame-parameters device))) "stdio")) - -(sysdep-defun device-frame-list (&optional device) - "Return a list of all frames on DEVICE. -If DEVICE is nil, the selected device will be used." - (let ((desired (device-connection device))) - (filtered-frame-list (function (lambda (x) (equal (device-connection x) - desired)))))) -(sysdep-defun device-list () - "Return a list of all devices" - (let ((seen nil) - (cur nil) - (conn nil) - (retval nil) - (not-heard (frame-list))) - (while not-heard - (setq cur (car not-heard) - conn (device-connection cur) - not-heard (cdr not-heard)) - (if (member conn seen) - nil ; Already got it - (setq seen (cons conn seen) ; Whoo hoo, a new one! - retval (cons cur retval)))) - retval)) - -(sysdep-defvar delete-device-hook nil - "Function or functions to call when a device is deleted. -One argument, the to-be-deleted device.") - -(sysdep-defun delete-device (device &optional force) - "Delete DEVICE, permanently eliminating it from use. -Normally, you cannot delete the last non-minibuffer-only frame (you must -use `save-buffers-kill-emacs' or `kill-emacs'). However, if optional -second argument FORCE is non-nil, you can delete the last frame. (This -will automatically call `save-buffers-kill-emacs'.)" - (let ((frames (device-frame-list device))) - (run-hook-with-args 'delete-device-hook device) - (while frames - (delete-frame (car frames) force) - (setq frames (cdr frames))))) - -(sysdep-defalias 'device-color-cells - (cond - ((null window-system) 'ignore) - ((fboundp 'display-color-cells) 'display-color-cells) - ((fboundp 'x-display-color-cells) 'x-display-color-cells) - ((fboundp 'ns-display-color-cells) 'ns-display-color-celles) - (t 'ignore))) - -(sysdep-defun try-font-name (fontname &rest args) - (car-safe (x-list-fonts fontname))) - -(sysdep-defalias 'device-pixel-width - (cond - ((and (eq window-system 'x) (fboundp 'x-display-pixel-width)) - 'x-display-pixel-width) - ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-width)) - 'ns-display-pixel-width) - (t 'ignore))) - -(sysdep-defalias 'device-pixel-height - (cond - ((and (eq window-system 'x) (fboundp 'x-display-pixel-height)) - 'x-display-pixel-height) - ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-height)) - 'ns-display-pixel-height) - (t 'ignore))) - -(sysdep-defalias 'device-mm-width - (cond - ((and (eq window-system 'x) (fboundp 'x-display-mm-width)) - 'x-display-mm-width) - ((and (eq window-system 'ns) (fboundp 'ns-display-mm-width)) - 'ns-display-mm-width) - (t 'ignore))) - -(sysdep-defalias 'device-mm-height - (cond - ((and (eq window-system 'x) (fboundp 'x-display-mm-height)) - 'x-display-mm-height) - ((and (eq window-system 'ns) (fboundp 'ns-display-mm-height)) - 'ns-display-mm-height) - (t 'ignore))) - -(sysdep-defalias 'device-bitplanes - (cond - ((and (eq window-system 'x) (fboundp 'x-display-planes)) - 'x-display-planes) - ((and (eq window-system 'ns) (fboundp 'ns-display-planes)) - 'ns-display-planes) - (t 'ignore))) - -(sysdep-defalias 'device-class - (cond - ;; First, Xwindows - ((and (eq window-system 'x) (fboundp 'x-display-visual-class)) - (function - (lambda (&optional device) - (let ((val (symbol-name (x-display-visual-class device)))) - (cond - ((string-match "color" val) 'color) - ((string-match "gray-scale" val) 'grayscale) - (t 'mono)))))) - ;; Now, Presentation-Manager under OS/2 - ((and (eq window-system 'pm) (fboundp 'pm-display-visual-class)) - (function - (lambda (&optional device) - (let ((val (symbol-name (pm-display-visual-class device)))) - (cond - ((string-match "color" val) 'color) - ((string-match "gray-scale" val) 'grayscale) - (t 'mono)))))) - ;; A slightly different way of doing it under OS/2 - ((and (eq window-system 'pm) (fboundp 'pm-display-color-p)) - (function - (lambda (&optional device) - (if (pm-display-color-p) - 'color - 'mono)))) - ((fboundp 'number-of-colors) - (function - (lambda (&optional device) - (if (= 2 (number-of-colors)) - 'mono - 'color)))) - ((and (eq window-system 'x) (fboundp 'x-color-p)) - (function - (lambda (&optional device) - (if (x-color-p) - 'color - 'mono)))) - ((and (eq window-system 'ns) (fboundp 'ns-display-visual-class)) - (function - (lambda (&optional device) - (let ((val (symbol-name (ns-display-visual-class)))) - (cond - ((string-match "color" val) 'color) - ((string-match "gray-scale" val) 'grayscale) - (t 'mono)))))) - (t (function (lambda (&optional device) 'mono))))) - -(sysdep-defun device-class-list () - "Returns a list of valid device classes." - (list 'color 'grayscale 'mono)) - -(sysdep-defun valid-device-class-p (class) - "Given a CLASS, return t if it is valid. -Valid classes are 'color, 'grayscale, and 'mono." - (memq class (device-class-list))) - -(sysdep-defun device-or-frame-type (device-or-frame) - "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. -DEVICE-OR-FRAME should be a device or a frame object. See `device-type' -for a description of the possible types." - (if (or (cdr-safe (assq 'display (frame-parameters device-or-frame))) - (cdr-safe (assq 'window-id (frame-parameters device-or-frame)))) - window-system - 'tty)) - -(sysdep-defun device-type (&optional device) - "Return the type of the specified device (e.g. `x' or `tty'). -Value is `tty' for a tty device (a character-only terminal), -`x' for a device which is a connection to an X server, -'ns' for a device which is a connection to a NeXTStep dps server, -'win32' for a Windows-NT window, -'pm' for an OS/2 Presentation Manager window, -'intuition' for an Amiga screen" - (device-or-frame-type device)) - -(sysdep-defun device-type-list () - "Return a list of valid console types." - (if window-system - (list window-system 'tty) - (list 'tty))) - -(sysdep-defun valid-device-type-p (type) - "Given a TYPE, return t if it is valid." - (memq type (device-type-list))) - - -;; Extent stuff -(sysdep-fset 'delete-extent 'delete-overlay) -(sysdep-fset 'extent-end-position 'overlay-end) -(sysdep-fset 'extent-start-position 'overlay-start) -(sysdep-fset 'set-extent-endpoints 'move-overlay) -(sysdep-fset 'set-extent-property 'overlay-put) -(sysdep-fset 'make-extent 'make-overlay) - -(sysdep-defun extent-property (extent property &optional default) - (or (overlay-get extent property) default)) - -(sysdep-defun extent-at (pos &optional object property before at-flag) - (let ((tmp (overlays-at (point))) - ovls) - (if property - (while tmp - (if (extent-property (car tmp) property) - (setq ovls (cons (car tmp) ovls))) - (setq tmp (cdr tmp))) - (setq ovls tmp - tmp nil)) - (car-safe - (sort ovls - (function - (lambda (a b) - (< (- (extent-end-position a) (extent-start-position a)) - (- (extent-end-position b) (extent-start-position b))))))))) - -(sysdep-defun overlays-in (beg end) - "Return a list of the overlays that overlap the region BEG ... END. -Overlap means that at least one character is contained within the overlay -and also contained within the specified region. -Empty overlays are included in the result if they are located at BEG -or between BEG and END." - (let ((ovls (overlay-lists)) - tmp retval) - (if (< end beg) - (setq tmp end - end beg - beg tmp)) - (setq ovls (nconc (car ovls) (cdr ovls))) - (while ovls - (setq tmp (car ovls) - ovls (cdr ovls)) - (if (or (and (<= (overlay-start tmp) end) - (>= (overlay-start tmp) beg)) - (and (<= (overlay-end tmp) end) - (>= (overlay-end tmp) beg))) - (setq retval (cons tmp retval)))) - retval)) - -(sysdep-defun map-extents (function &optional object from to - maparg flags property value) - (let ((tmp (overlays-in (or from (point-min)) - (or to (point-max)))) - ovls) - (if property - (while tmp - (if (extent-property (car tmp) property) - (setq ovls (cons (car tmp) ovls))) - (setq tmp (cdr tmp))) - (setq ovls tmp - tmp nil)) - (catch 'done - (while ovls - (setq tmp (funcall function (car ovls) maparg) - ovls (cdr ovls)) - (if tmp - (throw 'done tmp)))))) - -;; misc -(sysdep-fset 'make-local-hook 'make-local-variable) - -(sysdep-defun buffer-substring-no-properties (beg end) - "Return the text from BEG to END, without text properties, as a string." - (format "%s" (buffer-substring beg end))) - -(sysdep-defun symbol-value-in-buffer (symbol buffer &optional unbound-value) - "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound." - (save-excursion - (set-buffer buffer) - (if (not (boundp symbol)) - unbound-value - (symbol-value symbol)))) - -(sysdep-defun insert-file-contents-literally - (file &optional visit beg end replace) - "Like `insert-file-contents', q.v., but only reads in the file. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (let ((file-name-handler-alist nil) - (find-file-hooks nil)) - (insert-file-contents file visit beg end replace))) - -(sysdep-defun alist-to-plist (alist) - "Convert association list ALIST into the equivalent property-list form. -The plist is returned. This converts from - -\((a . 1) (b . 2) (c . 3)) - -into - -\(a 1 b 2 c 3) - -The original alist is not modified. See also `destructive-alist-to-plist'." - (let (plist) - (while alist - (let ((el (car alist))) - (setq plist (cons (cdr el) (cons (car el) plist)))) - (setq alist (cdr alist))) - (nreverse plist))) - -(sysdep-defun add-minor-mode (toggle name &optional keymap after toggle-fun) - "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. -TOGGLE is a symbol which is used as the variable which toggle the minor mode, -NAME is the name that should appear in the modeline (it should be a string -beginning with a space), KEYMAP is a keymap to make active when the minor -mode is active, and AFTER is the toggling symbol used for another minor -mode. If AFTER is non-nil, then it is used to position the new mode in the -minor-mode alists. TOGGLE-FUN specifies an interactive function that -is called to toggle the mode on and off; this affects what appens when -button2 is pressed on the mode, and when button3 is pressed somewhere -in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an -interactive function, TOGGLE is used as the toggle function. - -Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)" - (if (not (assq toggle minor-mode-alist)) - (setq minor-mode-alist (cons (list toggle name) minor-mode-alist))) - (if (and keymap (not (assq toggle minor-mode-map-alist))) - (setq minor-mode-map-alist (cons (cons toggle keymap) - minor-mode-map-alist)))) - -(sysdep-defvar x-font-regexp-foundry-and-family - (let ((- "[-?]") - (foundry "[^-]+") - (family "[^-]+") - ) - (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))) - -(sysdep-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))))) - -(sysdep-defun add-hook (hook-var function &optional at-end) - "Add a function to a hook. -First argument HOOK-VAR (a symbol) is the name of a hook, second - argument FUNCTION is the function to add. -Third (optional) argument AT-END means to add the function at the end - of the hook list instead of the beginning. If the function is already - present, this has no effect. -Returns nil if FUNCTION was already present in HOOK-VAR, else new - value of HOOK-VAR." - (if (not (boundp hook-var)) (set hook-var nil)) - (let ((old (symbol-value hook-var))) - (if (or (not (listp old)) (eq (car old) 'lambda)) - (setq old (list old))) - (if (member function old) - nil - (set hook-var - (if at-end - (append old (list function)) ; don't nconc - (cons function old)))))) - -(sysdep-defalias 'valid-color-name-p - (cond - ((fboundp 'x-valid-color-name-p) ; XEmacs/Lucid - 'x-valid-color-name-p) - ((and window-system - (fboundp 'color-defined-p)) ; NS/Emacs 19 - 'color-defined-p) - ((and window-system - (fboundp 'pm-color-defined-p)) - 'pm-color-defined-p) - ((and window-system - (fboundp 'x-color-defined-p)) ; Emacs 19 - 'x-color-defined-p) - ((fboundp 'get-color) ; Epoch - (function (lambda (color) - (let ((x (get-color color))) - (if x - (setq x (progn - (free-color x) - t))) - x)))) - (t 'identity))) ; All others - -;; Misc. -(sysdep-defun split-string (string pattern) - "Return a list of substrings of STRING which are separated by PATTERN." - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts)) - )) - -(sysdep-defun member (elt list) - (while (and list (not (equal elt (car list)))) - (setq list (cdr list))) - list) - -(sysdep-defun rassoc (key list) - (let ((found nil)) - (while (and list (not found)) - (if (equal (cdr (car list)) key) (setq found (car list))) - (setq list (cdr list))) - found)) - -(sysdep-defun display-error (error-object stream) - "Display `error-object' on `stream' in a user-friendly way." - (funcall (or (let ((type (car-safe error-object))) - (catch 'error - (and (consp error-object) - (symbolp type) - ;;(stringp (get type 'error-message)) - (consp (get type 'error-conditions)) - (let ((tail (cdr error-object))) - (while (not (null tail)) - (if (consp tail) - (setq tail (cdr tail)) - (throw 'error nil))) - t) - ;; (check-type condition condition) - (get type 'error-conditions) - ;; Search class hierarchy - (let ((tail (get type 'error-conditions))) - (while (not (null tail)) - (cond ((not (and (consp tail) - (symbolp (car tail)))) - (throw 'error nil)) - ((get (car tail) 'display-error) - (throw 'error (get (car tail) - 'display-error))) - (t - (setq tail (cdr tail))))) - ;; Default method - (function - (lambda (error-object stream) - (let ((type (car error-object)) - (tail (cdr error-object)) - (first t)) - (if (eq type 'error) - (progn (princ (car tail) stream) - (setq tail (cdr tail))) - (princ (or (get type 'error-message) type) - stream)) - (while tail - (princ (if first ": " ", ") stream) - (prin1 (car tail) stream) - (setq tail (cdr tail) - first nil))))))))) - (function - (lambda (error-object stream) - (princ "Peculiar error " stream) - (prin1 error-object stream)))) - error-object stream)) - -(sysdep-defun find-face (face) - (car-safe (memq face (face-list)))) - -(sysdep-defun set-marker-insertion-type (marker type) - "Set the insertion-type of MARKER to TYPE. -If TYPE is t, it means the marker advances when you insert text at it. -If TYPE is nil, it means the marker stays behind when you insert text at it." - nil) - -;; window functions - -;; not defined in v18 -(sysdep-defun eval-buffer (bufname &optional printflag) - (save-excursion - (set-buffer bufname) - (eval-current-buffer))) - -(sysdep-defun window-minibuffer-p (window) - "Returns non-nil if WINDOW is a minibuffer window." - (eq window (minibuffer-window))) - -(sysdep-defun window-live-p (window) - "Returns t if OBJ is a window which is currently visible." - (and (windowp window) - (window-point window))) - -;; this parenthesis closes the if statement at the top of the file. - -) - -;; DO NOT put a provide statement here. This file should never be -;; loaded with `require'. Use `load-library' instead. - -;;; sysdep.el ends here - -;;;(sysdep.el) Local Variables: -;;;(sysdep.el) eval: (put 'sysdep-defun 'lisp-indent-function 'defun) -;;;(sysdep.el) eval: (put 'sysdep-defalias 'lisp-indent-function 'defun) -;;;(sysdep.el) eval: (put 'sysdep-defconst 'lisp-indent-function 'defun) -;;;(sysdep.el) eval: (put 'sysdep-defvar 'lisp-indent-function 'defun) -;;;(sysdep.el) End: diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-vars.el --- a/lisp/url/url-vars.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,580 +0,0 @@ -;;; url-vars.el,v --- Variables for Uniform Resource Locator tool -;; Author: wmperry -;; Created: 1996/06/03 15:04:57 -;; Version: 1.13 -;; Keywords: comm, data, processes, hypermedia - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst url-version (let ((x "p1.0.41")) - (if (string-match "State: \\([^ \t\n]+\\)" x) - (substring x (match-beginning 1) (match-end 1)) - x)) - "Version # of URL package.") - - -;;; This is so we can use a consistent method of checking for mule support -;;; Emacs-based mule uses (boundp 'MULE), but XEmacs-based mule uses -;;; (featurep 'mule) - I choose to use the latter. - -(if (boundp 'MULE) - (provide 'mule)) - -(defvar url-current-can-be-cached t - "*Whether the current URL can be cached.") - -(defvar url-current-object nil - "A parsed representation of the current url") - -(defvar url-current-callback-func nil - "*The callback function for the current buffer.") - -(defvar url-current-callback-data nil - "*The data to be passed to the callback function. This should be a list, -each item in the list will be an argument to the url-current-callback-func.") - -(mapcar 'make-variable-buffer-local '( - url-current-callback-data - url-current-callback-func - url-current-can-be-cached - url-current-content-length - url-current-file - url-current-isindex - url-current-mime-encoding - url-current-mime-headers - url-current-mime-type - url-current-mime-viewer - url-current-object - url-current-port - url-current-referer - url-current-server - url-current-type - url-current-user - )) - -(defvar url-default-retrieval-proc 'url-default-callback - "*The default action to take when an asynchronous retrieval completes.") - -(defvar url-honor-refresh-requests t - "*Whether to do automatic page reloads at the request of the document -author or the server via the `Refresh' header in an HTTP/1.0 response. -If nil, no refresh requests will be honored. -If t, all refresh requests will be honored. -If non-nil and not t, the user will be asked for each refresh request.") - -(defvar url-emacs-minor-version - (if (boundp 'emacs-minor-version) - (symbol-value 'emacs-minor-version) - (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) - (string-to-int - (substring emacs-version - (match-beginning 1) (match-end 1))) - 0)) - "What minor version of emacs we are using.") - -(defvar url-inhibit-mime-parsing nil - "Whether to parse out (and delete) the MIME headers from a message.") - -(defvar url-forms-based-ftp nil - "*If non-nil, local and remote file access of directories will be shown -as an HTML 3.0 form, allowing downloads of multiple files at once.") - -(defvar url-automatic-caching nil - "*If non-nil, all documents will be automatically cached to the local -disk.") - -(defvar url-cache-expired - (function (lambda (t1 t2) (>= (- (car t2) (car t1)) 5))) - "*A function (`funcall'able) that takes two times as its arguments, and -returns non-nil if the second time is 'too old' when compared to the first -time.") - -(defvar url-check-md5s nil - "*Whether to check md5s of retrieved documents or not.") - -(defvar url-expected-md5 nil "What md5 we expect to see.") - -(defvar url-broken-resolution nil - "*Whether to use [ange|efs]-ftp-nslookup-host.") - -(defvar url-bug-address "wmperry@spry.com" "Where to send bug reports.") - -(defvar url-cookie-confirmation nil - "*If non-nil, confirmation by the user is required before accepting any -HTTP cookies.") - -(defvar url-personal-mail-address nil - "*Your full email address. This is what is sent to HTTP/1.0 servers as -the FROM field. If not set when url-do-setup is run, it defaults to -the value of url-pgp/pem-entity.") - -(defvar url-mule-retrieval-coding-system (if (featurep 'mule) - (if (boundp '*euc-japan*) - *euc-japan* - 'euc-japan-unix) - nil) - "Coding system for retrieval, used before hexified.") - -(defvar url-mule-no-coding-system (cond - ((and (featurep 'mule) - (string-match "XEmacs" emacs-version)) - 'noconv) - ((featurep 'mule) - '*noconv*) - (t nil)) - "*Variable containing a symbol that specifies no coding system is to be used. -Only used if you are in a Mule-enabled Emacsen.") - -(defvar url-directory-index-file "index.html" - "*The filename to look for when indexing a directory. If this file -exists, and is readable, then it will be viewed instead of -automatically creating the directory listing.") - -(defvar url-pgp/pem-entity nil - "*The users PGP/PEM id - usually their email address.") - -(defvar url-privacy-level 'none - "*How private you want your requests to be. -HTTP/1.0 has header fields for various information about the user, including -operating system information, email addresses, the last page you visited, etc. -This variable controls how much of this information is sent. - -This should a symbol or a list. -Valid values if a symbol are: -none -- Send all information -low -- Don't send the last location -high -- Don't send the email address or last location -paranoid -- Don't send anything - -If a list, this should be a list of symbols of what NOT to send. -Valid symbols are: -email -- the email address -os -- the operating system info -lastloc -- the last location -agent -- Do not send the User-Agent string -cookie -- never accept HTTP cookies - -Samples: - -(setq url-privacy-level 'high) -(setq url-privacy-level '(email lastloc)) ;; equivalent to 'high -(setq url-privacy-level '(os)) - -::NOTE:: -This variable controls several other variables and is _NOT_ automatically -updated. Call the function `url-setup-privacy-info' after modifying this -variable. -") - -(defvar url-uudecode-program "uudecode" "*The UUdecode executable.") - -(defvar url-uuencode-program "uuencode" "*The UUencode executable.") - -(defvar url-history-list nil "List of urls visited this session.") - -(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.") - -(defvar url-keep-history nil - "*Controls whether to keep a list of all the URLS being visited. If -non-nil, url will keep track of all the URLS visited. -If eq to `t', then the list is saved to disk at the end of each emacs -session.") - -(defvar url-uncompressor-alist '((".z" . "x-gzip") - (".gz" . "x-gzip") - (".uue" . "x-uuencoded") - (".hqx" . "x-hqx") - (".Z" . "x-compress")) - "*An assoc list of file extensions and the appropriate -content-transfer-encodings for each.") - -(defvar url-xterm-command "xterm -title %s -ut -e %s %s %s" - "*Command used to start an xterm window.") - -(defvar url-tn3270-emulator "tn3270" - "The client to run in a subprocess to connect to a tn3270 machine.") - -(defvar url-use-transparent nil - "*Whether to use the transparent package by Brian Tompsett instead of -the builtin telnet functions. Using transparent allows you to have full -vt100 emulation in the telnet and tn3270 links.") - -(defvar url-mail-command 'url-mail - "*This function will be called whenever url needs to send mail. It should -enter a mail-mode-like buffer in the current window. -The commands mail-to and mail-subject should still work in this -buffer, and it should use mail-header-separator if possible.") - -(defvar url-local-exec-path nil - "*A list of possible locations for x-exec scripts.") - -(defvar url-proxy-services nil - "*An assoc list of access types and servers that gateway them. -Looks like ((\"http\" . \"url://for/proxy/server/\") ....) This is set up -from the ACCESS_proxy environment variables in url-do-setup.") - -(defvar url-global-history-file nil - "*The global history file used by both Mosaic/X and the url package. -This file contains a list of all the URLs you have visited. This file -is parsed at startup and used to provide URL completion.") - -(defvar url-global-history-save-interval 3600 - "*The number of seconds between automatic saves of the history list. -Default is 1 hour. Note that if you change this variable after `url-do-setup' -has been run, you need to run the `url-setup-save-timer' function manually.") - -(defvar url-global-history-timer nil) - -(defvar url-passwd-entry-func nil - "*This is a symbol indicating which function to call to read in a -password. It will be set up depending on whether you are running EFS -or ange-ftp at startup if it is nil. This function should accept the -prompt string as its first argument, and the default value as its -second argument.") - -(defvar url-gopher-labels - '(("0" . "(TXT)") - ("1" . "(DIR)") - ("2" . "(CSO)") - ("3" . "(ERR)") - ("4" . "(MAC)") - ("5" . "(PCB)") - ("6" . "(UUX)") - ("7" . "(???)") - ("8" . "(TEL)") - ("T" . "(TN3)") - ("9" . "(BIN)") - ("g" . "(GIF)") - ("I" . "(IMG)") - ("h" . "(WWW)") - ("s" . "(SND)")) - "*An assoc list of gopher types and how to describe them in the gopher -menus. These can be any string, but HTML/HTML+ entities should be -used when necessary, or it could disrupt formatting of the document -later on. It is also a good idea to make sure all the strings are the -same length after entity references are removed, on a strictly -stylistic level.") - -(defvar url-gopher-icons - '( - ("0" . "&text.document;") - ("1" . "&folder;") - ("2" . "&index;") - ("3" . "&stop;") - ("4" . "&binhex.document;") - ("5" . "&binhex.document;") - ("6" . "&uuencoded.document;") - ("7" . "&index;") - ("8" . "&telnet;") - ("T" . "&tn3270;") - ("9" . "&binary.document;") - ("g" . "ℑ") - ("I" . "ℑ") - ("s" . "&audio;")) - "*An assoc list of gopher types and the graphic entity references to -show when possible.") - -(defvar url-standalone-mode nil "*Rely solely on the cache?") -(defvar url-working-buffer " *URL*" "The buffer to do all the processing in.") -(defvar url-current-annotation nil "URL of document we are annotating...") -(defvar url-current-referer nil "Referer of this page.") -(defvar url-current-content-length nil "Current content length.") -(defvar url-current-file nil "Filename of current document.") -(defvar url-current-isindex nil "Is the current document a searchable index?") -(defvar url-current-mime-encoding nil "MIME encoding of current document.") -(defvar url-current-mime-headers nil "An alist of MIME headers.") -(defvar url-current-mime-type nil "MIME type of current document.") -(defvar url-current-mime-viewer nil "How to view the current MIME doc.") -(defvar url-current-nntp-server nil "What nntp server currently opened.") -(defvar url-current-passwd-count 0 "How many times password has failed.") -(defvar url-current-port nil "Port # of the current document.") -(defvar url-current-server nil "Server of the current document.") -(defvar url-current-user nil "Username for ftp login.") -(defvar url-current-type nil "We currently in http or file mode?") -(defvar url-gopher-types "0123456789+gIThws:;<" - "A string containing character representations of all the gopher types.") -(defvar url-mime-separator-chars (mapcar 'identity - (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "abcdefghijklmnopqrstuvwxyz" - "0123456789'()+_,-./=?")) - "Characters allowable in a MIME multipart separator.") - -(defvar url-bad-port-list - '("25" "119" "19") - "*List of ports to warn the user about connecting to. Defaults to just -the mail, chargen, and NNTP ports so you cannot be tricked into sending -fake mail or forging messages by a malicious HTML document.") - -(defvar url-be-anal-about-file-attributes nil - "*Whether to use HTTP/1.0 to figure out file attributes -or just guess based on file extension, etc.") - -(defvar url-be-asynchronous nil - "*Controls whether document retrievals over HTTP should be done in -the background. This allows you to keep working in other windows -while large downloads occur.") -(make-variable-buffer-local 'url-be-asynchronous) - -(defvar url-request-data nil "Any data to send with the next request.") - -(defvar url-request-extra-headers nil - "A list of extra headers to send with the next request. Should be -an assoc list of headers/contents.") - -(defvar url-request-method nil "The method to use for the next request.") - -(defvar url-mime-encoding-string nil - "String to send to the server in the Accept-encoding: field in HTTP/1.0 -requests. This is created automatically from mm-content-transfer-encodings.") - -(defvar url-mime-language-string "*/*" - "String to send to the server in the Accept-language: field in -HTTP/1.0 requests.") - -(defvar url-mime-accept-string nil - "String to send to the server in the Accept: field in HTTP/1.0 requests. -This is created automatically from url-mime-viewers, after the mailcap file -has been parsed.") - -(defvar url-history-changed-since-last-save nil - "Whether the history list has changed since the last save operation.") - -(defvar url-proxy-basic-authentication nil - "Internal structure - do not modify!") - -(defvar url-registered-protocols nil - "Internal structure - do not modify! See `url-register-protocol'") - -(defvar url-package-version "Unknown" "Version # of package using URL.") - -(defvar url-package-name "Unknown" "Version # of package using URL.") - -(defvar url-system-type nil "What type of system we are on.") -(defvar url-os-type nil "What OS we are on.") - -(defvar url-max-password-attempts 5 - "*Maximum number of times a password will be prompted for when a -protected document is denied by the server.") - -(defvar url-wais-to-mime - '( - ("WSRC" . "application/x-wais-source") ; A database description - ("TEXT" . "text/plain") ; plain text - ) - "An assoc list of wais doctypes and their corresponding MIME -content-types.") - -(defvar url-waisq-prog "waisq" - "*Name of the waisq executable on this system. This should be the -waisq program from think.com's wais8-b5.1 distribution.") - -(defvar url-wais-gateway-server "www.ncsa.uiuc.edu" - "*The machine name where the WAIS gateway lives.") - -(defvar url-wais-gateway-port "8001" - "*The port # of the WAIS gateway.") - -(defvar url-temporary-directory "/tmp" "*Where temporary files go.") - -(defvar url-show-status t - "*Whether to show a running total of bytes transferred. Can cause a -large hit if using a remote X display over a slow link, or a terminal -with a slow modem.") - -(defvar url-using-proxy nil - "Either nil or the fully qualified proxy URL in use, e.g. -http://www.domain.com/") - -(defvar url-news-server nil - "*The default news server to get newsgroups/articles from if no server -is specified in the URL. Defaults to the environment variable NNTPSERVER -or \"news\" if NNTPSERVER is undefined.") - -(defvar url-gopher-to-mime - '((?0 . "text/plain") ; It's a file - (?1 . "www/gopher") ; Gopher directory - (?2 . "www/gopher-cso-search") ; CSO search - (?3 . "text/plain") ; Error - (?4 . "application/mac-binhex40") ; Binhexed macintosh file - (?5 . "application/pc-binhex40") ; DOS binary archive of some sort - (?6 . "archive/x-uuencode") ; Unix uuencoded file - (?7 . "www/gopher-search") ; Gopher search! - (?9 . "application/octet-stream") ; Binary file! - (?g . "image/gif") ; Gif file - (?I . "image/gif") ; Some sort of image - (?h . "text/html") ; HTML source - (?s . "audio/basic") ; Sound file - ) - "*An assoc list of gopher types and their corresponding MIME types.") - -(defvar url-use-hypertext-gopher t - "*Controls how gopher documents are retrieved. -If non-nil, the gopher pages will be converted into HTML and parsed -just like any other page. If nil, the requests will be passed off to -the gopher.el package by Scott Snyder. Using the gopher.el package -will lose the gopher+ support, and inlined searching.") - -(defvar url-global-history-hash-table nil - "Hash table for global history completion.") - -(defvar url-nonrelative-link - "^\\([-a-zA-Z0-9+.]+:\\)" - "A regular expression that will match an absolute URL.") - -(defvar url-configuration-directory nil - "*Where the URL configuration files can be found.") - -(defvar url-confirmation-func 'y-or-n-p - "*What function to use for asking yes or no functions. Possible -values are 'yes-or-no-p or 'y-or-n-p, or any function that takes a -single argument (the prompt), and returns t only if a positive answer -is gotten.") - -(defvar url-connection-retries 5 - "*# of times to try for a connection before bailing. -If for some reason url-open-stream cannot make a connection to a host -right away, it will sit for 1 second, then try again, up to this many -tries.") - -(defvar url-find-this-link nil "Link to go to within a document.") - -(defvar url-show-http2-transfer t - "*Whether to show the total # of bytes, size of file, and percentage -transferred when retrieving a document over HTTP/1.0 and it returns a -valid content-length header. This can mess up some people behind -gateways.") - -(defvar url-gateway-method 'native - "*The type of gateway support to use. -Should be a symbol specifying how we are to get a connection off of the -local machine. - -Currently supported methods: -'program :: Run a program in a subprocess to connect - (examples are itelnet, an expect script, etc) -'native :: Use the native open-network-stream in emacs -'tcp :: Use the excellent tcp.el package from gnus. - This simply does a (require 'tcp), then sets - url-gateway-method to be 'native.") - -(defvar url-gateway-shell-is-telnet nil - "*Whether the login shell of the remote host is telnet.") - -(defvar url-gateway-program-interactive nil - "*Whether url needs to hand-hold the login program on the remote machine.") - -(defvar url-gateway-handholding-login-regexp "ogin:" - "*Regexp for when to send the username to the remote process.") - -(defvar url-gateway-handholding-password-regexp "ord:" - "*Regexp for when to send the password to the remote process.") - -(defvar url-gateway-host-prompt-pattern "^[^#$%>;]*[#$%>;] *" - "*Regexp used to detect when the login is finished on the remote host.") - -(defvar url-gateway-telnet-ready-regexp "Escape character is .*" - "*A regular expression that signifies url-gateway-telnet-program is -ready to accept input.") - -(defvar url-local-rlogin-prog "rlogin" - "*Program for local telnet connections.") - -(defvar url-remote-rlogin-prog "rlogin" - "*Program for remote telnet connections.") - -(defvar url-local-telnet-prog "telnet" - "*Program for local telnet connections.") - -(defvar url-remote-telnet-prog "telnet" - "*Program for remote telnet connections.") - -(defvar url-running-xemacs (string-match "XEmacs" emacs-version) - "*In XEmacs?.") - -(defvar url-gateway-telnet-program "itelnet" - "*Program to run in a subprocess when using gateway-method 'program.") - -(defvar url-gateway-local-host-regexp nil - "*If a host being connected to matches this regexp then the -connection is done natively, otherwise the process is started on -`url-gateway-host' instead.") - -(defvar url-use-hypertext-dired t - "*How to format directory listings. - -If value is non-nil, use directory-files to list them out and -transform them into a hypertext document, then pass it through the -parse like any other document. - -If value nil, just pass the directory off to dired using find-file.") - -(defconst monthabbrev-alist - '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) - ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))) - -(defvar url-default-ports '(("http" . "80") - ("gopher" . "70") - ("telnet" . "23") - ("news" . "119") - ("https" . "443") - ("shttp" . "80")) - "An assoc list of protocols and default port #s") - -(defvar url-setup-done nil "*Has setup configuration been done?") - -(defvar url-source nil - "*Whether to force a sourcing of the next buffer. This forces local -files to be read into a buffer, no matter what. Gets around the -optimization that if you are passing it to a viewer, just make a -symbolic link, which looses if you want the source for inlined -images/etc.") - -(defconst weekday-alist - '(("Sunday" . 0) ("Monday" . 1) ("Tuesday" . 2) ("Wednesday" . 3) - ("Thursday" . 4) ("Friday" . 5) ("Saturday" . 6) - ("Tues" . 2) ("Thurs" . 4) - ("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3) - ("Thu" . 4) ("Fri" . 5) ("Sat" . 6))) - -(defconst monthabbrev-alist - '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) - ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)) - ) - -(defvar url-lazy-message-time 0) - -(defvar url-extensions-header "Security/Digest Security/SSL") - -(defvar url-mailserver-syntax-table - (copy-syntax-table emacs-lisp-mode-syntax-table) - "*A syntax table for parsing the mailserver URL") - -(modify-syntax-entry ?' "\"" url-mailserver-syntax-table) -(modify-syntax-entry ?` "\"" url-mailserver-syntax-table) -(modify-syntax-entry ?< "(>" url-mailserver-syntax-table) -(modify-syntax-entry ?> ")<" url-mailserver-syntax-table) -(modify-syntax-entry ?/ " " url-mailserver-syntax-table) - -;;; Make OS/2 happy - yeeks -(defvar tcp-binary-process-input-services nil - "*Make OS/2 happy with our CRLF pairs...") - -(provide 'url-vars) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url-wais.el --- a/lisp/url/url-wais.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,249 +0,0 @@ -;;; url-wais.el,v --- WAIS Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1996/05/24 15:27:12 -;; Version: 1.3 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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 'url-vars) -(require 'url-parse) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; WAIS support -;;; ------------ -;;; Here are even more gross hacks that I call native WAIS support. -;;; This code requires a working waisq program that is fully -;;; compatible with waisq from think.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-create-wais-source (server port dbase) - ;; Create a temporary wais source description file. Returns the - ;; file name the description is in. - (let ((x (url-generate-unique-filename)) - (y (get-buffer-create " *waisq-tmp*"))) - (save-excursion - (set-buffer y) - (erase-buffer) - (insert - (format - (concat "(:source\n:version 3\n" - ":ip-name \"%s\"\n:tcp-port %s\n" - ":database-name \"%s\"\n)") - server (if (equal port "") "210" port) dbase)) - (write-region (point-min) (point-max) x nil nil) - (kill-buffer y)) - x)) - -(defun url-wais-stringtoany (str) - ;; Return a wais subelement that specifies STR in any database - (concat "(:any :size " (length str) " :bytes #( " - (mapconcat 'identity str " ") - " ) )")) - -;(defun url-retrieve-wais-docid (server port dbase local-id) -; (call-process "waisretrieve" nil url-working-buffer nil -; (format "%s:%s@%s:%s" (url-unhex-string local-id) -; dbase server port))) - -;(url-retrieve-wais-docid "quake.think.com" "210" "directory-of-servers" -; "0 2608 /proj/wais/wais-sources/vpiej-l.src") -(defun url-retrieve-wais-docid (server port dbase local-id) - ;; Retrieve a wais document. - ;; SERVER is the server the database is on (:ip-name in source description) - ;; PORT is the port number to contact (:tcp-port in the source description) - ;; DBASE is the database name (:database-name in the source description) - ;; LOCAL-ID is the document (:original-local-id in the question description) - (let* ((dbf (url-create-wais-source server port dbase)) - (qstr (format - (concat "(:question :version 2\n" - " :result-documents\n" - " ( (:document-id\n" - " :document\n" - " (:document\n" - " :headline \"\"\n" - " :doc-id\n" - " (:doc-id :original-database %s\n" - " :original-local-id %s )\n" - " :number-of-bytes -1\n" - " :type \"\"\n" - " :source\n" - " (:source-id :filename \"%s\") ) ) ) )") - (url-wais-stringtoany dbase) - (url-wais-stringtoany (url-unhex-string local-id)) - dbf)) - (qf (url-generate-unique-filename))) - (set-buffer (get-buffer-create url-working-buffer)) - (insert qstr) - (write-region (point-min) (point-max) qf nil nil) - (erase-buffer) - (call-process url-waisq-prog nil url-working-buffer nil "-f" qf "-v" "1") - (save-excursion - (set-buffer url-working-buffer) - (setq url-current-file (url-unhex-string local-id))) - (condition-case () - (delete-file dbf) - (error nil)) - (condition-case () - (delete-file qf) - (error nil)))) - -;(url-perform-wais-query "quake.think.com" "210" "directory-of-servers" "SGML") -(defun url-perform-wais-query (server port dbase search) - ;; Perform a wais query. - ;; SERVER is the server the database is on (:ip-name in source description) - ;; PORT is the port number to contact (:tcp-port in the source description) - ;; DBASE is the database name (:database-name in the source description) - ;; SEARCH is the search term (:seed-words in the question description)" - (let ((dbfname (url-create-wais-source server port dbase)) - (qfname (url-generate-unique-filename)) - (results 'url-none-gotten)) - (save-excursion - (url-clear-tmp-buffer) - (insert - (format - (concat "(:question\n" - " :version 2\n" - " :seed-words \"%s\"\n" - " :sourcepath \"" url-temporary-directory "\"\n" - " :sources\n" - " ( (:source-id\n" - " :filename \"%s\"\n" - " )\n" - " )\n" - " :maximum-results 100)\n") - search dbfname)) - (write-region (point-min) (point-max) qfname nil nil) - (erase-buffer) - (call-process url-waisq-prog nil url-working-buffer nil "-g" "-f" qfname) - (set-buffer url-working-buffer) - (erase-buffer) - (setq url-current-server server - url-current-port port - url-current-file dbase) - (insert-file-contents-literally qfname) - (goto-char (point-min)) - (if (re-search-forward "(:question" nil t) - (delete-region (point-min) (match-beginning 0))) - (url-replace-regexp "Process.*finished.*" "") - (subst-char-in-region (point-min) (point-max) 35 32) - (goto-char (point-min)) - (message "Done reading info - parsing results...") - (if (re-search-forward ":result-documents[^(]+" nil t) - (progn - (goto-char (match-end 0)) - (while (eq results 'url-none-gotten) - (condition-case () - (setq results (read (current-buffer))) - (error (progn - (setq results 'url-none-gotten) - (goto-char (match-end 0)))))) - (erase-buffer) - (insert "Results of WAIS search\n" - "

    Searched " dbase " for " search "

    \n" - "
    \n" - "Found " (int-to-string (length results)) - " matches.\n" - "
      \n
    1. " - (mapconcat 'url-parse-wais-doc-id results "\n
    2. ") - "\n
    \n
    \n")) - (message "No results")) - (setq url-current-mime-type "text/html") - (condition-case () - (delete-file qfname) - (error nil)) - (condition-case () - (delete-file dbfname) - (error nil))))) - -(defun url-wais-anytostring (x) - ;; Convert a (:any ....) wais construct back into a string. - (mapconcat 'char-to-string (car (cdr (memq ':bytes x))) "")) - -(defun url-parse-wais-doc-id (x) - ;; Return a list item that points at the doc-id specified by X - (let* ((document (car (cdr (memq ':document x)))) - (doc-id (car (cdr (memq ':doc-id document)))) - (score (car (cdr (memq ':score x)))) - (title (car (cdr (memq ':headline document)))) - (type (car (cdr (memq ':type document)))) - (size (car (cdr (memq ':number-of-bytes document)))) - (server (car (cdr (memq ':original-server doc-id)))) - (dbase (car (cdr (memq ':original-database doc-id)))) - (localid (car (cdr (memq ':original-local-id doc-id)))) - (dist-server (car (cdr (memq ':distributor-server doc-id)))) - (dist-dbase (car (cdr (memq ':distributor-database doc-id)))) - (dist-id (car (cdr (memq ':distributor-local-id doc-id)))) - (copyright (or (car (cdr (memq ':copyright-disposition doc-id))) 0))) - (format "%s (Score = %s)" - url-current-server url-current-port url-current-file - type size - (url-hexify-string (url-wais-anytostring server)) - (url-hexify-string (url-wais-anytostring dbase)) - (url-hexify-string (url-wais-anytostring localid)) - (url-hexify-string (url-wais-anytostring dist-server)) - (url-hexify-string (url-wais-anytostring dist-dbase)) - (url-hexify-string (url-wais-anytostring dist-id)) - copyright title score))) - -(defun url-grok-wais-href (url) - "Return a list of server, port, database, search-term, doc-id" - (if (string-match "wais:/+\\([^/:]+\\):*\\([^/]*\\)/+\\(.*\\)" url) - (let ((host (url-match url 1)) - (port (url-match url 2)) - (data (url-match url 3))) - (list host port data)) - (make-list 3 nil))) - -(defun url-wais (url) - ;; Retrieve a document via WAIS - (if (and url-wais-gateway-server url-wais-gateway-port) - (url-retrieve - (format "http://%s:%s/%s" - url-wais-gateway-server - url-wais-gateway-port - (substring url (match-end 0) nil))) - (let ((href (url-grok-wais-href url))) - (url-clear-tmp-buffer) - (setq url-current-type "wais" - url-current-server (nth 0 href) - url-current-port (nth 1 href) - url-current-file (nth 2 href)) - (cond - ((string-match "2=\\(.*\\);3=\\([^ ;]+\\)" (nth 2 href)); full link - (url-retrieve-wais-docid (nth 0 href) (nth 1 href) - (url-match (nth 2 href) 1) - (url-match (nth 2 href) 2))) - ((string-match "\\([^\\?]+\\)\\?\\(.*\\)" (nth 2 href)) ; stored query - (url-perform-wais-query (nth 0 href) (nth 1 href) - (url-match (nth 2 href) 1) - (url-match (nth 2 href) 2))) - (t - (insert "WAIS search\n" - "

    WAIS search of " (nth 2 href) "

    " - "
    \n" - (format "
    \n" url) - "Enter search term: \n" - "
    \n" - "
    \n")))))) - -(provide 'url-wais) - diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/url.el --- a/lisp/url/url.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2430 +0,0 @@ -;;; url.el,v --- Uniform Resource Locator retrieval tool -;; Author: wmperry -;; Created: 1996/05/30 13:25:47 -;; Version: 1.52 -;; Keywords: comm, data, processes, hypermedia - -;;; LCD Archive Entry: -;;; url|William M. Perry|wmperry@spry.com| -;;; Major mode for manipulating URLs| -;;; 1996/05/30 13:25:47|1.52|Location Undetermined -;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(require 'url-vars) -(require 'url-parse) -(require 'urlauth) -(require 'url-cookie) -(require 'mm) -(require 'md5) -(require 'base64) -(require 'url-hash) -(or (featurep 'efs) - (featurep 'efs-auto) - (condition-case () - (require 'ange-ftp) - (error nil))) - -(load-library "url-sysdp") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions that might not exist in old versions of emacs -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-save-error (errobj) - (save-excursion - (set-buffer (get-buffer-create " *url-error*")) - (erase-buffer)) - (display-error errobj (get-buffer-create " *url-error*"))) - -(cond - ((fboundp 'display-warning) - (fset 'url-warn 'display-warning)) - ((fboundp 'w3-warn) - (fset 'url-warn 'w3-warn)) - ((fboundp 'warn) - (defun url-warn (class message &optional level) - (warn "(%s/%s) %s" class (or level 'warning) message))) - (t - (defun url-warn (class message &optional level) - (save-excursion - (set-buffer (get-buffer-create "*W3-WARNINGS*")) - (goto-char (point-max)) - (save-excursion - (insert (format "(%s/%s) %s\n" class (or level 'warning) message))) - (display-buffer (current-buffer)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Autoload all the URL loaders -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(autoload 'url-file "url-file") -(autoload 'url-ftp "url-file") -(autoload 'url-gopher "url-gopher") -(autoload 'url-irc "url-irc") -(autoload 'url-http "url-http") -(autoload 'url-nfs "url-nfs") -(autoload 'url-mailserver "url-mail") -(autoload 'url-mailto "url-mail") -(autoload 'url-info "url-misc") -(autoload 'url-shttp "url-http") -(autoload 'url-https "url-http") -(autoload 'url-finger "url-misc") -(autoload 'url-rlogin "url-misc") -(autoload 'url-telnet "url-misc") -(autoload 'url-tn3270 "url-misc") -(autoload 'url-proxy "url-misc") -(autoload 'url-x-exec "url-misc") -(autoload 'url-news "url-news") -(autoload 'url-nntp "url-news") -(autoload 'url-decode-pgp/pem "url-pgp") -(autoload 'url-wais "url-wais") - -(autoload 'url-save-newsrc "url-news") -(autoload 'url-news-generate-reply-form "url-news") -(autoload 'url-parse-newsrc "url-news") -(autoload 'url-mime-response-p "url-http") -(autoload 'url-parse-mime-headers "url-http") -(autoload 'url-handle-refresh-header "url-http") -(autoload 'url-create-mime-request "url-http") -(autoload 'url-create-message-id "url-http") -(autoload 'url-create-multipart-request "url-http") -(autoload 'url-parse-viewer-types "url-http") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; File-name-handler-alist functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-setup-file-name-handlers () - ;; Setup file-name handlers. - '(cond - ((not (boundp 'file-name-handler-alist)) - nil) ; Don't load if no alist - ((rassq 'url-file-handler file-name-handler-alist) - nil) ; Don't load twice - ((and (string-match "XEmacs\\|Lucid" emacs-version) - (< url-emacs-minor-version 11)) ; Don't load in lemacs 19.10 - nil) - (t - (setq file-name-handler-alist - (let ((new-handler (cons - (concat "^/*" - (substring url-nonrelative-link1 nil)) - 'url-file-handler))) - (if file-name-handler-alist - (append (list new-handler) file-name-handler-alist) - (list new-handler))))))) - -(defun url-file-handler (operation &rest args) - ;; Function called from the file-name-handler-alist routines. OPERATION - ;; is what needs to be done ('file-exists-p, etc). args are the arguments - ;; that would have been passed to OPERATION." - (let ((fn (get operation 'url-file-handlers)) - (url (car args)) - (myargs (cdr args))) - (if (= (string-to-char url) ?/) - (setq url (substring url 1 nil))) - (if fn (apply fn url myargs) - (let (file-name-handler-alist) - (apply operation url myargs))))) - -(defun url-file-handler-identity (&rest args) - (car args)) - -(defun url-file-handler-null (&rest args) - nil) - -(put 'file-directory-p 'url-file-handlers 'url-file-handler-null) -(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity) -(put 'file-writable-p 'url-file-handlers 'url-file-handler-null) -(put 'file-truename 'url-file-handlers 'url-file-handler-identity) -(put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents) -(put 'expand-file-name 'url-file-handlers 'url-expand-file-name) -(put 'directory-files 'url-file-handlers 'url-directory-files) -(put 'file-directory-p 'url-file-handlers 'url-file-directory-p) -(put 'file-writable-p 'url-file-handlers 'url-file-writable-p) -(put 'file-readable-p 'url-file-handlers 'url-file-exists) -(put 'file-executable-p 'url-file-handlers 'null) -(put 'file-symlink-p 'url-file-handlers 'null) -(put 'file-exists-p 'url-file-handlers 'url-file-exists) -(put 'copy-file 'url-file-handlers 'url-copy-file) -(put 'file-attributes 'url-file-handlers 'url-file-attributes) -(put 'file-name-all-completions 'url-file-handlers - 'url-file-name-all-completions) -(put 'file-name-completion 'url-file-handlers 'url-file-name-completion) -(put 'file-local-copy 'url-file-handlers 'url-file-local-copy) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Utility functions -;;; ----------------- -;;; Various functions used around the url code. -;;; Some of these qualify as hacks, but hey, this is elisp. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(if (fboundp 'mm-string-to-tokens) - (fset 'url-string-to-tokens 'mm-string-to-tokens) - (defun url-string-to-tokens (str &optional delim) - "Return a list of words from the string STR" - (setq delim (or delim ? )) - (let (results y) - (mapcar - (function - (lambda (x) - (cond - ((and (= x delim) y) (setq results (cons y results) y nil)) - ((/= x delim) (setq y (concat y (char-to-string x)))) - (t nil)))) str) - (nreverse (cons y results))))) - -(defun url-days-between (date1 date2) - ;; Return the number of days between date1 and date2. - (- (url-day-number date1) (url-day-number date2))) - -(defun url-day-number (date) - (let ((dat (mapcar (function (lambda (s) (and s (string-to-int s)) )) - (timezone-parse-date date)))) - (timezone-absolute-from-gregorian - (nth 1 dat) (nth 2 dat) (car dat)))) - -(defun url-seconds-since-epoch (date) - ;; Returns a number that says how many seconds have - ;; lapsed between Jan 1 12:00:00 1970 and DATE." - (let* ((tdate (mapcar (function (lambda (ti) (and ti (string-to-int ti)))) - (timezone-parse-date date))) - (ttime (mapcar (function (lambda (ti) (and ti (string-to-int ti)))) - (timezone-parse-time - (aref (timezone-parse-date date) 3)))) - (edate (mapcar (function (lambda (ti) (and ti (string-to-int ti)))) - (timezone-parse-date "Jan 1 12:00:00 1970"))) - (tday (- (timezone-absolute-from-gregorian - (nth 1 tdate) (nth 2 tdate) (nth 0 tdate)) - (timezone-absolute-from-gregorian - (nth 1 edate) (nth 2 edate) (nth 0 edate))))) - (+ (nth 2 ttime) - (* (nth 1 ttime) 60) - (* (nth 0 ttime) 60 60) - (* tday 60 60 24)))) - -(defun url-match (s x) - ;; Return regexp match x in s. - (substring s (match-beginning x) (match-end x))) - -(defun url-split (str del) - ;; Split the string STR, with DEL (a regular expression) as the delimiter. - ;; Returns an assoc list that you can use with completing-read." - (let (x y) - (while (string-match del str) - (setq y (substring str 0 (match-beginning 0)) - str (substring str (match-end 0) nil)) - (if (not (string-match "^[ \t]+$" y)) - (setq x (cons (list y y) x)))) - (if (not (equal str "")) - (setq x (cons (list str str) x))) - x)) - -(defun url-replace-regexp (regexp to-string) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (replace-match to-string t nil))) - -(defun url-clear-tmp-buffer () - (set-buffer (get-buffer-create url-working-buffer)) - (if buffer-read-only (toggle-read-only)) - (erase-buffer)) - -(defun url-maybe-relative (url) - (url-retrieve (url-expand-file-name url))) - -(defun url-buffer-is-hypertext (&optional buff) - "Return t if a buffer contains HTML, as near as we can guess." - (setq buff (or buff (current-buffer))) - (save-excursion - (set-buffer buff) - (let ((case-fold-search t)) - (goto-char (point-min)) - (re-search-forward - "<\\(TITLE\\|HEAD\\|BASE\\|H[0-9]\\|ISINDEX\\|P\\)>" nil t)))) - -(defun nntp-after-change-function (&rest args) - (save-excursion - (set-buffer nntp-server-buffer) - (message "Read %d bytes" (point-max)))) - -(defun url-percentage (x y) - (if (fboundp 'float) - (round (* 100 (/ x (float y)))) - (/ (* x 100) y))) - -(defun url-after-change-function (&rest args) - ;; The nitty gritty details of messaging the HTTP/1.0 status messages - ;; in the minibuffer." - (if (get-buffer url-working-buffer) - (save-excursion - (set-buffer url-working-buffer) - (let (status-message) - (if url-current-content-length - nil - (goto-char (point-min)) - (skip-chars-forward " \t\n") - (if (not (looking-at "HTTP/[0-9]\.[0-9]")) - (setq url-current-content-length 0) - (setq url-current-isindex - (and (re-search-forward "$\r*$" nil t) (point))) - (if (re-search-forward - "^content-type:[ \t]*\\([^\r\n]+\\)\r*$" - url-current-isindex t) - (setq url-current-mime-type (downcase - (url-eat-trailing-space - (buffer-substring - (match-beginning 1) - (match-end 1)))))) - (if (re-search-forward "^content-length:\\([^\r\n]+\\)\r*$" - url-current-isindex t) - (setq url-current-content-length - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (setq url-current-content-length nil)))) - (goto-char (point-min)) - (if (re-search-forward "^status:\\([^\r]*\\)" url-current-isindex t) - (progn - (setq status-message (buffer-substring (match-beginning 1) - (match-end 1))) - (replace-match (concat "btatus:" status-message)))) - (goto-char (point-max)) - (cond - (status-message (url-lazy-message "%s" status-message)) - ((and url-current-content-length (> url-current-content-length 1) - url-current-mime-type) - (url-lazy-message "Read %d of %d bytes (%d%%) [%s]" - (point-max) url-current-content-length - (url-percentage (point-max) - url-current-content-length) - url-current-mime-type)) - ((and url-current-content-length (> url-current-content-length 1)) - (url-lazy-message "Read %d of %d bytes (%d%%)" - (point-max) url-current-content-length - (url-percentage (point-max) - url-current-content-length))) - ((and (/= 1 (point-max)) url-current-mime-type) - (url-lazy-message "Read %d bytes. [%s]" (point-max) - url-current-mime-type)) - ((/= 1 (point-max)) - (url-lazy-message "Read %d bytes." (point-max))) - (t (url-lazy-message "Waiting for response."))))))) - -(defun url-insert-entities-in-string (string) - "Convert HTML markup-start characters to entity references in STRING. - Also replaces the \" character, so that the result may be safely used as - an attribute value in a tag. Returns a new string with the result of the - conversion. Replaces these characters as follows: - & ==> & - < ==> < - > ==> > - \" ==> "" - (if (string-match "[&<>\"]" string) - (save-excursion - (set-buffer (get-buffer-create " *entity*")) - (erase-buffer) - (buffer-disable-undo (current-buffer)) - (insert string) - (goto-char (point-min)) - (while (progn - (skip-chars-forward "^&<>\"") - (not (eobp))) - (insert (cdr (assq (char-after (point)) - '((?\" . """) - (?& . "&") - (?< . "<") - (?> . ">"))))) - (delete-char 1)) - (buffer-string)) - string)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Information information -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar url-process-lookup-table nil) - -(defun url-setup-process-get () - (let ((x nil) - (nativep t)) - (condition-case () - (progn - (setq x (start-process "Test" nil "/bin/sh")) - (get x 'command)) - (error (setq nativep nil))) - (cond - ((fboundp 'process-get) ; Emacs 19.31 w/my hacks - (defun url-process-get (proc prop &optional default) - (or (process-get proc prop) default))) - (nativep ; XEmacs 19.14 w/my hacks - (fset 'url-process-get 'get)) - (t - (defun url-process-get (proc prop &optional default) - (or (plist-get (cdr-safe (assq proc url-process-lookup-table)) prop) - default)))) - (cond - ((fboundp 'process-put) ; Emacs 19.31 w/my hacks - (fset 'url-process-put 'process-put)) - (nativep - (fset 'url-process-put 'put)) - (t - (defun url-process-put (proc prop val) - (let ((node (assq proc url-process-lookup-table))) - (if (not node) - (setq url-process-lookup-table (cons (cons proc (list prop val)) - url-process-lookup-table)) - (setcdr node (plist-put (cdr node) prop val))))))) - (and (processp x) (delete-process x)))) - -(defun url-gc-process-lookup-table () - (let (new) - (while url-process-lookup-table - (if (not (memq (process-status (caar url-process-lookup-table)) - '(stop closed nil))) - (setq new (cons (car url-process-lookup-table) new))) - (setq url-process-lookup-table (cdr url-process-lookup-table))) - (setq url-process-lookup-table new))) - -(defun url-list-processes () - (interactive) - (url-gc-process-lookup-table) - (let ((processes (process-list)) - proc len type) - (set-buffer (get-buffer-create "URL Status Display")) - (display-buffer (current-buffer)) - (erase-buffer) - (insert - (eval-when-compile (format "%-40s%-10s%-25s" "URL" "Size" "Type")) "\n" - (eval-when-compile (make-string 75 ?-)) "\n") - (while processes - (setq proc (car processes) - processes (cdr processes)) - (if (url-process-get proc 'url) - (progn - (save-excursion - (set-buffer (process-buffer proc)) - (setq len url-current-content-length - type url-current-mime-type)) - (insert - (format "%-40s%-10d%-25s" (url-process-get proc 'url) - len type))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; file-name-handler stuff calls this -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun url-have-visited-url (url &rest args) - "Return non-nil iff the user has visited URL before. -The return value is a cons of the url and the date last accessed as a string" - (url-gethash url url-global-history-hash-table)) - -(defun url-directory-files (url &rest args) - "Return a list of files on a server." - nil) - -(defun url-file-writable-p (url &rest args) - "Return t iff a url is writable by this user" - nil) - -(defun url-copy-file (url &rest args) - "Copy a url to the specified filename." - nil) - -(defun url-file-directly-accessible-p (url) - "Returns t iff the specified URL is directly accessible -on your filesystem. (nfs, local file, etc)." - (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url))) - (type (url-type urlobj))) - (and (member type '("file" "ftp")) - (not (url-host urlobj))))) - -;;;###autoload -(defun url-file-attributes (url &rest args) - "Return a list of attributes of URL. -Value is nil if specified file cannot be opened. -Otherwise, list elements are: - 0. t for directory, string (name linked to) for symbolic link, or nil. - 1. Number of links to file. - 2. File uid. - 3. File gid. - 4. Last access time, as a list of two integers. - First integer has high-order 16 bits of time, second has low 16 bits. - 5. Last modification time, likewise. - 6. Last status change time, likewise. - 7. Size in bytes. (-1, if number is out of range). - 8. File modes, as a string of ten letters or dashes as in ls -l. - If URL is on an http server, this will return the content-type if possible. - 9. t iff file's gid would change if file were deleted and recreated. -10. inode number. -11. Device number. - -If file does not exist, returns nil." - (and url - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj)) - (url-automatic-caching nil) - (data nil) - (exists nil)) - (cond - ((equal type "http") - (cond - ((not url-be-anal-about-file-attributes) - (setq data (list - (url-file-directory-p url) ; Directory - 1 ; number of links to it - 0 ; UID - 0 ; GID - (cons 0 0) ; Last access time - (cons 0 0) ; Last mod. time - (cons 0 0) ; Last status time - -1 ; file size - (mm-extension-to-mime - (url-file-extension (url-filename urlobj))) - nil ; gid would change - 0 ; inode number - 0 ; device number - ))) - (t ; HTTP/1.0, use HEAD - (let ((url-request-method "HEAD") - (url-request-data nil) - (url-working-buffer " *url-temp*")) - (save-excursion - (condition-case () - (progn - (url-retrieve url) - (setq data (and - (setq exists - (cdr - (assoc "status" - url-current-mime-headers))) - (>= exists 200) - (< exists 300) - (list - (url-file-directory-p url) ; Directory - 1 ; links to - 0 ; UID - 0 ; GID - (cons 0 0) ; Last access time - (cons 0 0) ; Last mod. time - (cons 0 0) ; Last status time - (or ; Size in bytes - (cdr (assoc "content-length" - url-current-mime-headers)) - -1) - (or - (cdr (assoc "content-type" - url-current-mime-headers)) - (mm-extension-to-mime - (url-file-extension - (url-filename urlobj)))) ; content-type - nil ; gid would change - 0 ; inode number - 0 ; device number - )))) - (error nil)) - (and (not data) - (setq data (list (url-file-directory-p url) - 1 0 0 (cons 0 0) (cons 0 0) (cons 0 0) - -1 (mm-extension-to-mime - (url-file-extension - url-current-file)) - nil 0 0))) - (kill-buffer " *url-temp*")))))) - ((member type '("ftp" "file")) - (let ((fname (if (url-host urlobj) - (concat "/" - (if (url-user urlobj) - (concat (url-user urlobj) "@") - "") - (url-host urlobj) ":" - (url-filename urlobj)) - (url-filename urlobj)))) - (setq data (or (file-attributes fname) (make-list 12 nil))) - (setcar (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr data)))))))) - (mm-extension-to-mime (url-file-extension fname))))) - (t nil)) - data))) - -(defun url-file-name-all-completions (file dirname &rest args) - "Return a list of all completions of file name FILE in directory DIR. -These are all file names in directory DIR which begin with FILE." - ;; need to rewrite - ) - -(defun url-file-name-completion (file dirname &rest args) - "Complete file name FILE in directory DIR. -Returns the longest string -common to all filenames in DIR that start with FILE. -If there is only one and FILE matches it exactly, returns t. -Returns nil if DIR contains no name starting with FILE." - (apply 'url-file-name-all-completions file dirname args)) - -(defun url-file-local-copy (file &rest args) - "Copy the file FILE into a temporary file on this machine. -Returns the name of the local copy, or nil, if FILE is directly -accessible." - nil) - -(defun url-insert-file-contents (url &rest args) - "Insert the contents of the URL in this buffer." - (interactive "sURL: ") - (save-excursion - (let ((old-asynch url-be-asynchronous)) - (setq-default url-be-asynchronous nil) - (url-retrieve url) - (setq-default url-be-asynchronous old-asynch))) - (insert-buffer url-working-buffer) - (setq buffer-file-name url) - (kill-buffer url-working-buffer)) - -(defun url-file-directory-p (url &rest args) - "Return t iff a url points to a directory" - (equal (substring url -1 nil) "/")) - -(defun url-file-exists (url &rest args) - "Return t iff a file exists." - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj)) - (exists nil)) - (cond - ((equal type "http") ; use head - (let ((url-request-method "HEAD") - (url-request-data nil) - (url-working-buffer " *url-temp*")) - (save-excursion - (url-retrieve url) - (setq exists (or (cdr - (assoc "status" url-current-mime-headers)) 500)) - (kill-buffer " *url-temp*") - (setq exists (and (>= exists 200) (< exists 300)))))) - ((member type '("ftp" "file")) ; file-attributes - (let ((fname (if (url-host urlobj) - (concat "/" - (if (url-user urlobj) - (concat (url-user urlobj) "@") - "") - (url-host urlobj) ":" - (url-filename urlobj)) - (url-filename urlobj)))) - (setq exists (file-exists-p fname)))) - (t nil)) - exists)) - -;;;###autoload -(defun url-normalize-url (url) - "Return a 'normalized' version of URL. This strips out default port -numbers, etc." - (let (type data grok retval) - (setq data (url-generic-parse-url url) - type (url-type data)) - (if (member type '("www" "about" "mailto" "mailserver" "info")) - (setq retval url) - (setq retval (url-recreate-url data))) - retval)) - -;;;###autoload -(defun url-buffer-visiting (url) - "Return the name of a buffer (if any) that is visiting URL." - (setq url (url-normalize-url url)) - (let ((bufs (buffer-list)) - (found nil)) - (if (condition-case () - (string-match "\\(.*\\)#" url) - (error nil)) - (setq url (url-match url 1))) - (while (and bufs (not found)) - (save-excursion - (set-buffer (car bufs)) - (setq found (if (and - (not (equal (buffer-name (car bufs)) - url-working-buffer)) - (memq major-mode '(url-mode w3-mode)) - (equal (url-view-url t) url)) (car bufs) nil) - bufs (cdr bufs)))) - found)) - -(defun url-file-size (url &rest args) - "Return the size of a file in bytes, or -1 if can't be determined." - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj)) - (size -1) - (data nil)) - (cond - ((equal type "http") ; use head - (let ((url-request-method "HEAD") - (url-request-data nil) - (url-working-buffer " *url-temp*")) - (save-excursion - (url-retrieve url) - (setq size (or (cdr - (assoc "content-length" url-current-mime-headers)) - -1)) - (kill-buffer " *url-temp*")))) - ((member type '("ftp" "file")) ; file-attributes - (let ((fname (if (url-host urlobj) - (concat "/" - (if (url-user urlobj) - (concat (url-user urlobj) "@") - "") - (url-host urlobj) ":" - (url-filename urlobj)) - (url-filename urlobj)))) - (setq data (file-attributes fname) - size (nth 7 data)))) - (t nil)) - (cond - ((stringp size) (string-to-int size)) - ((integerp size) size) - ((null size) -1) - (t -1)))) - -(defun url-generate-new-buffer-name (start) - "Create a new buffer name based on START." - (let ((x 1) - name) - (if (not (get-buffer start)) - start - (progn - (setq name (format "%s<%d>" start x)) - (while (get-buffer name) - (setq x (1+ x) - name (format "%s<%d>" start x))) - name)))) - -(defun url-generate-unique-filename (&optional fmt) - "Generate a unique filename in url-temporary-directory" - (if (not fmt) - (let ((base (format "url-tmp.%d" (user-real-uid))) - (fname "") - (x 0)) - (setq fname (format "%s%d" base x)) - (while (file-exists-p (expand-file-name fname url-temporary-directory)) - (setq x (1+ x) - fname (concat base (int-to-string x)))) - (expand-file-name fname url-temporary-directory)) - (let ((base (concat "url" (int-to-string (user-real-uid)))) - (fname "") - (x 0)) - (setq fname (format fmt (concat base (int-to-string x)))) - (while (file-exists-p (expand-file-name fname url-temporary-directory)) - (setq x (1+ x) - fname (format fmt (concat base (int-to-string x))))) - (expand-file-name fname url-temporary-directory)))) - -(defun url-lazy-message (&rest args) - "Just like `message', but is a no-op if called more than once a second. -Will not do anything if url-show-status is nil." - (if (or (null url-show-status) - (= url-lazy-message-time - (setq url-lazy-message-time (nth 1 (current-time))))) - nil - (apply 'message args))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Gateway Support -;;; --------------- -;;; Fairly good/complete gateway support -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-kill-process (proc) - "Kill the process PROC - knows about all the various gateway types, -and acts accordingly." - (cond - ((eq url-gateway-method 'native) (delete-process proc)) - ((eq url-gateway-method 'program) (kill-process proc)) - (t (error "Unknown url-gateway-method %s" url-gateway-method)))) - -(defun url-accept-process-output (proc) - "Allow any pending output from subprocesses to be read by Emacs. -It is read into the process' buffers or given to their filter functions. -Where possible, this will not exit until some output is received from PROC, -or 1 second has elapsed." - (accept-process-output proc 1)) - -(defun url-process-status (proc) - "Return the process status of a url buffer" - (cond - ((memq url-gateway-method '(native ssl program)) (process-status proc)) - (t (error "Unkown url-gateway-method %s" url-gateway-method)))) - -(defun url-open-stream (name buffer host service) - "Open a stream to a host" - (let ((tmp-gateway-method (if (and url-gateway-local-host-regexp - (not (eq 'ssl url-gateway-method)) - (string-match - url-gateway-local-host-regexp - host)) - 'native - url-gateway-method)) - (tcp-binary-process-output-services (if (stringp service) - (list service) - (list service - (int-to-string service))))) - (and (eq url-gateway-method 'tcp) - (require 'tcp) - (setq url-gateway-method 'native - tmp-gateway-method 'native)) - (cond - ((eq tmp-gateway-method 'ssl) - (open-ssl-stream name buffer host service)) - ((eq tmp-gateway-method 'native) - (if url-broken-resolution - (setq host - (cond - ((featurep 'ange-ftp) (ange-ftp-nslookup-host host)) - ((featurep 'efs) (efs-nslookup-host host)) - ((featurep 'efs-auto) (efs-nslookup-host host)) - (t host)))) - (let ((max-retries url-connection-retries) - (cur-retries 0) - (retry t) - (errobj nil) - (conn nil)) - (while (and (not conn) retry) - (condition-case errobj - (setq conn (open-network-stream name buffer host service)) - (error - (url-save-error errobj) - (save-window-excursion - (save-excursion - (switch-to-buffer-other-window " *url-error*") - (shrink-window-if-larger-than-buffer) - (goto-char (point-min)) - (if (and (re-search-forward "in use" nil t) - (< cur-retries max-retries)) - (progn - (setq retry t - cur-retries (1+ cur-retries)) - (sleep-for 0.5)) - (setq cur-retries 0 - retry (funcall url-confirmation-func - (concat "Connection to " host - " failed, retry? ")))) - (kill-buffer (current-buffer))))))) - (if conn - (progn - (if (featurep 'mule) - (save-excursion - (set-buffer (get-buffer-create buffer)) - (setq mc-flag nil) - (if (not url-running-xemacs) - (set-process-coding-system conn *noconv* *noconv*) - (set-process-input-coding-system conn 'noconv) - (set-process-output-coding-system conn 'noconv)))) - conn) - (error "Unable to connect to %s:%s" host service)))) - ((eq tmp-gateway-method 'program) - (let ((proc (start-process name buffer url-gateway-telnet-program host - (int-to-string service))) - (tmp nil)) - (save-excursion - (set-buffer buffer) - (setq tmp (point)) - (while (not (progn - (goto-char (point-min)) - (re-search-forward - url-gateway-telnet-ready-regexp nil t))) - (url-accept-process-output proc)) - (delete-region tmp (point)) - (goto-char (point-min)) - (if (re-search-forward "connect:" nil t) - (progn - (condition-case () - (delete-process proc) - (error nil)) - (url-replace-regexp ".*connect:.*" "") - nil) - proc)))) - (t (error "Unknown url-gateway-method %s" url-gateway-method))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Miscellaneous functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-setup-privacy-info () - (interactive) - (setq url-system-type - (cond - ((or (eq url-privacy-level 'paranoid) - (and (listp url-privacy-level) - (memq 'os url-privacy-level))) - nil) - ((eq system-type 'Apple-Macintosh) "Macintosh") - ((eq system-type 'next-mach) "NeXT") - ((eq system-type 'windows-nt) "Windows-NT; 32bit") - ((eq system-type 'ms-windows) "Windows; 16bit") - ((eq system-type 'ms-dos) "MS-DOS; 32bit") - ((and (eq system-type 'vax-vms) (device-type)) - "VMS; X11") - ((eq system-type 'vax-vms) "VMS; TTY") - ((eq (device-type) 'x) "X11") - ((eq (device-type) 'ns) "NeXTStep") - ((eq (device-type) 'pm) "OS/2") - ((eq (device-type) 'win32) "Windows; 32bit") - ((eq (device-type) 'tty) "(Unix?); TTY") - (t "UnkownPlatform"))) - - ;; Set up the entity definition for PGP and PEM authentication - (setq url-pgp/pem-entity (or url-pgp/pem-entity - user-mail-address - (format "%s@%s" (user-real-login-name) - (system-name)))) - - (setq url-personal-mail-address (or url-personal-mail-address - url-pgp/pem-entity - user-mail-address)) - - (if (or (memq url-privacy-level '(paranoid high)) - (and (listp url-privacy-level) - (memq 'email url-privacy-level))) - (setq url-personal-mail-address nil)) - - (if (or (eq url-privacy-level 'paranoid) - (and (listp url-privacy-level) - (memq 'os url-privacy-level))) - (setq url-os-type nil) - (let ((vers (emacs-version))) - (if (string-match "(\\([^, )]+\\))$" vers) - (setq url-os-type (url-match vers 1)) - (setq url-os-type (symbol-name system-type)))))) - -(defun url-handle-no-scheme (url) - (let ((temp url-registered-protocols) - (found nil)) - (while (and temp (not found)) - (if (and (not (member (car (car temp)) '("auto" "www"))) - (string-match (concat "^" (car (car temp)) "\\.") - url)) - (setq found t) - (setq temp (cdr temp)))) - (cond - (found ; Found something like ftp.spry.com - (url-retrieve (concat (car (car temp)) "://" url))) - ((string-match "^www\\." url) - (url-retrieve (concat "http://" url))) - ((string-match "\\(\\.[^\\.]+\\)\\(\\.[^\\.]+\\)" url) - ;; Ok, we have at least two dots in the filename, just stick http on it - (url-retrieve (concat "http://" url))) - (t - (url-retrieve (concat "http://www." url ".com")))))) - -(defun url-setup-save-timer () - "Reset the history list timer." - (interactive) - (cond - ((featurep 'itimer) - (if (get-itimer "url-history-saver") - (delete-itimer (get-itimer "url-history-saver"))) - (start-itimer "url-history-saver" 'url-write-global-history - url-global-history-save-interval - url-global-history-save-interval)) - ((fboundp 'run-at-time) - (run-at-time url-global-history-save-interval - url-global-history-save-interval - 'url-write-global-history)) - (t nil))) - -(defvar url-download-minor-mode nil) - -(defun url-download-minor-mode (on) - (setq url-download-minor-mode (if on - (1+ (or url-download-minor-mode 0)) - (1- (or url-download-minor-mode 1)))) - (if (<= url-download-minor-mode 0) - (setq url-download-minor-mode nil))) - -(defun url-do-setup () - "Do setup - this is to avoid conflict with user settings when URL is -dumped with emacs." - (if url-setup-done - nil - - (add-minor-mode 'url-download-minor-mode " Webbing" nil) - ;; Decide what type of process-get to use - ;(url-setup-process-get) - - ;; Make OS/2 happy - (setq tcp-binary-process-input-services - (append '("http" "80") - tcp-binary-process-input-services)) - - ;; Register all the protocols we can handle - (url-register-protocol 'file) - (url-register-protocol 'ftp nil nil "21") - (url-register-protocol 'gopher nil nil "70") - (url-register-protocol 'http nil nil "80") - (url-register-protocol 'https nil nil "443") - (url-register-protocol 'nfs nil nil "2049") - (url-register-protocol 'info nil 'url-identity-expander) - (url-register-protocol 'mailserver nil 'url-identity-expander) - (url-register-protocol 'finger nil 'url-identity-expander "79") - (url-register-protocol 'mailto nil 'url-identity-expander) - (url-register-protocol 'news nil 'url-identity-expander "119") - (url-register-protocol 'nntp nil 'url-identity-expander "119") - (url-register-protocol 'irc nil 'url-identity-expander "6667") - (url-register-protocol 'rlogin) - (url-register-protocol 'shttp nil nil "80") - (url-register-protocol 'telnet) - (url-register-protocol 'tn3270) - (url-register-protocol 'wais) - (url-register-protocol 'x-exec) - (url-register-protocol 'proxy) - (url-register-protocol 'auto 'url-handle-no-scheme) - - ;; Register all the authentication schemes we can handle - (url-register-auth-scheme "basic" nil 4) - (url-register-auth-scheme "digest" nil 7) - - ;; Filename handler stuff for emacsen that support it - (url-setup-file-name-handlers) - - (setq url-cookie-file - (or url-cookie-file - (expand-file-name "~/.w3cookies"))) - - (setq url-global-history-file - (or url-global-history-file - (and (memq system-type '(ms-dos ms-windows)) - (expand-file-name "~/mosaic.hst")) - (and (memq system-type '(axp-vms vax-vms)) - (expand-file-name "~/mosaic.global-history")) - (condition-case () - (expand-file-name "~/.mosaic-global-history") - (error nil)))) - - ;; Parse the global history file if it exists, so that it can be used - ;; for URL completion, etc. - (if (and url-global-history-file - (file-exists-p url-global-history-file)) - (url-parse-global-history)) - - ;; Setup save timer - (and url-global-history-save-interval (url-setup-save-timer)) - - (if (and url-cookie-file - (file-exists-p url-cookie-file)) - (url-cookie-parse-file url-cookie-file)) - - ;; Read in proxy gateways - (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services)) - (or (getenv "NO_PROXY") - (getenv "no_PROXY") - (getenv "no_proxy"))))) - (if noproxy - (setq url-proxy-services - (cons (cons "no_proxy" - (concat "\\(" - (mapconcat - (function - (lambda (x) - (cond - ((= x ?,) "\\|") - ((= x ? ) "") - ((= x ?.) (regexp-quote ".")) - ((= x ?*) ".*") - ((= x ??) ".") - (t (char-to-string x))))) - noproxy "") "\\)")) - url-proxy-services)))) - - ;; Set the url-use-transparent with decent defaults - (if (not (eq (device-type) 'tty)) - (setq url-use-transparent nil)) - (and url-use-transparent (require 'transparent)) - - ;; Set the password entry funtion based on user defaults or guess - ;; based on which remote-file-access package they are using. - (cond - (url-passwd-entry-func nil) ; Already been set - ((boundp 'read-passwd) ; Use secure password if available - (setq url-passwd-entry-func 'read-passwd)) - ((or (featurep 'efs) ; Using EFS - (featurep 'efs-auto)) ; or autoloading efs - (if (not (fboundp 'read-passwd)) - (autoload 'read-passwd "passwd" "Read in a password" nil)) - (setq url-passwd-entry-func 'read-passwd)) - ((or (featurep 'ange-ftp) ; Using ange-ftp - (and (boundp 'file-name-handler-alist) - (not (string-match "Lucid" (emacs-version))))) - (setq url-passwd-entry-func 'ange-ftp-read-passwd)) - (t - (url-warn 'security - "Can't determine how to read passwords, winging it."))) - - ;; Set up the news service if they haven't done so - (setq url-news-server - (cond - (url-news-server url-news-server) - ((and (boundp 'gnus-default-nntp-server) - (not (equal "" gnus-default-nntp-server))) - gnus-default-nntp-server) - ((and (boundp 'gnus-nntp-server) - (not (null gnus-nntp-server)) - (not (equal "" gnus-nntp-server))) - gnus-nntp-server) - ((and (boundp 'nntp-server-name) - (not (null nntp-server-name)) - (not (equal "" nntp-server-name))) - nntp-server-name) - ((getenv "NNTPSERVER") (getenv "NNTPSERVER")) - (t "news"))) - - ;; Set up the MIME accept string if they haven't got it hardcoded yet - (or url-mime-accept-string - (setq url-mime-accept-string (url-parse-viewer-types))) - (or url-mime-encoding-string - (setq url-mime-encoding-string - (mapconcat 'car - mm-content-transfer-encodings - ", "))) - - (url-setup-privacy-info) - (run-hooks 'url-load-hook) - (setq url-setup-done t))) - -(defun url-cache-file-writable-p (file) - "Follows the documentation of file-writable-p, unlike file-writable-p." - (and (file-writable-p file) - (if (file-exists-p file) - (not (file-directory-p file)) - (file-directory-p (file-name-directory file))))) - -(defun url-prepare-cache-for-file (file) - "Makes it possible to cache data in FILE. -Creates any necessary parent directories, deleting any non-directory files -that would stop this. Returns nil if parent directories can not be -created. If FILE already exists as a non-directory, it changes -permissions of FILE or deletes FILE to make it possible to write a new -version of FILE. Returns nil if this can not be done. Returns nil if -FILE already exists as a directory. Otherwise, returns t, indicating that -FILE can be created or overwritten." - - ;; COMMENT: We don't delete directories because that requires - ;; recursively deleting the directories's contents, which might - ;; eliminate a substantial portion of the cache. - - (cond - ((url-cache-file-writable-p file) - t) - ((file-directory-p file) - nil) - (t - (catch 'upcff-tag - (let ((dir (file-name-directory file)) - dir-parent dir-last-component) - (if (string-equal dir file) - ;; *** Should I have a warning here? - ;; FILE must match a pattern like /foo/bar/, indicating it is a - ;; name only suitable for a directory. So presume we won't be - ;; able to overwrite FILE and return nil. - (throw 'upcff-tag nil)) - - ;; Make sure the containing directory exists, or throw a failure - ;; if we can't create it. - (if (file-directory-p dir) - nil - (or (fboundp 'make-directory) - (throw 'upcff-tag nil)) - (make-directory dir t) - ;; make-directory silently fails if there is an obstacle, so - ;; we must verify its results. - (if (file-directory-p dir) - nil - ;; Look at prefixes of the path to find the obstacle that is - ;; stopping us from making the directory. Unfortunately, there - ;; is no portable function in Emacs to find the parent directory - ;; of a *directory*. So this code may not work on VMS. - (while (progn - (if (eq ?/ (aref dir (1- (length dir)))) - (setq dir (substring dir 0 -1)) - ;; Maybe we're on VMS where the syntax is different. - (throw 'upcff-tag nil)) - (setq dir-parent (file-name-directory dir)) - (not (file-directory-p dir-parent))) - (setq dir dir-parent)) - ;; We have found the longest path prefix that exists as a - ;; directory. Deal with any obstacles in this directory. - (if (file-exists-p dir) - (condition-case nil - (delete-file dir) - (error (throw 'upcff-tag nil)))) - (if (file-exists-p dir) - (throw 'upcff-tag nil)) - ;; Try making the directory again. - (setq dir (file-name-directory file)) - (make-directory dir t) - (or (file-directory-p dir) - (throw 'upcff-tag nil)))) - - ;; The containing directory exists. Let's see if there is - ;; something in the way in this directory. - (if (url-cache-file-writable-p file) - (throw 'upcff-tag t) - (condition-case nil - (delete-file file) - (error (throw 'upcff-tag nil)))) - - ;; The return value, if we get this far. - (url-cache-file-writable-p file)))))) - -(defun url-store-in-cache (&optional buff) - "Store buffer BUFF in the cache" - (if (or (not (get-buffer buff)) - (member url-current-type '("www" "about" "https" "shttp" - "news" "mailto")) - (and (member url-current-type '("file" "ftp" nil)) - (not url-current-server)) - ) - nil - (save-excursion - (and buff (set-buffer buff)) - (let* ((fname (url-create-cached-filename (url-view-url t))) - (fname-hdr (concat (if (memq system-type '(ms-windows ms-dos os2)) - (url-file-extension fname t) - fname) ".hdr")) - (info (mapcar (function (lambda (var) - (cons (symbol-name var) - (symbol-value var)))) - '( url-current-content-length - url-current-file - url-current-isindex - url-current-mime-encoding - url-current-mime-headers - url-current-mime-type - url-current-port - url-current-server - url-current-type - url-current-user - )))) - (cond ((and (url-prepare-cache-for-file fname) - (url-prepare-cache-for-file fname-hdr)) - (write-region (point-min) (point-max) fname nil 5) - (set-buffer (get-buffer-create " *cache-tmp*")) - (erase-buffer) - (insert "(setq ") - (mapcar - (function - (lambda (x) - (insert (car x) " " - (cond ((null (setq x (cdr x))) "nil") - ((stringp x) (prin1-to-string x)) - ((listp x) (concat "'" (prin1-to-string x))) - ((numberp x) (int-to-string x)) - (t "'???")) "\n"))) - info) - (insert ")\n") - (write-region (point-min) (point-max) fname-hdr nil 5))))))) - - -(defun url-is-cached (url) - "Return non-nil if the URL is cached." - (let* ((fname (url-create-cached-filename url)) - (attribs (file-attributes fname))) - (and fname ; got a filename - (file-exists-p fname) ; file exists - (not (eq (nth 0 attribs) t)) ; Its not a directory - (nth 5 attribs)))) ; Can get last mod-time - -(defun url-create-cached-filename-using-md5 (url) - (if url - (expand-file-name (md5 url) - (concat url-temporary-directory "/" - (user-real-login-name))))) - -(defun url-create-cached-filename (url) - "Return a filename in the local cache for URL" - (if url - (let* ((url url) - (urlobj (if (vectorp url) - url - (url-generic-parse-url url))) - (protocol (url-type urlobj)) - (hostname (url-host urlobj)) - (host-components - (cons - (user-real-login-name) - (cons (or protocol "file") - (nreverse - (delq nil - (mm-string-to-tokens - (or hostname "localhost") ?.)))))) - (fname (url-filename urlobj))) - (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/)) - (setq fname (substring fname 1 nil))) - (if fname - (let ((slash nil)) - (setq fname - (mapconcat - (function - (lambda (x) - (cond - ((and (= ?/ x) slash) - (setq slash nil) - "%2F") - ((= ?/ x) - (setq slash t) - "/") - (t - (setq slash nil) - (char-to-string x))))) fname "")))) - - (if (and fname (memq system-type '(ms-windows ms-dos windows-nt)) - (string-match "\\([A-Za-z]\\):[/\\]" fname)) - (setq fname (concat (url-match fname 1) "/" - (substring fname (match-end 0))))) - - (setq fname (and fname - (mapconcat - (function (lambda (x) - (if (= x ?~) "" (char-to-string x)))) - fname "")) - fname (cond - ((null fname) nil) - ((or (string= "" fname) (string= "/" fname)) - url-directory-index-file) - ((= (string-to-char fname) ?/) - (if (string= (substring fname -1 nil) "/") - (concat fname url-directory-index-file) - (substring fname 1 nil))) - (t - (if (string= (substring fname -1 nil) "/") - (concat fname url-directory-index-file) - fname)))) - - ;; Honor hideous 8.3 filename limitations on dos and windows - ;; we don't have to worry about this in Windows NT/95 (or OS/2?) - (if (and fname (memq system-type '(ms-windows ms-dos))) - (let ((base (url-file-extension fname t)) - (ext (url-file-extension fname nil))) - (setq fname (concat (substring base 0 (min 8 (length base))) - (substring ext 0 (min 4 (length ext))))) - (setq host-components - (mapcar - (function - (lambda (x) - (if (> (length x) 8) - (concat - (substring x 0 8) "." - (substring x 8 (min (length x) 11))) - x))) - host-components)))) - - (and fname - (expand-file-name fname - (expand-file-name - (mapconcat 'identity host-components "/") - url-temporary-directory)))))) - -(defun url-extract-from-cache (fnam) - "Extract FNAM from the local disk cache" - (set-buffer (get-buffer-create url-working-buffer)) - (erase-buffer) - (setq url-current-mime-viewer nil) - (insert-file-contents-literally fnam) - (load (concat (if (memq system-type '(ms-windows ms-dos os2)) - (url-file-extension fnam t) - fnam) ".hdr") t t)) - -;;;###autoload -(defun url-get-url-at-point (&optional pt) - "Get the URL closest to point, but don't change your -position. Has a preference for looking backward when not -directly on a symbol." - ;; Not at all perfect - point must be right in the name. - (save-excursion - (if pt (goto-char pt)) - (let ((filename-chars "%.?@a-zA-Z0-9---()_/:~=&") start url) - (save-excursion - ;; first see if you're just past a filename - (if (not (eobp)) - (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens - (progn - (skip-chars-backward " \n\t\r({[]})") - (if (not (bobp)) - (backward-char 1))))) - (if (string-match (concat "[" filename-chars "]") - (char-to-string (following-char))) - (progn - (skip-chars-backward filename-chars) - (setq start (point)) - (skip-chars-forward filename-chars)) - (setq start (point))) - (setq url (if (fboundp 'buffer-substring-no-properties) - (buffer-substring-no-properties start (point)) - (buffer-substring start (point))))) - (if (string-match "^URL:" url) - (setq url (substring url 4 nil))) - (if (string-match "\\.$" url) - (setq url (substring url 0 -1))) - (if (not (string-match url-nonrelative-link url)) - (setq url nil)) - url))) - -(defun url-eat-trailing-space (x) - ;; Remove spaces/tabs at the end of a string - (let ((y (1- (length x))) - (skip-chars (list ? ?\t ?\n))) - (while (and (>= y 0) (memq (aref x y) skip-chars)) - (setq y (1- y))) - (substring x 0 (1+ y)))) - -(defun url-strip-leading-spaces (x) - ;; Remove spaces at the front of a string - (let ((y (1- (length x))) - (z 0) - (skip-chars (list ? ?\t ?\n))) - (while (and (<= z y) (memq (aref x z) skip-chars)) - (setq z (1+ z))) - (substring x z nil))) - -(defun url-convert-newlines-to-spaces (x) - "Convert newlines and carriage returns embedded in a string into spaces, -and swallow following whitespace. -The argument is not side-effected, but may be returned by this function." - (if (string-match "[\n\r]+\\s-*" x) ; [\\n\\r\\t ] - (concat (substring x 0 (match-beginning 0)) " " - (url-convert-newlines-to-spaces - (substring x (match-end 0)))) - x)) - -;; Test cases -;; (url-convert-newlines-to-spaces "foo bar") ; nothing happens -;; (url-convert-newlines-to-spaces "foo\n \t bar") ; whitespace converted -;; -;; This implementation doesn't mangle the match-data, is fast, and doesn't -;; create garbage, but it leaves whitespace. -;; (defun url-convert-newlines-to-spaces (x) -;; "Convert newlines and carriage returns embedded in a string into spaces. -;; The string is side-effected, then returned." -;; (let ((i 0) -;; (limit (length x))) -;; (while (< i limit) -;; (if (or (= ?\n (aref x i)) -;; (= ?\r (aref x i))) -;; (aset x i ? )) -;; (setq i (1+ i))) -;; x)) - -(defun url-expand-file-name (url &optional default) - "Convert URL to a fully specified URL, and canonicalize it. -Second arg DEFAULT is a URL to start with if URL is relative. -If DEFAULT is nil or missing, the current buffer's URL is used. -Path components that are `.' are removed, and -path components followed by `..' are removed, along with the `..' itself." - (if url - (setq url (mapconcat (function (lambda (x) - (if (= x ?\n) "" (char-to-string x)))) - (url-strip-leading-spaces - (url-eat-trailing-space url)) ""))) - (cond - ((null url) nil) ; Something hosed! Be graceful - ((string-match "^#" url) ; Offset link, use it raw - url) - (t - (let* ((urlobj (url-generic-parse-url url)) - (inhibit-file-name-handlers t) - (defobj (cond - ((vectorp default) default) - (default (url-generic-parse-url default)) - ((and (null default) url-current-object) - url-current-object) - (t (url-generic-parse-url (url-view-url t))))) - (expander (cdr-safe - (cdr-safe - (assoc (or (url-type urlobj) - (url-type defobj)) - url-registered-protocols))))) - (if (string-match "^//" url) - (setq urlobj (url-generic-parse-url (concat (url-type defobj) ":" - url)))) - (if (fboundp expander) - (funcall expander urlobj defobj) - (message "Unknown URL scheme: %s" (or (url-type urlobj) - (url-type defobj))) - (url-identity-expander urlobj defobj)) - (url-recreate-url urlobj))))) - -(defun url-default-expander (urlobj defobj) - ;; The default expansion routine - urlobj is modified by side effect! - (url-set-type urlobj (or (url-type urlobj) (url-type defobj))) - (url-set-port urlobj (or (url-port urlobj) - (and (string= (url-type urlobj) - (url-type defobj)) - (url-port defobj)))) - (if (not (string= "file" (url-type urlobj))) - (url-set-host urlobj (or (url-host urlobj) (url-host defobj)))) - (if (string= "ftp" (url-type urlobj)) - (url-set-user urlobj (or (url-user urlobj) (url-user defobj)))) - (if (string= (url-filename urlobj) "") - (url-set-filename urlobj "/")) - (if (string-match "^/" (url-filename urlobj)) - nil - (url-set-filename urlobj - (url-remove-relative-links - (concat (url-basepath (url-filename defobj)) - (url-filename urlobj)))))) - -(defun url-identity-expander (urlobj defobj) - (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))) - -(defun url-hexify-string (str) - "Escape characters in a string" - (if (and (featurep 'mule) str) - (setq str (code-convert-string - str *internal* url-mule-retrieval-coding-system))) - (setq str (mapconcat - (function - (lambda (char) - (if (or (> char ?z) - (< char ?-) - (and (< char ?a) - (> char ?Z)) - (and (< char ?@) - (>= char ?:))) - (if (< char 16) - (upcase (format "%%0%x" char)) - (upcase (format "%%%x" char))) - (char-to-string char)))) str ""))) - -(defun url-make-sequence (start end) - "Make a sequence (list) of numbers from START to END" - (cond - ((= start end) '()) - ((> start end) '()) - (t - (let ((sqnc '())) - (while (<= start end) - (setq sqnc (cons end sqnc) - end (1- end))) - sqnc)))) - -(defun url-file-extension (fname &optional x) - "Return the filename extension of FNAME. If optional variable X is t, -then return the basename of the file with the extension stripped off." - (if (and fname (string-match "\\.[^./]+$" fname)) - (if x (substring fname 0 (match-beginning 0)) - (substring fname (match-beginning 0) nil)) - ;; - ;; If fname has no extension, and x then return fname itself instead of - ;; nothing. When caching it allows the correct .hdr file to be produced - ;; for filenames without extension. - ;; - (if x - fname - ""))) - -(defun url-basepath (file &optional x) - "Return the base pathname of FILE, or the actual filename if X is true" - (cond - ((null file) "") - (x (file-name-nondirectory file)) - (t (file-name-directory file)))) - -(defun url-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - -(defun url-unhex-string (str) - "Remove %XXX embedded spaces, etc in a url" - (setq str (or str "")) - (let ((tmp "")) - (while (string-match "%[0-9a-f][0-9a-f]" str) - (let* ((start (match-beginning 0)) - (ch1 (url-unhex (elt str (+ start 1)))) - (code (+ (* 16 ch1) - (url-unhex (elt str (+ start 2)))))) - (setq tmp - (concat - tmp (substring str 0 start) - (if (or (= code ?\n) (= code ?\r)) " " (char-to-string code))) - str (substring str (match-end 0))))) - (setq tmp (concat tmp str)) - tmp)) - -(defun url-clean-text () - "Clean up a buffer, removing any excess garbage from a gateway mechanism, -and decoding any MIME content-transfer-encoding used." - (set-buffer url-working-buffer) - (goto-char (point-min)) - (url-replace-regexp "Connection closed by.*" "") - (goto-char (point-min)) - (url-replace-regexp "Process WWW.*" "")) - -(defun url-remove-compressed-extensions (filename) - (while (assoc (url-file-extension filename) url-uncompressor-alist) - (setq filename (url-file-extension filename t))) - filename) - -(defun url-uncompress () - "Do any necessary uncompression on `url-working-buffer'" - (set-buffer url-working-buffer) - (if (not url-inhibit-uncompression) - (let* ((extn (url-file-extension url-current-file)) - (decoder nil) - (code-1 (cdr-safe - (assoc "content-transfer-encoding" - url-current-mime-headers))) - (code-2 (cdr-safe - (assoc "content-encoding" url-current-mime-headers))) - (code-3 (and (not code-1) (not code-2) - (cdr-safe (assoc extn url-uncompressor-alist)))) - (done nil) - (default-process-coding-system - (if (featurep 'mule) (cons *noconv* *noconv*)))) - (mapcar - (function - (lambda (code) - (setq decoder (and (not (member code done)) - (cdr-safe - (assoc code mm-content-transfer-encodings))) - done (cons code done)) - (cond - ((null decoder) nil) - ((stringp decoder) - (message "Decoding...") - (call-process-region (point-min) (point-max) decoder t t nil) - (message "Decoding... done.")) - ((listp decoder) - (apply 'call-process-region (point-min) (point-max) - (car decoder) t t nil (cdr decoder))) - ((and (symbolp decoder) (fboundp decoder)) - (message "Decoding...") - (funcall decoder (point-min) (point-max)) - (message "Decoding... done.")) - (t - (error "Bad entry for %s in `mm-content-transfer-encodings'" - code))))) - (list code-1 code-2 code-3)))) - (set-buffer-modified-p nil)) - -(defun url-filter (proc string) - (save-excursion - (set-buffer url-working-buffer) - (insert string) - (if (string-match "\nConnection closed by" string) - (progn (set-process-filter proc nil) - (url-sentinel proc string)))) - string) - -(defun url-default-callback (buf) - (url-download-minor-mode nil) - (cond - ((save-excursion (set-buffer buf) - (and url-current-callback-func - (fboundp url-current-callback-func))) - (save-excursion - (save-window-excursion - (set-buffer buf) - (cond - ((listp url-current-callback-data) - (apply url-current-callback-func - url-current-callback-data)) - (url-current-callback-data - (funcall url-current-callback-func - url-current-callback-data)) - (t - (funcall url-current-callback-func)))))) - ((fboundp 'w3-sentinel) - (set-variable 'w3-working-buffer buf) - (w3-sentinel)) - (t - (message "Retrieval for %s complete." buf)))) - -(defun url-sentinel (proc string) - (if (buffer-name (process-buffer proc)) - (save-excursion - (set-buffer (get-buffer (process-buffer proc))) - (remove-hook 'after-change-functions 'url-after-change-function) - (let ((status nil) - (url-working-buffer (current-buffer))) - (if url-be-asynchronous - (progn - (widen) - (url-clean-text) - (cond - ((and (null proc) (not (get-buffer url-working-buffer))) nil) - ((url-mime-response-p) - (setq status (url-parse-mime-headers)))) - (if (not url-current-mime-type) - (setq url-current-mime-type (mm-extension-to-mime - (url-file-extension - url-current-file)))))) - (if (member status '(401 301 302 303 204)) - nil - (funcall url-default-retrieval-proc (buffer-name))))) - (url-warn 'url (format "Process %s completed with no buffer!" proc)))) - -(defun url-remove-relative-links (name) - ;; Strip . and .. from pathnames - (let ((new (if (not (string-match "^/" name)) - (concat "/" name) - name))) - (while (string-match "/\\([^/]*/\\.\\./\\)" new) - (setq new (concat (substring new 0 (match-beginning 1)) - (substring new (match-end 1))))) - (while (string-match "/\\(\\./\\)" new) - (setq new (concat (substring new 0 (match-beginning 1)) - (substring new (match-end 1))))) - (while (string-match "^/\\.\\.\\(/\\)" new) - (setq new (substring new (match-beginning 1) nil))) - new)) - -(defun url-truncate-url-for-viewing (url &optional width) - "Return a shortened version of URL that is WIDTH characters or less wide. -WIDTH defaults to the current frame width." - (let* ((fr-width (or width (frame-width))) - (str-width (length url)) - (tail (file-name-nondirectory url)) - (fname nil) - (modified 0) - (urlobj nil)) - ;; The first thing that can go are the search strings - (if (and (>= str-width fr-width) - (string-match "?" url)) - (setq url (concat (substring url 0 (match-beginning 0)) "?...") - str-width (length url) - tail (file-name-nondirectory url))) - (if (< str-width fr-width) - nil ; Hey, we are done! - (setq urlobj (url-generic-parse-url url) - fname (url-filename urlobj) - fr-width (- fr-width 4)) - (while (and (>= str-width fr-width) - (string-match "/" fname)) - (setq fname (substring fname (match-end 0) nil) - modified (1+ modified)) - (url-set-filename urlobj fname) - (setq url (url-recreate-url urlobj) - str-width (length url))) - (if (> modified 1) - (setq fname (concat "/.../" fname)) - (setq fname (concat "/" fname))) - (url-set-filename urlobj fname) - (setq url (url-recreate-url urlobj))) - url)) - -(defun url-view-url (&optional no-show) - "View the current document's URL. Optional argument NO-SHOW means -just return the URL, don't show it in the minibuffer." - (interactive) - (let ((url "")) - (cond - ((equal url-current-type "gopher") - (setq url (format "%s://%s%s/%s" - url-current-type url-current-server - (if (or (null url-current-port) - (string= "70" url-current-port)) "" - (concat ":" url-current-port)) - url-current-file))) - ((equal url-current-type "news") - (setq url (concat "news:" - (if (not (equal url-current-server - url-news-server)) - (concat "//" url-current-server - (if (or (null url-current-port) - (string= "119" url-current-port)) - "" - (concat ":" url-current-port)) "/")) - url-current-file))) - ((equal url-current-type "about") - (setq url (concat "about:" url-current-file))) - ((member url-current-type '("http" "shttp" "https")) - (setq url (format "%s://%s%s/%s" url-current-type url-current-server - (if (or (null url-current-port) - (string= "80" url-current-port)) - "" - (concat ":" url-current-port)) - (if (and url-current-file - (= ?/ (string-to-char url-current-file))) - (substring url-current-file 1 nil) - url-current-file)))) - ((equal url-current-type "ftp") - (setq url (format "%s://%s%s/%s" url-current-type - (if (and url-current-user - (not (string= "anonymous" url-current-user))) - (concat url-current-user "@") "") - url-current-server - (if (and url-current-file - (= ?/ (string-to-char url-current-file))) - (substring url-current-file 1 nil) - url-current-file)))) - ((and (member url-current-type '("file" nil)) url-current-file) - (setq url (format "file:%s" url-current-file))) - ((equal url-current-type "www") - (setq url (format "www:/%s/%s" url-current-server url-current-file))) - (t - (setq url nil))) - (if (not no-show) (message "%s" url) url))) - -(defun url-parse-Netscape-history (fname) - ;; Parse a Netscape/X style global history list. - (let (pos ; Position holder - url ; The URL - time) ; Last time accessed - (goto-char (point-min)) - (skip-chars-forward "^\n") - (skip-chars-forward "\n \t") ; Skip past the tag line - (setq url-global-history-hash-table (url-make-hashtable 131)) - ;; Here we will go to the end of the line and - ;; skip back over a token, since we might run - ;; into spaces in URLs, depending on how much - ;; smarter netscape is than the old XMosaic :) - (while (not (eobp)) - (setq pos (point)) - (end-of-line) - (skip-chars-backward "^ \t") - (skip-chars-backward " \t") - (setq url (buffer-substring pos (point)) - pos (1+ (point))) - (skip-chars-forward "^\n") - (setq time (buffer-substring pos (point))) - (skip-chars-forward "\n") - (setq url-history-changed-since-last-save t) - (url-puthash url time url-global-history-hash-table)))) - -(defun url-parse-Mosaic-history-v1 (fname) - ;; Parse an NCSA Mosaic/X style global history list - (goto-char (point-min)) - (skip-chars-forward "^\n") - (skip-chars-forward "\n \t") ; Skip past the tag line - (skip-chars-forward "^\n") - (skip-chars-forward "\n \t") ; Skip past the second tag line - (setq url-global-history-hash-table (url-make-hashtable 131)) - (let (pos ; Temporary position holder - bol ; Beginning-of-line - url ; URL - time ; Time - last-end ; Last ending point - ) - (while (not (eobp)) - (setq bol (point)) - (end-of-line) - (setq pos (point) - last-end (point)) - (skip-chars-backward "^ \t" bol) ; Skip over year - (skip-chars-backward " \t" bol) - (skip-chars-backward "^ \t" bol) ; Skip over time - (skip-chars-backward " \t" bol) - (skip-chars-backward "^ \t" bol) ; Skip over day # - (skip-chars-backward " \t" bol) - (skip-chars-backward "^ \t" bol) ; Skip over month - (skip-chars-backward " \t" bol) - (skip-chars-backward "^ \t" bol) ; Skip over day abbrev. - (if (bolp) - nil ; Malformed entry!!! Ack! Bailout! - (setq time (buffer-substring pos (point))) - (skip-chars-backward " \t") - (setq pos (point))) - (beginning-of-line) - (setq url (buffer-substring (point) pos)) - (goto-char (min (1+ last-end) (point-max))) ; Goto next line - (if (/= (length url) 0) - (progn - (setq url-history-changed-since-last-save t) - (url-puthash url time url-global-history-hash-table)))))) - -(defun url-parse-Mosaic-history-v2 (fname) - ;; Parse an NCSA Mosaic/X style global history list (version 2) - (goto-char (point-min)) - (skip-chars-forward "^\n") - (skip-chars-forward "\n \t") ; Skip past the tag line - (skip-chars-forward "^\n") - (skip-chars-forward "\n \t") ; Skip past the second tag line - (setq url-global-history-hash-table (url-make-hashtable 131)) - (let (pos ; Temporary position holder - bol ; Beginning-of-line - url ; URL - time ; Time - last-end ; Last ending point - ) - (while (not (eobp)) - (setq bol (point)) - (end-of-line) - (setq pos (point) - last-end (point)) - (skip-chars-backward "^ \t" bol) ; Skip over time - (if (bolp) - nil ; Malformed entry!!! Ack! Bailout! - (setq time (buffer-substring pos (point))) - (skip-chars-backward " \t") - (setq pos (point))) - (beginning-of-line) - (setq url (buffer-substring (point) pos)) - (goto-char (min (1+ last-end) (point-max))) ; Goto next line - (if (/= (length url) 0) - (progn - (setq url-history-changed-since-last-save t) - (url-puthash url time url-global-history-hash-table)))))) - -(defun url-parse-Emacs-history (&optional fname) - ;; Parse out the Emacs-w3 global history file for completion, etc. - (or fname (setq fname (expand-file-name url-global-history-file))) - (cond - ((not (file-exists-p fname)) - (message "%s does not exist." fname)) - ((not (file-readable-p fname)) - (message "%s is unreadable." fname)) - (t - (condition-case () - (load fname nil t) - (error (message "Could not load %s" fname))) - (if (boundp 'url-global-history-completion-list) - ;; Hey! Automatic conversion of old format! - (progn - (setq url-global-history-hash-table (url-make-hashtable 131) - url-history-changed-since-last-save t) - (mapcar (function - (lambda (x) - (url-puthash (car x) (cdr x) - url-global-history-hash-table))) - (symbol-value 'url-global-history-completion-list))))))) - -(defun url-parse-global-history (&optional fname) - ;; Parse out the mosaic global history file for completions, etc. - (or fname (setq fname (expand-file-name url-global-history-file))) - (cond - ((not (file-exists-p fname)) - (message "%s does not exist." fname)) - ((not (file-readable-p fname)) - (message "%s is unreadable." fname)) - (t - (save-excursion - (set-buffer (get-buffer-create " *url-tmp*")) - (erase-buffer) - (insert-file-contents-literally fname) - (goto-char (point-min)) - (cond - ((looking-at "(setq") (url-parse-Emacs-history fname)) - ((looking-at "ncsa-mosaic-.*-1$") (url-parse-Mosaic-history-v1 fname)) - ((looking-at "ncsa-mosaic-.*-2$") (url-parse-Mosaic-history-v2 fname)) - ((or (looking-at "MCOM-") (looking-at "netscape")) - (url-parse-Netscape-history fname)) - (t - (url-warn 'url (format "Cannot deduce type of history file: %s" - fname)))))))) - -(defun url-write-Emacs-history (fname) - ;; Write an Emacs-w3 style global history list into FNAME - (erase-buffer) - (let ((count 0)) - (url-maphash (function - (lambda (key value) - (setq count (1+ count)) - (insert "(url-puthash " - (if (stringp key) - (prin1-to-string key) - (concat "\"" (symbol-name key) "\"")) - (if (not (stringp value)) " '" "") - (prin1-to-string value) - " url-global-history-hash-table)\n"))) - url-global-history-hash-table) - (goto-char (point-min)) - (insert (format - "(setq url-global-history-hash-table (url-make-hashtable %d))\n" - (/ count 4))) - (goto-char (point-max)) - (insert "\n") - (write-file fname))) - -(defun url-write-Netscape-history (fname) - ;; Write a Netscape-style global history list into FNAME - (erase-buffer) - (let ((last-valid-time "785305714")) ; Picked out of thin air, - ; in case first in assoc list - ; doesn't have a valid time - (goto-char (point-min)) - (insert "MCOM-Global-history-file-1\n") - (url-maphash (function - (lambda (url time) - (if (or (not (stringp time)) (string-match " \t" time)) - (setq time last-valid-time) - (setq last-valid-time time)) - (insert (concat (if (stringp url) - url - (symbol-name url)) - " " time "\n")))) - url-global-history-hash-table) - (write-file fname))) - -(defun url-write-Mosaic-history-v1 (fname) - ;; Write a Mosaic/X-style global history list into FNAME - (erase-buffer) - (goto-char (point-min)) - (insert "ncsa-mosaic-history-format-1\nGlobal\n") - (url-maphash (function - (lambda (url time) - (if (listp time) - (setq time (current-time-string time))) - (if (or (not (stringp time)) - (not (string-match " " time))) - (setq time (current-time-string))) - (insert (concat (if (stringp url) - url - (symbol-name url)) - " " time "\n")))) - url-global-history-hash-table) - (write-file fname)) - -(defun url-write-Mosaic-history-v2 (fname) - ;; Write a Mosaic/X-style global history list into FNAME - (let ((last-valid-time "827250806")) - (erase-buffer) - (goto-char (point-min)) - (insert "ncsa-mosaic-history-format-2\nGlobal\n") - (url-maphash (function - (lambda (url time) - (if (listp time) - (setq time last-valid-time) - (setq last-valid-time time)) - (if (not (stringp time)) - (setq time last-valid-time)) - (insert (concat (if (stringp url) - url - (symbol-name url)) - " " time "\n")))) - url-global-history-hash-table) - (write-file fname))) - -(defun url-write-global-history (&optional fname) - "Write the global history file into `url-global-history-file'. -The type of data written is determined by what is in the file to begin -with. If the type of storage cannot be determined, then prompt the -user for what type to save as." - (interactive) - (or fname (setq fname (expand-file-name url-global-history-file))) - (cond - ((not url-history-changed-since-last-save) nil) - ((not (file-writable-p fname)) - (message "%s is unwritable." fname)) - (t - (let ((make-backup-files nil) - (version-control nil) - (require-final-newline t)) - (save-excursion - (set-buffer (get-buffer-create " *url-tmp*")) - (erase-buffer) - (condition-case () - (insert-file-contents-literally fname) - (error nil)) - (goto-char (point-min)) - (cond - ((looking-at "ncsa-mosaic-.*-1$") (url-write-Mosaic-history-v1 fname)) - ((looking-at "ncsa-mosaic-.*-2$") (url-write-Mosaic-history-v2 fname)) - ((looking-at "MCOM-") (url-write-Netscape-history fname)) - ((looking-at "netscape") (url-write-Netscape-history fname)) - ((looking-at "(setq") (url-write-Emacs-history fname)) - (t (url-write-Emacs-history fname))) - (kill-buffer (current-buffer)))))) - (setq url-history-changed-since-last-save nil)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The main URL fetching interface -;;; ------------------------------- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;###autoload -(defun url-popup-info (url) - "Retrieve the HTTP/1.0 headers and display them in a temp buffer." - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj)) - data) - (cond - ((string= type "http") - (let ((url-request-method "HEAD") - (url-automatic-caching nil) - (url-inhibit-mime-parsing t) - (url-working-buffer " *popup*")) - (save-excursion - (set-buffer (get-buffer-create url-working-buffer)) - (erase-buffer) - (setq url-be-asynchronous nil) - (url-retrieve url) - (subst-char-in-region (point-min) (point-max) ?\r ? ) - (buffer-string)))) - ((or (string= type "file") (string= type "ftp")) - (setq data (url-file-attributes url)) - (set-buffer (get-buffer-create - (url-generate-new-buffer-name "*Header Info*"))) - (erase-buffer) - (if data - (concat (if (stringp (nth 0 data)) - (concat " Linked to: " (nth 0 data)) - (concat " Directory: " (if (nth 0 data) "Yes" "No"))) - "\n Links: " (int-to-string (nth 1 data)) - "\n File UID: " (int-to-string (nth 2 data)) - "\n File GID: " (int-to-string (nth 3 data)) - "\n Last Access: " (current-time-string (nth 4 data)) - "\nLast Modified: " (current-time-string (nth 5 data)) - "\n Last Changed: " (current-time-string (nth 6 data)) - "\n Size (bytes): " (int-to-string (nth 7 data)) - "\n File Type: " (or (nth 8 data) "text/plain")) - (concat "No info found for " url))) - ((and (string= type "news") (string-match "@" url)) - (let ((art (url-filename urlobj))) - (if (not (string= (substring art -1 nil) ">")) - (setq art (concat "<" art ">"))) - (url-get-headers-from-article-id art))) - (t (concat "Don't know how to find information on " url))))) - -(defun url-decode-text () - ;; Decode text transmitted by NNTP. - ;; 0. Delete status line. - ;; 1. Delete `^M' at end of line. - ;; 2. Delete `.' at end of buffer (end of text mark). - ;; 3. Delete `.' at beginning of line." - (save-excursion - (set-buffer nntp-server-buffer) - ;; Insert newline at end of buffer. - (goto-char (point-max)) - (if (not (bolp)) - (insert "\n")) - ;; Delete status line. - (goto-char (point-min)) - (delete-region (point) (progn (forward-line 1) (point))) - ;; Delete `^M' at end of line. - ;; (replace-regexp "\r$" "") - (while (not (eobp)) - (end-of-line) - (if (= (preceding-char) ?\r) - (delete-char -1)) - (forward-line 1) - ) - ;; Delete `.' at end of buffer (end of text mark). - (goto-char (point-max)) - (forward-line -1) ;(beginning-of-line) - (if (looking-at "^\\.$") - (delete-region (point) (progn (forward-line 1) (point)))) - ;; Replace `..' at beginning of line with `.'. - (goto-char (point-min)) - ;; (replace-regexp "^\\.\\." ".") - (while (search-forward "\n.." nil t) - (delete-char -1)) - )) - -(defun url-get-headers-from-article-id (art) - ;; Return the HEAD of ART (a usenet news article) - (cond - ((string-match "flee" nntp-version) - (nntp/command "HEAD" art) - (save-excursion - (set-buffer nntp-server-buffer) - (while (progn (goto-char (point-min)) - (not (re-search-forward "^.\r*$" nil t))) - (url-accept-process-output nntp/connection)))) - (t - (nntp-send-command "^\\.\r$" "HEAD" art) - (url-decode-text))) - (save-excursion - (set-buffer nntp-server-buffer) - (buffer-string))) - -(defvar url-external-retrieval-program "www" - "*Name of the external executable to run to retrieve URLs.") - -(defvar url-external-retrieval-args '("-source") - "*A list of arguments to pass to `url-external-retrieval-program' to -retrieve a URL by its HTML source.") - -(defun url-retrieve-externally (url &optional no-cache) - (if (get-buffer url-working-buffer) - (save-excursion - (set-buffer url-working-buffer) - (set-buffer-modified-p nil) - (kill-buffer url-working-buffer))) - (set-buffer (get-buffer-create url-working-buffer)) - (let* ((args (append url-external-retrieval-args (list url))) - (urlobj (url-generic-parse-url url)) - (type (url-type urlobj))) - (if (or (member type '("www" "about" "mailto" "mailserver")) - (url-file-directly-accessible-p urlobj)) - (url-retrieve-internally url) - (url-lazy-message "Retrieving %s..." url) - (apply 'call-process url-external-retrieval-program - nil t nil args) - (url-lazy-message "Retrieving %s... done" url) - (if (and type urlobj) - (setq url-current-server (url-host urlobj) - url-current-type (url-type urlobj) - url-current-port (url-port urlobj) - url-current-file (url-filename urlobj))) - (if (member url-current-file '("/" "")) - (setq url-current-mime-type "text/html"))))) - -(defun url-get-normalized-date (&optional specified-time) - ;; Return a 'real' date string that most HTTP servers can understand. - (require 'timezone) - (let* ((raw (if specified-time (current-time-string specified-time) - (current-time-string))) - (gmt (timezone-make-date-arpa-standard raw - (nth 1 (current-time-zone)) - "GMT")) - (parsed (timezone-parse-date gmt)) - (day (cdr-safe (assoc (substring raw 0 3) weekday-alist))) - (year nil) - (month (car - (rassoc - (string-to-int (aref parsed 1)) monthabbrev-alist))) - ) - (setq day (or (car-safe (rassoc day weekday-alist)) - (substring raw 0 3)) - year (aref parsed 0)) - ;; This is needed for plexus servers, or the server will hang trying to - ;; parse the if-modified-since header. Hopefully, I can take this out - ;; soon. - (if (and year (> (length year) 2)) - (setq year (substring year -2 nil))) - - (concat day ", " (aref parsed 2) "-" month "-" year " " - (aref parsed 3) " " (or (aref parsed 4) - (concat "[" (nth 1 (current-time-zone)) - "]"))))) - -;;;###autoload -(defun url-cache-expired (url mod) - "Return t iff a cached file has expired." - (if (not (string-match url-nonrelative-link url)) - t - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj))) - (cond - (url-standalone-mode - (not (file-exists-p (url-create-cached-filename urlobj)))) - ((string= type "http") - (if (not url-standalone-mode) t - (not (file-exists-p (url-create-cached-filename urlobj))))) - ((not (fboundp 'current-time)) - t) - ((member type '("file" "ftp")) - (if (or (equal mod '(0 0)) (not mod)) - (return t) - (or (> (nth 0 mod) (nth 0 (current-time))) - (> (nth 1 mod) (nth 1 (current-time)))))) - (t nil))))) - -(defun url-retrieve-internally (url &optional no-cache) - (if (get-buffer url-working-buffer) - (save-excursion - (set-buffer url-working-buffer) - (erase-buffer) - (setq url-current-can-be-cached (not no-cache)) - (set-buffer-modified-p nil))) - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj)) - (url-using-proxy (and - (url-host urlobj) - (if (assoc "no_proxy" url-proxy-services) - (not (string-match - (cdr - (assoc "no_proxy" url-proxy-services)) - (url-host urlobj))) - t) - (cdr (assoc type url-proxy-services)))) - (handler nil) - (original-url url) - (cached nil) - (tmp url-current-file)) - (if url-using-proxy (setq type "proxy")) - (setq cached (url-is-cached url) - cached (and cached (not (url-cache-expired url cached))) - handler (if cached 'url-extract-from-cache - (car-safe - (cdr-safe (assoc (or type "auto") - url-registered-protocols)))) - url (if cached (url-create-cached-filename url) url)) - (save-excursion - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-can-be-cached (not no-cache))) -; (if url-be-asynchronous -; (url-download-minor-mode t)) - (if (and handler (fboundp handler)) - (funcall handler url) - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-file tmp) - (erase-buffer) - (insert " Link Error! \n" - "

    An error has occurred...

    \n" - (format "The link type `%s'" type) - " is unrecognized or unsupported at this time.

    \n" - "If you feel this is an error, please " - "send me mail." - "

    William Perry

    " - "
    " url-bug-address "
    ") - (setq url-current-file "error.html")) - (if (and - (not url-be-asynchronous) - (get-buffer url-working-buffer)) - (progn - (set-buffer url-working-buffer) - (if (not url-current-object) - (setq url-current-object urlobj)) - (url-clean-text))) - (cond - ((equal type "wais") nil) - ((and url-be-asynchronous (not cached) (member type '("http" "proxy"))) - nil) - (url-be-asynchronous - (funcall url-default-retrieval-proc (buffer-name))) - ((not (get-buffer url-working-buffer)) nil) - ((and (not url-inhibit-mime-parsing) - (or cached (url-mime-response-p t))) - (or cached (url-parse-mime-headers nil t)))) - (if (and (or (not url-be-asynchronous) - (not (equal type "http"))) - (not url-current-mime-type)) - (if (url-buffer-is-hypertext) - (setq url-current-mime-type "text/html") - (setq url-current-mime-type (mm-extension-to-mime - (url-file-extension - url-current-file))))) - (if (and url-automatic-caching url-current-can-be-cached - (not url-be-asynchronous)) - (save-excursion - (url-store-in-cache url-working-buffer))) - (if (not (url-hashtablep url-global-history-hash-table)) - (setq url-global-history-hash-table (url-make-hashtable 131))) - (if (not (string-match "^about:" original-url)) - (progn - (setq url-history-changed-since-last-save t) - (url-puthash original-url (current-time) - url-global-history-hash-table))) - cached)) - -;;;###autoload -(defun url-retrieve (url &optional no-cache expected-md5) - "Retrieve a document over the World Wide Web. -The document should be specified by its fully specified -Uniform Resource Locator. No parsing is done, just return the -document as the server sent it. The document is left in the -buffer specified by url-working-buffer. url-working-buffer is killed -immediately before starting the transfer, so that no buffer-local -variables interfere with the retrieval. HTTP/1.0 redirection will -be honored before this function exits." - (url-do-setup) - (if (and (fboundp 'set-text-properties) - (subrp (symbol-function 'set-text-properties))) - (set-text-properties 0 (length url) nil url)) - (if (and url (string-match "^url:" url)) - (setq url (substring url (match-end 0) nil))) - (let ((status (url-retrieve-internally url no-cache))) - (if (and expected-md5 url-check-md5s) - (let ((cur-md5 (md5 (current-buffer)))) - (if (not (string= cur-md5 expected-md5)) - (and (not (funcall url-confirmation-func - "MD5s do not match, use anyway? ")) - (error "MD5 error."))))) - status)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; How to register a protocol -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-register-protocol (protocol &optional retrieve expander defport) - "Register a protocol with the URL retrieval package. -PROTOCOL is the type of protocol being registers (http, nntp, etc), - and is the first chunk of the URL. ie: http:// URLs will be - handled by the protocol registered as 'http'. PROTOCOL can - be either a symbol or a string - it is converted to a string, - and lowercased before being registered. -RETRIEVE (optional) is the function to be called with a url as its - only argument. If this argument is omitted, then this looks - for a function called 'url-PROTOCOL'. A warning is shown if - the function is undefined, but the protocol is still - registered. -EXPANDER (optional) is the function to call to expand a relative link - of type PROTOCOL. If omitted, this defaults to - `url-default-expander' - -Any proxy information is read in from environment variables at this -time, so this function should only be called after dumping emacs." - (let* ((protocol (cond - ((stringp protocol) (downcase protocol)) - ((symbolp protocol) (downcase (symbol-name protocol))) - (t nil))) - - (retrieve (or retrieve (intern (concat "url-" protocol)))) - (expander (or expander 'url-default-expander)) - (cur-protocol (assoc protocol url-registered-protocols)) - (urlobj nil) - (cur-proxy (assoc protocol url-proxy-services)) - (env-proxy (or (getenv (concat protocol "_proxy")) - (getenv (concat protocol "_PROXY")) - (getenv (upcase (concat protocol "_PROXY")))))) - - (if (not protocol) - (error "Invalid data to url-register-protocol.")) - - (if (not (fboundp retrieve)) - (message "Warning: %s registered, but no function found." protocol)) - - ;; Store the default port, if none previously specified and - ;; defport given - (if (and defport (not (assoc protocol url-default-ports))) - (setq url-default-ports (cons (cons protocol defport) - url-default-ports))) - - ;; Store the appropriate information for later - (if cur-protocol - (setcdr cur-protocol (cons retrieve expander)) - (setq url-registered-protocols (cons (cons protocol - (cons retrieve expander)) - url-registered-protocols))) - - ;; Store any proxying information - this will not overwrite an old - ;; entry, so that people can still set this information in their - ;; .emacs file - (cond - (cur-proxy nil) ; Keep their old settings - ((null env-proxy) nil) ; No proxy setup - ;; First check if its something like hostname:port - ((string-match "^\\([^:]+\\):\\([0-9]+\\)$" env-proxy) - (setq urlobj (url-generic-parse-url nil)) ; Get a blank object - (url-set-type urlobj "http") - (url-set-host urlobj (url-match env-proxy 1)) - (url-set-port urlobj (url-match env-proxy 2))) - ;; Then check if its a fully specified URL - ((string-match url-nonrelative-link env-proxy) - (setq urlobj (url-generic-parse-url env-proxy)) - (url-set-type urlobj "http") - (url-set-target urlobj nil)) - ;; Finally, fall back on the assumption that its just a hostname - (t - (setq urlobj (url-generic-parse-url nil)) ; Get a blank object - (url-set-type urlobj "http") - (url-set-host urlobj env-proxy))) - - (if (and (not cur-proxy) urlobj) - (progn - (setq url-proxy-services - (cons (cons protocol (url-recreate-url urlobj)) - url-proxy-services)) - (message "Using a proxy for %s..." protocol))))) - -(provide 'url) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/url/urlauth.el --- a/lisp/url/urlauth.el Mon Aug 13 08:48:18 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,305 +0,0 @@ -;;; urlauth.el,v --- Uniform Resource Locator authorization modules -;; Author: wmperry -;; Created: 1995/11/19 01:02:26 -;; Version: 1.3 -;; Keywords: comm, data, processes, hypermedia - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'url-vars) -(require 'url-parse) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Basic authorization code -;;; ------------------------ -;;; This implements the BASIC authorization type. See the online -;;; documentation at -;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html -;;; for the complete documentation on this type. -;;; -;;; This is very insecure, but it works as a proof-of-concept -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar url-basic-auth-storage nil - "Where usernames and passwords are stored. Its value is an assoc list of -assoc lists. The first assoc list is keyed by the server name. The cdr of -this is an assoc list based on the 'directory' specified by the url we are -looking up.") - -(defun url-basic-auth (url &optional prompt overwrite realm args) - "Get the username/password for the specified URL. -If optional argument PROMPT is non-nil, ask for the username/password -to use for the url and its descendants. If optional third argument -OVERWRITE is non-nil, overwrite the old username/password pair if it -is found in the assoc list. If REALM is specified, use that as the realm -instead of the pathname inheritance method." - (let* ((href (if (stringp url) - (url-generic-parse-url url) - url)) - (server (or (url-host href) url-current-server)) - (port (or (url-port href) "80")) - (path (url-filename href)) - user pass byserv retval data) - (setq server (concat server ":" port) - path (cond - (realm realm) - ((string-match "/$" path) path) - (t (url-basepath path))) - byserv (cdr-safe (assoc server url-basic-auth-storage))) - (cond - ((and prompt (not byserv)) - (setq user (read-string "Username: " (user-real-login-name)) - pass (funcall url-passwd-entry-func "Password: ") - url-basic-auth-storage - (cons (list server - (cons path - (setq retval - (base64-encode - (format "%s:%s" user pass))))) - url-basic-auth-storage))) - (byserv - (setq retval (cdr-safe (assoc path byserv))) - (if (and (not retval) - (string-match "/" path)) - (while (and byserv (not retval)) - (setq data (car (car byserv))) - (if (or (not (string-match "/" data)) ; Its a realm - take it! - (and - (>= (length path) (length data)) - (string= data (substring path 0 (length data))))) - (setq retval (cdr (car byserv)))) - (setq byserv (cdr byserv)))) - (if (or (and (not retval) prompt) overwrite) - (progn - (setq user (read-string "Username: " (user-real-login-name)) - pass (funcall url-passwd-entry-func "Password: ") - retval (base64-encode (format "%s:%s" user pass)) - byserv (assoc server url-basic-auth-storage)) - (setcdr byserv - (cons (cons path retval) (cdr byserv)))))) - (t (setq retval nil))) - (if retval (setq retval (concat "Basic " retval))) - retval)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Digest authorization code -;;; ------------------------ -;;; This implements the DIGEST authorization type. See the internet draft -;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt -;;; for the complete documentation on this type. -;;; -;;; This is very secure -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar url-digest-auth-storage nil - "Where usernames and passwords are stored. Its value is an assoc list of -assoc lists. The first assoc list is keyed by the server name. The cdr of -this is an assoc list based on the 'directory' specified by the url we are -looking up.") - -(defun url-digest-auth-create-key (username password realm method uri) - "Create a key for digest authentication method" - (let* ((info (if (stringp uri) - (url-generic-parse-url uri) - uri)) - (a1 (md5 (concat username ":" realm ":" password))) - (a2 (md5 (concat method ":" (url-filename info))))) - (list a1 a2))) - -(defun url-digest-auth (url &optional prompt overwrite realm args) - "Get the username/password for the specified URL. -If optional argument PROMPT is non-nil, ask for the username/password -to use for the url and its descendants. If optional third argument -OVERWRITE is non-nil, overwrite the old username/password pair if it -is found in the assoc list. If REALM is specified, use that as the realm -instead of hostname:portnum." - (if args - (let* ((href (if (stringp url) - (url-generic-parse-url url) - url)) - (server (or (url-host href) url-current-server)) - (port (or (url-port href) "80")) - (path (url-filename href)) - user pass byserv retval data) - (setq path (cond - (realm realm) - ((string-match "/$" path) path) - (t (url-basepath path))) - server (concat server ":" port) - byserv (cdr-safe (assoc server url-digest-auth-storage))) - (cond - ((and prompt (not byserv)) - (setq user (read-string "Username: " (user-real-login-name)) - pass (funcall url-passwd-entry-func "Password: ") - url-digest-auth-storage - (cons (list server - (cons path - (setq retval - (cons user - (url-digest-auth-create-key - user pass realm - (or url-request-method "GET") - url))))) - url-digest-auth-storage))) - (byserv - (setq retval (cdr-safe (assoc path byserv))) - (if (and (not retval) ; no exact match, check directories - (string-match "/" path)) ; not looking for a realm - (while (and byserv (not retval)) - (setq data (car (car byserv))) - (if (or (not (string-match "/" data)) - (and - (>= (length path) (length data)) - (string= data (substring path 0 (length data))))) - (setq retval (cdr (car byserv)))) - (setq byserv (cdr byserv)))) - (if (or (and (not retval) prompt) overwrite) - (progn - (setq user (read-string "Username: " (user-real-login-name)) - pass (funcall url-passwd-entry-func "Password: ") - retval (setq retval - (cons user - (url-digest-auth-create-key - user pass realm - (or url-request-method "GET") - url))) - byserv (assoc server url-digest-auth-storage)) - (setcdr byserv - (cons (cons path retval) (cdr byserv)))))) - (t (setq retval nil))) - (if retval - (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")) - (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven"))) - (format - (concat "Digest username=\"%s\", realm=\"%s\"," - "nonce=\"%s\", uri=\"%s\"," - "response=\"%s\", opaque=\"%s\"") - (nth 0 retval) realm nonce (url-filename href) - (md5 (concat (nth 1 retval) ":" nonce ":" - (nth 2 retval))) opaque)))))) - -(defvar url-registered-auth-schemes nil - "A list of the registered authorization schemes and various and sundry -information associated with them.") - -(defun url-get-authentication (url realm type prompt &optional args) - "Return an authorization string suitable for use in the WWW-Authenticate -header in an HTTP/1.0 request. - -URL is the url you are requesting authorization to. This can be either a - string representing the URL, or the parsed representation returned by - `url-generic-parse-url' -REALM is the realm at a specific site we are looking for. This should be a - string specifying the exact realm, or nil or the symbol 'any' to - specify that the filename portion of the URL should be used as the - realm -TYPE is the type of authentication to be returned. This is either a string - representing the type (basic, digest, etc), or nil or the symbol 'any' - to specify that any authentication is acceptable. If requesting 'any' - the strongest matching authentication will be returned. If this is - wrong, its no big deal, the error from the server will specify exactly - what type of auth to use -PROMPT is boolean - specifies whether to ask the user for a username/password - if one cannot be found in the cache" - (if (not realm) - (setq realm (cdr-safe (assoc "realm" args)))) - (if (stringp url) - (setq url (url-generic-parse-url url))) - (if (or (null type) (eq type 'any)) - ;; Whooo doogies! - ;; Go through and get _all_ the authorization strings that could apply - ;; to this URL, store them along with the 'rating' we have in the list - ;; of schemes, then sort them so that the 'best' is at the front of the - ;; list, then get the car, then get the cdr. - ;; Zooom zooom zoooooom - (cdr-safe - (car-safe - (sort - (mapcar - (function - (lambda (scheme) - (if (fboundp (car (cdr scheme))) - (cons (cdr (cdr scheme)) - (funcall (car (cdr scheme)) url nil nil realm)) - (cons 0 nil)))) - url-registered-auth-schemes) - (function - (lambda (x y) - (cond - ((null (cdr x)) nil) - ((and (cdr x) (null (cdr y))) t) - ((and (cdr x) (cdr y)) - (>= (car x) (car y))) - (t nil))))))) - (if (symbolp type) (setq type (symbol-name type))) - (let* ((scheme (car-safe - (cdr-safe (assoc (downcase type) - url-registered-auth-schemes))))) - (if (and scheme (fboundp scheme)) - (funcall scheme url prompt - (and prompt - (funcall scheme url nil nil realm args)) - realm args))))) - -(defun url-register-auth-scheme (type &optional function rating) - "Register an HTTP authentication method. - -TYPE is a string or symbol specifying the name of the method. This - should be the same thing you expect to get returned in an Authenticate - header in HTTP/1.0 - it will be downcased. -FUNCTION is the function to call to get the authorization information. This - defaults to `url-?-auth', where ? is TYPE -RATING a rating between 1 and 10 of the strength of the authentication. - This is used when asking for the best authentication for a specific - URL. The item with the highest rating is returned." - (let* ((type (cond - ((stringp type) (downcase type)) - ((symbolp type) (downcase (symbol-name type))) - (t (error "Bad call to `url-register-auth-scheme'")))) - (function (or function (intern (concat "url-" type "-auth")))) - (rating (cond - ((null rating) 2) - ((stringp rating) (string-to-int rating)) - (t rating))) - (node (assoc type url-registered-auth-schemes))) - (if (not (fboundp function)) - (url-warn 'security - (format (eval-when-compile - "Tried to register `%s' as an auth scheme" - ", but it is not a function!") function))) - - (if node - (progn - (setcdr node (cons function rating)) - (url-warn 'security - (format - "Replacing authorization method `%s' - this could be bad." - type))) - (setq url-registered-auth-schemes - (cons (cons type (cons function rating)) - url-registered-auth-schemes))))) - -(defun url-auth-registered (scheme) - ;; Return non-nil iff SCHEME is registered as an auth type - (assoc scheme url-registered-auth-schemes)) - -(provide 'urlauth) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/utils/bench.el --- a/lisp/utils/bench.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/utils/bench.el Mon Aug 13 08:48:42 2007 +0200 @@ -1,8 +1,16 @@ -;;; bench.el --- a crude benchmark for emacsen +;;; bench.el --- benchmarking utility for emacsen + ;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc. +;; $Id: bench.el,v 1.2 1997/01/11 22:10:19 steve Exp $ +;; $Source: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs-19/lisp/utils/bench.el,v $ +;; $Revision: 1.2 $ +;; $Author: steve $ +;; $Date: 1997/01/11 22:10:19 $ ;; Author: Shane Holder ;; Adapted-By: Steve Baur +;; Further adapted by: Shane Holder +;; Keywords: internal, maint ;; This file is part of XEmacs. @@ -23,33 +31,332 @@ ;;; Commentary: +;; Adapted from Shane Holder's bench.el by steve@altair.xemacs.org. + ;; To run -;; Extract the shar file in /tmp, or modify bench-large-lisp-file to -;; point to the gnus-bench.el file. -;; At the shell prompt emacs -q --no-site-file <= don't load users .emacs or -;; site-file +;; Extract the shar file in /tmp, or modify bench-lisp-file to +;; point to the gnus.el file. +;; At the shell prompt emacs -q --no-site-file <= don't load users .emacs or site-file ;; M-x byte-compile-file "/tmp/bench.el" ;; M-x load-file "/tmp/bench.elc" ;; In the scratch buffer (bench 1) + +;; All bench marks must be named bench-mark- +;; Results are put in bench-mark- + ;;; Code: ;; Use elp to profile benchmarks -(require 'elp) -(eval-when-compile (require 'cl)) ; Emacs doesn't have when and cdar +(require 'cl) ;Emacs doesn't have when and cdar + +;----------------------------------------------------------------------------- +(defvar bench-mark-hanoi-times nil) + +(defun bench-handler-hanoi (times) + (let ((start-time)) + (while (> times 0) +; (setq start-time (bench-get-time)) + (bench-mark-hanoi) +; (setq bench-mark-hanoi-times (cons (- (bench-get-time) start-time ) bench-mark-hanoi-times )) + (setq times (- times 1)))) +) + +(defun bench-mark-hanoi () + "How long to complete the tower of hanoi." + (hanoi 4)) + +;----------------------------------------------------------------------------- +(defvar bench-mark-font-lock-buffer nil "buffer used for bench-mark-fontlock") + +(defun bench-handler-font-lock (times) + (setq bench-mark-font-lock-buffer (find-file bench-lisp-file)) + (while (> times 0) + (bench-mark-font-lock) + (font-lock-mode) ; Turn it off + (setq times (- times 1))) + (kill-buffer bench-mark-font-lock-buffer) +) + +(defun bench-mark-font-lock () + "How long to fonitfy a large file." + (font-lock-fontify-buffer) +) + +;----------------------------------------------------------------------------- +(defvar bench-mark-scrolling-buffer nil "buffer used for bench-mark-scrolling") + +(defun bench-handler-scrolling (times) + (setq bench-mark-scrolling-buffer (find-file bench-lisp-file)) + (set-buffer bench-mark-scrolling-buffer) +; (setq scroll-step 1) + (font-lock-mode -1) + (goto-char (point-min)) ;Start at point min + (let ((temp-times times)) + (while (> temp-times 0) + (bench-mark-scrolling-down) + (bench-mark-scrolling-up) + (setq temp-times (- temp-times 1)))) + + (font-lock-fontify-buffer) + + (goto-char (point-min)) ;Start at point min + (let ((temp-times times)) + (while (> temp-times 0) + (bench-mark-scrolling-down-fontified) + (bench-mark-scrolling-up-fontified) + (setq temp-times (- temp-times 1)))) + (kill-buffer bench-mark-scrolling-buffer) +) + +(defun bench-mark-scrolling-down () + "How long does it take to scroll down through a large file. +Expect point to be at point min" + (let ((buffer-read-only t)) + (while (< (point) (point-max)) + (next-line 1) + (sit-for 0)))) -(defconst bench-version 1.0) +(defun bench-mark-scrolling-up () + "How long does it take to scroll up through a large fontified ile." + (let ((buffer-read-only t)) + (while (> (point) (point-min)) + (previous-line 1) + (sit-for 0)))) + +(defun bench-mark-scrolling-down-fontified () + "How long does it take to scroll down through a large fontified file." + (let ((buffer-read-only t)) + (goto-char (point-min)) + (while (< (point) (point-max)) + (next-line 1) + (sit-for 0)))) + +(defun bench-mark-scrolling-up-fontified () + "How long does it take to scroll up through a large fontified ile." + (let ((buffer-read-only t)) + (while (> (point) (point-min)) + (previous-line 1) + (sit-for 0)))) + +;----------------------------------------------------------------------------- + +(defun bench-handler-make-frames (times) + (let ((temp-times times) + (frame)) + (while (> temp-times 0) + (setq frame (bench-mark-make-frame)) ;Make frame + (bench-mark-delete-frame frame) ;Delete frame + (setq temp-times (- temp-times 1)))) + + (let ((temp-times times) + (frames)) + (while (> temp-times 0) + (setq frames (cons (bench-mark-make-multiple-frames) frames)) ;Make frames + (setq temp-times (- temp-times 1))) + + (setq temp-times times) + + (while (> temp-times 0) + (bench-mark-delete-multiple-frames (car frames)) ;Delete frames + (setq frames (cdr frames)) + (setq temp-times (- temp-times 1)))) + +) + +(defun bench-mark-make-frame () + "How quickly can emacs create a new frame." + (make-frame)) + +(defun bench-mark-delete-frame (frame) + "How quickly can emacs create a new frame." + (delete-frame frame)) + +(defun bench-mark-make-multiple-frames () + "How quickly can emacs create a new frame." + (make-frame)) + +(defun bench-mark-delete-multiple-frames (frame) + "How quickly can emacs create a new frame." + (delete-frame frame)) + + +;----------------------------------------------------------------------------- +(defconst bench-mark-make-words-buffer nil) +(defconst bench-mark-make-words-buffer-name "*bench-mark-make-words*") +(defconst bench-mark-make-words-number-of-words 10000) + +(defun bench-handler-make-words (times) + (setq bench-mark-make-words-buffer (get-buffer-create bench-mark-make-words-buffer-name)) + (set-buffer bench-mark-make-words-buffer) + (while (> times 0) + (bench-mark-make-words) + (erase-buffer) + (setq times (- times 1))) + (kill-buffer bench-mark-make-words-buffer) +) -(defconst bench-large-lisp-file "/usr/local/lib/gnus-bench.el" - "Large lisp file to use in benchmarks. -Grab `ftp://ftp.xemacs.org/pub/beta/contrib/gnus-bench.el.gz' for a good -version. Don't install this file with Emacs/XEmacs.") +(defun bench-mark-make-words () + "How long does it take to generate lots of random words." + (let ((tmp-words bench-mark-make-words-number-of-words)) + (while (not (= tmp-words 0)) + (let ((word-len (random 10))) + (while (not (= word-len 0)) + (insert (+ ?a (random 25))) + (setq word-len (- word-len 1)))) + (insert "\n") + (setq tmp-words (- tmp-words 1))))) + +;----------------------------------------------------------------------------- +(defconst bench-mark-sort-words-buffer-name "*bench-mark-sort-words*") +(defconst bench-mark-sort-words-buffer nil) +(defconst bench-mark-sort-words-number-words 10000) + +(defun bench-handler-sort-words (times) + (setq bench-mark-sort-words-buffer (get-buffer-create bench-mark-sort-words-buffer-name)) + (switch-to-buffer bench-mark-sort-words-buffer) + (while (> times 0) + (bench-pre-sort-words) ;Generate the random words + (bench-mark-sort-words) ;Sort those puppies + (erase-buffer) + (setq times (- times 1))) + (kill-buffer bench-mark-sort-words-buffer) +) + +(defun bench-pre-sort-words () + "How long does it take to generate lots of random words." + (let ((tmp-words bench-mark-sort-words-number-words)) + (while (not (= tmp-words 0)) + (let ((word-len (random 10))) + (while (not (= word-len 0)) + (insert (+ ?a (random 25))) + (setq word-len (- word-len 1)))) + (insert "\n") + (setq tmp-words (- tmp-words 1))))) + +(defun bench-mark-sort-words () + (sort-lines nil (point-min) (point-max)) +) + +;----------------------------------------------------------------------------- +; Byte compile a file +(defun bench-handler-byte-compile (times) + (while (> times 0) + (bench-mark-byte-compile) + (setq times (- times 1))) +) + +(defun bench-mark-byte-compile () + "How long does it take to byte-compile a large lisp file" + (byte-compile-file bench-lisp-file) +) + +;----------------------------------------------------------------------------- +; Run through a loop + +(defconst bench-mark-loop-count 250000) + +(defun bench-handler-loop (times) + (while (> times 0) + (bench-mark-loop) + (setq times (- times 1))) +) + +(defun bench-mark-loop () + "How long does it take to run through a loop." + (let ((count bench-mark-loop-count)) + (let ((i 0) (gcount 0)) + (while (< i count) + (increment) + (setq i (1+ i))) + (message "gcount = %d" gcount)))) + +(defun increment () + "Increment a variable for bench-mark-loop." + (setq gcount (1+ gcount))) -(defconst bench-sort-buffer "*Sort*" - "File to be used in the sort benchmark") +;----------------------------------------------------------------------------- +(defconst bench-mark-large-list-list-size 500000 + "Size of list to use in small list creation/garbage collection") +(defconst bench-mark-large-list-num-lists 10) + +(defun bench-handler-large-list (times) + (let ((tmp-foo bench-mark-large-list-num-lists)) + (while (> tmp-foo 0) + (bench-mark-large-list) + (setq tmp-foo (- tmp-foo 1)))) +) + +(defun bench-mark-large-list () + (make-list bench-mark-large-list-list-size '1) +) + +;----------------------------------------------------------------------------- +(defun bench-mark-large-list-garbage-collect (times) + (garbage-collect) +) + +;----------------------------------------------------------------------------- +(defconst bench-mark-small-list-list-size 10 + "Size of list to use in small list creation/garbage collection") + +(defconst bench-mark-small-list-num-lists 100000 + "Number of lists to use in small list creation/garbage collections") + +(defun bench-handler-small-list (times) + (let ((tmp-foo bench-mark-small-list-num-lists)) + (while (> tmp-foo 0) + (bench-mark-small-list) + (setq tmp-foo (- tmp-foo 1))) +)) + +(defun bench-mark-small-list () + (make-list bench-mark-small-list-list-size '1) +) -(defconst bench-sort-number-words 10000 - "Number of words to use in sort benchmark") +;----------------------------------------------------------------------------- +(defun bench-mark-small-list-garbage-collect (times) + (garbage-collect) +) + +;----------------------------------------------------------------------------- +(defconst bench-mark-insert-into-empty-buffer-num-words 100000) + +(defun bench-handler-insert-into-empty-buffer () + (set-buffer (get-buffer-create "*tmp*")) + (bench-mark-insert-into-empty-buffer) + (erase-buffer) + (kill-buffer "*tmp*") +) + +(defun bench-mark-insert-into-empty-buffer () + (let ((a bench-mark-insert-into-empty-buffer-num-words)) + (while (> a 0) + (insert "0123456789\n") + (setq a (1- a)))) +) + +;============================================================================= +(defconst bench-version (let ((rcsvers "$Revision: 1.2 $")) + (substring rcsvers 11 (- (length rcsvers) 2))) + "*Version number of bench.el") + +(defconst temp-dir (file-name-as-directory + (or (getenv "TMPDIR") + (getenv "TMP") + (getenv "TEMP") + "/tmp/"))) + +(defconst bench-large-lisp-file (concat temp-dir "./bench-large.el") + "Large lisp file to use in benchmarks should be /temp-dir/bench-text.el") + +(defconst bench-small-lisp-file (concat temp-dir "./bench-small.el") + "Large lisp file to use in benchmarks should be /temp-dir/bench-text.el") + +(defconst bench-lisp-file bench-large-lisp-file) (defconst bench-pre-bench-hook nil "Hook for individual bench mark initialization.") @@ -59,19 +366,19 @@ (defconst bench-mark-function-alist '( - (bench-mark-1 . "Tower of Hanoi") - (bench-mark-2 . "Font Lock") - (bench-mark-3 . "Large File scrolling") - (bench-mark-4 . "Frame Creation") - (bench-mark-5 . "Generate Words") - (bench-mark-6 . "Sort Buffer") - (bench-mark-7 . "Large File bytecompilation") - (bench-mark-8 . "Loop Computation") - (bench-mark-9 . "Make a Few Large Size List") - (bench-mark-10 . "Garbage Collection Large Size List") - (bench-mark-11 . "Make Several Small Size List") - (bench-mark-12 . "Garbage Collection Small Size List") - (bench-mark-13 . "Append to buffer") + (bench-handler-hanoi . "Tower of Hanoi") + (bench-handler-font-lock . "Font Lock") + (bench-handler-scrolling . "Large File scrolling") + (bench-handler-make-frames . "Frame Creation") + (bench-handler-make-words . "Generate Words") + (bench-handler-sort-words . "Sort Buffer") + (bench-handler-byte-compile . "Large File bytecompilation") + (bench-handler-loop . "Loop Computation") + (bench-handler-large-list . "Make a Few Large Size List") + (bench-mark-large-list-garbage-collect . "Garbage Collection Large Size List") + (bench-handler-small-list . "Make Several Small Size List") + (bench-mark-small-list-garbage-collect . "Garbage Collection Small Size List") + (bench-handler-insert-into-empty-buffer . "Text Insertion") )) (defconst bench-enabled-profiling nil @@ -82,126 +389,18 @@ (setq gc-cons-threshold 40000000) -(defconst bench-number-of-large-lists 10 - "Number of lists to use in large list creation/garbage collections") - -(defconst bench-number-of-small-lists 1000000 - "Number of lists to use in small list creation/garbage collections") - -(defconst bench-large-list-size 1000000 - "Size of list to use in small list creation/garbage collection") - -(defconst bench-small-list-size 10 - "Size of list to use in small list creation/garbage collection") - -;----------------------------------------------------------------------------- -(defun bench-mark-1 () - "How long to complete the tower of hanoi." - (hanoi 4)) - -;----------------------------------------------------------------------------- -(defun bench-mark-2 () - "How long to fonitfy a large file." - (find-file bench-large-lisp-file) - (font-lock-fontify-buffer)) - -;----------------------------------------------------------------------------- -(defun bench-mark-3 () - "How long does it take to scroll down through a large file." - (let ((buffer-read-only t)) - (goto-char (point-min)) - (while (< (point) (point-max)) - (next-line 1) - (sit-for 0)))) - -;----------------------------------------------------------------------------- -(defun bench-mark-4 () - "How quickly can emacs create a new frame." - (make-frame)) - - -;----------------------------------------------------------------------------- -(defun bench-mark-5 () - "How long does it take to generate lots of random words." - (set-buffer (get-buffer-create bench-sort-buffer)) - (let ((tmp-words bench-sort-number-words)) - (while (not (= tmp-words 0)) - (let ((word-len (random 10))) - (while (not (= word-len 0)) - (insert (+ ?a (random 25))) - (setq word-len (- word-len 1)))) - (insert "\n") - (setq tmp-words (- tmp-words 1))))) - -;----------------------------------------------------------------------------- - -(defun bench-mark-6 () - "How long does it take to sort the random words from bench-mark-5." - (set-buffer (get-buffer-create bench-sort-buffer)) - (sort-lines nil (point-min) (point-max)) -) +(defconst bench-small-frame-alist '((height . 24) (width . 80))) +(defconst bench-medium-frame-alist '((height . 48) (width . 80))) +(defconst bench-large-frame-alist '((height . 72) (width . 80))) -;----------------------------------------------------------------------------- -(defun bench-mark-7 () - "How long does it take to byte-compile a large lisp file" - (byte-compile-file bench-large-lisp-file) -) - -;----------------------------------------------------------------------------- -(defun bench-mark-8 () - "How long does it take to run through a loop." - (let ((count 250000)) - (let ((i 0) (gcount 0)) - (while (< i count) - (increment) - (setq i (1+ i))) - (message "gcount = %d" gcount)))) - -(defun increment () - "Increment a variable for bench-mark-8." - (setq gcount (1+ gcount))) - -;----------------------------------------------------------------------------- -(defun bench-mark-9 () - (let ((tmp-foo bench-number-of-large-lists)) - (while (> tmp-foo 0) - (make-list bench-large-list-size '1) - (setq tmp-foo (- tmp-foo 1))) - ) -) +(defsubst bench-get-time () + ;; Stolen from elp + ;; get current time in seconds and microseconds. I throw away the + ;; most significant 16 bits of seconds since I doubt we'll ever want + ;; to profile lisp on the order of 18 hours. See notes at top of file. + (let ((now (current-time))) + (+ (float (nth 1 now)) (/ (float (nth 2 now)) 1000000.0)))) -;----------------------------------------------------------------------------- -(defun bench-mark-10 () - (garbage-collect) -) - -;----------------------------------------------------------------------------- -(defun bench-mark-11 () - (let ((tmp-foo bench-number-of-small-lists)) - (while (> tmp-foo 0) - (make-list bench-small-list-size '1) - (setq tmp-foo (- tmp-foo 1)) - )) -) - -;----------------------------------------------------------------------------- -(defun bench-mark-12 () - (garbage-collect) -) - -;----------------------------------------------------------------------------- -(defun bench-mark-13 () - (unwind-protect - (let ((a 100000)) - (set-buffer (get-buffer-create "*tmp*")) - (erase-buffer) - (while (> a 0) - (insert "0123456789\n") - (setq a (1- a)))) - (kill-buffer "*tmp*"))) - - -;============================================================================= (defun bench-init () "Initialize profiling for bench marking package." (if (fboundp 'start-profiling) @@ -210,9 +409,29 @@ (when (profiling-active-p) (stop-profiling) (clear-profiling-info))) - (message "Profiling not available in this Emacs.") + (message "Profiling not available in this XEmacs.") (sit-for 2))) +(defun bench-test-init () + "Initialize profiling for bench marking package." + (if (fboundp 'start-profiling) + (let ((buf (get-buffer-create bench-mark-profile-buffer))) + (erase-buffer buf) + (when (profiling-active-p) + (stop-profiling) + (clear-profiling-info))) + (message "Profiling not available in this XEmacs.") + (sit-for 2)) + (setq bench-lisp-file bench-small-lisp-file) + (setq bench-mark-make-words-number-of-words 100) + (setq bench-mark-sort-words-number-of-words 100) + (setq bench-mark-loop-count 10000) + (setq bench-mark-large-list-list-size 500) + (setq bench-mark-small-list-num-lists 100) + (setq bench-mark-insert-into-empty-buffer-num-words 100) + +) + (defun bench-profile-start (test-name) "Turn on profiling for test `test-name'." (when (and bench-enabled-profiling @@ -240,6 +459,16 @@ (add-hook 'bench-pre-bench-hook 'bench-profile-start) (add-hook 'bench-post-bench-hook 'bench-profile-stop) +(defun bench-post () +"Post processing of elp results" +; I can't figure out a good way to sort the lines numerically. +; If someone comes up with a good way, let me know. + (goto-char (point-min)) + (next-line 2) + (sort-lines nil (point) (point-max)) + (mail-results (current-buffer)) +) + (defun bench (arg) "Run a series of benchmarks." (interactive "p") @@ -248,35 +477,68 @@ (bench-init) (if (fboundp 'byte-optimize) ;Turn off byte-compile optimization in XEmacs (setq byte-optimize nil)) + (if (fboundp 'menu-bar-mode) + (menu-bar-mode -1)) ;Turn off menu-bar (let ((benches bench-mark-function-alist)) (while benches (let ((test-name (cdar benches))) (run-hook-with-args 'bench-pre-bench-hook test-name) - (let ((count arg)) - (while (> count 0) - (message "Running %s - %s." (symbol-name (caar benches)) test-name) - (funcall (caar benches)) - (setq count (1- count)))) + (message "Running %s - %s." (symbol-name (caar benches)) test-name) + (funcall (caar benches) arg) (setq benches (cdr benches)) (run-hook-with-args 'bench-post-bench-hook test-name)) )) (elp-results) - (goto-char (point-min)) - (next-line 2) -; I can't figure out a good way to sort the lines numerically. -; If someone comes up with a good way, let me know. - (sort-lines nil (point) (point-max)) - (goto-char (point-min)) + (bench-post) +) + +(defun bench-test (arg) + "Run all the tests but with smaller values so the tests run quicker. +This way I don't have to sit around to see if the tests complete" + (interactive "p") + (elp-instrument-package "bench-mark") ;Only instrument functions + ;beginning with bench-mark + (bench-test-init) + (if (fboundp 'byte-optimize) ;Turn off byte-compile optimization in XEmacs + (setq byte-optimize nil)) + (if (fboundp 'menu-bar-mode) + (menu-bar-mode -1)) ;Turn off menu-bar (let ((benches bench-mark-function-alist)) (while benches - (goto-char (point-min)) - (let ((test-name (cdar benches)) - (test-func (caar benches))) - (search-forward (symbol-name test-func)) - (end-of-line) - (insert " <= " test-name)) + (let ((test-name (cdar benches))) + (run-hook-with-args 'bench-pre-bench-hook test-name) + (message "Running %s - %s." (symbol-name (caar benches)) test-name) + (funcall (caar benches) arg) (setq benches (cdr benches)) + (run-hook-with-args 'bench-post-bench-hook test-name)) )) + (elp-results) + (bench-post) ) + +(defconst bench-send-results-to "holder@rsn.hp.com") +(defconst bench-subject "Bench Mark Results") +(defconst bench-system-form (format " + +Please fill in as much of the following as you can +and then hit C-cC-c to send. + +CPU Manufacturer (Intel,HP,DEC,etc.): +CPU Type (Pentium,Alpha): +CPU Speed: +RAM (in meg): +Emacs Version: %s +Emacs (version): %s +Compile line: +Bench Version: %s +" emacs-version (emacs-version) bench-version)) + +(defun mail-results (buffer) + (mail nil bench-send-results-to bench-subject) + (sit-for 0) + (goto-char (point-max)) + (insert bench-system-form) + (insert-buffer buffer) +) ;;; bench.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/utils/loadhist.el --- a/lisp/utils/loadhist.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/utils/loadhist.el Mon Aug 13 08:48:42 2007 +0200 @@ -34,6 +34,7 @@ (defun symbol-file (sym) "Return the input source from which SYM was loaded. This is a file name, or nil if the source was a buffer with no associated file." + (interactive "S") ; XEmacs (catch 'foundit (mapcar (function (lambda (x) (if (memq sym (cdr x)) (throw 'foundit (car x))))) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/version.el --- a/lisp/version.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/version.el Mon Aug 13 08:48:42 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 (beta7)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta90)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/Makefile --- a/lisp/viper/Makefile Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/Makefile Mon Aug 13 08:48:42 2007 +0200 @@ -30,9 +30,6 @@ VIPERelc = viper-util.elc viper-mous.elc viper-ex.elc viper-macs.elc \ viper-keym.elc viper.elc -PRELOADS = -l viper-util.el -l viper-ex.el -l viper-mous.el \ - -l viper-macs.el -l viper-keym.el -l viper.el - all: dvi info hello elc goodbye elc: $(VIPERelc) @@ -98,23 +95,23 @@ viper-ex.elc: viper-ex.el viper-util.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile viper-ex.el + $(EMACS) -batch -f batch-byte-compile viper-ex.el viper-mous.elc: viper-mous.el viper-util.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile viper-mous.el + $(EMACS) -batch -f batch-byte-compile viper-mous.el viper-macs.elc: viper-macs.el viper-util.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile viper-macs.el + $(EMACS) -batch -f batch-byte-compile viper-macs.el viper-keym.elc: viper-keym.el viper-util.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile viper-keym.el + $(EMACS) -batch -f batch-byte-compile viper-keym.el viper.elc: viper.el viper-util.el @echo "" - $(EMACS) -batch $(PRELOADS) -f batch-byte-compile viper.el + $(EMACS) -batch -f batch-byte-compile viper.el dvi: viper.dvi viperCard.dvi @@ -135,7 +132,7 @@ rm -f *.elc *~ core distclean: clean - + realclean: clean rm -f *.dvi viper.info* rm -f viper.aux viper.cp viper.cps viper.fn viper.fns viper.ky \ diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/README --- a/lisp/viper/README Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/README Mon Aug 13 08:48:42 2007 +0200 @@ -111,3 +111,5 @@ viperCard.dvi contain the Viper manual and the quick reference card, respectively. + + diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/viper-ex.el --- a/lisp/viper/viper-ex.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/viper-ex.el Mon Aug 13 08:48:42 2007 +0200 @@ -19,14 +19,34 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;; Code -;; Code +(provide 'viper-ex) + +;; Compiler pacifier +(defvar read-file-name-map) +(defvar vip-use-register) +(defvar vip-s-string) +(defvar vip-shift-width) +(defvar vip-ex-history) +(defvar vip-related-files-and-buffers-ring) +(defvar vip-local-search-start-marker) +(defvar vip-expert-level) +(defvar vip-custom-file-name) +(defvar vip-case-fold-search) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'viper-util) + (load "viper-util.el" nil nil 'nosuffix)) + (or (featurep 'viper-keym) + (load "viper-keym.el" nil nil 'nosuffix)) + )) +;; end pacifier + (require 'viper-util) -;; Compiler pacifier -(defvar read-file-name-map) -;; end compiler pacifier ;;; Variables @@ -285,7 +305,7 @@ ;; A token has a type, \(command, address, end-mark\), and a value (defun vip-get-ex-token () (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (skip-chars-forward " \t|") (cond ((looking-at "#") @@ -421,7 +441,7 @@ "!*"))) (save-window-excursion ;; put cursor at the end of the Ex working buffer - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (goto-char (point-max))) (cond ((vip-looking-back quit-regex1) (exit-minibuffer)) @@ -499,7 +519,7 @@ map))) (save-window-excursion ;; just a precaution - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (delete-region (point-min) (point-max)) (insert com-str "\n") @@ -594,7 +614,7 @@ ;; get an ex command (defun vip-get-ex-command () (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (if (looking-at "/") (forward-char 1)) (skip-chars-forward " \t") @@ -610,7 +630,7 @@ ;; Get an Ex option g or c (defun vip-get-ex-opt-gc (c) (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (if (looking-at (format "%c" c)) (forward-char 1)) (skip-chars-forward " \t") @@ -722,7 +742,7 @@ (setq ex-count nil) (setq ex-flag nil) (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (skip-chars-forward " \t") (if (looking-at "[a-zA-Z]") @@ -748,7 +768,7 @@ ex-count nil ex-flag nil) (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (skip-chars-forward " \t") (if (looking-at "!") @@ -810,7 +830,7 @@ ex-cmdfile nil) (save-excursion (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (skip-chars-forward " \t") (if (looking-at "!") @@ -1183,7 +1203,7 @@ (if ex-offset (progn (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (delete-region (point-min) (point-max)) (insert ex-offset "\n") @@ -1255,7 +1275,7 @@ (forward-line -1) (end-of-line))))) (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (setq com-str (buffer-substring (1+ (point)) (1- (point-max))))) (while marks @@ -1327,7 +1347,7 @@ (setq ex-addresses (cons (point) nil))) (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (skip-chars-forward " \t") (if (looking-at "[a-z]") @@ -1462,7 +1482,7 @@ (defun ex-quit () ;; skip "!", if it is q!. In Viper q!, w!, etc., behave as q, w, etc. (save-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (if (looking-at "!") (forward-char 1))) (if (< vip-expert-level 3) @@ -1696,7 +1716,7 @@ ;; special meaning (defun ex-get-inline-cmd-args (regex-forw &optional chars-back replace-str) (save-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (goto-char (point-min)) (re-search-forward regex-forw nil t) @@ -1830,7 +1850,7 @@ (defun ex-tag () (let (tag) (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (skip-chars-forward " \t") (set-mark (point)) @@ -1907,12 +1927,11 @@ (insert region) (save-buffer) (ex-write-info file-exists ex-file (point-min) (point-max)) - ) - (set-buffer temp-buf) - (set-buffer-modified-p nil) - (kill-buffer temp-buf) - )) - ) + )) + (set-buffer temp-buf) + (set-buffer-modified-p nil) + (kill-buffer temp-buf) + )) ;; this prevents the loss of data if writing part of the buffer (if (and (buffer-file-name) writing-same-file) (set-visited-file-modtime)) @@ -1964,7 +1983,7 @@ (defun ex-command () (let (command) (save-window-excursion - (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) + (setq vip-ex-work-buf (get-buffer-create vip-ex-work-buf-name)) (set-buffer vip-ex-work-buf) (skip-chars-forward " \t") (setq command (buffer-substring (point) (point-max))) @@ -2024,6 +2043,4 @@ )) -(provide 'viper-ex) - ;;; viper-ex.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/viper-keym.el --- a/lisp/viper/viper-keym.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/viper-keym.el Mon Aug 13 08:48:42 2007 +0200 @@ -21,6 +21,23 @@ ;; Code +(provide 'viper-keym) + +;; compiler pacifier +(defvar vip-always) +(defvar vip-current-state) +(defvar vip-mode-string) +(defvar vip-expert-level) +(defvar vip-ex-style-editing-in-insert) +(defvar vip-ex-style-motion) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'viper-util) + (load "viper-util.el" nil nil 'nosuffix)) + )) +;; end pacifier + (require 'viper-util) ;;; Variables @@ -35,6 +52,29 @@ "Key used to ESC. Must be set in .vip file or prior to loading Viper. This setting cannot be changed interactively.") + +;;; Emacs keys in other states. + +(defvar vip-want-emacs-keys-in-insert t + "*Set to nil if you want complete Vi compatibility in insert mode. +Complete compatibility with Vi is not recommended for power use of Viper.") + +(defvar vip-want-emacs-keys-in-vi t + "*Set to nil if you want complete Vi compatibility in Vi mode. +Full Vi compatibility is not recommended for power use of Viper.") + +(defvar vip-no-multiple-ESC t + "*If true, multiple ESC in Vi mode will cause bell to ring. +This is set to t on a windowing terminal and to 'twice on a dumb +terminal (unless the user level is 1, 2, or 5). On a dumb terminal, this +enables cursor keys and is generally more convenient, as terminals usually +don't have a convenient Meta key. +Setting vip-no-multiple-ESC to nil will allow as many multiple ESC, +as is allowed by the major mode in effect.") + +(defvar vip-want-ctl-h-help nil + "*If t then C-h is bound to help-command in insert mode, if nil then it is +bound to delete-backward-char.") ;;; Keymaps @@ -335,7 +375,7 @@ (define-key vip-vi-basic-map "~" 'vip-toggle-case) (define-key vip-vi-basic-map "\C-?" 'vip-backward-char) (define-key vip-vi-basic-map "_" 'vip-nil) - + ;;; Escape from Emacs to Vi for one command (global-set-key "\C-c\\" 'vip-escape-to-vi) ; everywhere @@ -441,7 +481,7 @@ (defun vip-zap-local-keys () "Unconditionally reset Viper vip-*-local-user-map's. -Rarely useful, but if you made a mistake by switching to a mode that adds +Rarely useful, but if u made a mistake by switching to a mode that adds undesirable local keys, e.g., comint-mode, then this function can restore sanity." (interactive) @@ -579,6 +619,4 @@ alist)) -(provide 'viper-keym) - ;;; viper-keym.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/viper-macs.el --- a/lisp/viper/viper-macs.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/viper-macs.el Mon Aug 13 08:48:42 2007 +0200 @@ -21,6 +21,24 @@ ;; Code +(provide 'viper-macs) + +;; compiler pacifier +(defvar vip-ex-work-buf) +(defvar vip-custom-file-name) +(defvar vip-current-state) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'viper-util) + (load "viper-util.el" nil nil 'nosuffix)) + (or (featurep 'viper-keym) + (load "viper-keym.el" nil nil 'nosuffix)) + (or (featurep 'viper-mous) + (load "viper-mous.el" nil nil 'nosuffix)) + )) +;; end pacifier + (require 'viper-util) (require 'viper-keym) @@ -938,6 +956,4 @@ (call-last-kbd-macro))) -(provide 'viper-macs) - ;;; viper-macs.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/viper-mous.el --- a/lisp/viper/viper-mous.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/viper-mous.el Mon Aug 13 08:48:42 2007 +0200 @@ -21,12 +21,25 @@ ;; Code -(require 'viper-util) +(provide 'viper-mous) ;; compiler pacifier (defvar double-click-time) (defvar mouse-track-multi-click-time) -;; end compiler pacifier +(defvar vip-search-start-marker) +(defvar vip-local-search-start-marker) +(defvar vip-search-history) +(defvar vip-s-string) +(defvar vip-re-search) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'viper-util) + (load "viper-util.el" nil nil 'nosuffix)) + )) +;; end pacifier + +(require 'viper-util) ;;; Variables @@ -453,7 +466,4 @@ ))) - -(provide 'viper-mous) - ;;; viper-mous.el ends here diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/viper-util.el --- a/lisp/viper/viper-util.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/viper-util.el Mon Aug 13 08:48:42 2007 +0200 @@ -42,7 +42,11 @@ (defvar vip-use-replace-region-delimiters) (defvar vip-fast-keyseq-timeout) (defvar vip-related-files-and-buffers-ring) -;; end compiler pacifier +(defvar vip-saved-cursor-color) +(defvar ex-unix-type-shell) +(defvar ex-unix-type-shell-options) +(defvar vip-ex-tmp-buf-name) +;; end pacifier ;; Is it XEmacs? (defconst vip-xemacs-p (string-match "\\(Lucid\\|XEmacs\\)" emacs-version)) @@ -155,6 +159,120 @@ (defvar vip-search-overlay-priority 500) +;;; Viper minor modes + +;; This is not local in Emacs, so we make it local. +;; This must be local because although the stack of minor modes can be the same +;; for all buffers, the associated *keymaps* can be different. In Viper, +;; vip-vi-local-user-map, vip-insert-local-user-map, and others can have +;; different keymaps for different buffers. +;; Also, the keymaps associated with vip-vi/insert-state-modifier-minor-mode +;; can be different. +(make-variable-buffer-local 'minor-mode-map-alist) + +;; Mode for vital things like \e, C-z. +(vip-deflocalvar vip-vi-intercept-minor-mode nil) + +(vip-deflocalvar vip-vi-basic-minor-mode nil + "Viper's minor mode for Vi bindings.") + +(vip-deflocalvar vip-vi-local-user-minor-mode nil + "Auxiliary minor mode for user-defined local bindings in Vi state.") + +(vip-deflocalvar vip-vi-global-user-minor-mode nil + "Auxiliary minor mode for user-defined global bindings in Vi state.") + +(vip-deflocalvar vip-vi-state-modifier-minor-mode nil + "Minor mode used to make major-mode-specific modification to Vi state.") + +(vip-deflocalvar vip-vi-diehard-minor-mode nil + "This minor mode is in effect when the user wants Viper to be Vi.") + +(vip-deflocalvar vip-vi-kbd-minor-mode nil + "Minor mode for Ex command macros in Vi state. +The corresponding keymap stores key bindings of Vi macros defined with +the Ex command :map.") + +;; Mode for vital things like \e, C-z. +(vip-deflocalvar vip-insert-intercept-minor-mode nil) + +(vip-deflocalvar vip-insert-basic-minor-mode nil + "Viper's minor mode for bindings in Insert mode.") + +(vip-deflocalvar vip-insert-local-user-minor-mode nil + "Auxiliary minor mode for buffer-local user-defined bindings in Insert state. +This is a way to overshadow normal Insert mode bindings locally to certain +designated buffers.") + +(vip-deflocalvar vip-insert-global-user-minor-mode nil + "Auxiliary minor mode for global user-defined bindings in Insert state.") + +(vip-deflocalvar vip-insert-state-modifier-minor-mode nil + "Minor mode used to make major-mode-specific modification to Insert state.") + +(vip-deflocalvar vip-insert-diehard-minor-mode nil + "Minor mode that simulates Vi very closely. +Not recommened, except for the novice user.") + +(vip-deflocalvar vip-insert-kbd-minor-mode nil +"Minor mode for Ex command macros Insert state. +The corresponding keymap stores key bindings of Vi macros defined with +the Ex command :map!.") + +(vip-deflocalvar vip-replace-minor-mode nil + "Minor mode in effect in replace state (cw, C, and the like commands).") + +;; Mode for vital things like \C-z and \C-x) +;; This is t, by default. So, any new buffer will have C-z defined as +;; switch to Vi, unless we switched states in this buffer +(vip-deflocalvar vip-emacs-intercept-minor-mode t) + +(vip-deflocalvar vip-emacs-local-user-minor-mode t + "Minor mode for local user bindings effective in Emacs state. +Users can use it to override Emacs bindings when Viper is in its Emacs +state.") + +(vip-deflocalvar vip-emacs-global-user-minor-mode t + "Minor mode for global user bindings in effect in Emacs state. +Users can use it to override Emacs bindings when Viper is in its Emacs +state.") + +(vip-deflocalvar vip-emacs-kbd-minor-mode t + "Minor mode for Vi style macros in Emacs state. +The corresponding keymap stores key bindings of Vi macros defined with +`vip-record-kbd-macro' command. There is no Ex-level command to do this +interactively.") + +(vip-deflocalvar vip-emacs-state-modifier-minor-mode t + "Minor mode used to make major-mode-specific modification to Emacs state. +For instance, a Vi purist may want to bind `dd' in Dired mode to a function +that deletes a file.") + +(vip-deflocalvar vip-vi-minibuffer-minor-mode nil + "Minor mode that forces Vi-style when the Minibuffer is in Vi state.") + +(vip-deflocalvar vip-insert-minibuffer-minor-mode nil + "Minor mode that forces Vi-style when the Minibuffer is in Insert state.") + + + +;; Some common error messages + +(defconst vip-SpuriousText "Spurious text after command" "") +(defconst vip-BadExCommand "Not an editor command" "") +(defconst vip-InvalidCommandArgument "Invalid command argument" "") +(defconst vip-NoPrevSearch "No previous search string" "") +(defconst vip-EmptyRegister "`%c': Nothing in this register" "") +(defconst vip-InvalidRegister "`%c': Invalid register" "") +(defconst vip-EmptyTextmarker "`%c': Text marker doesn't point anywhere" "") +(defconst vip-InvalidTextmarker "`%c': Invalid text marker" "") +(defconst vip-InvalidViCommand "Invalid command" "") +(defconst vip-BadAddress "Ill-formed address" "") +(defconst vip-FirstAddrExceedsSecond "First address exceeds second" "") +(defconst vip-NoFileSpecified "No file specified" "") + + + ;;; XEmacs support (if vip-xemacs-p @@ -255,7 +373,7 @@ (vip-overlay-get vip-replace-overlay 'vip-cursor-color))) (defsubst vip-restore-cursor-color-after-insert () (vip-change-cursor-color vip-saved-cursor-color)) - + ;; Check the current version against the major and minor version numbers ;; using op: cur-vers op major.minor If emacs-major-version or @@ -947,6 +1065,12 @@ (set hook hook-value)))) +;; it is suggested that an event must be copied before it is assigned to +;; last-command-event in XEmacs +(defun vip-copy-event (event) + (if vip-xemacs-p + (copy-event event) + event)) ;; like read-event, but in XEmacs also try to convert to char, if possible (defun vip-read-event-convert-to-char () @@ -964,7 +1088,7 @@ ;; by correctly mapping key sequences for Left/Right/... (one an ascii ;; terminal) into logical keys left, right, etc. (defun vip-read-key () - (let ((overriding-local-map vip-overriding-map) + (let ((overriding-local-map vip-overriding-map) (inhibit-quit t) key) (use-global-map vip-overriding-map) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/viper/viper.el --- a/lisp/viper/viper.el Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/viper/viper.el Mon Aug 13 08:48:42 2007 +0200 @@ -8,7 +8,7 @@ ;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -(defconst viper-version "2.91 of August 5, 1996" +(defconst viper-version "2.92 of January 3, 1997" "The current version of Viper") ;; This file is part of GNU Emacs. @@ -300,7 +300,7 @@ (require 'cl) (require 'ring) -(require 'viper-util) +(provide 'viper) ;; Compiler pacifier (defvar vip-minibuffer-current-face) @@ -309,8 +309,30 @@ (defvar vip-minibuffer-emacs-face) (defvar iso-accents-mode) (defvar zmacs-region-stays) +(defvar mark-even-if-inactive) + +(eval-when-compile + (let ((load-path (cons "." load-path))) + (or (featurep 'viper-util) + (load "viper-util.el" nil nil 'nosuffix)) + (or (featurep 'viper-keym) + (load "viper-keym.el" nil nil 'nosuffix)) + (or (featurep 'viper-mous) + (load "viper-mous.el" nil nil 'nosuffix)) + (or (featurep 'viper-macs) + (load "viper-macs.el" nil nil 'nosuffix)) + (or (featurep 'viper-ex) + (load "viper-ex.el" nil nil 'nosuffix)) + )) ;; end pacifier +(require 'viper-util) +(require 'viper-keym) +(require 'viper-mous) +(require 'viper-macs) +(require 'viper-ex) + + ;;; Variables @@ -335,96 +357,6 @@ (defvar vip-saved-user-settings nil) -;;; Viper minor modes - -;; This must be local because although the stack of minor modes can be the same -;; for all buffers, the associated *keymaps* can be different. In Viper, -;; vip-vi-local-user-map, vip-insert-local-user-map, and others can have -;; different keymaps for different buffers. -;; Also, the keymaps associated with vip-vi/insert-state-modifier-minor-mode -;; can be different. -(make-variable-buffer-local 'minor-mode-map-alist) - -;; Mode for vital things like \e, C-z. -(vip-deflocalvar vip-vi-intercept-minor-mode nil) - -(vip-deflocalvar vip-vi-basic-minor-mode nil - "Viper's minor mode for Vi bindings.") - -(vip-deflocalvar vip-vi-local-user-minor-mode nil - "Auxiliary minor mode for user-defined local bindings in Vi state.") - -(vip-deflocalvar vip-vi-global-user-minor-mode nil - "Auxiliary minor mode for user-defined global bindings in Vi state.") - -(vip-deflocalvar vip-vi-state-modifier-minor-mode nil - "Minor mode used to make major-mode-specific modification to Vi state.") - -(vip-deflocalvar vip-vi-diehard-minor-mode nil - "This minor mode is in effect when the user wants Viper to be Vi.") - -(vip-deflocalvar vip-vi-kbd-minor-mode nil - "Minor mode for Ex command macros in Vi state. -The corresponding keymap stores key bindings of Vi macros defined with -the Ex command :map.") - -;; Mode for vital things like \e, C-z. -(vip-deflocalvar vip-insert-intercept-minor-mode nil) - -(vip-deflocalvar vip-insert-basic-minor-mode nil - "Viper's minor mode for bindings in Insert mode.") - -(vip-deflocalvar vip-insert-local-user-minor-mode nil - "Auxiliary minor mode for buffer-local user-defined bindings in Insert state. -This is a way to overshadow normal Insert mode bindings locally to certain -designated buffers.") - -(vip-deflocalvar vip-insert-global-user-minor-mode nil - "Auxiliary minor mode for global user-defined bindings in Insert state.") - -(vip-deflocalvar vip-insert-state-modifier-minor-mode nil - "Minor mode used to make major-mode-specific modification to Insert state.") - -(vip-deflocalvar vip-insert-diehard-minor-mode nil - "Minor mode that simulates Vi very closely. -Not recommened, except for the novice user.") - -(vip-deflocalvar vip-insert-kbd-minor-mode nil -"Minor mode for Ex command macros Insert state. -The corresponding keymap stores key bindings of Vi macros defined with -the Ex command :map!.") - -(vip-deflocalvar vip-replace-minor-mode nil - "Minor mode in effect in replace state (cw, C, and the like commands).") - -;; Mode for vital things like \C-z and \C-x) -;; This is t, by default. So, any new buffer will have C-z defined as -;; switch to Vi, unless we switched states in this buffer -(vip-deflocalvar vip-emacs-intercept-minor-mode t) - -(vip-deflocalvar vip-emacs-local-user-minor-mode t - "Minor mode for local user bindings effective in Emacs state. -Users can use it to override Emacs bindings when Viper is in its Emacs -state.") - -(vip-deflocalvar vip-emacs-global-user-minor-mode t - "Minor mode for global user bindings in effect in Emacs state. -Users can use it to override Emacs bindings when Viper is in its Emacs -state.") - -(vip-deflocalvar vip-emacs-kbd-minor-mode t - "Minor mode for Vi style macros in Emacs state. -The corresponding keymap stores key bindings of Vi macros defined with -`vip-record-kbd-macro' command. There is no Ex-level command to do this -interactively.") - -(vip-deflocalvar vip-emacs-state-modifier-minor-mode t - "Minor mode used to make major-mode-specific modification to Emacs state. -For instance, a Vi purist may want to bind `dd' in Dired mode to a function -that deletes a file.") - - - ;;; ISO characters (vip-deflocalvar vip-automatic-iso-accents nil @@ -432,18 +364,6 @@ For some users, this behavior may be too primitive. In this case, use insert/emacs/vi state hooks.") - -;;; Emacs keys in other states. - -(defvar vip-want-emacs-keys-in-insert t - "*Set to nil if you want complete Vi compatibility in insert mode. -Complete compatibility with Vi is not recommended for power use of Viper.") - -(defvar vip-want-emacs-keys-in-vi t - "*Set to nil if you want complete Vi compatibility in Vi mode. -Full Vi compatibility is not recommended for power use of Viper.") - - ;; VI-style Undo @@ -478,13 +398,12 @@ (defvar vip-replace-overlay-cursor-color "Red" "*Cursor color to use in Replace state") - (defvar vip-insert-state-cursor-color nil "Cursor color for Viper insert state.") (put 'vip-insert-state-cursor-color 'permanent-local t) ;; place to save cursor colow when switching to insert mode (vip-deflocalvar vip-saved-cursor-color nil "") - + (vip-deflocalvar vip-replace-overlay nil "") (put 'vip-replace-overlay 'permanent-local t) @@ -580,19 +499,6 @@ ;; Current mode. One of: `emacs-state', `vi-state', `insert-state' (vip-deflocalvar vip-current-state 'emacs-state) -(defvar vip-no-multiple-ESC t - "*If true, multiple ESC in Vi mode will cause bell to ring. -This is set to t on a windowing terminal and to 'twice on a dumb -terminal (unless the user level is 1, 2, or 5). On a dumb terminal, this -enables cursor keys and is generally more convenient, as terminals usually -don't have a convenient Meta key. -Setting vip-no-multiple-ESC to nil will allow as many multiple ESC, -as is allowed by the major mode in effect.") - - -(defvar vip-want-ctl-h-help nil - "*If t then C-h is bound to help-command in insert mode, if nil then it is -bound to delete-backward-char.") ;; Autoindent in insert @@ -702,14 +608,16 @@ (defvar vip-s-forward nil) (defconst vip-case-fold-search nil - "*If not nil, search ignores case.") + "*If not nil, search ignores cases.") (defconst vip-re-search t "*If not nil, search is reg-exp search, otherwise vanilla search.") -(defvar vip-adjust-window-after-search t - "*If not nil, pull the window up or down, depending on the direction of the -search, if search ends up near the bottom or near the top of the window.") +(defvar vip-search-scroll-threshold 2 + "*If search lands within this threshnold from the window top/bottom, +the window will be scrolled up or down appropriately, to reveal context. +If you want Viper search to behave as usual in Vi, set this variable to a +negative number.") (defconst vip-re-query-replace t "*If t then do regexp replace, if nil then do string replace.") @@ -778,22 +686,6 @@ ;; Remembers position of the last jump done using `''. (vip-deflocalvar vip-last-jump-ignore 0) -;; Some common error messages - -(defconst vip-SpuriousText "Spurious text after command" "") -(defconst vip-BadExCommand "Not an editor command" "") -(defconst vip-InvalidCommandArgument "Invalid command argument" "") -(defconst vip-NoPrevSearch "No previous search string" "") -(defconst vip-EmptyRegister "`%c': Nothing in this register" "") -(defconst vip-InvalidRegister "`%c': Invalid register" "") -(defconst vip-EmptyTextmarker "`%c': Text marker doesn't point anywhere" "") -(defconst vip-InvalidTextmarker "`%c': Invalid text marker" "") -(defconst vip-InvalidViCommand "Invalid command" "") -(defconst vip-BadAddress "Ill-formed address" "") -(defconst vip-FirstAddrExceedsSecond "First address exceeds second" "") -(defconst vip-NoFileSpecified "No file specified" "") - - ;; History variables ;; History of search strings. @@ -840,6 +732,10 @@ (defvar vip-tags-file-name "TAGS" "The tags file used by Viper.") +;; Indicates if we are in the middle of executing a command that takes another +;; command as an argument, e.g., cw, dw, etc. +(defvar vip-inside-command-argument-action nil) + ;; Minibuffer (defvar vip-vi-style-in-minibuffer t @@ -854,11 +750,6 @@ ;; *after* exiting the minibuffer (defvar vip-minibuffer-exit-hook nil) -(vip-deflocalvar vip-vi-minibuffer-minor-mode nil - "Minor mode that forces Vi-style when the Minibuffer is in Vi state.") -(vip-deflocalvar vip-insert-minibuffer-minor-mode nil - "Minor mode that forces Vi-style when the Minibuffer is in Insert state.") - ;; setup emacs-supported vi-style feel (setq next-line-add-newlines nil require-final-newline t) @@ -920,10 +811,12 @@ ;; Modifying commands that can be prefixes to movement commands (defconst vip-prefix-commands '(?c ?d ?y ?! ?= ?# ?< ?> ?\")) +;; define vip-prefix-command-p (vip-test-com-defun vip-prefix-command) ;; Commands that are pairs eg. dd. r and R here are a hack (defconst vip-charpair-commands '(?c ?d ?y ?! ?= ?< ?> ?r ?R)) +;; define vip-charpair-command-p (vip-test-com-defun vip-charpair-command) (defconst vip-movement-commands '(?b ?B ?e ?E ?f ?F ?G ?h ?H ?j ?k ?l @@ -932,31 +825,33 @@ ?; ?, ?0 ?? ?/ ) "Movement commands") +;; define vip-movement-command-p (vip-test-com-defun vip-movement-command) ;; Commands that can be repeated by . (dotted) -(defconst vip-dotable-commands '(?c ?d ?C ?D ?> ?<)) +(defconst vip-dotable-commands '(?c ?d ?C ?s ?S ?D ?> ?<)) +;; define vip-dotable-command-p (vip-test-com-defun vip-dotable-command) ;; Commands that can follow a # -(defconst vip-hash-cmds '(?c ?C ?g ?q ?S)) -(vip-test-com-defun vip-hash-cmd) +(defconst vip-hash-commands '(?c ?C ?g ?q ?s)) +;; define vip-hash-command-p +(vip-test-com-defun vip-hash-command) ;; Commands that may have registers as prefix (defconst vip-regsuffix-commands '(?d ?y ?Y ?D ?p ?P ?x ?X)) +;; define vip-regsuffix-command-p (vip-test-com-defun vip-regsuffix-command) (defconst vip-vi-commands (append vip-movement-commands vip-dotable-commands vip-charpair-commands - vip-hash-cmds + vip-hash-commands vip-prefix-commands vip-regsuffix-commands) "The list of all commands in Vi-state.") +;; define vip-vi-command-p (vip-test-com-defun vip-vi-command) - -;;; Arrange the keymaps -(require 'viper-keym) ;;; CODE @@ -1035,7 +930,7 @@ (memq (vip-event-key last-command-event) '(up down left right (meta f) (meta b) (control n) (control p) (control f) (control b))) - (vip-restore-cursor-color))) + (vip-restore-cursor-color-after-replace))) (defun vip-replace-state-post-command-sentinel () ;; Restoring cursor color is needed despite @@ -1174,7 +1069,7 @@ [(control h)] 'vip-del-backward-char-in-insert) (define-key vip-replace-map [(control h)] 'vip-del-backward-char-in-replace))) - + (t ; Vi state (setq vip-vi-diehard-minor-mode (not vip-want-emacs-keys-in-vi)) (if vip-want-ctl-h-help @@ -1451,7 +1346,7 @@ (iso-accents-mode -1)) (vip-restore-cursor-color-after-insert) - + ;; Protection against user errors in hooks (condition-case conds (run-hooks 'vip-vi-state-hook) @@ -1537,7 +1432,7 @@ (interactive "P") (message "Switched to VI state for the next command...") (vip-escape-to-state arg nil 'vi-state)) - + ;; Escape to STATE mode for one Emacs command. (defun vip-escape-to-state (arg events state) ;;(let (com key prefix-arg) @@ -1574,10 +1469,10 @@ ;; this-command, last-command-char, last-command-event (setq this-command com) (if vip-xemacs-p ; XEmacs represents key sequences as vectors - (setq last-command-event (vip-seq-last-elt key) + (setq last-command-event (vip-copy-event (vip-seq-last-elt key)) last-command-char (event-to-character last-command-event)) ;; Emacs represents them as sequences (str or vec) - (setq last-command-event (vip-seq-last-elt key) + (setq last-command-event (vip-copy-event (vip-seq-last-elt key)) last-command-char last-command-event)) (if (commandp com) @@ -1669,6 +1564,7 @@ (defun vip-alternate-Meta-key (arg) "Simulate Emacs Meta key." (interactive "P") + (sit-for 1) (message "ESC-") (vip-escape-to-emacs arg '(?\e))) (defun vip-toggle-key-action () @@ -1679,6 +1575,7 @@ (vip-iconify) (suspend-emacs)) (vip-change-state-to-emacs))) + ;; Intercept ESC sequences on dumb terminals. ;; Based on the idea contributed by Marcelino Veiga Tuimil @@ -1742,7 +1639,7 @@ (setq last-input-event event keyseq (vector (character-to-event ?\e)))) ((eventp first-key) - (setq last-command-event first-key)) + (setq last-command-event (vip-copy-event first-key))) )) ) ; end progn @@ -1862,7 +1759,7 @@ (while (eq event ?U) (vip-describe-arg prefix-arg) (setq event (vip-read-event-convert-to-char))) - + (if (or com (and (not (eq vip-current-state 'vi-state)) ;; make sure it is a Vi command (vip-characterp event) (vip-vi-command-p event) @@ -1879,7 +1776,7 @@ ;; If vip-digit-argument was invoked by vip-escape-to-vi (which is ;; indicated by the fact that the current state is not vi-state, ;; then `event' represents the vi command to be executed (e.g., `d', - ;; `w', etc. Again, last-command-char must make emacs believe that + ;; `w', etc). Again, last-command-char must make emacs believe that ;; this is the command we typed. (setq last-command-char (or com event)) (setq func (vip-exec-form-in-vi @@ -1889,7 +1786,7 @@ ;; some other command -- let emacs do it in its own way (vip-set-unread-command-events event)) )) - + ;; Vi operator as prefix argument." (defun vip-prefix-arg-com (char value com) @@ -1928,7 +1825,8 @@ (setq char (read-char)))) (t (setq com char) - (setq char (vip-read-char-exclusive)))))) + (setq char (read-char)))))) + (if (atom com) ;; `com' is a single char, so we construct the command argument ;; and if `char' is `?', we describe the arg; otherwise @@ -1943,6 +1841,7 @@ (setq mv-or-digit-cmd (vip-exec-form-in-vi (` (key-binding (char-to-string (, char))))))) + ;; as com is non-nil, this means that we have a command to execute (if (memq (car com) '(?r ?R)) ;; execute apropriate region command. @@ -1964,10 +1863,13 @@ ((equal com '(?! . ?!)) (vip-line (cons value ?!))) ((equal com '(?= . ?=)) (vip-line (cons value ?=))) (t (error ""))))) - + (if mv-or-digit-cmd (progn (setq last-command-char char) + (setq last-command-event + (vip-copy-event + (if vip-xemacs-p (character-to-event char) char))) (funcall mv-or-digit-cmd cmd-info))) )) @@ -1993,20 +1895,21 @@ (defun vip-command-argument (arg) "Accept a motion command as an argument." (interactive "P") - (condition-case nil - (vip-prefix-arg-com - last-command-char - (cond ((null arg) nil) - ((consp arg) (car arg)) - ((integerp arg) arg) - (t (error vip-InvalidCommandArgument))) - (cond ((null arg) nil) - ((consp arg) (cdr arg)) - ((integerp arg) nil) - (t (error vip-InvalidCommandArgument)))) - (quit (setq vip-use-register nil) - (signal 'quit nil))) - (vip-deactivate-mark)) + (let ((vip-inside-command-argument-action t)) + (condition-case nil + (vip-prefix-arg-com + last-command-char + (cond ((null arg) nil) + ((consp arg) (car arg)) + ((integerp arg) arg) + (t (error vip-InvalidCommandArgument))) + (cond ((null arg) nil) + ((consp arg) (cdr arg)) + ((integerp arg) nil) + (t (error vip-InvalidCommandArgument)))) + (quit (setq vip-use-register nil) + (signal 'quit nil))) + (vip-deactivate-mark))) ;; repeat last destructive command @@ -2043,6 +1946,8 @@ ;; invoked by the `C' command (defun vip-exec-change (m-com com) + (or (and (markerp vip-com-point) (marker-position vip-com-point)) + (set-marker vip-com-point (point) (current-buffer))) ;; handle C cmd at the eol and at eob. (if (or (and (eolp) (= vip-com-point (point))) (= vip-com-point (point-max))) @@ -2076,6 +1981,8 @@ (if (= com ?C) (vip-change-mode-to-insert) (vip-yank-last-insertion))) (defun vip-exec-delete (m-com com) + (or (and (markerp vip-com-point) (marker-position vip-com-point)) + (set-marker vip-com-point (point) (current-buffer))) (if vip-use-register (progn (cond ((vip-valid-register vip-use-register '(letter digit)) @@ -2118,6 +2025,8 @@ (back-to-indentation)) (defun vip-exec-yank (m-com com) + (or (and (markerp vip-com-point) (marker-position vip-com-point)) + (set-marker vip-com-point (point) (current-buffer))) (if vip-use-register (progn (cond ((vip-valid-register vip-use-register '(letter digit)) @@ -2326,7 +2235,8 @@ )) -;; This command is invoked interactively by the key sequence # +;; The hash-command. It is invoked interactively by the key sequence #. +;; The chars that can follow `#' are determined by vip-hash-command-p (defun vip-special-prefix-com (char) (cond ((= char ?c) (downcase-region (min vip-com-point (point)) @@ -2589,8 +2499,8 @@ (setq incr 1)) (<= (+ incr (count-lines beg end)) 1)))) )) - - + + ;; Check if the string ends with a newline. (defun vip-end-with-a-newline-p (string) (or (string= string "") @@ -3869,10 +3779,11 @@ (interactive "p") (recenter (- (window-height) (1+ arg)))) -;; If vip-adjust-window-after-search is t, scroll up or down 1/4 of window -;; height, depending on whether we are at the bottom or at the top of the -;; window. This function is called by vip-search (which is called from -;; vip-search-forward/backward/next) +;; If point is within vip-search-scroll-threshold of window top or bottom, +;; scroll up or down 1/7 of window height, depending on whether we are at the +;; bottom or at the top of the window. This function is called by vip-search +;; (which is called from vip-search-forward/backward/next). If the value of +;; vip-search-scroll-threshold is negative - don't scroll. (defun vip-adjust-window () (let ((win-height (if vip-emacs-p (1- (window-height)) ; adjust for modeline @@ -3882,15 +3793,18 @@ min-scroll direction) (save-excursion (move-to-window-line 0) ; top - (setq at-top-p (<= (count-lines pt (point)) 2)) + (setq at-top-p + (<= (count-lines pt (point)) + vip-search-scroll-threshold)) (move-to-window-line -1) ; bottom - (setq at-bottom-p (<= (count-lines pt (point)) 2)) + (setq at-bottom-p + (<= (count-lines pt (point)) vip-search-scroll-threshold)) ) - (cond (at-top-p (setq min-scroll 1 + (cond (at-top-p (setq min-scroll (1- vip-search-scroll-threshold) direction 1)) - (at-bottom-p (setq min-scroll 2 + (at-bottom-p (setq min-scroll (1+ vip-search-scroll-threshold) direction -1))) - (if (and vip-adjust-window-after-search min-scroll) + (if min-scroll (recenter (* (max min-scroll (/ win-height 7)) direction))) )) @@ -4181,7 +4095,7 @@ this sets the macros only in the macros in that major mode. Otherwise, the macros are set in the current major mode. \(When unsetting the macros, the second argument has no effect.\)" - (interactive "P") + (interactive "P") (or noninteractive (if (not unset) (progn @@ -4317,6 +4231,7 @@ ;; highlight the result of search ;; don't wait and don't highlight in macros (or executing-kbd-macro + vip-inside-command-argument-action (vip-flash-search-pattern)) ))) @@ -4839,16 +4754,16 @@ (defun vip-mark-point () "Set mark at point of buffer." (interactive) - (let ((char (vip-read-char-exclusive))) - (cond ((and (<= ?a char) (<= char ?z)) - (point-to-register (1+ (- char ?a)))) - ((= char ?<) (vip-mark-beginning-of-buffer)) - ((= char ?>) (vip-mark-end-of-buffer)) - ((= char ?.) (vip-set-mark-if-necessary)) - ((= char ?,) (vip-cycle-through-mark-ring)) - ((= char ?D) (mark-defun)) - (t (error "")) - ))) + (let ((char (read-char))) + (cond ((and (<= ?a char) (<= char ?z)) + (point-to-register (1+ (- char ?a)))) + ((= char ?<) (vip-mark-beginning-of-buffer)) + ((= char ?>) (vip-mark-end-of-buffer)) + ((= char ?.) (vip-set-mark-if-necessary)) + ((= char ?,) (vip-cycle-through-mark-ring)) + ((= char ?D) (mark-defun)) + (t (error "")) + ))) ;; Algorithm: If first invocation of this command save mark on ring, goto ;; mark, M0, and pop the most recent elt from the mark ring into mark, @@ -5154,7 +5069,7 @@ vip-want-emacs-keys-in-insert nil)) ((and (> vip-expert-level 1) (< vip-expert-level 5)) - ;; an intermediate to guru + ;; intermediate to guru (setq vip-no-multiple-ESC (if (vip-window-display-p) t 'twice) vip-want-emacs-keys-in-vi t vip-want-emacs-keys-in-insert (> vip-expert-level 2)) @@ -5542,13 +5457,6 @@ -;;; Bring in the rest of the files -(require 'viper-mous) -(require 'viper-macs) -(require 'viper-ex) - - - ;; The following is provided for compatibility with older VIP's (defalias 'vip-change-mode-to-vi 'vip-change-state-to-vi) @@ -5620,12 +5528,12 @@ (defvar fortran-mode-hook) (add-hook 'fortran-mode-hook 'vip-mode) - + (defvar basic-mode-hook) (add-hook 'basic-mode-hook 'vip-mode) (defvar bat-mode-hook) (add-hook 'bat-mode-hook 'vip-mode) - + (defvar text-mode-hook) (add-hook 'text-mode-hook 'viper-mode) @@ -5648,7 +5556,7 @@ '(defadvice vc-diff (after vip-vc-ad activate) "Force Vi state in VC diff buffer." (vip-change-state-to-vi)))) - + (vip-eval-after-load "emerge" '(defadvice emerge-quit (after vip-emerge-advice activate) @@ -5701,7 +5609,7 @@ 'internal-ange-ftp-mode 'vi-state vip-comint-mode-modifier-map) ;; set hook (add-hook 'comint-mode-hook 'vip-comint-mode-hook) - + ;; Shell scripts (defvar sh-mode-hook) (add-hook 'sh-mode-hook 'viper-mode) @@ -5797,7 +5705,7 @@ ;; set the toggle case sensitivity and regexp search macros (vip-set-vi-search-style-macros nil) - + ;; ~/.vip is loaded if it exists (if (and (file-exists-p vip-custom-file-name) @@ -5880,7 +5788,6 @@ (run-hooks 'vip-load-hook) ; the last chance to change something -(provide 'viper) (provide 'vip19) (provide 'vip) diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/ChangeLog --- a/lisp/w3/ChangeLog Mon Aug 13 08:48:18 2007 +0200 +++ b/lisp/w3/ChangeLog Mon Aug 13 08:48:42 2007 +0200 @@ -1,4 +1,1183 @@ -Sun Aug 11 16:41:58 1996 William Perry +Fri Jan 3 08:43:56 1997 William M. Perry + +* font.el (make-font): Treat args as a plist, just for sanity's sake. + +Thu Jan 2 12:19:31 1997 William M. Perry + +* w3-display.el (w3-table-hack-borders): Fix stupid use of 'otheriwse' + instead of 'otherwise' in a case statement. + +* w3-forms.el (w3-form-add-element): Fix stupid use of 'otheriwse' + instead of 'otherwise' in a case statement. + (w3-form-resurrect-widgets): Fixed XEmacs handling of widget recreation, + and also fixed problem where some widgets would be skipped. + +Tue Dec 31 07:37:17 1996 William M. Perry + +* w3-e19.el: All the menus in Emacs-19 now use the same constructors that + the :filter entries under XEmacs do. This will make things much easier + in the future in not duplicating crufty menu-construction code once for + XEmacs menu-structs and once for Emacs keymaps. + +* w3-menu.el (w3-menu-html-links-constructor): Now works with the Emacs 19 + implementation of property lists. + +Mon Dec 30 06:25:28 1996 William M. Perry + +* w3-menu.el (w3-popup-menu): context-sensitive menus over delayed images + work again + +* w3-display.el (w3-parse-link): New way to store information from + an HTML document. + +* w3.el (w3-search): Deal with new storage + +* w3-menu.el (w3-menu-html-links-constructor): Deal with new way + items are stored - now uses the 'title' attribute if present. + +* w3-auto.el (w3-form-resurrect-widgets): Added autoload + +* url-file.el (url-format-directory): Removed url-forms-based-ftp option - + didn't really work anyway. + +Sun Dec 29 15:54:21 1996 William M. Perry + +* w3-forms.el (w3-form-resurrect-widgets): fixed stupid problem in munging + of the size of form elements. + +* Emacs-W3 3.0.42 released + +* w3-display.el (w3-table-hack-borders): Deal gracefully with not finding + a 'terminal' font to display hacked border chars in + +* w3-hot.el (w3-hotlist-add-document): don't hexify a url before sticking + it in the hotlist buffer + +* w3-display.el (w3-display-node): hyperlinks with images at the start + will now have a button associated with the entire link, not just the + image part. + +* w3-sysdp.el (fillin-text-property): made it work under Emacs19 + +Sun Dec 29 00:07:39 1996 Takahiro Hayata + +* mule-sysdp.el (mule-write-region-no-coding-system): Patch for Mule 2.3 + +Sun Dec 29 00:07:39 1996 William M. Perry + +* w3-forms.el (w3-form-add-element): Only insert stubs of the right length + for a for element, and do munging of that text into the actual widgets + later. This saves us a lot of grief and heartache when handling things + like radio buttons that span table elements because the markers have + become completely insane by the time the next widget is ready to be + created. + +Sat Dec 28 17:24:08 1996 William M. Perry + +* w3-display.el (w3-display-table): Don't crap out on invalid tables where + table-dimensions tells us we have a 0 column or 0 row table. + +* w3-widget.el (widget-image-value-create): Use :action instead of :notify + for widget-image-callback - hyperlinked images under Emacs 19 should + work again. + +Thu Dec 26 18:26:25 1996 William M. Perry + +* w3.el (w3-widget-forward): Use this instead of widget-forward. +(w3-widget-backward): Ditto. Need to make both of these smart for w3. + +* w3-display.el (w3-display-node): Implemented the display class 'none' + for turning off the rendering of an element and its subcontent. + +Thu Dec 26 07:21:58 1996 William Perry + +* w3-parse.el (w3-parse-buffer): *sigh* Allow _ in attribute names. + +* Emacs-W3 3.0.41 released + +* url-parse.el (url-generic-parse-url): bind inhibit-read-only to 't' in + url parsing buffers, to avoid 'attempt to modify read-only text' + problems when the string passed to url-generic-parse-url has the + read-only text property set. + +* w3-e19.el (w3-setup-version-specifics): popup menus should work in + Emacs19 again. + +* css.el (css-expand-value): For margin and padding, make sure we _always_ + convert into a valid length spec. Setting a 'margin' or 'padding' + property group instead of individual margin-* or padding-* values would + cause the display engine to crap out. + (css-get): Fixed generic class-only lookups (.foo, etc) + +* w3-display.el (w3-display-handle-list-type): Tweaks to list indentation + +* w3-menu.el (w3-menu-html-links-constructor): Fixed stupid problem with + the new navigate menu under XEmacs. + +Tue Dec 24 22:46:11 1996 William M. Perry + +* css.el (css-expand-color): Better handling of X-style color specs - + convert them to internal RGB format. + +Tue Dec 24 02:50:08 1996 Christian Limpach + +* font.el (ns-font-families-for-device): added test for unbound + device-fonts-cache variable. + (ns-font-create-name): handle font-styles which are numbers. + +* w3-sysdp.el (try-font-name): added support for Nextstep. + +Tue Dec 24 06:16:33 1996 William M. Perry + +* w3.el (w3-open-local): Send filename through expand-file-name in + w3-open-local to avoid having illegal URLs like file:/~/test.html + +* w3-widget.el (widget-image-value-create): fixed new problem with client + side imagemaps. Should really work this time. + +* w3.el (w3-map-links): w3-map-links and hence w3-complete-link will now + find images that are also hyperlinks. + +Mon Dec 23 22:28:58 1996 William M. Perry + +* Emacs-W3 3.0.40 released + +* w3-menu.el (w3-menu-go-menu): Added 'navigate' submenu to hold the + predefined types. + +* w3-widget.el (widget-image-summarize): Image widgets should now be much + better at identifying themselves when being tab'ed to or waggled at with + the mouse. + +* w3-prefs.el: Fixed a few references to w3-glyphp (now widget-glyphp) + +* w3.el (w3-url-completion-function): Fixed completion of URLs + +Sat Dec 21 Dave Love + +* w3-display.el, w3-vars.el, w3.el: Define and use + w3-defined-link-types to canonicalize link descriptions' case for + ease of use. + +* w3-e19.el (w3-build-FSF19-menu): Add any recognised items + to the menu in the absence of a toolbar. + +Thu Dec 19 13:52:35 1996 William Perry + +* Emacs-W3 3.0.39 released + +* w3-forms.el (w3-form-encode-xwfu): Ditto. + +* url.el (url-hexify-string): Updated to use url-unreserved-chars when + escaping, ala + http://www.ics.uci.edu/pub/ietf/uri/draft-fielding-url-syntax-02.txt + +Wed Dec 18 22:09:41 1996 William M. Perry + +* w3.el (w3-mode): Removed bogus setting of widget-motion-hook from way + back + +* w3-parse.el (w3-parse-buffer): Better handling of tag. + +* w3-display.el (w3-widget-echo): Better falling-back when the preferred + echo method yields nil. + +* url.el, w3-display.el, w3.el: Remove last vestiges of url-hash.el and + removed it from the distribution. + +Wed Dec 18 08:07:32 1996 William Perry + +* dsssl.el: Moved the DSSSL parser and friends into its own namespace. + +Removed dependencies on url-hash. + +* custom.el: Synch'd up to custom 1.13 + +Tue Dec 17 16:36:05 1996 William M. Perry + +* url.el (url-expand-file-name): If we weren't given a base object to work + from, and url-current-object is null, set it to the object returned by + parsing url-view-url. + +* url-http.el (url-create-mime-request): Send the right information in the + 'Host' header field when going through a proxy. + (url-setup-reload-timer): Emacs 19 doesn't deal well with 0-length + timeouts, so protect against trying to create one when dealing with the + refresh header. + +* w3-parse.el: Removed lots of crap for the old display engine - shouldn't + cons up as much garbage as before. Now it will just cons up garbage + that we actually need. + +Tue Dec 17 07:10:47 1996 William Perry + +* css.el (css-properties): New property type 'string-list' for font-family + +* w3.el (w3-find-default-stylesheets): Make sure to look in + data-directory/../../w3 for stylesheets + +Tue Dec 17 06:07:08 1996 William M. Perry + +* w3-toolbar.el: wrapped a condition-case around the require for + xpm-button and xbm-button so that it will compile under Emacs + +Mon Dec 16 08:19:40 1996 William Perry + +* Emacs-W3 3.0.38 released. + +* dist.Makefile (OBJECTS): Removed xpm-button and xbm-button from the + distribution. Any version of XEmacs that can run the latest 3.0 stuff + has them already. + +* default.css: Make nested ol/ul items display class 'line' so they look + prettier. + +* w3-display.el (w3-display-node): EVIL hack to make the first item in a + nested list get indented correctly. + +* w3-about.el (w3-about): Fixed the about:style stylesheet to be + up-to-date with new CSS spec. + +* default.css: Turned down indentation on list items by default. + +* w3-display.el (w3-display-node): Mouse tracking should work under XEmacs + again. + +* dist.Makefile (all): Removed 'emacs' from dependency list. + +Mon Dec 16 06:03:14 1996 William M. Perry + +* w3-display.el (w3-table-hack-borders): This should work on TTY's again. + +Sun Dec 15 14:19:53 1996 William M. Perry + +* Emacs-W3 3.0.37 released + +* w3-display.el: Better handling of paragraphs (well, any block-level + element within a list-item display group. + +* default.css (address): Changed
    display tpye to line so that + right-justification will take effect. + +Sat Dec 14 10:24:13 1996 William M. Perry + +* w3-sysdp.el: Removed stubs for add-submenu - it was confusing 'custom' + +* dist.Makefile: More GNU-ish project makefile + +* url.el (url-default-find-proxy-for-url): Fixed no_proxy handling +(url-default-find-proxy-for-url): Don't pass 'www://' links to a proxy + +Fri Dec 13 22:50:45 1996 William M. Perry + +* dist.Makefile (URLSOURCES): Added socks.el to the distribution. Not + used just yet. + +* css.el (css-copy-stylesheet): Fixed problem with sharing the list + structure between the hash tables - document stylesheets would infect + the main w3-user-stylesheet and cause weirdness. + +Fri Dec 13 09:47:40 1996 William Perry + +* w3-style.el (w3-display-stylesheet): Fixed problem where + w3-display-stylesheet would override the buffer css-display was showing + the stylesheet in. Duhh. + +* mule-sysdp.el (mule-encode-string): Fixed stupid problem on non-XEmacs + mule + (mule-sysdep-version): Ditto. + +Fri Dec 13 06:25:45 1996 William M. Perry + +* css.el (css-get): Removed bogus recursive call to css-get, and moved the + guts of css-get out into its own fuction, which is in turn inlined into + css-get. Might even make things faster. At the least, I expect it to + get rid of the 'takes two makes to make w3-display.elc' problem some + people have been seeing. + +* w3-display.el (w3-display-handle-list-type): Fixed stupid problem with + margin handling where list-item display items were always flush-left + +Fri Dec 13 02:51:24 1996 Greg Stark +* w3-display.el (w3-display-line-break): correct right justification code + (w3-min-size-of-string): removed unused function that didn't work. + (w3-size-of-tree): maintain consistent w3-display-open-element-stack + don't hard code assumption that hr's are drawn with '-' + (w3-display-table-dimensions): major bug if the last column rowspans + (w3-table-lookup-char): new function + (w3-table-hack-borders): new function makes table borders use pretty + graphic characters instead of ascii characters. + (w3-table-unhack-borders): new function restore lame ascii borders. + (w3-display-table): Major changes to support drawing better borders + also fix various bugs and tweak various things. + +* w3-parse.el: remove = from set of characters that terminate an attribute + when guessing about an syntactically invalid attribute. + (didn't this get changed once already?) + +* w3.el (w3-sentinel): hack around bug that bit w3-preview-this-buffer + but I don't know what the right thing for Mule. + +Thu Dec 12 08:36:01 1996 William Perry +* Synch'd up to widget 1.13 + +* w3-display.el (w3-get-pad-string): Ack - watch for negative values in + w3-get-pad-string + +* Released 3.0.36 + +* w3-style.el (w3-display-stylesheet): Use new css-display function + +* css.el (css-get): Better class checking + (css-display): New function to pretty-print a stylesheet that is in + memory. + +* w3-parse.el (w3-parse-buffer): *sigh* Parser now keeps track of 'base' + of this document. Also normalizes 'align' attribute, as well as + auto-expanding any SRC or HREF attributes. + +* w3-display.el (w3-display-handle-list-type): Now handles text-indent + style property. + (w3-display-table): Can now specify properties on 'tr', for + vertical-alignment, etc. + (w3-display-node): Lots of changes to deal with new method of munging + class/align/etc in the parser. + +Wed Dec 11 17:37:14 1996 William M. Perry + +* w3-parse.el (w3-parse-buffer): Do munging of align/src/href/class + attributes to save time in w3-display-node and friends. + +* w3-prefs.el (w3-preferences-compatibility-variables): Fixed problems + with renaming of w3-style-ie-compatibility to css-ie-compatibility + +* w3-display.el (w3-display-node): fix for hyperlinks / form info in + tables. Duhh. + +Wed Dec 11 07:36:08 1996 William Perry + +* css.el (css-copy-stylesheet): New function + +* w3-display.el (w3-display-node): use it + +* mule-sysdp.el (mule-encode-string): Fixes for XEmacs w/mule +(mule-decode-string): Fixes for XEmacs w/mule + +* w3-display.el (w3-display-node): Fixed problem in isindex handling. + Using forms for isindex handling should work again. + +* css.el (css-specificity): new function css-specificity to find how + specific a certain rule is. Need to use this to sort rules in css-get. + +Tue Dec 10 22:37:59 1996 William M. Perry + +* w3-display.el (w3-get-style-info): Changes to deal with new css.el - + should be much much faster now. + +* css.el (css-get): Radically changed the internal representation of + stylesheets, and how they are looked up. + +Mon Dec 9 22:31:11 1996 William M. Perry + +* w3-display.el (w3-face-for-element): Fixed bug in w3-face-for-element + where weight of the element wasn't being taken into account. + +* css.el: Changed font-variant style type from string to symbol-list + +Mon Dec 9 12:29:59 1996 William Perry + +* default.css: Changed default header sizes - should look better on most + machines + +Sun Dec 8 19:21:07 1996 William M. Perry + +* Emacs-w3 3.0.34 Released + +* w3-display.el: New macro w3-get-attribute to replace + (cdr (assq 'blah args)), just in case I ever decide to replace the + assoc list currently used. + +* New file mule-sysdp.el, to make supporting Mule 2.3, Mule 2.4, and + XEmacs 20.0 easier. + +* url-file.el (url-insert-possibly-compressed-file): handle mule 2.4 + +Fri Dec 6 06:54:03 1996 William Perry + +* w3-parse.el: Emit warnings when people try to slap attribute/value pairs + on end tags. Evil bastards. + Added SPAN, BDO, OBJECT, BASEFONT + +Fri Dec 6 04:42:24 1996 Greg Stark + +* default.css: add th td and caption text-align information + +* docomp.el: increase max-specpdl-size so it can compile w3-display + +* url.el (url-sentinel): avoid save-excursion around switch-buffer + +* w3-display (w3-display-line-break): if we're in nowrap mode but the + region doesn't end on a newline insert an extra newline, otherwise
    + gets ignored inside a 
     or nowrap environment. 
+  Also protect against fill-column less than the length of fill-prefix. 
+  Also avoid infloop in right justification, and
+  fix bug that caused right justification to never be executed.
+
+* w3-display (table-cut table-dimensions w3-display-table): 
+  lots of new code to handle rowspan and autolayout.
+
+* (w3-display-fix-widgets): be more agressive adjust even markers that have
+  buffers and adjust parent markers.
+
+* w3-display (w3-display-node): These changes are important for tables
+  Don't insert insert-before on  tags before the class is adjusted
+  Don't insert more than one class into an  tag when we adjust it. 
+  Protect against a negative fill-column when drawing 
    s
+  Set adaptive-fill-mode (what's filladapt-mode?)
+
+* w3-parse.el: remove font from %block. WARNING, i have little idea what
+  consequences this has but it seems to have the desired effect of
+  handling table cells whose first tag is a  without discarding the
+  implied 
     tag.
+
+* w3-parse.el: skip-chars-forward "^>" when parsing end tags 
+  (some people seem to think you can put attributes in end tags)
+
+Fri Dec  6 14:08:30 1996  William M. Perry  
+
+* css.el: Better handling of text-decoration, to go along with the new version
+  of set-font-style-by-keywords
+	
+* font.el: Faster version of set-font-style-by-keywords.
+  Fixed RGB spec. problem if you used non-floats.
+
+* w3-display.el: (w3-face-for-element) Obey some font function renaming.
+  (w3-face-for-element) Changed format specification on w3-style-face-xxx
+  creation.
+  (w3-display-node) Alignment specified via attributes overrides
+  stylesheet, not vice versa.
+  (w3-display-node) Fixed stupid mistake in 'link' handling where
+  stylesheets were ignored.
+
+Thu Dec  5 17:51:37 1996  William M. Perry  
+
+* url.el: (url-retrieve-internally) Can now specify an alternative
+  function to determine whether a URL should be proxied or not.  modelled
+  off the netscape auto-proxy-configuration crap, so hopefully someday we
+  can just suck down one of their files and be 'happy' with it.
+
+* w3-display.el, css.el:
+  Modified some of the css properties to not be inherited - let
+  w3-display figure it out on its own - quicker this way.  Saves a few
+  thousand lookups over the life of a parse.
+
+Mon Dec  2 20:22:12 1996  William M. Perry  
+
+* w3-display.el: use better face names... avoids problems in xemacs
+  resource name checking.
+
+* w3-vars.el: Created version 3.0.33
+
+* w3-parse.el: Fixed problem parsing attribute values like  -
+  the regexp didn't like empty attribute values specified with single
+  quotes.
+
+* w3.el: -Patches from Dave Love
+
+* font.el: Renamed the font-set-*-p to set-font-*-p, to be more in line with
+set-face-underline-p and friends.  Fixed stupid problem in
+set-font-*-p where it would always just toggle the property, not
+actually set it.  Blah.  Added code in x-font-create-name to try
+oblique and italic versions of a font if italic is set.
+
+* default.css: Prettied up the :speech: section
+
+* w3-display.el:
+Conditionalized get-style-info calls in w3-voice-for-element on
+feature 'emacspeak
+
+* w3.el: Added code to try loading dtk-css-speech and w3-speak if the feature
+'emacspeak' is available.
+
+* css.el: Fixed a few stupid problems.
+
+* font.el:
+made tty-font-create-object return a 12pt font object, just for reference.
+
+* w3.txi: More updates to the documentation
+
+* w3.el, w3-style.el: Moved to using the new 'css' package
+
+* w3-parse.el:
+Removed some old functions.  Save some string creation by downcasing
+tag and atribute names in the buffer instead of using 'downcase'.
+
+* w3-display.el: Moved to using the new 'css' package
+
+* w3-auto.el: Removed some outdated autoloads
+
+* font.el: Added function font-set-style-by-keywords
+
+* css.el: Better handling of various entities - beter way of specifying new
+properties and how they should be handled.
+
+* default.css: *** empty log message ***
+
+* dist.Makefile: Added 'css.el' to targets
+
+* css.el: Initial revision
+
+* w3-vars.el: Renamed w3-right-border to w3-right-margin
+
+Sat Nov 30 17:42:38 1996  William M. Perry  
+
+* custom-edit.el, custom.el, widget-edit.el, widget.el:
+-Synch'd up to Custom/Widget 1.09
+
+Fri Nov 29 23:12:42 1996  William M. Perry  
+
+* font.el: Actually try to use the 'oblique' property under X
+
+* w3-display.el:
+Fix for sometimes getting an invalid glyph error in image retrieval.
+Fixed problem where table display would pop something off the open element stack.
+
+* custom-edit.el, custom.el, widget-edit.el, widget.el:
+-Synch'd up to Custom/Widget 1.08
+
+* w3-display.el: List filling seems to line up correctly now.
+Fixed bug in ordered list handling (wrong arg passed to a format).
+Changed the way spacing is handled.
+
+* w3-menu.el: Added new 'search' menu with common web indexes
+
+* dist.Makefile:
+Don't specify widget*.el twice in SOURCES _AND_ CUSTOMSOURCES or
+install under FreeBSD chokes.
+
+* w3-display.el: Protect against list-item display property outside of a list.
+
+* w3-sysdp.el: Fixed free var reference in make-device
+
+Thu Nov 28 23:01:11 1996  William M. Perry  
+
+* w3-display.el:
+Protect against bad values of w3-last-fill-pos in w3-display-line-break
+
+* w3-e19.el, w3-menu.el:
+-Patches from Dave Love  for using title of link in menus
+
+Wed Nov 27 22:59:56 1996  William M. Perry  
+
+* w3-vars.el: Created version 3.0.32
+
+* w3.txi: Started revamping some of the documentation
+
+* url-custom.el: Initial revision
+
+* w3-display.el: Handle 'menu' list type correctly
+
+* url.el: Patch from Thierry.Emery@aar.alcatel-alsthom.fr;
+- insert information about processes in buffer "URL Status Display"
+  instead of *URL-* : added a local variable `url-status-buf' and a
+  call to `set-buffer'
+
+- changed `url-get-working-buffer' to `url-get-working-buffer-name',
+  because `url-working-buffer' is expected to be a name, not a buffer
+  (my mistake)
+
+* w3-xemac.el, w3-vars.el:
+Removed some old variables that aren't used anywhere now.
+
+* w3-e19.el:
+Patch from Dave Love  for 'title' version of w3-echo-link.
+
+* w3-display.el:
+Patch from Dave Love  for 'title' version of w3-echo-link.
+Form info is now stuck on a stack instead of in a let-bound variable.
+Only call w3-display-fix-widgets once!  recursive calls to
+w3-display-node when rendering tables caused it to happen more than it
+should.
+
+* w3-forms.el:
+Patch from Dave Love  to protect against bad value
+for 'next' in w3-next-widget.
+
+* dist.Makefile: Don't use `install -d', use mkdir -p if necessary
+
+Tue Nov 26 16:21:32 1996  William M. Perry  
+
+* custom-edit.el, custom.el: synch'd up to custom 1.05
+
+* widget.el, widget-edit.el: *** empty log message ***
+
+* widget-edit.el, widget.el: synch'd up to widget 1.05
+
+* w3-display.el: Handles the 'dir' list type correctly now.
+
+* url.el:
+Quick patch to check for url-working-buffer being a buffer, not a string.
+
+* w3-display.el:
+Backed out _BAD BAD BAD_ change to protect against invalid values for
+w3-last-fill-pos that basically fucked everything in regards to
+vertical whitespace.
+
+Mon Nov 25 21:12:17 1996  William M. Perry  
+
+* w3-display.el: *** empty log message ***
+
+* w3-display.el:
+Now only does incrememental display around block level elements.
+Does better munging of pre-formatted text CR -> LF CRLF->LF, etc.
+
+* w3.el: Protect against errors in w3-sentinel on bad buffers.
+
+* w3-vars.el: Created version 3.0.31
+
+* widget-edit.el: Fixed compile problems under emacs
+
+* w3-vars.el: *** empty log message ***
+
+* widget.el: Made widget.el compile in emacsen w/o native backquote support
+
+* w3-display.el: *** empty log message ***
+
+* w3-parse.el:
+Patch from greg stark for dealing with '=' in misquoted attribute value pairs
+
+Sun Nov 24 23:25:25 1996  William M. Perry  
+
+* w3-display.el: Reimplemented targetted anchors (#foo)
+
+* url.el: *** empty log message ***
+
+* url-vars.el:
+Changed default of url-mime-language-string to '*' to make some sites happy.
+
+* w3-display.el: Protect against w3-last-fill-pos getting an invalid position
+
+* w3.el, w3-display.el, w3-vars.el:
+Patch from Dave Love  to add new possibility 'title'
+to w3-echo-link to show the 'title' attribute of a link if its there.
+
+* w3-speak.el: Patch from raman.
+
+* font.el:
+Patch from nagae@mickey.ai.kyutech.ac.jp to handle fontsets correctly in mule
+
+* w3-display.el: Implemented a few more CSS properties.
+list-style - control how list items are displayed.  Ordered lists are
+             now different from unordered only in their list-style.
+             Need to implement contextual selectors to get ordered
+             lists to work out of the box though.
+white-space - control whether whitespace is collapsed or not, and
+              whether text is wrapped.  
      and <plaintext>
+              are now all specified to use this in the default
+              stylesheet.
+text-align - this replaces the old 'align' attribute
+
+Reimplemented inlined styles.
+
+* default.css: Varius updates to take advantage of the new CSS properties
+white-space, list-style, etc.
+
+* w3-style.el: Handle url() and rgb() notation in color specifications
+
+* w3-vars.el: Removed a few outdated variables
+
+Sat Nov 23 02:10:37 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el: *** empty log message ***
+
+* dsssl.el: Got rid of yet more compilation warnings.
+
+* custom.el, custom-edit.el: Synch'd up to custom 1.0.1
+
+* w3-display.el:
+Better handling of <hr> and <center>, and line spacing in general
+
+* default.css: Updates to default stylesheet to deal with <center> and <div>
+
+* w3.el, url.el, url-vars.el, url-http.el:
+Patches from Thierry Emery to allow multiple asynch fetches.
+
+Fri Nov 22 22:26:35 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* widget-edit.el, widget.el: -Synch'd up to widget 1.01
+
+* w3-style.el: Fixed a few fRemoved a few free variable sets/refs
+
+* w3.el:
+When saving a document as html source, try to get into the 'head' before inserting the base.
+
+* w3-display.el, w3-style.el:
+Stylesheets now store all there information as property lists instead
+of assoc lists.  Just easier.
+
+* font.el: Fix for font-normalize-color under nextstep
+
+Thu Nov 21 04:01:22 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* widget-edit.el, widget.el: synch'd to 1.00 of widget/custom
+
+Mon Nov 18 16:26:06 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* install.sh: Initial revision
+
+* html32.dsl: Updated to latest from jon bosak
+
+* w3-vars.el: Created version 3.0.30
+
+Thu Nov 14 22:39:36 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3.el: Changed this so you can actually just do a (require 'w3-sysdp) and
+each function will check to see if it should overwrite, instead of
+conditionalizing that on the whole file.
+
+* url.el: *** empty log message ***
+
+* images.el, font.el, docomp.el, w3-sysdp.el:
+Changed this so you can actually just do a (require 'w3-sysdp) and
+each function will check to see if it should overwrite, instead of
+conditionalizing that on the whole file.
+
+* w3-display.el: Moved some macros around.
+
+* widget.el, widget-edit.el, w3-forms.el: Sync'd up to Widget 0.999
+
+* w3-auto.el, w3-menu.el: *** empty log message ***
+
+Sun Nov 10 18:08:24 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.29
+
+* dsssl.el: Various changes, starting on the actual flow object stuff
+
+Tue Nov  5 05:26:07 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* url-news.el: Updated version checking of news to deal with 'red' gnus
+
+Mon Nov  4 14:47:47 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el: Don't show the content of 'script' - typo
+
+Fri Nov  1 15:08:45 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* default.css: Changes from raman
+
+Thu Oct 31 18:51:52 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* widget-edit.el: -
+
+Tue Oct 29 19:53:38 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el: *** empty log message ***
+
+Thu Oct 24 02:25:03 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-widget.el: Updated the image widget to the new widget stuff.
+
+Wed Oct 23 13:26:09 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* docomp.el: *** empty log message ***
+
+* url.el: Fixed bug in url-remove-relative-links that would choke on something
+like: /foo/bar/./../baz/ - they /../ was removed first, removing its
+parent directory, the /./ - ack.
+
+* w3-display.el: Image loading is back!
+Client-side imagemaps are back!
+Forms that span tables are working now.
+
+Mon Oct 21 21:32:33 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.28
+
+* url-mail.el: Make mail handling a little more generic.
+
+* w3-display.el:
+Fix for w3-display-fix-widgets so that links right up against each
+other don't cause it to skip every-other-one.
+
+Sun Oct 20 16:47:05 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-style.el: don't map a pitch of 9 to 0.
+
+* w3-speak.el:
+Added back in the advice for url-lazy-message that provided auditory
+feedback during URL retrieval.  Also added back in the
+w3-speak-browse-page command.
+
+* w3-speak.el:
+Some patches from TV Raman to fix multiline text entry area speaking
+and a bogus call to widget-get in text entry area speaking.
+
+Fri Oct 18 12:27:04 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el:
+Patches from Thierry Emery <Thierry.Emery@aar.alcatel-alsthom.fr> to
+implement 'colspan' on tables.  Patch to support align=xxx on
+arbitrary tags.
+
+Thu Oct 17 22:27:44 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.27
+
+* w3-display.el:
+fixed voicification of hyperlinks.  Fixed problem in w3-normalize-spaces
+and multi-line strings.
+
+Wed Oct 16 20:56:40 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-speak.el: Fix stupid problem.  function renaming lossage.  Fun
+
+* w3-display.el:
+Fixed <select> form items that had no <option value=xxx selected>
+entry in them.  Wheee.
+
+* w3-display.el:
+Fixed <select> form items that had an <option value=xxx selected>
+entry in them.  Wheee.
+
+* w3.el: document info is now shown as a table.
+
+* w3.el: Document information is now shown as a table.
+
+* w3-display.el, w3-vars.el: Now keeps better track of the <meta> tag info
+
+* w3-vars.el: Created version 3.0.26
+
+* w3-display.el: *** empty log message ***
+
+Tue Oct 15 13:21:54 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el: Added back in <meta> and <link> handling.
+Fixed insert-before and insert-after for 'a' tag and pseudo-classes
+
+* w3-display.el:
+Fixed some potential runaway style inheritance - need to think about a
+better way to pop style info off the various stacks than
+(w3-handle-content node) on an empty element.
+
+* w3-display.el: Fixed <textarea> elements in forms
+
+* w3-display.el, w3-forms.el: Fixed <select> elements in forms
+
+Sun Oct 13 23:50:03 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.25
+
+* dsssl.el: Bug fixes
+
+* url-hash.el:
+Fixed bug in url-gethash where it wasn't honoring the 'default' parameter
+
+Sat Oct 12 20:32:49 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* widget.el, widget-edit.el: Synched up to widget 0.99.4
+
+Fri Oct 11 18:55:02 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el: fix for xemacs w/ temp faces
+
+* w3-display.el: Fixed a bug with the insert-after handling. Duhh.
+
+* default.css, w3-display.el: Implemented insert-before and insert-after
+
+Wed Oct  9 19:00:59 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* ssl.el, url-cookie.el, url-file.el, url-gopher.el, url-hash.el, url-http.el, url-irc.el, url-mail.el, url-misc.el, url-news.el, url-nfs.el, url-parse.el, url-pgp.el, url-vars.el, url-wais.el, url.el, urlauth.el, w3-about.el, w3-annotat.el, w3-display.el, w3-e19.el, w3-emulate.el, w3-forms.el, w3-hot.el, w3-imap.el, w3-keyword.el, w3-latex.el, w3-menu.el, w3-mouse.el, w3-mule.el, w3-parse.el, w3-prefs.el, w3-print.el, w3-speak.el, w3-style.el, w3-toolbar.el, w3-vars.el, w3-widget.el, w3-xem20.el, w3-xemac.el, w3.el, xbm-button.el, xpm-button.el, base64.el, dsssl.el, font.el, images.el, md5.el, mm.el:
+-Updated copyrights/addresses
+
+Tue Oct  8 14:56:22 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el: Tables now default to having no border
+
+* w3-forms.el: Require w3-vars so Gnus will work
+
+* w3-vars.el: Created version 3.0.24
+
+* w3-speak.el:
+Added a few patches from raman and the latest version of emacspeak -
+everything appears to work out of the box now.
+
+* w3-style.el:
+Added in a few autoloads for getting emacspeak to work right out of the box.
+
+* w3-display.el: Added back in the :help-echo stuff on widgets
+
+Mon Oct  7 18:09:17 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el:
+<isindex> works again.  Automatically turns off filladapt-mode now,
+since we apparently don't play well together.
+
+* default.css: Added some margins
+
+* w3-display.el: Fix for emacs 19
+
+Fri Oct  4 17:08:51 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* dsssl.el:
+Fixed a few errors in calling w3-dsssl-check-args.  Now _EVERYTHING_
+compiles cleanly.
+
+* docomp.el: Added a few more variables to the 'expected-to-be-free' list.
+Everything but dsssl.el compiles cleanly now.
+
+* url-news.el: Fixed a few typos that resulted in free variable references.
+
+* w3-display.el: New function w3-make-face to 'do the right thing' in
+Emacs/XEmacs/Emacs-with-no-X-support.
+Implemented margin-left and margin-right.
+Fixed a few problems with runaway or insufficient application of styles.
+
+Mon Sep 30 19:43:35 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* url-hash.el:
+Nasty hack to fix the   !! error (("file \"cl-extra\" didn't define \"gethash\"")) stuff people are seeing under Emacs-19
+
+* w3-vars.el: Created version 3.0.23
+
+* w3-prefs.el: Updates for new widget package
+
+* w3-display.el:
+No more recursion!  Lots more shit broke though.  Lists are totally broken.
+
+* w3.el: Updates for new widget package
+
+* w3-keyword.el: *** empty log message ***
+
+Sun Sep 29 21:26:47 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* widget.el, widget-edit.el: Updated to version 0.99 of the library
+
+* widget-edit.el: Allow the :help-echo widget stuff to be a symbol
+
+* w3.el: More updates for the latest widget package
+
+* w3-sysdp.el: New functions prepend-text-property, append-text-property,
+fillin-text-property
+
+* default.css, url.el: *** empty log message ***
+
+Wed Sep 25 10:53:08 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* dist.Makefile: Removed custom.el and custom-edit.el from the distribution.
+
+Tue Sep 24 05:04:47 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.22
+
+* widget.el, widget-edit.el: Updated to latest widget stuff from Per.
+
+* w3-parse.el:
+Added <script> to %body.content so that stupid IE 3.0 demo pages would work.
+
+* w3-keyword.el:
+Added some new keyword defs to get rid of compile-time warnings
+
+* w3-forms.el, w3-display.el: Now works with newest widget stuff
+
+* url.el: New function url-parse-query-string, to return an assoc list of name
+value pairs from a URL-style query. url-unhex-string now takes an
+optional second argument for whether to allow decoding of newlines or
+not.
+
+* url-mail.el:
+Now understands netscape-style 'extensions' to the mailto: specifier.
+ie: mailto:wmperry?subject=thesubject&bcc=root
+
+* font.el:
+Now always converts to points instead of pixels, seems to give better
+results this way.
+
+Mon Sep 23 04:53:56 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.20
+
+* dsssl.el: Made dsssl depend on url-hash
+
+Sun Sep 22 05:16:06 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el, w3-parse.el: *** empty log message ***
+
+* w3-display.el: Some spacing changes, fix for nested lists
+
+* custom.el, widget-edit.el, widget.el: -
+
+* custom-edit.el: *** empty log message ***
+
+Fri Sep 20 05:07:12 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.19
+
+* w3-display.el: *** empty log message ***
+
+* w3-sysdp.el: Added in stub for set-keymap-parents
+
+* w3-speak.el: Patches from raman
+
+* w3-prefs.el, w3-imap.el: *** empty log message ***
+
+* w3-hot.el: Fixed w3-read-html-bookmarks to work with some parser changes.
+
+* w3-forms.el: Made forms work again.
+
+* w3-display.el: Changed how the borders on tables are drawn.
+Added back in the voice support.
+
+Thu Sep 19 05:12:49 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.18
+
+* dist.Makefile:
+Moved the URL and W3 packages back into one big distrubtion again
+
+* w3-vars.el: Created version 3.0.18
+
+* w3-vars.el: Created version 3.0.19
+
+* w3-display.el: Don't crap out on tables with 0 columns
+
+* docomp.el, url.el: *** empty log message ***
+
+Wed Sep 18 12:50:03 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.18
+
+* docomp.el: *** empty log message ***
+
+* w3-display.el: Space filling fixes
+
+* w3-auto.el: Added autoload for w3-style-post-process-stylesheet
+
+Tue Sep 17 12:50:47 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.16
+
+* w3-display.el, w3-e19.el: *** empty log message ***
+
+Mon Sep 16 04:46:18 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* custom-edit.el, custom.el, widget-edit.el, widget-example.el, widget.el:
+Initial revision
+
+Sun Sep 15 22:47:53 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.15
+
+* w3-display.el: Alignment stuff works (right, left, full, center).
+Tables can now be borderless, and if it has borders, they are all there.
+<pre>/<xmp> work.
+
+* url-vars.el: Created version 1.0.42
+
+* url-http.el: *** empty log message ***
+
+* w3-vars.el: Created version 3.0.14
+
+* html32.dsl: Initial revision
+
+* w3.el: Use the new display code.
+
+* w3-forms.el: A few changes for the latest display code
+
+* w3-vars.el: Created version 3.0.14
+
+* w3-display.el: Actually mostly works
+
+* w3-parse.el: Removed hooks into the old display engine
+
+* url.el: *** empty log message ***
+
+* w3-speak.el: Update from raman
+
+* url.el: *** empty log message ***
+
+Sat Sep 14 16:48:24 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* url-gopher.el, url.el:
+Added '...' to the downloading messages so that they do not show up in
+the message log buffer under Emacs 19.xx
+
+* w3-parse.el: Changed content-model of <script> to fix problems on some sites
+(notably netscape's) that use an unescaped </ in the script.  BAD SGML
+DAMMIT.
+
+Fri Sep 13 05:24:53 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.13
+
+* w3-forms.el: Use the new :ignore-case stuff for choice items
+
+Thu Sep 12 05:57:47 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-display.el: Holy shit tables work.
+
+Tue Sep 10 03:11:55 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-speak.el: Bug-fixes from raman.
+
+Mon Sep  9 05:18:37 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* dsssl.el:
+Removed a few compiler warnings and fixed a few bugs (equal, error, time
+
+* dsssl.el:
+DSSSL (define ...)'d functions are now called correctly.  Wow.  Added
+in most of the rest of the DSSSL(o) application profile functions.
+
+* dsssl.el: Initial revision
+
+* w3-parse.el: *** empty log message ***
+
+* w3-about.el, w3-annotat.el, w3-draw.el, w3-e19.el, w3-emulate.el, w3-forms.el, w3-hot.el, w3-imap.el, w3-keyword.el, w3-menu.el, w3-mouse.el, w3-mule.el, w3-prefs.el, w3-print.el, w3-speak.el, w3-style.el, w3-toolbar.el, w3-vars.el, w3-widget.el, w3.el, w3-xemac.el, images.el:
+Changed copyright assignment
+
+* font.el: changed copyright assignment
+
+Sun Sep  8 00:31:52 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-draw.el:
+Added in a stub handler for the 'frame' tag, so that you can still get
+to frame pages written by idiots who don't use a decent 'noframe'
+subdocument.
+
+* url.el: Removed nntp-after-change-function, since it screwed up GNUS
+
+Sat Sep  7 01:45:17 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-latex.el: updated email address for stephen peters
+
+Wed Sep  4 02:09:08 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* socks.el: Initial revision
+
+Sun Sep  1 16:22:50 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-draw.el: Don't load images on a TTY device in XEmacs.  General speedup
+
+Thu Aug 29 04:09:40 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-vars.el: Created version 3.0.12
+
+Sun Aug 25 17:12:32 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-draw.el: Added some stubs for tables
+
+Mon Aug 19 03:30:47 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3.el: fixed bug in w3-insert-formatted-url
+
+Mon Aug 12 03:10:30 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* w3-style.el: Don't make a null voice of paul-5555 if no stuff is specified.
+
+* default.css: Added speech elements to the default stylesheet.
+
+Sun Aug 11 16:41:58 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-vars.el: Created version 3.0.11
 
@@ -6,7 +1185,7 @@
 Fix for font-default-font-for-device under XEmacs when you use a font
 like '10x20' instead of the fully specified version
 
-Sat Aug 10 16:14:08 1996  William Perry  <wmperry@cs.indiana.edu>
+Sat Aug 10 16:14:08 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-forms.el:
 Do not encode the '.' in application/x-www-form-urlencoded.  Fucking
@@ -17,7 +1196,7 @@
 Fixed problem with submissions of a form with the exact same arguments
 causes elements from both form to be submitted.  ack.
 
-Tue Aug  6 14:03:52 1996  William Perry  <wmperry@cs.indiana.edu>
+Tue Aug  6 14:03:52 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-parse.el:
 fixed stupid mistake in DTD I made when changing to 3.2 DTD - left
@@ -28,13 +1207,13 @@
 
 * w3-speak.el: fixed bugs
 
-Mon Aug  5 14:03:09 1996  William Perry  <wmperry@cs.indiana.edu>
+Mon Aug  5 14:03:09 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-vars.el: Created version 3.0.10
 
 * default.css: A few mild changes, and docs.
 
-Sun Aug  4 23:51:26 1996  William Perry  <wmperry@cs.indiana.edu>
+Sun Aug  4 23:51:26 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-speak.el: new version of w3-speak from raman
 
@@ -53,16 +1232,28 @@
 
 * w3-parse.el: fixed graphical entities
 
-Sat Aug  3 20:09:50 1996  William Perry  <wmperry@cs.indiana.edu>
+Sat Aug  3 20:09:50 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-vars.el:
 Added textual representation of the 'artist formerly known as prince'
 graphical icons
 
-Thu Aug  1 13:32:54 1996  William Perry  <wmperry@cs.indiana.edu>
+* md5.el: removed /bin/sh dependency in md5
+
+Fri Aug  2 14:08:38 1996  William M. Perry  <wmperry@cs.indiana.edu>
+
+* url-vars.el: Created version 1.0.41
+
+* url.el:
+no longer special case file:// urls when checking for no_proxy - thats
+just stupid.
+
+Thu Aug  1 13:32:54 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-vars.el: Created version 3.0.9
 
+* url.el: made url-insert-file-contents  interactive
+
 * w3-sysdp.el:
 added data-directory to sysdep version of x-library-search-path for
 emacs under windows 95/nt
@@ -75,9163 +1266,6 @@
 
 * w3-draw.el: Added support for balloon-help
 
-Fri Jul 26 05:57:21 1996  William Perry  <wmperry@cs.indiana.edu>
+Fri Jul 26 05:57:21 1996  William M. Perry  <wmperry@cs.indiana.edu>
 
 * w3-display.el, w3-texinfo.el: Initial revision
-
-* w3-parse.el: *** empty log message ***
-
-* w3-hot.el: Should now be able to handle XMosaic style hotlist files
-
-* w3-parse.el:
-Added some HTML 3.2 stuff, reorged some of the content-models, et. c
-
-* w3-draw.el: few fixes to the title handling.
-don't display any text outside the <html></html> area
-
-* w3-style.el:
-Changes to w3-style-parse-css to gracefully ignore <!-- and --> in a
-stylesheet, for those losers who insist on using SGML comments to hide
-the <style> tag from stupid browsers.
-
-* w3-parse.el:
-Changed the content model of the <style> tag to CDATA so that idiots
-who want to hide the style information from stupid old browsers by the absolutely braindead use of comments (<!-- ... -->) can.  *sigh*
-
-Thu Jul 25 05:00:55 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-style.el: Fixed stupid bug in :device: handling
-
-Tue Jul 23 00:40:54 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-keyword.el: more keywords for speech stuff
-
-* docomp.el: *** empty log message ***
-
-* w3-draw.el:
-Beginnings of support for the new and improved fucked up netscapism
-<spacer> tag
-
-Mon Jul 22 03:22:52 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-sysdp.el: added stub for make-local-hook - more Emacs 19.2x lossage.
-
-* w3-forms.el:
-always encode hex strigs into uppercase for stupid broken fucking
-braindead forms decoders!!!
-
-Sun Jul 21 20:07:50 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-vars.el: Created version 3.0.8
-
-* w3.txi: fixed a few compilation errors in w3.txi
-
-* w3.txi: Revamped a few nodes, removed the downloading/compiling notes, and
-documented url-proxy-services and improved the proxy section in
-general.
-
-* w3-hot.el: Should now auto-recognize HTML bookmark files
-
-* font.el: Allow a font to have a size like "+12pt"
-
-* w3-draw.el:
-Now handles <font face="xxxx"> ala Internet Exploiter and Nutscrape
-
-* w3.el: Added function for reloading all stylesheets
-
-* w3-menu.el: Added option to the 'style' menu for reloading stylesheets
-
-* w3-forms.el:
-fixed problem with dropwon menus with the same 'value' would show the first item with that value, not necessarily the one the user selected.
-
-* w3-widget.el: w3-follow-inlined-image works again
-
-* w3-draw.el, w3-keyword.el, w3-menu.el, w3-vars.el, w3-xemac.el, w3.el:
-You can now load delayed images
-
-Sat Jul 20 05:15:06 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3.txi: Removed 16-bit windows section.
-removed programming interface chapter.
-fixed Gnus accessing function docs.
-added pointer to browse-url-browser-function.
-removed docs of w3-delimit-emphasis / w3-delimit-links.
-
-* w3-forms.el:
-If a form has an invalid encoding type, issue a warning about the bad
-html and the fall back on application/x-www-form-urlencoded
-
-* w3-style.el:
-@import no longer causes a 'buffer-modified, kill it anyway?' question.
-newer CSS font shorthand supported.
-split the font-family on commas, not spaces, ala newer CSS.
-
-* font.el: A few changes to the default font-family-mappings
-
-* w3-draw.el:
-Allow global document stuff to be specified on the 'body' tag as well
-as the 'html' tag.
-
-Fri Jul 19 04:35:48 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-vars.el: Created version 3.0.7
-
-Thu Jul 18 14:20:20 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* default.css:
-moved monospaced font declaration for pre/xmp into the :xemacs: section
-
-Tue Jul 16 02:49:55 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-latex.el: Lots of patches from stephen peters.
-* Fix to backslash handling code so that it works.
-
-* Fix to ~ (very important, that) so that it generates a
-  `\textasciitilde', since in a <tt> environment the previous call
-  would work incorrectly.  Similar fix for ^ characters.
-
-* For carriage returns in a verbatim environment, use `\newline'
-  instead of `\ '.  Also adds a \nullspace command for use in <pre>
-  environments, since the existing code for <pre> tended to eat
-  leading whitespace without it.
-
-* Use `\newline' instead of `\linebreak', since \linebreak tries to
-  justify the line out to the text width.
-
-* Added `\batchmode' call at the beginning of the generated LaTeX, to
-  force attempted recovery of any errors.
-
-* Added calls to not indent paragraphs and skip lines between
-  paragraphs.  I'm not sure whether I like this better or not, but I
-  figured that most HTML browsers currently use that formatting.  This
-  should be changed once stylesheets are working nicely, to use
-  whatever's specified in the stylesheet for LaTeX.
-
-Mon Jul 15 17:33:19 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-draw.el:
-tty-closest-color-matching now works for netscape-style color crap as
-well as stylesheet stuff
-
-* w3-parse.el, w3-xemac.el: anal retentive patch for mispelling in comments
-
-Sat Jul 13 22:47:21 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3.el:
-w3-echo-link stuff is now handled in the new widget-motion-hook variable.
-
-* widget-edit.el:
-New hook - widget-motion-hook - called with the widget moved to.
-
-* w3-draw.el:
-w3-echo-link stuff is now handled in the new widget-motion-hook variable.
-when following a link, its color is changed correctly.
-
-Fri Jul 12 05:52:49 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-style.el: fixed problem parsing class attributes in CSS
-
-* w3-style.el: *** empty log message ***
-
-Thu Jul 11 18:00:20 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-style.el: deal gracefully with device-bitplanes returning nil
-
-* w3-style.el: You can now use a :speech: device section in a CSS stylesheet
-
-* patch-for-old-emacsen: Initial revision
-
-* w3-sysdp.el: version of valid-color-name-p and device-class for the OS/2
-presentation manager.
-
-* w3-e19.el: Some OS/2 hacks
-
-* w3-draw.el:
-sanity check the fill-prefix before setting it, and issue a warning if
-list indentation tries to overflow the right window margin.
-
-* w3-vars.el: Created version 3.0.6
-
-Wed Jul 10 23:50:10 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-draw.el: fixed problem with emacspeak
-
-* default.css: *** empty log message ***
-
-* dist.Makefile: fixed install target - duh
-
-* w3.el: some more mule fixing
-
-* w3.el: remove compression extensions from default save-as filenames
-
-* w3.el: fixed w3-save-binary-file to set initial-contents on the call to
-read-file-name
-
-* w3-hot.el: fixed problem with w3-hotlist-add-document-at-point
-
-* w3-parse.el: Fix for mule and character entities > 127
-
-* w3-draw.el:
-fixed mysterious problem of stylesheet formatting info not working
-correctly the first time a tag was seen.  *dumb* mistake on my part.
-
-Tue Jul  9 21:01:15 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-sysdp.el: added more overlay functions
-
-* w3-vars.el: Created version 3.0.5
-
-* w3.el: *** empty log message ***
-
-* dist.Makefile:
-Now uses 'install' to do the copying around, instead of trying to fake it.
-
-* dist.Makefile: *** empty log message ***
-
-* font.el: Require disp-table so that display table stuff is loaded (apparently
-XEmacs 19.13 didn't autoload or dump it - *sigh*)
-
-* dist.Makefile: No longer mention THIS-IS-VERSION-XX in the makefile
-
-* w3.el: *** empty log message ***
-
-* w3.el: Fixed w3-save-binary-file
-
-* w3.el, w3-speak.el, w3-style.el, w3-draw.el: voices-via-stylesheet fixes
-
-* dtk-css-speech.el: Initial revision
-
-* w3-forms.el: wais submissions work again
-
-* w3-print.el: fix problem with ps-print and forms printing (read-only text)
-
-Sun Jul  7 22:04:07 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-vars.el: Created version 3.0.4
-
-* w3-forms.el: <input type=radio checked> works now
-
-* w3-forms.el: Radio buttons work again.  *sigh*
-
-Thu Jul  4 16:32:06 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-draw.el: Let stylesheets handle the w3-delimit-links stuff
-
-Mon Jul  1 15:42:21 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-vars.el: Created version 3.0.3
-
-* widget-edit.el: another patch to not require new-style backquote processing
-
-* w3-sysdp.el: Added stub for buffer-substring-no-properties
-
-* w3-menu.el:
-Do not use menus under Emacs 19.28 - they are broken / incompatible
-with that version of easymenu
-
-* w3-sysdp.el: Fix to device-or-frame-type to work under Emacs 19.28
-
-* w3.el: fix for set-auto-mode lossage on null buffer-file-name
-
-* w3-sysdp.el: Added in stubs for plist-put and plist-get, and an Emacs 19.2x
-specific version of facep.  everything almost works in 19.28 now.
-
-* widget-edit.el: Don't assume native backquoting abilities
-
-Sun Jun 30 22:53:02 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-vars.el: Created version 3.0.2
-
-* w3.txi: *** empty log message ***
-
-* w3.el, w3-xemac.el, w3-widget.el, w3-toolbar.el, w3-sysdp.el, w3-style.el, w3-speak.el, w3-print.el, w3-prefs.el, w3-parse.el, w3-mule.el, w3-mouse.el, w3-menu.el, w3-latex.el, w3-keyword.el, w3-imap.el, w3-hot.el, w3-forms.el, w3-emulate.el, w3-e19.el, w3-draw.el, w3-annotat.el, w3-about.el, images.el, font.el, w3-vars.el:
-Changed email address info
-
-* dist.Makefile: Added w3-latex.el to the dist.Makefile
-
-* w3-vars.el, default.css: *** empty log message ***
-
-* font.el: final fix for font-height lossage
-
-* docomp.el: added menubar-visible-p
-
-Wed Jun 26 16:38:12 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* font.el:
-Use truncate instead of round for font sizes - usually gives better results
-
-* w3-annotat.el, w3.el:
-Patch from Darrell Kindred <dkindred+@cmu.edu> for news problems
-1. nnheader-init-server-buffer isn't called, so the
-     first call to nntp-open-server fails.  (Patch inserts
-     a call to nnheader-init-server-buffer in url-news-open-host.)
-  2. The `&', '<', and '>' characters don't get turned into
-     entities in news from lines, subject, body, etc.  The result
-     is that "William Perry <wmperry@monolith.spry.com>" shows up
-     as "William Perry @monolith.spry.com>".  (The patch moves
-     w3-insert-entities-in-string to url.el and renames it to
-     url-insert-entities-in-string, then calls it from url-format-news.
-  3. When displayed, news articles get an extra, empty
-     "References" entry.  (Patch inserts a `(delete "" ...)'
-     to remove the trailing empty reference from the list.)
-
-Tue Jun 25 19:00:48 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-menu.el: Revamped the options menu - added the edit-preferences button.
-
-* w3.el: Fix for window-splitting with the back button
-
-* w3-sysdp.el: Added bogus definition of set-marker-insertion-type
-
-Mon Jun 24 14:51:18 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-about.el: changed pointers for xemacs.cs.uiuc.edu to xemacs.org
-
-Fri Jun 14 16:50:26 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-auto.el: *** empty log message ***
-
-* w3-vars.el, w3.el, w3-forms.el:
-Fixes for mule from MORIOKA Tomohiko <morioka@jaist.ac.jp>
-
-* w3-xem20.el: Initial revision
-
-* w3-prefs.el: fixed problem under FSFmacs
-
-Thu Jun 13 14:31:38 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-menu.el:
-Extended w3-menu-save-options to save more info.  Different way of
-turning menubar on/off in XEmacs 19.14 (menubar-visible-p specifier)
-
-* w3-latex.el: Applied hypertext link printing patches from Stephen Peters
-<speters%samsun@us.oracle.com>
-
-* w3.el: patch for imbalanced tags in w3-document-information
-
-* w3-prefs.el: All the panels work to some degree now
-
-Wed Jun 12 03:25:39 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* w3-prefs.el: More panels work
-
-* w3-forms.el: fix for radio button munging
-
-Tue Jun 11 23:47:37 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* widget-edit.el:
-fixed bug in widget-forward if a widget extended to (point-max)
-
-* w3.el: *** empty log message ***
-
-Sun Jun  9 21:21:35 1996  William Perry  <wmperry@cs.indiana.edu>
-
-* widget-edit.el: Few bug fixes for widget-backward behaviour
-
-* w3-speak.el: more renamings that I forgot before
-
-* w3.el: w3-find-default-stylesheets is now a little smarter (looks for
-stylesheets in the directory it is being loaded from).  Error messages
-when no default stylesheet can be found is much better now as well.
-
-* dist.Makefile, clean-cache, default.css, w3.txi, descrip.mms, font.el, images.el, w3-about.el, w3-annotat.el, w3-auto.el, w3-draw.el, w3-e19.el, w3-emulate.el, w3-forms.el, w3-hot.el, w3-imap.el, w3-keyword.el, w3-latex.el, w3-menu.el, w3-mouse.el, w3-mule.el, w3-parse.el, w3-prefs.el, w3-print.el, w3-speak.el, w3-style.el, w3-sysdp.el, w3-toolbar.el, w3-vars.el, w3-widget.el, w3-xemac.el, w3.el, widget-edit.el, widget.el, xbm-button.el, xpm-button.el, docomp.el:
-Initial revision
-
-Thu Jun  6 15:03:15 1996  William Perry  <wmperry@indiana.edu>
-
-
-* w3-auto.el: Added autoload for w3-show-dvi
-
-* w3-latex.el: w3-parse-tree-to-latex now takes optional URL argument.
-<pre> and <xmp> text now work correctly.
-Added a known-bugs section.
-Added a variable for whether to print hyperlinks as footnotes or not.
-
-
-* w3-annotat.el, w3-e19.el, w3-forms.el, w3-hot.el, w3-prefs.el, w3-xemac.el, w3.el:
-Replaced w3-insert w/insert - no longer needed
-
-* w3-latex.el: Added footnotes for hypertext links
-
-Wed Jun  5 20:18:36 1996  William Perry  <wmperry@indiana.edu>
-
-* w3-latex.el:
-Changed some things to be more like w3-draw in how it gets formatting
-informatino for each chunk
-
-* w3.el:
-Merged in new latex printing code from Stephen Peters <speters%samsun@us.oracle.com>
-
-* w3-print.el: Stephen Peters <speters%samsun@us.oracle.com>
-
-* w3-auto.el:
-Merged in new latex printing code from Stephen Peters <speters%samsun@us.oracle.com>
-
-* w3-latex.el: Initial revision
-
-* w3-parse.el: patch from jbw for eveil <! comment syntax
-
-Mon Jun  3 20:43:37 1996  William Perry  <wmperry@indiana.edu>
-
-* w3-parse.el, w3-vars.el:
-added flag for whether to honor netscape style <! > comments.
-
-
-* w3-parse.el, w3-vars.el: Added alt text capabilities to w3-graphic-entities
-
-* w3-menu.el: Toggling menubar from Emacs->W3 works again
-
-* w3.el: w3-map-links works again, so does w3-complete-link
-
-* w3-e19.el, w3-xemac.el: removed old def. of w3-map-links
-
-* w3-draw.el: fixed url expansion
-
-* w3-forms.el:
-More fixes for netscape compatibility with single-text entry form
-submissions
-
-* w3-speak.el:
-Added a few patches from Raman (folding-mode stuff) and definition of
-advice for w3-scroll-up
-
-* w3-prefs.el:
-Got rid of some compiler warnings about free variables, and removed
-some bogus variables that I can get elsewhere now
-(w3-preferences-numglyphs)
-
-* w3-prefs.el: Added hooks for setting up the prefs buffer, and ok/cancel/reset
-hooks.  Fixed saving of proxy information
-
-* descrip.mms: Updated VMS MMS file
-
-* dist.Makefile: Added w3-prefs to the distribution
-
-Sun Jun  2 20:09:22 1996  William Perry  <wmperry@indiana.edu>
-
-* w3-draw.el: a few more emacspeak extensions
-
-
-* w3-e19.el: Fixed compile-time errors re: w3-form-element-* functions
-
-* w3-draw.el: fixed bug in w3-valid-voice-p
-
-
-* w3-speak.el: fixed some compiler warnings
-
-
-* dist.Makefile: Added w3-speak.el to the distribution
-
-* w3-speak.el:
-Move some functionality of the w3-fetch defadvice into a w3-mode-hook
-that is automatically added by w3-speak-use-voice-locking
-
-* w3-speak.el: Wow, I think it will work
-
-* w3-draw.el: reimplemented w3-echo-link
-
-* w3.el: fixed problem of not resetting the user's value of url-be-asynchronous
-in the new version of w3-download-url
-
-* w3.el: Made w3-download-url asynchronous by default, and make sure it asks
-for the filename before it starts the download.
-
-Sat Jun  1 20:04:22 1996  William Perry  <wmperry@indiana.edu>
-
-* w3.el: Fixed w3-download-url
-
-* w3-parse.el: Fixed graphic entities to use normal entity expansion instead of
-'STARTTAG - see commentary in the code for why exactly.
-
-* w3.el: Fixed w3-mail-document-author to do the right thing for 'made' links
-again.  Now searches for mail(to|server) links first.  If none found,
-takes the first 'made' link and fetches that.  If one found, fetch it.
-If more than one mail(to|server) link is found, present the user with
-a list and let them choose.
-
-* w3-speak.el: Initial revision
-
-Fri May 31 21:34:19 1996  William Perry  <wmperry@indiana.edu>
-
-* w3-draw.el, w3-style.el: Basic support for emacspeak out of the box
-
-* w3.el: Fixed typo in w3-popup-info
-
-* w3-parse.el: Fixed bug in graphic entity creation
-
-* w3.el: Added new function w3-describe-entities that lists all the entities
-currently defined.
-
-* w3-parse.el: Added in new definitions for graphic entities - they live again!
-
-* w3-vars.el: Added in new definitions for graphic entities
-
-
-Thu May 30 17:32:36 1996  William Perry  <wmperry@indiana.edu>
-
-
-* w3-prefs.el:
-Changed to only using one buffer instead of two stacked buffers - was
-too big a pain in the ass to navigate w/o the mouse.
-
-* w3-forms.el: fixed form submission changes
-
-* w3-draw.el:
-Supports target'ed windows to some extent (external, _blank, _top)
-
-* w3.el: delete-other-windows in w3-fetch-other-frame
-
-* w3-draw.el:
-the hyperlnk widgets now keep _all_ attributes that are specified on a
-link in them as widget properties.  This will eventually allow us to
-do targetted windows, etc.
-
-
-* w3-prefs.el: protect against errors in widget-forward
-
-* w3-prefs.el:
-Ok, cancel, and save buttons work.  Proxy configuration screen is
-complete.  Old window configuration restored when exiting.  Now
-selects the prefs window after choosing something from the toolbar
-
-* w3-sysdp.el: Added symbol-value-in-buffer
-
-
-* w3-draw.el, w3-forms.el: Single-entry form auto-submission now works again
-
-* w3-sysdp.el: Added insert-file-contents-literally function
-
-Wed May 29 21:52:40 1996  William Perry  <wmperry@indiana.edu>
-
-* w3-prefs.el: proxy panel sort of works
-
-* w3-print.el: Few patches to the latex printing by Stephen Peters
-<speters%samsun@us.oracle.com>
-
-* w3-mouse.el: w3-follow-inlined-image works again
-
-* w3-draw.el:
-Fixed problem with paragraph filling screwups after <xmp> sections
-
-* w3-vars.el:
-new keybinding for return so that return doesn't self-insert when not
-on a hyperlink
-
-
-* font.el: don't error out on bad rgb color values
-
-* font.el: Don't error out if you cannot find the rgb.txt file
-
-* w3-parse.el:
-Supports stupid %!@*ing netscape-style  `comments'.  What complete
-and utter horseshit.
-
-* w3-draw.el: fixed read-only errors once and for all. :)
-
-* w3-e19.el: removed old bogus definition of w3-follow-inlined-image-mouse
-
-
-* w3-prefs.el: progress
-
-* w3.el: Now correctly looks for 'stylesheet' in w3-configuration-directory.
-Avoid infinite recursion if url-be-asynch == t when
-w3-find-default-stylesheets is called
-
-* w3.el: fix for http 0.9 servers and asynchronous transfers
-
-* w3-widget.el:
-Actually added w3-image-widget-callback so 'href images work right
-
-Tue May 28 22:35:46 1996  William Perry  
-
-* w3-prefs.el: Initial revision
-
-
-* w3-menu.el: Put the correct Emacs/XEmacs in the menubar toggle
-
-* w3-draw.el:
-fixed problems with badly specifid colors in netscape-crap  attributes
-
-* w3-forms.el:  works minimally
-
-* w3-forms.el:
-Fixed a problem with option lists in forms.  The forms validator is cool
-
-* w3.el: previewing buffers now works much _MUCH_ better
-
-* w3.el: Added stub for w3-find-file, a more intuitive name for w3-open-local
-
-* w3-draw.el: Link-echoing now works
-
-* widget.el, widget-edit.el:
-Changed widget-forward to honor a new :help-echo property
-
-
-* widget-edit.el:
-Fix for widget-forward when widgets are _RIGHT_ on top of each other
-
-* w3.el: Fixed stupid problem on my part
-
-* w3-draw.el:
-Fix problem with 
     segments from Mac-based web servers (^M only, no ^J)
-
-* w3.el: Don't do set-auto-mode under mule, as it wigs out with null filenames
-
-* w3.el: Fixes for www: hrefs
-
-* w3.el: Fix for file information & last-modified
-
-Mon May 27 23:08:26 1996  William Perry  
-
-* w3-draw.el: problem in 19.30
-
-* w3-forms.el:
-Fixed problem with 'submit' button on forms _always_ being sent to the
-server - overanxious with making sure everything had a 'name' field at
-widget creation time.  Gack.
-
-* w3-xemac.el:
-Beginnings of a mode-motion-handler to do spiffy handling of client
-side imagemaps, etc.
-
-
-Sun May 26 01:17:31 1996  William Perry  
-
-* images.el: removed duplicate converter
-
-Fri May 24 18:19:16 1996  William Perry  
-
-* w3-draw.el: file: urls for images work now
-
-* w3.el: Fixed missing paren in configuration-file warning code
-
-* w3.el: New version of w3-version from "Robert J. Chassell"
- that will let you do C-u M-x w3-version to insert
-the version information into the buffer at point.
-
-* w3.el, w3-hot.el, w3-forms.el, w3-emulate.el, w3-annotat.el:
-No longer use mm-insert-file-contents lossage
-
-* images.el: Added p[np]m<->ps converters
-
-
-* w3-widget.el: No more newlines after images w/alt text & no hyperlink
-
-* w3.el: Moved where w3-default-configuration gets loaded so that you can set
-some variables in it and have them honored by the rest of w3-do-setup
-
-Thu May 23 16:08:23 1996  William Perry  
-
-
-* w3-draw.el:
-Now only grabs images with the same URL/SRC once per page, instead of
-starting up multiple transfers for the same one.  Yeah.
-
-* w3-menu.el: context-sensitive menus now work again on images
-
-* w3-sysdp.el: synching up with XEmacs 19.14's version
-
-* w3-sysdp.el: Added lots more device functions
-
-Wed May 22 17:08:21 1996  William Perry  
-
-
-* w3-widget.el: Now checks for invalid glyphs before removing the textual
-representation from the buffer.
-
-* w3.el: Removed w3-beta from the distribution - functionality moved elsewhere
-
-* w3-widget.el:
-Better handling of images that are hyperlinks that have no 'alt' text.
-
-* w3-draw.el:
-Some stuff from the old w3-beta, image fixes, initial color of html page should be better.
-
-
-* dist.Makefile:
-Removed w3-beta from the distribution - functionality moved elsewhere
-
-* w3-emulate.el: Moved w3-read-netscape-config into w3-emulate
-
-* w3-widget.el: Few screwups w/markers fixed
-
-Tue May 21 05:31:56 1996  William Perry  
-
-* w3-draw.el, w3-forms.el, w3.el: Some XEmacs 20.0 MULE changes
-
-* w3-xem20.el: Initial revision
-
-
-Mon May 20 16:17:37 1996  William Perry  
-
-* w3-draw.el: Asynch image loading works!
-
-* w3-widget.el: Put a help-echo property on the image extent when necessary
-
-* w3-imap.el: Removed lots of stuff into the new image widget
-
-* w3-widget.el:
-Make sure you always use a marker for the 'where' of an image widget
-
-* w3.el: w3-my-safe-copy-face is now a little more paranoid so that it will not
-bomb on TTYs
-
-Sat May 18 22:44:53 1996  William Perry  
-
-* widget-edit.el: some text property munging for XEmacs
-
-* w3-widget.el: Yet more bug fixes for ye olde image widget
-
-* w3-widget.el:
-reorded some checks in the image widget callback so that client side
-imagemaps got done correctly.
-
-* w3-draw.el:
-Fixed bug in the use of the new image widget when it was _not_ used
-like testtest
-
-* w3-forms.el: Support  ala netscape
-
-* w3-forms.el: Give default labels to submit and reset buttons
-
-
-Fri May 17 19:52:49 1996  William Perry  
-
-* w3-draw.el: Now uses the new image widget
-
-* w3-widget.el: Various fixes
-
-* dist.Makefile: Added w3-widget to the distribution
-
-* w3-forms.el:
-Fixed radio button formatting problems (similar to choice options)
-
-* w3-menu.el:
-Don't put the hide location and hide statusbar menu entries in under
-Emacs 19 just yet.
-
-* w3-imap.el: Few fixes for Emacs 19 in tty mode
-
-* w3-forms.el:
-Option lists now no longer insert a newline unconditionally.  Ack.
-
-* w3-draw.el: inhibit-read-only for some Emacs 19 lossage
-
-Thu May 16 16:15:01 1996  William Perry  
-
-* w3-menu.el: Better fix for XEmacs w/no menus
-
-* w3-mouse.el:
-Do not use button keysyms if no X support is compiled in (button1, etc)
-
-* w3-xemac.el:
-Don't make toolbar buttons if not (featurep 'toolbar).  Don't add our
-help stuff to the help menu unless (featurep 'menubar)
-
-* w3-menu.el:
-Don't install menus under XEmacs unless (featurep 'menubar), otherwise it will bomb on a TTY-only XEmacs.
-
-Tue May 14 16:32:16 1996  William Perry  
-
-* w3-widget.el: Initial revision
-
-* font.el: Strikethru stuff works again.
-
-* default.css: added some netscapisms in the default stylesheets
-
-* w3-style.el: Added a require 'cl for 'case' handling
-
-* w3-parse.el: Added 'strike' tag to %font in the DTD ala HTML 3.2
-
-Mon May 13 20:56:52 1996  William Perry  
-
-* dist.Makefile: Removed w3.ad from the distribution, as it is no longer used.
-
-Fri May 10 16:28:13 1996  William Perry  
-
-
-* w3-imap.el: Now displays client-side imagemaps pretty sweetly under Emacs 19
-(drop-down list of destinations)... Whoo hoo!
-
-
-* default.css: few changes to default stylesheet - nothing major
-
-
-* w3-draw.el: fixed problem in w3-decode-area-coords
-
-Thu May  9 13:46:42 1996  William Perry  
-
-
-Wed May  8 17:52:10 1996  William Perry  
-
-* w3.el: Avoid creating bad html in w3-document-information
-
-
-Tue May  7 16:06:20 1996  William Perry  
-
-
-* w3-vars.el: New keybinding C-A-t for listing open network transfers
-
-
-* w3-draw.el, w3-forms.el, w3-parse.el: Support  tags in the parser
-
-Mon May  6 18:03:06 1996  William Perry  
-
-* images.el: fixed image converter for tiff->pnm and pnm->tiff.  Also added
-converter for JBIG (?!) image type
-
-* w3-forms.el:
-Fall back to using old-style looking stuff for text entry areas - some
-HTML was truly confusing where the widget ended and began.  Gack.
-
-Thu May  2 16:24:12 1996  William Perry  
-
-
-* dist.Makefile: now installs default.css
-
-* w3-imap.el:
-image order fixed on pages with consecutive images with no text in between.
-
-* w3.el: Now looks in the data-directory and data-directory/w3/ subdir for
-stylesheet files.  Now looks for several stylesheet files, not just
-the first one it finds.
-
-Wed May  1 21:36:37 1996  William Perry  
-
-* w3-e19.el: fixed mouse waggling under fsf
-
-* w3-vars.el: Added default for w3-source-file-hook ... automatically goes into
-html-mode (should probably do font-lock as well to get netscap'y look)
-
-* w3-draw.el: Fixed  tags yet again... god am I stupid
-
-* w3-e19.el: Fixed mouse movement under FSF
-
-
-* w3.el: auto-autoload w3-do-setup
-
-* w3-vars.el: changed w3-documentation-root
-
-* w3-menu.el, w3-xemac.el, w3-toolbar.el, w3-mouse.el:
-
-* w3-menu.el:
-Now use w3-default-configuration-file for saving options from the menubar
-
-* w3-auto.el: removed a few autoloads due to the forms revamping
-
-* docomp.el: few more stub variables
-
-* w3-vars.el: More forms fixes
-
-* w3.el: Some jka-compr fixes
-
-* w3-style.el: removed annoying 'applying style hints' messages
-
-* w3-draw.el: Fixed the handling of default attributes on  tag for text
-coloring, etc.  Wasn't using the new syntax the stylesheet parser was
-expecting.
-
-* w3-hot.el, w3-menu.el: In XEmacs, changed the hotlist menu constructor to use
-w3-html-bookmarks instead of adding a separate menu item for it.
-Consitent with how it has to be done under Emacs19
-
-
-Tue Apr 30 20:45:20 1996  William Perry  
-
-* w3-mouse.el: In netscape emulation mode, emulate the mouse bindings as well.
-
-* font.el:
-Now takes care of setting a display-table on the face for smallcaps and bigcaps
-
-* w3-forms.el: more fixes
-
-* w3-sysdp.el: Added definition of alist-to-plist
-
-* w3-draw.el: fixed some "
+			   form			 ; Earlier string
+			   (or (nth 0 parms) "") ; Prompt string
+			   x			 ; Name
+			   (or (nth 1 parms) "") ; Default value
+			   )))
+       ((or (string= "select" type)
+	    (string= "choose" type))
+	(setq parms (url-string-to-tokens parms ?\t)
+	      form (format "%s\n
  • %s")))))
+    (concat form "\n
  • ")))
+
+(defun url-grok-gopher-line ()
+  "Return a list of link attributes from a gopher string.  Order is:
+title, type, selector string, server, port, gopher-plus?"
+  (let (type selector server port gopher+ st nd)
+    (beginning-of-line)
+    (setq st (point))
+    (end-of-line)
+    (setq nd (point))
+    (save-excursion
+      (mapcar (function
+	       (lambda (var)
+		 (goto-char st)
+		 (skip-chars-forward "^\t\n" nd)
+		 (set-variable var (buffer-substring st (point)))
+		 (setq st (min (point-max) (1+ (point))))))
+	      '(type selector server port))
+      (setq gopher+ (and (/= (1- st) nd) (buffer-substring st nd)))
+      (list type (concat (substring type 0 1) selector) server port gopher+))))
+
+(defun url-format-gopher-link (gophobj)
+  ;; Insert a gopher link as an  tag
+  (let ((title (nth 0 gophobj))
+	(ref   (nth 1 gophobj))
+	(type  (if (> (length (nth 0 gophobj)) 0)
+		   (substring (nth 0 gophobj) 0 1) ""))
+	(serv  (nth 2 gophobj))
+	(port  (nth 3 gophobj))
+	(plus  (nth 4 gophobj))
+	(desc  nil))
+    (if (and (equal type "")
+	     (> (length title) 0))
+	(setq type (substring title 0 1)))
+    (setq title (and title (substring title 1 nil))
+	  title (mapconcat
+		 (function
+		  (lambda (x)
+		    (cond
+		     ((= x ?&) "&")
+		     ((= x ?<) "<");
+		     ((= x ?>) ">");
+		     (t (char-to-string x))))) title "")
+	  desc (or (cdr (assoc type url-gopher-labels)) "(UNK)"))
+    (cond
+     ((null ref) "")
+     ((equal type "8")
+      (format "
  •  %s %s\n"
+	      desc serv port title))
+     ((equal type "T")
+      (format "
  •  %s %s\n"
+	      desc serv port title))
+     (t (format "
  •  %s %s\n"
+		desc type serv (concat port plus)
+		(url-hexify-string ref) title)))))
+
+(defun url-gopher-clean-text (&optional buffer)
+  "Decode text transmitted by gopher.
+0. Delete status line.
+1. Delete `^M' at end of line.
+2. Delete `.' at end of buffer (end of text mark).
+3. Delete `.' at beginning of line.   (does gopher want this?)"
+  (set-buffer (or buffer url-working-buffer))
+  ;; Insert newline at end of buffer.
+  (goto-char (point-max))
+  (if (not (bolp))
+      (insert "\n"))
+  ;; Delete `^M' at end of line.
+  (goto-char (point-min))
+  (while (re-search-forward "\r[^\n]*$" nil t)
+    (replace-match ""))
+;  (goto-char (point-min))
+;  (while (not (eobp))
+;    (end-of-line)
+;    (if (= (preceding-char) ?\r)
+;       (delete-char -1))
+;    (forward-line 1)
+;    )
+  ;; Delete `.' at end of buffer (end of text mark).
+  (goto-char (point-max))
+  (forward-line -1)                     ;(beginning-of-line)
+  (while (looking-at "^\\.$")
+    (delete-region (point) (progn (forward-line 1) (point)))
+    (forward-line -1))
+  ;; Replace `..' at beginning of line with `.'.
+  (goto-char (point-min))
+  ;; (replace-regexp "^\\.\\." ".")
+  (while (search-forward "\n.." nil t)
+    (delete-char -1))
+  )
+
+(defun url-parse-gopher (&optional buffer)
+  (save-excursion
+    (set-buffer (or buffer url-working-buffer))
+    (url-replace-regexp "^\r*$\n" "")
+    (url-replace-regexp "^\\.\r*$\n" "")
+    (url-gopher-clean-text (current-buffer))
+    (goto-char (point-max))
+    (skip-chars-backward "\n\r\t ")
+    (delete-region (point-max) (point))
+    (insert "\n")
+    (goto-char (point-min))
+    (skip-chars-forward " \t\n")
+    (delete-region (point-min) (point))
+    (let* ((len (count-lines (point-min) (point-max)))
+	   (objs nil)
+	   (i 0))
+      (while (not (eobp))
+	(setq objs (cons (url-grok-gopher-line) objs)
+	      i (1+ i))
+	(url-lazy-message "Converting gopher listing... %d/%d (%d%%)"
+			  i len (url-percentage i len))
+						
+	(forward-line 1))
+      (setq objs (nreverse objs))
+      (erase-buffer)
+      (insert ""
+	      (cond
+	       ((or (string= "" url-current-file)
+		    (string= "1/" url-current-file)
+		    (string= "1" url-current-file))
+		(concat "Gopher root at " url-current-server))
+	       ((string-match (format "^[%s]+/" url-gopher-types)
+			      url-current-file)
+		(substring url-current-file 2 nil))
+	       (t url-current-file))
+	      "
      "
+	      (mapconcat 'url-format-gopher-link objs "")
+	      "
    "))))
+
+(defun url-gopher-retrieve (host port selector &optional wait-for)
+  ;; Fetch a gopher object and don't mess with it at all
+  (let ((proc (url-open-stream "*gopher*" url-working-buffer
+			      host (if (stringp port) (string-to-int port)
+				     port)))
+	(len nil)
+	(parsed nil))
+    (url-clear-tmp-buffer)
+    (setq url-current-file selector
+	  url-current-port port
+	  url-current-server host
+	  url-current-type "gopher")
+    (if (> (length selector) 0)
+	(setq selector (substring selector 1 nil)))
+    (if (stringp proc)
+	(message "%s" proc)
+      (save-excursion
+	(process-send-string proc (concat selector "\r\n"))
+	(while (and (or (not wait-for)
+			(progn
+			  (goto-char (point-min))
+			  (not (re-search-forward wait-for nil t))))
+		    (memq (url-process-status proc) '(run open)))
+	  (if (not parsed)
+	      (cond
+	       ((and (eq ?+ (char-after 1))
+		     (memq (char-after 2)
+			   (list ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
+		(setq parsed (copy-marker 2)
+		      len (read parsed))
+		(delete-region (point-min) parsed))
+	       ((and (eq ?+ (char-after 1))
+		     (eq ?- (char-after 2)))
+		(setq len nil
+		      parsed t)
+		(goto-char (point-min))
+		(delete-region (point-min) (progn
+					     (end-of-line)
+					     (point))))
+	       ((and (eq ?- (char-after 1))
+		     (eq ?- (char-after 2)))
+		(setq parsed t
+		      len nil)
+		(goto-char (point-min))
+		(delete-region (point-min) (progn
+					     (end-of-line)
+					     (point))))))
+	  (if len (url-lazy-message "Reading... %d of %d bytes (%d%%)"
+				    (point-max)
+				    len
+				    (url-percentage (point-max) len))
+	    (url-lazy-message "Read... %d bytes." (point-max)))
+	  (url-accept-process-output proc))
+	(condition-case ()
+	    (url-kill-process proc)
+	  (error nil))
+	(url-replace-regexp "\n*Connection closed.*\n*" "")
+	(url-replace-regexp "\n*Process .*gopher.*\n*" "")
+	(while (looking-at "\r") (delete-char 1))))))
+
+(defun url-do-gopher-cso-search (descr)
+  ;; Do a gopher CSO search and return a plaintext document
+  (let ((host (nth 0 descr))
+	(port (nth 1 descr))
+	(file (nth 2 descr))
+	search-type search-term)
+    (string-match "search-by=\\([^&]+\\)" file)
+    (setq search-type (url-match file 1))
+    (string-match "search-term=\\([^&]+\\)" file)
+    (setq search-term (url-match file 1))
+    (url-gopher-retrieve host port (format "2query %s=%s"
+					  search-type search-term) "^[2-9]")
+    (goto-char (point-min))
+    (url-replace-regexp "^-[0-9][0-9][0-9]:[0-9]*:" "")
+    (url-replace-regexp "^[^15][0-9][0-9]:.*" "")
+    (url-replace-regexp "^[15][0-9][0-9]:\\(.*\\)" "
    \\1
     
    ")
+    (goto-char (point-min))
+    (insert "Results of CSO search\n"
+	    "
    " search-type " = " search-term "
    \n")
+    (goto-char (point-max))
+    (insert "
    ")))
+
+(defun url-do-gopher (descr)
+  ;; Fetch a gopher object
+  (let ((host (nth 0 descr))
+	(port (nth 1 descr))
+	(file (nth 2 descr))
+	(type (nth 3 descr))
+	(extr (nth 4 descr))
+	parse-gopher)
+    (cond
+     ((and				; Gopher CSO search
+       (equal type "www/gopher-cso-search")
+       (string-match "search-by=" file)) ; With a search term in it
+      (url-do-gopher-cso-search descr)
+      (setq type "text/html"))
+     ((equal type "www/gopher-cso-search") ; Blank CSO search
+      (url-clear-tmp-buffer)
+      (insert "\n"
+	      " \n"
+	      "  CSO Search\n"
+	      " \n"
+	      " \n"
+	      "  
    \n"
+	      "   
    This is a CSO search
    \n"
+	      "   
    \n"
+	      "   
    \n"
+	      "    
      \n"
+	      "     
    •  Search by: \n"
+	      "     
    •  Search for: \n"
+	      "     
    •  \n"
+	      "    
    \n"
+	      "   
    \n"
+	      "  
    \n"
+	      " \n"
+	      "\n"
+	      "\n")
+      (setq type "text/html"
+	    parse-gopher t))
+     ((and
+       (equal type "www/gopher-search")	; Ack!  Mosaic-style search href
+       (string-match "\t" file))	; and its got a search term in it!
+      (url-gopher-retrieve host port file)
+      (setq type "www/gopher"
+	    parse-gopher t))
+     ((and
+       (equal type "www/gopher-search")	; Ack!  Mosaic-style search href
+       (string-match "\\?" file))	; and its got a search term in it!
+      (setq file (concat (substring file 0 (match-beginning 0)) "\t"
+			 (substring file (match-end 0) nil)))
+      (url-gopher-retrieve host port file)
+      (setq type "www/gopher"
+	    parse-gopher t))
+     ((equal type "www/gopher-search")	; Ack!  Mosaic-style search href
+      (setq type "text/html"
+	    parse-gopher t)
+      (url-clear-tmp-buffer)
+      (insert "\n"
+	      " \n"
+	      "  Gopher Server\n"
+	      " \n"
+	      " \n"
+	      "  
    \n"
+	      "   
    Searchable Gopher Index
    \n"
+	      "   
    \n"
+	      "   
    \n"
+	      "    Enter the search keywords below\n"
+	      "   
    "
+	      "   
    \n"
+	      "    \n"
+	      "   
    \n"
+	      "   
    \n"
+	      "  
    \n"
+	      " \n"
+	      "\n"
+	      "\n"))
+     ((null extr)			; Normal Gopher link
+      (url-gopher-retrieve host port file)
+      (setq parse-gopher t))
+     ((eq extr 'gopher+)		; A gopher+ link
+      (url-gopher-retrieve host port (concat file "\t+"))
+      (setq parse-gopher t))
+     ((eq extr 'ask-block)		; A gopher+ interactive query
+      (url-gopher-retrieve host port (concat file "\t!")) ; Fetch the info
+      (goto-char (point-min))
+      (cond
+       ((re-search-forward "^\\+ASK:[ \t\r]*" nil t) ; There is an ASK
+	(let ((x (buffer-substring (1+ (point))
+				   (or (re-search-forward "^\\+[^:]+:" nil t)
+				       (point-max)))))
+	  (erase-buffer)
+	  (insert (url-convert-ask-to-form x))
+	  (setq type "text/html" parse-gopher t)))
+       (t (setq parse-gopher t)))))
+    (if (or (equal type "www/gopher")
+	    (equal type "text/plain")
+	    (equal file "")
+	    (equal type "text/html"))
+	(url-gopher-clean-text))
+    (if (and parse-gopher (or (equal type "www/gopher")
+			      (equal file "")))
+	(progn
+	  (url-parse-gopher)
+	  (setq type "text/html"
+		url-current-mime-viewer (mm-mime-info type nil 5))))
+    (setq url-current-mime-type (or type "text/plain")
+	  url-current-mime-viewer (mm-mime-info type nil 5)
+	  url-current-file file
+	  url-current-port port
+	  url-current-server host
+	  url-current-type "gopher")))
+
+(defun url-gopher (url)
+  ;; Handle gopher URLs
+  (let ((descr (url-grok-gopher-href url)))
+    (cond
+     ((or (not (member (nth 1 descr) url-bad-port-list))
+	  (funcall
+	   url-confirmation-func
+	   (format "Warning!  Trying to connect to port %s - continue? "
+		   (nth 1 descr))))
+      (if url-use-hypertext-gopher
+	  (url-do-gopher descr)
+	(gopher-dispatch-object (vector (if (= 0
+					       (string-to-char (nth 2 descr)))
+					    ?1
+					  (string-to-char (nth 2 descr)))
+					(nth 2 descr) (nth 2 descr)
+					(nth 0 descr)
+					(string-to-int (nth 1 descr)))
+				(current-buffer))))
+     (t
+      (ding)
+      (url-warn 'security "Aborting connection to bad port...")))))
+
+(provide 'url-gopher)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-http.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-http.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,643 @@
+;;; url-http.el --- HTTP Uniform Resource Locator retrieval code
+;; Author: wmperry
+;; Created: 1996/12/18 00:38:45
+;; Version: 1.7
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+(require 'url-cookie)
+(require 'timezone)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for HTTP/1.0 MIME messages
+;;; ----------------------------------
+;;; These functions are the guts of the HTTP/0.9 and HTTP/1.0 transfer
+;;; protocol, handling access authorization, format negotiation, the
+;;; whole nine yards.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-parse-viewer-types ()
+  "Create a string usable for an Accept: header from mm-mime-data"
+  (let ((tmp mm-mime-data)
+	label mjr mnr cur-mnr (str ""))
+    (while tmp
+      (setq mnr (cdr (car tmp))
+	    mjr (car (car tmp))
+	    tmp (cdr tmp))
+      (while mnr
+	(setq cur-mnr (car mnr)
+	      label (concat mjr "/" (if (string= ".*" (car cur-mnr))
+					"*"
+				      (car cur-mnr))))
+	(cond
+	 ((string-match (regexp-quote label) str) nil)
+	 ((> (+ (% (length str) 60)
+		(length (concat ", " mjr "/" (car cur-mnr)))) 60)
+	  (setq str (format "%s\r\nAccept: %s" str label)))
+	 (t
+	  (setq str (format "%s, %s" str label))))
+	(setq mnr (cdr mnr))))
+    (substring str 2 nil)))
+
+(defun url-create-multipart-request (file-list)
+  "Create a multi-part MIME request for all files in FILE-LIST"
+  (let ((separator (current-time-string))
+	(content "message/http-request")		   
+	(ref-url nil))
+    (setq separator
+	  (concat "separator-"
+		  (mapconcat
+		   (function
+		    (lambda (char)
+		      (if (memq char url-mime-separator-chars)
+			  (char-to-string char) ""))) separator "")))
+    (cons separator
+	  (concat
+	   (mapconcat
+	    (function
+	     (lambda (file)
+	       (concat "--" separator "\nContent-type: " content "\n\n"
+		       (url-create-mime-request file ref-url)))) file-list
+		       "\n")
+	   "--" separator))))
+
+(defun url-create-message-id ()
+  "Generate a string suitable for the Message-ID field of a request"
+  (concat "<" (url-create-unique-id) "@" (system-name) ">"))
+
+(defun url-create-unique-id ()
+  ;; Generate unique ID from user name and current time.
+  (let* ((date (current-time-string))
+	 (name (user-login-name))
+	 (dateinfo (and date (timezone-parse-date date)))
+	 (timeinfo (and date (timezone-parse-time (aref dateinfo 3)))))
+    (if (and dateinfo timeinfo)
+	(concat (upcase name) "."
+		(aref dateinfo 0)	; Year
+		(aref dateinfo 1)	; Month
+		(aref dateinfo 2)	; Day
+		(aref timeinfo 0)	; Hour
+		(aref timeinfo 1)	; Minute 
+		(aref timeinfo 2)	; Second
+		)
+      (error "Cannot understand current-time-string: %s." date))
+    ))
+
+(defun url-http-user-agent-string ()
+  (if (or (eq url-privacy-level 'paranoid)
+	  (and (listp url-privacy-level)
+	       (memq 'agent url-privacy-level)))
+      ""
+    (format "User-Agent: %s/%s URL/%s%s\r\n"
+	    url-package-name url-package-version
+	    url-version
+	    (cond
+	     ((and url-os-type url-system-type)
+	      (concat " (" url-os-type "; " url-system-type ")"))
+	     ((or url-os-type url-system-type)
+	      (concat " (" (or url-system-type url-os-type) ")"))
+	     (t "")))))
+
+(defun url-create-mime-request (fname ref-url)
+  "Create a MIME request for fname, referred to by REF-URL."
+  (let* ((extra-headers)
+	 (request nil)
+	 (url (url-view-url t))
+	 (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers)))
+	 (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
+					      url-request-extra-headers))
+			     (not (boundp 'proxy-info)))
+			 nil
+		       (let ((url-basic-auth-storage
+			      url-proxy-basic-authentication))
+			 (url-get-authentication url nil 'any nil))))
+	 (host (if (boundp 'proxy-info)
+		   (url-host (url-generic-parse-url proxy-info))
+		 url-current-server))
+	 (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
+		   nil
+		 (url-get-authentication (or
+					  (and (boundp 'proxy-info)
+					       proxy-info)
+					  url) nil 'any nil))))
+    (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
+    (if auth
+	(setq auth (concat "Authorization: " auth "\r\n")))
+    (if proxy-auth
+	(setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
+
+    (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
+					   (string= ref-url "")))
+	(setq ref-url nil))
+
+    (if (or (memq url-privacy-level '(low high paranoid))
+	    (and (listp url-privacy-level)
+		 (memq 'lastloc url-privacy-level)))
+	(setq ref-url nil))
+
+    (setq extra-headers (mapconcat
+			 (function (lambda (x)
+				     (concat (car x) ": " (cdr x))))
+			 url-request-extra-headers "\r\n"))
+    (if (not (equal extra-headers ""))
+	(setq extra-headers (concat extra-headers "\r\n")))
+    (setq request
+	  (format
+	   (concat
+	    "%s %s HTTP/1.0\r\n"	; The request
+	    "MIME-Version: 1.0\r\n"	; Version of MIME we speaketh
+	    "Extension: %s\r\n"		; HTTP extensions we support
+	    "Host: %s\r\n"		; Who we want to talk to
+	    "%s"			; Who its from
+	    "Accept-encoding: %s\r\n"	; Encodings we understand
+	    "Accept-language: %s\r\n" 	; Languages we understand
+	    "Accept: %s\r\n"		; Types we understand
+	    "%s"			; User agent
+	    "%s"			; Authorization
+	    "%s"			; Cookies
+	    "%s"			; Proxy Authorization
+	    "%s"			; If-modified-since
+	    "%s"			; Where we came from
+	    "%s"			; Any extra headers
+	    "%s"			; Any data
+	    "\r\n")			; End request
+	   (or url-request-method "GET")
+	   fname
+	   (or url-extensions-header "none")
+	   (or host "UNKNOWN.HOST.NAME")
+	   (if url-personal-mail-address
+	       (concat "From: " url-personal-mail-address "\r\n")
+	     "")
+	   url-mime-encoding-string
+	   url-mime-language-string
+	   url-mime-accept-string
+	   (url-http-user-agent-string)
+	   (or auth "")
+	   (url-cookie-generate-header-lines url-current-server
+					     fname
+					     (string-match "https"
+							   url-current-type))
+	   (or proxy-auth "")
+	   (if (and (not no-cache)
+		    (member url-request-method '("GET" nil)))
+	       (let ((tm (url-is-cached url)))
+		 (if tm
+		     (concat "If-modified-since: "
+			     (url-get-normalized-date tm) "\r\n")
+		   ""))
+	     "")
+	   (if ref-url (concat "Referer: " ref-url "\r\n") "")
+	   extra-headers
+	   (if url-request-data
+	       (format "Content-length: %d\r\n\r\n%s"
+		       (length url-request-data) url-request-data)
+	     "")))
+    request))
+
+(defun url-setup-reload-timer (url must-be-viewing &optional time)
+  ;; Set up a timer to load URL at optional TIME.  If TIME is unspecified,
+  ;; default to 5 seconds.  Only loads document if MUST-BE-VIEWING is the
+  ;; current URL when the timer expires."
+  (if (or (not time)
+	  (<= time 0))
+      (setq time 5))
+  (let ((func
+	 (` (lambda ()
+	      (if (equal (url-view-url t) (, must-be-viewing))
+		  (let ((w3-reuse-buffers 'no))
+		    (if (equal (, url) (url-view-url t))
+			(kill-buffer (current-buffer)))
+		    (w3-fetch (, url))))))))
+    (cond
+     ((featurep 'itimer)
+      (start-itimer "reloader" func time))
+     ((fboundp 'run-at-time)
+      (run-at-time time nil func))
+     (t
+      (url-warn 'url "Cannot set up timer for automatic reload, sorry!")))))
+
+(defun url-handle-refresh-header (reload)
+  (if (and reload
+	   url-honor-refresh-requests
+	   (or (eq url-honor-refresh-requests t)
+	       (funcall url-confirmation-func "Honor refresh request? ")))
+      (let ((uri (url-view-url t)))
+	(if (string-match ";" reload)
+	    (progn
+	      (setq uri (substring reload (match-end 0) nil)
+		    reload (substring reload 0 (match-beginning 0)))
+	      (if (string-match
+		   "ur[li][ \t]*=[ \t]*\"*\\([^ \t\"]+\\)\"*"
+		   uri)
+		  (setq uri (url-match uri 1)))
+	      (setq uri (url-expand-file-name uri (url-view-url t)))))
+	(url-setup-reload-timer uri (url-view-url t)
+				(string-to-int (or reload "5"))))))
+
+(defun url-parse-mime-headers (&optional no-delete switch-buff)
+  ;; Parse mime headers and remove them from the html
+  (and switch-buff (set-buffer url-working-buffer))
+  (let* ((st (point-min))
+	 (nd (progn
+	       (goto-char (point-min))
+	       (skip-chars-forward " \t\n")
+	       (if (re-search-forward "^\r*$" nil t)
+		   (1+ (point))
+		 (point-max))))
+	 save-pos
+	 status
+	 class
+	 hname
+	 hvalu
+	 result
+	 )
+    (narrow-to-region st (min nd (point-max)))
+    (goto-char (point-min))
+    (skip-chars-forward " \t\n")	; Get past any blank crap
+    (skip-chars-forward "^ \t")	; Skip over the HTTP/xxx
+    (setq status (read (current-buffer)); Quicker than buffer-substring, etc.
+	  result (cons (cons "status" status) result))
+    (end-of-line)
+    (while (not (eobp))
+      (skip-chars-forward " \t\n\r")
+      (setq save-pos (point))
+      (skip-chars-forward "^:\n\r")
+      (downcase-region save-pos (point))
+      (setq hname (buffer-substring save-pos (point)))
+      (skip-chars-forward ": \t ")
+      (setq save-pos (point))
+      (skip-chars-forward "^\n\r")
+      (setq hvalu (buffer-substring save-pos (point))
+	    result (cons (cons hname hvalu) result))
+      (if (string= hname "set-cookie")
+	  (url-cookie-handle-set-cookie hvalu)))
+    (or no-delete (delete-region st (min nd (point))))
+    (setq url-current-mime-type (cdr (assoc "content-type" result))
+	  url-current-mime-encoding (cdr (assoc "content-encoding" result))
+	  url-current-mime-viewer (mm-mime-info url-current-mime-type nil t)
+	  url-current-mime-headers result
+	  url-current-can-be-cached
+	  (not (string-match "no-cache"
+			     (or (cdr-safe (assoc "pragma" result)) ""))))
+    (url-handle-refresh-header (cdr-safe (assoc "refresh" result)))
+    (if (and url-request-method
+	     (not (string= url-request-method "GET")))
+	(setq url-current-can-be-cached nil))
+    (let ((expires (cdr-safe (assoc "expires" result))))
+      (if (and expires url-current-can-be-cached (featurep 'timezone))
+	  (progn
+	    (if (string-match
+		 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
+			 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
+			      expires)
+		(setq expires (concat (url-match expires 1) " "
+				      (url-match expires 2) " "
+				      (url-match expires 3) " "
+				      (url-match expires 4) " ["
+				      (url-match expires 5) "]")))
+	    (setq expires
+		  (let ((d1 (mapcar
+			     (function
+			      (lambda (s) (and s (string-to-int s))))
+			     (timezone-parse-date
+			      (current-time-string))))
+			(d2 (mapcar
+			     (function (lambda (s) (and s (string-to-int s))))
+			     (timezone-parse-date expires))))
+		    (- (timezone-absolute-from-gregorian 
+			(nth 1 d1) (nth 2 d1) (car d1))
+		       (timezone-absolute-from-gregorian 
+			(nth 1 d2) (nth 2 d2) (car d2))))
+		  url-current-can-be-cached (/= 0 expires)))))
+    (setq class (/ status 100))
+    (cond
+     ;; Classes of response codes
+     ;;
+     ;; 5xx = Server Error
+     ;; 4xx = Client Error
+     ;; 3xx = Redirection
+     ;; 2xx = Successful
+     ;; 1xx = Informational
+     ;;
+     ((= class 2)			; Successful in some form or another
+      (cond
+       ((or (= status 206)		; Partial content
+	    (= status 205))		; Reset content
+	(setq url-current-can-be-cached nil))
+       ((= status 204)			; No response - leave old document
+	(kill-buffer url-working-buffer))
+       (t nil))				; All others indicate success
+      )
+     ((= class 3)			; Redirection of some type
+      (cond
+       ((or (= status 301)		; Moved - retry with Location: header
+	    (= status 302)		; Found - retry with Location: header
+	    (= status 303))		; Method - retry with location/method
+	(let ((x (url-view-url t))
+	      (redir (or (cdr (assoc "uri" result))
+			 (cdr (assoc "location" result))))
+	      (redirmeth (upcase (or (cdr (assoc "method" result))
+				     url-request-method
+				     "get"))))
+	  (if (and redir (string-match "\\([^ \t]+\\)[ \t]" redir))
+	      (setq redir (url-match redir 1)))
+	  (if (and redir (string-match "^<\\(.*\\)>$" redir))
+	      (setq redir (url-match redir 1)))
+
+	  ;; As per Roy Fielding, 303 maps _any_ method to a 'GET'
+	  (if (= 303 status)
+	      (setq redirmeth "GET"))
+
+	  ;; As per Roy Fielding, 301, 302 use the same method as the
+	  ;; original request, but if != GET, user interaction is
+	  ;; required.
+	  (if (and (not (string= "GET" redirmeth))
+		   (not (funcall
+			 url-confirmation-func
+			 (concat
+			  "Honor redirection with non-GET method "
+			  "(possible security risks)? "))))
+	      (progn
+		(url-warn 'url
+			  (format
+			   "The URL %s tried to issue a redirect to %s using a method other than
+GET, which can open up various security holes.  Please see the
+HTTP/1.0 specification for more details." x redir) 'error)
+		(if (funcall url-confirmation-func
+			     "Continue (with method of GET)? ")
+		    (setq redirmeth "GET")
+		  (error "Transaction aborted."))))
+
+	  (if (not (equal x redir))
+	      (let ((url-request-method redirmeth))
+		(url-maybe-relative redir))
+	    (progn
+	      (goto-char (point-max))
+	      (insert "
    Error!  This URL tried to redirect me to itself!
    "
+		      "Please notify the server maintainer.")))))
+       ((= status 304)			; Cached document is newer
+	(message "Extracting from cache...")
+	(url-extract-from-cache (url-create-cached-filename (url-view-url t))))
+       ((= status 305)			; Use proxy in Location: header
+	nil)))
+     ((= class 4)			; Client error
+      (cond
+       ((and (= status 401)		; Unauthorized access, retry w/auth.
+	     (< url-current-passwd-count url-max-password-attempts))
+	(setq url-current-passwd-count (1+ url-current-passwd-count))
+	(let* ((y (or (cdr (assoc "www-authenticate" result)) "basic"))
+	       (url (url-view-url t))
+	       (type (downcase (if (string-match "[ \t]" y)
+				   (substring y 0 (match-beginning 0))
+				 y))))
+	  (cond
+	   ((or (equal "pem" type) (equal "pgp" type))
+	    (if (string-match "entity=\"\\([^\"]+\\)\"" y)
+		(url-fetch-with-pgp url-current-file
+				    (url-match y 1) (intern type))
+	      (error "Could not find entity in %s!" type)))
+	   ((url-auth-registered type)
+	    (let ((args y)
+		  (ctr (1- (length y)))
+		  auth
+		  (url-request-extra-headers url-request-extra-headers))
+	      (while (/= 0 ctr)
+		(if (= ?, (aref args ctr))
+		    (aset args ctr ?\;))
+		(setq ctr (1- ctr)))
+	      (setq args (mm-parse-args y)
+		    auth (url-get-authentication url
+						 (cdr-safe
+						  (assoc "realm" args))
+						 type t args))
+	      (if auth
+		  (setq url-request-extra-headers
+			(cons (cons "Authorization" auth)
+			      url-request-extra-headers)))
+	      (url-retrieve url t)))
+	   (t
+	    (widen)
+	    (goto-char (point-max))
+	    (setq url-current-can-be-cached nil)
+	    (insert "
    Sorry, but I do not know how to handle " y
+		    " authentication.  If you'd like to write it,"
+		    " send it to " url-bug-address ".
    ")))))
+       ((= status 407)			; Proxy authentication required
+	(let* ((y (or (cdr (assoc "proxy-authenticate" result)) "basic"))
+	       (url (url-view-url t))
+	       (url-basic-auth-storage url-proxy-basic-authentication)
+	       (type (downcase (if (string-match "[ \t]" y)
+				   (substring y 0 (match-beginning 0))
+				 y))))
+	  (cond
+	   ((or (equal "pem" type) (equal "pgp" type))
+	    (if (string-match "entity=\"\\([^\"]+\\)\"" y)
+		(url-fetch-with-pgp url-current-file
+				    (url-match y 1) (intern type))
+	      (error "Could not find entity in %s!" type)))
+	   ((url-auth-registered type)
+	    (let ((args y)
+		  (ctr (1- (length y)))
+		  auth
+		  (url-request-extra-headers url-request-extra-headers))
+	      (while (/= 0 ctr)
+		(if (= ?, (aref args ctr))
+		    (aset args ctr ?\;))
+		(setq ctr (1- ctr)))
+	      (setq args (mm-parse-args y)
+		    auth (url-get-authentication (or url-using-proxy url)
+						 (cdr-safe
+						  (assoc "realm" args))
+						 type t args))
+	      (if auth
+		  (setq url-request-extra-headers
+			(cons (cons "Proxy-Authorization" auth)
+			      url-request-extra-headers)))
+	      (setq url-proxy-basic-authentication url-basic-auth-storage)
+	      (url-retrieve url t)))
+	   (t
+	    (widen)
+	    (goto-char (point-max))
+	    (setq url-current-can-be-cached nil)
+	    (insert "
    Sorry, but I do not know how to handle " y
+		    " authentication.  If you'd like to write it,"
+		    " send it to " url-bug-address ".
    ")))))
+       ;;((= status 400) nil)		; Bad request - syntax
+       ;;((= status 401) nil)		; Tried too many times
+       ;;((= status 402) nil)		; Payment required, retry w/Chargeto:
+       ;;((= status 403) nil)		; Access is forbidden
+       ;;((= status 404) nil)		; Not found...
+       ;;((= status 405) nil)		; Method not allowed
+       ;;((= status 406) nil)		; None acceptable
+       ;;((= status 408) nil)		; Request timeout
+       ;;((= status 409) nil)		; Conflict
+       ;;((= status 410) nil)		; Document is gone
+       ;;((= status 411) nil)		; Length required
+       ;;((= status 412) nil)		; Unless true
+       (t				; All others mena something hosed
+	(setq url-current-can-be-cached nil))))
+     ((= class 5)
+;;;      (= status 504)			; Gateway timeout
+;;;      (= status 503)			; Service unavailable
+;;;      (= status 502)			; Bad gateway
+;;;      (= status 501)			; Facility not supported
+;;;      (= status 500)			; Internal server error
+      (setq url-current-can-be-cached nil))
+     ((= class 1)
+      (cond
+       ((or (= status 100)		; Continue
+	    (= status 101))		; Switching protocols
+	nil)))
+     (t
+      (setq url-current-can-be-cached nil)))
+    (widen)
+    status))
+
+(defun url-mime-response-p (&optional switch-buff)
+  ;; Determine if the current buffer is a MIME response
+  (and switch-buff (set-buffer url-working-buffer))
+  (goto-char (point-min))
+  (skip-chars-forward " \t\n")
+  (and (looking-at "^HTTP/.+")))
+
+(defsubst url-recreate-with-attributes (obj)
+  (if (url-attributes obj)
+      (concat (url-filename obj) ";"
+	      (mapconcat
+	       (function
+		(lambda (x)
+		  (if (cdr x)
+		      (concat (car x) "=" (cdr x))
+		    (car x)))) (url-attributes obj) ";"))
+    (url-filename obj)))
+
+(defun url-http (url &optional proxy-info)
+  ;; Retrieve URL via http.
+  (let* ((urlobj (url-generic-parse-url url))
+	 (ref-url (or url-current-referer (url-view-url t))))
+    (url-clear-tmp-buffer)
+    (setq url-current-type (if (boundp 'url-this-is-ssl)
+			       "https" "http"))
+    (let* ((server (url-host urlobj))
+	   (port   (url-port urlobj))
+	   (file   (or proxy-info (url-recreate-with-attributes urlobj)))
+	   (dest   (url-target urlobj))
+	   request)
+      (if (equal port "") (setq port "80"))
+      (if (equal file "") (setq file "/"))
+      (if (not server)
+	  (progn
+	    (url-warn
+	     'url
+	     (eval-when-compile
+	       (concat
+		"Malformed URL got passed into url-retrieve.\n"
+		"Either `url-expand-file-name' is broken in some\n"
+		"way, or an incorrect URL was manually entered (more likely)."
+		)))
+	    (error "Malformed URL: `%s'" url)))
+      (if proxy-info
+	  (let ((x (url-generic-parse-url url)))
+	    (setq url-current-server (url-host urlobj)
+		  url-current-port (url-port urlobj)
+		  url-current-file (url-filename urlobj)
+		  url-find-this-link (url-target urlobj)
+		  request (url-create-mime-request file ref-url)))
+	(setq url-current-server server
+	      url-current-port port
+	      url-current-file file
+	      url-find-this-link dest
+	      request (url-create-mime-request file ref-url)))
+      (if (or (not (member port url-bad-port-list))
+	      (funcall url-confirmation-func
+		       (concat
+			"Warning!  Trying to connect to port "
+			port
+			" - continue? ")))
+	  (progn
+	    (url-lazy-message "Contacting %s:%s" server port)
+	    (let ((process
+		   (url-open-stream "WWW" url-working-buffer server
+				   (string-to-int port))))
+	      (if (stringp process)
+		  (progn
+		    (set-buffer url-working-buffer)
+		    (erase-buffer)
+		    (setq url-current-mime-type "text/html"
+			  url-current-mime-viewer 
+			  (mm-mime-info "text/html" nil 5))
+		    (insert "ERROR\n"
+			    "
    ERROR - Could not establish connection
    "
+			    "
    "
+			    "The browser could not establish a connection "
+			    (format "to %s:%s.
    " server port)
+			    "The server is either down, or the URL"
+			    (format "(%s) is malformed.
    " (url-view-url t)))
+		    (message "%s" process))
+		(progn
+		  (url-process-put process 'url (or proxy-info url))
+		  (process-kill-without-query process)
+		  (process-send-string process request)
+		  (url-lazy-message "Request sent, waiting for response...")
+		  (if url-show-http2-transfer
+		      (progn
+			(make-local-variable 'after-change-functions)
+			(setq url-current-content-length nil)
+			(add-hook 'after-change-functions
+				  'url-after-change-function)))
+		  (if url-be-asynchronous
+		      (set-process-sentinel process 'url-sentinel)
+		    (unwind-protect
+			(save-excursion
+			  (set-buffer url-working-buffer)
+			  (while (memq (url-process-status process)
+				       '(run open))
+			    (url-accept-process-output process)))
+		      (condition-case ()
+			  (url-kill-process process)
+			(error nil))))
+		  (if url-be-asynchronous
+		      nil
+		    (message "Retrieval complete.")
+		    (remove-hook 'after-change-functions
+				 'url-after-change-function))))))
+	(progn
+	  (ding)
+	  (url-warn 'security "Aborting connection to bad port..."))))))
+
+(defun url-shttp (url)
+  ;; Retrieve a URL via Secure-HTTP
+  (error "Secure-HTTP not implemented yet."))
+
+(defun url-https (url)
+  ;; Retrieve a URL via SSL
+  (condition-case ()
+      (require 'ssl)
+    (error (error "Not configured for SSL, please read the info pages.")))
+  (let ((url-this-is-ssl t)
+	(url-gateway-method 'ssl))
+    (url-http url)))
+
+(provide 'url-http)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-irc.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-irc.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,71 @@
+;;; url-irc.el --- IRC URL interface
+;; Author: wmperry
+;; Created: 1996/10/09 19:00:59
+;; Version: 1.4
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+
+(defvar url-irc-function 'url-irc-zenirc
+  "*Function to actually open an IRC connection.
+Should be a function that takes several argument:
+    HOST - the hostname of the IRC server to contact
+    PORT - the port number of the IRC server to contact
+ CHANNEL - What channel on the server to visit right away (can be nil)
+    USER - What username to use
+PASSWORD - What password to use")
+
+(defun url-irc-zenirc (host port channel user password)
+  (let ((zenirc-buffer-name (if (and user host port)
+				(format "%s@%s:%d" user host port)
+			      (format "%s:%d" host port)))
+	(zenirc-server-alist
+	 (list
+	  (list host port password nil user))))
+    (zenirc)
+    (goto-char (point-max))
+    (if (not channel)
+	nil
+      (insert "/join " channel)
+      (zenirc-send-line))))
+
+(defun url-irc (url)
+  (let* ((urlobj (url-generic-parse-url url))
+	 (host (url-host urlobj))
+	 (port (string-to-int (url-port urlobj)))
+	 (pass (url-password urlobj))
+	 (user (url-user urlobj))
+	 (chan (url-filename urlobj)))
+    (if (url-target urlobj)
+	(setq chan (concat chan "#" (url-target urlobj))))
+    (and (get-buffer url-working-buffer)
+	 (kill-buffer url-working-buffer))
+    (if (string-match "^/" chan)
+	(setq chan (substring chan 1 nil)))
+    (if (= (length chan) 0)
+	(setq chan nil))
+    (funcall url-irc-function host port chan user pass)))
+    
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-mail.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-mail.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,194 @@
+;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
+;; Author: wmperry
+;; Created: 1996/10/21 21:27:36
+;; Version: 1.4
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+
+(defmacro url-mailserver-skip-chunk ()
+  (` (while (and (not (looking-at "/"))
+		 (not (eobp)))
+       (forward-sexp 1))))
+
+(defun url-mail (&rest args)
+  (interactive "P")
+  (or (apply 'mail args)
+      (error "Mail aborted")))
+
+(defun url-mail-goto-field (field)
+  (if (not field)
+      (goto-char (point-max))
+    (let ((dest nil)
+	  (lim nil)
+	  (case-fold-search t))
+      (save-excursion
+	(goto-char (point-min))
+	(if (re-search-forward (regexp-quote mail-header-separator) nil t)
+	    (setq lim (match-beginning 0)))
+	(goto-char (point-min))
+	(if (re-search-forward (concat "^" (regexp-quote field) ":") lim t)
+	    (setq dest (match-beginning 0))))
+      (if dest
+	  (progn
+	    (goto-char dest)
+	    (end-of-line))
+	(goto-char lim)
+	(insert (capitalize field) ": ")
+	(save-excursion
+	  (insert "\n"))))))
+  
+(defun url-mailto (url)
+  ;; Send mail to someone
+  (if (not (string-match "mailto:/*\\(.*\\)" url))
+      (error "Malformed mailto link: %s" url))
+  (setq url (substring url (match-beginning 1) nil))
+  (if (get-buffer url-working-buffer)
+      (kill-buffer url-working-buffer))
+  (let (to args source-url subject func)
+    (if (string-match (regexp-quote "?") url)
+	(setq to (url-unhex-string (substring url 0 (match-beginning 0)))
+	      args (url-parse-query-string
+		    (substring url (match-end 0) nil) t))
+      (setq to (url-unhex-string url)))
+    (setq source-url (url-view-url t))
+    (if (and url-request-data (not (assoc "subject" args)))
+	(setq args (cons (list "subject"
+			       (concat "Automatic submission from "
+				       url-package-name "/"
+				       url-package-version)) args)))
+    (if (and source-url (not (assoc "x-url-from" args)))
+	(setq args (cons (list "x-url-from" source-url) args)))
+    (setq args (cons (list "to" to) args)
+	  subject (cdr-safe (assoc "subject" args)))
+    (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
+    (while args
+      (url-mail-goto-field (caar args))
+      (setq func (intern-soft (concat "mail-" (caar args))))
+      (insert (mapconcat 'identity (cdar args) ", "))
+      (setq args (cdr args)))
+    (url-mail-goto-field "X-Mailer")
+    (insert url-package-name "/" url-package-version)
+    (if (not url-request-data)
+	(if subject
+	    (url-mail-goto-field nil)
+	  (url-mail-goto-field "subject"))
+      (if url-request-extra-headers
+	  (mapconcat
+	   (function
+	    (lambda (x)
+	      (url-mail-goto-field (car x))
+	      (insert (cdr x))))
+	   url-request-extra-headers ""))
+      (goto-char (point-max))
+      (insert url-request-data)
+      (mail-send-and-exit nil))))
+
+(defun url-mailserver (url)
+  ;; Send mail to someone, much cooler/functional than mailto
+  (if (get-buffer url-working-buffer)
+      (kill-buffer url-working-buffer))
+  (set-buffer (get-buffer-create " *mailserver*"))
+  (erase-buffer)
+  (insert url)
+  (goto-char (point-min))
+  (set-syntax-table url-mailserver-syntax-table)
+  (skip-chars-forward "^:")		; Get past mailserver
+  (skip-chars-forward ":")		; Get past :
+  ;; Handle some ugly malformed URLs, but bitch about it.
+  (if (looking-at "/")
+      (progn
+	(url-warn 'url "Invalid mailserver URL... attempting to cope.")
+	(skip-chars-forward "/")))
+  
+  (let ((save-pos (point))
+	(url (url-view-url t))
+	(rfc822-addr nil)
+	(subject nil)
+	(body nil))
+    (url-mailserver-skip-chunk)
+    (setq rfc822-addr (buffer-substring save-pos (point)))
+    (forward-char 1)
+    (setq save-pos (point))
+    (url-mailserver-skip-chunk)
+    (setq subject (buffer-substring save-pos (point)))
+    (if (not (eobp))
+	(progn				; There is some text to use
+	  (forward-char 1)		; as the body of the message
+	  (setq body (buffer-substring (point) (point-max)))))
+    (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
+    (url-mail-goto-field "to")
+    (insert rfc822-addr)
+    (if (and url (not (string= url "")))
+	(progn
+	  (url-mail-goto-field "X-URL-From")
+	  (insert url)))
+    (url-mail-goto-field "X-Mailer")
+    (insert url-package-name "/" url-package-version)
+    (url-mail-goto-field "subject")
+    ;; Massage the subject from URLEncoded garbage
+    ;; Note that we do not allow any newlines in the subject,
+    ;; as recommended by the Internet Draft on the mailserver
+    ;; URL - this means the document author cannot spoof additional
+    ;; header lines, which is a 'Good Thing'
+    (if subject
+	(progn
+	  (setq subject (url-unhex-string subject))
+	  (let ((x (1- (length subject)))
+		(y 0))
+	    (while (<= y x)
+	      (if (memq (aref subject y) '(?\r ?\n))
+		  (aset subject y ? ))
+	      (setq y (1+ y))))))
+    (insert subject)
+    (if url-request-extra-headers
+	(progn
+	  (goto-char (point-min))
+	  (insert
+	   (mapconcat
+	    (function
+	     (lambda (x)
+	       (url-mail-goto-field (car x))
+	       (insert (cdr x))))
+	    url-request-extra-headers ""))))
+    (goto-char (point-max))
+    ;; Massage the body from URLEncoded garbage
+    (if body
+	(let ((x (1- (length body)))
+	      (y 0))
+	  (while (<= y x)
+	    (if (= (aref body y) ?/)
+		(aset body y ?\n))
+	    (setq y (1+ y)))
+	  (setq body (url-unhex-string body))))
+    (and body (insert body))
+    (and url-request-data (insert url-request-data))
+    (if (and (or body url-request-data)
+	     (funcall url-confirmation-func
+		      (concat "Send message to " rfc822-addr "? ")))
+	(mail-send-and-exit nil))))    
+
+(provide 'url-mail)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-misc.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-misc.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,313 @@
+;;; url-misc.el --- Misc Uniform Resource Locator retrieval code
+;; Author: wmperry
+;; Created: 1996/10/09 19:00:59
+;; Version: 1.3
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+(autoload 'Info-goto-node "info" "" t)
+
+(defun url-info (url)
+  ;; Fetch an info node
+  (if (get-buffer url-working-buffer)
+      (kill-buffer url-working-buffer))
+  (let* ((data (url-generic-parse-url url))
+	 (fname (url-filename data))
+	 (node (or (url-target data) "Top")))
+    (if (and fname node)
+	(Info-goto-node (concat "(" fname ")" node))
+      (error "Malformed url: %s" url))))
+
+(defun url-finger (url)
+  ;; Find a finger reference
+  (setq url-current-mime-headers '(("content-type" . "text/html"))
+	url-current-mime-type "text/html")
+  (set-buffer (get-buffer-create url-working-buffer))
+  (let* ((urlobj (if (vectorp url) url
+		   (url-generic-parse-url url)))
+	 (host (or (url-host urlobj) "localhost"))
+	 (port (or (url-port urlobj)
+		   (cdr-safe (assoc "finger" url-default-ports))))
+	 (user (url-unhex-string (url-filename urlobj)))
+	 (proc (url-open-stream "finger" url-working-buffer host
+				(string-to-int port))))
+    (if (stringp proc)
+	(message "%s" proc)
+      (process-kill-without-query proc)
+      (if (= (string-to-char user) ?/)
+	  (setq user (substring user 1 nil)))
+      (goto-char (point-min))
+      (insert "\n"
+	      " \n"
+	      "  Finger information for " user "@" host "\n"
+	      " \n"
+	      " \n"
+	      "  
    Finger information for " user "@" host "
    \n"
+	      "  
    \n"
+	      "  
    \n")
+      (process-send-string proc (concat user "\r\n"))
+      (while (memq (url-process-status proc) '(run open))
+	(url-after-change-function)
+	(url-accept-process-output proc))
+      (goto-char (point-min))
+      (url-replace-regexp "^Process .* exited .*code .*$" "")
+      (goto-char (point-max))
+      (insert "  
    \n"
+	      " \n"
+	      "\n"))))
+
+(defun url-rlogin (url)
+  ;; Open up an rlogin connection
+  (if (get-buffer url-working-buffer)
+      (kill-buffer url-working-buffer))
+  (or (string-match "rlogin:/*\\(.*@\\)*\\([^/]*\\)/*" url)
+      (error "Malformed RLOGIN URL."))
+  (let* ((server (substring url (match-beginning 2) (match-end 2)))
+	 (name (if (match-beginning 1)
+		   (substring url (match-beginning 1) (1- (match-end 1)))
+		 nil))
+	 (title (format "%s%s" (if name (concat name "@") "") server))
+	 (thebuf (string-match ":" server))
+	 (port (if thebuf
+		   (prog1
+		       (substring server (1+ thebuf) nil)
+		     (setq server (substring server 0 thebuf))) "23")))
+    (cond
+     ((not (eq (device-type) 'tty))
+      (apply 'start-process
+	     "htmlsub"
+	     nil
+	     (url-string-to-tokens
+	      (format url-xterm-command title 
+		      (if (and url-gateway-local-host-regexp
+			       (string-match url-gateway-local-host-regexp
+					     server))
+			  url-local-rlogin-prog
+			url-remote-rlogin-prog) server
+			(concat "-l " name)) ? )))
+     (url-use-transparent
+      (require 'transparent)
+      (sit-for 1)
+      (transparent-window (get-buffer-create
+			   (format "%s%s:%s" (if name (concat name "@") "")
+				   server port))
+			  (if (and url-gateway-local-host-regexp
+				   (string-match url-gateway-local-host-regexp
+						 server))
+			      url-local-rlogin-prog
+			    url-remote-rlogin-prog)
+			  (list server "-l" name) nil
+			  "Press any key to return to emacs"))
+     (t
+      (terminal-emulator
+       (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "")
+				  server port))
+       (if (and url-gateway-local-host-regexp
+		(string-match url-gateway-local-host-regexp
+			      server))
+	   url-local-rlogin-prog
+	 url-remote-rlogin-prog)
+       (list server "-l" name))))))
+
+(defun url-telnet (url)
+  ;; Open up a telnet connection
+  (if (get-buffer url-working-buffer)
+      (kill-buffer url-working-buffer))
+  (or (string-match "telnet:/*\\(.*@\\)*\\([^/]*\\)/*" url)
+      (error "Malformed telnet URL: %s" url))
+  (let* ((server (substring url (match-beginning 2) (match-end 2)))
+	 (name (if (match-beginning 1)
+		   (substring url (match-beginning 1) (1- (match-end 1)))
+		 nil))
+	 (title (format "%s%s" (if name (concat name "@") "") server))
+	 (thebuf (string-match ":" server))
+	 (port (if thebuf
+		   (prog1
+		       (substring server (1+ thebuf) nil)
+		     (setq server (substring server 0 thebuf))) "23")))
+    (cond
+     ((not (eq (device-type) 'tty))
+      (apply 'start-process
+	     "htmlsub"
+	     nil
+	     (url-string-to-tokens
+	      (format url-xterm-command title 
+		      (if (and url-gateway-local-host-regexp
+			       (string-match url-gateway-local-host-regexp
+					     server))
+			  url-local-telnet-prog
+			url-remote-telnet-prog) server port) ? ))
+      (if name (message "Please log in as %s" name)))
+     (url-use-transparent
+      (require 'transparent)
+      (if name (message "Please log in as %s" name))
+      (sit-for 1)
+      (transparent-window (get-buffer-create
+			   (format "%s%s:%s" (if name (concat name "@") "")
+				   server port))
+			  (if (and url-gateway-local-host-regexp
+				   (string-match url-gateway-local-host-regexp
+						 server))
+			      url-local-telnet-prog
+			    url-remote-telnet-prog)
+			  (list server port) nil
+			  "Press any key to return to emacs"))
+     (t
+      (terminal-emulator
+       (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "")
+				  server port))
+       (if (and url-gateway-local-host-regexp
+		(string-match url-gateway-local-host-regexp
+			      server))
+	   url-local-telnet-prog
+	 url-remote-telnet-prog)
+       (list server port))
+      (if name (message "Please log in as %s" name))))))
+
+(defun url-tn3270 (url)
+  ;; Open up a tn3270 connection
+  (if (get-buffer url-working-buffer)
+      (kill-buffer url-working-buffer))
+  (string-match "tn3270:/*\\(.*@\\)*\\([^/]*\\)/*" url)
+  (let* ((server (substring url (match-beginning 2) (match-end 2)))
+	 (name (if (match-beginning 1)
+		   (substring url (match-beginning 1) (1- (match-end 1)))
+		 nil))
+	 (thebuf (string-match ":" server))
+	 (title (format "%s%s" (if name (concat name "@") "") server))
+	 (port (if thebuf
+		   (prog1
+		       (substring server (1+ thebuf) nil)
+		     (setq server (substring server 0 thebuf))) "23")))
+    (cond
+     ((not (eq (device-type) 'tty))
+      (start-process "htmlsub" nil url-xterm-command
+		     "-title" title
+		     "-ut" "-e" url-tn3270-emulator server port)
+      (if name (message "Please log in as %s" name)))
+     (url-use-transparent
+      (require 'transparent)
+      (if name (message "Please log in as %s" name))
+      (sit-for 1)
+      (transparent-window (get-buffer-create
+			   (format "%s%s:%s" (if name (concat name "@") "")
+				   server port))
+			  url-tn3270-emulator
+			  (list server port) nil
+			  "Press any key to return to emacs"))
+     (t
+      (terminal-emulator
+       (get-buffer-create (format "%s%s:%s" (if name (concat name "@") "")
+				  server port))
+       url-tn3270-emulator
+       (list server port))
+      (if name (message "Please log in as %s" name))))))
+
+(defun url-proxy (url)
+  ;; Retrieve URL from a proxy.
+  ;; Expects `url-using-proxy' to be bound to the specific proxy to use."
+  (let (
+	(urlobj (url-generic-parse-url url))
+	(proxyobj (url-generic-parse-url url-using-proxy)))
+    (url-http url-using-proxy url)
+    (setq url-current-type (url-type urlobj)
+	  url-current-user (url-user urlobj)
+	  url-current-port (or (url-port urlobj)
+			       (cdr-safe (assoc url-current-type
+						url-default-ports)))
+	  url-current-server (url-host urlobj)
+	  url-current-file (url-filename urlobj))))
+
+(defun url-x-exec (url)
+  ;; Handle local execution of scripts.
+  (set-buffer (get-buffer-create url-working-buffer))
+  (erase-buffer)
+  (string-match "x-exec:/+\\([^/]+\\)\\(/.*\\)" url)
+  (let ((process-environment process-environment)
+	(executable (url-match url 1))
+	(path-info (url-match url 2))
+	(query-string nil)
+	(safe-paths url-local-exec-path)
+	(found nil)
+	(y nil)
+	)
+    (setq url-current-server executable
+	  url-current-file path-info)
+    (if (string-match "\\(.*\\)\\?\\(.*\\)" path-info)
+	(setq query-string (url-match path-info 2)
+	      path-info (url-match path-info 1)))
+    (while (and safe-paths (not found))
+      (setq y (expand-file-name executable (car safe-paths))
+	    found (and (file-exists-p y) (file-executable-p y) y)
+	    safe-paths (cdr safe-paths)))
+    (if (not found)
+	(url-retrieve (concat "www://error/nofile/" executable))
+      (setq process-environment
+	    (append
+	     (list
+	      "SERVER_SOFTWARE=x-exec/1.0"
+	      (concat "SERVER_NAME=" (system-name))
+	      "GATEWAY_INTERFACE=CGI/1.1"
+	      "SERVER_PROTOCOL=HTTP/1.0"
+	      "SERVER_PORT="
+	      (concat "REQUEST_METHOD=" url-request-method)
+	      (concat "HTTP_ACCEPT="
+		      (mapconcat
+		       (function
+			(lambda (x)
+			  (cond
+			   ((= x ?\n) (setq y t) "")
+			   ((= x ?:) (setq y nil) ",")
+			   (t (char-to-string x))))) url-mime-accept-string
+		       ""))
+	      (concat "PATH_INFO=" (url-unhex-string path-info))
+	      (concat "PATH_TRANSLATED=" (url-unhex-string path-info))
+	      (concat "SCRIPT_NAME=" executable)
+	      (concat "QUERY_STRING=" (url-unhex-string query-string))
+	      (concat "REMOTE_HOST=" (system-name)))
+	     (if (assoc "content-type" url-request-extra-headers)
+		 (concat "CONTENT_TYPE=" (cdr
+					  (assoc "content-type"
+						 url-request-extra-headers))))
+	     (if url-request-data
+		 (concat "CONTENT_LENGTH=" (length url-request-data)))
+	     process-environment))
+      (and url-request-data (insert url-request-data))
+      (setq y (call-process-region (point-min) (point-max) found t t))
+      (goto-char (point-min))
+      (delete-region (point) (progn (skip-chars-forward " \t\n") (point)))
+      (cond
+       ((url-mime-response-p) nil)	; Its already got an HTTP/1.0 header
+       ((null y)			; Weird exit status, whassup?
+	(insert "HTTP/1.0 404 Not Found\n"
+		"Server: " url-package-name "/x-exec\n"))	
+       ((= 0 y)				; The shell command was successful
+	(insert "HTTP/1.0 200 Document follows\n"
+		"Server: " url-package-name "/x-exec\n"))	
+       (t				; Non-zero exit status is bad bad bad
+	(insert "HTTP/1.0 404 Not Found\n"
+		"Server: " url-package-name "/x-exec\n"))))))
+
+(provide 'url-misc)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-news.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-news.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,292 @@
+;;; url-news.el --- News Uniform Resource Locator retrieval code
+;; Author: wmperry
+;; Created: 1996/11/05 05:26:07
+;; Version: 1.5
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(require 'url-vars)
+(require 'url-parse)
+
+(defun url-format-news ()
+  (url-clear-tmp-buffer)
+  (insert "HTTP/1.0 200 Retrieval OK\r\n"
+ 	  (save-excursion
+ 	    (set-buffer nntp-server-buffer)
+ 	    (buffer-string)))
+  (url-parse-mime-headers)
+  (let* ((from  (cdr (assoc "from" url-current-mime-headers)))
+	 (qfrom (if from (url-insert-entities-in-string from) nil))
+	 (subj  (cdr (assoc "subject" url-current-mime-headers)))
+	 (qsubj (if subj (url-insert-entities-in-string subj) nil))
+	 (org   (cdr (assoc "organization" url-current-mime-headers)))
+	 (qorg  (if org (url-insert-entities-in-string org) nil))
+	 (typ   (or (cdr (assoc "content-type" url-current-mime-headers))
+		    "text/plain"))
+	 (qgrps (mapcar 'car
+			(url-split
+			 (url-insert-entities-in-string
+			  (or (cdr (assoc "newsgroups" 
+					  url-current-mime-headers))
+			      ""))
+			 "[ \t\n,]+")))
+	 (qrefs (delete "" 
+			(mapcar
+			 'url-insert-entities-in-string
+			 (mapcar 'car
+				 (url-split
+				  (or (cdr (assoc "references" 
+						  url-current-mime-headers))
+				      "")
+				  "[ \t,\n<>]+")))))
+	 (date  (cdr (assoc "date" url-current-mime-headers))))
+    (setq url-current-file ""
+ 	  url-current-type "")
+    (if (or (not (string-match "text/" typ))
+ 	    (string-match "text/html" typ))
+ 	nil				; Let natural content-type take over
+      (insert "\n"
+ 	      " \n"
+ 	      "  " qsubj "\n"
+ 	      "  \n"
+ 	      " \n"
+ 	      " \n"
+ 	      "  
    \n"
+ 	      "   
    " qsubj "
    \n"
+ 	      "   
    \n"
+ 	      "    From: " qfrom "
    \n"
+ 	      "    Newsgroups: "
+ 	      (mapconcat
+ 	       (function
+ 		(lambda (grp)
+ 		  (concat "" grp ""))) qgrps ", ")
+ 	      "
    \n"
+ 	      (if org
+ 		  (concat
+ 		   "    Organization:  " qorg " 
    \n")
+ 		"")
+ 	      "    Date:  " date " 
    \n"
+ 	      "   
     
    \n"
+ 	      (if (null qrefs)
+ 		  ""
+ 		(concat
+ 		 "   
    References\n"
+ 		 "    
      \n"
+ 		 (mapconcat
+ 		  (function
+ 		   (lambda (ref)
+ 		     (concat "     
    1.   " 
+ 			     ref "
      2. \n")))
+ 		  qrefs "")
+ 		 "    
    \n"
+		 "   
    \n"
+ 		 "   
    \n"))
+ 	      "   \n"
+ 	      "   
    "
+ 	      "   
    \n")
+      (let ((s (buffer-substring (point) (point-max))))
+	(delete-region (point) (point-max))
+	(insert (url-insert-entities-in-string s)))
+      (goto-char (point-max))
+      (setq url-current-mime-type "text/html"
+ 	    url-current-mime-viewer (mm-mime-info url-current-mime-type nil 5))
+      (let ((x (assoc "content-type" url-current-mime-headers)))
+ 	(if x
+ 	    (setcdr x "text/html")
+ 	  (setq url-current-mime-headers (cons (cons "content-type"
+ 						     "text/html")
+ 					       url-current-mime-headers))))
+      (insert "\n"
+ 	      "   
    \n"
+ 	      "  
    \n"
+ 	      " \n"
+ 	      "\n"
+ 	      ""))))
+
+(defun url-check-gnus-version ()
+  (require 'nntp)
+  (condition-case ()
+      (require 'gnus)
+    (error (setq gnus-version "GNUS not found")))
+  (if (or (not (boundp 'gnus-version))
+	  (string-match "v5.[.0-9]+$" gnus-version)
+	  (string-match "Red" gnus-version))
+      nil
+    (url-warn 'url (concat
+		    "The version of GNUS found on this system is too old and does\n"
+		    "not support the necessary functionality for the URL package.\n"
+		    "Please upgrade to version 5.x of GNUS.  This is bundled by\n"
+		    "default with Emacs 19.30 and XEmacs 19.14 and later.\n\n"
+		    "This version of GNUS is: " gnus-version "\n"))
+    (fset 'url-news 'url-news-version-too-old))
+  (fset 'url-check-gnus-version 'ignore))
+
+(defun url-news-version-too-old (article)
+  (set-buffer (get-buffer-create url-working-buffer))
+  (setq url-current-mime-headers '(("content-type" . "text/html"))
+	url-current-mime-type "text/html")
+  (insert "\n"
+	  " \n"
+	  "  News Error\n"
+	  " \n"
+	  " \n"
+	  "  
    News Error - too old
    \n"
+	  "  
    \n"
+	  "   The version of GNUS found on this system is too old and does\n"
+	  "   not support the necessary functionality for the URL package.\n"
+	  "   Please upgrade to version 5.x of GNUS.  This is bundled by\n"
+	  "   default with Emacs 19.30 and XEmacs 19.14 and later.\n\n"
+	  "   This version of GNUS is: " gnus-version "\n"
+	  "  
    \n"
+	  " \n"
+	  "\n"))
+
+(defun url-news-open-host (host port user pass)
+  (if (fboundp 'nnheader-init-server-buffer)
+      (nnheader-init-server-buffer))
+  (nntp-open-server host (list (string-to-int port)))
+  (if (and user pass)
+      (progn
+	(nntp-send-command "^.*\r?\n" "AUTHINFO USER" user)
+	(nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass)
+	(if (not (nntp-server-opened host))
+	    (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed"
+				   host user))))))
+
+(defun url-news-fetch-article-number (newsgroup article)
+  (nntp-request-group newsgroup)
+  (nntp-request-article article))
+
+(defun url-news-fetch-message-id (host port message-id)
+  (if (eq ?> (aref message-id (1- (length message-id))))
+      nil
+    (setq message-id (concat "<" message-id ">")))
+  (if (nntp-request-article message-id)
+      (url-format-news)
+    (set-buffer (get-buffer-create url-working-buffer))
+    (setq url-current-can-be-cached nil)
+    (insert "\n"
+	    " \n"
+	    "  Error\n"
+	    " \n"
+	    " \n"
+	    "  
    \n"
+	    "   
    Error requesting article...
    \n"
+	    "   
    \n"
+	    "    The status message returned by the NNTP server was:"
+	    "
    \n"
+	    "    \n"
+	    (nntp-status-message)
+	    "    \n"
+	    "   
    \n"
+	    "   
    \n"
+	    "    If you If you feel this is an error, send me mail\n"
+	    "   
    \n"
+	    "  
    \n"
+	    " \n"
+	    "\n"
+	    "\n"
+	    )))
+
+(defun url-news-fetch-newsgroup (newsgroup host)
+  (if (string-match "^/+" newsgroup)
+      (setq newsgroup (substring newsgroup (match-end 0))))
+  (if (string-match "/+$" newsgroup)
+      (setq newsgroup (substring newsgroup 0 (match-beginning 0))))
+
+  ;; This saves a bogus 'Untitled' buffer by Emacs-W3
+  (kill-buffer url-working-buffer)
+  
+  ;; This saves us from checking new news if GNUS is already running
+  (if (or (not (get-buffer gnus-group-buffer))
+	  (save-excursion
+	    (set-buffer gnus-group-buffer)
+	    (not (eq major-mode 'gnus-group-mode))))
+      (gnus))
+  (set-buffer gnus-group-buffer)
+  (goto-char (point-min))
+  (gnus-group-read-ephemeral-group newsgroup (list 'nntp host)
+				   nil
+				   (cons (current-buffer) 'browse)))
+  
+(defun url-news (article)
+  ;; Find a news reference
+  (url-check-gnus-version)
+  (let* ((urlobj (url-generic-parse-url article))
+	 (host (or (url-host urlobj) url-news-server))
+	 (port (or (url-port urlobj)
+		   (cdr-safe (assoc "news" url-default-ports))))
+	 (article-brackets nil)
+	 (article (url-filename urlobj)))
+    (url-news-open-host host port (url-user urlobj) (url-password urlobj))
+    (cond
+     ((string-match "@" article)	; Its a specific article
+      (url-news-fetch-message-id host port article))
+     ((string= article "")		; List all newsgroups
+      (gnus)
+      (kill-buffer url-working-buffer))
+     (t					; Whole newsgroup
+      (url-news-fetch-newsgroup article host)))
+    (setq url-current-type "news"
+	  url-current-server host
+	  url-current-user (url-user urlobj)
+	  url-current-port port
+	  url-current-file article)))
+
+(defun url-nntp (url)
+  ;; Find a news reference
+  (url-check-gnus-version)
+  (let* ((urlobj (url-generic-parse-url url))
+	 (host (or (url-host urlobj) url-news-server))
+	 (port (or (url-port urlobj)
+		   (cdr-safe (assoc "nntp" url-default-ports))))
+	 (article-brackets nil)
+	 (article (url-filename urlobj)))
+    (url-news-open-host host port (url-user urlobj) (url-password urlobj))
+    (cond
+     ((string-match "@" article)	; Its a specific article
+      (url-news-fetch-message-id host port article))
+     ((string-match "/\\([0-9]+\\)$" article)
+      (url-news-fetch-article-number (substring article 0
+						(match-beginning 0))
+				     (match-string 1 article)))
+						
+     ((string= article "")		; List all newsgroups
+      (gnus)
+      (kill-buffer url-working-buffer))
+     (t					; Whole newsgroup
+      (url-news-fetch-newsgroup article)))
+    (setq url-current-type "news"
+	  url-current-server host
+	  url-current-user (url-user urlobj)
+	  url-current-port port
+	  url-current-file article)))
+
+(provide 'url-news)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-nfs.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-nfs.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,73 @@
+;;; url-nfs.el --- NFS URL interface
+;; Author: wmperry
+;; Created: 1996/10/09 19:00:59
+;; Version: 1.2
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+(require 'cl)
+
+(defvar url-nfs-automounter-directory-spec
+  "file:/net/%h%f"
+  "*How to invoke the NFS automounter.  Certain % sequences are recognized.
+
+%h -- the hostname of the NFS server
+%n -- the port # of the NFS server
+%u -- the username to use to authenticate
+%p -- the password to use to authenticate
+%f -- the filename on the remote server
+%% -- a literal %
+
+Each can be used any number of times.")
+
+(defun url-nfs-unescape (format host port user pass file)
+  (save-excursion
+    (set-buffer (get-buffer-create " *nfs-parse*"))
+    (erase-buffer)
+    (insert format)
+    (goto-char (point-min))
+    (while (re-search-forward "%\\(.\\)" nil t)
+       (let ((escape (aref (match-string 1) 0)))
+	 (replace-match "" t t)
+	 (case escape
+	   (?% (insert "%"))
+	   (?h (insert host))
+	   (?n (insert (or port "")))
+	   (?u (insert (or user "")))
+	   (?p (insert (or pass "")))
+	   (?f (insert (or file "/"))))))
+    (buffer-string)))
+
+(defun url-nfs (url)
+  (let* ((urlobj (url-generic-parse-url url))
+	 (host (url-host urlobj))
+	 (port (string-to-int (url-port urlobj)))
+	 (pass (url-password urlobj))
+	 (user (url-user urlobj))
+	 (file (url-filename urlobj)))
+    (url-retrieve (url-nfs-unescape url-nfs-automounter-directory-spec
+				    host port user pass file))))
+    
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-parse.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-parse.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,193 @@
+;;; url-parse.el --- Uniform Resource Locator parser
+;; Author: wmperry
+;; Created: 1996/12/26 23:25:55
+;; Version: 1.3
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defmacro url-type (urlobj)
+  (` (aref (, urlobj) 0)))
+
+(defmacro url-user (urlobj)
+  (` (aref (, urlobj) 1)))
+
+(defmacro url-password (urlobj)
+  (` (aref (, urlobj) 2)))
+
+(defmacro url-host (urlobj)
+  (` (aref (, urlobj) 3)))
+
+(defmacro url-port (urlobj)
+  (` (or (aref (, urlobj) 4)
+	 (if (url-fullness (, urlobj))
+	     (cdr-safe (assoc (url-type (, urlobj)) url-default-ports))))))
+
+(defmacro url-filename (urlobj)
+  (` (aref (, urlobj) 5)))
+
+(defmacro url-target (urlobj)
+  (` (aref (, urlobj) 6)))
+
+(defmacro url-attributes (urlobj)
+  (` (aref (, urlobj) 7)))
+
+(defmacro url-fullness (urlobj)
+  (` (aref (, urlobj) 8)))
+
+(defmacro url-set-type (urlobj type)
+  (` (aset (, urlobj) 0 (, type))))
+
+(defmacro url-set-user (urlobj user)
+  (` (aset (, urlobj) 1 (, user))))
+
+(defmacro url-set-password (urlobj pass)
+  (` (aset (, urlobj) 2 (, pass))))
+
+(defmacro url-set-host (urlobj host)
+  (` (aset (, urlobj) 3 (, host))))
+
+(defmacro url-set-port (urlobj port)
+  (` (aset (, urlobj) 4 (, port))))
+
+(defmacro url-set-filename (urlobj file)
+  (` (aset (, urlobj) 5 (, file))))
+
+(defmacro url-set-target (urlobj targ)
+  (` (aset (, urlobj) 6 (, targ))))
+
+(defmacro url-set-attributes (urlobj targ)
+  (` (aset (, urlobj) 7 (, targ))))
+
+(defmacro url-set-full (urlobj val)
+  (` (aset (, urlobj) 8 (, val))))
+  
+(defun url-recreate-url (urlobj)
+  (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
+	  (if (url-user urlobj)
+	      (concat (url-user urlobj)
+		      (if (url-password urlobj)
+			  (concat ":" (url-password urlobj)))
+		      "@"))
+	  (url-host urlobj)
+	  (if (and (url-port urlobj)
+		   (not (equal (url-port urlobj)
+			       (cdr-safe (assoc (url-type urlobj)
+						url-default-ports)))))
+	      (concat ":" (url-port urlobj)))
+	  (or (url-filename urlobj) "/")
+	  (if (url-target urlobj)
+	      (concat "#" (url-target urlobj)))
+	  (if (url-attributes urlobj)
+	      (concat ";"
+		      (mapconcat
+		       (function
+			(lambda (x)
+			  (if (cdr x)
+			      (concat (car x) "=" (cdr x))
+			    (car x)))) (url-attributes urlobj) ";")))))
+
+(defun url-generic-parse-url (url)
+  "Return a vector of the parts of URL.
+Format is [protocol username password hostname portnumber file reference]"
+  (cond
+   ((null url)
+    (make-vector 9 nil))
+   ((or (not (string-match url-nonrelative-link url))
+	(= ?/ (string-to-char url)))
+    (let ((retval (make-vector 9 nil)))
+      (url-set-filename retval url)
+      (url-set-full retval nil)
+      retval))
+   (t
+    (save-excursion
+      (set-buffer (get-buffer-create " *urlparse*"))
+      (set-syntax-table url-mailserver-syntax-table)
+      (let ((save-pos nil)
+	    (prot nil)
+	    (user nil)
+	    (pass nil)
+	    (host nil)
+	    (port nil)
+	    (file nil)
+	    (refs nil)
+	    (attr nil)
+	    (full nil)
+	    (inhibit-read-only t))
+	(erase-buffer)
+	(insert url)
+	(goto-char (point-min))
+	(setq save-pos (point))
+	(if (not (looking-at "//"))
+	    (progn
+	      (skip-chars-forward "a-zA-Z+.\\-")
+	      (downcase-region save-pos (point))
+	      (setq prot (buffer-substring save-pos (point)))
+	      (skip-chars-forward ":")
+	      (setq save-pos (point))))
+
+	;; We are doing a fully specified URL, with hostname and all
+	(if (looking-at "//")
+	    (progn
+	      (setq full t)
+	      (forward-char 2)
+	      (setq save-pos (point))
+	      (skip-chars-forward "^/")
+	      (downcase-region save-pos (point))
+	      (setq host (buffer-substring save-pos (point)))
+	      (if (string-match "^\\([^@]+\\)@" host)
+		  (setq user (url-match host 1)
+			host (substring host (match-end 0) nil)))
+	      (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
+		  (setq pass (url-match user 2)
+			user (url-match user 1)))
+	      (if (string-match ":\\([0-9+]+\\)" host)
+		  (setq port (url-match host 1)
+			host (substring host 0 (match-beginning 0))))
+	      (if (string-match ":$" host)
+		  (setq host (substring host 0 (match-beginning 0))))
+	      (setq save-pos (point))))
+	;; Now check for references
+	(setq save-pos (point))
+	(skip-chars-forward "^#")
+	(if (eobp)
+	    nil
+          (delete-region
+           (point)
+           (progn
+             (skip-chars-forward "#")
+             (setq refs (buffer-substring (point) (point-max)))
+             (point-max))))
+	(goto-char save-pos)
+	(skip-chars-forward "^;")
+	(if (not (eobp))
+	    (setq attr (mm-parse-args (point) (point-max))
+		  attr (nreverse attr)))
+	(setq file (buffer-substring save-pos (point)))
+	(and port (string= port (or (cdr-safe (assoc prot url-default-ports))
+				    ""))
+	     (setq port nil))
+	(if (and host (string-match "%[0-9][0-9]" host))
+	    (setq host (url-unhex-string host)))
+	(vector prot user pass host port file refs attr full)))))) 
+
+(provide 'url-parse)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-pgp.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-pgp.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,175 @@
+;;; url-pgp.el --- PGP encapsulation of HTTP
+;; Author: wmperry
+;; Created: 1996/10/09 19:00:59
+;; Version: 1.2
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; UUencoding
+;;; ----------
+;;; These functions are needed for the (RI)PEM encoding.  PGP can
+;;; handle binary data, but (RI)PEM requires that it be uuencoded
+;;; first, or it will barf severely.  How rude.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-uuencode-buffer (&optional buff)
+  "UUencode buffer BUFF, with a default of the current buffer."
+  (setq buff (or buff (current-buffer)))
+  (save-excursion
+    (set-buffer buff)
+    (url-lazy-message "UUencoding...")
+    (call-process-region (point-min) (point-max)
+			 url-uuencode-program t t nil "url-temp-file")
+    (url-lazy-message "UUencoding... done.")))
+
+(defun url-uudecode-buffer (&optional buff)
+  "UUdecode buffer BUFF, with a default of the current buffer."
+  (setq buff (or buff (current-buffer)))
+  (let ((newname (url-generate-unique-filename)))
+    (save-excursion
+      (set-buffer buff)
+      (goto-char (point-min))
+      (re-search-forward "^begin [0-9][0-9][0-9] \\(.*\\)$" nil t)
+      (replace-match (concat "begin 600 " newname))
+      (url-lazy-message "UUdecoding...")
+      (call-process-region (point-min) (point-max) url-uudecode-program)
+      (url-lazy-message "UUdecoding...")
+      (erase-buffer)
+      (insert-file-contents-literally newname)
+      (url-lazy-message "UUdecoding... done.")
+      (condition-case ()
+	  (delete-file newname)
+	(error nil)))))
+      
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Decoding PGP/PEM responses
+;;; --------------------------
+;;; A PGP/PEM encrypted/signed response contains all the real headers,
+;;; so this is just a quick decrypt-then-reparse hack.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-decode-pgp/pem (arg)
+  "Decode a pgp/pem response from an HTTP/1.0 server.
+This expects the decoded message to contain all the necessary HTTP/1.0 headers
+to correctly act on the decoded message (new content-type, etc)."
+  (mc-decrypt-message)
+  (url-parse-mime-headers))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; PGP/PEM Encryption
+;;; ------------------
+;;; This implements the highly secure PGP/PEM encrypted requests, as
+;;; specified by NCSA and CERN.
+;;;
+;;; The complete online spec of this scheme was done by Tony Sanders
+;;; , and can be seen at
+;;; http://www.bsdi.com/HTTP:TNG/ripem-http.txt
+;;;
+;;; This section of code makes use of the EXCELLENT mailcrypt.el
+;;; package by Jin S Choi (jsc@mit.edu)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun url-public-key-exists (entity scheme)
+  "Return t iff a key for ENTITY exists using public key system SCHEME.
+ENTITY is the username/hostname combination we are checking for.
+SCHEME is a symbol representing what public key encryption program to use.
+       Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
+       recognized."
+  (let (retval)
+    (save-excursion
+      (cond
+       ((eq 'pgp scheme)			; PGP encryption
+	(set-buffer (get-buffer-create " *keytmp*"))
+	(erase-buffer)
+	(call-process mc-pgp-path nil t nil "+batchmode" "-kxaf" entity)
+	(goto-char (point-min))
+	(setq retval (search-forward mc-pgp-key-begin-line nil t)))
+       ((eq 'pem scheme)			; PEM encryption
+	(set-buffer (find-file-noselect mc-ripem-pubkeyfile))
+	(goto-char (point-min))
+	(setq retval (search-forward entity nil t)))
+       (t
+	(url-warn 'security
+		  (format
+		   "Bad value for SCHEME in url-public-key-exists %s"
+		   scheme))))
+      (kill-buffer (current-buffer)))
+    retval))
+
+(defun url-get-server-keys (entity &optional scheme)
+  "Make sure the key for ENTITY exists using SCHEME.
+ENTITY is the username/hostname combination to get the info for.  
+       This should be a string you could pass to 'finger'.
+SCHEME is a symbol representing what public key encryption program to use.
+       Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
+       recognized."
+  (or scheme (setq scheme mc-default-scheme))
+  (save-excursion
+    (cond
+     ((url-public-key-exists entity scheme) nil)
+     (t
+      (string-match "\\([^@]+\\)@\\(.*\\)" entity)
+      (let ((url-working-buffer " *url-get-keys*"))
+	(url-retrieve (format "gopher://%s:79/0%s/w" (url-match entity 1)
+			     (url-match entity 2)))
+	(mc-snarf-keys)
+	(kill-buffer url-working-buffer))))))
+   
+(defun url-fetch-with-pgp (url recipient type)
+  "Retrieve a document with public-key authentication.
+      URL is the url to request from the server.
+RECIPIENT is the server's entity name (usually webmaster@host)
+     TYPE is a symbol representing what public key encryption program to use.
+          Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
+          recognized."
+  (or noninteractive (require 'mailcrypt))
+  (let ((request (url-create-mime-request url "PGP-Redirect"))
+	(url-request-data nil)
+	(url-request-extra-headers nil))
+    (save-excursion
+      (url-get-server-keys recipient type)
+      (set-buffer (get-buffer-create " *url-encryption*"))
+      (erase-buffer)
+      (insert "\n\n" mail-header-separator "\n" request)
+      (mc-encrypt-message recipient type)
+      (goto-char (point-min))
+      (if (re-search-forward (concat "\n" mail-header-separator "\n") nil t)
+	  (delete-region (point-min) (point)))
+      (setq url-request-data (buffer-string)
+	    url-request-extra-headers
+	    (list (cons "Authorized" (format "%s entity=\"%s\""
+					     (cond
+					      ((eq type 'pgp) "PGP")
+					      ((eq type 'pem) "PEM"))
+					     url-pgp/pem-entity))
+		  (cons "Content-type" (format "application/x-www-%s-reply"
+					       (cond
+						((eq type 'pgp) "pgp")
+						((eq type 'pem) "pem")))))))
+    (kill-buffer " *url-encryption*")
+    (url-retrieve (url-expand-file-name "/") t)))
+     
+(provide 'url-pgp)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-vars.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-vars.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,558 @@
+;;; url-vars.el --- Variables for Uniform Resource Locator tool
+;; Author: wmperry
+;; Created: 1996/12/30 14:25:24
+;; Version: 1.19
+;; Keywords: comm, data, processes, hypermedia
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst url-version (let ((x "Exp"))
+			(if (string-match "State: \\([^ \t\n]+\\)" x)
+			    (substring x (match-beginning 1) (match-end 1))
+			  x))
+  "Version # of URL package.")
+
+(defvar url-current-can-be-cached t
+  "*Whether the current URL can be cached.")
+
+(defvar url-current-object nil
+  "A parsed representation of the current url")
+
+(defvar url-current-callback-func nil
+  "*The callback function for the current buffer.")
+
+(defvar url-current-callback-data nil
+  "*The data to be passed to the callback function.  This should be a list,
+each item in the list will be an argument to the url-current-callback-func.")
+
+(mapcar 'make-variable-buffer-local '(
+				      url-current-callback-data
+				      url-current-callback-func
+				      url-current-can-be-cached
+				      url-current-content-length
+				      url-current-file
+				      url-current-isindex
+				      url-current-mime-encoding
+				      url-current-mime-headers
+				      url-current-mime-type
+				      url-current-mime-viewer
+				      url-current-object
+				      url-current-port
+				      url-current-referer
+				      url-current-server
+				      url-current-type
+				      url-current-user
+				      ))
+
+(defvar url-default-retrieval-proc 'url-default-callback
+  "*The default action to take when an asynchronous retrieval completes.")
+
+(defvar url-honor-refresh-requests t
+  "*Whether to do automatic page reloads at the request of the document
+author or the server via the `Refresh' header in an HTTP/1.0 response.
+If nil, no refresh requests will be honored.
+If t, all refresh requests will be honored.
+If non-nil and not t, the user will be asked for each refresh request.")
+
+(defvar url-emacs-minor-version
+  (if (boundp 'emacs-minor-version)
+      (symbol-value 'emacs-minor-version)
+    (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
+	(string-to-int
+	 (substring emacs-version
+		    (match-beginning 1) (match-end 1)))
+      0))
+  "What minor version of emacs we are using.")
+
+(defvar url-inhibit-mime-parsing nil
+  "Whether to parse out (and delete) the MIME headers from a message.")
+
+(defvar url-automatic-caching nil
+  "*If non-nil, all documents will be automatically cached to the local
+disk.")
+
+(defvar url-cache-expired
+  (function (lambda (t1 t2) (>= (- (car t2) (car t1)) 5)))
+  "*A function (`funcall'able) that takes two times as its arguments, and
+returns non-nil if the second time is 'too old' when compared to the first
+time.")
+
+(defvar url-check-md5s nil
+  "*Whether to check md5s of retrieved documents or not.")
+
+(defvar url-expected-md5 nil "What md5 we expect to see.")
+
+(defvar url-broken-resolution nil
+  "*Whether to use [ange|efs]-ftp-nslookup-host.")
+
+(defvar url-bug-address "wmperry@cs.indiana.edu" "Where to send bug reports.")
+
+(defvar url-cookie-confirmation nil
+  "*If non-nil, confirmation by the user is required before accepting any
+HTTP cookies.")
+
+(defvar url-personal-mail-address nil
+  "*Your full email address.  This is what is sent to HTTP/1.0 servers as
+the FROM field.  If not set when url-do-setup is run, it defaults to
+the value of url-pgp/pem-entity.")
+
+(defvar url-directory-index-file "index.html"
+  "*The filename to look for when indexing a directory.  If this file
+exists, and is readable, then it will be viewed instead of
+automatically creating the directory listing.")
+
+(defvar url-pgp/pem-entity nil
+  "*The users PGP/PEM id - usually their email address.")
+
+(defvar url-privacy-level 'none
+  "*How private you want your requests to be.
+HTTP/1.0 has header fields for various information about the user, including
+operating system information, email addresses, the last page you visited, etc.
+This variable controls how much of this information is sent.
+
+This should a symbol or a list.
+Valid values if a symbol are:
+none     -- Send all information
+low      -- Don't send the last location
+high     -- Don't send the email address or last location
+paranoid -- Don't send anything
+
+If a list, this should be a list of symbols of what NOT to send.
+Valid symbols are:
+email    -- the email address
+os       -- the operating system info
+lastloc  -- the last location
+agent    -- Do not send the User-Agent string
+cookie   -- never accept HTTP cookies
+
+Samples:
+
+(setq url-privacy-level 'high)
+(setq url-privacy-level '(email lastloc))    ;; equivalent to 'high
+(setq url-privacy-level '(os))
+
+::NOTE::
+This variable controls several other variables and is _NOT_ automatically
+updated.  Call the function `url-setup-privacy-info' after modifying this
+variable.
+")
+
+(defvar url-uudecode-program "uudecode" "*The UUdecode executable.")
+
+(defvar url-uuencode-program "uuencode" "*The UUencode executable.")
+
+(defvar url-history-list nil "List of urls visited this session.")
+
+(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.")
+
+(defvar url-keep-history nil
+  "*Controls whether to keep a list of all the URLS being visited.  If
+non-nil, url will keep track of all the URLS visited.
+If eq to `t', then the list is saved to disk at the end of each emacs
+session.")
+
+(defvar url-uncompressor-alist '((".z"  . "x-gzip")
+				(".gz" . "x-gzip")
+				(".uue" . "x-uuencoded")
+				(".hqx" . "x-hqx")
+				(".Z"  . "x-compress"))
+  "*An assoc list of file extensions and the appropriate
+content-transfer-encodings for each.")
+
+(defvar url-xterm-command "xterm -title %s -ut -e %s %s %s"
+  "*Command used to start an xterm window.")
+
+(defvar url-tn3270-emulator "tn3270"
+  "The client to run in a subprocess to connect to a tn3270 machine.")
+
+(defvar url-use-transparent nil
+  "*Whether to use the transparent package by Brian Tompsett instead of
+the builtin telnet functions.  Using transparent allows you to have full
+vt100 emulation in the telnet and tn3270 links.")
+
+(defvar url-mail-command 'url-mail
+  "*This function will be called whenever url needs to send mail.  It should
+enter a mail-mode-like buffer in the current window.
+The commands mail-to and mail-subject should still work in this
+buffer, and it should use mail-header-separator if possible.")
+
+(defvar url-local-exec-path nil
+  "*A list of possible locations for x-exec scripts.")
+
+(defvar url-proxy-services nil
+  "*An assoc list of access types and servers that gateway them.
+Looks like ((\"http\" . \"url://for/proxy/server/\") ....)  This is set up
+from the ACCESS_proxy environment variables in url-do-setup.")
+
+(defvar url-global-history-file nil
+  "*The global history file used by both Mosaic/X and the url package.
+This file contains a list of all the URLs you have visited.  This file
+is parsed at startup and used to provide URL completion.")
+
+(defvar url-global-history-save-interval 3600
+  "*The number of seconds between automatic saves of the history list.
+Default is 1 hour.  Note that if you change this variable after `url-do-setup'
+has been run, you need to run the `url-setup-save-timer' function manually.")
+
+(defvar url-global-history-timer nil)
+
+(defvar url-passwd-entry-func nil
+  "*This is a symbol indicating which function to call to read in a
+password.  It will be set up depending on whether you are running EFS
+or ange-ftp at startup if it is nil.  This function should accept the
+prompt string as its first argument, and the default value as its
+second argument.")
+
+(defvar url-gopher-labels
+  '(("0" . "(TXT)")
+    ("1" . "(DIR)")
+    ("2" . "(CSO)")
+    ("3" . "(ERR)")
+    ("4" . "(MAC)")
+    ("5" . "(PCB)")
+    ("6" . "(UUX)")
+    ("7" . "(???)")
+    ("8" . "(TEL)")
+    ("T" . "(TN3)")
+    ("9" . "(BIN)")
+    ("g" . "(GIF)")
+    ("I" . "(IMG)")
+    ("h" . "(WWW)")
+    ("s" . "(SND)"))
+  "*An assoc list of gopher types and how to describe them in the gopher
+menus.  These can be any string, but HTML/HTML+ entities should be
+used when necessary, or it could disrupt formatting of the document
+later on.  It is also a good idea to make sure all the strings are the
+same length after entity references are removed, on a strictly
+stylistic level.")
+
+(defvar url-gopher-icons
+  '(
+    ("0" . "&text.document;")
+    ("1" . "&folder;")
+    ("2" . "&index;")
+    ("3" . "&stop;")
+    ("4" . "&binhex.document;")
+    ("5" . "&binhex.document;")
+    ("6" . "&uuencoded.document;")
+    ("7" . "&index;")
+    ("8" . "&telnet;")
+    ("T" . "&tn3270;")
+    ("9" . "&binary.document;")
+    ("g" . "ℑ")
+    ("I" . "ℑ")
+    ("s" . "&audio;"))
+  "*An assoc list of gopher types and the graphic entity references to
+show when possible.")
+
+(defvar url-standalone-mode nil "*Rely solely on the cache?")
+(defvar url-multiple-p t
+  "*If non-nil, multiple queries are possible through ` *URL-*' buffers")
+(defvar url-default-working-buffer " *URL*" " The default buffer to do all of the processing in.")
+(defvar url-working-buffer url-default-working-buffer " The buffer to do all of the processing in.
+ (It defaults to `url-default-working-buffer' and is bound to ` *URL-*' buffers
+  when used for multiple requests, cf. `url-multiple-p')")
+(defvar url-current-annotation nil "URL of document we are annotating...")
+(defvar url-current-referer nil "Referer of this page.")
+(defvar url-current-content-length nil "Current content length.")
+(defvar url-current-file nil "Filename of current document.")
+(defvar url-current-isindex nil "Is the current document a searchable index?")
+(defvar url-current-mime-encoding nil "MIME encoding of current document.")
+(defvar url-current-mime-headers nil "An alist of MIME headers.")
+(defvar url-current-mime-type nil "MIME type of current document.")
+(defvar url-current-mime-viewer nil "How to view the current MIME doc.")
+(defvar url-current-nntp-server nil "What nntp server currently opened.")
+(defvar url-current-passwd-count 0 "How many times password has failed.")
+(defvar url-current-port nil "Port # of the current document.")
+(defvar url-current-server nil "Server of the current document.")
+(defvar url-current-user nil "Username for ftp login.")
+(defvar url-current-type nil "We currently in http or file mode?")
+(defvar url-gopher-types "0123456789+gIThws:;<"
+  "A string containing character representations of all the gopher types.")
+(defvar url-mime-separator-chars (mapcar 'identity
+					(concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+						"abcdefghijklmnopqrstuvwxyz"
+						"0123456789'()+_,-./=?"))
+  "Characters allowable in a MIME multipart separator.")
+
+(defvar url-bad-port-list
+  '("25" "119" "19")
+  "*List of ports to warn the user about connecting to.  Defaults to just
+the mail, chargen, and NNTP ports so you cannot be tricked into sending
+fake mail or forging messages by a malicious HTML document.")
+
+(defvar url-be-anal-about-file-attributes nil
+  "*Whether to use HTTP/1.0 to figure out file attributes
+or just guess based on file extension, etc.")
+
+(defvar url-be-asynchronous nil
+  "*Controls whether document retrievals over HTTP should be done in
+the background.  This allows you to keep working in other windows
+while large downloads occur.")
+(make-variable-buffer-local 'url-be-asynchronous)
+
+(defvar url-request-data nil "Any data to send with the next request.")
+
+(defvar url-request-extra-headers nil
+  "A list of extra headers to send with the next request.  Should be
+an assoc list of headers/contents.")
+
+(defvar url-request-method nil "The method to use for the next request.")
+
+(defvar url-mime-encoding-string nil
+  "String to send to the server in the Accept-encoding: field in HTTP/1.0
+requests.  This is created automatically from mm-content-transfer-encodings.")
+
+(defvar url-mime-language-string "*"
+  "String to send to the server in the Accept-language: field in
+HTTP/1.0 requests.")
+
+(defvar url-mime-accept-string nil
+  "String to send to the server in the Accept: field in HTTP/1.0 requests.
+This is created automatically from url-mime-viewers, after the mailcap file
+has been parsed.")
+
+(defvar url-history-changed-since-last-save nil
+  "Whether the history list has changed since the last save operation.")
+
+(defvar url-proxy-basic-authentication nil
+  "Internal structure - do not modify!")
+  
+(defvar url-registered-protocols nil
+  "Internal structure - do not modify!  See `url-register-protocol'")
+
+(defvar url-package-version "Unknown" "Version # of package using URL.")
+
+(defvar url-package-name "Unknown" "Version # of package using URL.")
+
+(defvar url-system-type nil "What type of system we are on.")
+(defvar url-os-type nil "What OS we are on.")
+
+(defvar url-max-password-attempts 5
+  "*Maximum number of times a password will be prompted for when a
+protected document is denied by the server.")
+
+(defvar url-wais-to-mime
+  '(
+    ("WSRC" . "application/x-wais-source") 	; A database description
+    ("TEXT" . "text/plain")			; plain text
+    )
+  "An assoc list of wais doctypes and their corresponding MIME
+content-types.")
+
+(defvar url-waisq-prog "waisq"
+  "*Name of the waisq executable on this system.  This should be the
+waisq program from think.com's wais8-b5.1 distribution.")
+
+(defvar url-wais-gateway-server "www.ncsa.uiuc.edu"
+  "*The machine name where the WAIS gateway lives.")
+
+(defvar url-wais-gateway-port "8001"
+  "*The port # of the WAIS gateway.")
+
+(defvar url-temporary-directory "/tmp" "*Where temporary files go.")
+
+(defvar url-show-status t
+  "*Whether to show a running total of bytes transferred.  Can cause a
+large hit if using a remote X display over a slow link, or a terminal
+with a slow modem.")
+
+(defvar url-using-proxy nil
+  "Either nil or the fully qualified proxy URL in use, e.g.
+http://www.domain.com/")
+
+(defvar url-news-server nil
+  "*The default news server to get newsgroups/articles from if no server
+is specified in the URL.  Defaults to the environment variable NNTPSERVER
+or \"news\" if NNTPSERVER is undefined.")
+
+(defvar url-gopher-to-mime
+  '((?0 . "text/plain")			; It's a file
+    (?1 . "www/gopher")			; Gopher directory
+    (?2 . "www/gopher-cso-search")	; CSO search
+    (?3 . "text/plain")			; Error
+    (?4 . "application/mac-binhex40")	; Binhexed macintosh file
+    (?5 . "application/pc-binhex40")	; DOS binary archive of some sort
+    (?6 . "archive/x-uuencode")		; Unix uuencoded file
+    (?7 . "www/gopher-search")		; Gopher search!
+    (?9 . "application/octet-stream")	; Binary file!
+    (?g . "image/gif")			; Gif file
+    (?I . "image/gif")			; Some sort of image
+    (?h . "text/html")			; HTML source
+    (?s . "audio/basic")		; Sound file
+    )
+  "*An assoc list of gopher types and their corresponding MIME types.")
+
+(defvar url-use-hypertext-gopher t
+  "*Controls how gopher documents are retrieved.
+If non-nil, the gopher pages will be converted into HTML and parsed
+just like any other page.  If nil, the requests will be passed off to
+the gopher.el package by Scott Snyder.  Using the gopher.el package
+will lose the gopher+ support, and inlined searching.")
+
+(defvar url-global-history-hash-table nil
+  "Hash table for global history completion.")
+
+(defvar url-nonrelative-link
+  "^\\([-a-zA-Z0-9+.]+:\\)"
+  "A regular expression that will match an absolute URL.")
+
+(defvar url-configuration-directory nil
+  "*Where the URL configuration files can be found.")
+
+(defvar url-confirmation-func 'y-or-n-p
+  "*What function to use for asking yes or no functions.  Possible
+values are 'yes-or-no-p or 'y-or-n-p, or any function that takes a
+single argument (the prompt), and returns t only if a positive answer
+is gotten.")
+
+(defvar url-connection-retries 5
+  "*# of times to try for a connection before bailing.
+If for some reason url-open-stream cannot make a connection to a host
+right away, it will sit for 1 second, then try again, up to this many
+tries.")
+
+(defvar url-find-this-link nil "Link to go to within a document.")
+
+(defvar url-show-http2-transfer t
+  "*Whether to show the total # of bytes, size of file, and percentage
+transferred when retrieving a document over HTTP/1.0 and it returns a
+valid content-length header.  This can mess up some people behind
+gateways.")
+
+(defvar url-gateway-method 'native
+  "*The type of gateway support to use.
+Should be a symbol specifying how we are to get a connection off of the
+local machine.
+
+Currently supported methods:
+'program	:: Run a program in a subprocess to connect
+                   (examples are itelnet, an expect script, etc)
+'native		:: Use the native open-network-stream in emacs
+'tcp            :: Use the excellent tcp.el package from gnus.
+                   This simply does a (require 'tcp), then sets
+                   url-gateway-method to be 'native.")
+
+(defvar url-gateway-shell-is-telnet nil
+  "*Whether the login shell of the remote host is telnet.")
+
+(defvar url-gateway-program-interactive nil
+  "*Whether url needs to hand-hold the login program on the remote machine.")
+
+(defvar url-gateway-handholding-login-regexp "ogin:"
+  "*Regexp for when to send the username to the remote process.")
+
+(defvar url-gateway-handholding-password-regexp "ord:"
+  "*Regexp for when to send the password to the remote process.")
+
+(defvar url-gateway-host-prompt-pattern "^[^#$%>;]*[#$%>;] *"
+  "*Regexp used to detect when the login is finished on the remote host.")
+
+(defvar url-gateway-telnet-ready-regexp "Escape character is .*"
+  "*A regular expression that signifies url-gateway-telnet-program is
+ready to accept input.")
+
+(defvar url-local-rlogin-prog "rlogin"
+  "*Program for local telnet connections.")
+
+(defvar url-remote-rlogin-prog "rlogin"
+  "*Program for remote telnet connections.")
+
+(defvar url-local-telnet-prog "telnet"
+  "*Program for local telnet connections.")
+
+(defvar url-remote-telnet-prog "telnet"
+  "*Program for remote telnet connections.")  
+
+(defvar url-running-xemacs (string-match "XEmacs" emacs-version)
+  "*In XEmacs?.")
+
+(defvar url-gateway-telnet-program "itelnet"
+  "*Program to run in a subprocess when using gateway-method 'program.")
+
+(defvar url-gateway-local-host-regexp nil
+  "*If a host being connected to matches this regexp then the
+connection is done natively, otherwise the process is started on
+`url-gateway-host' instead.")
+
+(defvar url-use-hypertext-dired t
+  "*How to format directory listings.
+
+If value is non-nil, use directory-files to list them out and
+transform them into a hypertext document, then pass it through the
+parse like any other document.
+
+If value nil, just pass the directory off to dired using find-file.")
+
+(defconst monthabbrev-alist
+  '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
+    ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
+
+(defvar url-default-ports '(("http"   .  "80")
+			    ("gopher" .  "70")
+			    ("telnet" .  "23")
+			    ("news"   . "119")
+			    ("https"  . "443")
+			    ("shttp"  .  "80"))
+  "An assoc list of protocols and default port #s")
+
+(defvar url-setup-done nil "*Has setup configuration been done?")
+
+(defvar url-source nil
+  "*Whether to force a sourcing of the next buffer.  This forces local
+files to be read into a buffer, no matter what.  Gets around the
+optimization that if you are passing it to a viewer, just make a
+symbolic link, which looses if you want the source for inlined
+images/etc.")
+
+(defconst weekday-alist
+  '(("Sunday" . 0) ("Monday" . 1) ("Tuesday" . 2) ("Wednesday" . 3)
+    ("Thursday" . 4) ("Friday" . 5) ("Saturday" . 6)
+    ("Tues" . 2) ("Thurs" . 4)
+    ("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3)
+    ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))
+
+(defconst monthabbrev-alist
+  '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
+    ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))
+  )
+
+(defvar url-lazy-message-time 0)
+
+(defvar url-extensions-header "Security/Digest Security/SSL")
+
+(defvar url-mailserver-syntax-table
+  (copy-syntax-table emacs-lisp-mode-syntax-table)
+  "*A syntax table for parsing the mailserver URL")
+
+(modify-syntax-entry ?' "\"" url-mailserver-syntax-table)
+(modify-syntax-entry ?` "\"" url-mailserver-syntax-table)
+(modify-syntax-entry ?< "(>" url-mailserver-syntax-table)
+(modify-syntax-entry ?> ")<" url-mailserver-syntax-table)
+(modify-syntax-entry ?/ " " url-mailserver-syntax-table)
+
+;;; Make OS/2 happy - yeeks
+(defvar	tcp-binary-process-input-services nil
+  "*Make OS/2 happy with our CRLF pairs...")
+
+(provide 'url-vars)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url-wais.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url-wais.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,251 @@
+;;; url-wais.el --- WAIS Uniform Resource Locator retrieval code
+;; Author: wmperry
+;; Created: 1996/10/09 19:00:59
+;; Version: 1.3
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; WAIS support
+;;; ------------
+;;; Here are even more gross hacks that I call native WAIS support.
+;;; This code requires a working waisq program that is fully
+;;; compatible with waisq from think.com
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-create-wais-source (server port dbase)
+  ;; Create a temporary wais source description file.  Returns the
+  ;; file name the description is in.
+  (let ((x (url-generate-unique-filename))
+	(y (get-buffer-create " *waisq-tmp*")))
+    (save-excursion
+      (set-buffer y)
+      (erase-buffer)
+      (insert 
+       (format
+	(concat "(:source\n:version 3\n"
+		":ip-name \"%s\"\n:tcp-port %s\n"
+		":database-name \"%s\"\n)")
+	server (if (equal port "") "210" port) dbase))
+      (write-region (point-min) (point-max) x nil nil)
+      (kill-buffer y))
+    x))
+
+(defun url-wais-stringtoany (str)
+  ;; Return a wais subelement that specifies STR in any database
+  (concat "(:any :size " (length str) " :bytes #( "
+	  (mapconcat 'identity str " ")
+	  " ) )"))
+
+;(defun url-retrieve-wais-docid (server port dbase local-id)
+;  (call-process "waisretrieve" nil url-working-buffer nil
+;		(format "%s:%s@%s:%s" (url-unhex-string local-id)
+;			dbase server port)))
+
+;(url-retrieve-wais-docid "quake.think.com" "210" "directory-of-servers"
+;			"0 2608 /proj/wais/wais-sources/vpiej-l.src")
+(defun url-retrieve-wais-docid (server port dbase local-id)
+  ;; Retrieve a wais document.
+  ;; SERVER is the server the database is on (:ip-name in source description)
+  ;; PORT is the port number to contact (:tcp-port in the source description)
+  ;; DBASE is the database name (:database-name in the source description)
+  ;; LOCAL-ID is the document (:original-local-id in the question description)
+  (let* ((dbf (url-create-wais-source server port dbase))
+	 (qstr (format
+		(concat "(:question :version 2\n"
+			"           :result-documents\n"
+			"           ( (:document-id\n"
+			"              :document\n"
+			"              (:document\n"
+			"               :headline \"\"\n"
+			"               :doc-id\n"
+			"               (:doc-id :original-database %s\n"
+			"                :original-local-id %s )\n"
+			"               :number-of-bytes -1\n"
+			"               :type \"\"\n"
+			"               :source\n"
+			"               (:source-id :filename \"%s\") ) ) ) )")
+		(url-wais-stringtoany dbase)
+		(url-wais-stringtoany (url-unhex-string local-id))
+		dbf))
+	 (qf (url-generate-unique-filename)))
+    (set-buffer (get-buffer-create url-working-buffer))
+    (insert qstr)
+    (write-region (point-min) (point-max) qf nil nil)
+    (erase-buffer)
+    (call-process url-waisq-prog nil url-working-buffer nil "-f" qf "-v" "1")
+    (save-excursion
+      (set-buffer url-working-buffer)
+      (setq url-current-file (url-unhex-string local-id)))
+    (condition-case ()
+	(delete-file dbf)
+      (error nil))
+    (condition-case ()
+	(delete-file qf)
+      (error nil))))
+
+;(url-perform-wais-query "quake.think.com" "210" "directory-of-servers" "SGML")
+(defun url-perform-wais-query (server port dbase search)
+  ;; Perform a wais query.
+  ;; SERVER is the server the database is on (:ip-name in source description)
+  ;; PORT is the port number to contact (:tcp-port in the source description)
+  ;; DBASE is the database name (:database-name in the source description)
+  ;; SEARCH is the search term (:seed-words in the question description)"
+  (let ((dbfname (url-create-wais-source server port dbase))
+	(qfname (url-generate-unique-filename))
+	(results 'url-none-gotten))
+    (save-excursion
+      (url-clear-tmp-buffer)
+      (insert
+       (format
+	(concat "(:question\n"
+		" :version 2\n"
+		" :seed-words \"%s\"\n"
+		" :sourcepath \"" url-temporary-directory "\"\n"
+		" :sources\n"
+		" (  (:source-id\n"
+		"     :filename \"%s\"\n"
+		"    )\n"
+		" )\n"
+		" :maximum-results 100)\n")
+	search dbfname))
+      (write-region (point-min) (point-max) qfname nil nil)
+      (erase-buffer)
+      (call-process url-waisq-prog nil url-working-buffer nil "-g" "-f" qfname)
+      (set-buffer url-working-buffer)
+      (erase-buffer)
+      (setq url-current-server server
+	    url-current-port port
+	    url-current-file dbase)
+      (insert-file-contents-literally qfname)
+      (goto-char (point-min))
+      (if (re-search-forward "(:question" nil t)
+	  (delete-region (point-min) (match-beginning 0)))
+      (url-replace-regexp "Process.*finished.*" "")
+      (subst-char-in-region (point-min) (point-max) 35 32)
+      (goto-char (point-min))
+      (message "Done reading info - parsing results...")
+      (if (re-search-forward ":result-documents[^(]+" nil t)
+	  (progn
+	    (goto-char (match-end 0))
+	    (while (eq results 'url-none-gotten)
+	      (condition-case ()
+		  (setq results (read (current-buffer)))
+		(error (progn
+			 (setq results 'url-none-gotten)
+			 (goto-char (match-end 0))))))
+	    (erase-buffer)
+	    (insert "Results of WAIS search\n"
+		    "
    Searched " dbase " for " search "
    \n"
+		    "
    \n"
+		    "Found " (int-to-string (length results))
+		    " matches.\n"
+		    "
      \n
    1. "
+		    (mapconcat 'url-parse-wais-doc-id results "\n
    2. ")
+		    "\n
    \n
    \n"))
+	(message "No results"))
+      (setq url-current-mime-type "text/html")
+      (condition-case ()
+	  (delete-file qfname)
+	(error nil))
+      (condition-case ()
+	  (delete-file dbfname)
+	(error nil)))))
+
+(defun url-wais-anytostring (x)
+  ;; Convert a (:any ....) wais construct back into a string.
+  (mapconcat 'char-to-string (car (cdr (memq ':bytes x))) ""))
+
+(defun url-parse-wais-doc-id (x)
+  ;; Return a list item that points at the doc-id specified by X
+  (let* ((document (car (cdr (memq ':document x))))
+	 (doc-id (car (cdr (memq ':doc-id document))))
+	 (score (car (cdr (memq ':score x)))) 
+	 (title (car (cdr (memq ':headline document))))
+	 (type (car (cdr (memq ':type document))))
+	 (size (car (cdr (memq ':number-of-bytes document))))
+	 (server (car (cdr (memq ':original-server doc-id))))
+	 (dbase (car (cdr (memq ':original-database doc-id))))
+	 (localid (car (cdr (memq ':original-local-id doc-id))))
+	 (dist-server (car (cdr (memq ':distributor-server doc-id))))
+	 (dist-dbase (car (cdr (memq ':distributor-database doc-id))))
+	 (dist-id (car (cdr (memq ':distributor-local-id doc-id))))
+	 (copyright (or (car (cdr (memq ':copyright-disposition doc-id))) 0)))
+    (format "%s (Score = %s)"
+	    url-current-server url-current-port url-current-file
+	    type size
+	    (url-hexify-string (url-wais-anytostring server))
+	    (url-hexify-string (url-wais-anytostring dbase))
+	    (url-hexify-string (url-wais-anytostring localid))
+	    (url-hexify-string (url-wais-anytostring dist-server))
+	    (url-hexify-string (url-wais-anytostring dist-dbase))
+	    (url-hexify-string (url-wais-anytostring dist-id))
+	    copyright title score)))
+
+(defun url-grok-wais-href (url)
+  "Return a list of server, port, database, search-term, doc-id"
+  (if (string-match "wais:/+\\([^/:]+\\):*\\([^/]*\\)/+\\(.*\\)" url)
+      (let ((host (url-match url 1))
+	    (port (url-match url 2))
+	    (data (url-match url 3)))
+	(list host port data))
+    (make-list 3 nil)))
+
+(defun url-wais (url)
+  ;; Retrieve a document via WAIS
+  (if (and url-wais-gateway-server url-wais-gateway-port)
+      (url-retrieve
+       (format "http://%s:%s/%s"
+	       url-wais-gateway-server
+	       url-wais-gateway-port
+	       (substring url (match-end 0) nil)))
+    (let ((href (url-grok-wais-href url)))
+      (url-clear-tmp-buffer)
+      (setq url-current-type "wais"
+	    url-current-server (nth 0 href)
+	    url-current-port (nth 1 href)
+	    url-current-file (nth 2 href))
+      (cond
+       ((string-match "2=\\(.*\\);3=\\([^ ;]+\\)" (nth 2 href)); full link
+	(url-retrieve-wais-docid (nth 0 href) (nth 1 href)
+				(url-match (nth 2 href) 1)
+				(url-match (nth 2 href) 2)))
+       ((string-match "\\([^\\?]+\\)\\?\\(.*\\)" (nth 2 href)) ; stored query
+	(url-perform-wais-query (nth 0 href) (nth 1 href)
+			       (url-match (nth 2 href) 1)
+			       (url-match (nth 2 href) 2)))
+       (t
+	(insert "WAIS search\n"
+		"
    WAIS search of " (nth 2 href) "
    "
+		"
    \n"
+		(format "
    \n" url)
+		"Enter search term: \n"
+		"
    \n"
+		"
    \n"))))))
+
+(provide 'url-wais)
+
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/url.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/url.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,2496 @@
+;;; url.el --- Uniform Resource Locator retrieval tool
+;; Author: wmperry
+;; Created: 1996/12/19 21:53:03
+;; Version: 1.40
+;; Keywords: comm, data, processes, hypermedia
+
+;;; LCD Archive Entry:
+;;; url|William M. Perry|wmperry@cs.indiana.edu|
+;;; Major mode for manipulating URLs|
+;;; 1996/12/19 21:53:03|1.40|Location Undetermined
+;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(require 'cl)
+(require 'url-vars)
+(require 'url-parse)
+(require 'urlauth)
+(require 'url-cookie)
+(require 'mm)
+(require 'md5)
+(require 'base64)
+(require 'mule-sysdp)
+(or (featurep 'efs)
+    (featurep 'efs-auto)
+    (condition-case ()
+	(require 'ange-ftp)
+      (error nil)))
+
+(require 'w3-sysdp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Functions that might not exist in old versions of emacs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-save-error (errobj)
+  (save-excursion
+    (set-buffer (get-buffer-create " *url-error*"))
+    (erase-buffer))
+  (display-error errobj (get-buffer-create " *url-error*")))
+
+(cond
+ ((fboundp 'display-warning)
+  (fset 'url-warn 'display-warning))
+ ((fboundp 'w3-warn)
+  (fset 'url-warn 'w3-warn))
+ ((fboundp 'warn)
+  (defun url-warn (class message &optional level)
+    (warn "(%s/%s) %s" class (or level 'warning) message)))
+ (t
+  (defun url-warn (class message &optional level)
+    (save-excursion
+      (set-buffer (get-buffer-create "*W3-WARNINGS*"))
+      (goto-char (point-max))
+      (save-excursion
+	(insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
+      (display-buffer (current-buffer))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Autoload all the URL loaders
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(autoload 'url-file "url-file")
+(autoload 'url-ftp "url-file")
+(autoload 'url-gopher "url-gopher")
+(autoload 'url-irc "url-irc")
+(autoload 'url-http "url-http")
+(autoload 'url-nfs "url-nfs")
+(autoload 'url-mailserver "url-mail")
+(autoload 'url-mailto "url-mail")
+(autoload 'url-info "url-misc")
+(autoload 'url-shttp "url-http")
+(autoload 'url-https "url-http")
+(autoload 'url-finger "url-misc")
+(autoload 'url-rlogin "url-misc")
+(autoload 'url-telnet "url-misc")
+(autoload 'url-tn3270 "url-misc")
+(autoload 'url-proxy "url-misc")
+(autoload 'url-x-exec "url-misc")
+(autoload 'url-news "url-news")
+(autoload 'url-nntp "url-news")
+(autoload 'url-decode-pgp/pem "url-pgp")
+(autoload 'url-wais "url-wais")
+
+(autoload 'url-save-newsrc "url-news")
+(autoload 'url-news-generate-reply-form "url-news")
+(autoload 'url-parse-newsrc "url-news")
+(autoload 'url-mime-response-p "url-http")
+(autoload 'url-parse-mime-headers "url-http")
+(autoload 'url-handle-refresh-header "url-http")
+(autoload 'url-create-mime-request "url-http")
+(autoload 'url-create-message-id "url-http")
+(autoload 'url-create-multipart-request "url-http")
+(autoload 'url-parse-viewer-types "url-http")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File-name-handler-alist functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-setup-file-name-handlers ()
+  ;; Setup file-name handlers.
+  '(cond
+    ((not (boundp 'file-name-handler-alist))
+     nil)				; Don't load if no alist
+    ((rassq 'url-file-handler file-name-handler-alist)
+     nil)				; Don't load twice
+    ((and (string-match "XEmacs\\|Lucid" emacs-version)
+	  (< url-emacs-minor-version 11)) ; Don't load in lemacs 19.10
+     nil)
+    (t
+     (setq file-name-handler-alist
+	   (let ((new-handler (cons
+			       (concat "^/*"
+				       (substring url-nonrelative-link1 nil))
+			       'url-file-handler)))
+	     (if file-name-handler-alist
+		 (append (list new-handler) file-name-handler-alist)
+	       (list new-handler)))))))
+  
+(defun url-file-handler (operation &rest args)
+  ;; Function called from the file-name-handler-alist routines.  OPERATION
+  ;; is what needs to be done ('file-exists-p, etc).  args are the arguments
+  ;; that would have been passed to OPERATION."
+  (let ((fn (get operation 'url-file-handlers))
+	(url (car args))
+	(myargs (cdr args)))
+    (if (= (string-to-char url) ?/)
+	(setq url (substring url 1 nil)))
+    (if fn (apply fn url myargs)
+      (let (file-name-handler-alist)
+	(apply operation url myargs)))))
+
+(defun url-file-handler-identity (&rest args)
+  (car args))
+
+(defun url-file-handler-null (&rest args)
+  nil)
+
+(put 'file-directory-p 'url-file-handlers 'url-file-handler-null)
+(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
+(put 'file-writable-p 'url-file-handlers 'url-file-handler-null)
+(put 'file-truename 'url-file-handlers 'url-file-handler-identity)
+(put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents)
+(put 'expand-file-name 'url-file-handlers 'url-expand-file-name)
+(put 'directory-files 'url-file-handlers 'url-directory-files)
+(put 'file-directory-p 'url-file-handlers 'url-file-directory-p)
+(put 'file-writable-p 'url-file-handlers 'url-file-writable-p)
+(put 'file-readable-p 'url-file-handlers 'url-file-exists)
+(put 'file-executable-p 'url-file-handlers 'null)
+(put 'file-symlink-p 'url-file-handlers 'null)
+(put 'file-exists-p 'url-file-handlers 'url-file-exists)
+(put 'copy-file 'url-file-handlers 'url-copy-file)
+(put 'file-attributes 'url-file-handlers 'url-file-attributes)
+(put 'file-name-all-completions 'url-file-handlers
+     'url-file-name-all-completions)
+(put 'file-name-completion 'url-file-handlers 'url-file-name-completion)
+(put 'file-local-copy 'url-file-handlers 'url-file-local-copy)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Utility functions
+;;; -----------------
+;;; Various functions used around the url code.
+;;; Some of these qualify as hacks, but hey, this is elisp.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(if (fboundp 'mm-string-to-tokens)
+    (fset 'url-string-to-tokens 'mm-string-to-tokens)
+  (defun url-string-to-tokens (str &optional delim)
+    "Return a list of words from the string STR"
+    (setq delim (or delim ? ))
+    (let (results y)
+      (mapcar
+       (function
+	(lambda (x)
+	  (cond
+	   ((and (= x delim) y) (setq results (cons y results) y nil))
+	   ((/= x delim) (setq y (concat y (char-to-string x))))
+	   (t nil)))) str)
+      (nreverse (cons y results)))))
+
+(defun url-days-between (date1 date2)
+  ;; Return the number of days between date1 and date2.
+  (- (url-day-number date1) (url-day-number date2)))
+
+(defun url-day-number (date)
+  (let ((dat (mapcar (function (lambda (s) (and s (string-to-int s)) ))
+		     (timezone-parse-date date))))
+    (timezone-absolute-from-gregorian 
+     (nth 1 dat) (nth 2 dat) (car dat))))
+
+(defun url-seconds-since-epoch (date)
+  ;; Returns a number that says how many seconds have
+  ;; lapsed between Jan 1 12:00:00 1970 and DATE."
+  (let* ((tdate (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
+			(timezone-parse-date date)))
+	 (ttime (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
+			(timezone-parse-time
+			 (aref (timezone-parse-date date) 3))))
+	 (edate (mapcar (function (lambda (ti) (and ti (string-to-int ti))))
+			(timezone-parse-date "Jan 1 12:00:00 1970")))
+	 (tday (- (timezone-absolute-from-gregorian 
+		   (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
+		  (timezone-absolute-from-gregorian 
+		   (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
+    (+ (nth 2 ttime)
+       (* (nth 1 ttime) 60)
+       (* (nth 0 ttime) 60 60)
+       (* tday 60 60 24))))
+
+(defun url-match (s x)
+  ;; Return regexp match x in s.
+  (substring s (match-beginning x) (match-end x)))
+
+(defun url-split (str del)
+  ;; Split the string STR, with DEL (a regular expression) as the delimiter.
+  ;; Returns an assoc list that you can use with completing-read."
+  (let (x y)
+    (while (string-match del str)
+      (setq y (substring str 0 (match-beginning 0))
+	    str (substring str (match-end 0) nil))
+      (if (not (string-match "^[ \t]+$" y))
+	  (setq x (cons (list y y) x))))
+    (if (not (equal str ""))
+	(setq x (cons (list str str) x)))
+    x))
+
+(defun url-replace-regexp (regexp to-string)
+  (goto-char (point-min))
+  (while (re-search-forward regexp nil t)
+    (replace-match to-string t nil)))
+
+(defun url-clear-tmp-buffer ()
+  (set-buffer (get-buffer-create url-working-buffer))
+  (if buffer-read-only (toggle-read-only))
+  (erase-buffer))  
+
+(defun url-maybe-relative (url)
+  (url-retrieve (url-expand-file-name url)))
+
+(defun url-buffer-is-hypertext (&optional buff)
+  "Return t if a buffer contains HTML, as near as we can guess."
+  (setq buff (or buff (current-buffer)))
+  (save-excursion
+    (set-buffer buff)
+    (let ((case-fold-search t))
+      (goto-char (point-min))
+      (re-search-forward
+       "<\\(TITLE\\|HEAD\\|BASE\\|H[0-9]\\|ISINDEX\\|P\\)>" nil t))))
+
+(defun url-percentage (x y)
+  (if (fboundp 'float)
+      (round (* 100 (/ x (float y))))
+    (/ (* x 100) y)))
+
+(defun url-after-change-function (&rest args)
+  ;; The nitty gritty details of messaging the HTTP/1.0 status messages
+  ;; in the minibuffer."
+  (or url-current-content-length
+      (save-excursion
+	(goto-char (point-min))
+	(skip-chars-forward " \t\n")
+	(if (not (looking-at "HTTP/[0-9]\.[0-9]"))
+	    (setq url-current-content-length 0)
+	  (setq url-current-isindex
+		(and (re-search-forward "$\r*$" nil t) (point)))
+	  (if (re-search-forward
+	       "^content-type:[ \t]*\\([^\r\n]+\\)\r*$"
+	       url-current-isindex t)
+	      (setq url-current-mime-type (downcase
+					   (url-eat-trailing-space
+					    (buffer-substring
+					     (match-beginning 1)
+					     (match-end 1))))))
+	  (goto-char (point-min))
+	  (if (re-search-forward "^content-length:\\([^\r\n]+\\)\r*$"
+				 url-current-isindex t)
+	      (setq url-current-content-length
+		    (string-to-int (buffer-substring (match-beginning 1)
+						     (match-end 1))))
+	    (setq url-current-content-length nil))))
+      )
+  (let ((current-length (max (point-max)
+			     (if url-current-isindex
+				 (- (point-max) url-current-isindex)
+			       (point-max)))))
+    (cond
+     ((and url-current-content-length (> url-current-content-length 1)
+	   url-current-mime-type)
+      (url-lazy-message "Reading [%s]... %d of %d bytes (%d%%)"
+			url-current-mime-type
+			current-length
+			url-current-content-length
+			(url-percentage current-length
+					url-current-content-length)))
+     ((and url-current-content-length (> url-current-content-length 1))
+      (url-lazy-message "Reading... %d of %d bytes (%d%%)"
+			current-length url-current-content-length
+			(url-percentage current-length
+					url-current-content-length)))
+     ((and (/= 1 current-length) url-current-mime-type)
+      (url-lazy-message "Reading [%s]... %d bytes"
+			url-current-mime-type current-length))
+     ((/= 1 current-length)
+      (url-lazy-message "Reading... %d bytes." current-length))
+     (t (url-lazy-message "Waiting for response...")))))
+
+(defun url-insert-entities-in-string (string)
+  "Convert HTML markup-start characters to entity references in STRING.
+  Also replaces the \" character, so that the result may be safely used as
+  an attribute value in a tag.  Returns a new string with the result of the
+  conversion.  Replaces these characters as follows:
+    &  ==>  &
+    <  ==>  <
+    >  ==>  >
+    \"  ==>  ""
+  (if (string-match "[&<>\"]" string)
+      (save-excursion
+	(set-buffer (get-buffer-create " *entity*"))
+	(erase-buffer)
+	(buffer-disable-undo (current-buffer))
+	(insert string)
+	(goto-char (point-min))
+	(while (progn
+		 (skip-chars-forward "^&<>\"")
+		 (not (eobp)))
+	  (insert (cdr (assq (char-after (point))
+			     '((?\" . """)
+			       (?& . "&")
+			       (?< . "<")
+			       (?> . ">")))))
+	  (delete-char 1))
+	(buffer-string))
+    string))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Information information
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar url-process-lookup-table nil)
+
+(defun url-process-get (proc prop &optional default)
+  "Get a value associated to PROC as property PROP
+         in plist stored in `url-process-lookup-table'"
+  (or (plist-get (cdr-safe (assq proc url-process-lookup-table)) prop)
+      default))
+
+(defun url-process-put (proc prop val)
+  "Associate to PROC as property PROP the value VAL
+         in plist stored in `url-process-lookup-table'"
+  (let ((node (assq proc url-process-lookup-table)))
+    (if (not node)
+	(setq url-process-lookup-table (cons (cons proc (list prop val))
+					     url-process-lookup-table))
+      (setcdr node (plist-put (cdr node) prop val)))))
+
+(defun url-gc-process-lookup-table ()
+  (let (new)
+    (while url-process-lookup-table
+      (if (not (memq (process-status (caar url-process-lookup-table))
+		     '(stop closed nil)))
+	  (setq new (cons (car url-process-lookup-table) new)))
+      (setq url-process-lookup-table (cdr url-process-lookup-table)))
+    (setq url-process-lookup-table new)))
+
+(defun url-process-list ()
+  (url-gc-process-lookup-table)
+  (let ((processes (process-list))
+	(retval nil))
+    (while processes
+      (if (url-process-get (car processes) 'url)
+	  (setq retval (cons (car processes) retval)))
+      (setq processes (cdr processes)))
+    retval))
+    
+(defun url-list-processes ()
+  (interactive)
+  (let ((processes (url-process-list))
+	proc total-len len type url
+	(url-status-buf (get-buffer-create "URL Status Display")))
+    (set-buffer url-status-buf)
+    (erase-buffer)
+    (display-buffer url-status-buf)
+    (insert
+     (eval-when-compile (format "%-40s %-20s %-15s" "URL" "Size" "Type")) "\n"
+     (eval-when-compile (make-string 77 ?-)) "\n")
+    (while processes
+      (setq proc (car processes)
+	    processes (cdr processes))
+      (save-excursion
+	(set-buffer (process-buffer proc))
+	(setq total-len url-current-content-length
+	      len (max (point-max)
+		       (if url-current-isindex
+			   (- (point-max) url-current-isindex)
+			 (point-max)))
+	      type url-current-mime-type
+	      url (url-process-get proc 'url))
+	(set-buffer url-status-buf)
+	(insert
+	 (format "%-40s%s%-20s %-15s\n"
+		 (url-process-get proc 'url)
+		 (if (> (length url) 40)
+		     (format "\n%-40s " " ")
+		   " ")
+		 (if total-len
+		     (format "%d of %d" len total-len)
+		   (format "%d" len))
+		 (or type "unknown")))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; file-name-handler stuff calls this
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun url-have-visited-url (url &rest args)
+  "Return non-nil iff the user has visited URL before.
+The return value is a cons of the url and the date last accessed as a string"
+  (cl-gethash url url-global-history-hash-table))
+
+(defun url-directory-files (url &rest args)
+  "Return a list of files on a server."
+  nil)
+
+(defun url-file-writable-p (url &rest args)
+  "Return t iff a url is writable by this user"
+  nil)
+
+(defun url-copy-file (url &rest args)
+  "Copy a url to the specified filename."
+  nil)
+
+(defun url-file-directly-accessible-p (url)
+  "Returns t iff the specified URL is directly accessible
+on your filesystem.  (nfs, local file, etc)."
+  (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
+	 (type (url-type urlobj)))
+    (and (member type '("file" "ftp"))
+	 (not (url-host urlobj)))))
+
+;;;###autoload
+(defun url-file-attributes (url &rest args)
+  "Return a list of attributes of URL.
+Value is nil if specified file cannot be opened.
+Otherwise, list elements are:
+ 0. t for directory, string (name linked to) for symbolic link, or nil.
+ 1. Number of links to file.
+ 2. File uid.
+ 3. File gid.
+ 4. Last access time, as a list of two integers.
+  First integer has high-order 16 bits of time, second has low 16 bits.
+ 5. Last modification time, likewise.
+ 6. Last status change time, likewise.
+ 7. Size in bytes. (-1, if number is out of range).
+ 8. File modes, as a string of ten letters or dashes as in ls -l.
+    If URL is on an http server, this will return the content-type if possible.
+ 9. t iff file's gid would change if file were deleted and recreated.
+10. inode number.
+11. Device number.
+
+If file does not exist, returns nil."
+  (and url
+       (let* ((urlobj (url-generic-parse-url url))
+	      (type (url-type urlobj))
+	      (url-automatic-caching nil)
+	      (data nil)
+	      (exists nil))
+	 (cond
+	  ((equal type "http")
+	   (cond
+	    ((not url-be-anal-about-file-attributes)
+	     (setq data (list
+			 (url-file-directory-p url) ; Directory
+			 1		; number of links to it
+			 0		; UID
+			 0		; GID
+			 (cons 0 0)	; Last access time
+			 (cons 0 0)	; Last mod. time
+			 (cons 0 0)	; Last status time
+			 -1		; file size
+			 (mm-extension-to-mime
+			  (url-file-extension (url-filename urlobj)))
+			 nil		; gid would change
+			 0		; inode number
+			 0		; device number
+			 )))
+	    (t				; HTTP/1.0, use HEAD
+	     (let ((url-request-method "HEAD")
+		   (url-request-data nil)
+		   (url-working-buffer " *url-temp*"))
+	       (save-excursion
+		 (condition-case ()
+		     (progn
+		       (url-retrieve url)
+		       (setq data (and
+				   (setq exists
+					 (cdr
+					  (assoc "status"
+						 url-current-mime-headers)))
+				   (>= exists 200)
+				   (< exists 300)
+				   (list
+				    (url-file-directory-p url) ; Directory
+				    1	; links to
+				    0	; UID
+				    0	; GID
+				    (cons 0 0) ; Last access time
+				    (cons 0 0) ; Last mod. time
+				    (cons 0 0) ; Last status time
+				    (or ; Size in bytes
+				     (cdr (assoc "content-length"
+						 url-current-mime-headers))
+				     -1)
+				    (or
+				     (cdr (assoc "content-type"
+						 url-current-mime-headers))
+				     (mm-extension-to-mime
+				      (url-file-extension
+				       (url-filename urlobj)))) ; content-type
+				    nil ; gid would change
+				    0	; inode number
+				    0	; device number
+				    ))))
+		   (error nil))
+		 (and (not data)
+		      (setq data (list (url-file-directory-p url)
+				       1 0 0 (cons 0 0) (cons 0 0) (cons 0 0)
+				       -1 (mm-extension-to-mime
+					   (url-file-extension
+					    url-current-file))
+				       nil 0 0)))
+		 (kill-buffer " *url-temp*"))))))
+	  ((member type '("ftp" "file"))
+	   (let ((fname (if (url-host urlobj)
+			    (concat "/"
+				    (if (url-user urlobj)
+					(concat (url-user urlobj) "@")
+				      "")
+				    (url-host urlobj) ":"
+				    (url-filename urlobj))
+			  (url-filename urlobj))))
+	     (setq data (or (file-attributes fname) (make-list 12 nil)))
+	     (setcar (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr data))))))))
+		     (mm-extension-to-mime (url-file-extension fname)))))
+	  (t nil))
+	 data)))
+
+(defun url-file-name-all-completions (file dirname &rest args)
+  "Return a list of all completions of file name FILE in directory DIR.
+These are all file names in directory DIR which begin with FILE."
+  ;; need to rewrite
+  )
+
+(defun url-file-name-completion (file dirname &rest args)
+  "Complete file name FILE in directory DIR.
+Returns the longest string
+common to all filenames in DIR that start with FILE.
+If there is only one and FILE matches it exactly, returns t.
+Returns nil if DIR contains no name starting with FILE."
+  (apply 'url-file-name-all-completions file dirname args))
+
+(defun url-file-local-copy (file &rest args)
+  "Copy the file FILE into a temporary file on this machine.
+Returns the name of the local copy, or nil, if FILE is directly
+accessible."
+  nil)
+
+(defun url-insert-file-contents (url &rest args)
+  "Insert the contents of the URL in this buffer."
+  (interactive "sURL: ")
+  (save-excursion
+    (let ((old-asynch url-be-asynchronous))
+      (setq-default url-be-asynchronous nil)
+      (let ((buf (current-buffer))
+	    (url-working-buffer (cdr (url-retrieve url))))
+	(setq-default url-be-asynchronous old-asynch)
+	(set-buffer buf)
+	(insert-buffer url-working-buffer)
+	(setq buffer-file-name url)
+	(save-excursion
+	  (set-buffer url-working-buffer)
+	  (set-buffer-modified-p nil))
+	(kill-buffer url-working-buffer)))))
+
+(defun url-file-directory-p (url &rest args)
+  "Return t iff a url points to a directory"
+  (equal (substring url -1 nil) "/"))
+
+(defun url-file-exists (url &rest args)
+  "Return t iff a file exists."
+  (let* ((urlobj (url-generic-parse-url url))
+	 (type (url-type urlobj))
+	 (exists nil))
+    (cond
+     ((equal type "http")		; use head
+      (let ((url-request-method "HEAD")
+	    (url-request-data nil)
+	    (url-working-buffer " *url-temp*"))
+	(save-excursion
+	  (url-retrieve url)
+	  (setq exists (or (cdr
+			    (assoc "status" url-current-mime-headers)) 500))
+	  (kill-buffer " *url-temp*")
+	  (setq exists (and (>= exists 200) (< exists 300))))))
+     ((member type '("ftp" "file"))	; file-attributes
+      (let ((fname (if (url-host urlobj)
+		       (concat "/"
+			       (if (url-user urlobj)
+				   (concat (url-user urlobj) "@")
+				 "")
+			       (url-host urlobj) ":"
+			       (url-filename urlobj))
+		     (url-filename urlobj))))
+	(setq exists (file-exists-p fname))))
+     (t nil))
+    exists))
+
+;;;###autoload
+(defun url-normalize-url (url)
+  "Return a 'normalized' version of URL.  This strips out default port
+numbers, etc."
+  (let (type data grok retval)
+    (setq data (url-generic-parse-url url)
+	  type (url-type data))
+    (if (member type '("www" "about" "mailto" "mailserver" "info"))
+	(setq retval url)
+      (setq retval (url-recreate-url data)))
+    retval))
+
+;;;###autoload
+(defun url-buffer-visiting (url)
+  "Return the name of a buffer (if any) that is visiting URL."
+  (setq url (url-normalize-url url))
+  (let ((bufs (buffer-list))
+	(found nil))
+    (if (condition-case ()
+	    (string-match "\\(.*\\)#" url)
+	  (error nil))
+	(setq url (url-match url 1)))
+    (while (and bufs (not found))
+      (save-excursion
+	(set-buffer (car bufs))
+	(setq found (if (and
+			 (not (string-match " \\*URL-?[0-9]*\\*" (buffer-name (car bufs))))
+			 (memq major-mode '(url-mode w3-mode))
+			 (equal (url-view-url t) url)) (car bufs) nil)
+	      bufs (cdr bufs))))
+    found))
+
+(defun url-file-size (url &rest args)
+  "Return the size of a file in bytes, or -1 if can't be determined."
+  (let* ((urlobj (url-generic-parse-url url))
+	 (type (url-type urlobj))
+	 (size -1)
+	 (data nil))
+    (cond
+     ((equal type "http")		; use head
+      (let ((url-request-method "HEAD")
+	    (url-request-data nil)
+	    (url-working-buffer " *url-temp*"))
+	(save-excursion
+	  (url-retrieve url)
+	  (setq size (or (cdr
+			  (assoc "content-length" url-current-mime-headers))
+			 -1))
+	  (kill-buffer " *url-temp*"))))
+     ((member type '("ftp" "file"))	; file-attributes
+      (let ((fname (if (url-host urlobj)
+		       (concat "/"
+			       (if (url-user urlobj)
+				   (concat (url-user urlobj) "@")
+				 "")
+			       (url-host urlobj) ":"
+			       (url-filename urlobj))
+		     (url-filename urlobj))))
+	(setq data (file-attributes fname)
+	      size (nth 7 data))))
+     (t nil))
+    (cond
+     ((stringp size) (string-to-int size))
+     ((integerp size) size)
+     ((null size) -1)
+     (t -1))))
+
+(defun url-generate-new-buffer-name (start)
+  "Create a new buffer name based on START."
+  (let ((x 1)
+	name)
+    (if (not (get-buffer start))
+	start
+      (progn
+	(setq name (format "%s<%d>" start x))
+	(while (get-buffer name)
+	  (setq x (1+ x)
+		name (format "%s<%d>" start x)))
+	name))))
+
+(defun url-generate-unique-filename (&optional fmt)
+  "Generate a unique filename in url-temporary-directory"
+  (if (not fmt)
+      (let ((base (format "url-tmp.%d" (user-real-uid)))
+	    (fname "")
+	    (x 0))
+	(setq fname (format "%s%d" base x))
+	(while (file-exists-p (expand-file-name fname url-temporary-directory))
+	  (setq x (1+ x)
+		fname (concat base (int-to-string x))))
+	(expand-file-name fname url-temporary-directory))
+    (let ((base (concat "url" (int-to-string (user-real-uid))))
+	  (fname "")
+	  (x 0))
+      (setq fname (format fmt (concat base (int-to-string x))))
+      (while (file-exists-p (expand-file-name fname url-temporary-directory))
+	(setq x (1+ x)
+	      fname (format fmt (concat base (int-to-string x)))))
+      (expand-file-name fname url-temporary-directory))))
+
+(defun url-lazy-message (&rest args)
+  "Just like `message', but is a no-op if called more than once a second.
+Will not do anything if url-show-status is nil."
+  (if (or (null url-show-status)
+	  (= url-lazy-message-time
+	     (setq url-lazy-message-time (nth 1 (current-time)))))
+      nil
+    (apply 'message args)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Gateway Support
+;;; ---------------
+;;; Fairly good/complete gateway support
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-kill-process (proc)
+  "Kill the process PROC - knows about all the various gateway types,
+and acts accordingly."
+  (cond
+   ((eq url-gateway-method 'native) (delete-process proc))
+   ((eq url-gateway-method 'program) (kill-process proc))
+   (t (error "Unknown url-gateway-method %s" url-gateway-method))))
+
+(defun url-accept-process-output (proc)
+  "Allow any pending output from subprocesses to be read by Emacs.
+It is read into the process' buffers or given to their filter functions.
+Where possible, this will not exit until some output is received from PROC,
+or 1 second has elapsed."
+  (accept-process-output proc 1))
+
+(defun url-process-status (proc)
+  "Return the process status of a url buffer"
+  (cond
+   ((memq url-gateway-method '(native ssl program)) (process-status proc))
+   (t (error "Unkown url-gateway-method %s" url-gateway-method))))  
+
+(defun url-open-stream (name buffer host service)
+  "Open a stream to a host"
+  (let ((tmp-gateway-method (if (and url-gateway-local-host-regexp
+				     (not (eq 'ssl url-gateway-method))
+				     (string-match
+				      url-gateway-local-host-regexp
+				      host))
+				'native
+			      url-gateway-method))
+	(tcp-binary-process-output-services (if (stringp service)
+						(list service)
+					      (list service
+						    (int-to-string service)))))
+    (and (eq url-gateway-method 'tcp)
+	 (require 'tcp)
+	 (setq url-gateway-method 'native
+	       tmp-gateway-method 'native))
+    (cond
+     ((eq tmp-gateway-method 'ssl)
+      (open-ssl-stream name buffer host service))
+     ((eq tmp-gateway-method 'native)
+      (if url-broken-resolution
+	  (setq host
+		(cond
+		 ((featurep 'ange-ftp) (ange-ftp-nslookup-host host))
+		 ((featurep 'efs) (efs-nslookup-host host))
+		 ((featurep 'efs-auto) (efs-nslookup-host host))
+		 (t host))))
+      (let ((max-retries url-connection-retries)
+	    (cur-retries 0)
+	    (retry t)
+	    (errobj nil)
+	    (conn nil))
+	(while (and (not conn) retry)
+	  (condition-case errobj
+	      (setq conn (open-network-stream name buffer host service))
+	    (error
+	     (url-save-error errobj)
+	     (save-window-excursion
+	       (save-excursion
+		 (switch-to-buffer-other-window " *url-error*")
+		 (shrink-window-if-larger-than-buffer)
+		 (goto-char (point-min))
+		 (if (and (re-search-forward "in use" nil t)
+			  (< cur-retries max-retries))
+		     (progn
+		       (setq retry t
+			     cur-retries (1+ cur-retries))
+		       (sleep-for 0.5))
+		   (setq cur-retries 0
+			 retry (funcall url-confirmation-func
+					(concat "Connection to " host
+						" failed, retry? "))))
+		 (kill-buffer (current-buffer)))))))
+	(if (not conn)
+	    (error "Unable to connect to %s:%s" host service)
+	  (mule-inhibit-code-conversion conn)
+	  conn)))
+     ((eq tmp-gateway-method 'program)
+      (let ((proc (start-process name buffer url-gateway-telnet-program host
+				 (int-to-string service)))
+	    (tmp nil))
+	(save-excursion
+	  (set-buffer buffer)
+	  (setq tmp (point))
+	  (while (not (progn
+			(goto-char (point-min))
+			(re-search-forward 
+			 url-gateway-telnet-ready-regexp nil t)))
+	    (url-accept-process-output proc))
+	  (delete-region tmp (point))
+	  (goto-char (point-min))
+	  (if (re-search-forward "connect:" nil t)
+	      (progn
+		(condition-case ()
+		    (delete-process proc)
+		  (error nil))
+		(url-replace-regexp ".*connect:.*" "")
+		nil)
+	    proc))))
+     (t (error "Unknown url-gateway-method %s" url-gateway-method)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Miscellaneous functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-setup-privacy-info ()
+  (interactive)
+  (setq url-system-type
+	(cond
+	 ((or (eq url-privacy-level 'paranoid)
+	      (and (listp url-privacy-level)
+		   (memq 'os url-privacy-level)))
+	  nil)
+	 ((eq system-type 'Apple-Macintosh) "Macintosh")
+	 ((eq system-type 'next-mach) "NeXT")
+	 ((eq system-type 'windows-nt) "Windows-NT; 32bit")
+	 ((eq system-type 'ms-windows) "Windows; 16bit")
+	 ((eq system-type 'ms-dos) "MS-DOS; 32bit")
+	 ((and (eq system-type 'vax-vms) (device-type))
+	  "VMS; X11")
+	 ((eq system-type 'vax-vms) "VMS; TTY")
+	 ((eq (device-type) 'x) "X11")
+	 ((eq (device-type) 'ns) "NeXTStep")
+	 ((eq (device-type) 'pm) "OS/2")
+	 ((eq (device-type) 'win32) "Windows; 32bit")
+	 ((eq (device-type) 'tty) "(Unix?); TTY")
+	 (t "UnkownPlatform")))
+
+  ;; Set up the entity definition for PGP and PEM authentication
+  (setq url-pgp/pem-entity (or url-pgp/pem-entity
+			       user-mail-address
+			       (format "%s@%s"  (user-real-login-name)
+				       (system-name))))
+  
+  (setq url-personal-mail-address (or url-personal-mail-address
+				      url-pgp/pem-entity
+				      user-mail-address))
+
+  (if (or (memq url-privacy-level '(paranoid high))
+	  (and (listp url-privacy-level)
+	       (memq 'email url-privacy-level)))
+      (setq url-personal-mail-address nil))
+
+  (if (or (eq url-privacy-level 'paranoid)
+	  (and (listp url-privacy-level)
+	       (memq 'os url-privacy-level)))
+      (setq url-os-type nil)
+    (let ((vers (emacs-version)))
+      (if (string-match "(\\([^, )]+\\))$" vers)
+	  (setq url-os-type (url-match vers 1))
+	(setq url-os-type (symbol-name system-type))))))
+
+(defun url-handle-no-scheme (url)
+  (let ((temp url-registered-protocols)
+	(found nil))
+    (while (and temp (not found))
+      (if (and (not (member (car (car temp)) '("auto" "www")))
+	       (string-match (concat "^" (car (car temp)) "\\.")
+					url))
+	  (setq found t)
+	(setq temp (cdr temp))))
+    (cond
+     (found				; Found something like ftp.spry.com
+      (url-retrieve (concat (car (car temp)) "://" url)))
+     ((string-match "^www\\." url)
+      (url-retrieve (concat "http://" url)))
+     ((string-match "\\(\\.[^\\.]+\\)\\(\\.[^\\.]+\\)" url)
+      ;; Ok, we have at least two dots in the filename, just stick http on it
+      (url-retrieve (concat "http://" url)))
+     (t
+      (url-retrieve (concat "http://www." url ".com"))))))
+
+(defun url-setup-save-timer ()
+  "Reset the history list timer."
+  (interactive)
+  (cond
+   ((featurep 'itimer)
+    (if (get-itimer "url-history-saver")
+	(delete-itimer (get-itimer "url-history-saver")))
+    (start-itimer "url-history-saver" 'url-write-global-history
+		  url-global-history-save-interval
+		  url-global-history-save-interval))
+   ((fboundp 'run-at-time)
+    (run-at-time url-global-history-save-interval
+		 url-global-history-save-interval
+		 'url-write-global-history))
+   (t nil)))
+
+(defvar url-download-minor-mode nil)
+
+(defun url-download-minor-mode (on)
+  (setq url-download-minor-mode (if on
+				   (1+ (or url-download-minor-mode 0))
+				 (1- (or url-download-minor-mode 1))))
+  (if (<= url-download-minor-mode 0)
+      (setq url-download-minor-mode nil)))
+
+(defun url-do-setup ()
+  "Do setup - this is to avoid conflict with user settings when URL is
+dumped with emacs."
+  (if url-setup-done
+      nil
+
+    (add-minor-mode 'url-download-minor-mode " Webbing" nil)
+    
+    ;; Make OS/2 happy
+    (setq tcp-binary-process-input-services
+	  (append '("http" "80")
+		  tcp-binary-process-input-services))
+    
+    ;; Register all the protocols we can handle
+    (url-register-protocol 'file)
+    (url-register-protocol 'ftp        nil nil "21")
+    (url-register-protocol 'gopher     nil nil "70")
+    (url-register-protocol 'http       nil nil "80")
+    (url-register-protocol 'https      nil nil "443")
+    (url-register-protocol 'nfs        nil nil "2049")
+    (url-register-protocol 'info       nil 'url-identity-expander)
+    (url-register-protocol 'mailserver nil 'url-identity-expander)
+    (url-register-protocol 'finger     nil 'url-identity-expander "79")
+    (url-register-protocol 'mailto     nil 'url-identity-expander)
+    (url-register-protocol 'news       nil 'url-identity-expander "119")
+    (url-register-protocol 'nntp       nil 'url-identity-expander "119")
+    (url-register-protocol 'irc        nil 'url-identity-expander "6667")
+    (url-register-protocol 'rlogin)
+    (url-register-protocol 'shttp      nil nil "80")
+    (url-register-protocol 'telnet)
+    (url-register-protocol 'tn3270)
+    (url-register-protocol 'wais)
+    (url-register-protocol 'x-exec)
+    (url-register-protocol 'proxy)
+    (url-register-protocol 'auto 'url-handle-no-scheme)
+
+    ;; Register all the authentication schemes we can handle
+    (url-register-auth-scheme "basic" nil 4)
+    (url-register-auth-scheme "digest" nil 7)
+
+    ;; Filename handler stuff for emacsen that support it
+    (url-setup-file-name-handlers)
+
+    (setq url-cookie-file
+	  (or url-cookie-file
+	      (expand-file-name "~/.w3cookies")))
+    
+    (setq url-global-history-file
+	  (or url-global-history-file
+	      (and (memq system-type '(ms-dos ms-windows))
+		   (expand-file-name "~/mosaic.hst"))
+	      (and (memq system-type '(axp-vms vax-vms))
+		   (expand-file-name "~/mosaic.global-history"))
+	      (condition-case ()
+		  (expand-file-name "~/.mosaic-global-history")
+		(error nil))))
+  
+    ;; Parse the global history file if it exists, so that it can be used
+    ;; for URL completion, etc.
+    (if (and url-global-history-file
+	     (file-exists-p url-global-history-file))
+	(url-parse-global-history))
+
+    ;; Setup save timer
+    (and url-global-history-save-interval (url-setup-save-timer))
+
+    (if (and url-cookie-file
+	     (file-exists-p url-cookie-file))
+	(url-cookie-parse-file url-cookie-file))
+    
+    ;; Read in proxy gateways
+    (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
+			(or (getenv "NO_PROXY")
+			    (getenv "no_PROXY")
+			    (getenv "no_proxy")))))
+      (if noproxy
+	  (setq url-proxy-services
+		(cons (cons "no_proxy"
+			    (concat "\\("
+				    (mapconcat
+				     (function
+				      (lambda (x)
+					(cond
+					 ((= x ?,) "\\|")
+					 ((= x ? ) "")
+					 ((= x ?.) (regexp-quote "."))
+					 ((= x ?*) ".*")
+					 ((= x ??) ".")
+					 (t (char-to-string x)))))
+				     noproxy "") "\\)"))
+		      url-proxy-services))))
+
+    ;; Set the url-use-transparent with decent defaults
+    (if (not (eq (device-type) 'tty))
+	(setq url-use-transparent nil))
+    (and url-use-transparent (require 'transparent))
+  
+    ;; Set the password entry funtion based on user defaults or guess
+    ;; based on which remote-file-access package they are using.
+    (cond
+     (url-passwd-entry-func nil)	; Already been set
+     ((boundp 'read-passwd)		; Use secure password if available
+      (setq url-passwd-entry-func 'read-passwd))
+     ((or (featurep 'efs)		; Using EFS
+	  (featurep 'efs-auto))		; or autoloading efs
+      (if (not (fboundp 'read-passwd))
+	  (autoload 'read-passwd "passwd" "Read in a password" nil))
+      (setq url-passwd-entry-func 'read-passwd))
+     ((or (featurep 'ange-ftp)		; Using ange-ftp
+	  (and (boundp 'file-name-handler-alist)
+	       (not (string-match "Lucid" (emacs-version)))))
+      (setq url-passwd-entry-func 'ange-ftp-read-passwd))
+     (t
+      (url-warn 'security
+		"Can't determine how to read passwords, winging it.")))
+  
+    ;; Set up the news service if they haven't done so
+    (setq url-news-server
+	  (cond
+	   (url-news-server url-news-server)
+	   ((and (boundp 'gnus-default-nntp-server)
+		 (not (equal "" gnus-default-nntp-server)))
+	    gnus-default-nntp-server)
+	   ((and (boundp 'gnus-nntp-server)
+		 (not (null gnus-nntp-server))
+		 (not (equal "" gnus-nntp-server)))
+	    gnus-nntp-server)
+	   ((and (boundp 'nntp-server-name)
+		 (not (null nntp-server-name))
+		 (not (equal "" nntp-server-name)))
+	    nntp-server-name)
+	   ((getenv "NNTPSERVER") (getenv "NNTPSERVER"))
+	   (t "news")))
+  
+    ;; Set up the MIME accept string if they haven't got it hardcoded yet
+    (or url-mime-accept-string
+	(setq url-mime-accept-string (url-parse-viewer-types)))
+    (or url-mime-encoding-string
+	(setq url-mime-encoding-string
+	      (mapconcat 'car
+			 mm-content-transfer-encodings
+			 ", ")))
+  
+    (url-setup-privacy-info)
+    (run-hooks 'url-load-hook)
+    (setq url-setup-done t)))
+
+(defun url-cache-file-writable-p (file)
+  "Follows the documentation of file-writable-p, unlike file-writable-p."
+  (and (file-writable-p file)
+       (if (file-exists-p file)
+           (not (file-directory-p file))
+         (file-directory-p (file-name-directory file)))))
+                
+(defun url-prepare-cache-for-file (file)
+  "Makes it possible to cache data in FILE.
+Creates any necessary parent directories, deleting any non-directory files
+that would stop this.  Returns nil if parent directories can not be
+created.  If FILE already exists as a non-directory, it changes
+permissions of FILE or deletes FILE to make it possible to write a new
+version of FILE.  Returns nil if this can not be done.  Returns nil if
+FILE already exists as a directory.  Otherwise, returns t, indicating that
+FILE can be created or overwritten."
+
+  ;; COMMENT: We don't delete directories because that requires
+  ;; recursively deleting the directories's contents, which might
+  ;; eliminate a substantial portion of the cache.
+
+  (cond
+   ((url-cache-file-writable-p file)
+    t)
+   ((file-directory-p file)
+    nil)
+   (t
+    (catch 'upcff-tag
+      (let ((dir (file-name-directory file))
+            dir-parent dir-last-component)
+        (if (string-equal dir file)
+            ;; *** Should I have a warning here?
+            ;; FILE must match a pattern like /foo/bar/, indicating it is a
+            ;; name only suitable for a directory.  So presume we won't be
+            ;; able to overwrite FILE and return nil.
+            (throw 'upcff-tag nil))
+        
+        ;; Make sure the containing directory exists, or throw a failure
+        ;; if we can't create it.
+        (if (file-directory-p dir)
+            nil
+          (or (fboundp 'make-directory)
+              (throw 'upcff-tag nil))
+          (make-directory dir t)
+          ;; make-directory silently fails if there is an obstacle, so
+          ;; we must verify its results.
+          (if (file-directory-p dir)
+              nil
+            ;; Look at prefixes of the path to find the obstacle that is
+            ;; stopping us from making the directory.  Unfortunately, there
+            ;; is no portable function in Emacs to find the parent directory
+            ;; of a *directory*.  So this code may not work on VMS.
+            (while (progn
+                     (if (eq ?/ (aref dir (1- (length dir))))
+                         (setq dir (substring dir 0 -1))
+                       ;; Maybe we're on VMS where the syntax is different.
+                       (throw 'upcff-tag nil))
+                     (setq dir-parent (file-name-directory dir))
+                     (not (file-directory-p dir-parent)))
+              (setq dir dir-parent))
+            ;; We have found the longest path prefix that exists as a
+            ;; directory.  Deal with any obstacles in this directory.
+            (if (file-exists-p dir)
+                (condition-case nil
+                    (delete-file dir)
+                  (error (throw 'upcff-tag nil))))
+            (if (file-exists-p dir)
+                (throw 'upcff-tag nil))
+            ;; Try making the directory again.
+            (setq dir (file-name-directory file))
+            (make-directory dir t)
+            (or (file-directory-p dir)
+                (throw 'upcff-tag nil))))
+
+        ;; The containing directory exists.  Let's see if there is
+        ;; something in the way in this directory.
+        (if (url-cache-file-writable-p file)
+            (throw 'upcff-tag t)
+          (condition-case nil
+              (delete-file file)
+            (error (throw 'upcff-tag nil))))
+
+        ;; The return value, if we get this far.
+        (url-cache-file-writable-p file))))))
+       
+(defun url-store-in-cache (&optional buff)
+  "Store buffer BUFF in the cache"
+  (if (or (not (get-buffer buff))
+	  (member url-current-type '("www" "about" "https" "shttp"
+					 "news" "mailto"))
+	  (and (member url-current-type '("file" "ftp" nil))
+	       (not url-current-server))
+	  )
+      nil
+    (save-excursion
+      (and buff (set-buffer buff))
+      (let* ((fname (url-create-cached-filename (url-view-url t)))
+             (fname-hdr (concat (if (memq system-type '(ms-windows ms-dos os2))
+                                    (url-file-extension fname t)
+                                  fname) ".hdr"))
+	     (info (mapcar (function (lambda (var)
+				       (cons (symbol-name var)
+					     (symbol-value var))))
+			   '( url-current-content-length
+			      url-current-file
+			      url-current-isindex
+			      url-current-mime-encoding
+			      url-current-mime-headers
+			      url-current-mime-type
+			      url-current-port
+			      url-current-server
+			      url-current-type
+			      url-current-user
+			      ))))
+	(cond ((and (url-prepare-cache-for-file fname)
+		    (url-prepare-cache-for-file fname-hdr))
+	       (write-region (point-min) (point-max) fname nil 5)
+	       (set-buffer (get-buffer-create " *cache-tmp*"))
+	       (erase-buffer)
+	       (insert "(setq ")
+	       (mapcar
+		(function
+		 (lambda (x)
+		   (insert (car x) " "
+			   (cond ((null (setq x (cdr x))) "nil")
+				 ((stringp x) (prin1-to-string x))
+				 ((listp x) (concat "'" (prin1-to-string x)))
+				 ((numberp x) (int-to-string x))
+				 (t "'???")) "\n")))
+		info)
+	       (insert ")\n")
+	       (write-region (point-min) (point-max) fname-hdr nil 5)))))))
+	
+	     
+(defun url-is-cached (url)
+  "Return non-nil if the URL is cached."
+  (let* ((fname (url-create-cached-filename url))
+	 (attribs (file-attributes fname)))
+    (and fname				; got a filename
+	 (file-exists-p fname)		; file exists
+	 (not (eq (nth 0 attribs) t))	; Its not a directory
+	 (nth 5 attribs))))		; Can get last mod-time
+    
+(defun url-create-cached-filename-using-md5 (url)
+  (if url
+      (expand-file-name (md5 url)
+			(concat url-temporary-directory "/"
+				(user-real-login-name)))))
+
+(defun url-create-cached-filename (url)
+  "Return a filename in the local cache for URL"
+  (if url
+      (let* ((url url)
+	     (urlobj (if (vectorp url)
+			 url
+		       (url-generic-parse-url url)))
+	     (protocol (url-type urlobj))
+	     (hostname (url-host urlobj))
+	     (host-components
+	      (cons
+	       (user-real-login-name)
+	       (cons (or protocol "file")
+		     (nreverse
+		      (delq nil
+			    (mm-string-to-tokens
+			     (or hostname "localhost") ?.))))))
+	     (fname    (url-filename urlobj)))
+	(if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
+	    (setq fname (substring fname 1 nil)))
+	(if fname
+	    (let ((slash nil))
+	      (setq fname
+		    (mapconcat
+		     (function
+		      (lambda (x)
+			(cond
+			 ((and (= ?/ x) slash)
+			  (setq slash nil)
+			  "%2F")
+			 ((= ?/ x)
+			  (setq slash t)
+			  "/")
+			 (t
+			  (setq slash nil)
+			  (char-to-string x))))) fname ""))))
+
+	(if (and fname (memq system-type '(ms-windows ms-dos windows-nt))
+		 (string-match "\\([A-Za-z]\\):[/\\]" fname))
+	    (setq fname (concat (url-match fname 1) "/"
+				(substring fname (match-end 0)))))
+	
+	(setq fname (and fname
+			 (mapconcat
+			  (function (lambda (x)
+				      (if (= x ?~) "" (char-to-string x))))
+			  fname ""))
+	      fname (cond
+		     ((null fname) nil)
+		     ((or (string= "" fname) (string= "/" fname))
+		      url-directory-index-file)
+		     ((= (string-to-char fname) ?/)
+		      (if (string= (substring fname -1 nil) "/")
+			  (concat fname url-directory-index-file)
+			(substring fname 1 nil)))
+		     (t
+		      (if (string= (substring fname -1 nil) "/")
+			  (concat fname url-directory-index-file)
+			fname))))
+
+	;; Honor hideous 8.3 filename limitations on dos and windows
+	;; we don't have to worry about this in Windows NT/95 (or OS/2?)
+	(if (and fname (memq system-type '(ms-windows ms-dos)))
+	    (let ((base (url-file-extension fname t))
+		  (ext  (url-file-extension fname nil)))
+	      (setq fname (concat (substring base 0 (min 8 (length base)))
+				  (substring ext  0 (min 4 (length ext)))))
+	      (setq host-components
+		    (mapcar
+		     (function
+		      (lambda (x)
+			(if (> (length x) 8)
+			    (concat 
+			     (substring x 0 8) "."
+			     (substring x 8 (min (length x) 11)))
+			  x)))
+		     host-components))))
+
+	(and fname
+	     (expand-file-name fname
+			       (expand-file-name
+				(mapconcat 'identity host-components "/")
+				url-temporary-directory))))))
+
+(defun url-extract-from-cache (fnam)
+  "Extract FNAM from the local disk cache"
+  (set-buffer (get-buffer-create url-working-buffer))
+  (erase-buffer)
+  (setq url-current-mime-viewer nil)
+  (insert-file-contents-literally fnam)
+  (load (concat (if (memq system-type '(ms-windows ms-dos os2))
+		    (url-file-extension fnam t)
+		  fnam) ".hdr") t t)) 
+
+;;;###autoload
+(defun url-get-url-at-point (&optional pt)
+  "Get the URL closest to point, but don't change your
+position. Has a preference for looking backward when not
+directly on a symbol."
+  ;; Not at all perfect - point must be right in the name.
+  (save-excursion
+    (if pt (goto-char pt))
+    (let ((filename-chars "%.?@a-zA-Z0-9---()_/:~=&") start url)
+      (save-excursion
+	;; first see if you're just past a filename
+	(if (not (eobp))
+	    (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
+		(progn
+		  (skip-chars-backward " \n\t\r({[]})")
+		  (if (not (bobp))
+		      (backward-char 1)))))
+	(if (string-match (concat "[" filename-chars "]")
+			  (char-to-string (following-char)))
+	    (progn
+	      (skip-chars-backward filename-chars)
+	      (setq start (point))
+	      (skip-chars-forward filename-chars))
+	  (setq start (point)))
+	(setq url (if (fboundp 'buffer-substring-no-properties)
+		      (buffer-substring-no-properties start (point))
+		    (buffer-substring start (point)))))
+      (if (string-match "^URL:" url)
+	  (setq url (substring url 4 nil)))
+      (if (string-match "\\.$" url)
+	  (setq url (substring url 0 -1)))
+      (if (not (string-match url-nonrelative-link url))
+	  (setq url nil))
+      url)))
+
+(defun url-eat-trailing-space (x)
+  ;; Remove spaces/tabs at the end of a string
+  (let ((y (1- (length x)))
+	(skip-chars (list ?  ?\t ?\n)))
+    (while (and (>= y 0) (memq (aref x y) skip-chars))
+      (setq y (1- y)))
+    (substring x 0 (1+ y))))
+
+(defun url-strip-leading-spaces (x)
+  ;; Remove spaces at the front of a string
+  (let ((y (1- (length x)))
+	(z 0)
+	(skip-chars (list ?  ?\t ?\n)))
+    (while (and (<= z y) (memq (aref x z) skip-chars))
+      (setq z (1+ z)))
+    (substring x z nil)))
+
+(defun url-convert-newlines-to-spaces (x)
+  "Convert newlines and carriage returns embedded in a string into spaces,
+and swallow following whitespace.
+The argument is not side-effected, but may be returned by this function."
+  (if (string-match "[\n\r]+\\s-*" x)   ; [\\n\\r\\t ]
+      (concat (substring x 0 (match-beginning 0)) " "
+	      (url-convert-newlines-to-spaces
+	       (substring x (match-end 0))))
+    x))
+
+;; Test cases
+;; (url-convert-newlines-to-spaces "foo    bar")  ; nothing happens
+;; (url-convert-newlines-to-spaces "foo\n  \t  bar") ; whitespace converted
+;;
+;; This implementation doesn't mangle the match-data, is fast, and doesn't
+;; create garbage, but it leaves whitespace.
+;; (defun url-convert-newlines-to-spaces (x)
+;;   "Convert newlines and carriage returns embedded in a string into spaces.
+;; The string is side-effected, then returned."
+;;   (let ((i 0)
+;;      (limit (length x)))
+;;     (while (< i limit)
+;;       (if (or (= ?\n (aref x i))
+;;            (= ?\r (aref x i)))
+;;        (aset x i ? ))
+;;       (setq i (1+ i)))
+;;     x))
+
+(defun url-expand-file-name (url &optional default)
+  "Convert URL to a fully specified URL, and canonicalize it.
+Second arg DEFAULT is a URL to start with if URL is relative.
+If DEFAULT is nil or missing, the current buffer's URL is used.
+Path components that are `.' are removed, and 
+path components followed by `..' are removed, along with the `..' itself."
+  (if url
+      (setq url (mapconcat (function (lambda (x)
+				       (if (= x ?\n) "" (char-to-string x))))
+			   (url-strip-leading-spaces
+			    (url-eat-trailing-space url)) "")))
+  (cond
+   ((null url) nil)			; Something hosed!  Be graceful
+   ((string-match "^#" url)		; Offset link, use it raw
+    url)
+   (t
+    (let* ((urlobj (url-generic-parse-url url))
+	   (inhibit-file-name-handlers t)
+	   (defobj (cond
+		    ((vectorp default) default)
+		    (default (url-generic-parse-url default))
+		    (url-current-object url-current-object)
+		    (t (url-generic-parse-url (url-view-url t)))))
+	   (expander (cdr-safe
+		      (cdr-safe
+		       (assoc (or (url-type urlobj)
+				  (url-type defobj))
+			      url-registered-protocols)))))
+      (if (string-match "^//" url)
+	  (setq urlobj (url-generic-parse-url (concat (url-type defobj) ":"
+						      url))))
+      (if (fboundp expander)
+	  (funcall expander urlobj defobj)
+	(message "Unknown URL scheme: %s" (or (url-type urlobj)
+					     (url-type defobj)))
+	(url-identity-expander urlobj defobj))
+      (url-recreate-url urlobj)))))
+
+(defun url-default-expander (urlobj defobj)
+  ;; The default expansion routine - urlobj is modified by side effect!
+  (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))
+  (url-set-port urlobj (or (url-port urlobj)
+			   (and (string= (url-type urlobj)
+					 (url-type defobj))
+				(url-port defobj))))
+  (if (not (string= "file" (url-type urlobj)))
+      (url-set-host urlobj (or (url-host urlobj) (url-host defobj))))
+  (if (string= "ftp"  (url-type urlobj))
+      (url-set-user urlobj (or (url-user urlobj) (url-user defobj))))
+  (if (string= (url-filename urlobj) "")
+      (url-set-filename urlobj "/"))
+  (if (string-match "^/" (url-filename urlobj))
+      nil
+    (url-set-filename urlobj
+		      (url-remove-relative-links
+		       (concat (url-basepath (url-filename defobj))
+			       (url-filename urlobj))))))
+
+(defun url-identity-expander (urlobj defobj)
+  (url-set-type urlobj (or (url-type urlobj) (url-type defobj))))
+
+(defconst url-unreserved-chars
+  '(
+    ?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
+    ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+    ?$ ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\) ?,)
+  "A list of characters that are _NOT_ reserve in the URL spec.
+This is taken from draft-fielding-url-syntax-02.txt - check your local
+internet drafts directory for a copy.")
+       
+(defun url-hexify-string (str)
+  "Escape characters in a string"
+  (mapconcat
+   (function
+    (lambda (char)
+      (if (not (memq char url-unreserved-chars))
+	  (if (< char 16)
+	      (upcase (format "%%0%x" char))
+	    (upcase (format "%%%x" char)))
+	(char-to-string char))))
+   (mule-decode-string str) ""))
+
+(defun url-make-sequence (start end)
+  "Make a sequence (list) of numbers from START to END"
+  (cond
+   ((= start end) '())
+   ((> start end) '())
+   (t
+    (let ((sqnc '()))
+      (while (<= start end)
+	(setq sqnc (cons end sqnc)
+	      end (1- end)))
+      sqnc))))
+ 
+(defun url-file-extension (fname &optional x)
+  "Return the filename extension of FNAME.  If optional variable X is t,
+then return the basename of the file with the extension stripped off."
+  (if (and fname (string-match "\\.[^./]+$" fname))
+      (if x (substring fname 0 (match-beginning 0))
+	(substring fname (match-beginning 0) nil))
+    ;;
+    ;; If fname has no extension, and x then return fname itself instead of 
+    ;; nothing. When caching it allows the correct .hdr file to be produced
+    ;; for filenames without extension.
+    ;;
+    (if x
+ 	fname
+      "")))
+
+(defun url-basepath (file &optional x)
+  "Return the base pathname of FILE, or the actual filename if X is true"
+  (cond
+   ((null file) "")
+   (x (file-name-nondirectory file))
+   (t (file-name-directory file))))
+
+(defun url-parse-query-string (query &optional downcase)
+  (let (retval pairs cur key val)
+    (setq pairs (split-string query "&"))
+    (while pairs
+      (setq cur (car pairs)
+	    pairs (cdr pairs))
+      (if (not (string-match "=" cur))
+	  nil				; Grace
+	(setq key (url-unhex-string (substring cur 0 (match-beginning 0)))
+	      val (url-unhex-string (substring cur (match-end 0) nil)))
+	(if downcase
+	    (setq key (downcase key)))
+	(setq cur (assoc key retval))
+	(if cur
+	    (setcdr cur (cons val (cdr cur)))
+	  (setq retval (cons (list key val) retval)))))
+    retval))
+
+(defun url-unhex (x)
+  (if (> x ?9)
+      (if (>= x ?a)
+	  (+ 10 (- x ?a))
+	(+ 10 (- x ?A)))
+    (- x ?0)))
+
+(defun url-unhex-string (str &optional allow-newlines)
+  "Remove %XXX embedded spaces, etc in a url.
+If optional second argument ALLOW-NEWLINES is non-nil, then allow the
+decoding of carriage returns and line feeds in the string, which is normally
+forbidden in URL encoding."
+  (setq str (or str ""))
+  (let ((tmp "")
+	(case-fold-search t))
+    (while (string-match "%[0-9a-f][0-9a-f]" str)
+      (let* ((start (match-beginning 0))
+	     (ch1 (url-unhex (elt str (+ start 1))))
+	     (code (+ (* 16 ch1)
+		      (url-unhex (elt str (+ start 2))))))
+	(setq tmp (concat 
+		   tmp (substring str 0 start)
+		   (cond
+		    (allow-newlines
+		     (char-to-string code))
+		    ((or (= code ?\n) (= code ?\r))
+		     " ")
+		    (t (char-to-string code))))
+	      str (substring str (match-end 0)))))
+    (setq tmp (concat tmp str))
+    tmp))
+
+(defun url-clean-text ()
+  "Clean up a buffer, removing any excess garbage from a gateway mechanism,
+and decoding any MIME content-transfer-encoding used."
+  (set-buffer url-working-buffer)
+  (goto-char (point-min))
+  (url-replace-regexp "Connection closed by.*" "")
+  (goto-char (point-min))
+  (url-replace-regexp "Process WWW.*" ""))
+
+(defun url-remove-compressed-extensions (filename)
+  (while (assoc (url-file-extension filename) url-uncompressor-alist)
+    (setq filename (url-file-extension filename t)))
+  filename)
+
+(defun url-uncompress ()
+  "Do any necessary uncompression on `url-working-buffer'"
+  (set-buffer url-working-buffer)
+  (if (not url-inhibit-uncompression)
+      (let* ((extn (url-file-extension url-current-file))
+	     (decoder nil)
+	     (code-1 (cdr-safe
+		      (assoc "content-transfer-encoding"
+			     url-current-mime-headers)))
+	     (code-2 (cdr-safe
+		      (assoc "content-encoding" url-current-mime-headers)))
+	     (code-3 (and (not code-1) (not code-2)
+			  (cdr-safe (assoc extn url-uncompressor-alist))))
+	     (done nil)
+	     (default-process-coding-system
+	       (cons mule-no-coding-system mule-no-coding-system)))
+	(mapcar
+	 (function
+	  (lambda (code)
+	    (setq decoder (and (not (member code done))
+			       (cdr-safe
+				(assoc code mm-content-transfer-encodings)))
+		  done (cons code done))
+	    (cond
+	     ((null decoder) nil)
+	     ((stringp decoder)
+	      (message "Decoding...")
+	      (call-process-region (point-min) (point-max) decoder t t nil)
+	      (message "Decoding... done."))
+	     ((listp decoder)
+	      (apply 'call-process-region (point-min) (point-max)
+		     (car decoder) t t nil (cdr decoder)))
+	     ((and (symbolp decoder) (fboundp decoder))
+	      (message "Decoding...")
+	      (funcall decoder (point-min) (point-max))
+	      (message "Decoding... done."))
+	     (t
+	      (error "Bad entry for %s in `mm-content-transfer-encodings'"
+		     code)))))
+	 (list code-1 code-2 code-3))))
+  (set-buffer-modified-p nil))
+
+(defun url-filter (proc string)
+  (save-excursion
+    (set-buffer url-working-buffer)
+    (insert string)
+    (if (string-match "\nConnection closed by" string)
+	(progn (set-process-filter proc nil)
+	       (url-sentinel proc string))))
+  string)
+
+(defun url-default-callback (buf)
+  (url-download-minor-mode nil)
+  (cond
+   ((save-excursion (set-buffer buf)
+		    (and url-current-callback-func
+			 (fboundp url-current-callback-func)))
+    (save-excursion
+      (save-window-excursion
+	(set-buffer buf)
+	(cond
+	 ((listp url-current-callback-data)
+	  (apply url-current-callback-func
+		 url-current-callback-data))
+	 (url-current-callback-data
+	  (funcall url-current-callback-func
+		   url-current-callback-data))
+	 (t
+	  (funcall url-current-callback-func))))))
+   ((fboundp 'w3-sentinel)
+    (set-variable 'w3-working-buffer buf)
+    (w3-sentinel))
+   (t
+    (message "Retrieval for %s complete." buf))))
+
+(defun url-sentinel (proc string)
+  (let* ((buf (process-buffer proc))
+	 (url-working-buffer (and buf (get-buffer buf)))
+	 status)
+    (if (not url-working-buffer)
+	(url-warn 'url (format "Process %s completed with no buffer!" proc))
+      (save-excursion
+	(set-buffer url-working-buffer)
+	(remove-hook 'after-change-functions 'url-after-change-function)
+	(if url-be-asynchronous
+	    (progn
+	      (widen)
+	      (url-clean-text)
+	      (cond
+	       ((and (null proc) (not url-working-buffer)) nil)
+	       ((url-mime-response-p)
+		(setq status (url-parse-mime-headers))))
+	      (if (not url-current-mime-type)
+		  (setq url-current-mime-type (mm-extension-to-mime
+					       (url-file-extension
+						url-current-file)))))))
+	  (if (member status '(401 301 302 303 204))
+	      nil
+	(funcall url-default-retrieval-proc (buffer-name url-working-buffer))))))
+
+(defun url-remove-relative-links (name)
+  ;; Strip . and .. from pathnames
+  (let ((new (if (not (string-match "^/" name))
+		 (concat "/" name)
+	       name)))
+    (while (string-match "/\\(\\./\\)" new)
+      (setq new (concat (substring new 0 (match-beginning 1))
+			(substring new (match-end 1)))))
+    (while (string-match "/\\([^/]*/\\.\\./\\)" new)
+      (setq new (concat (substring new 0 (match-beginning 1))
+			(substring new (match-end 1)))))
+    (while (string-match "^/\\.\\.\\(/\\)" new)
+      (setq new (substring new (match-beginning 1) nil)))
+    new))
+
+(defun url-truncate-url-for-viewing (url &optional width)
+  "Return a shortened version of URL that is WIDTH characters or less wide.
+WIDTH defaults to the current frame width."
+  (let* ((fr-width (or width (frame-width)))
+	 (str-width (length url))
+	 (tail (file-name-nondirectory url))
+	 (fname nil)
+	 (modified 0)
+	 (urlobj nil))
+    ;; The first thing that can go are the search strings
+    (if (and (>= str-width fr-width)
+	     (string-match "?" url))
+	(setq url (concat (substring url 0 (match-beginning 0)) "?...")
+	      str-width (length url)
+	      tail (file-name-nondirectory url)))
+    (if (< str-width fr-width)
+	nil				; Hey, we are done!
+      (setq urlobj (url-generic-parse-url url)
+	    fname (url-filename urlobj)
+	    fr-width (- fr-width 4))
+      (while (and (>= str-width fr-width)
+		  (string-match "/" fname))
+	(setq fname (substring fname (match-end 0) nil)
+	      modified (1+ modified))
+	(url-set-filename urlobj fname)
+	(setq url (url-recreate-url urlobj)
+	      str-width (length url)))
+      (if (> modified 1)
+	  (setq fname (concat "/.../" fname))
+	(setq fname (concat "/" fname)))
+      (url-set-filename urlobj fname)
+      (setq url (url-recreate-url urlobj)))
+    url))
+
+(defun url-view-url (&optional no-show)
+  "View the current document's URL.  Optional argument NO-SHOW means
+just return the URL, don't show it in the minibuffer."
+  (interactive)
+  (let ((url ""))
+    (cond
+     ((equal url-current-type "gopher")
+      (setq url (format "%s://%s%s/%s"
+			url-current-type url-current-server
+			(if (or (null url-current-port)
+				(string= "70" url-current-port)) ""
+			  (concat ":" url-current-port))
+			url-current-file)))
+     ((equal url-current-type "news")
+      (setq url (concat "news:"
+			(if (not (equal url-current-server
+					url-news-server))
+			    (concat "//" url-current-server
+				    (if (or (null url-current-port)
+					    (string= "119" url-current-port))
+					""
+				      (concat ":" url-current-port)) "/"))
+			url-current-file)))
+     ((equal url-current-type "about")
+      (setq url (concat "about:" url-current-file)))
+     ((member url-current-type '("http" "shttp" "https"))
+      (setq url (format  "%s://%s%s/%s" url-current-type url-current-server
+			 (if (or (null url-current-port)
+				 (string= "80" url-current-port))
+			     ""
+			   (concat ":" url-current-port))
+			 (if (and url-current-file
+				  (= ?/ (string-to-char url-current-file)))
+			     (substring url-current-file 1 nil)
+			   url-current-file))))
+     ((equal url-current-type "ftp")
+      (setq url (format "%s://%s%s/%s" url-current-type
+			(if (and url-current-user
+				 (not (string= "anonymous" url-current-user)))
+			    (concat url-current-user "@") "")
+			url-current-server
+			(if (and url-current-file
+				 (= ?/ (string-to-char url-current-file)))
+			    (substring url-current-file 1 nil)
+			  url-current-file))))
+     ((and (member url-current-type '("file" nil)) url-current-file)
+      (setq url (format "file:%s" url-current-file)))
+     ((equal url-current-type "www")
+      (setq url (format "www:/%s/%s" url-current-server url-current-file)))
+     (t
+      (setq url nil)))
+    (if (not no-show) (message "%s" url) url)))
+
+(defun url-parse-Netscape-history (fname)
+  ;; Parse a Netscape/X style global history list.
+  (let (pos				; Position holder
+	url				; The URL
+	time)				; Last time accessed
+    (goto-char (point-min))
+    (skip-chars-forward "^\n")
+    (skip-chars-forward "\n \t")	; Skip past the tag line
+    (setq url-global-history-hash-table (make-hash-table :size 131
+							 :test 'equal))
+    ;; Here we will go to the end of the line and
+    ;; skip back over a token, since we might run
+    ;; into spaces in URLs, depending on how much
+    ;; smarter netscape is than the old XMosaic :)
+    (while (not (eobp))
+      (setq pos (point))
+      (end-of-line)
+      (skip-chars-backward "^ \t")
+      (skip-chars-backward " \t")
+      (setq url (buffer-substring pos (point))
+	    pos (1+ (point)))
+      (skip-chars-forward "^\n")
+      (setq time (buffer-substring pos (point)))
+      (skip-chars-forward "\n")
+      (setq url-history-changed-since-last-save t)
+      (cl-puthash url time url-global-history-hash-table))))
+
+(defun url-parse-Mosaic-history-v1 (fname)
+  ;; Parse an NCSA Mosaic/X style global history list
+  (goto-char (point-min))
+  (skip-chars-forward "^\n")
+  (skip-chars-forward "\n \t")	; Skip past the tag line
+  (skip-chars-forward "^\n")
+  (skip-chars-forward "\n \t")	; Skip past the second tag line
+  (setq url-global-history-hash-table (make-hash-table :size 131
+						       :test 'equal))
+  (let (pos				; Temporary position holder
+	bol				; Beginning-of-line
+	url				; URL
+	time				; Time
+	last-end			; Last ending point
+	)
+    (while (not (eobp))
+      (setq bol (point))
+      (end-of-line)
+      (setq pos (point)
+	    last-end (point))
+      (skip-chars-backward "^ \t" bol)	; Skip over year
+      (skip-chars-backward " \t" bol)
+      (skip-chars-backward "^ \t" bol)	; Skip over time
+      (skip-chars-backward " \t" bol)
+      (skip-chars-backward "^ \t" bol)	; Skip over day #
+      (skip-chars-backward " \t" bol)
+      (skip-chars-backward "^ \t" bol)	; Skip over month
+      (skip-chars-backward " \t" bol)
+      (skip-chars-backward "^ \t" bol)	; Skip over day abbrev.
+      (if (bolp)
+	  nil				; Malformed entry!!! Ack! Bailout!
+	(setq time (buffer-substring pos (point)))
+	(skip-chars-backward " \t")
+	(setq pos (point)))
+      (beginning-of-line)
+      (setq url (buffer-substring (point) pos))
+      (goto-char (min (1+ last-end) (point-max))) ; Goto next line
+      (if (/= (length url) 0)
+	  (progn
+	    (setq url-history-changed-since-last-save t)
+	    (cl-puthash url time url-global-history-hash-table))))))
+
+(defun url-parse-Mosaic-history-v2 (fname)
+  ;; Parse an NCSA Mosaic/X style global history list (version 2)
+  (goto-char (point-min))
+  (skip-chars-forward "^\n")
+  (skip-chars-forward "\n \t")	; Skip past the tag line
+  (skip-chars-forward "^\n")
+  (skip-chars-forward "\n \t")	; Skip past the second tag line
+  (setq url-global-history-hash-table (make-hash-table :size 131
+						       :test 'equal))
+  (let (pos				; Temporary position holder
+	bol				; Beginning-of-line
+	url				; URL
+	time				; Time
+	last-end			; Last ending point
+	)
+    (while (not (eobp))
+      (setq bol (point))
+      (end-of-line)
+      (setq pos (point)
+	    last-end (point))
+      (skip-chars-backward "^ \t" bol)	; Skip over time
+      (if (bolp)
+	  nil				; Malformed entry!!! Ack! Bailout!
+	(setq time (buffer-substring pos (point)))
+	(skip-chars-backward " \t")
+	(setq pos (point)))
+      (beginning-of-line)
+      (setq url (buffer-substring (point) pos))
+      (goto-char (min (1+ last-end) (point-max))) ; Goto next line
+      (if (/= (length url) 0)
+	  (progn
+	    (setq url-history-changed-since-last-save t)
+	    (cl-puthash url time url-global-history-hash-table))))))
+
+(defun url-parse-Emacs-history (&optional fname)
+  ;; Parse out the Emacs-w3 global history file for completion, etc.
+  (or fname (setq fname (expand-file-name url-global-history-file)))
+  (cond
+   ((not (file-exists-p fname))
+    (message "%s does not exist." fname))
+   ((not (file-readable-p fname))
+    (message "%s is unreadable." fname))
+   (t
+    (condition-case ()
+	(load fname nil t)
+      (error (message "Could not load %s" fname)))
+    (if (boundp 'url-global-history-completion-list)
+	;; Hey!  Automatic conversion of old format!
+	(progn
+	  (setq url-global-history-hash-table (make-hash-table :size 131
+							       :test 'equal)
+		url-history-changed-since-last-save t)
+	  (mapcar (function
+		   (lambda (x)
+		     (cl-puthash (car x) (cdr x)
+				 url-global-history-hash-table)))
+		  (symbol-value 'url-global-history-completion-list)))))))
+
+(defun url-parse-global-history (&optional fname)
+  ;; Parse out the mosaic global history file for completions, etc.
+  (or fname (setq fname (expand-file-name url-global-history-file)))
+  (cond
+   ((not (file-exists-p fname))
+    (message "%s does not exist." fname))
+   ((not (file-readable-p fname))
+    (message "%s is unreadable." fname))
+   (t
+    (save-excursion
+      (set-buffer (get-buffer-create " *url-tmp*"))
+      (erase-buffer)
+      (insert-file-contents-literally fname)
+      (goto-char (point-min))
+      (cond
+       ((looking-at "(setq") (url-parse-Emacs-history fname))
+       ((looking-at "ncsa-mosaic-.*-1$") (url-parse-Mosaic-history-v1 fname))
+       ((looking-at "ncsa-mosaic-.*-2$") (url-parse-Mosaic-history-v2 fname))
+       ((or (looking-at "MCOM-") (looking-at "netscape"))
+	(url-parse-Netscape-history fname))
+       (t
+	(url-warn 'url (format "Cannot deduce type of history file: %s"
+			       fname))))))))
+
+(defun url-write-Emacs-history (fname)
+  ;; Write an Emacs-w3 style global history list into FNAME
+  (erase-buffer)
+  (let ((count 0))
+    (cl-maphash (function
+		 (lambda (key value)
+		   (setq count (1+ count))
+		   (insert "(cl-puthash \"" key "\""
+			   (if (not (stringp value)) " '" "")
+			   (prin1-to-string value)
+			   " url-global-history-hash-table)\n")))
+		url-global-history-hash-table)
+    (goto-char (point-min))
+    (insert (format
+	     "(setq url-global-history-hash-table (make-hash-table :size %d :test 'equal))\n"
+	     (/ count 4)))
+    (goto-char (point-max))
+    (insert "\n")
+    (write-file fname)))
+
+(defun url-write-Netscape-history (fname)
+  ;; Write a Netscape-style global history list into FNAME
+  (erase-buffer)
+  (let ((last-valid-time "785305714"))	; Picked out of thin air,
+					; in case first in assoc list
+					; doesn't have a valid time
+    (goto-char (point-min))
+    (insert "MCOM-Global-history-file-1\n")
+    (cl-maphash (function
+		 (lambda (url time)
+		   (if (or (not (stringp time)) (string-match " \t" time))
+		       (setq time last-valid-time)
+		     (setq last-valid-time time))
+		   (insert url " " time "\n")))
+		url-global-history-hash-table)
+    (write-file fname)))
+
+(defun url-write-Mosaic-history-v1 (fname)
+  ;; Write a Mosaic/X-style global history list into FNAME
+  (erase-buffer)
+  (goto-char (point-min))
+  (insert "ncsa-mosaic-history-format-1\nGlobal\n")
+  (cl-maphash (function
+	       (lambda (url time)
+		 (if (listp time)
+		     (setq time (current-time-string time)))
+		 (if (or (not (stringp time))
+			 (not (string-match " " time)))
+		     (setq time (current-time-string)))
+		 (insert url " " time "\n")))
+	      url-global-history-hash-table)
+  (write-file fname))
+
+(defun url-write-Mosaic-history-v2 (fname)
+  ;; Write a Mosaic/X-style global history list into FNAME
+  (let ((last-valid-time "827250806"))
+    (erase-buffer)
+    (goto-char (point-min))
+    (insert "ncsa-mosaic-history-format-2\nGlobal\n")
+    (cl-maphash (function
+		 (lambda (url time)
+		   (if (listp time)
+		       (setq time last-valid-time)
+		     (setq last-valid-time time))
+		   (if (not (stringp time))
+		       (setq time last-valid-time))
+		   (insert url " " time "\n")))
+		url-global-history-hash-table)
+    (write-file fname)))
+
+(defun url-write-global-history (&optional fname)
+  "Write the global history file into `url-global-history-file'.
+The type of data written is determined by what is in the file to begin
+with.  If the type of storage cannot be determined, then prompt the
+user for what type to save as."
+  (interactive)
+  (or fname (setq fname (expand-file-name url-global-history-file)))
+  (cond
+   ((not url-history-changed-since-last-save) nil)
+   ((not (file-writable-p fname))
+    (message "%s is unwritable." fname))
+   (t
+    (let ((make-backup-files nil)
+	  (version-control nil)
+	  (require-final-newline t))
+      (save-excursion
+	(set-buffer (get-buffer-create " *url-tmp*"))
+	(erase-buffer)
+	(condition-case ()
+	    (insert-file-contents-literally fname)
+	  (error nil))
+	(goto-char (point-min))
+	(cond
+	 ((looking-at "ncsa-mosaic-.*-1$") (url-write-Mosaic-history-v1 fname))
+	 ((looking-at "ncsa-mosaic-.*-2$") (url-write-Mosaic-history-v2 fname))
+	 ((looking-at "MCOM-") (url-write-Netscape-history fname))
+	 ((looking-at "netscape") (url-write-Netscape-history fname))
+	 ((looking-at "(setq") (url-write-Emacs-history fname))
+	 (t (url-write-Emacs-history fname)))
+	(kill-buffer (current-buffer))))))
+  (setq url-history-changed-since-last-save nil))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The main URL fetching interface
+;;; -------------------------------
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;###autoload
+(defun url-popup-info (url)
+  "Retrieve the HTTP/1.0 headers and display them in a temp buffer."
+  (let* ((urlobj (url-generic-parse-url url))
+	 (type (url-type urlobj))
+	 data)
+    (cond
+     ((string= type "http")
+      (let ((url-request-method "HEAD")
+	    (url-automatic-caching nil)
+	    (url-inhibit-mime-parsing t)
+	    (url-working-buffer " *popup*"))
+	(save-excursion
+	  (set-buffer (get-buffer-create url-working-buffer))
+	  (erase-buffer)
+	  (setq url-be-asynchronous nil)
+	  (url-retrieve url)
+	  (subst-char-in-region (point-min) (point-max) ?\r ? )
+	  (buffer-string))))
+     ((or (string= type "file") (string= type "ftp"))
+      (setq data (url-file-attributes url))
+      (set-buffer (get-buffer-create
+		   (url-generate-new-buffer-name "*Header Info*")))
+      (erase-buffer)
+      (if data
+	  (concat (if (stringp (nth 0 data))
+		      (concat "    Linked to: " (nth 0 data))
+		    (concat "    Directory: " (if (nth 0 data) "Yes" "No")))
+		  "\n        Links: " (int-to-string (nth 1 data))
+		  "\n     File UID: " (int-to-string (nth 2 data))
+		  "\n     File GID: " (int-to-string (nth 3 data))
+		  "\n  Last Access: " (current-time-string (nth 4 data))
+		  "\nLast Modified: " (current-time-string (nth 5 data))
+		  "\n Last Changed: " (current-time-string (nth 6 data))
+		  "\n Size (bytes): " (int-to-string (nth 7 data))
+		  "\n    File Type: " (or (nth 8 data) "text/plain"))
+	(concat "No info found for " url)))
+     ((and (string= type "news") (string-match "@" url))
+      (let ((art (url-filename urlobj)))
+	(if (not (string= (substring art -1 nil) ">"))
+	    (setq art (concat "<" art ">")))
+	(url-get-headers-from-article-id art)))
+     (t (concat "Don't know how to find information on " url)))))
+
+(defun url-decode-text ()
+  ;; Decode text transmitted by NNTP.
+  ;; 0. Delete status line.
+  ;; 1. Delete `^M' at end of line.
+  ;; 2. Delete `.' at end of buffer (end of text mark).
+  ;; 3. Delete `.' at beginning of line."
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    ;; Insert newline at end of buffer.
+    (goto-char (point-max))
+    (if (not (bolp))
+	(insert "\n"))
+    ;; Delete status line.
+    (goto-char (point-min))
+    (delete-region (point) (progn (forward-line 1) (point)))
+    ;; Delete `^M' at end of line.
+    ;; (replace-regexp "\r$" "")
+    (while (not (eobp))
+      (end-of-line)
+      (if (= (preceding-char) ?\r)
+	  (delete-char -1))
+      (forward-line 1)
+      )
+    ;; Delete `.' at end of buffer (end of text mark).
+    (goto-char (point-max))
+    (forward-line -1)			;(beginning-of-line)
+    (if (looking-at "^\\.$")
+	(delete-region (point) (progn (forward-line 1) (point))))
+    ;; Replace `..' at beginning of line with `.'.
+    (goto-char (point-min))
+    ;; (replace-regexp "^\\.\\." ".")
+    (while (search-forward "\n.." nil t)
+      (delete-char -1))
+    ))
+
+(defun url-get-headers-from-article-id (art)
+  ;; Return the HEAD of ART (a usenet news article)
+  (cond
+   ((string-match "flee" nntp-version)
+    (nntp/command "HEAD" art)
+    (save-excursion
+      (set-buffer nntp-server-buffer)
+      (while (progn (goto-char (point-min))
+		    (not (re-search-forward "^.\r*$" nil t)))
+	(url-accept-process-output nntp/connection))))
+   (t
+    (nntp-send-command "^\\.\r$" "HEAD" art)
+    (url-decode-text)))
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (buffer-string)))
+
+(defvar url-external-retrieval-program "www"
+  "*Name of the external executable to run to retrieve URLs.")
+
+(defvar url-external-retrieval-args '("-source")
+  "*A list of arguments to pass to `url-external-retrieval-program' to
+retrieve a URL by its HTML source.")
+
+(defun url-retrieve-externally (url &optional no-cache)
+  (let ((url-working-buffer (if (and url-multiple-p
+				     (string-equal url-working-buffer
+						   url-default-working-buffer))
+				(url-get-working-buffer-name)
+			      url-working-buffer)))
+    (if (get-buffer-create url-working-buffer)
+	(save-excursion
+	  (set-buffer url-working-buffer)
+	  (set-buffer-modified-p nil)
+	  (kill-buffer url-working-buffer)))
+    (set-buffer (get-buffer-create url-working-buffer))
+    (let* ((args (append url-external-retrieval-args (list url)))
+	   (urlobj (url-generic-parse-url url))
+	   (type (url-type urlobj)))
+      (if (or (member type '("www" "about" "mailto" "mailserver"))
+	      (url-file-directly-accessible-p urlobj))
+	  (url-retrieve-internally url)
+	(url-lazy-message "Retrieving %s..." url)
+	(apply 'call-process url-external-retrieval-program
+	       nil t nil args)
+	(url-lazy-message "Retrieving %s... done" url)
+	(if (and type urlobj)
+	    (setq url-current-server (url-host urlobj)
+		  url-current-type (url-type urlobj)
+		  url-current-port (url-port urlobj)
+		  url-current-file (url-filename urlobj)))
+	(if (member url-current-file '("/" ""))
+	    (setq url-current-mime-type "text/html"))))))
+
+(defun url-get-normalized-date (&optional specified-time)
+  ;; Return a 'real' date string that most HTTP servers can understand.
+  (require 'timezone)
+  (let* ((raw (if specified-time (current-time-string specified-time)
+		(current-time-string)))
+	 (gmt (timezone-make-date-arpa-standard raw
+						(nth 1 (current-time-zone))
+						"GMT"))
+	 (parsed (timezone-parse-date gmt))
+	 (day (cdr-safe (assoc (substring raw 0 3) weekday-alist)))
+	 (year nil)
+	 (month (car
+		 (rassoc
+		  (string-to-int (aref parsed 1)) monthabbrev-alist)))
+	 )
+    (setq day (or (car-safe (rassoc day weekday-alist))
+		  (substring raw 0 3))
+	  year (aref parsed 0))
+    ;; This is needed for plexus servers, or the server will hang trying to
+    ;; parse the if-modified-since header.  Hopefully, I can take this out
+    ;; soon.
+    (if (and year (> (length year) 2))
+	(setq year (substring year -2 nil)))
+
+    (concat day ", " (aref parsed 2) "-" month "-" year " "
+	    (aref parsed 3) " " (or (aref parsed 4)
+				    (concat "[" (nth 1 (current-time-zone))
+					    "]")))))
+
+;;;###autoload
+(defun url-cache-expired (url mod)
+  "Return t iff a cached file has expired."
+  (if (not (string-match url-nonrelative-link url))
+      t
+    (let* ((urlobj (url-generic-parse-url url))
+	   (type (url-type urlobj)))
+      (cond
+       (url-standalone-mode
+	(not (file-exists-p (url-create-cached-filename urlobj))))
+       ((string= type "http")
+	(if (not url-standalone-mode) t
+	  (not (file-exists-p (url-create-cached-filename urlobj)))))
+       ((not (fboundp 'current-time))
+	t)
+       ((member type '("file" "ftp"))
+	(if (or (equal mod '(0 0)) (not mod))
+	      (return t)
+	    (or (> (nth 0 mod) (nth 0 (current-time)))
+		(> (nth 1 mod) (nth 1 (current-time))))))
+       (t nil)))))
+
+(defun url-get-working-buffer-name ()
+  "Get a working buffer name such as ` *URL-*' without a live process and empty"
+  (let ((num 1)
+	name buf)
+    (while (progn (setq name (format " *URL-%d*" num))
+		  (setq buf (get-buffer name))
+		  (and buf (or (get-buffer-process buf)
+			       (save-excursion (set-buffer buf)
+					       (> (point-max) 1)))))
+      (setq num (1+ num)))
+    name))
+
+(defun url-default-find-proxy-for-url (urlobj host)
+  (cond
+   ((or (and (assoc "no_proxy" url-proxy-services)
+	     (string-match
+	      (cdr
+	       (assoc "no_proxy" url-proxy-services))
+	      host))
+	(equal "www" (url-type urlobj)))
+    "DIRECT")
+   ((cdr (assoc (url-type urlobj) url-proxy-services))
+    (concat "PROXY " (cdr (assoc (url-type urlobj) url-proxy-services))))
+   ;;
+   ;; Should check for socks
+   ;;
+   (t
+    "DIRECT")))
+
+(defvar url-proxy-locator 'url-default-find-proxy-for-url)
+
+(defun url-find-proxy-for-url (url host)
+  (let ((proxies (split-string (funcall url-proxy-locator url host) " *; *"))
+	(proxy nil)
+	(case-fold-search t))
+    ;; Not sure how I should handle gracefully degrading from one proxy to
+    ;; another, so for now just deal with the first one
+    ;; (while proxies
+    (setq proxy (pop proxies))
+    (cond
+     ((string-match "^direct" proxy) nil)
+     ((string-match "^proxy +" proxy)
+      (concat "http://" (substring proxy (match-end 0)) "/"))
+     ((string-match "^socks +" proxy)
+      (concat "socks://" (substring proxy (match-end 0))))
+     (t
+      (url-warn 'url (format "Unknown proxy directive: %s" proxy) 'critical)
+      nil))))
+
+(defun url-retrieve-internally (url &optional no-cache)
+  (let ((url-working-buffer (if (and url-multiple-p
+				     (string-equal
+				      (if (bufferp url-working-buffer)
+					  (buffer-name url-working-buffer)
+					url-working-buffer)
+				      url-default-working-buffer))
+				(url-get-working-buffer-name)
+			      url-working-buffer)))
+    (if (get-buffer url-working-buffer)
+	(save-excursion
+	  (set-buffer url-working-buffer)
+	  (erase-buffer)
+	  (setq url-current-can-be-cached (not no-cache))
+	  (set-buffer-modified-p nil)))
+    (let* ((urlobj (url-generic-parse-url url))
+	   (type (url-type urlobj))
+	   (url-using-proxy (if (url-host urlobj)
+				(url-find-proxy-for-url urlobj
+							(url-host urlobj))
+			      nil))
+	   (handler nil)
+	   (original-url url)
+	   (cached nil)
+	   (tmp url-current-file))
+      (if url-using-proxy (setq type "proxy"))
+      (setq cached (url-is-cached url)
+	    cached (and cached (not (url-cache-expired url cached)))
+	    handler (if cached 'url-extract-from-cache
+		      (car-safe
+		       (cdr-safe (assoc (or type "auto")
+					url-registered-protocols))))
+	    url (if cached (url-create-cached-filename url) url))
+      (save-excursion
+	(set-buffer (get-buffer-create url-working-buffer))
+	(setq url-current-can-be-cached (not no-cache)))
+					;    (if url-be-asynchronous
+					;	(url-download-minor-mode t))
+      (if (and handler (fboundp handler))
+	  (funcall handler url)
+	(set-buffer (get-buffer-create url-working-buffer))
+	(setq url-current-file tmp)
+	(erase-buffer)
+	(insert " Link Error! \n"
+		"
     An error has occurred... 
    \n"
+		(format "The link type `%s'" type)
+		" is unrecognized or unsupported at this time.
    \n"
+		"If you feel this is an error, please "
+		"send me mail."
+		"
    William Perry

    "
+		"
    " url-bug-address "
    ")
+	(setq url-current-file "error.html"))
+      (if (and
+	   (not url-be-asynchronous)
+	   (get-buffer url-working-buffer))
+	  (progn
+	    (set-buffer url-working-buffer)
+
+	    (url-clean-text)))
+      (cond
+       ((equal type "wais") nil)
+       ((and url-be-asynchronous (not cached) (member type '("http" "proxy")))
+	nil)
+       (url-be-asynchronous
+	(funcall url-default-retrieval-proc (buffer-name)))
+       ((not (get-buffer url-working-buffer)) nil)
+       ((and (not url-inhibit-mime-parsing)
+	     (or cached (url-mime-response-p t)))
+	(or cached (url-parse-mime-headers nil t))))
+      (if (and (or (not url-be-asynchronous)
+		   (not (equal type "http")))
+	       (not url-current-mime-type))
+	  (if (url-buffer-is-hypertext)
+	      (setq url-current-mime-type "text/html")
+	    (setq url-current-mime-type (mm-extension-to-mime
+					 (url-file-extension
+					  url-current-file)))))
+      (if (and url-automatic-caching url-current-can-be-cached
+	       (not url-be-asynchronous))
+	  (save-excursion
+	    (url-store-in-cache url-working-buffer)))
+      (if (not url-global-history-hash-table)
+	  (setq url-global-history-hash-table (make-hash-table :size 131
+							       :test 'equal)))
+      (if (not (string-match "^about:" original-url))
+	  (progn
+	    (setq url-history-changed-since-last-save t)
+	    (cl-puthash original-url (current-time)
+			url-global-history-hash-table)))
+      (cons cached url-working-buffer))))
+
+;;;###autoload
+(defun url-retrieve (url &optional no-cache expected-md5)
+  "Retrieve a document over the World Wide Web.
+The document should be specified by its fully specified
+Uniform Resource Locator.  No parsing is done, just return the
+document as the server sent it.  The document is left in the
+buffer specified by url-working-buffer.  url-working-buffer is killed
+immediately before starting the transfer, so that no buffer-local
+variables interfere with the retrieval.  HTTP/1.0 redirection will
+be honored before this function exits."
+  (url-do-setup)
+  (if (and (fboundp 'set-text-properties)
+	   (subrp (symbol-function 'set-text-properties)))
+      (set-text-properties 0 (length url) nil url))
+  (if (and url (string-match "^url:" url))
+      (setq url (substring url (match-end 0) nil)))
+  (let ((status (url-retrieve-internally url no-cache)))
+    (if (and expected-md5 url-check-md5s)
+	(let ((cur-md5 (md5 (current-buffer))))
+	  (if (not (string= cur-md5 expected-md5))
+	      (and (not (funcall url-confirmation-func
+				 "MD5s do not match, use anyway? "))
+		   (error "MD5 error.")))))
+    status))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; How to register a protocol
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun url-register-protocol (protocol &optional retrieve expander defport)
+  "Register a protocol with the URL retrieval package.
+PROTOCOL is the type of protocol being registers (http, nntp, etc),
+         and is the first chunk of the URL.  ie: http:// URLs will be
+         handled by the protocol registered as 'http'.  PROTOCOL can
+         be either a symbol or a string - it is converted to a string,
+         and lowercased before being registered.
+RETRIEVE (optional) is the function to be called with a url as its
+         only argument.  If this argument is omitted, then this looks
+         for a function called 'url-PROTOCOL'.  A warning is shown if
+         the function is undefined, but the protocol is still
+         registered.
+EXPANDER (optional) is the function to call to expand a relative link
+         of type PROTOCOL.  If omitted, this defaults to
+         `url-default-expander'
+
+Any proxy information is read in from environment variables at this
+time, so this function should only be called after dumping emacs."
+  (let* ((protocol (cond
+		    ((stringp protocol) (downcase protocol))
+		    ((symbolp protocol) (downcase (symbol-name protocol)))
+		    (t nil)))
+		     
+	 (retrieve (or retrieve (intern (concat "url-" protocol))))
+	 (expander (or expander 'url-default-expander))
+	 (cur-protocol (assoc protocol url-registered-protocols))
+	 (urlobj nil)
+	 (cur-proxy (assoc protocol url-proxy-services))
+	 (env-proxy (or (getenv (concat protocol "_proxy"))
+			(getenv (concat protocol "_PROXY"))
+			(getenv (upcase (concat protocol "_PROXY"))))))
+
+    (if (not protocol)
+	(error "Invalid data to url-register-protocol."))
+    
+    (if (not (fboundp retrieve))
+	(message "Warning: %s registered, but no function found." protocol))
+
+    ;; Store the default port, if none previously specified and
+    ;; defport given
+    (if (and defport (not (assoc protocol url-default-ports)))
+	(setq url-default-ports (cons (cons protocol defport)
+				      url-default-ports)))
+    
+    ;; Store the appropriate information for later
+    (if cur-protocol
+	(setcdr cur-protocol (cons retrieve expander))
+      (setq url-registered-protocols (cons (cons protocol
+						 (cons retrieve expander))
+					   url-registered-protocols)))
+
+    ;; Store any proxying information - this will not overwrite an old
+    ;; entry, so that people can still set this information in their
+    ;; .emacs file
+    (cond
+     (cur-proxy nil)			; Keep their old settings
+     ((null env-proxy) nil)		; No proxy setup
+     ;; First check if its something like hostname:port
+     ((string-match "^\\([^:]+\\):\\([0-9]+\\)$" env-proxy)
+      (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
+      (url-set-type urlobj "http")
+      (url-set-host urlobj (url-match env-proxy 1))
+      (url-set-port urlobj (url-match env-proxy 2)))
+     ;; Then check if its a fully specified URL
+     ((string-match url-nonrelative-link env-proxy)
+      (setq urlobj (url-generic-parse-url env-proxy))
+      (url-set-type urlobj "http")
+      (url-set-target urlobj nil))
+     ;; Finally, fall back on the assumption that its just a hostname
+     (t
+      (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
+      (url-set-type urlobj "http")
+      (url-set-host urlobj env-proxy)))
+
+     (if (and (not cur-proxy) urlobj)
+	 (progn
+	   (setq url-proxy-services
+		 (cons (cons protocol (concat (url-host urlobj) ":"
+					      (url-port urlobj)))
+		       url-proxy-services))
+	   (message "Using a proxy for %s..." protocol)))))
+
+(provide 'url)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/urlauth.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/urlauth.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,303 @@
+;;; urlauth.el --- Uniform Resource Locator authorization modules
+;; Author: wmperry
+;; Created: 1996/10/09 19:00:59
+;; Version: 1.2
+;; Keywords: comm, data, processes, hypermedia
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'url-vars)
+(require 'url-parse)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Basic authorization code
+;;; ------------------------
+;;; This implements the BASIC authorization type.  See the online
+;;; documentation at
+;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
+;;; for the complete documentation on this type.
+;;;
+;;; This is very insecure, but it works as a proof-of-concept
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar url-basic-auth-storage nil
+  "Where usernames and passwords are stored.  Its value is an assoc list of
+assoc lists.  The first assoc list is keyed by the server name.  The cdr of
+this is an assoc list based on the 'directory' specified by the url we are
+looking up.")
+
+(defun url-basic-auth (url &optional prompt overwrite realm args)
+  "Get the username/password for the specified URL.
+If optional argument PROMPT is non-nil, ask for the username/password
+to use for the url and its descendants.  If optional third argument
+OVERWRITE is non-nil, overwrite the old username/password pair if it
+is found in the assoc list.  If REALM is specified, use that as the realm
+instead of the pathname inheritance method."
+  (let* ((href (if (stringp url)
+		   (url-generic-parse-url url)
+		 url))
+	 (server (or (url-host href) url-current-server))
+	 (port (or (url-port href) "80"))
+	 (path (url-filename href))
+	 user pass byserv retval data)
+    (setq server (concat server ":" port)
+	  path (cond
+		(realm realm)
+		((string-match "/$" path) path)
+		(t (url-basepath path)))
+	  byserv (cdr-safe (assoc server url-basic-auth-storage)))
+    (cond
+     ((and prompt (not byserv))
+      (setq user (read-string "Username: " (user-real-login-name))
+	    pass (funcall url-passwd-entry-func "Password: ")
+	    url-basic-auth-storage
+	    (cons (list server
+			(cons path
+			      (setq retval
+				    (base64-encode
+				     (format "%s:%s" user pass)))))
+		  url-basic-auth-storage)))
+     (byserv
+      (setq retval (cdr-safe (assoc path byserv)))
+      (if (and (not retval)
+	       (string-match "/" path))
+ 	  (while (and byserv (not retval))
+	    (setq data (car (car byserv)))
+	    (if (or (not (string-match "/" data)) ; Its a realm - take it!
+		    (and
+		     (>= (length path) (length data))
+		     (string= data (substring path 0 (length data)))))
+		(setq retval (cdr (car byserv))))
+	    (setq byserv (cdr byserv))))
+      (if (or (and (not retval) prompt) overwrite)
+	  (progn
+	    (setq user (read-string "Username: " (user-real-login-name))
+		  pass (funcall url-passwd-entry-func "Password: ")
+		  retval (base64-encode (format "%s:%s" user pass))
+		  byserv (assoc server url-basic-auth-storage))
+	    (setcdr byserv
+		    (cons (cons path retval) (cdr byserv))))))
+     (t (setq retval nil)))
+    (if retval (setq retval (concat "Basic " retval)))
+    retval))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Digest authorization code
+;;; ------------------------
+;;; This implements the DIGEST authorization type.  See the internet draft
+;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
+;;; for the complete documentation on this type.
+;;;
+;;; This is very secure
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar url-digest-auth-storage nil
+  "Where usernames and passwords are stored.  Its value is an assoc list of
+assoc lists.  The first assoc list is keyed by the server name.  The cdr of
+this is an assoc list based on the 'directory' specified by the url we are
+looking up.")
+
+(defun url-digest-auth-create-key (username password realm method uri)
+  "Create a key for digest authentication method"
+  (let* ((info (if (stringp uri)
+		   (url-generic-parse-url uri)
+		 uri))
+	 (a1 (md5 (concat username ":" realm ":" password)))
+	 (a2 (md5 (concat method ":" (url-filename info)))))
+    (list a1 a2)))
+
+(defun url-digest-auth (url &optional prompt overwrite realm args)
+  "Get the username/password for the specified URL.
+If optional argument PROMPT is non-nil, ask for the username/password
+to use for the url and its descendants.  If optional third argument
+OVERWRITE is non-nil, overwrite the old username/password pair if it
+is found in the assoc list.  If REALM is specified, use that as the realm
+instead of hostname:portnum."
+  (if args
+      (let* ((href (if (stringp url)
+		       (url-generic-parse-url url)
+		     url))
+	     (server (or (url-host href) url-current-server))
+	     (port (or (url-port href) "80"))
+	     (path (url-filename href))
+	     user pass byserv retval data)
+	(setq path (cond
+		    (realm realm)
+		    ((string-match "/$" path) path)
+		    (t (url-basepath path)))
+	      server (concat server ":" port)
+	      byserv (cdr-safe (assoc server url-digest-auth-storage)))
+	(cond
+	 ((and prompt (not byserv))
+	  (setq user (read-string "Username: " (user-real-login-name))
+		pass (funcall url-passwd-entry-func "Password: ")
+		url-digest-auth-storage
+		(cons (list server
+			    (cons path
+				  (setq retval
+					(cons user
+					      (url-digest-auth-create-key
+					       user pass realm
+					       (or url-request-method "GET")
+					       url)))))
+		      url-digest-auth-storage)))
+	 (byserv
+	  (setq retval (cdr-safe (assoc path byserv)))
+	  (if (and (not retval)		; no exact match, check directories
+		   (string-match "/" path)) ; not looking for a realm
+	      (while (and byserv (not retval))
+		(setq data (car (car byserv)))
+		(if (or (not (string-match "/" data))
+			(and
+			 (>= (length path) (length data))
+			 (string= data (substring path 0 (length data)))))
+		    (setq retval (cdr (car byserv))))
+		(setq byserv (cdr byserv))))
+	  (if (or (and (not retval) prompt) overwrite)
+	      (progn
+		(setq user (read-string "Username: " (user-real-login-name))
+		      pass (funcall url-passwd-entry-func "Password: ")
+		      retval (setq retval
+				   (cons user
+					 (url-digest-auth-create-key
+					  user pass realm
+					  (or url-request-method "GET")
+					  url)))
+		      byserv (assoc server url-digest-auth-storage))
+		(setcdr byserv
+			(cons (cons path retval) (cdr byserv))))))
+	 (t (setq retval nil)))
+	(if retval
+	    (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
+		  (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
+	      (format
+	       (concat "Digest username=\"%s\", realm=\"%s\","
+		       "nonce=\"%s\", uri=\"%s\","
+		       "response=\"%s\", opaque=\"%s\"")
+	       (nth 0 retval) realm nonce (url-filename href)
+	       (md5 (concat (nth 1 retval) ":" nonce ":"
+			    (nth 2 retval))) opaque))))))
+
+(defvar url-registered-auth-schemes nil
+  "A list of the registered authorization schemes and various and sundry
+information associated with them.")
+
+(defun url-get-authentication (url realm type prompt &optional args)
+  "Return an authorization string suitable for use in the WWW-Authenticate
+header in an HTTP/1.0 request.
+
+URL    is the url you are requesting authorization to.  This can be either a
+       string representing the URL, or the parsed representation returned by
+       `url-generic-parse-url'
+REALM  is the realm at a specific site we are looking for.  This should be a
+       string specifying the exact realm, or nil or the symbol 'any' to
+       specify that the filename portion of the URL should be used as the
+       realm
+TYPE   is the type of authentication to be returned.  This is either a string
+       representing the type (basic, digest, etc), or nil or the symbol 'any'
+       to specify that any authentication is acceptable.  If requesting 'any'
+       the strongest matching authentication will be returned.  If this is
+       wrong, its no big deal, the error from the server will specify exactly
+       what type of auth to use
+PROMPT is boolean - specifies whether to ask the user for a username/password
+       if one cannot be found in the cache"
+  (if (not realm)
+      (setq realm (cdr-safe (assoc "realm" args))))
+  (if (stringp url)
+      (setq url (url-generic-parse-url url)))
+  (if (or (null type) (eq type 'any))
+      ;; Whooo doogies!
+      ;; Go through and get _all_ the authorization strings that could apply
+      ;; to this URL, store them along with the 'rating' we have in the list
+      ;; of schemes, then sort them so that the 'best' is at the front of the
+      ;; list, then get the car, then get the cdr.
+      ;; Zooom zooom zoooooom
+      (cdr-safe
+       (car-safe
+	(sort
+	 (mapcar
+	  (function
+	   (lambda (scheme)
+	     (if (fboundp (car (cdr scheme)))
+		 (cons (cdr (cdr scheme))
+		       (funcall (car (cdr scheme)) url nil nil realm))
+	       (cons 0 nil))))
+	  url-registered-auth-schemes)
+	 (function
+	  (lambda (x y)
+	    (cond
+	     ((null (cdr x)) nil)
+	     ((and (cdr x) (null (cdr y))) t)
+	     ((and (cdr x) (cdr y))
+	      (>= (car x) (car y)))
+	     (t nil)))))))
+    (if (symbolp type) (setq type (symbol-name type)))
+    (let* ((scheme (car-safe
+		    (cdr-safe (assoc (downcase type)
+				     url-registered-auth-schemes)))))
+      (if (and scheme (fboundp scheme))
+	  (funcall scheme url prompt
+		   (and prompt
+			(funcall scheme url nil nil realm args))
+		   realm args)))))
+
+(defun url-register-auth-scheme (type &optional function rating)
+  "Register an HTTP authentication method.
+
+TYPE     is a string or symbol specifying the name of the method.   This
+         should be the same thing you expect to get returned in an Authenticate
+         header in HTTP/1.0 - it will be downcased.
+FUNCTION is the function to call to get the authorization information.  This
+         defaults to `url-?-auth', where ? is TYPE
+RATING   a rating between 1 and 10 of the strength of the authentication.
+         This is used when asking for the best authentication for a specific
+         URL.  The item with the highest rating is returned."
+  (let* ((type (cond
+		((stringp type) (downcase type))
+		((symbolp type) (downcase (symbol-name type)))
+		(t (error "Bad call to `url-register-auth-scheme'"))))
+	 (function (or function (intern (concat "url-" type "-auth"))))
+	 (rating (cond
+		  ((null rating) 2)
+		  ((stringp rating) (string-to-int rating))
+		  (t rating)))
+	 (node (assoc type url-registered-auth-schemes)))
+    (if (not (fboundp function))
+	(url-warn 'security
+		  (format (eval-when-compile
+			    "Tried to register `%s' as an auth scheme"
+			    ", but it is not a function!") function)))
+
+    (if node
+	(progn
+	  (setcdr node (cons function rating))
+	  (url-warn 'security
+		    (format
+		     "Replacing authorization method `%s' - this could be bad."
+		     type)))
+      (setq url-registered-auth-schemes
+	    (cons (cons type (cons function rating))
+		  url-registered-auth-schemes)))))
+
+(defun url-auth-registered (scheme)
+  ;; Return non-nil iff SCHEME is registered as an auth type
+  (assoc scheme url-registered-auth-schemes))
+
+(provide 'urlauth)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/w3-about.el
--- a/lisp/w3/w3-about.el	Mon Aug 13 08:48:18 2007 +0200
+++ b/lisp/w3/w3-about.el	Mon Aug 13 08:48:42 2007 +0200
@@ -1,13 +1,14 @@
 ;;; w3-about.el --- About pages for emacs-w3
 ;; Author: wmperry
-;; Created: 1996/06/30 18:02:26
-;; Version: 1.3
+;; Created: 1996/12/16 16:44:46
+;; Version: 1.6
 ;; Keywords: hypermedia
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
 ;;;
-;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;; 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
@@ -20,8 +21,9 @@
 ;;; 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.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun w3-about (url)
@@ -78,11 +80,11 @@
 	 ((string= "style" node)
 	  (insert
 	   "
--- This is the stylesheet for the about pages for Emacs-w3 --
+/* This is the stylesheet for the about pages for Emacs-w3 */
 
-address,h1,h2,h3,h4,h5,h6 { align:\"center\" }
-wired { color:yellow }
-wired { background:red }
+address,h1,h2,h3,h4,h5,h6 { text-align: center }
+wired { color: yellow }
+wired { background: red }
 "))
 	 ((string= "license" node)
 	  (kill-buffer (current-buffer))
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/w3-annotat.el
--- a/lisp/w3/w3-annotat.el	Mon Aug 13 08:48:18 2007 +0200
+++ b/lisp/w3/w3-annotat.el	Mon Aug 13 08:48:42 2007 +0200
@@ -1,13 +1,14 @@
 ;;; w3-annotat.el --- Annotation functions for Emacs-W3
 ;; Author: wmperry
-;; Created: 1996/06/30 18:02:56
-;; Version: 1.3
+;; Created: 1996/10/09 19:00:59
+;; Version: 1.5
 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
 ;;;
-;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;; 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
@@ -20,8 +21,9 @@
 ;;; 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.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/w3-auto.el
--- a/lisp/w3/w3-auto.el	Mon Aug 13 08:48:18 2007 +0200
+++ b/lisp/w3/w3-auto.el	Mon Aug 13 08:48:42 2007 +0200
@@ -32,18 +32,17 @@
 
 ;; Stylesheet stuff
 (autoload 'w3-handle-style "w3-style")
-(autoload 'w3-style-parse-css "w3-style")
-(autoload 'w3-generate-stylesheet-faces "w3-style")
+(autoload 'w3-display-stylesheet "w3-style")
 
 ;; Setup stuff
 (autoload 'url-do-setup "url")
 (autoload 'w3-do-setup "w3")
 
 ;; Forms stuff
+(autoload 'w3-form-resurrect-widgets "w3-forms")
 (autoload 'w3-form-add-element "w3-forms")
 (autoload 'w3-do-text-entry "w3-forms")
 (autoload 'w3-do-form-entry "w3-forms")
-(autoload 'widget-at "w3-forms")
 (autoload 'w3-next-widget "w3-forms")
 
 ;; Widget stuff
@@ -53,6 +52,7 @@
 (autoload 'widget-put "widget-edit")
 (autoload 'widget-forward "widget-edit")
 (autoload 'widget-backward "widget-edit")
+(autoload 'widget-at "widget-edit")
 
 ;; Preferences
 (autoload 'w3-preferences-edit "w3-prefs")
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/w3-display.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/w3/w3-display.el	Mon Aug 13 08:48:42 2007 +0200
@@ -0,0 +1,1866 @@
+;;; w3-display.el --- display engine v99999
+;; Author: wmperry
+;; Created: 1997/01/02 20:20:45
+;; Version: 1.90
+;; Keywords: faces, help, hypermedia
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
+;;; Copyright (c) 1996 Free Software Foundation, Inc.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; This file is part of GNU Emacs.
+;;;
+;;; GNU Emacs is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+;;;
+;;; GNU Emacs is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(require 'cl)
+(require 'css)
+(require 'font)
+(require 'w3-widget)
+(require 'w3-imap)
+
+(defmacro w3-d-s-var-def (var)
+  (` (make-variable-buffer-local (defvar (, var) nil))))
+
+(w3-d-s-var-def w3-display-open-element-stack)
+(w3-d-s-var-def w3-display-alignment-stack)
+(w3-d-s-var-def w3-display-list-stack)
+(w3-d-s-var-def w3-display-form-stack)
+(w3-d-s-var-def w3-display-whitespace-stack)
+(w3-d-s-var-def w3-display-font-family-stack)
+(w3-d-s-var-def w3-display-font-weight-stack)
+(w3-d-s-var-def w3-display-font-variant-stack)
+(w3-d-s-var-def w3-display-font-size-stack)
+(w3-d-s-var-def w3-face-color)
+(w3-d-s-var-def w3-face-background)
+(w3-d-s-var-def w3-active-faces)
+(w3-d-s-var-def w3-active-voices)
+(w3-d-s-var-def w3-current-form-number)
+(w3-d-s-var-def w3-face-font-family)
+(w3-d-s-var-def w3-face-font-weight)
+(w3-d-s-var-def w3-face-font-variant)
+(w3-d-s-var-def w3-face-font-size)
+(w3-d-s-var-def w3-face-font-family)
+(w3-d-s-var-def w3-face-font-size)
+(w3-d-s-var-def w3-face-font-spec)
+(w3-d-s-var-def w3-face-text-decoration)
+(w3-d-s-var-def w3-face-face)
+(w3-d-s-var-def w3-face-descr)
+(w3-d-s-var-def w3-face-pixmap)
+(w3-d-s-var-def w3-display-css-properties)
+
+(eval-when-compile
+  (defmacro w3-get-attribute (attr)
+    (` (cdr-safe (assq (, attr) args))))
+  
+  (defmacro w3-get-face-info (info)
+    (let ((var (intern (format "w3-face-%s" info))))
+      (` (push (w3-get-style-info (quote (, info)) node (car (, var)))
+	       (, var)))))
+
+  (defmacro w3-pop-face-info (info)
+    (let ((var (intern (format "w3-face-%s" info))))
+      (` (pop (, var)))))
+
+  (defmacro w3-get-all-face-info ()
+    (`
+     (progn
+       (w3-get-face-info font-family)
+       (w3-get-face-info font-weight)
+       (w3-get-face-info font-variant)
+       (w3-get-face-info font-size)
+       (w3-get-face-info text-decoration)
+       ;;(w3-get-face-info pixmap)
+       (w3-get-face-info color)
+       (w3-get-face-info background)
+       (setq w3-face-font-spec (make-font
+				:weight (car w3-face-font-weight)
+				:family (car w3-face-font-family)
+				:size (car w3-face-font-size))))))
+
+  (defmacro w3-pop-all-face-info ()
+    (`
+     (progn
+       (w3-pop-face-info font-family)
+       (w3-pop-face-info font-weight)
+       (w3-pop-face-info font-variant)
+       (w3-pop-face-info font-size)
+       (w3-pop-face-info text-decoration)
+       ;;(w3-pop-face-info pixmap)
+       (w3-pop-face-info color)
+       (w3-pop-face-info background))))
+
+  )
+
+(defvar w3-face-cache nil  "Cache for w3-face-for-element")
+(defvar w3-face-index 0)
+(defvar w3-image-widgets-waiting nil)
+
+(make-variable-buffer-local 'w3-last-fill-pos)
+
+(defconst w3-fill-prefixes-vector
+  (let ((len 0)
+        (prefix-vector (make-vector 80 nil)))
+    (while (< len 80)
+      (aset prefix-vector len (make-string len ? ))
+      (setq len (1+ len)))
+    prefix-vector))
+
+(defconst w3-line-breaks-vector
+  (let ((len 0)
+	(breaks-vector (make-vector 10 nil)))
+    (while (< len 10)
+      (aset breaks-vector len (make-string len ?\n))
+      (setq len (1+ len)))
+    breaks-vector))
+
+(defun w3-pause ()
+  (cond
+   (w3-running-FSF19 (sit-for 0))
+   (w3-running-xemacs
+    (sit-for 0))
+   ;; (if (and (not (sit-for 0)) (input-pending-p))
+   ;;	(condition-case ()
+   ;;	    (dispatch-event (next-command-event))
+   ;;	  (error nil)))
+   (t (sit-for 0))))
+
+(defmacro w3-get-pad-string (len)
+  (` (cond
+      ((< (, len) 0)
+       "")
+      ((< (, len) 80)
+       (aref w3-fill-prefixes-vector (, len)))
+      (t (make-string (, len) ? )))))
+
+(defsubst w3-set-fill-prefix-length (len)
+  (setq fill-prefix (if (< len (- (or w3-strict-width (window-width)) 4))
+			(w3-get-pad-string len)
+		      (url-warn
+		       'html
+		       "Runaway indentation!  Too deep for window width!")
+		      fill-prefix)))
+
+(defsubst w3-get-style-info (info node &optional default)
+  (or (cdr-safe (assq info w3-display-css-properties)) default))
+
+(defun w3-decode-area-coords (str)
+  (let (retval)
+    (while (string-match "\\([ \t0-9]+\\),\\([ \t0-9]+\\)" str)
+      (setq retval (cons (vector (string-to-int (match-string 1 str))
+				 (string-to-int (match-string 2 str))) retval)
+	    str (substring str (match-end 0) nil)))
+    (if (string-match "\\([0-9]+\\)" str)
+	(setq retval (cons (vector (+ (aref (car retval) 0)
+				      (string-to-int (match-string 1 str)))
+				   (aref (car retval) 1)) retval)))
+    (nreverse retval)))
+
+(defun w3-normalize-color (color)
+  (cond
+   ((valid-color-name-p color)
+    color)
+   ((valid-color-name-p (concat "#" color))
+    (concat "#" color))
+   ((string-match "[ \t\r\n]" color)
+    (w3-normalize-color
+     (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) ""
+					(char-to-string x)))) color "")))
+   ((valid-color-name-p (font-normalize-color color))
+    (font-normalize-color color))
+   (t
+    (w3-warn 'html (format "Bad color specification: %s" color))
+    nil)))
+
+(defsubst w3-voice-for-element (node)
+  (if (featurep 'emacspeak)
+      (let (family gain left right pitch pitch-range stress richness voice)
+	(setq family (w3-get-style-info 'voice-family node)
+	      gain (w3-get-style-info 'gain node)
+	      left (w3-get-style-info 'left-volume node)
+	      right (w3-get-style-info 'right-volume node)
+	      pitch (w3-get-style-info 'pitch node)
+	      pitch-range (w3-get-style-info 'pitch-range node)
+	      stress (w3-get-style-info 'stress node)
+	      richness (w3-get-style-info 'richness node))
+	(if (or family gain left right pitch pitch-range stress richness)
+	    (setq voice (dtk-personality-from-speech-style
+			 (make-dtk-speech-style :family (or family 'paul)
+						:gain (or gain 5)
+						:left-volume (or left 5)
+						:right-volume (or right 5)
+						:average-pitch (or pitch 5)
+						:pitch-range (or pitch-range 5)
+						:stress (or stress 5)
+						:richness (or richness 5))))
+	  (setq voice nil))
+	(or voice (car w3-active-voices)))))
+
+(defun w3-make-face-emacs19 (name &optional doc-string temporary)
+  "Defines and returns a new FACE described by DOC-STRING.
+If the face already exists, it is unmodified.
+If TEMPORARY is non-nil, this face will cease to exist if not in use."
+  (make-face name))
+
+(cond
+ ((not (fboundp 'make-face))
+  (fset 'w3-make-face 'ignore))
+ (w3-running-xemacs
+  (fset 'w3-make-face 'make-face))
+ (t
+  (fset 'w3-make-face 'w3-make-face-emacs19)))
+
+(defsubst w3-face-for-element (node)
+  (w3-get-all-face-info)
+  (if (car w3-face-text-decoration)
+      (set-font-style-by-keywords w3-face-font-spec
+				  (car w3-face-text-decoration)))
+  (if w3-face-font-variant
+      (set-font-style-by-keywords w3-face-font-spec
+				  (car w3-face-font-variant)))
+  (setq w3-face-descr (list w3-face-font-spec
+			    (car w3-face-color)
+			    (car w3-face-background))
+	w3-face-face (cdr-safe (assoc w3-face-descr w3-face-cache)))
+  (if (or w3-face-face (not (or (car w3-face-color)
+				(car w3-face-background)
+				w3-face-font-spec)))
+      nil				; Do nothing, we got it already
+    (setq w3-face-face
+	  (w3-make-face (intern (format "w3-style-face-%05d" w3-face-index))
+			"An Emacs-W3 face... don't edit by hand." t)
+	  w3-face-index (1+ w3-face-index))
+    (if w3-face-font-spec
+	(set-face-font w3-face-face w3-face-font-spec))
+    (if (car w3-face-color)
+	(set-face-foreground w3-face-face (car w3-face-color)))
+    (if (car w3-face-background)
+	(set-face-background w3-face-face (car w3-face-background)))
+    ;;(set-face-background-pixmap w3-face-face w3-face-pixmap)
+    (setq w3-face-cache (cons
+			 (cons w3-face-descr w3-face-face)
+			 w3-face-cache)))
+  w3-face-face)
+
+(defun w3-normalize-spaces (string)
+  ;; nuke spaces in the middle
+  (while (string-match "[ \t\r\n][ \r\t\n]+" string)
+    (setq string (concat (substring string 0 (1+ (match-beginning 0)))
+			 (substring string (match-end 0)))))
+
+  ;; nuke spaces at the beginning
+  (if (string-match "^[ \t\r\n]+" string)
+      (setq string (substring string (match-end 0))))
+
+  ;; nuke spaces at the end
+  (if (string-match "[ \t\n\r]+$" string)
+      (setq string (substring string 0 (match-beginning 0))))
+  string)
+
+(defvar w3-bullets
+  '((disc   . ?*)
+    (circle . ?o)
+    (square . ?#)
+    )
+  "*An assoc list of unordered list types mapping to characters to use
+as the bullet character.")    
+
+
+(defsubst w3-display-line-break (n)
+  (if (or
+       (memq (car w3-display-whitespace-stack) '(pre nowrap)) ; Been told
+       (= w3-last-fill-pos (point))
+       (> w3-last-fill-pos (point-max)))
+      (if (/= (preceding-char) ?\n) (setq n (1+ n))) ; at least put one line in
+    (let ((fill-column (max (1+ (length fill-prefix)) fill-column))
+	  width)
+      (case (car w3-display-alignment-stack)
+	(center
+	 (fill-region-as-paragraph w3-last-fill-pos (point))
+	 (center-region w3-last-fill-pos (point-max)))
+	((justify full)
+	 (fill-region-as-paragraph w3-last-fill-pos (point) t))
+	(right
+	 (fill-region-as-paragraph w3-last-fill-pos (point))
+	 (goto-char w3-last-fill-pos)
+	 (catch 'fill-exit
+	   (while (re-search-forward ".$" nil t)
+	     (if (>= (setq width (current-column)) fill-column)
+		 nil			; already justified, or error
+	       (beginning-of-line)
+	       (insert-char ?  (- fill-column width))
+	       (end-of-line)
+	       (if (eobp)
+		   (throw 'fill-exit t))
+	       (condition-case ()
+		   (forward-char 1)
+		 (error (throw 'fill-exit t))))))
+	 )
+	(otherwise			; Default is left justification
+	 (fill-region-as-paragraph w3-last-fill-pos (point)))
+	))
+    (setq n (1- n)))
+  (setq w3-last-fill-pos (point-max))
+  (insert (cond
+	   ((<= n 0) "")
+	   ((< n 10)
+	    (aref w3-line-breaks-vector n))
+	   (t
+	    (make-string n ?\n)))))
+
+(defsubst w3-munge-line-breaks-p ()
+  (eq (car w3-display-whitespace-stack) 'pre))
+
+(defvar w3-display-nil-face (w3-make-face nil "Stub face... don't ask." t))
+
+(defvar w3-scratch-start-point nil)
+
+(defsubst w3-handle-string-content (string)
+  (setq w3-scratch-start-point (point))
+  (insert string)
+  (if (w3-munge-line-breaks-p)
+      (progn
+	(goto-char w3-scratch-start-point)
+	(if (not (search-forward "\n" nil t))
+	    (subst-char-in-region w3-scratch-start-point (point-max) ?\r ?\n)
+	  (subst-char-in-region w3-scratch-start-point (point-max) ?\r ? )))
+    (goto-char w3-scratch-start-point)
+    (while (re-search-forward
+	    " [ \t\n\r]+\\|[\t\n\r][ \t\n\r]*"
+	    nil 'move)
+      (replace-match " "))
+    (goto-char w3-scratch-start-point)
+    (if (and (memq (preceding-char) '(?  ?\t ?\r ?\n))
+	     (looking-at "[ \t\r\n]"))
+	(delete-region (point)
+		       (progn
+			 (skip-chars-forward " \t\r\n")
+			 (point)))))
+  (goto-char (point-max))
+  (add-text-properties w3-scratch-start-point
+		       (point) (list 'face w3-active-faces 'duplicable t))
+  (if (car w3-active-voices)
+      (add-text-properties w3-scratch-start-point (point)
+			   (list 'personality (car w3-active-voices))))
+  )
+
+(defun w3-widget-echo (widget &rest ignore)
+  (let ((href (widget-get widget 'href))
+	(name (widget-get widget 'name))
+	(text (buffer-substring (widget-get widget :from)
+				(widget-get widget :to)))
+	(title (widget-get widget 'title))
+	(msg nil))
+    (if href
+	(setq href (url-truncate-url-for-viewing href)))
+    (if name
+	(setq name (concat "anchor:" name)))
+    (case w3-echo-link
+      (url (or href title text name))
+      (text (or text title href name))
+      (title (or title text href name))
+      (otherwise nil))))
+
+(defun w3-follow-hyperlink (widget &rest ignore)
+  (let* ((target (widget-get widget 'target))
+	 (href (widget-get widget 'href)))
+    (if target (setq target (intern (downcase target))))
+    (case target
+      ((_blank external)
+       (w3-fetch-other-frame href))
+      (_top
+       (delete-other-windows)
+       (w3-fetch href))
+      (otherwise
+       (w3-fetch href)))))
+
+(defun w3-balloon-help-callback (object &optional event)
+  (let* ((widget (widget-at (extent-start-position object)))
+	 (href (and widget (widget-get widget 'href))))
+    (if href
+	(url-truncate-url-for-viewing href)
+      nil)))
+
+
+;; Various macros
+(eval-when-compile
+  (defmacro w3-expand-url (url)
+    (`
+     (url-expand-file-name (, url)
+			   (cdr-safe
+			    (assoc
+			     (cdr-safe
+			      (assq 'base args)) w3-base-alist)))))
+
+  (defmacro w3-handle-empty-tag ()
+    (`
+     (progn
+       (push (cons tag args) w3-display-open-element-stack)
+       (push content content-stack)
+       (setq content nil))))
+
+  (defmacro w3-handle-content (node)
+    (`
+     (progn
+       (push (cons tag args) w3-display-open-element-stack)
+       (push content content-stack)
+       (setq content (nth 2 node)))))
+
+  (defmacro w3-display-handle-list-type ()
+    (`
+     (case (car break-style)
+       (list-item
+	(let ((list-style (w3-get-style-info 'list-style node))
+	      (list-num (if (car w3-display-list-stack)
+			    (incf (car w3-display-list-stack))
+			  1))
+	      (margin (1- (car left-margin-stack)))
+	      (indent (w3-get-style-info 'text-indent node 0)))
+	  (if (> indent 0)
+	      (setq margin (+ margin indent))
+	    (setq margin (max 0 (- margin indent))))
+	  (beginning-of-line)
+	  (case list-style
+	    ((disc circle square)
+	     (insert (format (format "%%%dc" margin)
+			     (or (cdr-safe (assq list-style w3-bullets))
+				 ?o))))
+	    ((decimal lower-roman upper-roman lower-alpha upper-alpha)
+	     (let ((x (case list-style
+			(lower-roman
+			 (w3-decimal-to-roman list-num))
+			(upper-roman
+			 (upcase
+			  (w3-decimal-to-roman list-num)))
+			(lower-alpha
+			 (w3-decimal-to-alpha list-num))
+			(upper-alpha
+			 (upcase
+			  (w3-decimal-to-alpha list-num)))
+			(otherwise
+			 (int-to-string list-num)))))
+	       (insert (format (format "%%%ds." margin) x))
+	       )
+	     )
+	    (otherwise
+	     (insert (w3-get-pad-string margin)))
+	    )
+	  )
+	)
+       (otherwise
+	(insert (w3-get-pad-string (+ (car left-margin-stack)
+				      (w3-get-style-info 'text-indent node 0)))))
+       )
+     )
+    )
+
+  (defmacro w3-display-set-margins ()
+    (`
+     (progn
+       (push (+ (w3-get-style-info 'margin-left node 0)
+		(car left-margin-stack)) left-margin-stack)
+       (push (-
+	      (car right-margin-stack)
+	      (w3-get-style-info 'margin-right node 0)) right-margin-stack)
+       (setq fill-column (car right-margin-stack))
+       (w3-set-fill-prefix-length (car left-margin-stack))
+       (w3-display-handle-list-type))))
+
+  (defmacro w3-display-restore-margins ()
+    (`
+     (progn
+       (pop right-margin-stack)
+       (pop left-margin-stack))))
+
+  (defmacro w3-display-handle-break ()
+    (`
+     (case (car break-style)
+       (block				; Full paragraph break
+	(if (eq (cadr break-style) 'list-item)
+	    (setf (cadr break-style) 'line)
+	  (w3-display-line-break 1))
+	(w3-display-set-margins)
+	(push
+	 (w3-get-style-info 'white-space node
+			    (car w3-display-whitespace-stack))
+	 w3-display-whitespace-stack)
+	(push
+	 (or (w3-get-attribute 'align)
+	     (w3-get-style-info 'text-align node
+				(car w3-display-alignment-stack)))
+	 w3-display-alignment-stack)
+	(and w3-do-incremental-display (w3-pause)))
+       ((line list-item)		; Single line break
+	(w3-display-line-break 0)
+	(w3-display-set-margins)
+	(push
+	 (w3-get-style-info 'white-space node
+			    (car w3-display-whitespace-stack))
+	 w3-display-whitespace-stack)
+	(push
+	 (w3-get-style-info 'text-align node
+			    (or (w3-get-attribute 'align)
+				(car w3-display-alignment-stack)))
+	 w3-display-alignment-stack))
+       (otherwise			; Assume 'inline' rendering as default
+	nil))
+     )
+    )
+
+  (defmacro w3-display-handle-end-break ()
+    (`
+     (case (pop break-style)
+       (block				; Full paragraph break
+	(w3-display-line-break 1)
+	(w3-display-restore-margins)
+	(pop w3-display-whitespace-stack)
+	(pop w3-display-alignment-stack)
+	(and w3-do-incremental-display (w3-pause)))
+       ((line list-item)		; Single line break
+	(w3-display-restore-margins)
+	(w3-display-line-break 0)
+	(pop w3-display-whitespace-stack)
+	(pop w3-display-alignment-stack))      
+       (otherwise			; Assume 'inline' rendering as default
+	nil))
+     )
+    )
+  )
+
+;;  handling
+(defun w3-parse-link (args)
+  (let* ((type (if (w3-get-attribute 'rel) 'rel 'rev))
+	 (desc (w3-get-attribute type))
+	 (dc-desc (and desc (downcase desc))) ; canonical case
+	 (dest (w3-get-attribute 'href))
+	 (plist (alist-to-plist args))
+	 (node-1 (assq type w3-current-links))
+	 (node-2 (and node-1 desc (or (assoc desc
+					     (cdr node-1))
+				      (assoc dc-desc
+					     (cdr node-1)))))
+	 )
+    ;; Canonicalize the case of link types we may look for
+    ;; specifically (toolbar etc.) since that's done with
+    ;; assoc.  See `w3-mail-document-author' and
+    ;; `w3-link-toolbar', at least.
+    (if (member dc-desc w3-defined-link-types)
+	(setq desc dc-desc))
+    (if dest				; ignore if HREF missing
+	(cond
+	 (node-2			; Add to old value
+	  (setcdr node-2 (cons plist (cdr node-2))))
+	 (node-1			; first rel/rev
+	  (setcdr node-1 (cons (cons desc (list plist))
+			       (cdr node-1))))
+	 (t (setq w3-current-links
+		  (cons (cons type (list (cons desc (list plist))))
+			w3-current-links)))))
+    (setq desc (and desc (intern dc-desc)))
+    (case desc
+      ((style stylesheet)
+       (w3-handle-style args))
+      (otherwise
+       )
+      )
+    )
+  )
+
+
+;; Image handling
+(defun w3-maybe-start-image-download (widget)
+  (let* ((src (widget-get widget 'src))
+	 (cached-glyph (w3-image-cached-p src)))
+    (if (and cached-glyph (widget-glyphp cached-glyph))
+	(setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting))
+      (cond
+       ((or w3-delay-image-loads	; Delaying images
+	    (not (fboundp 'valid-specifier-domain-p)) ; Can't do images
+	    (eq (device-type) 'tty))	; Why bother?
+	(w3-add-delayed-graphic widget))
+       ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
+	(w3-warn 'images (format "Skipping image %s" (url-basepath src t)))
+	(w3-add-delayed-graphic widget))
+       (t				; Grab the images
+	(let (
+	      (url-request-method "GET")
+	      (old-asynch url-be-asynchronous)
+	      (url-request-data nil)
+	      (url-request-extra-headers nil)
+	      (url-source t)
+	      (url-mime-accept-string (substring
+				       (mapconcat
+					(function
+					 (lambda (x)
+					   (if x
+					       (concat (car x) ",")
+					     "")))
+					w3-allowed-image-types "")
+				       0 -1))
+	      (url-working-buffer (generate-new-buffer-name " *W3GRAPH*")))
+	  (setq-default url-be-asynchronous t)
+	  (setq w3-graphics-list (cons (cons src (make-glyph))
+				       w3-graphics-list))
+	  (save-excursion
+	    (set-buffer (get-buffer-create url-working-buffer))
+	    (setq url-current-callback-data (list widget)
+		  url-be-asynchronous t
+		  url-current-callback-func 'w3-finalize-image-download)
+	    (url-retrieve src))
+	  (setq-default url-be-asynchronous old-asynch)))))))
+
+(defun w3-finalize-image-download (widget)
+  (let ((glyph nil)
+	(url (widget-get widget 'src))
+	(node nil)
+	(buffer (widget-get widget 'buffer)))
+    (message "Enhancing image...")
+    (setq glyph (image-normalize (cdr-safe (assoc url-current-mime-type
+						  w3-image-mappings))
+				 (buffer-string)))
+    (message "Enhancing image... done")
+    (kill-buffer (current-buffer))
+    (cond
+     ((w3-image-invalid-glyph-p glyph)
+      (setq glyph nil)
+      (w3-warn 'image (format "Reading of %s failed." url)))
+     ((eq (aref glyph 0) 'xbm)
+      (let ((temp-fname (url-generate-unique-filename "%s.xbm")))
+	(save-excursion
+	  (set-buffer (generate-new-buffer " *xbm-garbage*"))
+	  (erase-buffer)
+	  (insert (aref glyph 2))
+	  (setq glyph temp-fname)
+	  (write-region (point-min) (point-max) temp-fname)
+	  (kill-buffer (current-buffer)))
+	(setq glyph (make-glyph (list (cons 'x glyph))))
+	(condition-case ()
+	    (delete-file temp-fname)
+	  (error nil))))
+     (t
+      (setq glyph (make-glyph glyph))))
+    (setq node (assoc url w3-graphics-list))
+    (cond
+     ((and node glyph)
+      (set-glyph-image (cdr node) (glyph-image glyph)))
+     (glyph
+      (setq w3-graphics-list (cons (cons url glyph) w3-graphics-list)))
+     (t nil))
+
+    (if (and (buffer-name buffer)	; Dest. buffer exists
+	     (widget-glyphp glyph))	; got a valid glyph
+	(save-excursion
+	  (set-buffer buffer)
+	  (if (eq major-mode 'w3-mode)
+	      (widget-value-set widget glyph)
+	    (setq w3-image-widgets-waiting
+		  (cons widget w3-image-widgets-waiting)))))))
+
+(defmacro w3-node-visible-p ()
+  (` (not (eq (car break-style) 'none))))
+
+(defmacro w3-handle-image ()
+  (`
+   (let* ((height (w3-get-attribute 'height))
+	  (width (w3-get-attribute 'width))
+	  (src (or (w3-get-attribute 'src) "Error Image"))
+	  (our-alt (cond
+		    ((null w3-auto-image-alt) "")
+		    ((eq t w3-auto-image-alt)
+		     (concat "[IMAGE(" (url-basepath src t) ")] "))
+		    ((stringp w3-auto-image-alt)
+		     (format w3-auto-image-alt (url-basepath src t)))))
+	  (alt (or (w3-get-attribute 'alt) our-alt))
+	  (ismap (and (assq 'ismap args) 'ismap))
+	  (usemap (w3-get-attribute 'usemap))
+	  (base (w3-get-attribute 'base))
+	  (href (and hyperlink-info (widget-get (cadr hyperlink-info) 'href)))
+	  (widget nil)
+	  (align (or (w3-get-attribute 'align)
+		     (w3-get-style-info 'vertical-align node))))
+     (setq widget (widget-create 'image
+				 :value-face w3-active-faces
+				 'src src ; Where to load the image from
+				 'alt alt ; Textual replacement
+				 'ismap ismap ; Is it a server-side map?
+				 'usemap usemap	; Is it a client-side map?
+				 'href href ; Hyperlink destination
+				 ))
+     (widget-put widget 'buffer (current-buffer))
+     (w3-maybe-start-image-download widget)
+     (goto-char (point-max)))))
+
+;; The table handling
+
+(defvar w3-display-table-cut-words-p nil
+  "*Whether to cut words that are oversized in table cells")
+  
+(defvar w3-display-table-force-borders nil
+  "*Whether to always draw table borders")
+
+(defun w3-display-table-cut ()
+  (save-excursion
+    (goto-char (point-min))
+    (let ((offset -1))
+      (while (< offset 0)
+  	(end-of-line)
+  	(setq offset (- fill-column (current-column)))
+  	(cond ((< offset 0)
+  	       (condition-case nil
+  		   (progn (forward-char offset)
+  			  (insert ?\n))
+ 		 (error (setq offset 0))))
+  	      ((not (eobp))
+  	       (forward-line 1)
+  	       (setq offset -1)))))))
+
+
+(defun w3-display-fix-widgets ()
+  ;; Make markers belong to the right buffer
+  (save-excursion
+    (let ((st (point-min))
+ 	  (nd nil)
+	  (widget nil) parent
+ 	  (to-marker nil)
+ 	  (from-marker nil))
+      (while (setq st (next-single-property-change st 'button))
+ 	(setq nd (or (next-single-property-change st 'button) (point-max))
+ 	      widget (widget-at st)
+ 	      to-marker (and widget (widget-get widget :to))
+ 	      from-marker (and widget (widget-get widget :from))
+ 	      parent (and widget (widget-get widget :parent))
+ 	      )
+	(if (not widget)
+	    nil
+	  (widget-put widget :from (set-marker (make-marker) st))
+	  (widget-put widget :to   (set-marker (make-marker) nd))
+	  (if (not parent)
+	      nil
+	    (widget-put parent :from (set-marker (make-marker) st))
+	    (widget-put parent :to   (set-marker (make-marker) nd))))
+ 	(if (condition-case ()
+ 		(get-text-property (1+ nd) 'button)
+ 	      (error nil))
+ 	    (setq st nd)
+ 	  (setq st (min (point-max) (1+ nd))))))))
+
+(defun w3-size-of-tree (tree minmax)
+  (save-excursion
+    (save-restriction
+      (narrow-to-region (point) (point))
+      ;; XXX fill-column set to 1 fails when fill-prefix is set
+      ;; XXX setting fill-column at all isn't really right
+      ;; for example 
    s shouldn't be especially wide
+      ;; we should set a flag that makes w3 never wrap a line
+      (let ((fill-column (cond ((eq minmax 'min)
+				3)
+			       ((eq minmax 'max)
+				400))) 
+	    (fill-prefix "")
+	    (w3-last-fill-pos (point-min))
+	    a retval
+	    (w3-do-incremental-display nil)
+	    (hr-regexp  (concat "^"
+				(regexp-quote 
+				 (make-string 5 w3-horizontal-rule-char)) 
+				"*$"))
+	    )
+	;;(push 'left  w3-display-alignment-stack)
+	(push (if (eq minmax 'max) 'nowrap) w3-display-whitespace-stack)
+	(while tree
+	  (push (cons '*td args) w3-display-open-element-stack)
+	  (w3-display-node (pop tree)))
+	(pop w3-display-whitespace-stack)
+	(goto-char (point-min))
+	(while (re-search-forward hr-regexp nil t)
+	  (replace-match "" t t))
+	(goto-char (point-min))
+	(while (not (eobp))
+	  ;; loop invariant: at beginning of uncounted line
+	  (end-of-line)
+	  (skip-chars-backward " ")
+	  (setq retval (cons (current-column)
+			     retval))
+	  (beginning-of-line 2))
+	(if (= (point-min) (point-max))
+	    (setq retval 0)
+	  (setq retval (apply 'max (cons 0 retval))))
+	(delete-region (point-min) (point-max))
+	retval))))
+
+(defun w3-display-table-dimensions (node)
+  ;; fill-column sets maximum width
+  (let (min-vector
+	max-vector
+	rows cols
+	;;(w3-form-elements (and (boundp 'w3-form-elements) w3-form-elements))
+	(table-info (assq 'w3-table-info (cadr node)))) 
+    
+    (if table-info 
+	(setq min-vector (nth 1 table-info)
+	      max-vector (nth 2 table-info)
+	      rows       (nth 3 table-info)
+	      cols       (nth 4 table-info))
+
+      (push (cons '*table-autolayout args) w3-display-open-element-stack)
+      (let (content
+	    cur
+	    (table-spans (list nil))	; don't make this '(nil) 
+	    ptr
+	    col
+	    constraints
+	    
+	    colspan rowspan min max)
+	(setq content (nth 2 node))
+	(setq rows 0 cols 0)
+	(while content
+	  (setq cur (pop content))
+	  (if (stringp cur)
+	      nil
+	    (case (car cur)
+	      (tr
+	       (setq col 0)
+	       (setq rows (1+ rows))
+	       (setq ptr table-spans)
+	       (mapcar
+		(function
+		 (lambda (td)
+		   (setq colspan (string-to-int (or (cdr-safe (assq 'colspan (nth 1 td))) "1"))
+			 rowspan (string-to-int (or (cdr-safe (assq 'rowspan (nth 1 td))) "1"))
+			 min  (w3-size-of-tree  (nth 2 td) 'min)
+			 max  (w3-size-of-tree  (nth 2 td) 'max)
+			 )
+		   (while (eq (car-safe (car-safe (cdr ptr))) col)
+		     (setq col (+ col (cdr (cdr (car (cdr ptr))))))
+		     (if (= 0 (decf (car (cdr (car (cdr ptr))))))
+			 (pop (cdr ptr))
+		       (setq ptr (cdr ptr))))
+		   (push (list col colspan min max)
+			 constraints)
+		   (if (= rowspan 1) nil
+		     (push (cons col (cons (1- rowspan) colspan)) (cdr ptr))
+		     (setq ptr (cdr ptr)))
+		   (setq col (+ col colspan))
+		   ))
+		(nth 2 cur))
+	       (while (cdr ptr)
+		 (if (= 0 (decf (car (cdr (car (cdr ptr))))))
+		     (pop (cdr ptr))
+		   (setq ptr (cdr ptr))))
+	       (setq cols (max cols col))
+	       )
+	      (caption
+	       nil)
+	      (otherwise
+	       (setq content (nth 2 cur)))
+	      )
+	    )
+	  )
+	(setq constraints (sort constraints
+				(function
+				 (lambda (a b)
+				   (< (cadr a) (cadr b)))))
+	      min-vector (make-vector cols 0)
+	      max-vector (make-vector cols 0))
+	(let (start end i mincellwidth maxcellwidth)
+	  (mapcar (function (lambda (c)
+			      (cond ((= (cadr c) 1) 
+				     (aset min-vector (car c) 
+					   (max (aref min-vector (car c))
+						(nth 2 c)))
+				     (aset max-vector (car c) 
+					   (max (aref max-vector (car c))
+						(nth 3 c))))
+				    (t 
+				     (setq start (car c)
+					   end (+ (car c) (cadr c))
+					   mincellwidth 0
+					   maxcellwidth 0
+					   i start)
+				     (while (< i end)
+				       (setq mincellwidth (+ mincellwidth
+							     (aref min-vector i))
+					     maxcellwidth (+
+							   maxcellwidth
+							   (aref max-vector i))
+					     i (1+ i)))
+				     (setq i start)
+				     (if (= mincellwidth 0)
+					 ;; if existing width is 0 divide evenly
+					 (while (< i end)
+					   (aset min-vector i
+						 (/ (nth 2 c) (cadr c)))
+					   (aset max-vector i
+						 (/ (nth 3 c) (cadr c)))
+					   (setq i (1+ i)))
+				       ;; otherwise weight it by existing widths
+				       (while (< i end)
+					 (aset min-vector i
+					       (max (aref min-vector i)
+						    (/ (* (nth 2 c)
+							  (aref min-vector i))
+						       mincellwidth)))
+					 (aset max-vector i
+					       (max (aref max-vector i)
+						    (/ (* (nth 3 c)
+							  (aref max-vector i))
+						       maxcellwidth)))
+					 (setq i (1+ i))))
+				     ))))
+		  constraints)))
+      (push (cons 'w3-table-info
+		  (list min-vector max-vector rows cols))
+	    (cadr node))
+      (pop w3-display-open-element-stack))
+    
+    (let (max-width
+	  min-width 
+	  ret-vector
+	  col
+	  )
+    
+
+      (setq max-width (apply '+ (append max-vector (list cols 1))))
+      (setq min-width (apply '+ (append min-vector (list cols 1))))
+
+      ;; the comments in the cond are excerpts from rfc1942 itself
+      (cond 
+       ;;   1.  The minimum table width is equal to or wider than the available
+       ;;       space. In this case, assign the minimum widths and allow the
+       ;;       user to scroll horizontally. For conversion to braille, it will
+       ;;       be necessary to replace the cells by references to notes
+       ;;       containing their full content. By convention these appear
+       ;;       before the table.
+       ((>= min-width fill-column)
+	(setq ret-vector min-vector))
+     
+       ;;   2.  The maximum table width fits within the available space. In
+       ;;       this case, set the columns to their maximum widths.
+       ((<= max-width fill-column)
+	(setq ret-vector max-vector))
+     
+       ;;   3.  The maximum width of the table is greater than the available
+       ;;       space, but the minimum table width is smaller. In this case,
+       ;;       find the difference between the available space and the minimum
+       ;;       table width, lets call it W. Lets also call D the difference
+       ;;       between maximum and minimum width of the table.
+     
+       ;;       For each column, let d be the difference between maximum and
+       ;;       minimum width of that column. Now set the column's width to the
+       ;;       minimum width plus d times W over D. This makes columns with
+       ;;       large differences between minimum and maximum widths wider than
+       ;;       columns with smaller differences.
+       (t
+	(setq ret-vector (make-vector cols 0))
+	(let ((W (- fill-column min-width))
+	      (D (- max-width min-width))
+	      d extra)
+	  (setq col 0)
+	  (while (< col (length ret-vector))
+	    (setq d (- (aref max-vector col)
+		       (aref min-vector col)))
+	    (aset ret-vector col 
+		  (+ (aref min-vector col)
+		     (/ (* d W) D)))
+	    (setq col (1+ col)))
+	  (setq extra (- fill-column
+			 (apply '+ (append ret-vector
+					   (list (length ret-vector) 1))))
+		col 0)
+	  (while (and (< col (length ret-vector)) (> extra 0))
+	    (if (= 1 (- (aref max-vector col) (aref ret-vector col) ))
+		(aset ret-vector col (1+ (aref ret-vector col))))
+	    (setq extra (1- extra)
+		  col (1+ col)))
+	  )))
+      (list rows cols ret-vector))))
+
+(defvar w3-table-ascii-border-chars
+  [?  ?  ?  ?/ ?  ?- ?\\ ?- ?  ?\\ ?| ?| ?/ ?- ?| ?-]
+  "Vector of ascii characters to use to draw table borders.
+w3-table-unhack-border-chars uses this to restore w3-table-border-chars.")
+
+(defvar w3-table-border-chars w3-table-ascii-border-chars
+  "Vector of characters to use to draw table borders.
+If you set this you should set w3-table-ascii-border-chars to the same value
+so that w3-table-unhack-borders can restore the value if necessary.
+
+A reasonable value is [?  ?  ?  ?/ ?  ?- ?\\\\ ?^ ?  ?\\\\ ?| ?< ?/ ?- ?> ?-]
+Though i recommend replacing the ^ with - and the < and > with |")
+
+(defsubst w3-table-lookup-char (l u r b)
+  (aref w3-table-border-chars (logior (if l 1 0)
+				      (if u 2 0)
+				      (if r 4 0)
+				      (if b 8 0))))
+
+(defun w3-table-hack-borders nil
+  "Try to find the best set of characters to draw table borders with.
+I definitely recommend trying this on X. 
+On a console, this can trigger some Emacs display bugs.
+
+I haven't tried this on XEmacs or any window-system other than X."
+  (interactive)
+  (case (device-type)
+    (x
+     (let ((id (or (and (find-face 'w3-table-hack-x-face)
+			(face-id 'w3-table-hack-x-face))
+		   (progn
+		     (make-face 'w3-table-hack-x-face)
+		     (set-face-font 'w3-table-hack-x-face
+				    (make-font :family "terminal"))
+		     (face-id 'w3-table-hack-x-face)))))
+       (if (not (face-differs-from-default-p 'w3-table-hack-x-face))
+	   nil
+	 (aset standard-display-table 1 (vector (+ (* 256 id) ?l)))
+	 (aset standard-display-table 2 (vector (+ (* 256 id) ?q)))
+	 (aset standard-display-table 3 (vector (+ (* 256 id) ?k)))
+	 (aset standard-display-table 4 (vector (+ (* 256 id) ?t)))
+	 (aset standard-display-table 5 (vector (+ (* 256 id) ?n)))
+	 (aset standard-display-table 6 (vector (+ (* 256 id) ?u)))
+	 (aset standard-display-table 7 (vector (+ (* 256 id) ?m)))
+	 (aset standard-display-table 8 (vector (+ (* 256 id) ?x)))
+	 (aset standard-display-table 11 (vector (+ (* 256 id) ?j)))
+	 (aset standard-display-table 14 (vector (+ (* 256 id) ?v)))
+	 (aset standard-display-table 15 (vector (+ (* 256 id) ?w)))
+	 (setq w3-table-border-chars [?  ?  ?  11 ?  2 7 14 ?  3 8 6 1 15 4 5])
+	 (setq w3-horizontal-rule-char 2))))
+    (tty
+     (standard-display-g1 1 108)	; ulcorner 
+     (standard-display-g1 2 113)	; hline
+     (standard-display-g1 3 107)	; urcorner
+     (standard-display-g1 4 116)	; leftt
+     (standard-display-g1 5 110)	; intersection
+     (standard-display-g1 6 117)	; rightt
+     (standard-display-g1 7 109)	; llcorner
+     (standard-display-g1 8 120)	; vline
+     (standard-display-g1 11 106)	; lrcorner
+     (standard-display-g1 14 118)	; upt
+     (standard-display-g1 15 119)	; downt
+     (setq w3-table-border-chars [?  ?  ?  11 ?  2 7 14 ?  3 8 6 1 15 4 5])
+     (setq w3-horizontal-rule-char 2))
+    (otherwise
+     (error "Unknown window-system, can't do any better than ascii borders")))
+  )
+  
+(defun w3-table-unhack-borders nil
+  (interactive)
+  (w3-table-excise-hack (buffer-list))
+  (standard-display-default 1 15)
+  (setq w3-table-border-chars w3-table-ascii-border-chars)
+  (setq w3-horizontal-rule-char ?-))
+
+(defun w3-table-excise-hack (buffs)
+  "Replace hacked characters with ascii characters in buffers BUFFS.
+Should be run before restoring w3-table-border-chars to ascii characters."
+  (interactive (list (list (current-buffer))))
+  (let ((inhibit-read-only t)
+	(tr (make-string 16 ? ))
+	(i 0))
+    (while (< i (length tr))
+      (aset tr i i)
+      (setq i (1+ i)))
+    (setq i 0)
+    (while (< i (length w3-table-border-chars))
+      (if (< (aref w3-table-border-chars i) 16)
+	  (aset tr 
+		(aref w3-table-border-chars i)
+		(aref w3-table-ascii-border-chars i)))
+      (setq i (1+ i)))
+    (mapcar (function (lambda (buf)
+			(save-excursion
+			  (set-buffer buf)
+			  (if (eq major-mode 'w3-mode)
+			      (translate-region (point-min)
+						(point-max)
+						tr)))))
+	    buffs)))
+
+(defun w3-display-table (node)
+  (let* ((dimensions (w3-display-table-dimensions node))
+	 (num-cols (max (cadr dimensions) 1))
+	 (num-rows (max (car dimensions) 1))
+	 (column-dimensions (caddr dimensions))
+	 (table-width (apply '+ (append column-dimensions (list num-cols 1)))))
+    (cond
+     ((or (<= (cadr dimensions) 0) (<= (car dimensions) 0))
+      ;; We have an invalid table
+      nil)
+     ((assq '*table-autolayout w3-display-open-element-stack)
+      ;; don't bother displaying the table if all we really need is the size
+      (progn (insert-char ?T table-width) (insert "\n")))
+     (t
+      (let* ((tag  (nth 0 node))
+	     (args (nth 1 node))
+	     (border-node (cdr-safe (assq 'border args)))
+	     (border (or w3-display-table-force-borders
+			 (and border-node
+			      (or (/= 0 (string-to-int border-node))
+				  (string= "border" border-node)))))
+	     (w3-table-border-chars
+	      (if border
+		  w3-table-border-chars
+		(make-vector (length w3-table-border-chars) ? )))
+	     valign align 
+	     (content (nth 2 node))
+	     (avgwidth (/ (- fill-column num-cols num-cols) num-cols))
+	     (formatted-cols (make-vector num-cols nil))
+	     (table-rowspans (make-vector num-cols 0))
+	     (table-colspans (make-vector num-cols 1))
+	     (prev-colspans  (make-vector num-cols 0))
+	     (prev-rowspans  (make-vector num-cols 0))
+	     (table-colwidth (make-vector num-cols 0))
+	     (fill-prefix "")
+	     (height nil)
+	     (cur-height nil)
+	     (cols nil)
+	     (rows nil)
+	     (row 0)
+	     (this-rectangle nil)
+	     (i 0)
+	     )
+
+	(push (cons tag args) w3-display-open-element-stack)
+
+	(if (memq 'nowrap w3-display-whitespace-stack)
+	    (setq fill-prefix "")
+	  (case (car w3-display-alignment-stack)
+	    (center
+	     (w3-set-fill-prefix-length
+	      (max 0 (/ (- fill-column table-width) 2))))
+	    (right
+	     (w3-set-fill-prefix-length
+	      (max 0 (- fill-column table-width))))
+	    (t
+	     (setq fill-prefix ""))))
+	(while content
+	  (case (caar content)
+	    (tr
+	     (setq w3-display-css-properties (css-get
+					      (nth 0 (car content))
+					      (nth 1 (car content))
+					      w3-current-stylesheet
+					      w3-display-open-element-stack))
+	     (setq cols (nth 2 (car content))
+		   valign (or (cdr-safe (assq 'valign (nth 1 (car content))))
+			      (w3-get-style-info 'vertical-align node))
+		   align  (or (cdr-safe (assq 'align  (nth 1 (car content))))
+			      (w3-get-style-info 'text-align node))
+		   content (cdr content)
+		   row (1+ row))
+	     (if (and valign (stringp valign))
+		 (setq valign (intern (downcase valign))))
+	     ;; this is iffy
+	     ;;(if align (push (intern (downcase align)) w3-display-alignment-stack))
+	     (save-excursion
+	       (save-restriction
+		 (narrow-to-region (point) (point))
+		 (setq fill-column avgwidth
+		       inhibit-read-only t
+		       w3-last-fill-pos (point-min)
+		       i 0)
+		 ;; skip over columns that have leftover content
+		 (while (and (< i num-cols)
+			     (/= 0 (aref table-rowspans i)))
+		   (setq i (+ i (max 1 (aref table-colspans i)))))
+		 (while cols
+		   (let* ((node (car cols))
+			  (attributes (nth 1 node))
+			  (colspan (string-to-int
+				    (or (cdr-safe (assq 'colspan attributes))
+					"1")))
+			  (rowspan (string-to-int
+				    (or (cdr-safe (assq 'rowspan attributes))
+					"1")))
+			  fill-column column-width
+			  (fill-prefix "")
+			  (w3-do-incremental-display nil)
+			  (indent-tabs-mode nil)
+			  c e
+			  )
+
+		     (aset table-colspans i colspan)
+		     (aset table-rowspans i rowspan)
+
+		     (setq fill-column 0)
+		     (setq c i
+			   e (+ i colspan))
+		     (while (< c e)
+		       (setq fill-column (+ fill-column 
+					    (aref column-dimensions c)
+					    1)
+			     c (1+ c)))
+		     (setq fill-column (1- fill-column))
+		     (aset table-colwidth i fill-column)
+
+		     (setq w3-last-fill-pos (point-min))
+		     (push (cons (nth 0 node) (nth 1 node))
+			   w3-display-open-element-stack)
+		     (w3-display-node node)
+		     (setq fill-column (aref table-colwidth i))
+		     (if w3-display-table-cut-words-p
+			 (w3-display-table-cut))
+		     (setq cols (cdr cols))
+		     (goto-char (point-min))
+		     (skip-chars-forward "\t\n\r")
+		     (beginning-of-line)
+		     (delete-region (point-min) (point))
+		     (goto-char (point-max))
+		     (skip-chars-backward " \t\n\r")
+		     (delete-region (point) (point-max))
+		     (if (>= fill-column (current-column))
+			 (insert-char ?  (- fill-column (current-column))))
+		     (aset formatted-cols i (extract-rectangle (point-min) (point-max)))
+		     (delete-region (point-min) (point-max))
+		     (let ((j (1- colspan)))
+		       (while (> j 0)
+			 (aset table-colspans (+ i j) 0)
+			 (setq j (1- j))))		
+		     (setq i (+ i colspan))
+		     ;; skip over columns that have leftover content
+		     (while (and (< i num-cols)
+				 (/= 0 (aref table-rowspans i)))
+		       (setq i (+ i (max 1 (aref table-colspans i)))))
+		     ))
+
+		 ;; finish off the columns
+		 (while (< i num-cols)
+		   (aset table-colwidth i (aref column-dimensions i))
+		   (aset table-colspans i 1)
+		   (setq i (1+ i))
+		   (while (and (< i num-cols)
+			       (/= 0 (aref table-rowspans i)))
+		     (setq i (+ i (max 1 (aref table-colspans i))))))
+
+		 ;; on the last row empty any pending rowspans per the rfc
+		 (if content nil
+		   (fillarray table-rowspans 1)) 
+
+		 ;; Find the tallest rectangle that isn't a rowspanning cell
+		 (setq height 0 
+		       i 0)
+		 (while (< i num-cols)
+		   (if (= 1 (aref table-rowspans i))
+		       (setq height (max height (length (aref formatted-cols i)))))
+		   (setq i (+ i (max 1 (aref table-colspans i)))))
+
+		 ;; Make all rectangles the same height
+		 (setq i 0)
+		 (while (< i num-cols)
+		   (setq this-rectangle (aref formatted-cols i))
+		   (if (> height (length this-rectangle))
+		       (let ((colspan-fill-line
+			      (make-string (aref table-colwidth i) ? )))
+			 (case valign
+			   ((center middle)
+			    (aset formatted-cols i
+				  (append (make-list (/ (- height (length this-rectangle)) 2) 
+						     colspan-fill-line)
+					  this-rectangle)))
+			   (bottom
+			    (aset formatted-cols i 
+				  (append (make-list (- height (length this-rectangle))
+						     colspan-fill-line)
+					  this-rectangle))))))
+		   (setq i (+ i (max 1 (aref table-colspans i)))))))
+	     
+
+	     ;; fix broken colspans (this should only matter on illegal tables)
+	     (setq i 0)
+	     (while (< i num-cols)
+	       (if (= (aref table-colspans i) 0)
+		   (aset table-colspans i 1))
+	       (setq i (+ i (aref table-colspans i))))
+
+	     ;; Insert a separator 
+	     (insert fill-prefix)
+	     (setq i 0)
+	     (let (rflag bflag tflag lflag)
+	       (while (< i num-cols)
+
+		 (setq rflag (= (aref prev-rowspans i) 0))
+		 (setq bflag (/= (aref table-colspans i) 0))
+		 (setq tflag (/= (aref prev-colspans  i) 0))
+
+		 (insert (w3-table-lookup-char lflag tflag rflag bflag))
+		 (setq lflag t)
+		 (cond ((= (aref prev-rowspans i) 0)
+			(insert-char (w3-table-lookup-char t nil t nil) 
+				     (aref column-dimensions i))
+			(setq i (1+ i)))
+		       ((car (aref formatted-cols i))
+			(insert (pop (aref formatted-cols i)))
+			(setq lflag nil)
+			(setq i (+ i (max (aref table-colspans i)
+					  (aref prev-colspans  i) 1))))
+		       (t
+			(insert-char ?  (aref table-colwidth i))
+			(setq lflag nil)
+			(setq i (+ i (max (aref table-colspans i)
+					  (aref prev-colspans  i) 1))))))
+	       (insert (w3-table-lookup-char lflag (/= row 1) nil t) "\n"))
+
+	     ;; recalculate height (in case we've shortened a rowspanning cell
+	     (setq height 0 
+		   i 0)
+	     (while (< i num-cols)
+	       (if (= 1 (aref table-rowspans i))
+		   (setq height (max height (length (aref formatted-cols i)))))
+	       (setq i (+ i (max 1 (aref table-colspans i)))))
+
+	     ;; Insert a row back in original buffer
+	     (while (> height 0)
+	       (insert fill-prefix (w3-table-lookup-char nil t nil t))
+	       (setq i 0)
+	       (while (< i num-cols)
+		 (if (car (aref formatted-cols i))
+		     (insert (pop (aref formatted-cols i))) 
+		   (insert-char ?  (aref table-colwidth i))) 
+		 (insert (w3-table-lookup-char nil t nil t))
+		 (setq i (+ i (max (aref table-colspans i) 1))))
+	       (insert "\n")
+	       ;;(and w3-do-incremental-display (w3-pause))
+	       (setq height (1- height)))
+	     
+	     (setq i 0)
+	     (while (< i num-cols)
+	       (if (> (aref table-rowspans i) 0)
+		   (decf (aref table-rowspans i)))
+	       (incf i))
+	     
+	     (setq prev-rowspans (copy-seq table-rowspans))
+	     (setq prev-colspans (copy-seq table-colspans))
+	 
+	     (and w3-do-incremental-display (w3-pause))
+
+	     )
+	    (caption
+	     (let ((left (length fill-prefix))
+		   (fill-prefix "")
+		   (fill-column table-width)
+		   (start (point)))
+	       (w3-display-node (pop content))
+	       (indent-rigidly start (point) left)))
+	    (otherwise			
+	     (delete-horizontal-space)
+	     (setq content (nth 2 (car content))))
+	    ))
+	(if (= (length column-dimensions) 0) nil
+	  (insert fill-prefix)
+	  (setq i 0)
+	  (let (tflag lflag)
+	    (while (< i num-cols)
+	      (setq tflag (/= (aref prev-colspans  i) 0))
+	      (insert (w3-table-lookup-char lflag tflag t nil))
+	      (setq lflag t)
+	      (insert-char (w3-table-lookup-char t nil t nil) 
+			   (aref column-dimensions i))
+	      (setq i (1+ i)))
+	    (insert (w3-table-lookup-char t t nil nil) "\n")))
+	)
+      (pop w3-display-open-element-stack)))))
+
+
+
+(defun w3-display-create-unique-id ()
+  (let* ((date (current-time-string))
+	 (dateinfo (and date (timezone-parse-date date)))
+	 (timeinfo (and date (timezone-parse-time (aref dateinfo 3)))))
+    (if (and dateinfo timeinfo)
+	(concat (aref dateinfo 0)	; Year
+		(aref dateinfo 1)	; Month
+		(aref dateinfo 2)	; Day
+		(aref timeinfo 0)	; Hour
+		(aref timeinfo 1)	; Minute 
+		(aref timeinfo 2)	; Second
+		)
+      "HoplesSLYCoNfUSED")))
+
+(defun w3-display-node (node &optional nofaces)
+  (let (
+	(content-stack (list (list node)))
+	(right-margin-stack (list fill-column))
+	(left-margin-stack (list 0))
+	node
+	insert-before
+	insert-after
+	tag
+	args
+	content
+	hyperlink-info
+	break-style
+	cur
+	id
+	class
+	)
+    (while content-stack
+      (setq content (pop content-stack))
+      (pop w3-active-faces)
+      (pop w3-active-voices)
+      (case (car (pop w3-display-open-element-stack))
+	;; Any weird, post-display-of-content stuff for specific tags
+	;; goes here.   Couldn't think of any better way to do this when we
+	;; are iterative.  *sigh*
+	(a
+	 (if (not hyperlink-info)
+	     nil
+	   (add-text-properties (car hyperlink-info) (point)
+				(list
+				 'mouse-face 'highlight
+				 'duplicable t
+				 'help-echo 'w3-balloon-help-callback
+				 'balloon-help 'w3-balloon-help-callback))
+	   (fillin-text-property (car hyperlink-info) (point)
+				 'button 'button (cadr hyperlink-info))
+	   (widget-put (cadr hyperlink-info) :to (set-marker
+						  (make-marker) (point))))
+	 (setq hyperlink-info nil))
+	(form
+	 (pop w3-display-form-stack))
+	((ol ul dl dir menu)
+	 (pop w3-display-list-stack))
+	(otherwise
+	 nil))
+      (if (car insert-after)
+	  (w3-handle-string-content (car insert-after)))
+      (pop insert-after)
+      (w3-display-handle-end-break)
+      (w3-pop-all-face-info)
+      ;; Handle the element's content
+      (while content
+	(if (stringp (car content))
+	    (w3-handle-string-content (pop content))
+	  (setq node (pop content)
+		tag (nth 0 node)
+		args (nth 1 node)
+		id (or (w3-get-attribute 'name)
+		       (w3-get-attribute 'id))
+		)
+	  ;; This little bit of magic takes care of inline styles.
+	  ;; Evil Evil Evil, but it appears to work.
+	  (if (w3-get-attribute 'style)
+	      (let ((unique-id (or (w3-get-attribute 'id)
+				   (w3-display-create-unique-id)))
+		    (sheet ""))
+		(setq sheet (format "%s.%s { %s }\n" tag unique-id
+				    (w3-get-attribute 'style)))
+		(setf (nth 1 node) (cons (cons 'id unique-id) args))
+		(w3-handle-style (list (cons 'data sheet)
+				       (cons 'notation "css")))))
+	  (setq w3-display-css-properties (css-get
+					   (nth 0 node) (nth 1 node)
+					   w3-current-stylesheet
+					   w3-display-open-element-stack))
+	  (if nofaces
+	      nil
+	    (push (w3-face-for-element node) w3-active-faces)
+	    (push (w3-voice-for-element node) w3-active-voices))
+	  (push (w3-get-style-info 'display node) break-style)
+	  (push (w3-get-style-info 'insert-after node) insert-after)
+	  (setq insert-before (w3-get-style-info 'insert-before node))
+	  (w3-display-handle-break)
+	  (if (w3-node-visible-p)
+	      nil
+	    (setq insert-before nil
+		  tag '*invisible)
+	    (setcar insert-after nil))
+	  (if insert-before
+	      (w3-handle-string-content insert-before))
+	  (setq insert-before nil)
+	  (if id
+	      (setq w3-id-positions (cons
+				     (cons (intern id)
+					   (set-marker (make-marker)
+						       (point-max)))
+				     w3-id-positions)))
+	  (case tag
+	    (a				; Hyperlinks
+	     (let* (
+		    (title (w3-get-attribute 'title))
+		    (name (or (w3-get-attribute 'id)
+			      (w3-get-attribute 'name)))
+		    (btdt nil)
+		    class
+		    (before nil)
+		    (after nil)
+		    (face nil)
+		    (voice nil)
+		    (st nil))
+	       (setq st (point)
+		     hyperlink-info (list
+				     st
+				     (append 
+				      (list 'link :args nil
+					    :value "" :tag ""
+					    :action 'w3-follow-hyperlink
+					    :from
+					    (set-marker (make-marker) st)
+					    :help-echo 'w3-widget-echo
+					    )
+				      (alist-to-plist args))))
+	       (w3-handle-content node)
+	       )
+	     )
+	    ((ol ul dl dir menu)
+	     (push 0 w3-display-list-stack)
+	     (w3-handle-content node))
+	    (img			; inlined image
+	     (w3-handle-image)
+	     (w3-handle-empty-tag))
+	    (script			; Scripts
+	     (w3-handle-empty-tag))
+	    ((embed object)		; Embedded images/content
+	     (w3-handle-content node)
+	     )
+	    (hr				; Cause line break & insert rule
+	     (let* ((perc (or (w3-get-attribute 'width)
+			      (w3-get-style-info 'width node)
+			      "100%"))
+		    (rule nil)
+		    (width nil))
+	       (setq perc (/ (min (string-to-int perc) 100) 100.0)
+		     width (* fill-column perc)
+		     rule (make-string (max (truncate width) 0)
+				       w3-horizontal-rule-char)
+		     node (list 'hr nil (list rule)))
+	       (w3-handle-content node)))
+	    (map			; Client side imagemaps
+	     (let ((name (or (w3-get-attribute 'name)
+			     (w3-get-attribute 'id)
+			     "unnamed"))
+		   (areas
+		    (mapcar
+		     (function
+		      (lambda (node)
+			(let* ((args (nth 1 node))
+			       (type (downcase (or
+						(w3-get-attribute 'shape)
+						"rect")))
+			       (coords (w3-decode-area-coords
+					(or (cdr-safe
+					     (assq 'coords args)) "")))
+			       (alt (w3-get-attribute 'alt))
+			       (href (if (assq 'nohref args)
+					 t
+				       (or (w3-get-attribute 'src)
+					   (w3-get-attribute 'href))))
+			       )
+			  (vector type coords href alt))
+			)
+		      )
+		     (nth 2 node))))
+	       (setq w3-imagemaps (cons (cons name areas) w3-imagemaps)))
+	     (w3-handle-empty-tag)
+	     )
+	    (table			; Yeeee-hah!
+	     (w3-display-table node)
+	     (setq w3-last-fill-pos (point))
+	     (w3-handle-empty-tag)
+	     )
+	    (isindex
+	     (let ((prompt (or (w3-get-attribute 'prompt)
+			       "Search on (+ separates keywords): "))
+		   action node)
+	       (setq action (or (w3-get-attribute 'src)
+				(w3-get-attribute 'href)
+				(url-view-url t)))
+	       (if (and prompt (string-match "[^: \t-]+$" prompt))
+		   (setq prompt (concat prompt ": ")))
+	       (setq node
+		     (list 'isindex nil
+			   (list
+			    (list 'hr nil nil)
+			    (list 'form
+				  (list (cons 'action action)
+					(cons 'enctype
+					      "application/x-w3-isindex")
+					(cons 'method "get"))
+				  (list
+				   prompt
+				   (list 'input
+					 (list (cons 'type "text")
+					       (cons 'name "isindex"))))))))
+	       (w3-handle-content node)
+	       (setq w3-current-isindex (cons action prompt)))
+	     )
+	    (*document
+	     (let ((info (mapcar (lambda (x) (cons x (symbol-value x)))
+				 w3-persistent-variables)))
+	       (set-buffer (generate-new-buffer "Untitled"))
+	       (setq w3-current-form-number 0
+		     w3-display-open-element-stack nil
+		     w3-last-fill-pos (point-min)
+		     fill-column (min (- (or w3-strict-width (window-width))
+					 w3-right-margin)
+				      (or w3-maximum-line-length
+					  (window-width))))
+	       (switch-to-buffer (current-buffer))
+	       (buffer-disable-undo (current-buffer))
+	       (mapcar (function (lambda (x) (set (car x) (cdr x)))) info)
+	       ;; ACK!  We don't like filladapt mode!
+	       (set (make-local-variable 'filladapt-mode) nil)
+	       (set (make-local-variable 'adaptive-fill-mode) nil)
+	       (setq w3-current-stylesheet (css-copy-stylesheet
+					    w3-user-stylesheet)
+		     w3-last-fill-pos (point)
+		     fill-column (min (- (or w3-strict-width (window-width))
+					 w3-right-margin)
+				      (or w3-maximum-line-length
+					  (window-width)))
+		     fill-prefix "")
+	       (set (make-local-variable 'inhibit-read-only) t))
+	     (w3-handle-content node)
+	     )
+	    (*invisible
+	     (w3-handle-empty-tag))
+	    (meta
+	     (let* ((equiv (cdr-safe (assq 'http-equiv args)))
+		    (value (w3-get-attribute 'content))
+		    (name  (w3-get-attribute 'name))
+		    (node  (and equiv (assoc (setq equiv (downcase equiv))
+					     url-current-mime-headers))))
+	       (if equiv
+		   (setq url-current-mime-headers (cons
+						   (cons equiv value)
+						   url-current-mime-headers)))
+	       (if name
+		   (setq w3-current-metainfo (cons
+					      (cons name value)
+					      w3-current-metainfo)))
+
+	       ;; Special-case the Set-Cookie header
+	       (if (and equiv (string= (downcase equiv) "set-cookie"))
+		   (url-cookie-handle-set-cookie value))
+	       ;; Special-case the refresh header
+	       (if (and equiv (string= (downcase equiv) "refresh"))
+		   (url-handle-refresh-header value)))
+	     (w3-handle-empty-tag)
+	     )
+	    (link
+	     ;; This doesn't handle blank-separated values per the RFC.
+	     (w3-parse-link args)
+	     (w3-handle-empty-tag))
+	    (title
+	     (let ((potential-title "")
+		   (content (nth 2 node)))
+	       (while content
+		 (setq potential-title (concat potential-title (car content))
+		       content (cdr content)))
+	       (setq potential-title (w3-normalize-spaces potential-title))
+	       (if (string-match "^[ \t]*$" potential-title)
+		   nil
+		 (rename-buffer (generate-new-buffer-name
+				 (w3-fix-spaces potential-title)))))
+	     (w3-handle-empty-tag))
+	    (form
+	     (setq w3-current-form-number (1+ w3-current-form-number))
+	     (let* (
+		    (action (w3-get-attribute 'action))
+		    (url nil))
+	       (if (not action)
+		   (setq args (cons (cons 'action (url-view-url t)) args)))
+	       (push (cons
+		      (cons 'form-number
+			    w3-current-form-number)
+		      args) w3-display-form-stack)
+	       (w3-handle-content node)))
+	    (input
+	     (if (not (assq 'form w3-display-open-element-stack))
+		 (message "Input field outside of a 
    ")
+	       (let* (
+		      (type (intern (downcase (or (w3-get-attribute 'type)
+						  "text"))))
+		      (name (w3-get-attribute 'name))
+		      (value (or (w3-get-attribute 'value) ""))
+		      (size (if (w3-get-attribute 'size)
+				(string-to-int (w3-get-attribute 'size))))
+		      (maxlength (cdr (assoc 'maxlength args)))
+		      (default value)
+		      (action (car w3-display-form-stack))
+		      (options)
+		      (id (w3-get-attribute 'id))
+		      (checked (assq 'checked args)))
+		 (if (and (string-match "^[ \t\n\r]+$" value)
+			  (not (eq type 'hidden)))
+		     (setq value ""))
+		 (if maxlength (setq maxlength (string-to-int maxlength)))
+		 (if (and name (string-match "[\r\n]" name))
+		     (setq name (mapconcat (function
+					    (lambda (x)
+					      (if (memq x '(?\r ?\n))
+						  ""
+						(char-to-string x))))
+					   name "")))
+		 (if (memq type '(checkbox radio)) (setq default checked))
+		 (if (and (eq type 'checkbox) (string= value ""))
+		     (setq value "on"))
+		 (w3-form-add-element type name
+				      value size maxlength default action
+				      options w3-current-form-number id checked
+				      (car w3-active-faces))
+		 )
+	       )
+	     (w3-handle-empty-tag)
+	     )
+	    (select
+	     (if (not (assq 'form w3-display-open-element-stack))
+		 (message "Input field outside of a ")
+	       (let* (
+		      (name (w3-get-attribute 'name))
+		      (size (string-to-int (or (w3-get-attribute 'size)
+					       "20")))
+		      (maxlength (cdr (assq 'maxlength args)))
+		      (value nil)
+		      (tmp nil)
+		      (action (car w3-display-form-stack))
+		      (options)
+		      (id (w3-get-attribute 'id))
+		      (checked (assq 'checked args)))
+		 (if maxlength (setq maxlength (string-to-int maxlength)))
+		 (if (and name (string-match "[\r\n]" name))
+		     (setq name (mapconcat (function
+					    (lambda (x)
+					      (if (memq x '(?\r ?\n))
+						  ""
+						(char-to-string x))))
+					   name "")))
+		 (setq options
+		       (mapcar
+			(function
+			 (lambda (n)
+			   (setq tmp (w3-normalize-spaces
+				      (apply 'concat (nth 2 n)))
+				 tmp (cons tmp
+					   (or
+					    (cdr-safe (assq 'value (nth 1 n)))
+					    tmp)))
+			   (if (assq 'selected (nth 1 n))
+			       (setq value (car tmp)))
+			   tmp))
+			(nth 2 node)))
+		 (if (not value)
+		     (setq value (caar options)))
+		 (w3-form-add-element 'option name
+				      value size maxlength value action
+				      options w3-current-form-number id nil
+				      (car w3-active-faces))
+		 ;; This should really not be necessary, but some versions
+		 ;; of the widget library leave point _BEFORE_ the menu
+		 ;; widget instead of after.
+		 (goto-char (point-max))
+		 )
+	       )
+	     (w3-handle-empty-tag)
+	     )
+	    (textarea
+	     (if (not (assq 'form w3-display-open-element-stack))
+		 (message "Input field outside of a ")
+	       (let* (
+		      (name (w3-get-attribute 'name))
+		      (size (string-to-int (or (w3-get-attribute 'size)
+					       "20")))
+		      (maxlength (cdr (assq 'maxlength args)))
+		      (value (w3-normalize-spaces
+			      (apply 'concat (nth 2 node))))
+		      (default value)
+		      (tmp nil)
+		      (action (car w3-display-form-stack))
+		      (options)
+		      (id (w3-get-attribute 'id))
+		      (checked (assq 'checked args)))
+		 (if maxlength (setq maxlength (string-to-int maxlength)))
+		 (if (and name (string-match "[\r\n]" name))
+		     (setq name (mapconcat (function
+					    (lambda (x)
+					      (if (memq x '(?\r ?\n))
+						  ""
+						(char-to-string x))))
+					   name "")))
+		 (w3-form-add-element 'multiline name
+				      value size maxlength value action
+				      options w3-current-form-number id nil
+				      (car w3-active-faces))
+		 )
+	       )
+	     (w3-handle-empty-tag)
+	     )
+	    (style
+	     (w3-handle-style (cons (cons 'data (apply 'concat (nth 2 node)))
+				    (nth 1 node)))
+	     (w3-handle-empty-tag))
+	    (otherwise
+	     ;; Generic formatting
+	     (w3-handle-content node))
+	    )				; case tag
+	  )				; stringp content
+	)				; while content
+      )					; while content-stack
+    )
+  )
+
+(defun w3-draw-tree (tree)
+  ;; The main entry point - wow complicated
+  (setq w3-current-stylesheet w3-user-stylesheet)
+  (while tree
+    (w3-display-node (car tree))
+    (setq tree (cdr tree)))
+  (w3-display-fix-widgets)
+  (w3-form-resurrect-widgets))
+
+(defun time-display (&optional tree)
+  ;; Return the # of seconds it took to draw 'tree'
+  (let ((st (nth 1 (current-time)))
+	(nd nil))
+    (w3-draw-tree (or tree w3-last-parse-tree))
+    (setq nd (nth 1 (current-time)))
+    (- nd st)))
+
+
+(defun w3-prepare-buffer (&rest args)
+  ;; The text/html viewer - does all the drawing and displaying of the buffer
+  ;; that is necessary to go from raw HTML to a good presentation.
+  (let* ((source (buffer-string))
+	 (source-buf (current-buffer))
+	 (parse (w3-parse-buffer source-buf)))
+    (set-buffer-modified-p nil)
+    (w3-draw-tree parse)
+    (kill-buffer source-buf)
+    (set-buffer-modified-p nil)
+    (setq w3-current-source source
+	  w3-current-parse parse)
+    (if (and (boundp 'w3-image-widgets-waiting) w3-image-widgets-waiting)
+	(let (url glyph widget)
+	  (while w3-image-widgets-waiting
+	    (setq widget (car w3-image-widgets-waiting)
+		  w3-image-widgets-waiting (cdr w3-image-widgets-waiting)
+		  url (widget-get widget 'src)
+		  glyph (cdr-safe (assoc url w3-graphics-list)))
+	    (widget-value-set widget glyph))))
+    (w3-mode)
+    ;;(w3-handle-annotations)
+    ;;(w3-handle-headers)
+    (set-buffer-modified-p nil)
+    (goto-char (point-min))
+    (if url-keep-history
+	(let ((url (url-view-url t)))
+	  (if (not url-history-list)
+	      (setq url-history-list (make-hash-table :size 131 :test 'equal)))
+	  (cl-puthash url (buffer-name) url-history-list)
+	  (if (fboundp 'w3-shuffle-history-menu)
+	      (w3-shuffle-history-menu)))))
+  )
+
+(provide 'w3-display)
diff -r 13c6d0aaafe5 -r 9ee227acff29 lisp/w3/w3-draw.el
--- a/lisp/w3/w3-draw.el	Mon Aug 13 08:48:18 2007 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,2191 +0,0 @@
-;;; w3-draw.el --- Emacs-W3 drawing functions for new display engine
-;; Author: wmperry
-;; Created: 1996/08/25 17:12:32
-;; Version: 1.17
-;; Keywords: faces, help, hypermedia
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
-;;;
-;;; This file is not part of GNU Emacs, but the same permissions apply.
-;;;
-;;; 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.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; This function will take a stream of HTML from w3-parse-buffer
-;;; and draw it out
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(require 'w3-vars)
-(require 'w3-imap)
-(require 'w3-widget)
-(require 'widget)
-(require 'cl)
-
-(if (featurep 'mule) (fset 'string-width 'length))
-
-(defmacro w3-get-state (tag)
-  (or (symbolp tag)
-      (error "Bad argument: %s" tag))
-  (let ((index (length (memq tag w3-state-locator-variable))))
-    (` (aref w3-state-vector (, index)))))
-(put 'w3-get-state 'edebug-form-spec '(symbolp))
-
-(defmacro w3-put-state (tag val)
-  (or (symbolp tag)
-      (error "Bad argument: %s" tag))
-  (let ((index (length (memq tag w3-state-locator-variable))))
-    (` (aset w3-state-vector (, index) (, val)))))
-(put 'w3-put-state 'edebug-form-spec '(symbolp form))
-
-(defsubst w3-push-alignment (align)
-  (if align
-      (w3-put-state :align (cons (cons tag align) (w3-get-state :align)))))
-
-(defsubst w3-pop-alignment ()
-  (let ((flubber (memq (assq tag (w3-get-state :align))
-		       (w3-get-state :align))))
-    (cond
-     ((null flubber) nil)
-     ((cdr flubber)
-      (w3-put-state :align (cdr flubber)))
-     (t (w3-put-state :align nil)))))
-
-(defsubst w3-current-alignment ()
-  (cdr-safe (car-safe (w3-get-state :align))))
-
-(defconst w3-fill-prefixes-vector
-  (let ((len 0)
-        (prefix-vector (make-vector 80 nil)))
-    (while (< len 80)
-      (aset prefix-vector len (make-string len ? ))
-      (setq len (1+ len)))
-    prefix-vector))
-
-(defsubst w3-set-fill-prefix-length (len)
-  (setq fill-prefix (if (< len (- (or w3-strict-width (window-width)) 4))
-			(if (< len 80)
-			    (aref w3-fill-prefixes-vector len)
-			  (make-string len ? ))
-		      (url-warn
-		       'html
-		       "Runaway indentation!  Too deep for window width!")
-		      fill-prefix)))
-
-(defsubst w3-get-default-style-info (info)
-  (and w3-current-stylesheet
-       (or
-	;; Check for tag/id|name first!
-	(cdr-safe (assq info
-			(cdr-safe
-			 (assoc (or (cdr-safe (assq 'id args))
-				    (cdr-safe (assq 'name args)))
-				(cdr-safe
-				 (assq tag w3-current-stylesheet))))))
-
-	;; Check for tag/class next
-	(cdr-safe (assq info
-			(cdr-safe
-			 (assoc (cdr-safe (assq 'class args))
-				(cdr-safe
-				 (assq tag w3-current-stylesheet))))))
-
-	;; Then for global stuff with 'class'
-	(cdr-safe (assq info
-			(cdr-safe
-			 (assoc (cdr-safe (assq 'class args))
-				(cdr-safe
-				 (assq 'doc w3-current-stylesheet))))))
-     
-	;; Fall back on the default styles for just this tag.
-	(cdr-safe (assq info
-			(cdr-safe
-			 (assq 'internal
-			       (cdr-safe
-				(assq tag w3-current-stylesheet)))))))))
-
-(defsubst w3-normalize-color (color)
-  (cond
-   ((valid-color-name-p color)
-    color)
-   ((valid-color-name-p (concat "#" color))
-    (concat "#" color))
-   ((string-match "[ \t\r\n]" color)
-    (w3-normalize-color
-     (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) ""
-					(char-to-string x)))) color "")))
-   ((valid-color-name-p (font-normalize-color color))
-    (font-normalize-color color))
-   (t
-    (w3-warn 'html (format "Bad color specification: %s" color))
-    nil)))
-
-(defun w3-pause ()
-  (cond
-   (w3-running-FSF19 (sit-for 0))
-   (w3-running-xemacs
-    (if (and (not (sit-for 0)) (input-pending-p))
-	(condition-case ()
-	    (dispatch-event (next-command-event))
-	  (error nil))))
-   (t (sit-for 0))))
-
-(defvar w3-end-tags
-  '((/ul   . ul)
-    (/lit  . lit)
-    (/li   . li)
-    (/h1   . h1)
-    (/h2   . h2)
-    (/h3   . h3)
-    (/h4   . h4)
-    (/h5   . h5)
-    (/h6   . h6)
-    (/font0 . font0)
-    (/font1 . font1)
-    (/font2 . font2)
-    (/font3 . font3)
-    (/font4 . font4)
-    (/font5 . font5)
-    (/font6 . font6)
-    (/font7 . font7)
-    (/ol   . ol)
-    (/dl   . dl)
-    (/menu . menu)
-    (/dir  . dir)
-    (/a    . a)))
-
-(defvar w3-face-cache nil
-  "Cache for w3-face-for-element")
-
-(defsubst w3-voice-for-element ()
-  (let ((temporary-voice (w3-get-default-style-info 'voice-spec)))
-    (and temporary-voice (cons tag temporary-voice))))
-
-(defsubst w3-face-for-element ()
-  (let* ((font-spec  (w3-get-default-style-info 'font-spec))
-	 (foreground (w3-get-default-style-info 'color))
-	 (background (w3-get-default-style-info 'background))
-	 ;;(pixmap     (w3-get-default-style-info 'pixmap))
-	 (descr (list font-spec foreground background))
-	 (face (cdr-safe (assoc descr w3-face-cache))))
-    (if (or face (not (or foreground background font-spec)))
-	nil				; Do nothing, we got it already
-      (setq face (intern (format "%s" descr)))
-      (cond
-       ((not (fboundp 'make-face)) nil)	; Do nothing
-       ((and (fboundp 'face-property)	; XEmacs 19.14
-	     (not (get 'face-property 'sysdep-defined-this)))
-	(setq face (make-face face
-			      "An Emacs-W3 face... don't edit by hand." t)))
-       (t (make-face face)))
-
-      (and font-spec (set-face-font face font-spec))
-      (and foreground (set-face-foreground face foreground))
-      (and background (set-face-background face background))
-      ;(set-face-background-pixmap face pixmap)
-      (setq w3-face-cache (cons (cons descr face) w3-face-cache)))
-    (cons tag face)))
-
-(defun w3-handle-single-tag (tag &optional args)
-  (save-excursion
-    (and w3-draw-buffer (set-buffer w3-draw-buffer))
-    (let ((opos (point))
-	  (id (and (listp args)
-		   (or (cdr-safe (assq 'name args))
-		       (cdr-safe (assq 'id args))))))
-      
-      ;; This allows _ANY_ tag, whether it is known or not, to be
-      ;; the target of a # reference in a URL
-      (if id
-	  (progn
-	    (setq w3-id-positions (cons
-				   (cons (intern id)
-					 (set-marker (make-marker)
-						     (point-max)))
-				   w3-id-positions))))
-
-      (if (and (listp args) (cdr-safe (assq 'style args)))
-	  (let ((unique-id (or id (url-create-unique-id)))
-		(sheet ""))
-	    (setq sheet (format "%s.%s { %s }\n" tag unique-id
-				(cdr-safe (assq 'style args)))
-		  args (cons (cons 'id unique-id) args))
-	    
-	    (w3-handle-style (list (cons 'data sheet)
-				   (cons 'notation "css")))))
-      (goto-char (point-max))
-      (if (and (w3-get-state :next-break)
-	       (not (memq tag
-			  '(p h1 h2 h3 h4 h5 h6 ol ul dl menu dir pre))))
-	  (w3-handle-p))
-      (w3-put-state :next-break nil)
-      (setq w3-current-formatter (get tag 'w3-formatter))
-      (cond
-       ((eq 'w3-handle-text w3-current-formatter)
-	(w3-handle-text args))
-       (t
-	(let ((data-before nil)
-	      (data-after nil))
-	  (if (and (not (eq tag 'text)) w3-current-stylesheet)
-	      (progn
-		(setq data-before (w3-get-default-style-info
-				   'insert.before))
-		(let ((tag (cdr-safe (assq tag w3-end-tags))))
-		  (setq data-after (and tag
-					(w3-get-default-style-info
-					 'insert.after))))))
-	  (if data-before (w3-handle-text data-before))
-	  (setq w3-current-formatter (get tag 'w3-formatter))
-	  (cond
-	   ((eq w3-current-formatter 'ack) nil)
-	   ((null w3-current-formatter) (w3-handle-unknown-tag tag args))
-	   (t (funcall w3-current-formatter args)))
-	  (if data-after (w3-handle-text data-after)))))
-      (if (not (eq tag 'text))
-	  (setq w3-last-tag tag))
-      (goto-char opos))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Set up basic fonts/stuff
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-		      
-(defun w3-init-state ()
-  ;; Reset the state of an HTML drawing buffer
-  (setq w3-state-vector (copy-sequence w3-state-vector))
-  (setq w3-current-stylesheet (copy-tree w3-user-stylesheet))
-  (let* ((tag 'html)
-	 (args nil)
-	 (face (cdr (w3-face-for-element))))
-    (if (not face)
-	(setq tag 'body
-	      face (cdr (w3-face-for-element))))
-    (and face
-	 (if (not (fboundp 'valid-specifier-locale-p))
-	     nil
-	   (w3-my-safe-copy-face face 'default (current-buffer)))))
-  (setq w3-form-labels nil)
-  (make-local-variable 'w3-image-widgets-waiting)
-  (make-local-variable 'w3-active-voices)
-  (make-local-variable 'inhibit-read-only)
-  (setq w3-image-widgets-waiting nil
-	inhibit-read-only t)
-  (if (not (get 'w3-state 'init)) (w3-draw-setup))
-  (fillarray w3-state-vector 0)
-  (w3-put-state :bogus nil)		; Make all fake ones return nil
-  (w3-put-state :text-mangler nil)	; Any text mangling routine 
-  (w3-put-state :next-break nil)	; Next item needs a paragraph break
-  (w3-put-state :background nil)	; Netscapism - gag
-  (w3-put-state :table nil)		; Table args
-  (w3-put-state :figdata nil)		; Data for  tag
-  (w3-put-state :figalt nil)		; Alt data for  tag
-  (w3-put-state :pre-start nil)		; Where current 
     seg starts
-  (w3-put-state :zone nil)		; Zone of current href?
-  (w3-put-state :center nil)		; netscape tag
-  (w3-put-state :select nil)		; Data for current select field
-  (w3-put-state :options nil)		; Options in current select field
-  (w3-put-state :nofill nil)		; non-nil if in pre or xmp
-  (w3-put-state :nowrap nil)		; non-nil if in 
    
-  (w3-put-state :href nil)		; Current link destination
-  (w3-put-state :name nil)		; Current link ID tag
-  (w3-put-state :image nil)		; Current image destination
-  (w3-put-state :form nil)		; Current form information
-  (w3-put-state :optarg nil)		; Option arguments
-  (w3-put-state :w3-graphic nil)	; Image stuff for non-xemacs
-  (w3-put-state :lists '())		; Types of list currently in.
-  (w3-put-state :align nil)		; Current alignment of paragraphs
-  (w3-put-state :title nil)		; Whether we can have a title or not
-  (w3-put-state :seen-this-url nil)	; whether we have seen this url or not
-  (w3-put-state :needspace 'never)	; Spacing info
-  (setq w3-active-faces nil)		; Face attributes to use
-  (setq w3-active-voices nil)		; voice attributes to use
-  )
-
-(defun w3-draw-setup ()
-  (put 'w3-state 'init t)
-  (w3-init-state))
-  
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Mapping HTML tags to functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(put 'lit 'w3-formatter 'w3-handle-pre)
-(put '/lit 'w3-formatter 'w3-handle-/pre)
-(put 'li 'w3-formatter 'w3-handle-list-item)
-(put 'ul 'w3-formatter 'w3-handle-list-opening)
-(put 'ol 'w3-formatter 'w3-handle-list-opening)
-(put 'dl 'w3-formatter 'w3-handle-list-opening)
-(put '/dl 'w3-formatter 'w3-handle-list-ending)
-(put '/ul 'w3-formatter 'w3-handle-list-ending)
-(put '/ol 'w3-formatter 'w3-handle-list-ending)
-(put 'menu 'w3-formatter 'w3-handle-list-opening)
-(put '/menu 'w3-formatter 'w3-handle-list-ending)
-(put 'dir 'w3-formatter 'w3-handle-list-opening)
-(put '/dir 'w3-formatter 'w3-handle-list-ending)
-(put 'dt 'w3-formatter 'w3-handle-table-term)
-(put 'dd 'w3-formatter 'w3-handle-table-definition)
-(put 'a 'w3-formatter 'w3-handle-hyperlink)
-(put '/a 'w3-formatter 'w3-handle-hyperlink-end)
-(put 'h1 'w3-formatter 'w3-handle-header)
-(put 'h2 'w3-formatter 'w3-handle-header)
-(put 'h3 'w3-formatter 'w3-handle-header)
-(put 'h4 'w3-formatter 'w3-handle-header)
-(put 'h5 'w3-formatter 'w3-handle-header)
-(put 'h6 'w3-formatter 'w3-handle-header)
-(put '/h1 'w3-formatter 'w3-handle-header-end)
-(put '/h2 'w3-formatter 'w3-handle-header-end)
-(put '/h3 'w3-formatter 'w3-handle-header-end)
-(put '/h4 'w3-formatter 'w3-handle-header-end)
-(put '/h5 'w3-formatter 'w3-handle-header-end)
-(put '/h6 'w3-formatter 'w3-handle-header-end)
-(put 'img 'w3-formatter 'w3-handle-image)
-(put 'kill_sgml 'w3-formatter 'w3-handle-kill-sgml)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; The main drawing routines
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-unknown-tag (tag args)
-  ;; A generic formatter for an unkown HTML tag.  This will only be
-  ;; called if a formatter was not found in TAGs property list.
-  ;; If a function named `w3-handle-TAG' is defined, then it will be
-  ;; stored in TAGs property list, so it will be found next time
-  ;; the tag is run across.
-
-  (let ((handler (intern-soft (concat "w3-handle-" (symbol-name tag))))
-	(end-tag-p (= (string-to-char (symbol-name tag)) ?/)))
-
-    ;; This stores the info in w3-end-tags for future use by the display
-    ;; engine.
-    (if end-tag-p
-	(setq w3-end-tags (cons (cons tag
-				      (intern (substring (symbol-name tag)
-							 1)))
-				w3-end-tags)))
-
-    ;; For proper use of stylesheets, if no tag is found, then we should
-    ;; at least call w3-handle-emphasis
-    (cond
-     ((and handler (fboundp handler))
-      (put tag 'w3-formatter handler)
-      (funcall handler args))
-     (end-tag-p
-      (put tag 'w3-formatter 'w3-handle-emphasis-end)
-      (w3-handle-emphasis-end args))
-     (t 
-      (put tag 'w3-formatter 'w3-handle-emphasis)
-      (w3-handle-emphasis args)))))
-
-(defun w3-handle-text (&optional args)
-  ;; This is the main workhorse of the display engine.
-  ;; It will figure out how a chunk of text should be displayed and
-  ;; put all the necessary extents/overlays/regions around it."
-  (or args (error "Impossible"))
-  (if (string= args "")
-      (w3-put-state :needspace nil)
-    (let ((st (point))
-	  (mangler (w3-get-state :text-mangler))
-	  (sym nil))
-      (insert args)
-      ;;(goto-char st)
-      (cond ((w3-get-state :nofill)
-	     (goto-char st)
-	     (if (not (search-forward "\n" nil t))
-		 (subst-char-in-region st (point-max) ?\r ?\n)
-	       (subst-char-in-region st (point-max) ?\r ?  ))
-	     (goto-char (point-max)))
-            (t
-	     (goto-char st)
-             (while (re-search-forward
-                     " [ \t\n\r]+\\|[\t\n\r][ \t\n\r]*"
-                     nil 'move)
-               (replace-match " "))
-             (goto-char st)
-             (if (and (= ?  (following-char))
-                      (or (bolp)
-                          (eq 'never (w3-get-state :needspace))))
-                 (delete-char 1))
-             (goto-char (point-max))))
-      (and mangler w3-delimit-emphasis
-	   (fboundp mangler) (funcall mangler st (point)))
-      (let ((faces nil)
-	    (todo w3-active-faces)
-	    (voices w3-active-voices)
-	    (val nil)
-	    (cur nil))
-	(while todo
-	  (setq cur (car todo)
-		todo (cdr todo))
-	  (cond
-	   ((symbolp cur)
-	    nil)
-	   ((listp (cdr-safe cur))
-	    (let ((x (cdr cur)))
-	      (while x
-		(if (not (memq (car x) faces))
-		    (setq faces (cons (car x) faces)))
-		(setq x (cdr x)))))
-	   ((and (consp cur) (not (memq (cdr cur) faces)))
-	    (setq faces (cons (cdr cur) faces)))
-	   (t nil)))
-	(add-text-properties st (point) (list 'face faces))
-	(if (car voices)
-	    (add-text-properties st (point) (list 'personality (cdar voices))))
-	)
-      (if (not (memq (char-after (1- (point))) '(?  ?.)))
-	  (w3-put-state :needspace t))
-      )))
-
-(defun w3-handle-plaintext (&optional args)
-  (let ((x (w3-get-state :nofill)))
-    (w3-put-state :nofill t)
-    (and args (cdr-safe (assq 'data args))
-	 (w3-handle-text (cdr-safe (assq 'data args))))
-    (setq w3-last-fill-pos (point))))
-
-(defun w3-handle-/plaintext (&optional args)
-  (w3-put-state :nofill nil))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Paragraph breaks, and other things that can cause linebreaks and
-;;; alignment changes.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-header (&optional args)
-  ;; Handle the creation of a header (of any level).  Causes a full
-  ;; paragraph break. 
-  (w3-handle-emphasis args)
-  (let ((name (or (cdr-safe (assq 'name args))
-		  (cdr-safe (assq 'id args))))
-	(align (cdr-safe (assq 'align args)))
-	(mangler (nth 2 (cdr-safe (assq tag w3-header-chars-assoc)))))
-    (w3-handle-p)
-    (if align
-	(setq align (intern (downcase align)))
-      (setq align (w3-get-default-style-info 'align)))
-    (let ((tag 'p))
-      (w3-pop-alignment))
-    (w3-push-alignment align)
-    (w3-put-state :text-mangler mangler)
-    (if name (w3-put-state :name name))))
-
-(defun w3-handle-header-end (&optional args)
-  ;; Handle the closing of a header (of any level).  Causes a full
-  ;; paragraph break.
-  (w3-handle-emphasis-end)
-  (let ((mangler (w3-get-state :text-mangler)))
-    (and mangler (funcall mangler nil nil t)))
-  (w3-put-state :text-mangler nil)
-  (goto-char (point-max))
-  (w3-handle-p)
-  (let* ((info (car-safe (w3-get-state :lists)))
-	 (type (and info (car-safe info))))
-    (if (and type fill-prefix)
-	(insert fill-prefix (cond
-			     ((memq type '(ol dl)) "    ")
-			     (t "  ")))))
-  (let ((tag (cdr-safe (assoc tag w3-end-tags))))
-    (w3-pop-alignment)))
-
-(defun w3-handle-pre (&optional args)
-  ;; Marks the start of a preformatted section of text.  No paragraph
-  ;; filling should be done from this point until a matching /pre has
-  ;; been encountered.
-  (w3-handle-p)
-  (w3-put-state :nofill t)
-  (w3-put-state :needspace t)
-  (w3-put-state :pre-start (set-marker (make-marker) (point)))
-  )
-
-(defun w3-handle-xmp (&optional args)
-  ;; Marks the start of a preformatted section of text.  No paragraph
-  ;; filling should be done from this point until a matching /pre has
-  ;; been encountered.
-  (w3-handle-p)
-  (w3-put-state :nofill t)
-  (w3-put-state :needspace t)
-  (w3-put-state :pre-start (set-marker (make-marker) (point)))
-  (if (and args (cdr-safe (assq 'data args)))
-      (progn
-	(w3-handle-text (cdr-safe (assq 'data args)))
-	(w3-handle-/xmp))))
-
-(defun w3-handle-/pre (&optional args)
-  (if (not (w3-get-state :nofill))
-      (w3-handle-p)
-    (w3-put-state :nofill nil)
-    (let* ((info (car-safe (w3-get-state :lists)))
-	   (type (and info (car-safe info)))
-	   (st (w3-get-state :pre-start)))
-      (if (not (bolp)) (insert "\n"))
-      (if (and type fill-prefix st)
-	  (progn
-	    (save-excursion
-	      (goto-char st)
-	      (while (re-search-forward "^" nil t)
-		(insert fill-prefix (cond
-				     ((memq type '(ol dl)) "    ")
-				     (t "  ")))))
-	    (setq w3-last-fill-pos (point))
-	    (insert fill-prefix (cond
-				 ((memq type '(ol dl)) "    ")
-				 (t "  "))))
-	(setq w3-last-fill-pos (point))))
-    (let ((tag 'p))
-      (w3-handle-p))
-    (setq w3-active-faces nil)
-    (w3-put-state :pre-start nil)))
-
-(fset 'w3-handle-/xmp 'w3-handle-/pre)
-
-(defun w3-handle-blockquote (&optional args)
-  ;; Start a section of quoted text.  This is done by causing the text
-  ;; to be indented from the right and left margins.  Nested
-  ;; blockquotes will cause further indentation.
-  (let ((align (or (w3-get-default-style-info 'align) 'indent)))
-    (w3-handle-p)
-    (w3-push-alignment align))
-  (w3-put-state :fillcol fill-column)
-  (setq fill-column (max (- (or fill-column
-				(1- (or w3-strict-width (window-width)))) 8)
-			 10)))
-
-(defun w3-handle-/blockquote (&optional args)
-  (w3-handle-paragraph)
-  (let ((tag (cdr-safe (assoc tag w3-end-tags))))
-    (w3-pop-alignment))
-  (setq fill-column (or (w3-get-state :fillcol) (1- (or w3-strict-width
-							 (window-width)))))
-  (w3-put-state :fillcol nil))
-
-(defun w3-handle-align (&optional args)
-  ;; Cause a single line break (like 
    ) and replace the current
-  ;; alignment.
-  (let ((align (intern (or (cdr-safe (assq 'role args))
-			   (cdr-safe (assq 'align args))
-			   (cdr-safe (assq 'style args))))))
-    (w3-handle-paragraph)
-    (w3-push-alignment align)))
-
-(defun w3-handle-/align (&optional args)
-  (w3-handle-paragraph)
-  (w3-pop-alignment))
-
-(defun w3-handle-hr (&optional args)
-  ;; Cause a line break and insert a horizontal rule across the page.
-  (w3-handle-paragraph)
-  (let* ((perc (or (cdr-safe (assq 'width args))
-		   (w3-get-default-style-info 'width)
-		   "100%"))
-	 (old-align (w3-current-alignment))
-	 (talign (or (cdr-safe (assq 'textalign args))
-		     (cdr-safe (assq 'text-align args))
-		     (w3-get-default-style-info 'textalign)
-		     (w3-get-default-style-info 'text-align)
-		     (and old-align (symbol-name old-align))
-		     "center"))
-	 (text (cdr-safe (assq 'label args)))
-	 (align (or (cdr-safe (assq 'align args))
-		    (w3-get-default-style-info 'align)
-		    old-align
-		    'center))
-	 (rule nil)
-	 (width nil))
-    (if (stringp talign)
-	(setq talign (intern (downcase talign))))
-    (if (stringp align)
-	(setq align (intern (downcase align))))
-    (w3-push-alignment align)
-
-    (setq perc (min (string-to-int perc) 100)
-	  width (/ (* (- (or w3-strict-width
-			     (window-width))
-			 w3-right-border) perc) 100))
-    (if text
-	(cond
-	 ((>= (length text) width)
-	  (setq rule (concat "-" text "-")))
-	 ((eq talign 'right)
-	  (setq rule (concat (make-string (- width 1 (length text))
-					  w3-horizontal-rule-char)
-			     text "-")))
-	 ((eq talign 'center)
-	  (let ((half (make-string (/ (- width (length text)) 2)
-				   w3-horizontal-rule-char)))
-	    (setq rule (concat half text half))))
-	 ((eq talign 'left)
-	  (setq rule (concat "-" text (make-string (- width 1
-						      (length text))
-						   w3-horizontal-rule-char)))))
-      (setq rule (make-string width w3-horizontal-rule-char)))
-    (w3-handle-text rule)
-    (condition-case ()
-	(w3-handle-paragraph)
-      (error nil))
-    (w3-pop-alignment)
-    (setq w3-last-fill-pos (point))
-    (let* ((info (car-safe (w3-get-state :lists)))
-	   (type (and info (car-safe info)))
-	   (cur (w3-current-alignment)))
-      (cond
-       ;;((eq cur 'indent)
-       ;;(insert (make-string w3-indent-level ? )))
-       ((and type fill-prefix (eq w3-last-tag 'dt))
-	(insert fill-prefix))
-       ((and type fill-prefix)
-	(insert fill-prefix (if (eq type 'ol) "    " "  ")))
-       (t nil)))))
-
-(defun w3-handle-/p (&optional args)
-  ;; Marks the end of a paragraph.  Only causes a paragraph break if
-  ;; it is not followed by another paragraph or similar markup
-  ;; (headers, list openings, etc) that will already cause a new
-  ;; paragraph to be started.
-  (w3-handle-emphasis-end)
-  (let ((tag (cdr-safe (assoc tag w3-end-tags))))
-    (w3-handle-p)
-    (w3-pop-alignment)))
-
-(defun w3-handle-p (&optional args)
-  (if (or (not (memq w3-last-tag '(li tr td th dt dd)))
-	  (memq tag '(ol ul dl menu dir)))
-      (let ((name (or (cdr-safe (assq 'name args))
-		      (cdr-safe (assq 'id args))))
-	    (align (cdr-safe (assoc 'align args))))
-	(w3-handle-emphasis-end)
-	(w3-handle-emphasis args)
-	(w3-handle-paragraph)
-	(w3-put-state :nowrap (assq 'nowrap args))
-	(setq align (if align
-			(intern (downcase align))
-		      (w3-get-default-style-info 'align)))
-	(and (eq tag 'p) (progn
-			   (w3-pop-alignment)
-			   (w3-push-alignment align)))
-	(if (not (bobp))
-	    (progn
-	      (insert (cond
-		       ((and (eolp) (bolp)) "\n")
-		       ((eolp) "\n\n")
-		       (t "\n")))
-	      (setq w3-last-fill-pos (point))
-	      (cond
-	       ((null fill-prefix))
-	       ((string= fill-prefix ""))
-	       ((eq (car (car (w3-get-state :lists))) 'ol)
-		(insert fill-prefix "    "))
-	       (t (insert fill-prefix "  ")))))
-	(if name (w3-put-state :name name)))))
-
-(defun w3-handle-br (&optional args)
-  ;; Cause a single line break.
-  ;; The alignment will only effect the chunk of text (generally to
-  ;; the last 
     or 
     tag) immediately before the 
    .  After
-  ;; that, the alignment will revert to the containers alignment.
-  (w3-handle-paragraph)
-  (let* ((info (car-safe (w3-get-state :lists)))
-	 (type (and info (car-safe info)))
-	 (cur (w3-current-alignment)))
-    (cond
-     ;;((eq cur 'indent)
-     ;;(insert (make-string w3-indent-level ? )))
-     ((and type fill-prefix (eq w3-last-tag 'dt))
-      (insert fill-prefix))
-     ((and type fill-prefix)
-      (insert fill-prefix (if (eq type 'ol) "    " "  ")))
-     (t nil))))
-
-(defun w3-handle-paragraph (&optional args)
-  (if (not (bobp))
-      (let ((align (w3-current-alignment))
-            (fill-prefix fill-prefix))
-	(cond
-         ((eq align 'indent)
-          (w3-set-fill-prefix-length
-           (+ (length fill-prefix);; works even if fill-prefix is nil
-              w3-indent-level)))
-         ((null fill-prefix)
-          (setq fill-prefix ""))
-         ((string= fill-prefix ""))
-	 ((eq (car (car (w3-get-state :lists))) 'ol)
-          (w3-set-fill-prefix-length (+ 4 (length fill-prefix))))
-         (t
-          (w3-set-fill-prefix-length (+ 2 (length fill-prefix)))))
-	(if (eq align 'indent)
-	    (progn
-	      (goto-char w3-last-fill-pos)
-	      (insert fill-prefix)
-	      (goto-char (point-max))))
-	(if (and (> (current-column) fill-column)
-		 (not (w3-get-state :nowrap))
-		 (not (w3-get-state :nofill)))
-	    (fill-region-as-paragraph w3-last-fill-pos (point)
-				      (eq align 'justify)))
-	(if (not w3-last-fill-pos)
-	    (setq w3-last-fill-pos (point-min)))
-	(goto-char (point-max))
-	(skip-chars-backward " \t\n")
-	(delete-region (point) (point-max))
-	(if (< w3-last-fill-pos (point))
-	    (cond
-	     ((or (eq align 'center) (w3-get-state :center))
-	      (center-region w3-last-fill-pos (point)))
-	     ((eq align 'right)
-	      (let ((x (point)))
-		(catch 'fill-exit
-		  (save-excursion
-		    (goto-char w3-last-fill-pos)
-		    (while (re-search-forward "$" x t)
-		      (if (/= (current-column) fill-column)
-			  (let ((buff (- fill-column (current-column))))
-			    (beginning-of-line)
-			    (setq x (+ x buff))
-			    (if (> buff 0)
-				(insert (make-string buff ? )))
-			    (end-of-line))
-			(end-of-line))
-		      (if (eobp) (throw 'fill-exit t))
-		      (condition-case ()
-			  (forward-char 1)
-			(error (throw 'fill-exit t))))))))))
-	(insert "\n")
-	(setq w3-last-fill-pos (point))
-	(w3-put-state :needspace 'never))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; List handling code
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-list-ending (&optional args)
-  ;; Handles all the list terminators (/ol /ul /dl).
-  ;; This just fills the last paragrpah, then reduces the depth in
-  ;; `w3-state' and truncates `fill-prefix'"
-  (w3-handle-paragraph)
-  (w3-put-state :depth (max 0 (1- (w3-get-state :depth))))
-  (w3-put-state :next-break t)
-  (w3-set-fill-prefix-length (* (w3-get-state :depth) w3-indent-level))
-  (w3-put-state :lists (cdr (w3-get-state :lists)))
-  (if (/= 0 (length fill-prefix))
-      (insert fill-prefix "  ")))
-
-(defun w3-handle-list-opening (&optional args)
-  ;; Handles all the list openers (ol ul dl).
-  ;; This just fills the last paragraph, then increases the depth in
-  ;; `w3-state' and adds to `fill-prefix'
-  (w3-handle-p)
-  (let ((style (and (not (assq 'style args))
-		    (w3-get-default-style-info 'style))))
-    (if style
-	(setq args (cons (cons 'style style) args))))
-  ;; Default VALUE attribute for OL is 1.
-  (if (eq tag 'ol)
-      (or (assq 'value args)
-          (setq args (cons (cons 'value 1) args))))
-  (w3-put-state :depth (1+ (w3-get-state :depth)))
-  (w3-set-fill-prefix-length (* (w3-get-state :depth) w3-indent-level))
-  (insert "\n\n" fill-prefix "  ")
-  (w3-put-state :lists (cons (cons tag (copy-alist args))
-			      (w3-get-state :lists))))
-
-(defun w3-handle-table-definition (&optional args)
-  (w3-handle-paragraph)
-  (insert fill-prefix "  "))
-
-(defun w3-handle-table-term (&optional args)
-  (w3-handle-paragraph)
-  (insert "\n" fill-prefix))
-
-(defun w3-handle-list-item (&optional args)
-  (w3-handle-paragraph)
-  (let* ((info (car (w3-get-state :lists)))
-	 (type (car info))
-	 (endr (or (nth (1- (or (w3-get-state :depth) 1))
-			(cdr (or (assoc type w3-list-chars-assoc)
-				 (car w3-list-chars-assoc))))
-		   "*")))
-    (setq info (cdr info))
-    (cond
-     ((assq 'plain info)
-      ;; We still need to indent from the left margin for lists without
-      ;; bullets.  This is especially important with nested lists.
-      ;; Question: Do we want this to be equivalent to replacing the
-      ;; bullet by a space (" ") or by indenting so that the text starts
-      ;; where the bullet would have been?  I've chosen the latter after
-      ;; looking at both kinds of output.
-      (insert fill-prefix))
-     ((eq type 'ol)
-      (let ((next (or (assq 'seqnum info) (assq 'value info)))
-	    (type (cdr-safe (assq 'style info)))
-	    (uppr (assq 'upper info))
-	    (tokn nil))
-	(if (stringp (cdr next)) (setcdr next (string-to-int (cdr next))))
-	(cond
-	 ((or (assq 'roman info)
-	      (member type '("i" "I")))
-	  (setq tokn (concat
-		      (w3-pad-string (w3-decimal-to-roman (cdr next)) 3 ?
-				     'left)
-		      endr)))
-	 ((or (assq 'arabic info)
-	      (member type '("a" "A")))
-	  (setq tokn (concat (w3-pad-string
-			      (w3-decimal-to-alpha (cdr next)) 3 ?  'left)
-			     endr)))
-	 (t
-	  (setq tokn (concat (w3-pad-string (int-to-string (cdr next))
-					    2 ?  'left)
-			     endr))))
-	(if (assq 'uppercase info)
-	    (setq tokn (upcase tokn)))
-	(insert fill-prefix tokn " ")
-	(setcdr next (1+ (cdr next)))
-	(w3-put-state :needspace 'never)))
-     (t
-      (insert fill-prefix endr " ")))))
-
-(defun w3-pad-string (str len pad side)
-  ;; Pads a string STR to a certain length LEN, using fill character
-  ;; PAD by concatenating PAD to SIDE of the string.
-  (let ((strlen (length str)))
-    (cond
-     ((>= strlen len) str)
-     ((eq side 'right) (concat str (make-string (- len strlen) pad)))
-     ((eq side 'left)  (concat (make-string (- len strlen) pad) str)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Routines to handle character-level formatting
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-q (&optional args)
-  (w3-handle-emphasis)
-  (w3-handle-text (or (w3-get-default-style-info 'startquote) "\"")))
-
-(defun w3-handle-/q (&optional args)
-  (let ((tag (cdr-safe (assoc tag w3-end-tags))))
-    (w3-handle-text (or (w3-get-default-style-info 'endquote) "\"")))
-  (w3-handle-emphasis-end))
-
-(defun w3-handle-emphasis (&optional args)
-  ;; Generic handler for character-based emphasis.  Increments the state
-  ;; of TAG (which must be bound by the calling procedure).  This
-  ;; checks all the various stylesheet mechanisms that may cause an
-  ;; alignment shift as well.
-  (let ((align (or (w3-get-default-style-info 'align)
-		   (and (eq tag 'address) w3-right-justify-address 'right))))
-    (if (and align (not (memq tag '(h1 h2 h3 h4 h5 h6))))
-	(progn
-	  (w3-handle-paragraph)
-	  (w3-push-alignment align))))
-  (let* ((spec (and w3-delimit-emphasis (assoc tag w3-style-tags-assoc)))
-	 (class (cdr-safe (assq 'class args)))
-	 (face (w3-face-for-element))
-	 (voice (w3-voice-for-element))
-	 (beg (and spec (car (cdr spec)))))
-    (if spec
-	(insert beg))
-    (if voice
-	(setq w3-active-voices (cons voice w3-active-voices)))
-    (if face
-	(setq w3-active-faces (cons face w3-active-faces)))))
-
-(defun w3-handle-emphasis-end (&optional args)
-  ;; Generic handler for ending character-based emphasis.  Decrements
-  ;; the state of TAG (which must be bound by the calling procedure).
-  ;; Stylesheet mechanisms may cause arbitrary alignment changes.
-  (let* ((tag (cdr-safe (assq tag w3-end-tags)))
-	 (spec (and w3-delimit-emphasis (assq tag w3-style-tags-assoc)))
-	 (end (and spec (cdr (cdr spec)))))
-    (if (assq tag w3-active-voices)
-	(setq w3-active-voices (cdr (memq (assq tag w3-active-voices)
-					  w3-active-voices)))
-      (setq w3-active-voices (delq tag w3-active-voices)))
-    (if (assq tag w3-active-faces)
-	(setq w3-active-faces (cdr (memq (assq tag w3-active-faces)
-					 w3-active-faces)))
-      (setq w3-active-faces (delq tag w3-active-faces)))
-    (if spec (insert end))
-    (if (eq tag 'address)
-	(progn
-	  (w3-handle-paragraph)
-	  (w3-pop-alignment)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; HTML 3.0 compliance
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-math (&optional args)
-  (w3-handle-br)
-  (w3-handle-text "[START MATH - Not Implemented (Yet)]")
-  (w3-handle-br))
-
-(defun w3-handle-/math (&optional args)
-  (w3-handle-br)
-  (w3-handle-text "[END MATH]")
-  (w3-handle-br))
-
-(defun w3-handle-tr (&optional args)
-  (w3-handle-br))
-
-(defun w3-handle-/tr (&optional args)
-  (w3-handle-br))
-
-(defun w3-handle-td (&optional args)
-  (w3-handle-text " | "))
-
-(defun w3-handle-/td (&optional args)
-  (w3-handle-text " | "))
-
-(defun w3-handle-th (&optional args)
-  (w3-handle-text " | "))
-
-(defun w3-handle-/th (&optional args)
-  (w3-handle-text " | "))
-
-(defun w3-handle-table (&optional args)
-  (w3-handle-br))
-
-(defun w3-handle-/table (&optional args)
-  (w3-handle-br))
-
-(defun w3-handle-div (&optional args)
-  (let ((align (cdr-safe (assq 'align args))))
-    (w3-handle-emphasis args)
-    (w3-handle-paragraph)
-    (setq align (and align (intern (downcase align))))
-    (w3-push-alignment align)))
-
-(defun w3-handle-/div (&optional args)
-  (w3-handle-emphasis-end)
-  (let ((tag (cdr-safe (assq tag w3-end-tags))))
-    (w3-handle-paragraph)
-    (w3-pop-alignment)))
-
-(defun w3-handle-note (&optional args)
-  (w3-handle-emphasis)
-  (w3-handle-paragraph)
-  (let ((align (or (w3-get-default-style-info 'align) 'indent)))
-    (w3-push-alignment align))
-  (w3-handle-text (concat (or (cdr-safe (assq 'role args)) "CAUTION") ":")))
-
-(defun w3-handle-/note (&optional args)
-  (w3-handle-paragraph)
-  (w3-handle-emphasis-end)
-  (let ((tag (cdr-safe (assoc tag w3-end-tags))))
-    (w3-pop-alignment)))
-
-(defun w3-handle-fig (&optional args)
-  (w3-put-state :figdata args)
-  (w3-put-state :figalt (set-marker (make-marker) (point)))
-  )
-
-(defun w3-handle-caption (&optional args)
-  )
-
-(defun w3-handle-/caption (&optional args)
-  )
-
-(defun w3-handle-/fig (&optional args)
-  (let* ((data (w3-get-state :figdata))
-	 (src (cdr-safe (assq 'src data)))
-	 (aln (cdr-safe (assq 'align data)))
-	 (alt (if (w3-get-state :figalt)
-		  (prog1
-		      (buffer-substring (w3-get-state :figalt) (point))
-		    (delete-region (w3-get-state :figalt) (point)))))
-	 (ack nil))
-    (setq w3-last-fill-pos (point))
-    (if (not src)
-	(w3-warn 'html "Malformed  tag.")
-      (setq ack (list (cons 'src src)
-		      (cons 'alt alt)
-		      (cons 'align aln)))
-      (w3-handle-pre nil)
-      (w3-handle-image ack)
-      (w3-handle-/pre nil))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Netscape Compatibility
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; For some reason netscape treats 
     like 
     - ugh.
-(fset 'w3-handle-/br 'w3-handle-br)
-
-(defun w3-create-blank-pixmap (width height)
-  (let ((retval
-	 (concat "/* XPM */\n"
-		 "static char *pixmap[] = {\n"
-		 ;;"/* width height num_colors chars_per_pixel */\n"
-		 (format "\"    %d   %d   2     1\",\n" width height)
-		 ;;"/* colors */\n"
-		 "\". c #000000 s background\",\n"
-		 "\"# c #FFFFFF s foreground\",\n"
-		 ;;"/* pixels /*\n"
-		 ))
-	(line (concat "\"" (make-string width ?.) "\"")))
-    (while (/= 1 height)
-      (setq retval (concat retval line ",\n")
-	    height (1- height)))
-    (concat retval line "\n};")))
-
-(defun w3-handle-spacer (&optional args)
-  (let ((type (cdr-safe (assq 'type args)))
-	(size (cdr-safe (assq 'size args)))
-	(w (or (cdr-safe (assq 'width args)) 1))
-	(h (or (cdr-safe (assq 'height args)) 1))
-	(align (cdr-safe (assq 'align args)))
-	(glyph nil))
-    (condition-case ()
-	(setq glyph (make-glyph
-		     (vector 'xpm :data (w3-create-blank-pixmap w h))))
-      (error nil))
-    )
-  )
-
-(defun w3-handle-font (&optional args)
-  (let* ((sizearg (cdr-safe (assq 'size args)))
-	 (sizenum (cond
-		   ((null sizearg) nil)
-		   ((= ?+ (string-to-char sizearg))
-		    (min (+ 3 (string-to-int (substring sizearg 1))) 7))
-		   ((= ?- (string-to-char sizearg))
-		    (max (- 3 (string-to-int (substring sizearg 1))) 0))
-		   ((string= sizearg (int-to-string (string-to-int sizearg)))
-		    (string-to-int sizearg))
-		   (t nil)))
-	 (family (cdr-safe (assq 'face args)))
-	 (color (cdr-safe (assq 'color args)))
-	 (normcolor (if color (w3-normalize-color color)))
-	 (w3-current-stylesheet  (list
-				  (list 'font
-					(list 'internal
-					      (cons 'font-family family)
-					      (cons 'font-size-index sizenum)
-					      (cons 'foreground normcolor))))))
-    (w3-style-post-process-stylesheet w3-current-stylesheet)
-    (w3-handle-emphasis args)))
-
-(defun w3-handle-/font (&optional args)
-  (w3-handle-emphasis-end))
-
-(defun w3-handle-center (&optional args)
-  (w3-handle-paragraph)
-  (w3-push-alignment 'center))
-
-(defun w3-handle-/center (&optional args)
-  (w3-handle-paragraph)
-  (let ((tag 'center))
-    (w3-pop-alignment)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Bonus HTML Tags just for fun :)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-embed (&optional args)
-  ;; This needs to be reimplemented!!!
-  )
-
-(defun w3-handle-blink (&optional args)
-  ;; Keep track of all the buffers with blinking in them, and do GC
-  ;; of this list whenever a new  tag is encountered.  The
-  ;; timer checks this list to see if any of the buffers are visible,
-  ;; and only blinks the face if there are any visible.  This cuts
-  ;; down tremendously on the amount of X traffic, and frame !@#!age
-  ;; due to lots of face munging.
-  (w3-handle-emphasis args)
-  (let ((buffs w3-blinking-buffs)
-	(name1 (buffer-name))
-	(name2 nil)
-	(add t))
-    (setq w3-blinking-buffs nil)
-    ;; Get rid of old buffers
-    (while buffs
-      (setq name2 (buffer-name (car buffs)))
-      (if (null name2)
-	  nil
-	(setq w3-blinking-buffs (cons (car buffs) w3-blinking-buffs))
-	(if (string= name1 name2)
-	    (setq add nil)))
-      (setq buffs (cdr buffs)))
-    (if add
-	(setq w3-blinking-buffs (cons (current-buffer) w3-blinking-buffs)))))
-
-(defun w3-handle-/blink (&optional args)
-  (w3-handle-emphasis-end args))
-
-(defun w3-handle-peek (&optional args)
-  ;; Handle the peek tag.  Valid attributes are:
-  ;; VARIABLE:: any valid lisp variable
-  ;; If VARIABLE is bound and non-nil, then the value of the variable is
-  ;; inserted at point.  This can handle variables whos values are any
-  ;; arbitrary lisp type.
-  (let* ((var-name (cdr-safe (assq 'variable args)))
-	 (var-sym  (and var-name (intern var-name)))
-	 (val      (and var-sym (boundp var-sym) (symbol-value var-sym))))
-    (cond
-     ((null val) nil)
-     ((stringp val) (w3-handle-text val))
-     (t (w3-handle-text (format "%S" val))))))
-
-(defun w3-rotate-region (st nd &optional rotation)
-  "Ceasar rotate a region between ST and ND using ROTATION as the
-amount to rotate the text.  Defaults to caesar (13)."
-  (setq rotation (or rotation 13))
-  (save-excursion
-    (let (x)
-      (while (< st nd)
-	(setq x (char-after st))
-	(cond
-	 ((and (>= x ?a) (<= x ?z))
-	  (setq x (- x ?a)
-		x (char-to-string (+ (% (+ x rotation) 26) ?a))))
-	 ((and (>= x ?A) (<= x ?Z))
-	  (setq x (- x ?A)
-		x (char-to-string (+ (% (+ x rotation) 26) ?A))))
-	 (t (setq x nil)))
-	(if x (progn (goto-char st) (delete-char 1) (insert x)))
-	(setq st (1+ st))))))
-
-(defun w3-handle-kill-sgml (&optional args)
-  (w3-handle-text "SGML is the spawn of evil!  It must be stopped!"))
-
-(defun w3-handle-secret (&optional args)
-  (if (fboundp 'valid-specifier-locale-p)
-      (let ((tag 'rot13))
-	(w3-handle-emphasis))
-    (w3-put-state :secret (set-marker (make-marker) (point)))))
-
-(defun w3-handle-/secret (&optional args)
-  "Close a secret region of text."
-  (if (fboundp 'valid-specifier-locale-p)
-      (let ((tag '/rot13))
-	(w3-handle-emphasis-end))
-    (if (integer-or-marker-p (w3-get-state :secret))
-	(progn
-	  (w3-rotate-region (w3-get-state :secret) (point))
-	  (w3-put-state :secret nil)))))
-
-(defun w3-handle-hype (&optional args)
-  (if (and (or (featurep 'nas-sound) (featurep 'native-sound))
-	   (assoc 'hype sound-alist))
-      (play-sound 'hype 100)
-    (w3-handle-text "Hey, has Marca A. told you how cool he is?")))
-
-(defun w3-handle-yogsothoth (&optional args)
-  (w3-handle-image (list (cons 'src "href-to-yogsothoth-pic")
-			 (cons 'alt "YOGSOTHOTH LIVES!!!"))))
-
-(defun w3-handle-roach (&optional args)
-  (w3-handle-text "Man, I am so wasted..."))
-
-(defun w3-handle-/roach (&optional args)
-  (w3-handle-text (concat "So, you wanna get some "
-			  (or (cdr-safe (assq 'munchy args))
-			      "nachos") "? ")))
-
-(defun w3-invert-face (face)
-  (let ((buffs w3-blinking-buffs)
-	(blink nil)
-	(buff nil))
-    (if buffs
-	(while buffs
-	  (setq buff (car buffs))
-	  (cond
-	   ((bufferp buff)
-	    (if (buffer-name buff)
-		(setq buff (car buffs))
-	      (setq buff nil)))
-	   ((stringp buff)
-	    (setq buff (get-buffer buff)))
-	   (t
-	    (setq buff nil)))
-	  (setq buffs (cdr buffs)
-		buff (and buff (get-buffer-window buff 'visible))
-		buff (and buff (window-live-p buff)))
-	  (if buff (setq buffs nil
-			 blink t))))
-    (if blink (invert-face face))))
-
-(autoload 'sentence-ify "flame")
-(autoload 'string-ify "flame")
-(autoload '*flame "flame")
-(if (not (fboundp 'flatten)) (autoload 'flatten "flame"))
-
-(defvar w3-cookie-cache nil)
-
-(defun w3-handle-cookie (&optional args)
-  (if (not (fboundp 'cookie))
-      (w3-handle-text "Sorry, no cookies today.")
-    (let* ((url-working-buffer (url-generate-new-buffer-name " *cookie*"))
-	   (href (url-expand-file-name
-		  (or (cdr-safe (assq 'src args))
-		      (cdr-safe (assq 'href args)))
-		  (cdr-safe (assoc (cdr-safe (assq 'base args))
-				   w3-base-alist))))
-	   (fname (or (cdr-safe (assoc href w3-cookie-cache))
-		      (url-generate-unique-filename "%s.cki")))
-	   (st (or (cdr-safe (assq 'start args)) "Loading cookies..."))
-	   (nd (or (cdr-safe (assq 'end args))
-		   "Loading cookies... done.")))
-      (if (not (assoc href w3-cookie-cache))
-	  (save-excursion
-	    (url-clear-tmp-buffer)
-	    (setq url-be-asynchronous nil)
-	    (url-retrieve href)
-	    (url-uncompress)
-	    (write-region (point-min) (point-max) fname 5)
-	    (setq w3-cookie-cache (cons (cons href fname) w3-cookie-cache))))
-      (w3-handle-text (cookie fname st nd)))))
-
-(defun w3-handle-flame (&optional args)
-  (condition-case ()
-      (w3-handle-text
-       (concat
-	(sentence-ify
-	 (string-ify
-	  (append-suffixes-hack (flatten (*flame)))))))
-    (error nil)))
-
-(defun w3-handle-pinhead (&optional args)
-  (if (fboundp 'yow)
-      (w3-handle-text (yow))))
-   
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Client-side Imagemaps
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-map (&optional args)
-  (w3-put-state :map (cons (or (cdr-safe (assq 'name args))
-				     (cdr-safe (assq 'id args))
-				     "unnamed") nil)))
-
-(defun w3-handle-/map (&optional args)
-  (and (w3-get-state :map)
-       (setq w3-imagemaps (cons (w3-get-state :map) w3-imagemaps)))
-  (w3-put-state :map nil))
-
-(defun w3-decode-area-coords (str)
-  (let (retval)
-    (while (string-match "\\([ \t0-9]+\\),\\([ \t0-9]+\\)" str)
-      (setq retval (cons (vector (string-to-int (match-string 1 str))
-				 (string-to-int (match-string 2 str))) retval)
-	    str (substring str (match-end 0) nil)))
-    (if (string-match "\\([0-9]+\\)" str)
-	(setq retval (cons (vector (+ (aref (car retval) 0)
-				      (string-to-int (match-string 1 str)))
-				   (aref (car retval) 1)) retval)))
-    (nreverse retval)))
-
-(defun w3-handle-area (&optional args)
-  (let ((type (downcase (or (cdr-safe (assq 'shape args)) "rect")))
-	(coords (w3-decode-area-coords (or (cdr-safe (assq 'coords args)) "")))
-	(alt (cdr-safe (assq 'alt args)))
-	(href (if (assq 'nohref args)
-		  t
-		(url-expand-file-name
-		 (or (cdr-safe (assq 'src args))
-		     (cdr-safe (assq 'href args)))
-		 (cdr-safe (assoc (cdr-safe (assq 'base args))
-				  w3-base-alist)))))
-	(map (w3-get-state :map)))
-    ;; data structure in storage is a vector
-    ;; if (href == t) then no action should be taken
-    ;; [ type coordinates href (hopefully)descriptive-text]
-    (setcdr map (cons (vector type coords href alt) (cdr map)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Tags that don't really get drawn, etc.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-/html (&optional args)
-  ;; Technically, we are not supposed to have any text outside the
-  ;; html element, so start ignoring everything.
-  (put 'text 'w3-formatter 'ack))
-
-(defun w3-handle-body (&optional args)
-  (if (not w3-user-colors-take-precedence)
-      (let* ((vlink (cdr-safe (assq 'vlink args)))
-	     (alink (cdr-safe (assq 'alink args)))
-	     (link (cdr-safe (assq 'link args)))
-	     (text (cdr-safe (assq 'text args)))
-	     (backg (cdr-safe (assq 'background args)))
-	     (rgb (or (cdr-safe (assq 'bgcolor args))
-		      (cdr-safe (assq 'rgb args))))
-	     (temp-face nil)
-	     (sheet ""))
-	(setq backg (url-expand-file-name
-		     backg
-		     (cdr-safe (assoc (cdr-safe (assq 'base args))
-				      w3-base-alist))))
-	(if (or text rgb backg)
-	    (progn
-	      (setq sheet "html {")
-	      (if text  (setq sheet (format "%scolor: %s; " sheet
-					    (w3-normalize-color text))))
-	      (if rgb   (setq sheet (format "%sbackground: %s; "
-					    sheet (w3-normalize-color rgb))))
-	      (if backg (setq sheet (format "%sbackdrop: %s; "
-					    sheet backg)))
-	      (setq sheet (concat sheet " }\n"))))
-	(if link
-	    (setq sheet (format "%sa.link { color: %s }\n" sheet
-				(w3-normalize-color link))))
-	(if vlink
-	    (setq sheet (format "%sa.visited { color: %s }\n" sheet
-				(w3-normalize-color vlink))))
-	(if alink
-	    (setq sheet (format "%sa.active { color: %s }\n" sheet
-				(w3-normalize-color alink))))
-	(if (/= (length sheet) 0)
-	    (w3-handle-style (list (cons 'data sheet)
-				   (cons 'notation "css")))))))
-
-(defun w3-handle-cryptopts (&optional args)
-  (put 'text 'w3-formatter 'ack))
-
-(defun w3-handle-/cryptopts (&optional args)
-  (put 'text 'w3-formatter nil))
-
-(defun w3-handle-certs (&optional args)
-  (put 'text 'w3-formatter 'ack))
-
-(defun w3-handle-/certs (&optional args)
-  (put 'text 'w3-formatter nil))
-
-(defun w3-handle-base (&optional args)
-  (setq w3-base-alist (cons
-		       (cons (or (cdr-safe (assq 'name args))
-				 (cdr-safe (assq 'id args)))
-			     (or (cdr-safe (assq 'href args))
-				 (cdr-safe (assq 'src args))
-				 (url-view-url t)))
-		       w3-base-alist)))
-
-(defun w3-handle-isindex (&optional args)
-  (let ((prompt (or (cdr-safe (assq 'prompt args))
-		    "Search on (+ separates keywords): "))
-	action)
-    (setq action (url-expand-file-name
-		  (or (cdr-safe (assq 'src args))
-		      (cdr-safe (assq 'href args))
-		      (url-view-url t))
-		  (cdr-safe (assoc (cdr-safe (assq 'base args))
-				   w3-base-alist))))
-    (if (and prompt (string-match "[^: \t-]+$" prompt))
-	(setq prompt (concat prompt ": ")))
-    (if w3-use-forms-index
-	(progn
-	  (w3-handle-hr)
-	  (w3-handle-form (list (cons 'action action)
-				(cons 'enctype "application/x-w3-isindex")
-				(cons 'method "get")))
-	  (w3-handle-text (concat prompt " "))
-	  (w3-handle-input (list (cons 'type "text")
-				 (cons 'name "isindex")))))
-    (setq w3-current-isindex (cons action prompt))))
-
-(defun w3-handle-meta (&optional args)
-  (let* ((equiv (cdr-safe (assq 'http-equiv args)))
-	 (value (cdr-safe (assq 'content args)))
-	 (node  (and equiv (assoc (setq equiv (downcase equiv))
-				  url-current-mime-headers))))
-    (if equiv
-	(setq url-current-mime-headers (cons (cons equiv value)
-					     url-current-mime-headers)))
-    ;; Special-case the Set-Cookie header
-    (if (and equiv (string= (downcase equiv) "set-cookie"))
-	(url-cookie-handle-set-cookie value))
-    ;; Special-case the refresh header
-    (if (and equiv (string= (downcase equiv) "refresh"))
-	(url-handle-refresh-header value))))
-
-(defun w3-handle-link (&optional args)
-  (let* ((dest (cdr-safe (assq 'href args)))
-	 (type (if (assq 'rel args) "Parent of" "Child of"))
-	 (desc (or (cdr-safe (assq 'rel args))
-		   (cdr-safe (assq 'rev args))))
-	 (node-1 (assoc type w3-current-links))
-	 (node-2 (and node-1 desc (assoc desc (cdr node-1))))
-	 (base (cdr-safe (assq 'base args))))
-    (if dest
-	(progn
-	  (setq dest (url-expand-file-name
-		      dest
-		      (cdr-safe (assoc base w3-base-alist))))
-	  (cond
-	   (node-2			; Add to old value
-	    (setcdr node-2 (cons dest (cdr node-2))))
-	   (node-1			; first rel/rev
-	    (setcdr node-1 (cons (cons desc (list dest)) (cdr node-1))))
-	   (t (setq w3-current-links
-		    (cons (cons type (list (cons desc (list dest))))
-			  w3-current-links))))
-	  (if (and dest desc (member (downcase desc)
-					 '("style" "stylesheet")))
-	      (w3-handle-style (list (cons 'src dest))))))))
-
-(defun w3-maybe-start-image-download (widget)
-  (let* ((src (widget-get widget 'src))
-	 (cached-glyph (w3-image-cached-p src)))
-    (if (and cached-glyph (w3-glyphp cached-glyph))
-	(setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting))
-      (cond
-       ((or w3-delay-image-loads (not (fboundp 'valid-specifier-domain-p)))
-	(w3-add-delayed-graphic widget))
-       ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
-	(w3-warn 'images (format "Skipping image %s" (url-basepath src t)))
-	(w3-add-delayed-graphic widget))
-       (t				; Grab the images
-	(let (
-	      (url-request-method "GET")
-	      (old-asynch url-be-asynchronous)
-	      (url-request-data nil)
-	      (url-request-extra-headers nil)
-	      (url-source t)
-	      (url-mime-accept-string (substring
-				       (mapconcat
-					(function
-					 (lambda (x)
-					   (if x
-					       (concat (car x) ",")
-					     "")))
-					w3-allowed-image-types "")
-				       0 -1))
-	      (url-working-buffer (generate-new-buffer-name " *W3GRAPH*")))
-	  (setq-default url-be-asynchronous t)
-	  (setq w3-graphics-list (cons (cons src (make-glyph))
-				       w3-graphics-list))
-	  (save-excursion
-	    (set-buffer (get-buffer-create url-working-buffer))
-	    (setq url-current-callback-data (list widget)
-		  url-be-asynchronous t
-		  url-current-callback-func 'w3-finalize-image-download)
-	    (url-retrieve src))
-	  (setq-default url-be-asynchronous old-asynch)))))))
-
-(defun w3-finalize-image-download (widget)
-  (let ((glyph nil)
-	(url (widget-get widget 'src))
-	(node nil)
-	(buffer (widget-get widget 'buffer)))
-    (message "Enhancing image...")
-    (setq glyph (image-normalize (cdr-safe (assoc url-current-mime-type
-						  w3-image-mappings))
-				 (buffer-string)))
-    (message "Enhancing image... done")
-    (kill-buffer (current-buffer))
-    (cond
-     ((w3-image-invalid-glyph-p glyph)
-      (w3-warn 'image (format "Reading of %s failed." url)))
-     ((eq (aref glyph 0) 'xbm)
-      (let ((temp-fname (url-generate-unique-filename "%s.xbm")))
-	(save-excursion
-	  (set-buffer (generate-new-buffer " *xbm-garbage*"))
-	  (erase-buffer)
-	  (insert (aref glyph 2))
-	  (setq glyph temp-fname)
-	  (write-region (point-min) (point-max) temp-fname)
-	  (kill-buffer (current-buffer)))
-	(setq glyph (make-glyph (list (cons 'x glyph))))
-	(condition-case ()
-	    (delete-file temp-fname)
-	  (error nil))))
-     (t
-      (setq glyph (make-glyph glyph))))
-    (setq node (assoc url w3-graphics-list))
-    (if node
-	(set-glyph-image (cdr node) (glyph-image glyph))
-      (setq w3-graphics-list (cons (cons url glyph) w3-graphics-list)))
-
-    (if (and (buffer-name buffer)	; Dest. buffer exists
-	     (w3-glyphp glyph))		; got a valid glyph
-	(save-excursion
-	  (set-buffer buffer)
-	  (if (eq major-mode 'w3-mode)
-	      (widget-value-set widget glyph)
-	    (setq w3-image-widgets-waiting
-		  (cons widget w3-image-widgets-waiting)))))))
-
-(defun w3-handle-image (&optional args)
-  (let* ((parms args)
-	 (height (cdr-safe (assq 'height parms)))
-	 (width (cdr-safe (assq 'width parms)))
-	 (src (or (cdr-safe (assq 'src parms))
-		  "Error Image"))
-	 (our-alt (cond
-		   ((null w3-auto-image-alt) "")
-		   ((eq t w3-auto-image-alt)
-		    (concat "[IMAGE(" (url-basepath src t) ")] "))
-		   ((stringp w3-auto-image-alt)
-		    (format w3-auto-image-alt (url-basepath src t)))))
-	 (alt (or (cdr-safe (assq 'alt parms))
-		  our-alt))
-	 (ismap (and (assq 'ismap args) 'ismap))
-	 (usemap (cdr-safe (assq 'usemap args)))
-	 (dest (w3-get-state :href))
-	 (base (cdr-safe (assq 'base args)))
-	 (widget nil)
-	 (zone (w3-get-state :zone))
-	 (align (intern (or (cdr-safe (assq 'align parms)) "middle"))))
-    (setq src (url-expand-file-name src
-				    (cdr-safe (assoc base w3-base-alist))))
-    (if dest
-	(w3-handle-hyperlink-end))
-    (setq widget
-	  (widget-create 'image
-			 'src src	; Where to load the image from
-			 'alt alt	; Textual replacement
-			 'ismap ismap	; Is it a server-side map?
-			 'usemap usemap	; Is it a client-side map?
-			 'href dest	; Hyperlink destination
-			 ))
-    (widget-put widget 'buffer (current-buffer))
-    (w3-maybe-start-image-download widget)
-    (goto-char (point-max))
-    (if dest
-	(w3-handle-hyperlink (list (cons 'href dest))))))
-
-(defun w3-handle-title (&optional args)
-  (if (w3-get-state :title)
-      (w3-put-state :title nil))
-  (put 'text 'w3-formatter 'w3-handle-title-text))
-
-(defun w3-handle-title-text (&optional args)
-  (w3-put-state :title
-       (concat (w3-get-state :title) args)))
-
-(defun w3-handle-/title (&optional args)
-  (put 'text 'w3-formatter nil)
-  (let ((ttl (w3-get-state :title)))
-    (if (not (stringp ttl))
-	nil
-      (setq ttl (w3-fix-spaces ttl))
-      (if (and ttl (string= ttl ""))
-	  (setq ttl (w3-fix-spaces (url-view-url t))))
-      (rename-buffer (url-generate-new-buffer-name ttl))
-      ;; Make the URL show in list-buffers output
-      (make-local-variable 'list-buffers-directory)
-      (setq list-buffers-directory (url-view-url t))
-      (w3-put-state :title t))))
-
-(fset 'w3-handle-/head 'w3-handle-/title)
-
-(defun w3-handle-hyperlink (&optional args)
-  (let* ((href-node (assq 'href args))
-	 (href (cdr href-node))
-	 (title (cdr-safe (assq 'title args)))
-	 (base (cdr-safe (assq 'base args)))
-	 (name (or (cdr-safe (assq 'id args))
-		   (cdr-safe (assq 'name args)))))
-    (if href
-	(progn
-	  (setq href (url-expand-file-name href (cdr-safe
-						 (assoc base w3-base-alist))))
-	  (setcdr href-node href)))
-    (w3-put-state :seen-this-url (url-have-visited-url href))
-    (w3-put-state :zone (point))
-    (w3-put-state :link-args args)
-    (if title (w3-put-state :link-title title))
-    (if href (w3-put-state :href href))
-    (if name (w3-put-state :name name))))
-
-(defun w3-follow-hyperlink (widget &rest ignore)
-  (let* ((target (widget-get widget 'target))
-	 (href (widget-get widget 'href))
-	 (tag 'a)
-	 (args '((class . "visited")))
-	 (face (cdr (w3-face-for-element)))
-	 (old-face (and (widget-get widget :from)
-			(get-text-property (widget-get widget :from) 'face)))
-	 (faces (cond
-		 ((and old-face (consp old-face)) (cons face old-face))
-		 (old-face (cons face (list old-face)))
-		 (t (list face)))))	       
-    (if target (setq target (intern (downcase target))))
-    (put-text-property (widget-get widget :from) (widget-get widget :to)
-		       'face faces)
-    (case target
-      ((_blank external)
-       (w3-fetch-other-frame href))
-      (_top
-       (delete-other-windows)
-       (w3-fetch href))
-      (otherwise
-       (w3-fetch href)))))
-
-(defun w3-balloon-help-callback (object &optional event)
-  (let* ((widget (widget-at (extent-start-position object)))
-	 (href (and widget (widget-get widget 'href))))
-    (if href
-	(url-truncate-url-for-viewing href)
-      nil)))
-
-(defun w3-handle-hyperlink-end (&optional args)
-  (let* ((href (w3-get-state :href))
-	 (old-args (w3-get-state :link-args))
-	 (name (w3-get-state :name))
-	 (zone (w3-get-state :zone))
-	 (btdt (and href (w3-get-state :seen-this-url)))
-	 (tag 'a)
-	 (args (list (cons 'class (if btdt "visited" "link"))))
-	 (face (cdr (w3-face-for-element)))
-	 (old-face (and zone (get-text-property zone 'face)))
-	 (faces (cond
-		 ((and old-face (consp old-face)) (cons face old-face))
-		 (old-face (cons face (list old-face)))
-		 (t (list face)))))
-    (if (not href)
-	nil
-      (add-text-properties zone (point)
-			   (list 'mouse-face 'highlight
-				 'button
-				 (append 
-				  (list 'push :args nil :value "" :tag ""
-					:notify 'w3-follow-hyperlink
-					:from (set-marker (make-marker) zone)
-					:to (set-marker (make-marker) (point))
-					)
-				  (alist-to-plist old-args))
-				 'face faces
-				 'balloon-help 'w3-balloon-help-callback
-				 'title (cons
-					 (set-marker (make-marker) zone)
-					 (set-marker (make-marker) (point)))
-				 'help-echo href))
-      (w3-put-state :zone nil)
-      (w3-put-state :href nil)
-      (w3-put-state :name nil)
-      (if (and w3-link-info-display-function
-	       (fboundp w3-link-info-display-function))
-	  (let ((info (condition-case ()
-			  (funcall w3-link-info-display-function href)
-			(error nil))))
-	    (if (and info (stringp info))
-		(w3-handle-text info)))))))
-
-(defvar w3-tab-alist nil
-  "An assoc list of tab stops and their respective IDs")
-(make-variable-buffer-local 'w3-tab-alist)
-
-(defun w3-handle-tab (&optional args)
-  (let* ((id (cdr-safe (assq 'id args)))
-	 (to (cdr-safe (assq 'to args)))
-	 (pos (cdr-safe (assoc to w3-tab-alist))))
-    (cond
-     (id				; Define a new tab stop
-      (setq w3-tab-alist (cons (cons id (current-column)) w3-tab-alist)))
-     ((and to pos)			; Go to a currently defined tabstop
-      (while (<= (current-column) pos)
-	(insert " ")))
-     (to				; Tabstop 'to' is no defined yet
-      (w3-warn 'html (format "Unkown tab stop -- `%s'" to)))
-     (t					; Just do a tab
-      (insert (make-string w3-indent-level ? ))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;  Some bogus shit for pythia
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-margin (&optional args)
-  (if (assq 'reset args)
-      (w3-handle-/blockquote nil)
-    (w3-handle-blockquote nil)))
-  
-(fset 'w3-handle-l 'w3-handle-br)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Guts of the forms interface for the new display engine
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun w3-handle-form (&optional args)
-  (let ((actn (cdr-safe (assq 'action args)))
-	(enct (cdr-safe (assq 'enctype args)))
-	(meth (cdr-safe (assq 'method args))))
-    (if (not meth) (setq args (cons (cons 'method "GET") args)))
-    (if (not actn)
-	(setq args (cons (cons 'action
-			       (or
-				(cdr-safe (assoc (cdr-safe (assq 'base args))
-						 w3-base-alist))
-				(url-view-url t))) args))
-      (setcdr (assq 'action args)
-	      (url-expand-file-name
-	       actn
-	       (cdr-safe (assoc (cdr-safe (assq 'base args))
-				w3-base-alist)))))
-    (if (not enct)
-	(setq args
-	      (cons (cons 'enctype "application/x-www-form-urlencoded")
-		    args)))
-    (w3-put-state :form args)))
-
-(defun w3-handle-/form (&optional args)
-  (w3-handle-paragraph)
-  (w3-put-state :form nil)
-  (w3-put-state :formnum (1+ (w3-get-state :formnum)))
-  )
-
-(defun w3-handle-keygen (&optional args)
-  (w3-form-add-element 'keygen 
-		       (or (cdr-safe (assq 'name args)) "")
-		       nil
-		       nil
-		       1000
-		       nil
-		       (w3-get-state :form)
-		       nil
-		       (w3-get-state :formnum)
-		       nil
-		       (w3-face-for-element)))
-
-(defun w3-handle-input (&optional args)
-  (if (or (not (w3-get-state :form))
-	  (w3-get-state :select))
-      (w3-warn
-       'html
-       " outside of a  or inside  outside of a  or  construct - ERROR!!")
-    (w3-put-state :optargs args)
-    (put 'text 'w3-formatter 'w3-handle-option-data)))
-			     
-(defun w3-handle-select (&optional args)
-  (if (not (w3-get-state :form))
-      (w3-warn 'html "