# HG changeset patch # User cvs # Date 1186988797 -7200 # Node ID 1ce6082ce73ff761d79aa4d998632a2aa019a2ed # Parent 5b0a5bbffab66285b4f84b901cdb62fb503a8d10 Import from CVS: tag r20-0b90 diff -r 5b0a5bbffab6 -r 1ce6082ce73f CHANGES-beta --- a/CHANGES-beta Mon Aug 13 09:05:44 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 09:06:37 2007 +0200 @@ -1,4 +1,13 @@ -*- indented-text -*- +to 20.0 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 20.0 beta34 -- backup-dir 2.0 courtesy of Greg Klanderman -- lazy-lock-1.15 diff -r 5b0a5bbffab6 -r 1ce6082ce73f ChangeLog --- a/ChangeLog Mon Aug 13 09:05:44 2007 +0200 +++ b/ChangeLog Mon Aug 13 09:06:37 2007 +0200 @@ -1,3 +1,11 @@ +Sat Jan 11 12:05:31 1997 Steven L Baur + * XEmacs 20.0 beta90 (prerelease 1) is released. + * XEmacs 19.15 beta90 (prerelease 1) is released. + +Tue Jan 7 08:45:16 1997 Steven L Baur + + * configure.in (LIBS): Revise test for XFree86 (look for XF86Config). + Sat Jan 4 14:52:57 1997 Steven L Baur * XEmacs 20.0 beta 34 is released. * XEmacs 19.15 beta 7 is released. @@ -6,6 +14,133 @@ * lwlib/Makefile.in.in: lwlib is required if X11 is used. +Wed Jan 1 08:30:48 1997 Martin Buchholz + + * src/emacs.c: Make sure + `./temacs -batch -l loadup.el run-temacs ' + works properly + + * src/Makefile.in.in (rtcmacs): Add support for RTC, Sun's + competitor to Purify. + + * man/lispref/symbols.texi: Fix up bit vector documentation + * man/lispref/sequences.texi: Fix up bit vector documentation + + * lisp/sunpro/sunpro-load.el: Only preload mime-setup for Sun. + + * lisp/prim/update-elc.el: Don't rely on autoloads. + +Tue Dec 31 09:46:13 1996 Martin Buchholz + + * lisp/prim/auto-autoloads.el: New, completely program-generated, file + * lib-src/update-autoloads.sh: Rewritten to use auto-autoloads.el. + * lisp/utils/autoload.el: Reorganization of autoload mechanism: + Errors during autoload generation are just that - errors. + + Generated autoloads are now in a separate file of their own. + + Reliability of autoload generation greatly increased. + + Distribution smaller by about 100k. + + `make autoloads' is still the preferred mechanism for update. + + Autoloads are always regenerated completely from scratch. This + avoids errors with obsolete or corrupted autoload entries. + + Caching of autoload entries using timestamps has been eliminated. + + Files that have no autoloads no longer have a comment placed into + the generated autoloads file. + + There was a bug where autoload entries would sometimes end up + being inserted into the *middle* of other autoload entries, + thereby corrupting them. + + * src/event-Xt.c: Remove SUNOS_GCC_L0_BUG kludge. + +Sun Dec 29 05:37:43 1996 Martin Buchholz + + * lib-src/update-autoloads.sh: Make sure that `make autoloads' + doesn't use the autoload facility to load `autoload'; + load it explicity instead. + + * lib-src/update-elc.sh (ignore_dirs): ignore SCCS, CVS, RCS dirs + + * man/Makefile: Reinstate hyperbole & oo-browser manuals + + * lisp/modes/mail-abbrevs.el: Apply patch originated from Noah Friedman + + * src/mule-charset.c: Use lower case for charset registry, to + match XLFD. + + * Makefile.in: replace list of info files with *.info* - one less + maintenance headache + + * etc/sample.emacs: Add sample code to highlight continuation glyph + + * man/oo-browser.texi: Fix TeXability + + * man/hyperbole.texi: Fix TeXability + + * man/vhdl-mode.texi: Fix TeXability + + * lisp/prim/loaddefs.el: Wholesale housecleaning + `make autoloads' should finally work. + + * lib-src/emacsclient.c (main): ANSIfication, compiler warning removal + + * lisp/mule/mule-files.el: Add support for multi-lingual info files. + + * lib-src/update-elc.sh: `make all-elc' was updating files in + `special' directories without using the Makefiles + designed for that purpose. + - make sure ilisp isn't remade every time through `make all-elc'. + + * info/dir (Packages): Add Japanese TM info files + + * src/inline.c: Allow compilation with `gcc -g' + + * src/syntax.c (word_constituent_p): Allow compilation with `gcc -g' + + * src/lread.c: Don't put `...' immediately after a filename, so + that various tools can recognize the filename as such. + + * src/event-Xt.c (x_to_emacs_keysym): Fix crash when + --with-xim=xlib and key event on window frame. + Change return foo to return (foo) when return is a macro. + + * src/editfns.c (Ffollowing_char): docstring fixes. + + * man/tm/Makefile: Add support for Japanese TM info (but not dvi) files. + This Makefile is no longer officially broken. + + * info/dir: Add Japanese tm documents. + + * man/tm/tm-vm-en.texi: Make document TeX-friendly. + + * lib-src/update-autoloads.sh (EMACS): Don't rely on non-portable + xargs -i flag. + + * lisp/mule/mule-files.el (file-coding-system-alist): Make sure + the `binary' coding system is used for .gz and .Z extensions. + + * man/viper.texi: Viper version 2.90 + + * man/ediff.texi: Ediff Version 2.62 + + * lisp/packages/ispell.el (ispell-word): Avoid using strings with + define-key, for compatibility with loaddefs.el + + * lisp/modes/eiffel3.el: Make compatible with update-autoloads. + + * lisp/ilisp/Makefile (elc): Add target to avoid re-compilation. + + * lib-src/update-elc.sh: XEmacs sometimes re-byte-compiled elisp + files in dirs that have their own Makefiles. + + + Sun Dec 29 17:02:49 1996 Steven L Baur * Makefile.in (install-arch-indep): Force compression with `gzip -f'. diff -r 5b0a5bbffab6 -r 1ce6082ce73f Makefile.in --- a/Makefile.in Mon Aug 13 09:05:44 2007 +0200 +++ b/Makefile.in Mon Aug 13 09:06:37 2007 +0200 @@ -234,7 +234,7 @@ # Sub-target for all-elc. dump-elc dump-elcs: FRC.dump-elcs - cd src; $(MAKE) dump-elcs $(MFLAGS) \ + cd src && $(MAKE) dump-elcs $(MFLAGS) \ CC='${CC}' CFLAGS='${CFLAGS}' MAKE='${MAKE}' autoloads: src @@ -299,7 +299,7 @@ .RECURSIVE: ${SUBDIR} ${SUBDIR}: ${SUBDIR_MAKEFILES} src/config.h FRC - cd $@; $(MAKE) all $(MFLAGS) \ + cd $@ && $(MAKE) all $(MFLAGS) \ CC='${CC}' CFLAGS='${CFLAGS}' MAKE='${MAKE}' Makefile: ${srcdir}/Makefile.in config.status @@ -352,7 +352,7 @@ $(MAKE) install $(MFLAGS) prefix=${prefix} \ exec_prefix=${exec_prefix} bindir=${bindir} libdir=${libdir} \ archlibdir=${archlibdir}) - if [ `(cd ${archlibdir}; /bin/pwd)` != `(cd ./lib-src; /bin/pwd)` ]; \ + if [ `(cd ${archlibdir} && /bin/pwd)` != `(cd ./lib-src && /bin/pwd)` ]; \ then \ ${INSTALL_DATA} lib-src/DOC ${archlibdir}/DOC ; \ for subdir in `find ${archlibdir} -type d ! -name RCS ! -name SCCS ! -name CVS -print` ; do \ @@ -363,7 +363,7 @@ ${INSTALL_PROGRAM} src/xemacs ${bindir}/xemacs-${version} -chmod 0755 ${bindir}/xemacs-${version} rm -f ${bindir}/xemacs - (cd ${bindir} ; ${LN_S} xemacs-${version} ./xemacs) + (cd ${bindir} && ${LN_S} xemacs-${version} ./xemacs) install-arch-indep: mkdir -set ${COPYDESTS} ; \ @@ -380,7 +380,8 @@ [ -d $${dir} ] \ && [ `(cd $${dir} && /bin/pwd)` != `(cd $${dest} && /bin/pwd)` ] \ && (echo "Copying $${dir}..." ; \ - (cd $${dir}; tar -cf - . )|(cd $${dest};umask 022; tar -xf - );\ + (cd $${dir} && tar -cf - . ) | \ + (cd $${dest} && umask 022 && tar -xf - );\ chmod 0755 $${dest}; \ for subdir in `find $${dest} -type d ! -name RCS ! -name SCCS ! -name CVS -print` ; do \ rm -rf $${subdir}/RCS $${subdir}/CVS $${subdir}/SCCS ; \ @@ -389,17 +390,17 @@ done if [ `(cd ${srcdir}/info && /bin/pwd)` != `(cd ${infodir} && /bin/pwd)` ]; \ then \ - (cd ${srcdir}/info ; \ + (cd ${srcdir}/info && \ if [ ! -f ${infodir}/dir ] && [ -f dir ]; then \ ${INSTALL_DATA} ${srcdir}/info/dir ${infodir}/dir ; \ fi ; \ for f in *.info* ; do \ ${INSTALL_DATA} ${srcdir}/info/$$f ${infodir}/$$f ; \ chmod 0644 ${infodir}/$$f; \ - gzip -f9 ${infodir}/$$f; \ + gzip -9 -f ${infodir}/$$f; \ done); \ else true; fi - cd ${srcdir}/etc; for page in xemacs etags ctags gnuserv \ + cd ${srcdir}/etc && for page in xemacs etags ctags gnuserv \ gnuclient gnuattach gnudoit ; do \ ${INSTALL_DATA} ${srcdir}/etc/$${page}.1 ${mandir}/$${page}${manext} ; \ chmod 0644 ${mandir}/$${page}${manext} ; \ @@ -574,10 +575,10 @@ @echo "If you don't have a copy of etags around, then do 'make lib-src' first." @PATH=`pwd`/lib-src:$$PATH HOME=/-=-; export PATH HOME; \ echo "Using etags from `which etags`." - PATH=`pwd`/lib-src:$$PATH ; export PATH; cd ${srcdir} ; \ + PATH=`pwd`/lib-src:$$PATH ; export PATH; cd ${srcdir} && \ etags --regex='/[ ]*DEF\(VAR\|INE\)_[A-Z_]+[ ]*([ ]*"\([^"]+\)"/\2/' src/*.[ch] ; \ for d in `find lisp -name SCCS -prune -o -name RCS -prune -o -type d -print` ; do \ - (cd $$d ; if [ "`echo *.el`" != "*.el" ] ; then etags -a -o ${srcdir}/TAGS *.el ; fi ) ; \ + (cd $$d && if [ "`echo *.el`" != "*.el" ] ; then etags -a -o ${srcdir}/TAGS *.el ; fi ) ; \ done ; \ etags -a lwlib/*.[ch] diff -r 5b0a5bbffab6 -r 1ce6082ce73f configure --- a/configure Mon Aug 13 09:05:44 2007 +0200 +++ b/configure Mon Aug 13 09:06:37 2007 +0200 @@ -3011,7 +3011,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 @@ -5519,23 +5521,33 @@ # AIX export list -for export in /usr/lpp/X11/bin/smt.exp /usr/bin/X11/smt.exp ; do - if test -f "$export" ; then - -{ -test -n "$verbose" && \ -echo " defining" AIX_SMT_EXP to be "-bI:$export" -echo "#define" AIX_SMT_EXP "-bI:$export" >> confdefs.h -DEFS="$DEFS -DAIX_SMT_EXP=-bI:$export" -ac_sed_defs="${ac_sed_defs}\${ac_dA}AIX_SMT_EXP\${ac_dB}AIX_SMT_EXP\${ac_dC}-bI:\\\\\\\$export\${ac_dD} -\${ac_uA}AIX_SMT_EXP\${ac_uB}AIX_SMT_EXP\${ac_uC}-bI:\\\\\\\$export\${ac_uD} -\${ac_eA}AIX_SMT_EXP\${ac_eB}AIX_SMT_EXP\${ac_eC}-bI:\\\\\\\$export\${ac_eD} -" -} - - break - fi -done +if test -f /usr/lpp/X11/bin/smt.exp ; then + +{ +test -n "$verbose" && \ +echo " defining" AIX_SMT_EXP to be "-bI:/usr/lpp/X11/bin/smt.exp" +echo "#define" AIX_SMT_EXP "-bI:/usr/lpp/X11/bin/smt.exp" >> confdefs.h +DEFS="$DEFS -DAIX_SMT_EXP=-bI:/usr/lpp/X11/bin/smt.exp" +ac_sed_defs="${ac_sed_defs}\${ac_dA}AIX_SMT_EXP\${ac_dB}AIX_SMT_EXP\${ac_dC}-bI:/usr/lpp/X11/bin/smt.exp\${ac_dD} +\${ac_uA}AIX_SMT_EXP\${ac_uB}AIX_SMT_EXP\${ac_uC}-bI:/usr/lpp/X11/bin/smt.exp\${ac_uD} +\${ac_eA}AIX_SMT_EXP\${ac_eB}AIX_SMT_EXP\${ac_eC}-bI:/usr/lpp/X11/bin/smt.exp\${ac_eD} +" +} + +elif test -f /usr/bin/X11/smt.exp ; then + +{ +test -n "$verbose" && \ +echo " defining" AIX_SMT_EXP to be "-bI:/usr/bin/X11/smt.exp" +echo "#define" AIX_SMT_EXP "-bI:/usr/bin/X11/smt.exp" >> confdefs.h +DEFS="$DEFS -DAIX_SMT_EXP=-bI:/usr/bin/X11/smt.exp" +ac_sed_defs="${ac_sed_defs}\${ac_dA}AIX_SMT_EXP\${ac_dB}AIX_SMT_EXP\${ac_dC}-bI:/usr/bin/X11/smt.exp\${ac_dD} +\${ac_uA}AIX_SMT_EXP\${ac_uB}AIX_SMT_EXP\${ac_uC}-bI:/usr/bin/X11/smt.exp\${ac_uD} +\${ac_eA}AIX_SMT_EXP\${ac_eB}AIX_SMT_EXP\${ac_eC}-bI:/usr/bin/X11/smt.exp\${ac_eD} +" +} + +fi CFLAGS="$REAL_CFLAGS" diff -r 5b0a5bbffab6 -r 1ce6082ce73f configure.in --- a/configure.in Mon Aug 13 09:05:44 2007 +0200 +++ b/configure.in Mon Aug 13 09:06:37 2007 +0200 @@ -2091,7 +2091,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 5b0a5bbffab6 -r 1ce6082ce73f dynodump/Makefile.in.in --- a/dynodump/Makefile.in.in Mon Aug 13 09:05:44 2007 +0200 +++ b/dynodump/Makefile.in.in Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f etc/sample.emacs --- a/etc/sample.emacs Mon Aug 13 09:05:44 2007 +0200 +++ b/etc/sample.emacs Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f etc/viperCard.tex --- a/etc/viperCard.tex Mon Aug 13 09:05:44 2007 +0200 +++ b/etc/viperCard.tex Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/Makefile.in.in --- a/lib-src/Makefile.in.in Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/Makefile.in.in Mon Aug 13 09:06:37 2007 +0200 @@ -303,13 +303,13 @@ ./make-path ${archlibdir} if [ `(cd ${archlibdir} && /bin/pwd)` != `/bin/pwd` ]; then \ for file in ${UTILITIES}; do \ - (cd ..; $(INSTALL_PROGRAM) lib-src/$$file ${archlibdir}/$$file) ; \ + (cd .. && $(INSTALL_PROGRAM) lib-src/$$file ${archlibdir}/$$file) ; \ done ; \ fi if [ `(cd ${archlibdir} && /bin/pwd)` \ != `(cd ${srcdir} && /bin/pwd)` ]; then \ for file in ${SCRIPTS}; do \ - (cd ..; $(INSTALL_PROGRAM) ${srcdir}/$$file ${archlibdir}/$$file); \ + (cd .. && $(INSTALL_PROGRAM) ${srcdir}/$$file ${archlibdir}/$$file); \ done ; \ fi @@ -319,16 +319,16 @@ @echo @echo "Installing utilities for users to run." for file in ${INSTALLABLES} ; do \ - (cd ..; $(INSTALL_PROGRAM) lib-src/$${file} ${bindir}/$${file}) ; \ + (cd .. && $(INSTALL_PROGRAM) lib-src/$${file} ${bindir}/$${file}) ; \ done for file in ${INSTALLABLE_SCRIPTS} ; do \ - (cd ..; $(INSTALL_PROGRAM) ${srcdir}/$${file} ${bindir}/$${file}) ; \ + (cd .. && $(INSTALL_PROGRAM) ${srcdir}/$${file} ${bindir}/$${file}) ; \ done uninstall: - (cd ${bindir}; \ + (cd ${bindir} && \ rm -f ${INSTALLABLES} ${INSTALLABLE_SCRIPTS}) - (cd ${archlibdir}; \ + (cd ${archlibdir} && \ rm -f ${UTILITIES} ${INSTALLABLES} ${SCRIPTS} ${INSTALLABLE_SCRIPTS}) mostlyclean: @@ -383,7 +383,7 @@ etags: ${srcdir}/etags.c $(GETOPTDEPS) $(REGEXDEPS) ../src/config.h $(CC) ${ALL_CFLAGS} -DVERSION="\"${version}\"" -DETAGS_REGEXPS ${srcdir}/etags.c $(GETOPTOBJS) $(REGEXOBJ) $(LOADLIBES) -o etags -/* We depend on etags to assure that parallel makes don't write two +/* We depend on etags to assure that parallel makes do not write two etags.o files on top of each other. */ ctags: ${srcdir}/etags.c $(GETOPTDEPS) etags $(CC) ${ALL_CFLAGS} -DCTAGS -DVERSION="\"${version}\"" ${srcdir}/etags.c $(GETOPTOBJS) $(LOADLIBES) -o ctags @@ -433,7 +433,7 @@ make-po: ${srcdir}/make-po.c $(CC) ${CPP_CFLAGS} ${srcdir}/make-po.c $(LOADLIBES) -o make-po -/* Why oh why doesn't HP include half of the standard X distribution? */ +/* Why oh why does HP not include half of the standard X distribution? */ #if defined (HAVE_XAUTH) gnuslib.o: ${srcdir}/gnuslib.c ${srcdir}/gnuserv.h ../src/config.h diff -r 5b0a5bbffab6 -r 1ce6082ce73f lib-src/emacsclient.c --- a/lib-src/emacsclient.c Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/emacsclient.c Mon Aug 13 09:06:37 2007 +0200 @@ -44,7 +44,7 @@ fprintf (stderr, "%s: Sorry, the Emacs server is supported only\n", argv[0]); fprintf (stderr, "on systems with Berkeley sockets or System V IPC.\n"); - exit (1); + return 1; } #else /* HAVE_SOCKETS or HAVE_SYSVIPC */ @@ -321,7 +321,7 @@ strcpy (buf, msgp->mtext); printf ("\n%s\n", buf); - exit (0); + return 0; } #endif /* HAVE_SYSVIPC */ diff -r 5b0a5bbffab6 -r 1ce6082ce73f lib-src/gnudoit.c --- a/lib-src/gnudoit.c Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/gnudoit.c Mon Aug 13 09:06:37 2007 +0200 @@ -45,7 +45,7 @@ #else /* SYSV_IPC || UNIX_DOMAIN_SOCKETS || INTERNET_DOMAIN_SOCKETS */ int -main(int argc, char *argv[]) +main (int argc, char *argv[]) { int qflg = 0; /* don't wait around for * gnu emacs to eval cmd */ diff -r 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tm-au --- a/lib-src/tm-au Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tm-au Mon Aug 13 09:06:37 2007 +0200 @@ -1,8 +1,10 @@ #!/bin/sh - # -# $Id: tm-au,v 1.2 1996/12/28 21:02:51 steve Exp $ +# $Id: tm-au,v 1.3 1997/01/11 20:13:51 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tm-file --- a/lib-src/tm-file Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tm-file Mon Aug 13 09:06:37 2007 +0200 @@ -1,8 +1,10 @@ #!/bin/sh - # -# $Id: tm-file,v 1.2 1996/12/28 21:02:51 steve Exp $ +# $Id: tm-file,v 1.3 1997/01/11 20:13:51 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tm-html --- a/lib-src/tm-html Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tm-html Mon Aug 13 09:06:37 2007 +0200 @@ -1,8 +1,10 @@ #!/bin/sh # -# $Id: tm-html,v 1.2 1996/12/28 21:02:51 steve Exp $ +# $Id: tm-html,v 1.3 1997/01/11 20:13:51 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tm-image --- a/lib-src/tm-image Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tm-image Mon Aug 13 09:06:37 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-image,v 1.2 1996/12/28 21:02:52 steve Exp $ +# $Id: tm-image,v 1.3 1997/01/11 20:13:51 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tm-mpeg --- a/lib-src/tm-mpeg Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tm-mpeg Mon Aug 13 09:06:37 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-mpeg,v 1.2 1996/12/28 21:02:52 steve Exp $ +# $Id: tm-mpeg,v 1.3 1997/01/11 20:13:51 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tm-plain --- a/lib-src/tm-plain Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tm-plain Mon Aug 13 09:06:37 2007 +0200 @@ -1,8 +1,10 @@ #!/bin/sh - # -# $Id: tm-plain,v 1.2 1996/12/28 21:02:52 steve Exp $ +# $Id: tm-plain,v 1.3 1997/01/11 20:13:52 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tm-ps --- a/lib-src/tm-ps Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tm-ps Mon Aug 13 09:06:37 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-ps,v 1.2 1996/12/28 21:02:52 steve Exp $ +# $Id: tm-ps,v 1.3 1997/01/11 20:13:52 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/tmdecode --- a/lib-src/tmdecode Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/tmdecode Mon Aug 13 09:06:37 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tmdecode,v 1.2 1996/12/28 21:02:52 steve Exp $ +# $Id: tmdecode,v 1.3 1997/01/11 20:13:52 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 5b0a5bbffab6 -r 1ce6082ce73f lib-src/update-autoloads.sh --- a/lib-src/update-autoloads.sh Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/update-autoloads.sh Mon Aug 13 09:06:37 2007 +0200 @@ -1,5 +1,5 @@ #!/bin/sh -### update-autoloads.sh --- update auto-loaddefs.el as necessary +### update-autoloads.sh --- update auto-autoloads.el as necessary set -eu diff -r 5b0a5bbffab6 -r 1ce6082ce73f lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 09:05:44 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 09:06:37 2007 +0200 @@ -39,8 +39,8 @@ els=/tmp/rcl1.$$ ; elcs=/tmp/rcl2.$$ rm -f $els $elcs trap "rm -f $els $elcs" 0 1 2 3 15 -find lisp/. -name SCCS -prune -o -name '*.el' -print | sort > $els -find lisp/. -name SCCS -prune -o -name '*.elc' -print | sed 's/elc$/el/' | sort > $elcs +find lisp/. $prune_vc -name '*.el' -print | sort > $els +find lisp/. $prune_vc -name '*.elc' -print | sed 's/elc$/el/' | sort > $elcs echo "Deleting .elc files without .el files..." @@ -78,15 +78,14 @@ } make_special vm -make_special ediff elc -make_special viper elc +#make_special ediff elc +#make_special viper elc make_special gnus some make_special w3 -make_special url # really part of w3 make_special hyperbole elc make_special oobr HYPB_ELC='' elc make_special eos -k # not stricly necessary... -make_special ilisp elc -f Makefile +make_special ilisp elc ignore_pattern='' for dir in $ignore_dirs ; do @@ -122,9 +121,9 @@ echo "Compiling files with out-of-date .elc..." -find lisp/. -name CVS -prune -o -name SCCS -prune -o -type d -print | \ +find lisp/* $prune_vc -type d -print | \ sed "$ignore_pattern" | \ - xargs -t $REAL -batch -q -no-site-file -f batch-byte-recompile-directory + xargs -t $BYTECOMP -f batch-byte-recompile-directory echo "Compiling files with out-of-date .elc... Done" diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/ChangeLog --- a/lisp/ChangeLog Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 09:06:37 2007 +0200 @@ -1,3 +1,71 @@ +Fri Jan 10 22:27:58 1997 Shane Holder + + * utils/bench.el: New version. + +Fri Jan 10 13:22:26 1997 Christoph Wedler + + * packages/man.el (Manual-entry-switches): New variable. + (Manual-apropos-switches): New variable. + (Manual-run-formatter): Use them. + +Thu Jan 9 22:04:42 1997 Greg Klanderman + + * modes/make-mode.el: Allow disabling of suspicious line warnings + allow macro pickup when a macro is entered normally + add the runtime macros to the completion list so confirmation is + not necessary when minibuffer-confirm-incomplete is t. + (these last two only in effect when makefile-electric-keys=t) + +Thu Jan 9 11:44:11 1997 Martin Buchholz + + * mule/mule-files.el (file-coding-system-alist): Default to 8 bit + on .el and .info files. + +Wed Jan 8 20:57:16 1997 Steven L Baur + + * prim/help.el (help-mode-quit): Correct typo in docstring. + (help-mode-quit): Bury help buffer before restoring previous + window configuration. + +Wed Jan 8 20:20:01 1997 Joe Nuspl + + * x11/x-menubar.el (default-menubar): Include enriched.doc in the + samples in the help menu. + +Wed Jan 8 20:09:32 1997 Jens Krinke + + * x11/x-toolbar.el (toolbar-news-frame-properties): New variable. + (toolbar-news): Use it. + +Wed Jan 8 10:11:35 1997 Steven L Baur + + * x11/x-compose.el (global-map): Keysyms use `-' not `_'. + +Mon Jan 6 18:19:03 1997 Steven L Baur + + * comint/telnet.el (telnet-initial-filter): Enable + case-fold-search. + (telnet-maximum-count): Bump up to 6, since 4 does not always + appear to be enough. + +Mon Jan 6 08:30:55 1997 Andrew Cohen + + * psgml/psgml-parse.el (sgml-compile-dtd): noconv coding system + has been renamed to no-conversion. + (sgml-bdtd-merge): Ditto. + (sgml-push-to-entity): Ditto. + +Sun Jan 5 14:35:30 1997 Steven L Baur + + * utils/loadhist.el (symbol-file): Make interactive. + +Sun Jan 5 00:40:02 1997 Bob Weiner + + * packages/avoid.el (mouse-avoidance-mode): autoload. + + * x11/x-menubar.el (options-menu-saved-forms): Mouse avoidance + mode option. + Sat Jan 4 12:25:34 1997 Steven L Baur * prim/faces.el (init-other-random-faces): Guard against adding diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/comint/telnet.el --- a/lisp/comint/telnet.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/comint/telnet.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/Makefile --- a/lisp/ediff/Makefile Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/Makefile Mon Aug 13 09:06:37 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 "" diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/README --- a/lisp/ediff/README Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/README Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-diff.el --- a/lisp/ediff/ediff-diff.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-diff.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-help.el --- a/lisp/ediff/ediff-help.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-help.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-hook.el --- a/lisp/ediff/ediff-hook.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-hook.el Mon Aug 13 09:06:37 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 @@ -63,7 +70,8 @@ (add-submenu '("Tools") epatch-menu "OO-Browser...") (add-menu-button - '("Tools") "-------" "OO-Browser...") + '("Tools") + ["-------" nil nil] "OO-Browser...") ))) @@ -143,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] '("--")) @@ -183,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 @@ -225,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)) @@ -337,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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-init.el --- a/lisp/ediff/ediff-init.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-init.el Mon Aug 13 09:06:37 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, @@ -378,7 +378,7 @@ *** *** Please contact your system administrator. " (if ediff-xemacs-p "X" ""))) - + ;; Selective browsing (ediff-defvar-local ediff-skip-diff-region-function 'ediff-show-all-diffs @@ -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))) @@ -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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-merg.el --- a/lisp/ediff/ediff-merg.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-merg.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-mult.el --- a/lisp/ediff/ediff-mult.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-mult.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-ptch.el --- a/lisp/ediff/ediff-ptch.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-ptch.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-util.el --- a/lisp/ediff/ediff-util.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-util.el Mon Aug 13 09:06:37 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 @@ -983,7 +1002,6 @@ (ediff-abbreviate-file-name file) (beep 1))) )))) - ;; checkout if visited file is checked in (defun ediff-maybe-checkout (buf) (let ((file (buffer-file-name buf)) @@ -1160,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 () @@ -1267,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)))) @@ -1517,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)) @@ -1553,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)) @@ -2320,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)) @@ -2446,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) @@ -2468,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)))) )) @@ -2907,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) @@ -2925,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) @@ -2965,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) @@ -3011,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 @@ -3020,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 @@ -3028,8 +3089,8 @@ 'ediff-regions-linewise ; job name nil) ; no word mode )) - - + + (defun ediff-remove-flags-from-buffer (buffer overlay) (ediff-eval-in-buffer buffer @@ -3185,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 "^[ *]"). @@ -3595,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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-vers.el --- a/lisp/ediff/ediff-vers.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-vers.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff-wind.el --- a/lisp/ediff/ediff-wind.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff-wind.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/ediff/ediff.el --- a/lisp/ediff/ediff.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/ediff/ediff.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/games/decipher.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/games/decipher.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/gnus/Makefile --- a/lisp/gnus/Makefile Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/gnus/Makefile Mon Aug 13 09:06:37 2007 +0200 @@ -1,6 +1,6 @@ SHELL = /bin/sh EMACS=emacs -FLAGS=-batch -q -no-site-file -l ./dgnushack.el +FLAGS=-batch -q -no-site-file -l bytecomp -l ./dgnushack.el all: rm -f *.elc ; $(EMACS) $(FLAGS) -f dgnushack-compile diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/hyperbole/Makefile --- a/lisp/hyperbole/Makefile Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/hyperbole/Makefile Mon Aug 13 09:06:37 2007 +0200 @@ -172,7 +172,7 @@ || (echo "These files will be compiled: " \ && echo "`cat $(ELISP_TO_COMPILE)`" \ && $(EMACS) $(BATCHFLAGS) $(PRELOADS) \ - -f batch-byte-compile `cat $(ELISP_TO_COMPILE)`) + -l bytecomp -f batch-byte-compile `cat $(ELISP_TO_COMPILE)`) @ $(RM) $(ELISP_TO_COMPILE) elc-init: diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/modes/make-mode.el --- a/lisp/modes/make-mode.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/modes/make-mode.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/mule/mule-coding.el --- a/lisp/mule/mule-coding.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/mule/mule-coding.el Mon Aug 13 09:06:37 2007 +0200 @@ -42,12 +42,10 @@ (defun what-coding-system (start end &optional arg) "Show the encoding of text in the region. -With prefix arg, show all possible coding systems. This function is meant to be called interactively; from a Lisp program, use `detect-coding-region' instead." (interactive "r\nP") - (let ((codings (detect-coding-region start end))) - (message "%s" (if (or arg (symbolp codings)) codings (car codings))))) + (princ (detect-coding-region start end))) (defmacro with-string-as-buffer-contents (str &rest body) "With the contents of the current buffer being STR, run BODY. diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/mule/mule-files.el --- a/lisp/mule/mule-files.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/mule/mule-files.el Mon Aug 13 09:06:37 2007 +0200 @@ -52,8 +52,8 @@ (defvar file-coding-system-alist ;; '(; ("\\.el$" . euc-japan) - '(("\\.el$" . iso-2022-7) - ("\\.info$" . iso-2022-7) + '(("\\.el$" . iso-2022-8) + ("\\.info$" . iso-2022-8) ("\\.\\(gz\\|Z\\)$" . binary) ("/spool/mail/.*$" . convert-mbox-coding-system)) "Alist specifying the coding system used for particular files. @@ -403,8 +403,7 @@ FILENAME, APPEND, VISIT, and CODING-SYSTEM, the same as the corresponding arguments in the call to `write-region'.") -(defun write-region (start end filename &optional append visit lockname - coding-system) +(defun write-region (start end filename &optional append visit lockname coding-system) "Write current region into specified file. When called from a program, takes three arguments: START, END and FILENAME. START and END are buffer positions. diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/packages/avoid.el --- a/lisp/packages/avoid.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/packages/avoid.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/packages/lazy-lock.el --- a/lisp/packages/lazy-lock.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/packages/lazy-lock.el Mon Aug 13 09:06:37 2007 +0200 @@ -874,7 +874,9 @@ ;; These fix bugs in `text-property-any' and `text-property-not-all'. They may ;; not work perfectly in 19.11 and below because `next-single-property-change' ;; is also broke and not easily fixable in Lisp. -(if (and lazy-lock-running-xemacs-p (< emacs-minor-version 12)) +(if (and lazy-lock-running-xemacs-p + (= emacs-major-version 19) + (< emacs-minor-version 12)) (progn ;; Loop through property changes until found. This fix includes a work ;; around which prevents a bug in `window-start' causing a barf here. @@ -904,7 +906,9 @@ ;; than `face'. Since `font-lock-unfontify-region' only removes `face', and we ;; have non-font-lock properties hanging about, `text-prop' never gets removed. ;; Unfortunately `font-lock-any-extents-p' is inlined so we can't redefine it. -(if (and lazy-lock-running-xemacs-p (< emacs-minor-version 12)) +(if (and lazy-lock-running-xemacs-p + (= emacs-major-version 19) + (< emacs-minor-version 12)) (add-hook 'font-lock-mode-hook (function (lambda () (remove-hook 'after-change-functions 'font-lock-after-change-function) @@ -921,7 +925,9 @@ ;; Now set `fontified' to t to stop `lazy-lock-fontify-window'. (put-text-property beg end 'fontified t)))))))))) -(if (and lazy-lock-running-xemacs-p (>= emacs-minor-version 12)) +(if (and lazy-lock-running-xemacs-p + (or (> emacs-major-version 19) + (>= emacs-minor-version 12))) ;; XEmacs 19.12 font-lock.el's `font-lock-fontify-buffer' runs a hook. (add-hook 'font-lock-after-fontify-buffer-hook 'lazy-lock-after-fontify-buffer)) diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/packages/man.el --- a/lisp/packages/man.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/packages/man.el Mon Aug 13 09:06:37 2007 +0200 @@ -575,17 +575,21 @@ (error (buffer-substring (point) (progn (end-of-line) (point)))))) nil) - +(defvar Manual-entry-switches '("-s") + "Switches for `manual-entry' including switch for section (at the end).") +(defvar Manual-apropos-switches nil + "Additional switches for `Manpage-apropos' excluding switch `-k'.") + (defun Manual-run-formatter (name topic section) (cond ((string-match "roff\\'" Manual-program) ;; kludge kludge (call-process Manual-program nil t nil "-Tman" "-man" name)) - (Manual-section-switch - (call-process Manual-program nil t nil Manual-section-switch - section topic)) (t - (call-process Manual-program nil t nil section topic)))) - + (apply 'call-process Manual-program nil t nil + (append (if apropos-mode + Manual-apropos-switches + Manual-entry-switches) + (list section topic)))))) (defvar Manual-mode-map (let ((m (make-sparse-keymap))) diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 09:06:37 2007 +0200 @@ -1339,7 +1339,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" "\ @@ -1776,6 +1776,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" "\ @@ -3631,7 +3654,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.3 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.4 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -4928,7 +4951,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.3 $ +vhdl-mode $Revision: 1.4 $ 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 @@ -5308,6 +5331,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', @@ -6589,9 +6618,9 @@ If nil, the default personal dictionary, \"~/.ispell_DICTNAME\" is used, where DICTNAME is the name of your default dictionary.") -(defvar ispell-dictionary-alist-1 '((nil "[A-Za-z]" "[^A-Za-z]" "[']" nil ("-B") nil) ("english" "[A-Za-z]" "[^A-Za-z]" "[']" nil ("-B") nil) ("british" "[A-Za-z]" "[^A-Za-z]" "[']" nil ("-B" "-d" "british") nil) ("deutsch" "[a-zA-Z\"]" "[^a-zA-Z\"]" "[']" t ("-C") "~tex") ("deutsch8" "[a-zA-Z,ADV\dv_|(B]" "[^a-zA-Z,ADV\dv_|(B]" "[']" t ("-C" "-d" "deutsch") "~latin1") ("nederlands" "[A-Za-z,A@(B-,AEGH(B-,AOR(B-,AVY(B-,A\`(B-,Aegh(B-,Aoqr(B-,Avy(B-,A|(B]" "[^A-Za-z,A@(B-,AEGH(B-,AOR(B-,AVY(B-,A\`(B-,Aegh(B-,Aoqr(B-,Avy(B-,A|(B]" "[']" t ("-C") nil) ("nederlands8" "[A-Za-z,A@(B-,AEGH(B-,AOR(B-,AVY(B-,A\`(B-,Aegh(B-,Aoqr(B-,Avy(B-,A|(B]" "[^A-Za-z,A@(B-,AEGH(B-,AOR(B-,AVY(B-,A\`(B-,Aegh(B-,Aoqr(B-,Avy(B-,A|(B]" "[']" t ("-C") nil))) - -(defvar ispell-dictionary-alist-2 '(("svenska" "[A-Za-z}{|\\133\\135\\\\]" "[^A-Za-z}{|\\133\\135\\\\]" "[']" nil ("-C") nil) ("svenska8" "[A-Za-z,AedvEDv(B]" "[^A-Za-z,AedvEDv(B]" "[']" nil ("-C" "-d" "svenska") "~list") ("francais7" "[A-Za-z]" "[^A-Za-z]" "[`'^---]" t nil nil) ("francais" "[A-Za-z,A@BFGHIJKNOTY[\`bghijknoty{|(B]" "[^A-Za-z,A@BFGHIJKNOTY[\`bghijknoty{|(B]" "[---']" t nil "~list") ("francais-tex" "[A-Za-z,A@BFGHIJKNOTY[\`bghijknoty{|(B\\]" "[^A-Za-z,A@BFGHIJKNOTY[\`bghijknoty{|(B\\]" "[---'^`\"]" t nil "~tex") ("dansk" "[A-Z,AFXE(Ba-z,Afxe(B]" "[^A-Z,AFXE(Ba-z,Afxe(B]" "" nil ("-C") nil))) +(defvar ispell-dictionary-alist-1 '((nil "[A-Za-z]" "[^A-Za-z]" "[']" nil ("-B") nil) ("english" "[A-Za-z]" "[^A-Za-z]" "[']" nil ("-B") nil) ("british" "[A-Za-z]" "[^A-Za-z]" "[']" nil ("-B" "-d" "british") nil) ("deutsch" "[a-zA-Z\"]" "[^a-zA-Z\"]" "[']" t ("-C") "~tex") ("deutsch8" "[a-zA-ZÄÖÜäößü]" "[^a-zA-ZÄÖÜäößü]" "[']" t ("-C" "-d" "deutsch") "~latin1") ("nederlands" "[A-Za-zÀ-ÅÇÈ-ÏÒ-ÖÙ-Üà-åçè-ïñò-öù-ü]" "[^A-Za-zÀ-ÅÇÈ-ÏÒ-ÖÙ-Üà-åçè-ïñò-öù-ü]" "[']" t ("-C") nil) ("nederlands8" "[A-Za-zÀ-ÅÇÈ-ÏÒ-ÖÙ-Üà-åçè-ïñò-öù-ü]" "[^A-Za-zÀ-ÅÇÈ-ÏÒ-ÖÙ-Üà-åçè-ïñò-öù-ü]" "[']" t ("-C") nil))) + +(defvar ispell-dictionary-alist-2 '(("svenska" "[A-Za-z}{|\\133\\135\\\\]" "[^A-Za-z}{|\\133\\135\\\\]" "[']" nil ("-C") nil) ("svenska8" "[A-Za-zåäöÅÄö]" "[^A-Za-zåäöÅÄö]" "[']" nil ("-C" "-d" "svenska") "~list") ("francais7" "[A-Za-z]" "[^A-Za-z]" "[`'^---]" t nil nil) ("francais" "[A-Za-zÀÂÆÇÈÉÊËÎÏÔÙÛÜàâçèéêëîïôùûü]" "[^A-Za-zÀÂÆÇÈÉÊËÎÏÔÙÛÜàâçèéêëîïôùûü]" "[---']" t nil "~list") ("francais-tex" "[A-Za-zÀÂÆÇÈÉÊËÎÏÔÙÛÜàâçèéêëîïôùûü\\]" "[^A-Za-zÀÂÆÇÈÉÊËÎÏÔÙÛÜàâçèéêëîïôùûü\\]" "[---'^`\"]" t nil "~tex") ("dansk" "[A-ZÆØÅa-zæøå]" "[^A-ZÆØÅa-zæøå]" "" nil ("-C") nil))) (defvar ispell-dictionary-alist (append ispell-dictionary-alist-1 ispell-dictionary-alist-2) "\ An alist of dictionaries and their associated parameters. @@ -8322,7 +8351,7 @@ This is also a plain text. But, it is explicitly specified as is. --[[text/plain; charset=ISO-2022-JP]] - ...Japanese text here.... + ... Japanese text here ... --[[text/richtext]]
This is a richtext.
--[[image/gif][base64]]^M...image encoded in base64 here... @@ -8369,59 +8398,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 "\ @@ -9417,6 +9393,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" "\ @@ -9517,6 +9546,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 5b0a5bbffab6 -r 1ce6082ce73f lisp/prim/frame.el --- a/lisp/prim/frame.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/prim/frame.el Mon Aug 13 09:06:37 2007 +0200 @@ -802,6 +802,7 @@ (buffer-substring-no-properties begin end)) (error "CDE functionality not compiled in."))) + ;;; Application-specific frame-management diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/prim/help.el --- a/lisp/prim/help.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/prim/help.el Mon Aug 13 09:06:37 2007 +0200 @@ -181,11 +181,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 5b0a5bbffab6 -r 1ce6082ce73f lisp/prim/simple.el --- a/lisp/prim/simple.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/psgml/psgml-parse.el --- a/lisp/psgml/psgml-parse.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/psgml/psgml-parse.el Mon Aug 13 09:06:37 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/03 03:10:27 steve Exp $ +;; $Id: psgml-parse.el,v 1.3 1997/01/11 20:14:09 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/tm/tm-edit.el --- a/lisp/tm/tm-edit.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/tm/tm-edit.el Mon Aug 13 09:06:37 2007 +0200 @@ -6,7 +6,7 @@ ;; MORIOKA Tomohiko ;; Maintainer: MORIOKA Tomohiko ;; Created: 1994/08/21 renamed from mime.el -;; Version: $Revision: 1.3 $ +;; Version: $Revision: 1.4 $ ;; Keywords: mail, news, MIME, multimedia, multilingual ;; This file is part of tm (Tools for MIME). @@ -96,7 +96,6 @@ ;; This is also a plain text. But, it is explicitly specified as is. ;; ;;--[[text/plain; charset=ISO-2022-JP]] -;; $B$3$l$O(B charset $B$r(B ISO-2022-JP $B$K;XDj$7$?F|K\8l$N(B plain $B%F%-%9%H$G$9(B. ;; ;;--[[text/richtext]] ;;
This is a richtext.
@@ -120,7 +119,7 @@ ;;; (defconst mime-editor/RCS-ID - "$Id: tm-edit.el,v 1.3 1997/01/03 03:10:30 steve Exp $") + "$Id: tm-edit.el,v 1.4 1997/01/11 20:14:11 steve Exp $") (defconst mime-editor/version (get-version-string mime-editor/RCS-ID)) @@ -750,7 +749,7 @@ This is also a plain text. But, it is explicitly specified as is. --[[text/plain; charset=ISO-2022-JP]] - ...Japanese text here.... + ... Japanese text here ... --[[text/richtext]]
This is a richtext.
--[[image/gif][base64]]^M...image encoded in base64 here... diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/tm/tm-ew-d.el --- a/lisp/tm/tm-ew-d.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/tm/tm-ew-d.el Mon Aug 13 09:06:37 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.1.1.2 $ +;; Version: $Revision: 1.2 $ ;; 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.1.1.2 1996/12/21 20:50:42 steve Exp $") + "$Id: tm-ew-d.el,v 1.2 1997/01/11 20:14:11 steve Exp $") (defconst mime/eword-decoder-version (get-version-string tm-ew-d/RCS-ID)) diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/ChangeLog --- a/lisp/url/ChangeLog Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/Makefile --- a/lisp/url/Makefile Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/base64.el --- a/lisp/url/base64.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/docomp.el --- a/lisp/url/docomp.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/md5.el --- a/lisp/url/md5.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/mm.el --- a/lisp/url/mm.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/ssl.el --- a/lisp/url/ssl.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-cookie.el --- a/lisp/url/url-cookie.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-file.el --- a/lisp/url/url-file.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-gopher.el --- a/lisp/url/url-gopher.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-hash.el --- a/lisp/url/url-hash.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-http.el --- a/lisp/url/url-http.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-irc.el --- a/lisp/url/url-irc.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-mail.el --- a/lisp/url/url-mail.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-misc.el --- a/lisp/url/url-misc.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-news.el --- a/lisp/url/url-news.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-nfs.el --- a/lisp/url/url-nfs.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-parse.el --- a/lisp/url/url-parse.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-pgp.el --- a/lisp/url/url-pgp.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-sysdp.el --- a/lisp/url/url-sysdp.el Mon Aug 13 09:05:44 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 a 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-vars.el --- a/lisp/url/url-vars.el Mon Aug 13 09:05:44 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)) - 'no-conversion) - ((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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url-wais.el --- a/lisp/url/url-wais.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/url.el --- a/lisp/url/url.el Mon Aug 13 09:05:44 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 'no-conversion) - (set-process-output-coding-system conn 'no-conversion)))) - 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/url/urlauth.el --- a/lisp/url/urlauth.el Mon Aug 13 09:05:44 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/utils/bench.el --- a/lisp/utils/bench.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/utils/bench.el Mon Aug 13 09:06:37 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 20:14:12 steve Exp $ +;; $Source: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs/lisp/utils/Attic/bench.el,v $ +;; $Revision: 1.2 $ +;; $Author: steve $ +;; $Date: 1997/01/11 20:14:12 $ ;; 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/utils/loadhist.el --- a/lisp/utils/loadhist.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/utils/loadhist.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/version.el --- a/lisp/version.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/version.el Mon Aug 13 09:06:37 2007 +0200 @@ -25,7 +25,7 @@ (defconst emacs-version "20.0" "Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta34)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta90)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/Makefile --- a/lisp/viper/Makefile Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/Makefile Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/README --- a/lisp/viper/README Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/README Mon Aug 13 09:06:37 2007 +0200 @@ -111,3 +111,5 @@ viperCard.dvi contain the Viper manual and the quick reference card, respectively. + + diff -r 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/viper-ex.el --- a/lisp/viper/viper-ex.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/viper-ex.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/viper-keym.el --- a/lisp/viper/viper-keym.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/viper-keym.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/viper-macs.el --- a/lisp/viper/viper-macs.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/viper-macs.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/viper-mous.el --- a/lisp/viper/viper-mous.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/viper-mous.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/viper-util.el --- a/lisp/viper/viper-util.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/viper-util.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/viper/viper.el --- a/lisp/viper/viper.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/viper/viper.el Mon Aug 13 09:06:37 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. @@ -157,7 +157,7 @@ ;; and so many of the goodies of Emacs are not available. ;; ;; A skilled user should set vip-expert-level to at least 3. This will -;; enable `C-c; and many Emacs facilities will become available. +;; enable `C-c' and many Emacs facilities will become available. ;; In this case, vip-vi-diehard-minor-mode is inactive. ;; ;; Viper gurus should have at least @@ -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))) )) @@ -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) @@ -5596,7 +5504,7 @@ (add-hook 'html-helper-mode-hook 'viper-mode) (defvar java-mode-hook) (add-hook 'java-mode-hook 'viper-mode) - + (defvar emacs-lisp-mode-hook) (add-hook 'emacs-lisp-mode-hook 'viper-mode) @@ -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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/ChangeLog --- a/lisp/w3/ChangeLog Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/w3/ChangeLog Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-http.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-http.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-irc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-irc.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-mail.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-mail.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-misc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-misc.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-news.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-news.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-nfs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-nfs.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-parse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-parse.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-pgp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-pgp.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-vars.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-vars.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url-wais.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-wais.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/url.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/urlauth.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/urlauth.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/w3-about.el --- a/lisp/w3/w3-about.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/w3/w3-about.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/w3-annotat.el --- a/lisp/w3/w3-annotat.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/w3/w3-annotat.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/w3-auto.el --- a/lisp/w3/w3-auto.el Mon Aug 13 09:05:44 2007 +0200 +++ b/lisp/w3/w3-auto.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/w3-display.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/w3-display.el Mon Aug 13 09:06:37 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 5b0a5bbffab6 -r 1ce6082ce73f lisp/w3/w3-draw.el --- a/lisp/w3/w3-draw.el Mon Aug 13 09:05:44 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 "