# HG changeset patch # User Karoly Lorentey # Date 1081427349 0 # Node ID 1029206e72f2decc322ae01ecd7826f30d482c0a # Parent 7f60e040ccfc076895181da34410df80617ecd8d# Parent b3ef5fefdb59124dc46deae40202577f1f25bf50 Merged in changes from CVS HEAD Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-181 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-182 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-183 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-184 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-185 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-186 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-187 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-188 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-189 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-190 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-191 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-192 Update from CVS git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-132 diff -r 7f60e040ccfc -r 1029206e72f2 ChangeLog --- a/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,3 +1,9 @@ +2004-04-04 Eli Zaretskii + + * config.bat (lib-src): Recognize comment lines in Makefile.in + that have a TAB after the #, to avoid errors in preprocessing with + GCC 3.3.3. + 2004-03-31 Luc Teirlinck * Makefile.in: Mention in comment that `make maintainer-clean' @@ -28,7 +34,7 @@ * INSTALL.CVS: Add info about ssh/cvs related problems and work-around. -2004-02-16 Eli Zaretskii +2004-02-16 Eli Zaretskii * make-dist: Don't link index.*perm and permute-index into tempdir. @@ -53,7 +59,7 @@ * make-dist (tempdir): Include cursors in nt/icons. -2003-12-30 Eli Zaretskii +2003-12-30 Eli Zaretskii * INSTALL.CVS: Renamed from INSTALL-CVS to avoid file-name clashes with install-sh on 8+3 filesystems. diff -r 7f60e040ccfc -r 1029206e72f2 config.bat --- a/config.bat Sat Apr 03 20:24:17 2004 +0000 +++ b/config.bat Thu Apr 08 12:29:09 2004 +0000 @@ -1,7 +1,7 @@ @echo off rem ---------------------------------------------------------------------- rem Configuration script for MSDOS -rem Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2001 +rem Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2001, 2004 rem Free Software Foundation, Inc. rem This file is part of GNU Emacs. @@ -191,7 +191,7 @@ Echo Configuring the library source directory... cd lib-src rem Create "makefile" from "makefile.in". -sed -e "1,/== start of cpp stuff ==/s@^# .*$@@" junk.c +sed -e "1,/== start of cpp stuff ==/s@^#[ ].*$@@" junk.c gcc -E -traditional -I. -I../src junk.c | sed -e "s/^ / /" -e "/^#/d" -e "/^[ ]*$/d" >makefile.new If "%DJGPP_VER%" == "2" goto libsrc-v2 sed -f ../msdos/sed3.inp Makefile @@ -276,7 +276,7 @@ set X11= set nodebug= set djgpp_ver= - -goto skipArchTag - arch-tag: 2d2fed23-4dc6-4006-a2e4-49daf0031f33 -:skipArchTag + +goto skipArchTag + arch-tag: 2d2fed23-4dc6-4006-a2e4-49daf0031f33 +:skipArchTag diff -r 7f60e040ccfc -r 1029206e72f2 etc/ChangeLog --- a/etc/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/etc/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,3 +1,7 @@ +2004-04-05 Jesper Harder + + * TODO: Remove index-apropos entry. + 2004-04-01 Juri Linkov * HELLO: Add Javanese. diff -r 7f60e040ccfc -r 1029206e72f2 etc/NEWS --- a/etc/NEWS Sat Apr 03 20:24:17 2004 +0000 +++ b/etc/NEWS Thu Apr 08 12:29:09 2004 +0000 @@ -88,6 +88,42 @@ * Changes in Emacs 21.4 +** C-h v and C-h f commands now include a hyperlink to the C source for +variables and functions defined in C (if the C source is available). + +** When used interactively, `format-write-file' now asks for confirmation +before overwriting an existing file, unless a prefix argument is +supplied. This behavior is analogous to `write-file'. + +** You can now use Auto Revert mode to `tail' a file. +If point is at the end of a file buffer before reverting, Auto Revert +mode keeps it at the end after reverting. Similarly if point is +displayed at the end of a file buffer in any window, it will stay at +the end of the buffer in that window. This allows to tail a file: +just put point at the end of the buffer and it will stay there. This +rule applies to file buffers. For non-file buffers, the behavior may +be mode dependent. + +** Auto Revert mode is now more careful to avoid excessive reverts and +other potential problems when deciding which non-file buffers to +revert. This matters especially if Global Auto Revert mode is enabled +and `global-auto-revert-non-file-buffers' is non-nil. Auto Revert +mode will only revert a non-file buffer if the buffer has a non-nil +`revert-buffer-function' and a non-nil `buffer-stale-function', which +decides whether the buffer should be reverted. Currently, this means +that auto reverting works for Dired buffers (although this may not +work properly on all operating systems) and for the Buffer Menu. + +** If the new user option `auto-revert-check-vc-info' is non-nil, Auto +Revert mode reliably updates version control info (such as the version +control number in the mode line), in all version controlled buffers in +which it is active. If the option is nil, the default, then this info +only gets updated whenever the buffer gets reverted. + +** New command `Buffer-menu-toggle-files-only' toggles display of file +buffers only in the Buffer Menu. It is bound to `T' in Buffer Menu +mode. + ** M-x compile has become more robust and reliable Quite a few more kinds of messages are recognized. Messages that are @@ -293,11 +329,16 @@ ** New command `kill-whole-line' kills an entire line at once. By default, it is bound to C-S-. -+++ -** Info now hides node names in menus and cross references by default. +** Info mode: ++++ +*** Info now hides node names in menus and cross references by default. If you prefer the old behavior, you can set the new user option `Info-hide-note-references' to nil. +*** The new command `info-apropos' searches the indices of the known +Info files on your system for a string, and builds a menu of the +possible matches. + ** Support for the SQLite interpreter has been added to sql.el by calling 'sql-sqlite'. @@ -652,7 +693,7 @@ select it (give it focus), the selected window and cursor position normally changes according to the mouse click position. If you set the variable x-mouse-click-focus-ignore-position to t, the selected -window and cursor position do not changes when you click on a frame +window and cursor position do not change when you click on a frame to give it focus. +++ @@ -1651,6 +1692,8 @@ * New modes and packages in Emacs 21.4 +** The URL package (which had been part of W3) is now part of Emacs. + +++ ** The new global minor mode `size-indication-mode' (off by default) shows the size of accessible part of the buffer on the mode line. @@ -2432,7 +2475,7 @@ ** The new function `merge-coding-systems' fills in unspecified aspects of one coding system from another coding system. ---- ++++ ** The variable `safe-local-eval-forms' specifies a list of forms that are ok to evaluate when they appear in an `eval' local variables specification. Normally Emacs asks for confirmation before evaluating diff -r 7f60e040ccfc -r 1029206e72f2 etc/TODO --- a/etc/TODO Sat Apr 03 20:24:17 2004 +0000 +++ b/etc/TODO Thu Apr 08 12:29:09 2004 +0000 @@ -177,8 +177,6 @@ compilation of selected bytecode functions to subrs. Converting CCL programs to native code is probably the first thing to try, though. -* Add a feature to Info similar to "info --apropos SUBJECT". - * Add support for SVG (Scalable Vector Graphics) rendering to Emacs. diff -r 7f60e040ccfc -r 1029206e72f2 etc/TUTORIAL.translators --- a/etc/TUTORIAL.translators Sat Apr 03 20:24:17 2004 +0000 +++ b/etc/TUTORIAL.translators Thu Apr 08 12:29:09 2004 +0000 @@ -16,10 +16,10 @@ Janusz S. Bien TUTORIAL.ro: Tudor Hulubei TUTORIAL.ru: Alex Ott -TUTORIAL.sv: Mats Lidell TUTORIAL.sk: Miroslav Vaško Pavel Janík TUTORIAL.sl: Primož Peterlin +TUTORIAL.sv: Mats Lidell TUTORIAL.th: Virach Sornlertlamvanich TUTORIAL.zh: Chao-Hong Liu diff -r 7f60e040ccfc -r 1029206e72f2 etc/compilation.txt --- a/etc/compilation.txt Sat Apr 03 20:24:17 2004 +0000 +++ b/etc/compilation.txt Thu Apr 08 12:29:09 2004 +0000 @@ -76,6 +76,8 @@ File "F:\ocaml\sorting.ml", line 65, characters 2-145: Warning: this expression should have type unit. File "/usr/share/gdesklets/display/TargetGauge.py", line 41, in add_children + File \lib\python\Products\PythonScripts\PythonScript.py, line 302, in _exec + File "/tmp/foo.py", line 10 * Apollo cc, 4.3BSD fc & IBM RS6000/AIX xlc compiler & Microtec mcc68k & GNAT (July 94) @@ -118,6 +120,7 @@ symbol: irix ccom: Error: foo.c, line 2: syntax error +cc: Info: foo.c, line 27: ... cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ... cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ... /usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah diff -r 7f60e040ccfc -r 1029206e72f2 lib-src/ChangeLog --- a/lib-src/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/lib-src/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,3 +1,9 @@ +2004-04-07 Stefan Monnier + + * make-docfile.c (xmalloc): Fix return type. + (put_filename): New fun. + (scan_file): Use it. + 2004-03-09 Juanma Barranquero * grep-changelog: Changes to support ChangeLog.10+. diff -r 7f60e040ccfc -r 1029206e72f2 lib-src/make-docfile.c --- a/lib-src/make-docfile.c Sat Apr 03 20:24:17 2004 +0000 +++ b/lib-src/make-docfile.c Thu Apr 08 12:29:09 2004 +0000 @@ -1,5 +1,5 @@ /* Generate doc-string file for GNU Emacs from source files. - Copyright (C) 1985, 86, 92, 93, 94, 97, 1999, 2000, 2001 + Copyright (C) 1985, 86, 92, 93, 94, 97, 1999, 2000, 01, 2004 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -105,11 +105,11 @@ /* Like malloc but get fatal error if memory is exhausted. */ -long * +void * xmalloc (size) unsigned int size; { - long *result = (long *) malloc (size); + void *result = (void *) malloc (size); if (result == NULL) fatal ("virtual memory exhausted", 0); return result; @@ -178,6 +178,22 @@ return (err_count > 0 ? EXIT_FAILURE : EXIT_SUCCESS); } +/* Add a source file name boundary marker in the output file. */ +void +put_filename (filename) + char *filename; +{ + char *tmp = filename; + int len; + + while ((tmp = index (filename, '/'))) + filename = tmp + 1; + + putc (037, outfile); + putc ('S', outfile); + fprintf (outfile, "%s\n", filename); +} + /* Read file FILENAME and output its doc strings to outfile. */ /* Return 1 if file is not found, 0 if it is found. */ @@ -186,6 +202,8 @@ char *filename; { int len = strlen (filename); + + put_filename (filename); if (len > 4 && !strcmp (filename + len - 4, ".elc")) return scan_lisp_file (filename, READ_BINARY); else if (len > 3 && !strcmp (filename + len - 3, ".el")) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/ChangeLog --- a/lisp/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,3 +1,187 @@ +2004-04-08 Juri Linkov + + * info.el (Info-history): Doc fix. + (Info-history-list): New var. + (info-xref): Change magenta4 to blue, remove bold for dark and + light backgrounds, change bold to underline for non-color classes. + (info-xref-visited): New face. + (Info-fontify-visited-nodes): New custom. + (Info-hide-note-references): Add new value `hide'. Doc fix. + (Info-reference-name): New var. + (Info-selection-hook): New custom. + (Info-edit-mode-hook): New var. + (Info-find-file): New fun. + (Info-find-node): Move part of code to Info-find-file. + (Info-find-node-2): Add anchors to Info-history-list. Move point + to the place with the reference name if name is defined. + (Info-select-node): Add current node to Info-history-list. + (Info-goto-node): Switch to *info* from *info-history* *info-toc*. + (Info-search-whitespace-regexp): New custom. + (Info-search-case-fold): New var. + (Info-search): Add "case-sensitively" to the prompt. Use + Info-search-whitespace-regexp. Set Info-search-case-fold. + (Info-search-case-sensitively, Info-search-next): New fun. + (Info-up): Move point to the menu item of the current node. + (Info-history): New fun. Add *info-history* to same-window-buffer-names. + (Info-toc): New fun. Add *info-toc* to same-window-buffer-names. + (Info-insert-toc): New fun. + (Info-build-toc): New fun. + (Info-follow-reference): Add new arg `fork'. Doc fix. + Replace [ \n\t]* by [ \n\t]+ in the *Note regexp. For references + with the same name prefer the reference closest to point. + (Info-next-reference): Replace * by + in the *Note regexp. + Add regexp for http:// and ftp://. Skip the *Note prefix. + (Info-prev-reference): Replace * by + in the *Note regexp. + Add regexp for http:// and ftp://. Skip the *Note prefix. + (Info-follow-nearest-node): Add new arg `fork'. + (Info-try-follow-nearest-node): Add new arg `fork'. + Call browse-url for http:// and ftp:// references. + Set Info-reference-name for index entries. + (Info-mode-menu): Add menu items for Info-search-case-sensitively, + Info-search-next, Info-history, Info-toc, clone-buffer. + (Info-menu-update): Replace * by + in the *Note regexp. + (Info-mode): Add documentation for Info-history, Info-toc, + Info-search-case-sensitively, Info-search-next, clone-buffer. + (Info-fontify-menu-headers): Remove fun. Move code to + Info-fontify-node. + (Info-fontify-node): Add docstring. Add local vars + fontify-visited-p and not-fontified-p. If not-fontified-p is t + then fontify header line, titles, menu headers, http and ftp + references, refill paragraphs. If not-fontified-p is t or + fontify-visited-p is t then fontify cross references, menu items. + Fontify menu headers. Fontify http and ftp references. Change + regexp for cross references to require whitespace after *Note, add + matching groups for file and node names. Remove hack for quote. + Use display property for Info-hide-note-references=t. Use fifth + or fourth match for help-echo. Display visited nodes in a + different face. Unhide file names of external references. Unhide + newlines. Display visited menu items in a different face. + +2004-04-07 Jan Nieuwenhuizen + + * info.el (Info-hide-cookies-node): New function. + (Info-select-node): Use it. + (Info-display-images-node): Remove message with image file name. + +2004-04-07 Daniel Pfeiffer + + * progmodes/compile.el (compilation-warning-face) + (compilation-info-face, compilation-skip-threshold) + (compilation-skip-visited, compilation-context-lines): Declare + :version when added to Emacs. + (compilation-error-regexp-alist-alist): Extend caml and irix. + (compilation-setup): Fix if font-locked w/o font-lock-defaults. + (compilation-mode-font-lock-keywords): Temporarily undo line as + function patch, which wasn't ready. + +2004-04-07 Kenichi Handa + + * international/latin1-disp.el (latin1-display-setup): Check each + character is displayable or not instead of calling + latin1-display-check-font. + +2004-04-06 Kenichi Handa + + * language/ethio-util.el (ethio-sera-being-called-by-w3): New + variable. + (ethio-sera-to-fidel-ethio): Check ethio-sera-being-called-by-w3 + instead of sera-being-called-by-w3. + (ethio-fidel-to-sera-buffer): Likewise. + (ethio-find-file): Bind ethio-sera-being-called-by-w3 to t + instead of sera-being-called-by-w3. + (ethio-write-file): Likewise. + +2004-04-05 Vinicius Jose Latorre + + * printing.el: Dox fix. + +2004-04-05 Nick Roberts + + * progmodes/gdb-ui.el (gdb-use-inferior-io-buffer): New option. + (gdb-ann3, gdb-send, gdb-starting, gdb-stopping) + (gdb-setup-windows): Only use separate IO buffer if required. + +2004-04-06 Kim F. Storm + + * term.el (term-is-xemacs): Remove. + (term-if-xemacs, term-ifnot-xemacs): Test (featurep 'xemacs). + (term-window-width): New function. + (term-mode, term-check-size): Use it. + (term-mode): Disable overflow-newline-into-fringe in term buffer. + +2004-04-05 Per Abrahamsen + + * cus-edit.el (custom-add-parent-links): Changed unbound variable + `symbol' to `name'. + +2004-04-05 Jesper Harder + + * info.el (info-apropos): New function. + (Info-mode-menu): Add it. + (Info-find-node, Info-find-node-2): Grok apropos virtual file. + + * help-mode.el (help-make-xrefs): Recognize aliased variable with + inherited docstring. + + * play/gamegrid.el (gamegrid-add-score-insecure): Use sort-fields. + +2004-04-04 Luc Teirlinck + + * autorevert.el (auto-revert-handler): If point (or a window + point) is at the end of the buffer, keep it there after + reverting. This allows to tail a file. + Mention this in the `Commentary'. + + * format.el (format-write-file): Add optional argument CONFIRM + and make it behave like the analogous argument to `write-file'. + +2004-04-04 Vinicius Jose Latorre + + * progmodes/ebnf2ps.el: Doc fix. + (ebnf-version): New version number (4.2). + (ebnf-syntax): Customization and docstring fix. + (ebnf-eliminate-empty-rules, ebnf-optimize, ebnf-otz-initialize): Put + autoloaded funs before first use. + (ebnf-style-database): Add dtd entry. + (ebnf-syntax-alist): Add dtd initialization. + (ebnf-token-sequence): New fun. + (ebnf-comment-table): Add new comment action character. + (ebnf-dtd-parser, ebnf-dtd-initialize): Autoloaded funs from ebnf-dtd. + + * progmodes/ebnf-dtd.el: New file, implement a parser for DTD (Data + Type Definition for XML). + + * progmodes/ebnf-abn.el (ebnf-abn-concatenation): Code simplification: + call ebnf-token-sequence. + + * progmodes/ebnf-bnf.el (ebnf-sequence): Code simplification: call + ebnf-token-sequence. + + * progmodes/ebnf-ebx.el (ebnf-ebx-concatenation): Code simplification: + call ebnf-token-sequence. + + * progmodes/ebnf-iso.el (ebnf-iso-single-definition): Code + simplification: call ebnf-token-sequence. + + * progmodes/ebnf-yac.el (ebnf-yac-sequence): Code simplification: call + ebnf-token-sequence. + +2004-04-04 Eli Zaretskii + + * calendar/timeclock.el (timeclock-relative) + (timeclock-get-project-function, timeclock-get-workday-function) + (timeclock-query-out, timeclock-when-to-leave) + (timeclock-when-to-leave-string, timeclock-log-data) + (timeclock-generate-report, timeclock-in): Doc fixes. + +2004-04-03 Stefan Monnier + + * url: Import the URL package from its repository. + +2004-04-03 Andreas Schwab + + * diff-mode.el (diff-mode): Fix missing quote. + 2004-04-03 Juri Linkov * descr-text.el (describe-property-list): Add `font-lock-face'. @@ -6,8 +190,8 @@ 2004-04-02 Jan Dj,Ad(Brv - * x-dnd.el (x-dnd-handle-moz-url, x-dnd-insert-utf16-text): Use - utf-16le on little endian machines and utf-16be otherwise. + * x-dnd.el (x-dnd-handle-moz-url, x-dnd-insert-utf16-text): + Use utf-16le on little endian machines and utf-16be otherwise. 2004-04-02 David Kastrup @@ -67,7 +251,7 @@ 2004-03-31 H,Ae(Bkan Granath (tiny change) - * dired.el (dired-move-to-filename-regexp): Add . to HH:MM. + * dired.el (dired-move-to-filename-regexp): Add `.' to HH:MM. 2004-03-30 Vinicius Jose Latorre @@ -815,7 +999,7 @@ * woman.el (woman-man.conf-path): Doc fix. (woman-parse-man.conf): Also parse OPTIONAL_MANPATH. -2004-03-07 Eli Zaretskii +2004-03-07 Eli Zaretskii * sort.el (sort-columns): Remove ms-dos from the list of systems where the external `sort' command is not used. @@ -1323,7 +1507,7 @@ (yank-pop): Make its argument optional. (yank): Make ARG `-' equivalent to `-1'. -2004-02-17 Eli Zaretskii +2004-02-17 Eli Zaretskii * mail/rmail.el (rmail-get-new-mail): Don't reference rmail-use-spam-filter if rmail-spam-filter is not loaded. @@ -1334,7 +1518,7 @@ if one of global-auto-revert-non-file-buffers or autorevert-mode is non-nil. -2004-02-16 Eli Zaretskii +2004-02-16 Eli Zaretskii * subr.el (delete-dups): A better implementation from Karl Heuer . @@ -1346,7 +1530,7 @@ * progmodes/icon.el (icon-indent-command): Ditto. * textmodes/paragraphs.el (repunctuate-sentences): Ditto. -2004-02-16 Eli Zaretskii +2004-02-16 Eli Zaretskii * progmodes/grep.el (grep-compute-defaults): Undo change from 2004-01-29: don't use executable-command-find-posix-p. @@ -1385,7 +1569,7 @@ Change prefixes of all variables and functions from rmail-spam-filter- or spam-filter- or rmail-spam- to rsf-. -2004-02-16 Eli Zaretskii +2004-02-16 Eli Zaretskii * loadhist.el (unload-hook-features-list): New defvar. @@ -1403,7 +1587,7 @@ * subr.el (match-string-no-properties): Use substring-no-properties. -2004-02-16 Eli Zaretskii +2004-02-16 Eli Zaretskii * emacs-lisp/rx.el (rx-check, rx-check-any, rx-check-not) (rx-repeat, rx-check-backref, rx-syntax, rx-to-string): @@ -1461,7 +1645,7 @@ * Makefile.in (TAGS, TAGS-LISP): Filter out of `els' only loaddefs* and ldefs-boot*. -2004-02-16 Eli Zaretskii +2004-02-16 Eli Zaretskii * mail/mail-utils.el (rmail-dont-reply-to): Anchor user login name and email address at the beginning and end of the address. @@ -2267,7 +2451,7 @@ `Info node'. (help-make-xrefs): Adapt to new value of `help-xref-info-regexp'. -2003-12-30 Eli Zaretskii +2003-12-30 Eli Zaretskii * mail/rmail.el (rmail-convert-to-babyl-format): Fix off-by-one error in arguments to base64-decode-region. Remove ^M characters @@ -2280,7 +2464,7 @@ have only been distributed with Emacs for some years. (texinfo-mode-hook): Customize. -2003-12-30 Eli Zaretskii +2003-12-30 Eli Zaretskii * mail/rmail.el (rmail-convert-to-babyl-format): Make the code cleaner (suggested by Richard Stallman). @@ -2376,7 +2560,7 @@ * generic.el (define-generic-mode): Doc fix. -2003-12-29 Eli Zaretskii +2003-12-29 Eli Zaretskii * files.el (kill-some-buffers): Doc fix. @@ -2394,7 +2578,7 @@ "@", as required by some ISP hosting service. Fix defcustom argument syntax errors that prevented use of customization. -2003-12-29 Eli Zaretskii +2003-12-29 Eli Zaretskii * xml.el (xml-get-attribute-or-nil): Doc fix. @@ -2414,7 +2598,7 @@ (xml-get-attribute): Convert to defsubst, uses xml-get-attribute-or-nil. -2003-12-29 Eli Zaretskii +2003-12-29 Eli Zaretskii * emacs-lisp/easymenu.el (easy-menu-define): Doc fix. @@ -2439,7 +2623,7 @@ * generic-x.el (etc-modules-conf-generic-mode): A more complete set of keywords. -2003-12-29 Eli Zaretskii +2003-12-29 Eli Zaretskii * international/mule-cmds.el (reset-language-environment) (set-language-environment): Don't invoke fontset-related functions @@ -3015,7 +3199,7 @@ * subr.el (add-hook): Fix last change. -2003-11-03 Eli Zaretskii +2003-11-03 Eli Zaretskii * mail/rmail.el (rmail-convert-to-babyl-format): If base64-decode-region signals an error, catch it and silently @@ -3265,7 +3449,7 @@ (breakpoint-disabled-pbm-data): Make breakpoint icons 10x10 instead of 12x12. -2003-10-16 Eli Zaretskii +2003-10-16 Eli Zaretskii * mail/rmail.el (rmail-convert-to-babyl-format): Display a message while converting to Babyl. @@ -3365,7 +3549,7 @@ Rename from loadhist-hook-functions. (loadhist-hook-functions): Now an alias. -2003-10-04 Eli Zaretskii +2003-10-04 Eli Zaretskii * ldefs-boot.el: Renamed from loaddefs-boot.el, to prevent file-name clashes on 8+3 filesystems. @@ -3566,7 +3750,7 @@ * info.el (Info-find-index-name): Remove any "" suffixes which makeinfo appends to duplicate index entries. -2003-09-28 Eli Zaretskii +2003-09-28 Eli Zaretskii * dired-x.el (dired-clean-tex): Doc fix. @@ -3979,7 +4163,7 @@ the number of files. Bind the number of files to a local variable. Suggested by Kevin Rodgers . -2003-08-30 Eli Zaretskii +2003-08-30 Eli Zaretskii * vc-hooks.el (vc-make-version-backup): Fix the change made on 2003-07-26: msdos-long-file-names is a function, not a variable. @@ -4017,7 +4201,7 @@ category "|". (kinsoku-longer): Test for end of buffer. -2003-08-28 Eli Zaretskii +2003-08-28 Eli Zaretskii * mail/rmail.el (rmail-convert-to-babyl-format): Detect quoted-printable- and base64-encoded messages and decode them diff -r 7f60e040ccfc -r 1029206e72f2 lisp/autorevert.el --- a/lisp/autorevert.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/autorevert.el Thu Apr 08 12:29:09 2004 +0000 @@ -44,6 +44,17 @@ ;; seconds. The check is aborted whenever the user actually uses ;; Emacs. You should never even notice that this package is active ;; (except that your buffers will be reverted, of course). +;; +;; After reverting a file buffer, Auto Revert Mode normally puts point +;; at the same position that a regular manual revert would. However, +;; there is one exception to this rule. If point is at the end of the +;; buffer before reverting, it stays at the end. Similarly if point +;; is displayed at the end of a file buffer in any window, it will stay +;; at the end of the buffer in that window, even if the window is not +;; selected. This way, you can use Auto Revert Mode to `tail' a file. +;; Just put point at the end of the buffer and it will stay there. +;; These rules apply to file buffers. For non-file buffers, the +;; behavior may be mode dependent. ;; Usage: ;; @@ -298,10 +309,10 @@ "Revert current buffer, if appropriate. This is an internal function used by Auto-Revert Mode." (unless (buffer-modified-p) - (let (revert) - (or (and (buffer-file-name) - (file-readable-p (buffer-file-name)) - (not (verify-visited-file-modtime (current-buffer))) + (let ((buffer (current-buffer)) revert eob eoblist) + (or (and buffer-file-name + (file-readable-p buffer-file-name) + (not (verify-visited-file-modtime buffer)) (setq revert t)) (and (or auto-revert-mode global-auto-revert-non-file-buffers) revert-buffer-function @@ -312,7 +323,22 @@ (when (and auto-revert-verbose (not (eq revert 'fast))) (message "Reverting buffer `%s'." (buffer-name))) - (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes)) + ;; If point (or a window point) is at the end of the buffer, + ;; we want to keep it at the end after reverting. This allows + ;; to tail a file. + (when buffer-file-name + (setq eob (eobp)) + (walk-windows + #'(lambda (window) + (and (eq (window-buffer window) buffer) + (= (window-point window) (point-max)) + (push window eoblist))) + 'no-mini t)) + (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes) + (when buffer-file-name + (when eob (goto-char (point-max))) + (dolist (window eoblist) + (set-window-point window (point-max))))) ;; `preserve-modes' avoids changing the (minor) modes. But we ;; do want to reset the mode for VC, so we do it manually. (when (or revert auto-revert-check-vc-info) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/calendar/timeclock.el --- a/lisp/calendar/timeclock.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/calendar/timeclock.el Thu Apr 08 12:29:09 2004 +0000 @@ -1,6 +1,6 @@ ;;; timeclock.el --- mode for keeping track of how much you work -;; Copyright (C) 1999, 2000, 2001, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001, 2003, 2004 Free Software Foundation, Inc. ;; Author: John Wiegley ;; Created: 25 Mar 1999 @@ -60,7 +60,7 @@ ;; `timeclock-modeline-display' again. ;; You may also want Emacs to ask you before exiting, if you are -;; current working on a project. This can be done either by setting +;; currently working on a project. This can be done either by setting ;; `timeclock-ask-before-exiting' to t using M-x customize (this is ;; the default), or by adding the following to your .emacs file: ;; @@ -94,7 +94,7 @@ :group 'timeclock) (defcustom timeclock-relative t - "*When reporting time, make it relative to `timeclock-workday'? + "*Whether to maken reported time relative to `timeclock-workday'. For example, if the length of a normal workday is eight hours, and you work four hours on Monday, then the amount of time \"remaining\" on Tuesday is twelve hours -- relative to an averaged work period of @@ -107,7 +107,7 @@ (defcustom timeclock-get-project-function 'timeclock-ask-for-project "*The function used to determine the name of the current project. When clocking in, and no project is specified, this function will be -called to determine what the current project to be worked on is. +called to determine what is the current project to be worked on. If this variable is nil, no questions will be asked." :type 'function :group 'timeclock) @@ -115,7 +115,7 @@ (defcustom timeclock-get-reason-function 'timeclock-ask-for-reason "*A function used to determine the reason for clocking out. When clocking out, and no reason is specified, this function will be -called to determine what the reason is. +called to determine what is the reason. If this variable is nil, no questions will be asked." :type 'function :group 'timeclock) @@ -123,17 +123,17 @@ (defcustom timeclock-get-workday-function nil "*A function used to determine the length of today's workday. The first time that a user clocks in each day, this function will be -called to determine what the length of the current workday is. If +called to determine what is the length of the current workday. If the return value is nil, or equal to `timeclock-workday', nothing special will be done. If it is a quantity different from `timeclock-workday', however, a record will be output to the timelog file to note the fact that -that day has a different length from the norm." +that day has a length that is different from the norm." :type '(choice (const nil) function) :group 'timeclock) (defcustom timeclock-ask-before-exiting t "*If non-nil, ask if the user wants to clock out before exiting Emacs. -This variable only has an effect if set with \\[customize]." +This variable only has effect if set with \\[customize]." :set (lambda (symbol value) (if value (add-hook 'kill-emacs-query-functions 'timeclock-query-out) @@ -151,9 +151,9 @@ (defcustom timeclock-use-display-time t "*If non-nil, use `display-time-hook' for doing modeline updates. -The advantage to this is that it means one less timer has to be set -running amok in Emacs' process space. The disadvantage is that it -requires you to have `display-time' running. If you don't want to use +The advantage of this is that one less timer has to be set running +amok in Emacs' process space. The disadvantage is that it requires +you to have `display-time' running. If you don't want to use `display-time', but still want the modeline to show how much time is left, set this variable to nil. Changing the value of this variable while timeclock information is being displayed in the modeline has no @@ -240,7 +240,7 @@ Normally, timeclock assumes that you intend to work for `timeclock-workday' seconds every day. Any days in which you work more or less than this amount is considered either a positive or -negative discrepancy. If you work in such a manner that the +a negative discrepancy. If you work in such a manner that the discrepancy is always brought back to zero, then you will by definition have worked an average amount equal to `timeclock-workday' each day.") @@ -254,8 +254,8 @@ (defvar timeclock-last-period nil "Integer representing the number of seconds in the last period. -Note that you shouldn't access this value, but should use the function -`timeclock-last-period' instead.") +Note that you shouldn't access this value, but instead should use the +function `timeclock-last-period'.") (defvar timeclock-mode-string nil "The timeclock string (optionally) displayed in the modeline. @@ -343,7 +343,7 @@ _seconds_ worked today*. This feature only has effect the first time this function is called within a day. -PROJECT as the project being clocked into. If PROJECT is nil, and +PROJECT is the project being clocked into. If PROJECT is nil, and FIND-PROJECT is non-nil -- or the user calls `timeclock-in' interactively -- call the function `timeclock-get-project-function' to discover the name of the project." @@ -446,17 +446,18 @@ ;;;###autoload (defun timeclock-change (&optional arg project) - "Change to working on a different project, by clocking in then out. -With a prefix ARG, consider the previous project as having been -finished at the time of changeover. PROJECT is the name of the last -project you were working on." + "Change to working on a different project. +This clocks out of the current project, then clocks in on a new one. +With a prefix ARG, consider the previous project as finished at the +time of changeover. PROJECT is the name of the last project you were +working on." (interactive "P") (timeclock-out arg) (timeclock-in nil project (interactive-p))) ;;;###autoload (defun timeclock-query-out () - "Ask the user before clocking out. + "Ask the user whether to clock out. This is a useful function for adding to `kill-emacs-query-functions'." (and (equal (car timeclock-last-event) "i") (y-or-n-p "You're currently clocking time, clock out? ") @@ -550,7 +551,7 @@ ;; Should today-only be removed in favour of timeclock-relative? - gm (defsubst timeclock-when-to-leave (&optional today-only) - "Return a time value representing at when the workday ends today. + "Return a time value representing the end of today's workday. If TODAY-ONLY is non-nil, the value returned will be relative only to the time worked today, and not to past time." (timeclock-seconds-to-time @@ -565,7 +566,7 @@ ;;;###autoload (defun timeclock-when-to-leave-string (&optional show-seconds today-only) - "Return a string representing at what time the workday ends today. + "Return a string representing the end of today's workday. This string is relative to the value of `timeclock-workday'. If SHOW-SECONDS is non-nil, the value printed/returned will include seconds. If TODAY-ONLY is non-nil, the value returned will be @@ -852,8 +853,8 @@ h Set the required working time for the given day. This must be the first entry for that day. The COMMENT in this case is - the number of hours that must be worked. Floating point - amounts are allowed. + the number of hours in this workday. Floating point amounts + are allowed. i Clock in. The COMMENT in this case should be the name of the project worked on. @@ -1144,7 +1145,7 @@ (apply 'encode-time decoded))) (defun timeclock-geometric-mean (l) - "Compute the geometric mean of the list L." + "Compute the geometric mean of the values in the list L." (let ((total 0) (count 0)) (while l @@ -1158,7 +1159,7 @@ (defun timeclock-generate-report (&optional html-p) "Generate a summary report based on the current timelog file. By default, the report is in plain text, but if the optional argument -HTML-P is non-nil html markup is added." +HTML-P is non-nil, HTML markup is added." (interactive) (let ((log (timeclock-log-data)) (today (timeclock-day-base))) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/cus-edit.el --- a/lisp/cus-edit.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/cus-edit.el Thu Apr 08 12:29:09 2004 +0000 @@ -1963,7 +1963,7 @@ symbol) buttons) (setq parents (cons symbol parents)))))) - (and (null (get symbol 'custom-links)) ;No links of its own. + (and (null (get name 'custom-links)) ;No links of its own. (= (length parents) 1) ;A single parent. (let* ((links (get (car parents) 'custom-links)) (many (> (length links) 2))) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/diff-mode.el --- a/lisp/diff-mode.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/diff-mode.el Thu Apr 08 12:29:09 2004 +0000 @@ -936,7 +936,7 @@ (add-hook 'view-mode-hook `(lambda () (setq minor-mode-overriding-map-alist - (delq ,ro-bind minor-mode-overriding-map-alist))) + (delq ',ro-bind minor-mode-overriding-map-alist))) nil t)) ;; add-log support (set (make-local-variable 'add-log-current-defun-function) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/format.el --- a/lisp/format.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/format.el Thu Apr 08 12:29:09 2004 +0000 @@ -366,11 +366,15 @@ (funcall to-fn beg end (current-buffer))))) (setq format (cdr format))))))) -(defun format-write-file (filename format) +(defun format-write-file (filename format &optional confirm) "Write current buffer into file FILENAME using some FORMAT. -Makes buffer visit that file and sets the format as the default for future +Make buffer visit that file and set the format as the default for future saves. If the buffer is already visiting a file, you can specify a directory -name as FILENAME, to write a file of the same old name in that directory." +name as FILENAME, to write a file of the same old name in that directory. + +If optional third arg CONFIRM is non-nil, this function asks for +confirmation before overwriting an existing file. Interactively, +confirmation is required unless you supply a prefix argument." (interactive ;; Same interactive spec as write-file, plus format question. (let* ((file (if buffer-file-name @@ -382,7 +386,7 @@ nil nil (buffer-name)))) (fmt (format-read (format "Write file `%s' in format: " (file-name-nondirectory file))))) - (list file fmt))) + (list file fmt (not current-prefix-arg)))) (let ((old-formats buffer-file-format) preserve-formats) (dolist (fmt old-formats) @@ -393,7 +397,7 @@ (dolist (fmt preserve-formats) (unless (memq fmt buffer-file-format) (setq buffer-file-format (append buffer-file-format (list fmt)))))) - (write-file filename)) + (write-file filename confirm)) (defun format-find-file (filename format) "Find the file FILENAME using data format FORMAT. diff -r 7f60e040ccfc -r 1029206e72f2 lisp/help-fns.el --- a/lisp/help-fns.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/help-fns.el Thu Apr 08 12:29:09 2004 +0000 @@ -1,6 +1,6 @@ ;;; help-fns.el --- Complex help functions -;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002, 2003 +;; Copyright (C) 1985, 86, 93, 94, 98, 1999, 2000, 01, 02, 03, 2004 ;; Free Software Foundation, Inc. ;; Maintainer: FSF @@ -215,6 +215,61 @@ (intern (upcase name)))))) arglist))) +(defvar help-C-source-directory + (let ((dir (expand-file-name "src" source-directory))) + (when (and (file-directory-p dir) (file-readable-p dir)) + dir)) + "Directory where the C source files of Emacs can be found. +If nil, do not try to find the source code of functions and variables +defined in C.") + +(defun help-subr-name (subr) + (let ((name (prin1-to-string subr))) + (if (string-match "\\`#\\'" name) + (match-string 1 name) + (error "Unexpected subroutine print name: %s" name)))) + +(defun help-C-file-name (subr-or-var kind) + "Return the name of the C file where SUBR-OR-VAR is defined. +KIND should be `var' for a variable or `subr' for a subroutine." + (let ((docbuf (get-buffer-create " *DOC*")) + (name (if (eq 'var kind) + (concat "V" (symbol-name subr-or-var)) + (concat "F" (help-subr-name subr-or-var))))) + (with-current-buffer docbuf + (goto-char (point-min)) + (if (eobp) + (insert-file-contents-literally + (expand-file-name internal-doc-file-name doc-directory))) + (search-forward (concat "" name "\n")) + (re-search-backward "S\\(.*\\)") + (let ((file (match-string 1))) + (if (string-match "\\.\\(o\\|obj\\)\\'" file) + (replace-match ".c" t t file) + file))))) + +(defun help-find-C-source (fun-or-var file kind) + "Find the source location where SUBR-OR-VAR is defined in FILE. +KIND should be `var' for a variable or `subr' for a subroutine." + (setq file (expand-file-name file help-C-source-directory)) + (unless (file-readable-p file) + (error "The C source file %s is not available" + (file-name-nondirectory file))) + (if (eq 'fun kind) + (setq fun-or-var (indirect-function fun-or-var))) + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (unless (re-search-forward + (if (eq 'fun kind) + (concat "DEFUN[ \t\n]*([ \t\n]*\"" + (regexp-quote (help-subr-name fun-or-var)) + "\"") + (concat "DEFVAR[A-Z_]*[ \t\n]*([ \t\n]*\"" + (regexp-quote (symbol-name fun-or-var)))) + nil t) + (error "Can't find source for %s" fun)) + (cons (current-buffer) (match-beginning 0)))) + ;;;###autoload (defun describe-function-1 (function) (let* ((def (if (symbolp function) @@ -280,8 +335,10 @@ (when (re-search-backward "^;;; Generated autoloads from \\(.*\\)" nil t) (setq file-name (match-string 1))))))) - (cond - (file-name + (when (and (null file-name) (subrp def) help-C-source-directory) + ;; Find the C source file name. + (setq file-name (concat "src/" (help-C-file-name def 'subr)))) + (when file-name (princ " in `") ;; We used to add .el to the file name, ;; but that's completely wrong when the user used load-file. @@ -289,9 +346,9 @@ (princ "'") ;; Make a hyperlink to the library. (with-current-buffer standard-output - (save-excursion + (save-excursion (re-search-backward "`\\([^`']+\\)'" nil t) - (help-xref-button 1 'help-function-def function file-name))))) + (help-xref-button 1 'help-function-def function file-name)))) (princ ".") (terpri) (when (commandp function) @@ -500,6 +557,13 @@ (when (re-search-backward "^;;; Generated autoloads from \\(.*\\)" nil t) (setq file-name (match-string 1))))))) + (when (and (null file-name) + (integerp (get variable 'variable-documentation))) + ;; It's a variable not defined in Elisp but in C. + (if help-C-source-directory + (setq file-name + (concat "src/" (help-C-file-name variable 'var))) + (princ "\n\nDefined in core C code."))) (when file-name (princ "\n\nDefined in `") (princ file-name) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/help-mode.el --- a/lisp/help-mode.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/help-mode.el Thu Apr 08 12:29:09 2004 +0000 @@ -1,6 +1,6 @@ ;;; help-mode.el --- `help-mode' used by *Help* buffers -;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002, 2004 ;; Free Software Foundation, Inc. ;; Maintainer: FSF @@ -150,8 +150,11 @@ ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). (let ((location - (if (bufferp file) (cons file fun) - (find-function-search-for-symbol fun nil file)))) + (cond + ((bufferp file) (cons file fun)) + ((string-match "\\`src/\\(.*\\.c\\)" file) + (help-find-C-source fun (match-string 1 file) 'fun)) + (t (find-function-search-for-symbol fun nil file))))) (pop-to-buffer (car location)) (goto-char (cdr location)))) 'help-echo (purecopy "mouse-2, RET: find function's definition")) @@ -160,7 +163,10 @@ :supertype 'help-xref 'help-function (lambda (var &optional file) (let ((location - (find-variable-noselect var file))) + (cond + ((string-match "\\`src/\\(.*\\.c\\)" file) + (help-find-C-source var (match-string 1 file) 'var)) + (t (find-variable-noselect var file))))) (pop-to-buffer (car location)) (goto-char (cdr location)))) 'help-echo (purecopy"mouse-2, RET: find variable's definition")) @@ -374,8 +380,14 @@ (help-xref-button 8 'help-symbol sym)) ((and (boundp sym) - (documentation-property sym - 'variable-documentation)) + (or + (documentation-property + sym 'variable-documentation) + (condition-case nil + (documentation-property + (indirect-variable sym) + 'variable-documentation) + (cyclic-variable-indirection nil)))) (help-xref-button 8 'help-variable sym)) ((fboundp sym) (help-xref-button 8 'help-function sym))))))) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/info.el --- a/lisp/info.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/info.el Thu Apr 08 12:29:09 2004 +0000 @@ -44,9 +44,13 @@ (defvar Info-history nil - "List of info nodes user has visited. + "Stack of info nodes user has visited. Each element of list is a list (FILENAME NODENAME BUFFERPOS).") +(defvar Info-history-list nil + "List of all info nodes user has visited. +Each element of list is a list (FILENAME NODENAME).") + (defcustom Info-enable-edit nil "*Non-nil means the \\\\[Info-edit] command in Info can edit the current node. This is convenient if you want to write info files by hand. @@ -75,12 +79,25 @@ :group 'info) (defface info-xref - '((((class color) (background light)) (:foreground "magenta4" :weight bold)) - (((class color) (background dark)) (:foreground "cyan" :weight bold)) - (t (:weight bold))) + '((((class color) (background light)) (:foreground "blue")) + (((class color) (background dark)) (:foreground "cyan")) + (t (:underline t))) "Face for Info cross-references." :group 'info) +(defface info-xref-visited + '((((class color) (background light)) (:foreground "magenta4")) + (((class color) (background dark)) (:foreground "magenta4")) + (t (:underline t))) + "Face for visited Info cross-references." + :group 'info) + +(defcustom Info-fontify-visited-nodes t + "*Non-nil means to fontify visited nodes in a different face." + :version "21.4" + :type 'boolean + :group 'info) + (defcustom Info-fontify-maximum-menu-size 100000 "*Maximum size of menu to fontify if `font-lock-mode' is non-nil." :type 'integer @@ -154,12 +171,13 @@ (defcustom Info-hide-note-references t "*If non-nil, hide the tag and section reference in *note and * menu items. -Also replaces the \"*note\" text with \"see\". -If value is non-nil but not t, the reference section is still shown." +If value is non-nil but not `hide', also replaces the \"*note\" with \"see\". +If value is non-nil but not t or `hide', the reference section is still shown." :version "21.4" - :type '(choice (const :tag "No reformatting" nil) + :type '(choice (const :tag "No hiding" nil) (const :tag "Replace tag and hide reference" t) - (other :tag "Replace only tag" tag)) + (const :tag "Hide tag and reference" hide) + (other :tag "Only replace tag" tag)) :group 'info) (defcustom Info-refill-paragraphs nil @@ -170,14 +188,31 @@ :type 'boolean :group 'info) +(defcustom Info-search-whitespace-regexp "\\\\(?:\\\\s-+\\\\)" + "*If non-nil, regular expression to match a sequence of whitespace chars. +This applies to Info search for regular expressions. +You might want to use something like \"[ \\t\\r\\n]+\" instead. +In the Customization buffer, that is `[' followed by a space, +a tab, a carriage return (control-M), a newline, and `]+'." + :type 'regexp + :group 'info) + (defcustom Info-mode-hook ;; Try to obey obsolete Info-fontify settings. (unless (and (boundp 'Info-fontify) (null Info-fontify)) '(turn-on-font-lock)) - "Hooks run when `info-mode' is called." + "Hooks run when `Info-mode' is called." :type 'hook :group 'info) +(defcustom Info-selection-hook nil + "Hooks run when `Info-select-node' is called." + :type 'hook + :group 'info) + +(defvar Info-edit-mode-hook nil + "Hooks run when `Info-edit-mode' is called.") + (defvar Info-current-file nil "Info file that Info is now looking at, or nil. This is the name that was specified in Info, not the actual file name. @@ -204,6 +239,11 @@ (defvar Info-index-alternatives nil "List of possible matches for last `Info-index' command.") +(defvar Info-reference-name nil + "Name of the selected cross-reference. +Point is moved to the proper occurrence of this name within a node +after selecting it.") + (defvar Info-standalone nil "Non-nil if Emacs was started solely as an Info browser.") @@ -488,19 +528,22 @@ (forward-line 1) ; does the line after delimiter match REGEXP? (re-search-backward regexp beg t)))) -(defun Info-find-node (filename nodename &optional no-going-back) - "Go to an info node specified as separate FILENAME and NODENAME. -NO-GOING-BACK is non-nil if recovering from an error in this function; -it says do not attempt further (recursive) error recovery." - (info-initialize) +(defun Info-find-file (filename &optional noerror) + "Return expanded FILENAME, or t, if FILENAME is \"dir\". +Optional second argument NOERROR, if t, means if file is not found +just return nil (no error)." ;; Convert filename to lower case if not found as specified. ;; Expand it. (if (stringp filename) (let (temp temp-downcase found) (setq filename (substitute-in-file-name filename)) - (if (string= (downcase filename) "dir") - (setq found t) - (let ((dirs (if (string-match "^\\./" filename) + (cond + ((string= (downcase filename) "dir") + (setq found t)) + ((string= filename "apropos") + (setq found 'apropos)) + (t + (let ((dirs (if (string-match "^\\./" filename) ;; If specified name starts with `./' ;; then just try current directory. '("./") @@ -538,10 +581,20 @@ temp (car (car suffix-list)) nil))) (setq found temp))) (setq suffix-list (cdr suffix-list)))) - (setq dirs (cdr dirs))))) + (setq dirs (cdr dirs)))))) (if found (setq filename found) - (error "Info file %s does not exist" filename)))) + (if noerror + (setq filename nil) + (error "Info file %s does not exist" filename))) + filename))) + +(defun Info-find-node (filename nodename &optional no-going-back) + "Go to an info node specified as separate FILENAME and NODENAME. +NO-GOING-BACK is non-nil if recovering from an error in this function; +it says do not attempt further (recursive) error recovery." + (info-initialize) + (setq filename (Info-find-file filename)) ;; Record the node we are leaving. (if (and Info-current-file (not no-going-back)) (setq Info-history @@ -686,10 +739,14 @@ Info-current-file-completions nil buffer-file-name nil) (erase-buffer) - (if (eq filename t) - (Info-insert-dir) + (cond + ((eq filename t) + (Info-insert-dir)) + ((eq filename 'apropos) + (insert-buffer-substring " *info-apropos*")) + (t (info-insert-file-contents filename nil) - (setq default-directory (file-name-directory filename))) + (setq default-directory (file-name-directory filename)))) (set-buffer-modified-p nil) ;; See whether file has a tag table. Record the location if yes. (goto-char (point-max)) @@ -724,7 +781,11 @@ (set-marker Info-tag-table-marker pos))) (set-marker Info-tag-table-marker nil)) (setq Info-current-file - (if (eq filename t) "dir" filename)))) + (cond + ((eq filename t) "dir") + ((eq filename 'apropos) "apropos") + (t filename))) + )) ;; Use string-equal, not equal, to ignore text props. (if (string-equal nodename "*") (progn (setq Info-current-node nodename) @@ -788,7 +849,18 @@ nodename))) (Info-select-node) - (goto-char (or anchorpos (point-min)))))) + (goto-char (point-min)) + (cond (anchorpos + (let ((new-history (list Info-current-file + (substring-no-properties nodename)))) + ;; Add anchors to the history too + (setq Info-history-list + (cons new-history + (delete new-history Info-history-list)))) + (goto-char anchorpos)) + (Info-reference-name + (Info-find-index-name Info-reference-name) + (setq Info-reference-name nil)))))) ;; If we did not finish finding the specified node, ;; go back to the previous one. (or Info-current-node no-going-back (null Info-history) @@ -1134,12 +1206,28 @@ (image (if (file-exists-p image-file) (create-image image-file) "[broken image]"))) - (message "Found image: %S" image-file) (if (not (get-text-property start 'display)) (add-text-properties start (point) `(display ,image rear-nonsticky (display))))))) (set-buffer-modified-p nil))) +;; Texinfo 4.7 adds cookies of the form ^@^H[NAME CONTENTS ^@^H]. +;; Hide any construct of the general form ^@[^@-^_][ ... ^@[^@-^_]], +;; including one optional trailing newline. +(defun Info-hide-cookies-node () + "Hide unrecognised cookies in current node." + (save-excursion + (let ((inhibit-read-only t) + (case-fold-search t)) + (goto-char (point-min)) + (while (re-search-forward + "\\(\0[\0-\37][[][^\0]*\0[\0-\37][]]\n?\\)" + nil t) + (let* ((start (match-beginning 1))) + (if (not (get-text-property start 'invisible)) + (put-text-property start (point) 'invisible t))))) + (set-buffer-modified-p nil))) + (defun Info-select-node () "Select the info node that point is in." ;; Bind this in case the user sets it to nil. @@ -1174,8 +1262,13 @@ (read (current-buffer)))))) (point-max))) (if Info-enable-active-nodes (eval active-expression)) + ;; Add a new unique history item to full history list + (let ((new-history (list Info-current-file Info-current-node))) + (setq Info-history-list + (cons new-history (delete new-history Info-history-list)))) (Info-fontify-node) (Info-display-images-node) + (Info-hide-cookies-node) (run-hooks 'Info-selection-hook))))) (defun Info-set-mode-line () @@ -1207,6 +1300,8 @@ (if fork (set-buffer (clone-buffer (concat "*info-" (if (stringp fork) fork nodename) "*") t))) + (if (member (buffer-name) '("*info-history*" "*info-toc*")) + (switch-to-buffer "*info*")) (let (filename) (string-match "\\s *\\((\\s *\\([^\t)]*\\)\\s *)\\s *\\|\\)\\(.*\\)" nodename) @@ -1315,13 +1410,18 @@ (defvar Info-search-history nil "The history list for `Info-search'.") +(defvar Info-search-case-fold nil + "The value of `case-fold-search' from previous `Info-search' command.") + (defun Info-search (regexp) "Search for REGEXP, starting from point, and select node it's found in." (interactive (list (read-string (if Info-search-history - (format "Regexp search (default `%s'): " + (format "Regexp search%s (default `%s'): " + (if case-fold-search "" " case-sensitively") (car Info-search-history)) - "Regexp search: ") + (format "Regexp search%s: " + (if case-fold-search "" " case-sensitively"))) nil 'Info-search-history))) (when transient-mark-mode (deactivate-mark)) @@ -1334,6 +1434,10 @@ (opoint (point)) (ostart (window-start)) (osubfile Info-current-subfile)) + (when Info-search-whitespace-regexp + (setq regexp (replace-regexp-in-string + "[ \t\n]+" Info-search-whitespace-regexp regexp))) + (setq Info-search-case-fold case-fold-search) (save-excursion (save-restriction (widen) @@ -1409,6 +1513,20 @@ (equal ofile Info-current-file)) (setq Info-history (cons (list ofile onode opoint) Info-history)))))) + +(defun Info-search-case-sensitively () + "Search for a regexp case-sensitively." + (interactive) + (let ((case-fold-search nil)) + (call-interactively 'Info-search))) + +(defun Info-search-next () + "Search for next regexp from a previous `Info-search' command." + (interactive) + (let ((case-fold-search Info-search-case-fold)) + (if Info-search-history + (Info-search (car Info-search-history)) + (call-interactively 'Info-search)))) (defun Info-extract-pointer (name &optional errorname) "Extract the value of the node-pointer named NAME. @@ -1460,12 +1578,25 @@ "Go to the superior node of this node. If SAME-FILE is non-nil, do not move to a different Info file." (interactive) - (let ((node (Info-extract-pointer "up"))) + (let ((old-node Info-current-node) + (old-file Info-current-file) + (node (Info-extract-pointer "up")) p) (and (or same-file (not (stringp Info-current-file))) (string-match "^(" node) (error "Up node is in another Info file")) - (Info-goto-node node)) - (Info-restore-point Info-history)) + (Info-goto-node node) + (setq p (point)) + (goto-char (point-min)) + (if (and (search-forward "\n* Menu:" nil t) + (re-search-forward + (if (string-equal old-node "Top") + (concat "\n\\*[^:]+: +(" (file-name-nondirectory old-file) ")") + (concat "\n\\* +\\(" (regexp-quote old-node) + ":\\|[^:]+: +" (regexp-quote old-node) "\\)")) + nil t)) + (beginning-of-line) + (goto-char p) + (Info-restore-point Info-history)))) (defun Info-last () "Go back to the last node visited." @@ -1487,9 +1618,160 @@ (interactive) (Info-find-node "dir" "top")) -(defun Info-follow-reference (footnotename) +;;;###autoload (add-hook 'same-window-buffer-names "*info-history*") + +(defun Info-history () + "Create the buffer *info-history* with a menu of visited nodes." + (interactive) + (let ((curr-file Info-current-file) + (curr-node Info-current-node) + p) + (pop-to-buffer + (with-current-buffer (get-buffer-create "*info-history*") + (let ((inhibit-read-only t)) + (erase-buffer) + (goto-char (point-min)) + (insert "Node: History\n\n") + (insert "Recently Visited Nodes\n**********************\n\n") + (insert "* Menu:\n\n") + (let ((hl Info-history-list)) + (while hl + (let ((file (nth 0 (car hl))) + (node (nth 1 (car hl)))) + (if (and (string-equal file curr-file) + (string-equal node curr-node)) + (setq p (point))) + (insert "* " node ": (" (file-name-nondirectory file) + ")" node ".\n")) + (setq hl (cdr hl)))) + (or (eq major-mode 'Info-mode) (Info-mode)) + (setq Info-current-file "info-history") + (setq Info-current-node "Info History") + (Info-set-mode-line) + (if (not (bobp)) (Info-fontify-node)) + (current-buffer)))) + (goto-char (or p (point-min))))) + +;;;###autoload (add-hook 'same-window-buffer-names "*info-toc*") + +(defun Info-toc () + "Create the buffer *info-toc* with Info file's table of contents." + (interactive) + (let ((curr-file Info-current-file) + (curr-node Info-current-node) + p) + (pop-to-buffer + (with-current-buffer (get-buffer-create "*info-toc*") + (if (not (equal Info-current-file curr-file)) + (let ((inhibit-read-only t) + (node-list (Info-build-toc curr-file))) + (erase-buffer) + (goto-char (point-min)) + (insert "Node: Contents\n\n") + (insert "Table of Contents\n*****************\n\n") + (insert "*Note Top::\n") + (Info-insert-toc + (nth 2 (assoc "Top" node-list)) ; get Top nodes + node-list 0) + (or (eq major-mode 'Info-mode) (Info-mode)) + (setq Info-current-file curr-file) + (setq Info-current-node "Contents") + (Info-set-mode-line))) + (if (not (bobp)) + (let ((Info-hide-note-references 'hide)) + (Info-fontify-node))) + (goto-char (point-min)) + (if (setq p (search-forward (concat "*Note " curr-node "::") nil t)) + (setq p (- p (length curr-node) 2))) + (current-buffer))) + (goto-char (or p (point-min))))) + +(defun Info-insert-toc (nodes node-list level) + "Insert table of contents with references to nodes." + (let ((section "Top")) + (while nodes + (let ((node (assoc (car nodes) node-list))) + (unless (member (nth 1 node) (list nil section)) + (insert (setq section (nth 1 node)) "\n")) + (insert (make-string level ?\t)) + (insert "*Note " (car nodes) "::\n") + (Info-insert-toc (nth 2 node) node-list (1+ level)) + (setq nodes (cdr nodes)))))) + +(defun Info-build-toc (file) + "Build table of contents from menus of Info FILE and its subfiles." + (if (equal file "dir") + (error "Table of contents for Info directory is not supported yet")) + (with-temp-buffer + (let ((default-directory (or (and (stringp file) + (file-name-directory + (setq file (Info-find-file file)))) + default-directory)) + (sections '(("Top" "Top"))) + nodes subfiles) + (while (or file subfiles) + (or file (message "Searching subfile %s..." (car subfiles))) + (erase-buffer) + (info-insert-file-contents (or file (car subfiles))) + (while (and (search-forward "\n\^_\nFile:" nil 'move) + (search-forward "Node: " nil 'move)) + (let ((nodename (substring-no-properties (Info-following-node-name))) + (bound (- (or (save-excursion (search-forward "\n\^_" nil t)) + (point-max)) 2)) + (section "Top") + menu-items) + (when (and (not (string-match "\\" nodename)) + (re-search-forward "^\\* Menu:" bound t)) + (forward-line 1) + (beginning-of-line) + (setq bound (or (and (equal nodename "Top") + (save-excursion + (re-search-forward + "^[ \t-]*The Detailed Node Listing" nil t))) + bound)) + (while (< (point) bound) + (cond + ;; Menu item line + ((looking-at "^\\* +[^:]+:") + (beginning-of-line) + (forward-char 2) + (let ((menu-node-name (substring-no-properties + (Info-extract-menu-node-name)))) + (setq menu-items (cons menu-node-name menu-items)) + (if (equal nodename "Top") + (setq sections + (cons (list menu-node-name section) sections))))) + ;; Other non-empty strings in the Top node are section names + ((and (equal nodename "Top") + (looking-at "^\\([^ \t\n*=.-][^:\n]*\\)")) + (setq section (match-string-no-properties 1)))) + (forward-line 1) + (beginning-of-line))) + (setq nodes (cons (list nodename + (cadr (assoc nodename sections)) + (nreverse menu-items)) + nodes)) + (goto-char bound))) + (if file + (save-excursion + (goto-char (point-min)) + (if (search-forward "\n\^_\nIndirect:" nil t) + (let ((bound (save-excursion (search-forward "\n\^_" nil t)))) + (while (re-search-forward "^\\(.*\\): [0-9]+$" bound t) + (setq subfiles (cons (match-string-no-properties 1) + subfiles))))) + (setq subfiles (nreverse subfiles) + file nil)) + (setq subfiles (cdr subfiles)))) + (message "") + (nreverse nodes)))) + +(defun Info-follow-reference (footnotename &optional fork) "Follow cross reference named FOOTNOTENAME to the node it refers to. -FOOTNOTENAME may be an abbreviation of the reference name." +FOOTNOTENAME may be an abbreviation of the reference name. +If FORK is non-nil (interactively with a prefix arg), show the node in +a new info buffer. If FORK is a string, it is the name to use for the +new buffer." (interactive (let ((completion-ignore-case t) (case-fold-search t) @@ -1502,7 +1784,7 @@ (setq bol (point)) (goto-char (point-min)) - (while (re-search-forward "\\*note[ \n\t]*\\([^:]*\\):" nil t) + (while (re-search-forward "\\*note[ \n\t]+\\([^:]*\\):" nil t) (setq str (match-string-no-properties 1)) ;; See if this one should be the default. (and (null default) @@ -1539,7 +1821,7 @@ "Follow reference named: ") completions nil t))) (list (if (equal input "") - default input))) + default input) current-prefix-arg)) (error "No cross-references in this node")))) (unless footnotename @@ -1551,17 +1833,33 @@ (setq str (concat (substring str 0 i) "[ \t\n]+" (substring str (1+ i)))) (setq i (+ i 6))) (save-excursion - (goto-char (point-min)) - (or (re-search-forward str nil t) - (error "No cross-reference named %s" footnotename)) - (goto-char (+ (match-beginning 0) 5)) - (setq target - (Info-extract-menu-node-name t))) + ;; Move point to the beginning of reference if point is on reference + (or (looking-at "\\*note[ \n\t]+") + (and (looking-back "\\*note[ \n\t]+") + (goto-char (match-beginning 0))) + (if (and (save-excursion + (goto-char (+ (point) 5)) ; skip a possible *note + (re-search-backward "\\*note[ \n\t]+" nil t) + (looking-at (concat "\\*note[ \n\t]+" (Info-following-node-name-re)))) + (<= (point) (match-end 0))) + (goto-char (match-beginning 0)))) + ;; Go to the reference closest to point + (let ((next-ref (save-excursion (and (re-search-forward str nil t) + (+ (match-beginning 0) 5)))) + (prev-ref (save-excursion (and (re-search-backward str nil t) + (+ (match-beginning 0) 5))))) + (goto-char (cond ((and next-ref prev-ref) + (if (< (abs (- next-ref (point))) + (abs (- prev-ref (point)))) + next-ref prev-ref)) + ((or next-ref prev-ref)) + ((error "No cross-reference named %s" footnotename)))) + (setq target (Info-extract-menu-node-name t)))) (while (setq i (string-match "[ \t\n]+" target i)) (setq target (concat (substring target 0 i) " " (substring target (match-end 0)))) (setq i (+ i 1))) - (Info-goto-node target))) + (Info-goto-node target fork))) (defconst Info-menu-entry-name-re "\\(?:[^:]\\|:[^:,.;() \t\n]\\)*" ;; We allow newline because this is also used in Info-follow-reference, @@ -1968,7 +2266,7 @@ (defun Info-next-reference (&optional recur) "Move cursor to the next cross-reference or menu item in the node." (interactive) - (let ((pat "\\*note[ \n\t]*\\([^:]*\\):\\|^\\* .*:") + (let ((pat "\\*note[ \n\t]+\\([^:]+\\):\\|^\\* .*:\\|[hf]t?tp://") (old-pt (point)) (case-fold-search t)) (or (eobp) (forward-char 1)) @@ -1979,7 +2277,7 @@ (progn (goto-char old-pt) (error "No cross references in this node"))))) - (goto-char (match-beginning 0)) + (goto-char (or (match-beginning 1) (match-beginning 0))) (if (looking-at "\\* Menu:") (if recur (error "No cross references in this node") @@ -1988,7 +2286,7 @@ (defun Info-prev-reference (&optional recur) "Move cursor to the previous cross-reference or menu item in the node." (interactive) - (let ((pat "\\*note[ \n\t]*\\([^:]*\\):\\|^\\* .*:") + (let ((pat "\\*note[ \n\t]+\\([^:]+\\):\\|^\\* .*:\\|[hf]t?tp://") (old-pt (point)) (case-fold-search t)) (or (re-search-backward pat nil t) @@ -1998,7 +2296,7 @@ (progn (goto-char old-pt) (error "No cross references in this node"))))) - (goto-char (match-beginning 0)) + (goto-char (or (match-beginning 1) (match-beginning 0))) (if (looking-at "\\* Menu:") (if recur (error "No cross references in this node") @@ -2124,6 +2422,61 @@ (progn (beginning-of-line) t) ;; non-nil for recursive call (goto-char (point-min))))) +;;;###autoload +(defun info-apropos (string) + "Grovel indices of all known Info files on your system for STRING. +Build a menu of the possible matches." + (interactive "sIndex apropos: ") + (unless (string= string "") + (let ((pattern (format "\n\\* +\\([^\n]*%s[^\n]*\\):[ \t]+\\([^.]+\\)." + (regexp-quote string))) + (ohist Info-history) + (current-node Info-current-node) + (current-file Info-current-file) + manuals matches temp-file node) + (let ((Info-fontify-maximum-menu-size 0) + Info-use-header-lines + Info-hide-note-references) + (Info-directory) + (message "Searching indices...") + (goto-char (point-min)) + (re-search-forward "\\* Menu: *\n" nil t) + (while (re-search-forward "\\*.*: (\\([^)]+\\))" nil t) + (add-to-list 'manuals (match-string 1))) + (dolist (manual manuals) + (message "Searching %s" manual) + (condition-case nil + (save-excursion + (Info-find-node manual "Top") + (when (re-search-forward "\n\\* \\(.*\\\\)" nil t) + (goto-char (match-beginning 1)) + (Info-goto-node (Info-extract-menu-node-name)) + (while + (progn + (goto-char (point-min)) + (while (re-search-forward pattern nil t) + (add-to-list 'matches + (list (match-string 1) + (match-string 2) + manual))) + (and (setq node (Info-extract-pointer "next" t)) + (string-match "\\" node))) + (Info-goto-node node)))) + (error nil)))) + (Info-goto-node (concat "(" current-file ")" current-node)) + (setq Info-history ohist) + (message "Searching indices...done") + (if (null matches) + (message "No matches found") + (with-current-buffer (get-buffer-create " *info-apropos*") + (erase-buffer) + (insert "\n\nFile: apropos, Node: Top, Up: (dir)\n") + (insert "* Menu: \nNodes whose indices contain \"" string "\"\n\n") + (dolist (entry matches) + (insert "* " (car entry) " [" (nth 2 entry) + "]: (" (nth 2 entry) ")" (nth 1 entry) ".\n"))) + (Info-find-node "apropos" "top"))))) + (defun Info-undefined () "Make command be undefined in Info." (interactive) @@ -2209,12 +2562,12 @@ (save-excursion (forward-line 1) (eobp)) (Info-next-preorder))) -(defun Info-follow-nearest-node () +(defun Info-follow-nearest-node (&optional fork) "Follow a node reference near point. If point is on a reference, follow that reference. Otherwise, if point is in a menu item description, follow that menu item." - (interactive) - (or (Info-try-follow-nearest-node) + (interactive "P") + (or (Info-try-follow-nearest-node fork) (when (save-excursion (search-backward "\n* menu:" nil t)) (save-excursion @@ -2223,35 +2576,45 @@ (beginning-of-line 0)) (when (looking-at "\\* +\\([^\t\n]*\\):") (Info-goto-node - (Info-extract-menu-item (match-string-no-properties 1))) + (Info-extract-menu-item (match-string-no-properties 1)) fork) t))) (error "Point neither on reference nor in menu item description"))) ;; Common subroutine. -(defun Info-try-follow-nearest-node () +(defun Info-try-follow-nearest-node (&optional fork) "Follow a node reference near point. Return non-nil if successful." (let (node) (cond - ((setq node (Info-get-token (point) "\\*note[ \n]" - "\\*note[ \n]\\([^:]*\\):")) - (Info-follow-reference node)) + ((and (Info-get-token (point) "[hf]t?tp://" "[hf]t?tp://\\([^ \t\n\"`({<>})']+\\)") + (or (featurep 'browse-url) (require 'browse-url nil t))) + (setq node t) + (browse-url (browse-url-url-at-point))) + ((setq node (Info-get-token (point) "\\*note[ \n\t]+" + "\\*note[ \n\t]+\\([^:]*\\):\\(:\\|[ \n\t]*(\\)?")) +;;; (or (match-string 2) +;;; (setq Info-reference-name +;;; (replace-regexp-in-string +;;; "[ \n\t]+" " " (match-string-no-properties 1)))) + (Info-follow-reference node fork)) ;; menu item: node name ((setq node (Info-get-token (point) "\\* +" "\\* +\\([^:]*\\)::")) - (Info-goto-node node)) + (Info-goto-node node fork)) ;; menu item: index entry ((Info-get-token (point) "\\* +" "\\* +\\(.*\\): ") + (if (save-match-data (string-match "\\" Info-current-node)) + (setq Info-reference-name (match-string-no-properties 1))) (beginning-of-line) (forward-char 2) (setq node (Info-extract-menu-node-name)) - (Info-goto-node node)) + (Info-goto-node node fork)) ((setq node (Info-get-token (point) "Up: " "Up: \\([^,\n\t]*\\)")) - (Info-goto-node node)) + (Info-goto-node node fork)) ((setq node (Info-get-token (point) "Next: " "Next: \\([^,\n\t]*\\)")) - (Info-goto-node node)) + (Info-goto-node node fork)) ((setq node (Info-get-token (point) "File: " "File: \\([^,\n\t]*\\)")) - (Info-goto-node "Top")) + (Info-goto-node "Top" fork)) ((setq node (Info-get-token (point) "Prev: " "Prev: \\([^,\n\t]*\\)")) - (Info-goto-node node))) + (Info-goto-node node fork))) node)) (defvar Info-mode-map nil @@ -2335,19 +2698,31 @@ ("Reference" ["You should never see this" report-emacs-bug t]) ["Search..." Info-search :help "Search for regular expression in this Info file"] + ["Search Case-Sensitively..." Info-search-case-sensitively + :help "Search for regular expression case sensitively"] + ["Search Next" Info-search-next + :help "Search for another occurrence of regular expression"] ["Go to Node..." Info-goto-node :help "Go to a named node"] ["Last" Info-last :active Info-history :help "Go to the last node you were at"] + ["History" Info-history :active Info-history-list + :help "Go to the history buffer"] + ["Table of Contents" Info-toc + :help "Go to the buffer with a table of contents"] ("Index..." ["Lookup a String" Info-index :help "Look for a string in the index items"] ["Next Matching Item" Info-index-next - :help "Look for another occurrence of previous item"]) + :help "Look for another occurrence of previous item"] + ["Lookup a string in all indices" info-apropos + :help "Look for a string in the indices of all manuals"]) ["Edit" Info-edit :help "Edit contents of this node" :active Info-enable-edit] ["Copy Node Name" Info-copy-current-node-name :help "Copy the name of the current node into the kill ring"] + ["Clone Info buffer" clone-buffer + :help "Create a twin copy of the current Info buffer."] ["Exit" Info-exit :help "Stop reading Info"])) @@ -2403,7 +2778,7 @@ (case-fold-search t)) (save-excursion (goto-char (point-min)) - (while (re-search-forward "\\*note[ \n\t]*\\([^:]*\\):" nil t) + (while (re-search-forward "\\*note[ \n\t]+\\([^:]*\\):" nil t) (setq str (match-string 1)) (setq i 0) (while (setq i (string-match "[ \n\t]+" str i)) @@ -2476,6 +2851,8 @@ \\[Info-directory] Go to the Info directory node. \\[Info-follow-reference] Follow a cross reference. Reads name of reference. \\[Info-last] Move to the last node you were at. +\\[Info-history] Go to the history buffer. +\\[Info-toc] Go to the buffer with a table of contents. \\[Info-index] Look up a topic in this file's Index and move to that node. \\[Info-index-next] (comma) Move to the next match from a previous `i' command. \\[Info-top-node] Go to the Top node of this file. @@ -2496,6 +2873,7 @@ Advanced commands: \\[Info-copy-current-node-name] Put name of current info node in the kill ring. +\\[clone-buffer] Select a new cloned Info buffer in another window. \\[Info-edit] Edit contents of selected node. 1 Pick first item in node's menu. 2, 3, 4, 5 Pick second ... fifth item in node's menu. @@ -2504,6 +2882,10 @@ \\[universal-argument] \\[info] Move to new Info file with completion. \\[Info-search] Search through this Info file for specified regexp, and select the node in which the next occurrence is found. +\\[Info-search-case-sensitively] Search through this Info file + for specified regexp case-sensitively. +\\[Info-search-next] Search for another occurrence of regexp + from a previous `Info-search' command. \\[Info-next-reference] Move cursor to next cross-reference or menu item. \\[Info-prev-reference] Move cursor to previous cross-reference or menu item." (kill-all-local-variables) @@ -2793,17 +3175,6 @@ (push (substring string start end) matches) (apply #'concat (nreverse matches))))) -(defun Info-fontify-menu-headers () - "Add the face `info-menu-header' to any header before a menu entry." - (save-excursion - (goto-char (point-min)) - (when (re-search-forward "^\\* Menu:" nil t) - (put-text-property (match-beginning 0) (match-end 0) - 'font-lock-face 'info-menu-header) - (while (re-search-forward "\n\n\\([^*\n ].*\\)\n\n?[*]" nil t) - (put-text-property (match-beginning 1) (match-end 1) - 'font-lock-face 'info-menu-header))))) - (defvar Info-next-link-keymap (let ((keymap (make-sparse-keymap))) (define-key keymap [header-line mouse-1] 'Info-next) @@ -2833,201 +3204,313 @@ "Keymap to put on the Up link in the text or the header line.") (defun Info-fontify-node () - ;; Only fontify the node if it hasn't already been done. - (unless (let ((where (next-property-change (point-min)))) - (and where (not (= where (point-max))))) - (save-excursion - (let ((inhibit-read-only t) - (case-fold-search t) - paragraph-markers) - (goto-char (point-min)) - (when (looking-at "^\\(File: [^,: \t]+,?[ \t]+\\)?") - (goto-char (match-end 0)) - (while (looking-at "[ \t]*\\([^:, \t\n]+\\):[ \t]+\\([^:,\t\n]+\\),?") - (goto-char (match-end 0)) - (let* ((nbeg (match-beginning 2)) - (nend (match-end 2)) - (tbeg (match-beginning 1)) - (tag (match-string 1))) - (if (string-equal tag "Node") - (put-text-property nbeg nend 'font-lock-face 'info-header-node) - (put-text-property nbeg nend 'font-lock-face 'info-header-xref) - (put-text-property tbeg nend 'mouse-face 'highlight) - (put-text-property tbeg nend - 'help-echo - (concat "Go to node " - (buffer-substring nbeg nend))) - ;; Always set up the text property keymap. - ;; It will either be used in the buffer - ;; or copied in the header line. - (put-text-property tbeg nend 'keymap - (cond - ((equal tag "Prev") Info-prev-link-keymap) - ((equal tag "Next") Info-next-link-keymap) - ((equal tag "Up") Info-up-link-keymap)))))) - (when Info-use-header-line - (goto-char (point-min)) - (let ((header-end (line-end-position)) - header) - ;; If we find neither Next: nor Prev: link, show the entire - ;; node header. Otherwise, don't show the File: and Node: - ;; parts, to avoid wasting precious space on information that - ;; is available in the mode line. - (if (re-search-forward - "\\(next\\|up\\|prev[ious]*\\): " - header-end t) - (progn - (goto-char (match-beginning 1)) - (setq header (buffer-substring (point) header-end))) - (if (re-search-forward "node:[ \t]*[^ \t]+[ \t]*" header-end t) - (setq header - (concat "No next, prev or up links -- " - (buffer-substring (point) header-end))) - (setq header (buffer-substring (point) header-end)))) + "Fontify the node." + (save-excursion + (let* ((inhibit-read-only t) + (case-fold-search t) + paragraph-markers + (not-fontified-p ; the node hasn't already been fontified + (not (let ((where (next-property-change (point-min)))) + (and where (not (= where (point-max))))))) + (fontify-visited-p ; visited nodes need to be re-fontified + (and Info-fontify-visited-nodes + ;; Don't take time to refontify visited nodes in huge nodes + (< (- (point-max) (point-min)) Info-fontify-maximum-menu-size)))) + + ;; Fontify header line + (goto-char (point-min)) + (when (and not-fontified-p (looking-at "^\\(File: [^,: \t]+,?[ \t]+\\)?")) + (goto-char (match-end 0)) + (while (looking-at "[ \t]*\\([^:, \t\n]+\\):[ \t]+\\([^:,\t\n]+\\),?") + (goto-char (match-end 0)) + (let* ((nbeg (match-beginning 2)) + (nend (match-end 2)) + (tbeg (match-beginning 1)) + (tag (match-string 1))) + (if (string-equal tag "Node") + (put-text-property nbeg nend 'font-lock-face 'info-header-node) + (put-text-property nbeg nend 'font-lock-face 'info-header-xref) + (put-text-property tbeg nend 'mouse-face 'highlight) + (put-text-property tbeg nend + 'help-echo + (concat "Go to node " + (buffer-substring nbeg nend))) + ;; Always set up the text property keymap. + ;; It will either be used in the buffer + ;; or copied in the header line. + (put-text-property tbeg nend 'keymap + (cond + ((equal tag "Prev") Info-prev-link-keymap) + ((equal tag "Next") Info-next-link-keymap) + ((equal tag "Up") Info-up-link-keymap)))))) + (when Info-use-header-line + (goto-char (point-min)) + (let ((header-end (line-end-position)) + header) + ;; If we find neither Next: nor Prev: link, show the entire + ;; node header. Otherwise, don't show the File: and Node: + ;; parts, to avoid wasting precious space on information that + ;; is available in the mode line. + (if (re-search-forward + "\\(next\\|up\\|prev[ious]*\\): " + header-end t) + (progn + (goto-char (match-beginning 1)) + (setq header (buffer-substring (point) header-end))) + (if (re-search-forward "node:[ \t]*[^ \t]+[ \t]*" header-end t) + (setq header + (concat "No next, prev or up links -- " + (buffer-substring (point) header-end))) + (setq header (buffer-substring (point) header-end)))) + (put-text-property (point-min) (1+ (point-min)) + 'header-line (Info-escape-percent header)) + ;; Hide the part of the first line + ;; that is in the header, if it is just part. + (unless (bobp) + ;; Hide the punctuation at the end, too. + (skip-chars-backward " \t,") + (put-text-property (point) header-end 'invisible t))))) + + ;; Fontify titles + (goto-char (point-min)) + (when not-fontified-p + (while (re-search-forward "\n\\([^ \t\n].+\\)\n\\(\\*+\\|=+\\|-+\\|\\.+\\)$" + nil t) + (let* ((c (preceding-char)) + (face + (cond ((= c ?*) 'Info-title-1-face) + ((= c ?=) 'Info-title-2-face) + ((= c ?-) 'Info-title-3-face) + (t 'Info-title-4-face)))) + (put-text-property (match-beginning 1) (match-end 1) + 'font-lock-face face)) + ;; This is a serious problem for trying to handle multiple + ;; frame types at once. We want this text to be invisible + ;; on frames that can display the font above. + (when (memq (framep (selected-frame)) '(x pc w32 mac)) + (add-text-properties (1- (match-beginning 2)) (match-end 2) + '(invisible t front-sticky nil rear-nonsticky t))))) - (put-text-property (point-min) (1+ (point-min)) - 'header-line (Info-escape-percent header)) - ;; Hide the part of the first line - ;; that is in the header, if it is just part. - (unless (bobp) - ;; Hide the punctuation at the end, too. - (skip-chars-backward " \t,") - (put-text-property (point) header-end 'invisible t))))) - (goto-char (point-min)) - (while (re-search-forward "\n\\([^ \t\n].+\\)\n\\(\\*+\\|=+\\|-+\\|\\.+\\)$" - nil t) - (let* ((c (preceding-char)) - (face - (cond ((= c ?*) 'Info-title-1-face) - ((= c ?=) 'Info-title-2-face) - ((= c ?-) 'Info-title-3-face) - (t 'Info-title-4-face)))) - (put-text-property (match-beginning 1) (match-end 1) - 'font-lock-face face)) - ;; This is a serious problem for trying to handle multiple - ;; frame types at once. We want this text to be invisible - ;; on frames that can display the font above. - (when (memq (framep (selected-frame)) '(x pc w32 mac)) - (add-text-properties (1- (match-beginning 2)) (match-end 2) - '(invisible t front-sticky nil rear-nonsticky t)))) - (goto-char (point-min)) - (while (re-search-forward "\\(\\*Note[ \t]*\\)\n?[ \t]*\\([^:]*\\)\\(:[^.,:(]*\\(([^)]*)[^.,:]*\\)?[,:]?\n?\\)" nil t) - (unless (= (char-after (1- (match-beginning 0))) ?\") ; hack - (let ((start (match-beginning 0)) - (next (point)) - (hide-tag Info-hide-note-references) - other-tag) - (when hide-tag - ;; *Note is often used where *note should have been - (goto-char start) - (skip-syntax-backward " ") - (setq other-tag - (cond ((memq (char-before) '(nil ?\. ?! ??)) - "See ") - ((memq (char-before) '(?\, ?\; ?\: ?-)) - "see ") - ((memq (char-before) '(?\( ?\[ ?\{)) - ;; Check whether the paren is preceded by - ;; an end of sentence - (skip-syntax-backward " (") - (if (memq (char-before) '(nil ?\. ?! ??)) - "See " - "see ")) - ((save-match-data (looking-at "\n\n")) - "See "))) - (goto-char next)) - (if hide-tag - (add-text-properties (match-beginning 1) (match-end 1) - '(invisible t front-sticky nil rear-nonsticky t))) - (add-text-properties - (match-beginning 2) (match-end 2) - (cons 'help-echo - (cons (if (match-end 4) - (concat "mouse-2: go to " (match-string 4)) - "mouse-2: go to this node") - '(font-lock-face info-xref - mouse-face highlight)))) - (when (eq Info-hide-note-references t) - (add-text-properties (match-beginning 3) (match-end 3) - '(invisible t front-sticky nil rear-nonsticky t))) - (when other-tag - (save-excursion - (goto-char (match-beginning 1)) - (insert other-tag))) - (when (and Info-refill-paragraphs - (or hide-tag (eq Info-hide-note-references t))) - (push (set-marker (make-marker) start) - paragraph-markers))))) + ;; Fontify cross references + (goto-char (point-min)) + (when (or not-fontified-p fontify-visited-p) + (while (re-search-forward "\\(\\*Note[ \n\t]+\\)\\([^:]*\\)\\(:[ \t]*\\([^.,:(]*\\)\\(\\(([^)]*)\\)[^.,:]*\\)?[,:]?\n?\\)" nil t) + (let ((start (match-beginning 0)) + (next (point)) + other-tag) + (when not-fontified-p + (when Info-hide-note-references + ;; *Note is often used where *note should have been + (goto-char start) + (skip-syntax-backward " ") + (setq other-tag + (cond ((memq (char-before) '(nil ?\. ?! ??)) + "See ") + ((memq (char-before) '(?\, ?\; ?\: ?-)) + "see ") + ((memq (char-before) '(?\( ?\[ ?\{)) + ;; Check whether the paren is preceded by + ;; an end of sentence + (skip-syntax-backward " (") + (if (memq (char-before) '(nil ?\. ?! ??)) + "See " + "see ")) + ((save-match-data (looking-at "\n\n")) + "See "))) + (goto-char next) + (add-text-properties + (match-beginning 1) + (or (save-match-data + ;; Don't hide \n after *Note + (let ((start1 (match-beginning 1))) + (if (string-match "\n" (match-string 1)) + (+ start1 (match-beginning 0))))) + (match-end 1)) + (if (and other-tag (not (eq Info-hide-note-references 'hide))) + `(display ,other-tag front-sticky nil rear-nonsticky t) + '(invisible t front-sticky nil rear-nonsticky t)))) + (add-text-properties + (match-beginning 2) (match-end 2) + (list + 'help-echo (if (or (match-end 5) + (not (equal (match-string 4) ""))) + (concat "mouse-2: go to " (or (match-string 5) + (match-string 4))) + "mouse-2: go to this node") + 'mouse-face 'highlight))) + (when (or not-fontified-p fontify-visited-p) + (add-text-properties + (match-beginning 2) (match-end 2) + (list + 'font-lock-face + ;; Display visited nodes in a different face + (if (and Info-fontify-visited-nodes + (save-match-data + (let* ((node (replace-regexp-in-string + "^[ \t]+" "" + (replace-regexp-in-string + "[ \t\n]+" " " + (or (match-string 5) + (and (not (equal (match-string 4) "")) + (match-string 4)) + (match-string 2))))) + (file (file-name-nondirectory + Info-current-file)) + (hl Info-history-list) + res) + (if (string-match "(\\([^)]+\\))\\([^)]*\\)" node) + (setq file (match-string 1 node) + node (if (equal (match-string 2 node) "") + "Top" + (match-string 2 node)))) + (while hl + (if (and (string-equal node (nth 1 (car hl))) + (string-equal file + (file-name-nondirectory + (nth 0 (car hl))))) + (setq res (car hl) hl nil) + (setq hl (cdr hl)))) + res))) 'info-xref-visited 'info-xref)))) + (when not-fontified-p + (when (memq Info-hide-note-references '(t hide)) + (add-text-properties (match-beginning 3) (match-end 3) + '(invisible t front-sticky nil rear-nonsticky t)) + ;; Unhide the file name of the external reference in parens + (if (match-string 6) + (remove-text-properties (match-beginning 6) (match-end 6) + '(invisible t front-sticky nil rear-nonsticky t))) + ;; Unhide newline because hidden newlines cause too long lines + (save-match-data + (let ((start3 (match-beginning 3))) + (if (string-match "\n[ \t]*" (match-string 3)) + (remove-text-properties (+ start3 (match-beginning 0)) (+ start3 (match-end 0)) + '(invisible t front-sticky nil rear-nonsticky t)))))) + (when (and Info-refill-paragraphs Info-hide-note-references) + (push (set-marker (make-marker) start) + paragraph-markers)))))) - (when (and Info-refill-paragraphs - paragraph-markers) - (let ((fill-nobreak-invisible t) - (fill-individual-varying-indent nil) - (paragraph-start "\f\\|[ \t]*[-*]\\|[ \t]*$") - (paragraph-separate ".*\\.[ \t]*\n[ \t]\\|[ \t]*[-*]\\|[ \t\f]*$") - (adaptive-fill-mode nil)) - (goto-char (point-max)) - (while paragraph-markers - (let ((m (car paragraph-markers))) - (setq paragraph-markers (cdr paragraph-markers)) - (when (< m (point)) - (goto-char m) - (beginning-of-line) - (let ((beg (point))) - (when (zerop (forward-paragraph)) - (fill-individual-paragraphs beg (point) nil nil) - (goto-char beg)))) - (set-marker m nil))))) + ;; Refill paragraphs (experimental feature) + (when (and not-fontified-p + Info-refill-paragraphs + paragraph-markers) + (let ((fill-nobreak-invisible t) + (fill-individual-varying-indent nil) + (paragraph-start "\f\\|[ \t]*[-*]\\|[ \t]*$") + (paragraph-separate ".*\\.[ \t]*\n[ \t]\\|[ \t]*[-*]\\|[ \t\f]*$") + (adaptive-fill-mode nil)) + (goto-char (point-max)) + (while paragraph-markers + (let ((m (car paragraph-markers))) + (setq paragraph-markers (cdr paragraph-markers)) + (when (< m (point)) + (goto-char m) + (beginning-of-line) + (let ((beg (point))) + (when (zerop (forward-paragraph)) + (fill-individual-paragraphs beg (point) nil nil) + (goto-char beg)))) + (set-marker m nil))))) - (goto-char (point-min)) - (when (and (search-forward "\n* Menu:" nil t) - (not (string-match "\\" Info-current-node)) - ;; Don't take time to annotate huge menus - (< (- (point-max) (point)) Info-fontify-maximum-menu-size)) - (let ((n 0) - cont) - (while (re-search-forward - (concat "^\\* +\\(" Info-menu-entry-name-re "\\)\\(:" - Info-node-spec-re "\\([ \t]*\\)\\)") - nil t) - (setq n (1+ n)) - (if (and (<= n 9) (zerop (% n 3))) ; visual aids to help with 1-9 keys - (put-text-property (match-beginning 0) - (1+ (match-beginning 0)) - 'font-lock-face 'info-menu-5)) - (add-text-properties - (match-beginning 1) (match-end 1) - (cons 'help-echo - (cons - (if (match-end 3) - (concat "mouse-2: go to " (match-string 3)) - "mouse-2: go to this node") - '(font-lock-face info-xref - mouse-face highlight)))) - (when (eq Info-hide-note-references t) - (put-text-property (match-beginning 2) (1- (match-end 6)) - 'invisible t) - ;; We need a stretchable space like :align-to but with - ;; a minimum value. - (put-text-property (1- (match-end 6)) (match-end 6) 'display - (if (>= 22 (- (match-end 1) - (match-beginning 0))) - '(space :align-to 24) - '(space :width 2))) - (setq cont (looking-at ".")) - (while (and (= (forward-line 1) 0) - (looking-at "\\([ \t]+\\)[^*\n]")) - (put-text-property (match-beginning 1) (1- (match-end 1)) - 'invisible t) - (put-text-property (1- (match-end 1)) (match-end 1) - 'display - (if cont - '(space :align-to 26) - '(space :align-to 24))) - (setq cont t)))))) + ;; Fontify menu items + (goto-char (point-min)) + (when (and (or not-fontified-p fontify-visited-p) + (search-forward "\n* Menu:" nil t) + (not (string-match "\\" Info-current-node)) + ;; Don't take time to annotate huge menus + (< (- (point-max) (point)) Info-fontify-maximum-menu-size)) + (let ((n 0) + cont) + (while (re-search-forward + (concat "^\\* +\\(" Info-menu-entry-name-re "\\)\\(:" + Info-node-spec-re "\\([ \t]*\\)\\)") + nil t) + (when not-fontified-p + (setq n (1+ n)) + (if (and (<= n 9) (zerop (% n 3))) ; visual aids to help with 1-9 keys + (put-text-property (match-beginning 0) + (1+ (match-beginning 0)) + 'font-lock-face 'info-menu-5))) + (when not-fontified-p + (add-text-properties + (match-beginning 1) (match-end 1) + (list + 'help-echo (if (match-end 3) + (concat "mouse-2: go to " (match-string 3)) + "mouse-2: go to this node") + 'mouse-face 'highlight))) + (when (or not-fontified-p fontify-visited-p) + (add-text-properties + (match-beginning 1) (match-end 1) + (list + 'font-lock-face + ;; Display visited menu items in a different face + (if (and Info-fontify-visited-nodes + (save-match-data + (let ((node (if (equal (match-string 3) "") + (match-string 1) + (match-string 3))) + (file (file-name-nondirectory Info-current-file)) + (hl Info-history-list) + res) + (if (string-match "(\\([^)]+\\))\\([^)]*\\)" node) + (setq file (match-string 1 node) + node (if (equal (match-string 2 node) "") + "Top" + (match-string 2 node)))) + (while hl + (if (and (string-equal node (nth 1 (car hl))) + (string-equal file + (file-name-nondirectory + (nth 0 (car hl))))) + (setq res (car hl) hl nil) + (setq hl (cdr hl)))) + res))) 'info-xref-visited 'info-xref)))) + (when (and not-fontified-p (memq Info-hide-note-references '(t hide))) + (put-text-property (match-beginning 2) (1- (match-end 6)) + 'invisible t) + ;; Unhide the file name in parens + (if (and (match-end 4) (not (eq (char-after (match-end 4)) ?.))) + (remove-text-properties (match-beginning 4) (match-end 4) + '(invisible t))) + ;; We need a stretchable space like :align-to but with + ;; a minimum value. + (put-text-property (1- (match-end 6)) (match-end 6) 'display + (if (>= 22 (- (match-end 1) + (match-beginning 0))) + '(space :align-to 24) + '(space :width 2))) + (setq cont (looking-at ".")) + (while (and (= (forward-line 1) 0) + (looking-at "\\([ \t]+\\)[^*\n]")) + (put-text-property (match-beginning 1) (1- (match-end 1)) + 'invisible t) + (put-text-property (1- (match-end 1)) (match-end 1) + 'display + (if cont + '(space :align-to 26) + '(space :align-to 24))) + (setq cont t)))))) - (Info-fontify-menu-headers) - (set-buffer-modified-p nil))))) + ;; Fontify menu headers + ;; Add the face `info-menu-header' to any header before a menu entry + (goto-char (point-min)) + (when (and not-fontified-p (re-search-forward "^\\* Menu:" nil t)) + (put-text-property (match-beginning 0) (match-end 0) + 'font-lock-face 'info-menu-header) + (while (re-search-forward "\n\n\\([^*\n ].*\\)\n\n?[*]" nil t) + (put-text-property (match-beginning 1) (match-end 1) + 'font-lock-face 'info-menu-header))) + + ;; Fontify http and ftp references + (goto-char (point-min)) + (when not-fontified-p + (while (re-search-forward "[hf]t?tp://[^ \t\n\"`({<>})']+" nil t) + (add-text-properties (match-beginning 0) (match-end 0) + '(font-lock-face info-xref + mouse-face highlight + help-echo "mouse-2: go to this URL")))) + + (set-buffer-modified-p nil)))) ;; When an Info buffer is killed, make sure the associated tags buffer diff -r 7f60e040ccfc -r 1029206e72f2 lisp/international/latin1-disp.el --- a/lisp/international/latin1-disp.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/international/latin1-disp.el Thu Apr 08 12:29:09 2004 +0000 @@ -234,12 +234,11 @@ is. If FORCE is non-nil, set up the display regardless." (cond ((eq set 'latin-2) - (when (or force - (not (latin1-display-check-font set))) - (latin1-display-identities set) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (latin1-display-identities set) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,BF(B "'C" "C'") (?,BP(B "'D" "/D") (?,B&(B "'S" "S'") @@ -300,15 +299,14 @@ (?,Bk(B "\"e") (?,B=(B "''" "'") (?,B7(B "'<") ; Lynx's rendering of caron - )))) + ))) ((eq set 'latin-3) - (when (or force - (not (latin1-display-check-font set))) - (latin1-display-identities set) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (latin1-display-identities set) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,C!(B "/H") (?,C"(B "~`" "'(") (?,C&(B "^H" "H^") @@ -336,15 +334,14 @@ (?,Cx(B "^g" "g^") (?,C}(B "~u" "u(") (?,C~(B "^s" "s^") - (?,C(B "/." "^."))))) + (?,C(B "/." "^.")))) ((eq set 'latin-4) - (when (or force - (not (latin1-display-check-font set))) - (latin1-display-identities set) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (latin1-display-identities set) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,D!(B "A," "A;") (?,D"(B "k/" "kk") (?,D#(B "R," ",R") @@ -393,15 +390,14 @@ (?,Dy(B "u," "u;") (?,D}(B "u~" "~u") (?,D~(B "u-") - (?,D(B "^."))))) + (?,D(B "^.")))) ((eq set 'latin-5) - (when (or force - (not (latin1-display-check-font set))) - (latin1-display-identities set) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (latin1-display-identities set) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,Mp(B "~g" "g(") (?,MP(B "~G" "G(") (?,M](B ".I" "I^.") @@ -410,15 +406,14 @@ (?,Mj(B "^e" "e<") ; from latin-post (?,Ml(B ".e" "e^.") (?,Mo(B "\"i" "i-") ; from latin-post - (?,M}(B ".i" "i."))))) + (?,M}(B ".i" "i.")))) ((eq set 'latin-8) - (when (or force - (not (latin1-display-check-font set))) - (latin1-display-identities set) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (latin1-display-identities set) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,_!(B ".B" "B`") (?,_"(B ".b" "b`") (?,_%(B ".c" "c`") @@ -449,15 +444,14 @@ (?,_W(B ".T" "T`") (?,_~(B "^y" "y^") (?,_^(B "^Y" "Y^") - (?,_/(B "\"Y"))))) + (?,_/(B "\"Y")))) ((eq set 'latin-9) - (when (or force - (not (latin1-display-check-font set))) - (latin1-display-identities set) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (latin1-display-identities set) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,b((B "~s" "s<") (?,b&(B "~S" "S<") (?,b$(B "Euro" "E=") @@ -465,14 +459,13 @@ (?,b4(B "~Z" "Z<") (?,b>(B "\"Y") (?,b=(B "oe") - (?,b<(B "OE"))))) + (?,b<(B "OE")))) ((eq set 'greek) - (when (or force - (not (latin1-display-check-font set))) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,F!(B "9'") (?,F"(B "'9") (?,F/(B "-M") @@ -531,9 +524,10 @@ (?,F|(B "'o") (?,F}(B "'u") (?,F~(B "'w"))) - (mapc - (lambda (l) - (aset standard-display-table (car l) (string-to-vector (cadr l)))) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (aset standard-display-table (car l) (string-to-vector (cadr l))))) '((?,FA(B "A") (?,FB(B "B") (?,FE(B "E") @@ -548,23 +542,22 @@ (?,FT(B "T") (?,FU(B "Y") (?,FW(B "X") - (?,Fo(B "o"))))) + (?,Fo(B "o")))) ((eq set 'hebrew) - (when (or force - (not (latin1-display-check-font set))) - ;; Don't start with identities, since we don't have definitions - ;; for a lot of Hebrew in internal.el. (Intlfonts is also - ;; missing some glyphs.) - (let ((i 34)) - (while (<= i 62) - (aset standard-display-table - (make-char 'hebrew-iso8859-8 i) - (vector (make-char 'latin-iso8859-1 i))) - (setq i (1+ i)))) - (mapc - (lambda (l) - (aset standard-display-table (car l) (string-to-vector (cadr l)))) + ;; Don't start with identities, since we don't have definitions + ;; for a lot of Hebrew in internal.el. (Intlfonts is also + ;; missing some glyphs.) + (let ((i 34)) + (while (<= i 62) + (aset standard-display-table + (make-char 'hebrew-iso8859-8 i) + (vector (make-char 'latin-iso8859-1 i))) + (setq i (1+ i)))) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (aset standard-display-table (car l) (string-to-vector (cadr l))))) '((?,H_(B "=2") (?,H`(B "A+") (?,Ha(B "B+") @@ -592,19 +585,21 @@ (?,Hw(B "Q+") (?,Hx(B "R+") (?,Hy(B "Sh") - (?,Hz(B "T+"))))) + (?,Hz(B "T+")))) ;; Arabic probably isn't so useful in the absence of Arabic ;; language support... ((eq set 'arabic) (setq set 'arabic) - (when (or force - (not (latin1-display-check-font set))) - (aset standard-display-table ?,G (B ",A (B") - (aset standard-display-table ?,G$(B ",A$(B") - (aset standard-display-table ?,G-(B ",A-(B") - (mapc (lambda (l) - (apply 'latin1-display-char l)) + (or (char-displayable-p ?,G (B) + (aset standard-display-table ?,G (B ",A (B")) + (or (char-displayable-p ?,G$(B) + (aset standard-display-table ?,G$(B ",A$(B")) + (or (char-displayable-p ?,G-(B) + (aset standard-display-table ?,G-(B ",A-(B")) + (mapc (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,G,(B ",+") (?,G;(B ";+") (?,G?(B "?+") @@ -652,15 +647,14 @@ (?,Go(B "'+") (?,Gp(B "1+") (?,Gq(B "3+") - (?,Gr(B "0+"))))) + (?,Gr(B "0+")))) ((eq set 'cyrillic) (setq set 'cyrillic-iso) - (when (or force - (not (latin1-display-check-font set))) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) '((?,L"(B "Dj") (?,L#(B "Gj") (?,L$(B "IE") @@ -727,9 +721,10 @@ (?,L|(B "kj") (?,L~(B "v%") (?,L(B "dzh"))) - (mapc - (lambda (l) - (aset standard-display-table (car l) (string-to-vector (cadr l)))) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (aset standard-display-table (car l) (string-to-vector (cadr l))))) '((?,L!(B ",AK(B") (?,L%(B "S") (?,L&(B "I") @@ -758,7 +753,7 @@ (?,Lu(B "s") (?,Lv(B "i") (?,Lw(B ",Ao(B") - (?,Lx(B "j"))))) + (?,Lx(B "j")))) (t (error "Unsupported character set: %S" set))) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/language/ethio-util.el --- a/lisp/language/ethio-util.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/language/ethio-util.el Thu Apr 08 12:29:09 2004 +0000 @@ -417,6 +417,9 @@ nil nil nil nil nil ]) +;; To avoid byte-compiler warnings. It should never be set globally. +(defvar ethio-sera-being-called-by-w3) + ;;;###autoload (defun ethio-sera-to-fidel-region (beg end &optional secondary force) "Convert the characters in region from SERA to FIDEL. @@ -587,8 +590,8 @@ (cond ;; skip from "<" to ">" (or from "&" to ";") if in w3-mode - ((and (boundp 'sera-being-called-by-w3) - sera-being-called-by-w3 + ((and (boundp 'ethio-sera-being-called-by-w3) + ethio-sera-being-called-by-w3 (or (= ch ?<) (= ch ?&))) (search-forward (if (= ch ?<) ">" ";") nil 0)) @@ -1174,8 +1177,8 @@ (goto-char (1+ (match-end 0)))) ; because we inserted one byte (\) ;; skip from "<" to ">" (or from "&" to ";") if called from w3 - ((and (boundp 'sera-being-called-by-w3) - sera-being-called-by-w3 + ((and (boundp 'ethio-sera-being-called-by-w3) + ethio-sera-being-called-by-w3 (or (= ch ?<) (= ch ?&))) (search-forward (if (= ch ?<) ">" ";") nil 0)) @@ -1835,7 +1838,7 @@ (set-buffer-modified-p nil))) ((string-match "\\.html$" (buffer-file-name)) - (let ((sera-being-called-by-w3 t)) + (let ((ethio-sera-being-called-by-w3 t)) (save-excursion (ethio-sera-to-fidel-marker 'force) (goto-char (point-min)) @@ -1872,7 +1875,7 @@ ((string-match "\\.html$" (buffer-file-name)) (save-excursion - (let ((sera-being-called-by-w3 t) + (let ((ethio-sera-being-called-by-w3 t) (lq (aref ethio-fidel-to-sera-map 461)) (rq (aref ethio-fidel-to-sera-map 462))) (aset ethio-fidel-to-sera-map 461 "«te;") diff -r 7f60e040ccfc -r 1029206e72f2 lisp/play/gamegrid.el --- a/lisp/play/gamegrid.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/play/gamegrid.el Thu Apr 08 12:29:09 2004 +0000 @@ -566,7 +566,7 @@ ((boundp 'user-mail-address) user-mail-address) (t "")))) - (sort-numeric-fields 1 (point-min) (point-max)) + (sort-fields 1 (point-min) (point-max)) (reverse-region (point-min) (point-max)) (goto-line (1+ gamegrid-score-file-length)) (delete-region (point) (point-max)) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/printing.el --- a/lisp/printing.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/printing.el Thu Apr 08 12:29:09 2004 +0000 @@ -5,7 +5,7 @@ ;; Author: Vinicius Jose Latorre ;; Maintainer: Vinicius Jose Latorre -;; Time-stamp: <2004/03/31 23:14:47 vinicius> +;; Time-stamp: <2004/04/05 23:41:49 vinicius> ;; Keywords: wp, print, PostScript ;; Version: 6.7.4 ;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/ @@ -190,6 +190,13 @@ ;; 4. When running Emacs on Windows with cygwin, check if the ;; `pr-shell-file-name' variable is set to the proper shell. This shell ;; will execute the commands to preview/print the buffer, file or directory. +;; Also check the setting of `pr-path-style' variable. +;; Probably, you should use: +;; +;; (setq pr-shell-file-name "bash") +;; (setq pr-path-style 'unix) +;; +;; And use / instead of \ when specifying a directory. ;; ;; ;; Using `printing' diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/compile.el --- a/lisp/progmodes/compile.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/compile.el Thu Apr 08 12:29:09 2004 +0000 @@ -30,9 +30,9 @@ ;; This package provides the compile facilities documented in the Emacs user's ;; manual. -;;; This mode uses some complex data-structures: +;; This mode uses some complex data-structures: -;;; LOC (or location) is a list of (COLUMN LINE FILE-STRUCTURE) +;; LOC (or location) is a list of (COLUMN LINE FILE-STRUCTURE) ;; COLUMN and LINE are numbers parsed from an error message. COLUMN and maybe ;; LINE will be nil for a message that doesn't contain them. Then the @@ -44,8 +44,8 @@ ;; Being a marker it sticks to some text, when the buffer grows or shrinks ;; before that point. VISITED is t if we have jumped there, else nil. -;;; FILE-STRUCTURE is a list of ((FILENAME . DIRECTORY) FORMATS (LINE LOC ...) -;;; ...) +;; FILE-STRUCTURE is a list of +;; ((FILENAME . DIRECTORY) FORMATS (LINE LOC ...) ...) ;; FILENAME is a string parsed from an error message. DIRECTORY is a string ;; obtained by following directory change messages. DIRECTORY will be nil for @@ -57,7 +57,7 @@ ;; ordered the same way. Note that the whole file structure is referenced in ;; every LOC. -;;; MESSAGE is a list of (LOC TYPE END-LOC) +;; MESSAGE is a list of (LOC TYPE END-LOC) ;; TYPE is 0 for info or 1 for warning if the message matcher identified it as ;; such, 2 otherwise (for a real error). END-LOC is a LOC pointing to the @@ -66,11 +66,9 @@ ;; These are the value of the `message' text-properties in the compilation ;; buffer. - ;;; Code: -;; This is the parsing engine for compile: -(require 'font-lock) ; needed to get font-lock-value-in-major-mode +(eval-when-compile (require 'cl)) (defgroup compilation nil "Run compiler as inferior of Emacs, parse error messages." @@ -170,9 +168,9 @@ \\([0-9]+\\)\\(?:[) \t]\\|:[^0-9\n]\\)" 2 3 nil (1)) (caml - "^ *File \"\\([^,\" \n\t]+\\)\", lines? \\([0-9]+\\)-?\\([0-9]+\\)?,\ -\\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:\\)?\\([ \n]Warning:\\)?" - 1 (2 . 3) (4 . 5) (6)) + "^ *File \\(\"?\\)\\([^,\" \n\t<>]+\\)\\1, lines? \\([0-9]+\\)-?\\([0-9]+\\)?\\(?:$\\|,\ +\\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:\\)?\\([ \n]Warning:\\)?\\)" + 2 (3 . 4) (5 . 6) (7)) (comma "^\"\\([^,\" \n\t]+\\)\", line \\([0-9]+\\)\ @@ -190,8 +188,8 @@ \\(?:warnin\\(g\\)\\|informationa\\(l\\)\\)?" 1 2 3 (4 . 5)) (irix - "^[a-z0-9/]+: \\(?:[eE]rror\\|[wW]arnin\\(g\\)\\)[0-9 ]*:\ - \\([^,\" \n\t]+\\)\\(?:, line\\|:\\) \\([0-9]+\\):" 2 3 nil (1)) + "^[a-z0-9/]+: \\(?:[eE]rror\\|[wW]arnin\\(g\\)\\|[iI]nf\\(o\\)\\)[0-9 ]*:\ + \\([^,\" \n\t]+\\)\\(?:, line\\|:\\) \\([0-9]+\\):" 3 4 nil (1 . 2)) (java "^\\(?:[ \t]+at \\|==[0-9]+== +\\(?:at\\|b\\(y\\)\\)\\).+(\\([^()\n]+\\):\\([0-9]+\\))$" 2 3 nil (1)) @@ -453,7 +451,8 @@ (((class color)) (:foreground "Orange" :weight bold)) (t (:weight bold))) "Face used to highlight compiler warnings." - :group 'font-lock-highlighting-faces) + :group 'font-lock-highlighting-faces + :version "21.4") (defface compilation-info-face '((((type tty) (class color)) (:foreground "green" :weight bold)) @@ -461,7 +460,8 @@ (((class color) (background dark)) (:foreground "Green" :weight bold)) (t (:weight bold))) "Face used to highlight compiler warnings." - :group 'font-lock-highlighting-faces) + :group 'font-lock-highlighting-faces + :version "21.4") (defvar compilation-message-face nil "Face name to use for whole messages. @@ -493,6 +493,12 @@ +;; Used for compatibility with the old compile.el. +(defvar compilation-parsing-end nil) +(defvar compilation-parse-errors-function nil) +(defvar compilation-error-list nil) +(defvar compilation-old-error-list nil) + (defun compilation-face (type) (or (and (car type) (match-end (car type)) compilation-warning-face) (and (cdr type) (match-end (cdr type)) compilation-info-face) @@ -612,8 +618,7 @@ (nthcdr 3 marker) (cddr marker)) file compilation-error-screen-columns) - (save-excursion - (set-buffer (marker-buffer (cddr marker))) + (with-current-buffer (marker-buffer (cddr marker)) (save-restriction (widen) (goto-char (marker-position (cddr marker))) @@ -669,33 +674,45 @@ (if (consp file) (setq fmt (cdr file) file (car file))) (if (consp line) (setq end-line (cdr line) line (car line))) (if (consp col) (setq end-col (cdr col) col (car col))) - - `(,(nth 0 item) - - ,@(when (integerp file) - `((,file ,(if (consp type) - `(compilation-face ',type) - (aref [compilation-info-face - compilation-warning-face - compilation-error-face] - (or type 2)))))) + + (if (symbolp line) + ;; The old compile.el had here an undocumented hook that + ;; allowed `line' to be a function that computed the actual + ;; error location. Let's do our best. + `(,(car item) + (0 (compilation-compat-error-properties + (funcall ',line (list* (match-string ,file) + default-directory + ',(nthcdr 4 item)) + ,(if col `(match-string ,col))))) + (,file compilation-error-face t)) + + `(,(nth 0 item) - ,@(when line - `((,line compilation-line-face nil t))) - ,@(when end-line - `((,end-line compilation-line-face nil t))) + ,@(when (integerp file) + `((,file ,(if (consp type) + `(compilation-face ',type) + (aref [compilation-info-face + compilation-warning-face + compilation-error-face] + (or type 2)))))) - ,@(when col - `((,col compilation-column-face nil t))) - ,@(when end-col - `((,end-col compilation-column-face nil t))) + ,@(when line + `((,line compilation-line-face nil t))) + ,@(when end-line + `((,end-line compilation-line-face nil t))) - ,@(nthcdr 6 item) - (,(or (nth 5 item) 0) - (compilation-error-properties ',file ,line ,end-line - ,col ,end-col ',(or type 2) - ',fmt) - append)))) ; for compilation-message-face + ,@(when col + `((,col compilation-column-face nil t))) + ,@(when end-col + `((,end-col compilation-column-face nil t))) + + ,@(nthcdr 6 item) + (,(or (nth 5 item) 0) + (compilation-error-properties ',file ,line ,end-line + ,col ,end-col ',(or type 2) + ',fmt) + append))))) ; for compilation-message-face compilation-error-regexp-alist) compilation-mode-font-lock-keywords)) @@ -829,11 +846,10 @@ process-environment)) (thisdir default-directory) outwin outbuf) - (save-excursion - (setq outbuf - (get-buffer-create (compilation-buffer-name name-of-mode - name-function))) - (set-buffer outbuf) + (with-current-buffer + (setq outbuf + (get-buffer-create + (compilation-buffer-name name-of-mode name-function))) (let ((comp-proc (get-buffer-process (current-buffer)))) (if comp-proc (if (or (not (eq (process-status comp-proc) 'run)) @@ -962,7 +978,7 @@ (defvar compilation-minor-mode-map (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'compile-mouse-goto-error) + (define-key map [mouse-2] 'compile-goto-error) (define-key map "\C-c\C-c" 'compile-goto-error) (define-key map "\C-m" 'compile-goto-error) (define-key map "\C-c\C-k" 'kill-compilation) @@ -978,7 +994,7 @@ (defvar compilation-shell-minor-mode-map (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'compile-mouse-goto-error) + (define-key map [mouse-2] 'compile-goto-error) (define-key map "\M-\C-m" 'compile-goto-error) (define-key map "\M-\C-n" 'compilation-next-error) (define-key map "\M-\C-p" 'compilation-previous-error) @@ -1013,6 +1029,30 @@ (put 'compilation-mode 'mode-class 'special) +(defvar compilation-skip-to-next-location t + "*If non-nil, skip multiple error messages for the same source location.") + +(defcustom compilation-skip-threshold 1 + "*Compilation motion commands skip less important messages. +The value can be either 2 -- skip anything less than error, 1 -- +skip anything less than warning or 0 -- don't skip any messages. +Note that all messages not positively identified as warning or +info, are considered errors." + :type '(choice (const :tag "Warnings and info" 2) + (const :tag "Info" 1) + (const :tag "None" 0)) + :group 'compilation + :version "21.4") + +(defcustom compilation-skip-visited nil + "*Compilation motion commands skip visited messages if this is t. +Visited messages are ones for which the file, line and column have been jumped +to from the current content in the current compilation buffer, even if it was +from a different message." + :type 'boolean + :group 'compilation + :version "21.4") + ;;;###autoload (defun compilation-mode () "Major mode for compilation log buffers. @@ -1076,10 +1116,9 @@ (if (or noconfirm (yes-or-no-p (format "Restart compilation? "))) (apply 'compilation-start compilation-arguments)))) -;; This points to the location from where the next error will be found. -;; The global commands next/previous/first-error... as well as -;; (mouse-)goto-error use this. -(defvar compilation-current-error nil) +(defvar compilation-current-error nil + "Marker to the location from where the next error will be found. +The global commands next/previous/first-error/goto-error use this.") ;; A function name can't be a hook, must be something with a value. (defconst compilation-turn-on-font-lock 'turn-on-font-lock) @@ -1089,28 +1128,27 @@ (make-local-variable 'compilation-current-error) (make-local-variable 'compilation-error-screen-columns) (setq compilation-last-buffer (current-buffer)) - (if minor - (if font-lock-defaults - (font-lock-add-keywords nil (compilation-mode-font-lock-keywords)) - (set (make-local-variable 'font-lock-defaults) - '(compilation-mode-font-lock-keywords t))) - (set (make-local-variable 'font-lock-defaults) - '(compilation-mode-font-lock-keywords t))) (set (make-local-variable 'font-lock-extra-managed-props) '(directory message help-echo mouse-face debug)) (set (make-local-variable 'compilation-locs) (make-hash-table :test 'equal :weakness 'value)) ;; lazy-lock would never find the message unless it's scrolled to - ;; jit-lock might fontify some things too late - (if (font-lock-value-in-major-mode font-lock-support-mode) - (set (make-local-variable 'font-lock-support-mode) nil)) + ;; jit-lock might fontify some things too late. + (set (make-local-variable 'font-lock-support-mode) nil) (set (make-local-variable 'font-lock-maximum-size) nil) - (if minor - (if font-lock-mode - (font-lock-fontify-buffer) - (turn-on-font-lock)) - ;; maybe defer font-lock till after derived mode is set up - (run-mode-hooks 'compilation-turn-on-font-lock))) + (let ((fld font-lock-defaults)) + (if (and minor fld) + (font-lock-add-keywords nil (compilation-mode-font-lock-keywords)) + (setq font-lock-defaults '(compilation-mode-font-lock-keywords t))) + (if minor + (if font-lock-mode + (if fld + (font-lock-fontify-buffer) + (font-lock-change-mode) + (turn-on-font-lock)) + (turn-on-font-lock)) + ;; maybe defer font-lock till after derived mode is set up + (run-mode-hooks 'compilation-turn-on-font-lock)))) ;;;###autoload (define-minor-mode compilation-shell-minor-mode @@ -1185,22 +1223,16 @@ (if (null (buffer-name buffer)) ;; buffer killed (set-process-buffer proc nil) - (let ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in the compilation buffer - ;; and hack its mode line. - (set-buffer buffer) - (compilation-handle-exit (process-status proc) - (process-exit-status proc) - msg) - ;; Since the buffer and mode line will show that the - ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - (set-buffer obuf)))) + (with-current-buffer buffer + ;; Write something in the compilation buffer + ;; and hack its mode line. + (compilation-handle-exit (process-status proc) + (process-exit-status proc) + msg) + ;; Since the buffer and mode line will show that the + ;; process is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (delete-process proc))) (setq compilation-in-progress (delq proc compilation-in-progress)) )))) @@ -1208,9 +1240,8 @@ "Process filter for compilation buffers. Just inserts the text, but uses `insert-before-markers'." (if (buffer-name (process-buffer proc)) - (save-excursion - (set-buffer (process-buffer proc)) - (let ((buffer-read-only nil)) + (with-current-buffer (process-buffer proc) + (let ((inhibit-read-only t)) (save-excursion (goto-char (process-mark proc)) (insert-before-markers string) @@ -1254,18 +1285,15 @@ last) (if (zerop n) (unless (or msg ; find message near here - (setq msg (get-text-property (max (1- pt) 1) 'message))) + (setq msg (get-text-property (max (1- pt) (point-min)) + 'message))) (setq pt (previous-single-property-change pt 'message nil - (save-excursion - (beginning-of-line) - (point)))) - (if pt - (setq msg (get-text-property (max (1- pt) 1) 'message)) + (line-beginning-position))) + (if pt ; FIXME: `pt' can never be nil here anyway. --stef + (setq msg (get-text-property (max (1- pt) (point-min)) 'message)) (setq pt (next-single-property-change pt 'message nil - (save-excursion - (end-of-line) - (point)))) - (if pt + (line-end-position))) + (if pt ; FIXME: `pt' can never be nil here anyway. --stef (setq msg (get-text-property pt 'message)) (setq pt (point))))) (setq last (nth 2 (car msg))) @@ -1274,8 +1302,9 @@ (if (get-buffer-process (current-buffer)) "No more %ss yet" "Moved past last %s")) - ;; don't move "back" to message at or before point - (setq pt (previous-single-property-change pt 'message)) + ;; Don't move "back" to message at or before point. + ;; Pass an explicit (point-min) to make sure pt is non-nil. + (setq pt (previous-single-property-change pt 'message nil (point-min))) (compilation-loop < previous-single-property-change 1+ "Moved back before first %s"))) (goto-char pt) @@ -1329,26 +1358,20 @@ (interrupt-process (get-buffer-process buffer)) (error "The compilation process is not running")))) -(defun compile-mouse-goto-error (event) - "Visit the source for the error message the mouse is pointing at." - (interactive "e") - (mouse-set-point event) - (if (get-text-property (point) 'directory) - (dired-other-window (car (get-text-property (point) 'directory))) - (setq compilation-current-error (point)) - (next-error 0))) +(defalias 'compile-mouse-goto-error 'compile-goto-error) -(defun compile-goto-error () - "Visit the source for the error message point is on. +(defun compile-goto-error (&optional event) + "Visit the source for the error message at point. Use this command in a compilation log buffer. Sets the mark at point there." - (interactive) + (interactive (list last-input-event)) (or (compilation-buffer-p (current-buffer)) (error "Not in a compilation buffer")) - (if (get-text-property (point) 'directory) - (dired-other-window (car (get-text-property (point) 'directory))) - (push-mark) - (setq compilation-current-error (point)) - (next-error 0))) + (let ((pos (if event (posn-point (event-end event)) (point)))) + (if (get-text-property (point) 'directory) + (dired-other-window (car (get-text-property pos 'directory))) + (push-mark) + (setq compilation-current-error pos) + (next-error 0)))) ;; Return a compilation buffer. ;; If the current buffer is a compilation buffer, return it. @@ -1413,13 +1436,12 @@ ;; the marker is invalid the buffer has been killed. So, recalculate all ;; markers for that file. (unless (and (nthcdr 3 loc) (marker-buffer (nth 3 loc))) - (save-excursion - (set-buffer (compilation-find-file marker (caar (nth 2 loc)) - (or (cdar (nth 2 loc)) - default-directory))) + (with-current-buffer (compilation-find-file marker (caar (nth 2 loc)) + (or (cdar (nth 2 loc)) + default-directory)) (save-restriction (widen) - (goto-char 1) + (goto-char (point-min)) ;; Treat file's found lines in forward order, 1 by 1. (dolist (line (reverse (cddr (nth 2 loc)))) (when (car line) ; else this is a filename w/o a line# @@ -1460,35 +1482,14 @@ This operates on the output from the \\[compile] command." (interactive "p") (set-buffer (setq compilation-last-buffer (compilation-find-buffer))) - (setq compilation-current-error (point-min)) + (setq compilation-current-error nil) (next-error n)) -(defvar compilation-skip-to-next-location t - "*If non-nil, skip multiple error messages for the same source location.") - -(defcustom compilation-skip-threshold 1 - "*Compilation motion commands skip less important messages. -The value can be either 2 -- skip anything less than error, 1 -- -skip anything less than warning or 0 -- don't skip any messages. -Note that all messages not positively identified as warning or -info, are considered errors." - :type '(choice (const :tag "Warnings and info" 2) - (const :tag "Info" 1) - (const :tag "None" 0)) - :group 'compilation) - -(defcustom compilation-skip-visited nil - "*Compilation motion commands skip visited messages if this is t. -Visited messages are ones for which the file, line and column have been jumped -to from the current content in the current compilation buffer, even if it was -from a different message." - :type 'boolean - :group 'compilation) - (defcustom compilation-context-lines next-screen-context-lines "*Display this many lines of leading context before message." :type 'integer - :group 'compilation) + :group 'compilation + :version "21.4") (defsubst compilation-set-window (w mk) ;; Align the compilation output window W with marker MK near top. @@ -1540,12 +1541,13 @@ (when (and highlight-regexp (not (and end-mk transient-mark-mode))) (unless compilation-highlight-overlay - (setq compilation-highlight-overlay (make-overlay 1 1)) + (setq compilation-highlight-overlay + (make-overlay (point-min) (point-min))) (overlay-put compilation-highlight-overlay 'face 'region)) (with-current-buffer (marker-buffer mk) (save-excursion (end-of-line) - (let ((end (point)) olay) + (let ((end (point))) (beginning-of-line) (if (and (stringp highlight-regexp) (re-search-forward highlight-regexp end t)) @@ -1553,7 +1555,7 @@ (goto-char (match-beginning 0)) (move-overlay compilation-highlight-overlay (match-beginning 0) (match-end 0))) (move-overlay compilation-highlight-overlay (point) end)) - (sit-for 0 500) + (sit-for 0.5) (delete-overlay compilation-highlight-overlay))))))) @@ -1670,6 +1672,80 @@ (add-to-list 'debug-ignored-errors "^No more [-a-z ]+s yet$") +;;; Compatibility with the old compile.el. + +(defun compile-buffer-substring (n) (if n (match-string n))) + +(defun compilation-compat-error-properties (err) + ;; Map old-style ERROR to new-style MESSAGE. + (let* ((dst (cdr err)) + (loc (cond ((markerp dst) (list nil nil nil dst)) + ((consp dst) + (list (nth 2 dst) (nth 1 dst) + (cons (cdar dst) (caar dst))))))) + ;; Must start with a face, for font-lock. + `(face nil + message ,(list loc 2) + help-echo "mouse-2: visit the source location" + mouse-face highlight))) + +(defun compilation-compat-parse-errors (limit) + (when compilation-parse-errors-function + ;; FIXME: We should remove the rest of the compilation keywords + ;; but we can't do that from here because font-lock is using + ;; the value right now. --stef + (save-excursion + (setq compilation-error-list nil) + ;; Reset compilation-parsing-end each time because font-lock + ;; might force us the re-parse many times (typically because + ;; some code adds some text-property to the output that we + ;; already parsed). You might say "why reparse", well: + ;; because font-lock has just removed the `message' property so + ;; have to do it all over again. + (if compilation-parsing-end + (set-marker compilation-parsing-end (point)) + (setq compilation-parsing-end (point-marker))) + (condition-case nil + ;; Ignore any error: we're calling this function earlier than + ;; in the old compile.el so things might not all be setup yet. + (funcall compilation-parse-errors-function limit nil) + (error nil)) + (dolist (err (if (listp compilation-error-list) compilation-error-list)) + (let* ((src (car err)) + (dst (cdr err)) + (loc (cond ((markerp dst) (list nil nil nil dst)) + ((consp dst) + (list (nth 2 dst) (nth 1 dst) + (cons (cdar dst) (caar dst))))))) + (when loc + (goto-char src) + ;; (put-text-property src (line-end-position) 'font-lock-face 'font-lock-warning-face) + (put-text-property src (line-end-position) + 'message (list loc 2))))))) + (goto-char limit) + nil) + +(defun compilation-forget-errors () + ;; In case we hit the same file/line specs, we want to recompute a new + ;; marker for them, so flush our cache. + (set (make-local-variable 'compilation-locs) + (make-hash-table :test 'equal :weakness 'value)) + ;; FIXME: the old code reset the directory-stack, so maybe we should + ;; put a `directory change' marker of some sort, but where? -stef + ;; + ;; FIXME: The old code moved compilation-current-error (which was + ;; virtually represented by a mix of compilation-parsing-end and + ;; compilation-error-list) to point-min, but that was only meaningful for + ;; the internal uses of compilation-forget-errors: all calls from external + ;; packages seem to be followed by a move of compilation-parsing-end to + ;; something equivalent to point-max. So we speculatively move + ;; compilation-current-error to point-max (since the external package + ;; won't know that it should do it). --stef + (setq compilation-current-error (point-max)) + ;; FIXME the old code removed the mouse-face and help-echo properties. + ;; Should we font-lock-fontify-buffer? --stef + ) + (provide 'compile) ;;; arch-tag: 12465727-7382-4f72-b234-79855a00dd8c diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/ebnf-abn.el --- a/lisp/progmodes/ebnf-abn.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/ebnf-abn.el Thu Apr 08 12:29:09 2004 +0000 @@ -4,9 +4,9 @@ ;; Author: Vinicius Jose Latorre ;; Maintainer: Vinicius Jose Latorre -;; Time-stamp: <2004/03/18 23:49:58 vinicius> +;; Time-stamp: <2004/04/03 16:43:57 vinicius> ;; Keywords: wp, ebnf, PostScript -;; Version: 1.0 +;; Version: 1.1 ;; This file is part of GNU Emacs. @@ -316,11 +316,7 @@ term (cdr term)) (setq seq (cons term seq))) (cons token - (if (= (length seq) 1) - ;; sequence with only one element - (car seq) - ;; a real sequence - (ebnf-make-sequence (nreverse seq)))))) + (ebnf-token-sequence seq)))) ;;; repetition = [repeat] element diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/ebnf-bnf.el --- a/lisp/progmodes/ebnf-bnf.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/ebnf-bnf.el Thu Apr 08 12:29:09 2004 +0000 @@ -5,9 +5,9 @@ ;; Author: Vinicius Jose Latorre ;; Maintainer: Vinicius Jose Latorre -;; Time-stamp: <2004/02/28 18:25:52 vinicius> +;; Time-stamp: <2004/04/03 16:42:18 vinicius> ;; Keywords: wp, ebnf, PostScript -;; Version: 1.8 +;; Version: 1.9 ;; This file is part of GNU Emacs. @@ -206,17 +206,7 @@ term (cdr term)) (setq seq (cons term seq))) (cons token - (cond - ;; null sequence - ((null seq) - (ebnf-make-empty)) - ;; sequence with only one element - ((= (length seq) 1) - (car seq)) - ;; a real sequence - (t - (ebnf-make-sequence (nreverse seq))) - )))) + (ebnf-token-sequence seq)))) ;;; exception = repeat [ "-" repeat]. diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/ebnf-dtd.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/ebnf-dtd.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,1349 @@ +;;; ebnf-dtd.el --- parser for DTD (Data Type Description for XML) + +;; Copyright (C) 2004 Free Sofware Foundation, Inc. + +;; Author: Vinicius Jose Latorre +;; Maintainer: Vinicius Jose Latorre +;; Time-stamp: <2004/04/04 21:50:16 vinicius> +;; Keywords: wp, ebnf, PostScript +;; Version: 1.0 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; +;; This is part of ebnf2ps package. +;; +;; This package defines a parser for DTD (Data Type Description for XML). +;; +;; See ebnf2ps.el for documentation. +;; +;; +;; DTD Syntax +;; ---------- +;; +;; See the URLs: +;; `http://www.w3.org/TR/2004/REC-xml-20040204/' +;; (Extensible Markup Language (XML) 1.0 (Third Edition)) +;; `http://www.w3.org/TR/html40/' +;; (HTML 4.01 Specification) +;; `http://www.w3.org/TR/NOTE-html-970421' +;; (HTML DTD with support for Style Sheets) +;; +;; +;; /* Document */ +;; +;; document ::= prolog element Misc* +;; /* Note that *only* the prolog will be parsed */ +;; +;; +;; /* Characters */ +;; +;; Char ::= #x9 | #xA | #xD +;; | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] +;; /* any Unicode character, excluding the surrogate blocks, FFFE, and FFFF. */ +;; +;; /* NOTE: +;; +;; Document authors are encouraged to avoid "compatibility characters", as +;; defined in section 6.8 of [Unicode] (see also D21 in section 3.6 of +;; [Unicode3]). The characters defined in the following ranges are also +;; discouraged. They are either control characters or permanently undefined +;; Unicode characters: +;; +;; [#x7F-#x84], [#x86-#x9F], [#xFDD0-#xFDDF], +;; [#1FFFE-#x1FFFF], [#2FFFE-#x2FFFF], [#3FFFE-#x3FFFF], +;; [#4FFFE-#x4FFFF], [#5FFFE-#x5FFFF], [#6FFFE-#x6FFFF], +;; [#7FFFE-#x7FFFF], [#8FFFE-#x8FFFF], [#9FFFE-#x9FFFF], +;; [#AFFFE-#xAFFFF], [#BFFFE-#xBFFFF], [#CFFFE-#xCFFFF], +;; [#DFFFE-#xDFFFF], [#EFFFE-#xEFFFF], [#FFFFE-#xFFFFF], +;; [#10FFFE-#x10FFFF]. */ +;; +;; +;; /* White Space */ +;; +;; S ::= (#x20 | #x9 | #xD | #xA)+ +;; +;; +;; /* Names and Tokens */ +;; +;; NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' +;; | CombiningChar | Extender +;; +;; Name ::= (Letter | '_' | ':') (NameChar)* +;; +;; Names ::= Name (#x20 Name)* +;; +;; Nmtoken ::= (NameChar)+ +;; +;; Nmtokens ::= Nmtoken (#x20 Nmtoken)* +;; +;; +;; /* Literals */ +;; +;; EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"' +;; | "'" ([^%&'] | PEReference | Reference)* "'" +;; +;; AttValue ::= '"' ([^<&"] | Reference)* '"' +;; | "'" ([^<&'] | Reference)* "'" +;; +;; SystemLiteral ::= ('"' [^"]* '"') +;; | ("'" [^']* "'") +;; +;; PubidLiteral ::= '"' PubidChar* '"' +;; | "'" (PubidChar - "'")* "'" +;; +;; PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] | [-'()+,./:=?;!*#@$_%] +;; +;; /* NOTE: +;; +;; Although the EntityValue production allows the definition of a general +;; entity consisting of a single explicit < in the literal (e.g., ), it is strongly advised to avoid this practice since any +;; reference to that entity will cause a well-formedness error. */ +;; +;; +;; /* Character Data */ +;; +;; CharData ::= [^<&]* - ([^<&]* ']]>' [^<&]*) +;; +;; +;; /* Comments */ +;; +;; Comment ::= '' +;; +;; +;; /* Processing Instructions */ +;; +;; PI ::= '' Char*)))? '?>' +;; +;; PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) +;; +;; +;; /* CDATA Sections */ +;; +;; CDSect ::= CDStart CData CDEnd +;; +;; CDStart ::= '' Char*)) +;; +;; CDEnd ::= ']]>' +;; +;; +;; /* Prolog */ +;; +;; prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? +;; +;; XMLDecl ::= '' +;; +;; VersionInfo ::= S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"') +;; +;; Eq ::= S? '=' S? +;; +;; VersionNum ::= '1.0' +;; +;; Misc ::= Comment | PI | S +;; +;; +;; /* Document Type Definition */ +;; +;; doctypedecl ::= '' +;; [VC: Root Element Type] +;; [WFC: External Subset] +;; +;; DeclSep ::= PEReference | S +;; [WFC: PE Between Declarations] +;; +;; intSubset ::= (markupdecl | DeclSep)* +;; +;; markupdecl ::= elementdecl | AttlistDecl | EntityDecl +;; | NotationDecl | PI | Comment +;; [VC: Proper Declaration/PE Nesting] +;; [WFC: PEs in Internal Subset] +;; +;; +;; /* External Subset */ +;; +;; extSubset ::= TextDecl? extSubsetDecl +;; +;; extSubsetDecl ::= ( markupdecl | conditionalSect | DeclSep)* +;; +;; +;; /* Standalone Document Declaration */ +;; +;; SDDecl ::= S 'standalone' Eq +;; (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) +;; [VC: Standalone Document Declaration] +;; +;; +;; /* Element */ +;; +;; element ::= EmptyElemTag | STag content ETag +;; [WFC: Element Type Match] +;; [VC: Element Valid] +;; +;; +;; /* Start-tag */ +;; +;; STag ::= '<' Name (S Attribute)* S? '>' +;; [WFC: Unique Att Spec] +;; +;; Attribute ::= Name Eq AttValue +;; [VC: Attribute Value Type] +;; [WFC: No External Entity References] +;; [WFC: No < in Attribute Values] +;; +;; +;; /* End-tag */ +;; +;; ETag ::= '' +;; +;; +;; /* Content of Elements */ +;; +;; content ::= CharData? +;; ((element | Reference | CDSect | PI | Comment) CharData?)* +;; +;; +;; /* Tags for Empty Elements */ +;; +;; EmptyElemTag ::= '<' Name (S Attribute)* S? '/>' +;; [WFC: Unique Att Spec] +;; +;; +;; /* Element Type Declaration */ +;; +;; elementdecl ::= '' +;; [VC: Unique Element Type Declaration] +;; +;; contentspec ::= 'EMPTY' | 'ANY' | Mixed | children +;; +;; +;; /* Element-content Models */ +;; +;; children ::= (choice | seq) ('?' | '*' | '+')? +;; +;; cp ::= (Name | choice | seq) ('?' | '*' | '+')? +;; +;; choice ::= '(' S? cp ( S? '|' S? cp )+ S? ')' +;; [VC: Proper Group/PE Nesting] +;; +;; seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' +;; [VC: Proper Group/PE Nesting] +;; +;; +;; /* Mixed-content Declaration */ +;; +;; Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' +;; | '(' S? '#PCDATA' S? ')' +;; [VC: Proper Group/PE Nesting] +;; [VC: No Duplicate Types] +;; +;; +;; /* Attribute-list Declaration */ +;; +;; AttlistDecl ::= '' +;; +;; AttDef ::= S Name S AttType S DefaultDecl +;; +;; +;; /* Attribute Types */ +;; +;; AttType ::= StringType | TokenizedType | EnumeratedType +;; +;; StringType ::= 'CDATA' +;; +;; TokenizedType ::= 'ID' [VC: ID] +;; [VC: One ID per Element Type] +;; [VC: ID Attribute Default] +;; | 'IDREF' [VC: IDREF] +;; | 'IDREFS' [VC: IDREF] +;; | 'ENTITY' [VC: Entity Name] +;; | 'ENTITIES' [VC: Entity Name] +;; | 'NMTOKEN' [VC: Name Token] +;; | 'NMTOKENS' [VC: Name Token] +;; +;; +;; /* Enumerated Attribute Types */ +;; +;; EnumeratedType ::= NotationType | Enumeration +;; +;; NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' +;; [VC: Notation Attributes] +;; [VC: One Notation Per Element Type] +;; [VC: No Notation on Empty Element] +;; [VC: No Duplicate Tokens] +;; +;; Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' +;; [VC: Enumeration] +;; [VC: No Duplicate Tokens] +;; +;; +;; /* Attribute Defaults */ +;; +;; DefaultDecl ::= '#REQUIRED' | '#IMPLIED' +;; | (('#FIXED' S)? AttValue) +;; [VC: Required Attribute] +;; [VC: Attribute Default Value Syntactically Correct] +;; [WFC: No < in Attribute Values] +;; [VC: Fixed Attribute Default] +;; +;; +;; /* Conditional Section */ +;; +;; conditionalSect ::= includeSect | ignoreSect +;; +;; includeSect ::= '' +;; [VC: Proper Conditional Section/PE Nesting] +;; +;; ignoreSect ::= '' +;; [VC: Proper Conditional Section/PE Nesting] +;; +;; ignoreSectContents ::= Ignore ('' Ignore)* +;; +;; Ignore ::= Char* - (Char* ('') Char*) +;; +;; +;; /* Character Reference */ +;; +;; CharRef ::= '&#' [0-9]+ ';' +;; | '&#x' [0-9a-fA-F]+ ';' +;; [WFC: Legal Character] +;; +;; +;; /* Entity Reference */ +;; +;; Reference ::= EntityRef | CharRef +;; +;; EntityRef ::= '&' Name ';' +;; [WFC: Entity Declared] +;; [VC: Entity Declared] +;; [WFC: Parsed Entity] +;; [WFC: No Recursion] +;; +;; PEReference ::= '%' Name ';' +;; [VC: Entity Declared] +;; [WFC: No Recursion] +;; [WFC: In DTD] +;; +;; +;; /* Entity Declaration */ +;; +;; EntityDecl ::= GEDecl | PEDecl +;; +;; GEDecl ::= '' +;; +;; PEDecl ::= '' +;; +;; EntityDef ::= EntityValue | (ExternalID NDataDecl?) +;; +;; PEDef ::= EntityValue | ExternalID +;; +;; +;; /* External Entity Declaration */ +;; +;; ExternalID ::= 'SYSTEM' S SystemLiteral +;; | 'PUBLIC' S PubidLiteral S SystemLiteral +;; +;; NDataDecl ::= S 'NDATA' S Name +;; [VC: Notation Declared] +;; +;; +;; /* Text Declaration */ +;; +;; TextDecl ::= '' +;; +;; +;; /* Well-Formed External Parsed Entity */ +;; +;; extParsedEnt ::= TextDecl? content +;; +;; +;; /* Encoding Declaration */ +;; +;; EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" ) +;; +;; EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')* +;; /* Encoding name contains only Latin characters */ +;; +;; +;; /* Notation Declarations */ +;; +;; NotationDecl ::= '' +;; [VC: Unique Notation Name] +;; +;; PublicID ::= 'PUBLIC' S PubidLiteral +;; +;; +;; /* Characters */ +;; +;; Letter ::= BaseChar | Ideographic +;; +;; BaseChar ::= [#x0041-#x005A] | [#x0061-#x007A] | [#x00C0-#x00D6] +;; | [#x00D8-#x00F6] | [#x00F8-#x00FF] | [#x0100-#x0131] +;; | [#x0134-#x013E] | [#x0141-#x0148] | [#x014A-#x017E] +;; | [#x0180-#x01C3] | [#x01CD-#x01F0] | [#x01F4-#x01F5] +;; | [#x01FA-#x0217] | [#x0250-#x02A8] | [#x02BB-#x02C1] +;; | #x0386 | [#x0388-#x038A] | #x038C +;; | [#x038E-#x03A1] | [#x03A3-#x03CE] | [#x03D0-#x03D6] +;; | #x03DA | #x03DC | #x03DE +;; | #x03E0 | [#x03E2-#x03F3] | [#x0401-#x040C] +;; | [#x040E-#x044F] | [#x0451-#x045C] | [#x045E-#x0481] +;; | [#x0490-#x04C4] | [#x04C7-#x04C8] | [#x04CB-#x04CC] +;; | [#x04D0-#x04EB] | [#x04EE-#x04F5] | [#x04F8-#x04F9] +;; | [#x0531-#x0556] | #x0559 | [#x0561-#x0586] +;; | [#x05D0-#x05EA] | [#x05F0-#x05F2] | [#x0621-#x063A] +;; | [#x0641-#x064A] | [#x0671-#x06B7] | [#x06BA-#x06BE] +;; | [#x06C0-#x06CE] | [#x06D0-#x06D3] | #x06D5 +;; | [#x06E5-#x06E6] | [#x0905-#x0939] | #x093D +;; | [#x0958-#x0961] | [#x0985-#x098C] | [#x098F-#x0990] +;; | [#x0993-#x09A8] | [#x09AA-#x09B0] | #x09B2 +;; | [#x09B6-#x09B9] | [#x09DC-#x09DD] | [#x09DF-#x09E1] +;; | [#x09F0-#x09F1] | [#x0A05-#x0A0A] | [#x0A0F-#x0A10] +;; | [#x0A13-#x0A28] | [#x0A2A-#x0A30] | [#x0A32-#x0A33] +;; | [#x0A35-#x0A36] | [#x0A38-#x0A39] | [#x0A59-#x0A5C] +;; | #x0A5E | [#x0A72-#x0A74] | [#x0A85-#x0A8B] +;; | #x0A8D | [#x0A8F-#x0A91] | [#x0A93-#x0AA8] +;; | [#x0AAA-#x0AB0] | [#x0AB2-#x0AB3] | [#x0AB5-#x0AB9] +;; | #x0ABD | #x0AE0 | [#x0B05-#x0B0C] +;; | [#x0B0F-#x0B10] | [#x0B13-#x0B28] | [#x0B2A-#x0B30] +;; | [#x0B32-#x0B33] | [#x0B36-#x0B39] | #x0B3D +;; | [#x0B5C-#x0B5D] | [#x0B5F-#x0B61] | [#x0B85-#x0B8A] +;; | [#x0B8E-#x0B90] | [#x0B92-#x0B95] | [#x0B99-#x0B9A] +;; | #x0B9C | [#x0B9E-#x0B9F] | [#x0BA3-#x0BA4] +;; | [#x0BA8-#x0BAA] | [#x0BAE-#x0BB5] | [#x0BB7-#x0BB9] +;; | [#x0C05-#x0C0C] | [#x0C0E-#x0C10] | [#x0C12-#x0C28] +;; | [#x0C2A-#x0C33] | [#x0C35-#x0C39] | [#x0C60-#x0C61] +;; | [#x0C85-#x0C8C] | [#x0C8E-#x0C90] | [#x0C92-#x0CA8] +;; | [#x0CAA-#x0CB3] | [#x0CB5-#x0CB9] | #x0CDE +;; | [#x0CE0-#x0CE1] | [#x0D05-#x0D0C] | [#x0D0E-#x0D10] +;; | [#x0D12-#x0D28] | [#x0D2A-#x0D39] | [#x0D60-#x0D61] +;; | [#x0E01-#x0E2E] | #x0E30 | [#x0E32-#x0E33] +;; | [#x0E40-#x0E45] | [#x0E81-#x0E82] | #x0E84 +;; | [#x0E87-#x0E88] | #x0E8A | #x0E8D +;; | [#x0E94-#x0E97] | [#x0E99-#x0E9F] | [#x0EA1-#x0EA3] +;; | #x0EA5 | #x0EA7 | [#x0EAA-#x0EAB] +;; | [#x0EAD-#x0EAE] | #x0EB0 | [#x0EB2-#x0EB3] +;; | #x0EBD | [#x0EC0-#x0EC4] | [#x0F40-#x0F47] +;; | [#x0F49-#x0F69] | [#x10A0-#x10C5] | [#x10D0-#x10F6] +;; | #x1100 | [#x1102-#x1103] | [#x1105-#x1107] +;; | #x1109 | [#x110B-#x110C] | [#x110E-#x1112] +;; | #x113C | #x113E | #x1140 +;; | #x114C | #x114E | #x1150 +;; | [#x1154-#x1155] | #x1159 | [#x115F-#x1161] +;; | #x1163 | #x1165 | #x1167 +;; | #x1169 | [#x116D-#x116E] | [#x1172-#x1173] +;; | #x1175 | #x119E | #x11A8 +;; | #x11AB | [#x11AE-#x11AF] | [#x11B7-#x11B8] +;; | #x11BA | [#x11BC-#x11C2] | #x11EB +;; | #x11F0 | #x11F9 | [#x1E00-#x1E9B] +;; | [#x1EA0-#x1EF9] | [#x1F00-#x1F15] | [#x1F18-#x1F1D] +;; | [#x1F20-#x1F45] | [#x1F48-#x1F4D] | [#x1F50-#x1F57] +;; | #x1F59 | #x1F5B | #x1F5D +;; | [#x1F5F-#x1F7D] | [#x1F80-#x1FB4] | [#x1FB6-#x1FBC] +;; | #x1FBE | [#x1FC2-#x1FC4] | [#x1FC6-#x1FCC] +;; | [#x1FD0-#x1FD3] | [#x1FD6-#x1FDB] | [#x1FE0-#x1FEC] +;; | [#x1FF2-#x1FF4] | [#x1FF6-#x1FFC] | #x2126 +;; | [#x212A-#x212B] | #x212E | [#x2180-#x2182] +;; | [#x3041-#x3094] | [#x30A1-#x30FA] | [#x3105-#x312C] +;; | [#xAC00-#xD7A3] +;; +;; Ideographic ::= [#x4E00-#x9FA5] | #x3007 | [#x3021-#x3029] +;; +;; CombiningChar ::= [#x0300-#x0345] | [#x0360-#x0361] | [#x0483-#x0486] +;; | [#x0591-#x05A1] | [#x05A3-#x05B9] | [#x05BB-#x05BD] +;; | #x05BF | [#x05C1-#x05C2] | #x05C4 +;; | [#x064B-#x0652] | #x0670 | [#x06D6-#x06DC] +;; | [#x06DD-#x06DF] | [#x06E0-#x06E4] | [#x06E7-#x06E8] +;; | [#x06EA-#x06ED] | [#x0901-#x0903] | #x093C +;; | [#x093E-#x094C] | #x094D | [#x0951-#x0954] +;; | [#x0962-#x0963] | [#x0981-#x0983] | #x09BC +;; | #x09BE | #x09BF | [#x09C0-#x09C4] +;; | [#x09C7-#x09C8] | [#x09CB-#x09CD] | #x09D7 +;; | [#x09E2-#x09E3] | #x0A02 | #x0A3C +;; | #x0A3E | #x0A3F | [#x0A40-#x0A42] +;; | [#x0A47-#x0A48] | [#x0A4B-#x0A4D] | [#x0A70-#x0A71] +;; | [#x0A81-#x0A83] | #x0ABC | [#x0ABE-#x0AC5] +;; | [#x0AC7-#x0AC9] | [#x0ACB-#x0ACD] | [#x0B01-#x0B03] +;; | #x0B3C | [#x0B3E-#x0B43] | [#x0B47-#x0B48] +;; | [#x0B4B-#x0B4D] | [#x0B56-#x0B57] | [#x0B82-#x0B83] +;; | [#x0BBE-#x0BC2] | [#x0BC6-#x0BC8] | [#x0BCA-#x0BCD] +;; | #x0BD7 | [#x0C01-#x0C03] | [#x0C3E-#x0C44] +;; | [#x0C46-#x0C48] | [#x0C4A-#x0C4D] | [#x0C55-#x0C56] +;; | [#x0C82-#x0C83] | [#x0CBE-#x0CC4] | [#x0CC6-#x0CC8] +;; | [#x0CCA-#x0CCD] | [#x0CD5-#x0CD6] | [#x0D02-#x0D03] +;; | [#x0D3E-#x0D43] | [#x0D46-#x0D48] | [#x0D4A-#x0D4D] +;; | #x0D57 | #x0E31 | [#x0E34-#x0E3A] +;; | [#x0E47-#x0E4E] | #x0EB1 | [#x0EB4-#x0EB9] +;; | [#x0EBB-#x0EBC] | [#x0EC8-#x0ECD] | [#x0F18-#x0F19] +;; | #x0F35 | #x0F37 | #x0F39 +;; | #x0F3E | #x0F3F | [#x0F71-#x0F84] +;; | [#x0F86-#x0F8B] | [#x0F90-#x0F95] | #x0F97 +;; | [#x0F99-#x0FAD] | [#x0FB1-#x0FB7] | #x0FB9 +;; | [#x20D0-#x20DC] | #x20E1 | [#x302A-#x302F] +;; | #x3099 | #x309A +;; +;; Digit ::= [#x0030-#x0039] | [#x0660-#x0669] | [#x06F0-#x06F9] +;; | [#x0966-#x096F] | [#x09E6-#x09EF] | [#x0A66-#x0A6F] +;; | [#x0AE6-#x0AEF] | [#x0B66-#x0B6F] | [#x0BE7-#x0BEF] +;; | [#x0C66-#x0C6F] | [#x0CE6-#x0CEF] | [#x0D66-#x0D6F] +;; | [#x0E50-#x0E59] | [#x0ED0-#x0ED9] | [#x0F20-#x0F29] +;; +;; Extender ::= #x00B7 | #x02D0 | #x02D1 | #x0387 | #x0640 | #x0E46 | #x0EC6 +;; | #x3005 | [#x3031-#x3035] | [#x309D-#x309E] | [#x30FC-#x30FE] +;; +;; +;; NOTES +;; ----- +;; +;; At moment, only the ` +;; +;; +;; +;; +;; +;; +;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Code: + + +(require 'ebnf-otz) + + +(defvar ebnf-dtd-lex nil + "Value returned by `ebnf-dtd-lex' function.") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Syntactic analyzer + + +;;; document ::= prolog element Misc* +;;; /* Note that *only* the prolog will be parsed */ + +(defun ebnf-dtd-parser (start) + "DTD parser." + (let ((total (+ (- ebnf-limit start) 1)) + (bias (1- start)) + (origin (point)) + rule-list token rule the-end) + (goto-char start) + (setq token (ebnf-dtd-lex)) + (and (eq token 'end-of-input) + (error "Empty DTD file")) + (setq token (ebnf-dtd-prolog token)) + (unless (eq (car token) 'end-prolog) + (setq the-end (cdr token) + token (car token)) + (while (not (eq token the-end)) + (ebnf-message-float + "Parsing...%s%%" + (/ (* (- (point) bias) 100.0) total)) + (setq token (ebnf-dtd-intsubset token) + rule (cdr token) + token (car token)) + (or (null rule) + (ebnf-add-empty-rule-list rule) + (setq rule-list (cons rule rule-list)))) + (or (eq the-end 'end-of-input) + (eq (ebnf-dtd-lex) 'end-decl) + (error "Missing end of DOCTYPE")) + ;; adjust message, 'cause *only* prolog will be parsed + (ebnf-message-float "Parsing...%s%%" 100.0)) + (goto-char origin) + rule-list)) + + +;;; prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? +;;; +;;; XMLDecl ::= '' +;;; +;;; VersionInfo ::= S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"') +;;; +;;; Eq ::= S? '=' S? +;;; +;;; VersionNum ::= '1.0' +;;; +;;; Misc ::= Comment | PI | S +;;; +;;; EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" ) +;;; +;;; EncName ::= [A-Za-z] ([-A-Za-z0-9._])* +;;; /* Encoding name contains only Latin characters */ +;;; +;;; SDDecl ::= S 'standalone' Eq +;;; (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) +;;; +;;; doctypedecl ::= '' + + +(defun ebnf-dtd-prolog (token) + (when (and (eq token 'begin-pi) (string= ebnf-dtd-lex "xml")) + ;; version = "1.0" + (setq token (ebnf-dtd-attribute (ebnf-dtd-lex) 'version-attr + "^1\\.0$" "XML version")) + ;; ( encoding = "encoding name" )? + (setq token (ebnf-dtd-attribute-optional + token 'encoding-attr + "^[A-Za-z][-A-Za-z0-9._]*$" "XML encoding")) + ;; ( standalone = ( "yes" | "no" ) )? + (setq token (ebnf-dtd-attribute-optional + token 'standalone-attr + "^yes|no$" "XML standalone")) + (or (eq token 'end-pi) + (error "Missing end of XML processing instruction"))) + ;; processing instructions + (setq token (ebnf-dtd-pi (ebnf-dtd-lex))) + (cond + ;; DOCTYPE + ((eq token 'doctype-decl) + (or (eq (ebnf-dtd-lex) 'name) + (error "Document type name is missing")) + (cons (if (eq (ebnf-dtd-externalid) 'begin-subset) + (ebnf-dtd-lex) + 'end-prolog) + 'end-subset)) + ((memq token '(element-decl attlist-decl entity-decl notation-decl)) + (cons token 'end-of-input)) + (t + '(end-prolog . end-subset)) + )) + + +(defun ebnf-dtd-attribute (token attr match attr-name) + (or (eq token attr) + (error "%s attribute is missing" attr-name)) + (ebnf-dtd-attribute-optional token attr match attr-name)) + + +(defun ebnf-dtd-attribute-optional (token attr match attr-name) + (when (eq token attr) + (or (and (eq (ebnf-dtd-lex) 'equal) + (eq (ebnf-dtd-lex) 'string) + (string-match match ebnf-dtd-lex)) + (error "XML %s attribute is invalid" attr-name)) + (setq token (ebnf-dtd-lex))) + token) + + +;;; ExternalID ::= 'SYSTEM' S SystemLiteral +;;; | 'PUBLIC' S PubidLiteral S SystemLiteral + + +(defun ebnf-dtd-externalid (&optional token) + (let ((must-have token)) + (or token (setq token (ebnf-dtd-lex))) + (cond ((eq token 'system) + (ebnf-dtd-systemliteral)) + ((eq token 'public) + (ebnf-dtd-pubidliteral) + (ebnf-dtd-systemliteral)) + (must-have + (error "Missing `SYSTEM' or `PUBLIC' in external id")) + (t + token)))) + + +;;; SystemLiteral ::= ('"' [^"]* '"') +;;; | ("'" [^']* "'") + + +(defun ebnf-dtd-systemliteral () + (or (eq (ebnf-dtd-lex) 'string) + (error "System identifier is invalid")) + (ebnf-dtd-lex)) + + +;;; PubidLiteral ::= '"' PubidChar* '"' +;;; | "'" (PubidChar - "'")* "'" +;;; +;;; PubidChar ::= [-'()+,./:=?;!*#@$_%\n\r a-zA-Z0-9] + + +(defun ebnf-dtd-pubidliteral () + (or (and (eq (ebnf-dtd-lex) 'string) + (string-match "^[-'()+,./:=?;!*#@$_%\n\r a-zA-Z0-9]*$" + ebnf-dtd-lex)) + (error "Public identifier is invalid"))) + + +;;; PI ::= '' Char*)))? '?>' +;;; +;;; PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) + + +(defun ebnf-dtd-pi (token) + (while (eq token 'begin-pi) + (and (string-match "^[xX][mM][lL]$" ebnf-dtd-lex) + (error "Processing instruction name can not be `XML'")) + (while (not (eq (ebnf-dtd-lex) 'end-pi))) + (setq token (ebnf-dtd-lex))) + token) + + +;;; doctypedecl ::= '' +;;; +;;; intSubset ::= (markupdecl | DeclSep)* +;;; +;;; DeclSep ::= PEReference | S +;;; +;;; markupdecl ::= elementdecl | AttlistDecl | EntityDecl +;;; | NotationDecl | PI | Comment + + +(defun ebnf-dtd-intsubset (token) + ;; PI - Processing Instruction + (and (eq token 'begin-pi) + (setq token (ebnf-dtd-pi token))) + (cond + ((memq token '(end-subset end-of-input)) + (cons token nil)) + ((eq token 'pe-ref) + (cons (ebnf-dtd-lex) nil)) ; annotation + ((eq token 'element-decl) + (ebnf-dtd-elementdecl)) ; rule + ((eq token 'attlist-decl) + (ebnf-dtd-attlistdecl)) ; annotation + ((eq token 'entity-decl) + (ebnf-dtd-entitydecl)) ; annotation + ((eq token 'notation-decl) + (ebnf-dtd-notationdecl)) ; annotation + (t + (error "Invalid DOCTYPE element")) + )) + + +;;; elementdecl ::= '' +;;; +;;; contentspec ::= 'EMPTY' | 'ANY' | Mixed | children +;;; +;;; Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' +;;; | '(' S? '#PCDATA' S? ')' +;;; +;;; children ::= (choice | seq) ('?' | '*' | '+')? +;;; +;;; choice ::= '(' S? cp ( S? '|' S? cp )+ S? ')' +;;; +;;; seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' +;;; +;;; cp ::= (Name | choice | seq) ('?' | '*' | '+')? + + +(defun ebnf-dtd-elementdecl () + (let ((action ebnf-action) + name token body) + (setq ebnf-action nil) + (or (eq (ebnf-dtd-lex) 'name) + (error "Invalid ELEMENT name")) + (setq name ebnf-dtd-lex + token (ebnf-dtd-lex) + body (cond ((memq token '(empty any)) + (let ((term (ebnf-make-terminal ebnf-dtd-lex))) + (cons (ebnf-dtd-lex) term))) + ((eq token 'begin-group) + (setq token (ebnf-dtd-lex)) + (if (eq token 'pcdata) + (ebnf-dtd-mixed) + (ebnf-dtd-children token))) + (t + (error "Invalid ELEMENT content")) + )) + (or (eq (car body) 'end-decl) + (error "Missing `>' in ELEMENT declaration")) + (ebnf-eps-add-production name) + (cons (ebnf-dtd-lex) + (ebnf-make-production name (cdr body) action)))) + + +;;; Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' +;;; | '(' S? '#PCDATA' S? ')' + + +(defun ebnf-dtd-mixed () + (let* ((alt (cons (ebnf-make-terminal ebnf-dtd-lex) nil)) + (token (ebnf-dtd-lex)) + (has-alternative (eq token 'alternative))) + (while (eq token 'alternative) + (or (eq (ebnf-dtd-lex) 'name) + (error "Invalid name")) + (setq alt (cons ebnf-dtd-lex alt) + token (ebnf-dtd-lex))) + (or (eq token 'end-group) + (error "Missing `)'")) + (and has-alternative + (or (eq (ebnf-dtd-lex) 'zero-or-more) + (error "Missing `*'"))) + (ebnf-token-alternative alt (cons (ebnf-dtd-lex) nil)))) + + +;;; children ::= (choice | seq) ('?' | '*' | '+')? + + +(defun ebnf-dtd-children (token) + (ebnf-dtd-operators (ebnf-dtd-choice-seq token))) + + +;;; choice ::= '(' S? cp ( S? '|' S? cp )+ S? ')' +;;; +;;; seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' + + +(defun ebnf-dtd-choice-seq (token) + (setq token (ebnf-dtd-cp token)) + (let (elist) + (cond + ;; choice + ((eq (car token) 'alternative) + (while (eq (car token) 'alternative) + (setq elist (cons (cdr token) elist) + token (ebnf-dtd-cp (ebnf-dtd-lex)))) + (setq elist (ebnf-token-alternative elist token))) + ;; seq + ((eq (car token) 'comma) + (while (eq (car token) 'comma) + (setq elist (cons (cdr token) elist) + token (ebnf-dtd-cp (ebnf-dtd-lex)))) + (setq elist (ebnf-token-sequence (cons (cdr token) elist)))) + ;; only one element + (t + (setq elist (cdr token)))) + (or (eq (car token) 'end-group) + (error "Missing `)' in ELEMENT content")) + elist)) + + +;;; cp ::= (Name | choice | seq) ('?' | '*' | '+')? + + +(defun ebnf-dtd-cp (token) + (ebnf-dtd-operators (cond ((eq token 'name) + (ebnf-make-terminal ebnf-dtd-lex)) + ((eq token 'begin-group) + (ebnf-dtd-choice-seq (ebnf-dtd-lex))) + (t + (error "Invalid element")) + ))) + + +;;; elm ('?' | '*' | '+')? + + +(defun ebnf-dtd-operators (elm) + (let ((token (ebnf-dtd-lex))) + (cond ((eq token 'optional) ; ? - optional + (cons (ebnf-dtd-lex) (ebnf-token-optional elm))) + ((eq token 'zero-or-more) ; * - zero or more + (cons (ebnf-dtd-lex) (ebnf-make-zero-or-more elm))) + ((eq token 'one-or-more) ; + - one or more + (cons (ebnf-dtd-lex) (ebnf-make-one-or-more elm))) + (t ; only element + (cons token elm)) + ))) + + +;;; AttlistDecl ::= '' +;;; +;;; AttDef ::= S Name S AttType S DefaultDecl +;;; +;;; AttType ::= StringType | TokenizedType | EnumeratedType +;;; +;;; StringType ::= 'CDATA' +;;; +;;; TokenizedType ::= 'ID' +;;; | 'IDREF' +;;; | 'IDREFS' +;;; | 'ENTITY' +;;; | 'ENTITIES' +;;; | 'NMTOKEN' +;;; | 'NMTOKENS' +;;; +;;; EnumeratedType ::= NotationType | Enumeration +;;; +;;; NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' +;;; +;;; Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' +;;; +;;; DefaultDecl ::= '#REQUIRED' +;;; | '#IMPLIED' +;;; | (('#FIXED' S)? AttValue) +;;; +;;; +;;; AttValue ::= '"' ([^<&"] | Reference)* '"' +;;; | "'" ([^<&'] | Reference)* "'" +;;; +;;; Reference ::= EntityRef | CharRef +;;; +;;; EntityRef ::= '&' Name ';' +;;; +;;; CharRef ::= '&#' [0-9]+ ';' +;;; | '&#x' [0-9a-fA-F]+ ';' + +;;; "^\\(&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^<&]\\)*$" + + +(defun ebnf-dtd-attlistdecl () + (or (eq (ebnf-dtd-lex) 'name) + (error "Invalid ATTLIST name")) + (let (token) + (while (eq (setq token (ebnf-dtd-lex)) 'name) + ;; type + (setq token (ebnf-dtd-lex)) + (cond + ((eq token 'notation) + (or (eq (ebnf-dtd-lex) 'begin-group) + (error "Missing `(' in NOTATION type in ATTLIST declaration")) + (ebnf-dtd-namelist "NOTATION" '(name))) + ((eq token 'begin-group) + (ebnf-dtd-namelist "enumeration" '(name name-char))) + ((memq token + '(cdata id idref idrefs entity entities nmtoken nmtokens))) + (t + (error "Invalid type in ATTLIST declaration"))) + ;; default value + (setq token (ebnf-dtd-lex)) + (unless (memq token '(required implied)) + (and (eq token 'fixed) + (setq token (ebnf-dtd-lex))) + (or (and (eq token 'string) + (string-match + "^\\(&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^<&]\\)*$" + ebnf-dtd-lex)) + (error "Invalid default value in ATTLIST declaration")))) + (or (eq token 'end-decl) + (error "Missing `>' in end of ATTLIST")) + (cons (ebnf-dtd-lex) nil))) + + +(defun ebnf-dtd-namelist (type name-list) + (let (token) + (while (progn + (or (memq (ebnf-dtd-lex) name-list) + (error "Invalid name in %s type in ATTLIST declaration" type)) + (eq (setq token (ebnf-dtd-lex)) 'alternative))) + (or (eq token 'end-group) + (error "Missing `)' in %s type in ATTLIST declaration" type)))) + + +;;; EntityDecl ::= GEDecl | PEDecl +;;; +;;; GEDecl ::= '' +;;; +;;; PEDecl ::= '' +;;; +;;; EntityDef ::= EntityValue | (ExternalID NDataDecl?) +;;; +;;; PEDef ::= EntityValue | ExternalID +;;; +;;; NDataDecl ::= S 'NDATA' S Name +;;; +;;; +;;; EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"' +;;; | "'" ([^%&'] | PEReference | Reference)* "'" +;;; +;;; PEReference ::= '%' Name ';' +;;; +;;; Reference ::= EntityRef | CharRef +;;; +;;; EntityRef ::= '&' Name ';' +;;; +;;; CharRef ::= '&#' [0-9]+ ';' +;;; | '&#x' [0-9a-fA-F]+ ';' + +;;; "^\\(%[A-Za-z_:][-A-Za-z0-9._:]*;\\|&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^%&]\\)*$" + + +(defun ebnf-dtd-entitydecl () + (let* ((token (ebnf-dtd-lex)) + (pedecl (eq token 'percent))) + (and pedecl + (setq token (ebnf-dtd-lex))) + (or (eq token 'name) + (error "Invalid name of ENTITY")) + (setq token (ebnf-dtd-lex)) + (if (eq token 'string) + (if (string-match + "^\\(%[A-Za-z_:][-A-Za-z0-9._:]*;\\|&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^%&]\\)*$" + ebnf-dtd-lex) + (setq token (ebnf-dtd-lex)) + (error "Invalid ENTITY definition")) + (setq token (ebnf-dtd-externalid token)) + (when (and (not pedecl) (eq token 'ndata)) + (or (eq (ebnf-dtd-lex) 'name) + (error "Invalid NDATA name")) + (setq token (ebnf-dtd-lex)))) + (or (eq token 'end-decl) + (error "Missing `>' in end of ENTITY")) + (cons (ebnf-dtd-lex) nil))) + + +;;; NotationDecl ::= '' +;;; +;;; PublicID ::= 'PUBLIC' S PubidLiteral + + +(defun ebnf-dtd-notationdecl () + (or (eq (ebnf-dtd-lex) 'name) + (error "Invalid name NOTATION")) + (or (eq (ebnf-dtd-externalid-or-publicid) 'end-decl) + (error "Missing `>' in end of NOTATION")) + (cons (ebnf-dtd-lex) nil)) + + +;;; ExternalID ::= 'SYSTEM' S SystemLiteral +;;; | 'PUBLIC' S PubidLiteral S SystemLiteral +;;; +;;; PublicID ::= 'PUBLIC' S PubidLiteral + + +(defun ebnf-dtd-externalid-or-publicid () + (let ((token (ebnf-dtd-lex))) + (cond ((eq token 'system) + (ebnf-dtd-systemliteral)) + ((eq token 'public) + (ebnf-dtd-pubidliteral) + (and (eq (setq token (ebnf-dtd-lex)) 'string) + (setq token (ebnf-dtd-lex))) + token) + (t + (error "Missing `SYSTEM' or `PUBLIC'"))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Lexical analyzer + + +(defconst ebnf-dtd-token-table (make-vector 256 'error) + "Vector used to map characters to a lexical token.") + + +(defun ebnf-dtd-initialize () + "Initialize EBNF token table." + ;; control character & control 8-bit character are set to `error' + (let ((char ?\060)) + ;; digits: 0-9 + (while (< char ?\072) + (aset ebnf-dtd-token-table char 'name-char) + (setq char (1+ char))) + ;; printable character: A-Z + (setq char ?\101) + (while (< char ?\133) + (aset ebnf-dtd-token-table char 'name) + (setq char (1+ char))) + ;; printable character: a-z + (setq char ?\141) + (while (< char ?\173) + (aset ebnf-dtd-token-table char 'name) + (setq char (1+ char))) + ;; European 8-bit accentuated characters: + (setq char ?\240) + (while (< char ?\400) + (aset ebnf-dtd-token-table char 'name) + (setq char (1+ char))) + ;; Override name characters: + (aset ebnf-dtd-token-table ?_ 'name) + (aset ebnf-dtd-token-table ?: 'name) + (aset ebnf-dtd-token-table ?. 'name-char) + (aset ebnf-dtd-token-table ?- 'name-char) + ;; Override space characters: + (aset ebnf-dtd-token-table ?\n 'space) ; [NL] linefeed + (aset ebnf-dtd-token-table ?\r 'space) ; [CR] carriage return + (aset ebnf-dtd-token-table ?\t 'space) ; [HT] horizontal tab + (aset ebnf-dtd-token-table ?\ 'space) ; [SP] space + ;; Override other lexical characters: + (aset ebnf-dtd-token-table ?= 'equal) + (aset ebnf-dtd-token-table ?, 'comma) + (aset ebnf-dtd-token-table ?* 'zero-or-more) + (aset ebnf-dtd-token-table ?+ 'one-or-more) + (aset ebnf-dtd-token-table ?| 'alternative) + (aset ebnf-dtd-token-table ?% 'percent) + (aset ebnf-dtd-token-table ?& 'ampersand) + (aset ebnf-dtd-token-table ?# 'hash) + (aset ebnf-dtd-token-table ?\? 'interrogation) + (aset ebnf-dtd-token-table ?\" 'double-quote) + (aset ebnf-dtd-token-table ?\' 'single-quote) + (aset ebnf-dtd-token-table ?< 'less-than) + (aset ebnf-dtd-token-table ?> 'end-decl) + (aset ebnf-dtd-token-table ?\( 'begin-group) + (aset ebnf-dtd-token-table ?\) 'end-group) + (aset ebnf-dtd-token-table ?\[ 'begin-subset) + (aset ebnf-dtd-token-table ?\] 'end-subset))) + + +;; replace the range "\240-\377" (see `ebnf-range-regexp'). +(defconst ebnf-dtd-name-chars + (ebnf-range-regexp "-._:0-9A-Za-z" ?\240 ?\377)) + + +(defconst ebnf-dtd-decl-alist + '(("ATTLIST" . attlist-decl) + ("DOCTYPE" . doctype-decl) + ("ELEMENT" . element-decl) + ("ENTITY" . entity-decl) + ("NOTATION" . notation-decl))) + + +(defconst ebnf-dtd-element-alist + '(("#FIXED" . fixed) + ("#IMPLIED" . implied) + ("#PCDATA" . pcdata) + ("#REQUIRED" . required))) + + +(defconst ebnf-dtd-name-alist + '(("ANY" . any) + ("CDATA" . cdata) + ("EMPTY" . empty) + ("ENTITIES" . entities) + ("ENTITY" . entity) + ("ID" . id) + ("IDREF" . idref) + ("IDREFS" . idrefs) + ("NDATA" . ndata) + ("NMTOKEN" . nmtoken) + ("NMTOKENS" . nmtokens) + ("NOTATION" . notation) + ("PUBLIC" . public) + ("SYSTEM" . system) + ("encoding" . encoding-attr) + ("standalone" . standalone-attr) + ("version" . version-attr))) + + +(defun ebnf-dtd-lex () + "Lexical analyser for DTD. + +Return a lexical token. + +See documentation for variable `ebnf-dtd-lex'." + (if (>= (point) ebnf-limit) + 'end-of-input + (let (token) + ;; skip spaces and comments + (while (if (> (following-char) 255) + (progn + (setq token 'error) + nil) + (setq token (aref ebnf-dtd-token-table (following-char))) + (cond + ((eq token 'space) + (skip-chars-forward " \n\r\t" ebnf-limit) + (< (point) ebnf-limit)) + ((and (eq token 'less-than) + (looking-at "")))) + (skip-chars-forward "-" ebnf-limit)) + ;; check for a valid end of comment + (cond ((>= (point) ebnf-limit) + nil) + ((looking-at "-->") + (forward-char 3) + t) + (t + (error "Illegal character")) + )) + + +(defun ebnf-dtd-eps-filename () + (forward-char) + (let (fname) + (while (progn + (setq fname + (concat fname + (ebnf-buffer-substring ebnf-dtd-filename-chars))) + (and (< (point) ebnf-limit) + (= (following-char) ?-) ; may be \n, \t, \r + (not (looking-at "-->")))) + (setq fname (concat fname (ebnf-buffer-substring "-")))) + fname)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(provide 'ebnf-dtd) + +;;; arch-tag: c21bb640-135f-4afa-8712-fa11d86301c4 +;;; ebnf-dtd.el ends here diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/ebnf-ebx.el --- a/lisp/progmodes/ebnf-ebx.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/ebnf-ebx.el Thu Apr 08 12:29:09 2004 +0000 @@ -4,9 +4,9 @@ ;; Author: Vinicius Jose Latorre ;; Maintainer: Vinicius Jose Latorre -;; Time-stamp: <2004/03/22 08:53:21 vinicius> +;; Time-stamp: <2004/04/03 16:45:34 vinicius> ;; Keywords: wp, ebnf, PostScript -;; Version: 1.0 +;; Version: 1.1 ;; This file is part of GNU Emacs. @@ -282,11 +282,7 @@ term (cdr term)) (setq seq (cons term seq))) (cons token - (if (= (length seq) 1) - ;; sequence with only one element - (car seq) - ;; a real sequence - (ebnf-make-sequence (nreverse seq)))))) + (ebnf-token-sequence seq)))) ;;; exception ::= term ('-' term)? diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/ebnf-iso.el --- a/lisp/progmodes/ebnf-iso.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/ebnf-iso.el Thu Apr 08 12:29:09 2004 +0000 @@ -5,9 +5,9 @@ ;; Author: Vinicius Jose Latorre ;; Maintainer: Vinicius Jose Latorre -;; Time-stamp: <2004/02/29 18:31:33 vinicius> +;; Time-stamp: <2004/04/03 16:48:52 vinicius> ;; Keywords: wp, ebnf, PostScript -;; Version: 1.7 +;; Version: 1.8 ;; This file is part of GNU Emacs. @@ -203,17 +203,9 @@ (eq token 'catenate)) (setq seq (cons term seq))) (cons token - (cond - ;; null sequence - ((null seq) - term) - ;; sequence with only one element - ((and (null term) (= (length seq) 1)) - (car seq)) - ;; a real sequence - (t - (ebnf-make-sequence (nreverse (cons term seq)))) - )))) + (ebnf-token-sequence (if term + (cons term seq) + seq))))) ;;; term = factor, ['-', exception]; diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/ebnf-yac.el --- a/lisp/progmodes/ebnf-yac.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/ebnf-yac.el Thu Apr 08 12:29:09 2004 +0000 @@ -5,9 +5,9 @@ ;; Author: Vinicius Jose Latorre ;; Maintainer: Vinicius Jose Latorre -;; Time-stamp: <2004/02/29 20:23:29 vinicius> +;; Time-stamp: <2004/04/03 16:50:46 vinicius> ;; Keywords: wp, ebnf, PostScript -;; Version: 1.2.1 +;; Version: 1.3 ;; This file is part of GNU Emacs. @@ -218,20 +218,10 @@ factor (ebnf-yac-factor token)) (setq seq (cons factor seq))) (cons token - (cond - ;; ignore error recovery - ((and ebnf-yac-ignore-error-recovery ebnf-yac-error) - nil) - ;; null sequence - ((null seq) - (ebnf-make-empty)) - ;; sequence with only one element - ((= (length seq) 1) - (car seq)) - ;; a real sequence - (t - (ebnf-make-sequence (nreverse seq))) - )))) + (if (and ebnf-yac-ignore-error-recovery ebnf-yac-error) + ;; ignore error recovery + nil + (ebnf-token-sequence seq))))) ;;; Factor = Name diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/ebnf2ps.el --- a/lisp/progmodes/ebnf2ps.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/ebnf2ps.el Thu Apr 08 12:29:09 2004 +0000 @@ -5,9 +5,9 @@ ;; Author: Vinicius Jose Latorre ;; Maintainer: Vinicius Jose Latorre -;; Time-stamp: <2004/03/30 21:49:21 vinicius> +;; Time-stamp: <2004/04/04 21:40:30 vinicius> ;; Keywords: wp, ebnf, PostScript -;; Version: 4.1 +;; Version: 4.2 ;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/ ;; This file is part of GNU Emacs. @@ -27,8 +27,8 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -(defconst ebnf-version "4.1" - "ebnf2ps.el, v 4.1 <2004/03/18 vinicius> +(defconst ebnf-version "4.2" + "ebnf2ps.el, v 4.2 <2004/04/04 vinicius> Vinicius's last change version. When reporting bugs, please also report the version of Emacs, if any, that ebnf2ps was running with. @@ -177,9 +177,36 @@ ;; (global-set-key '(control f22) 'ebnf-despool) ;; ;; +;; Invoking Ebnf2ps in Batch +;; ------------------------- +;; +;; It's possible also to run ebnf2ps in batch, this is useful when, for +;; example, you have a directory with a lot of files containing the EBNF to be +;; translated to PostScript. +;; +;; To run ebnf2ps in batch type, for example: +;; +;; emacs -batch -l setup-ebnf2ps.el -f ebnf-eps-directory +;; +;; Where setup-ebnf2ps.el should be a file containing: +;; +;; ;; set load-path if ebnf2ps isn't installed in your Emacs environment +;; (setq load-path (append (list "/dir/of/ebnf2ps") load-path)) +;; (require 'ebnf2ps) +;; ;; insert here your ebnf2ps settings +;; (setq ebnf-terminal-shape 'bevel) +;; ;; etc. +;; +;; ;; EBNF Syntax ;; ----------- ;; +;; BNF (Backus Naur Form) notation is defined like languages, and like +;; languages there are rules about name formation and syntax. In this section +;; it's defined a BNF syntax that it's called simply EBNF (Extended BNF). +;; ebnf2ps package also deal with other BNF notation. Please, see the variable +;; `ebnf-syntax' documentation below in this section. +;; ;; The current EBNF that ebnf2ps accepts has the following constructions: ;; ;; ; comment (until end of line) @@ -324,6 +351,10 @@ ;; `http://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation' ;; ("Extensible Markup Language (XML) 1.0 (Third Edition)") ;; +;; `dtd' ebnf2ps recognizes the syntax described in the URL: +;; `http://www.w3.org/TR/2004/REC-xml-20040204/' +;; ("Extensible Markup Language (XML) 1.0 (Third Edition)") +;; ;; Any other value is treated as `ebnf'. ;; ;; The default value is `ebnf'. @@ -395,6 +426,8 @@ ;; ;; ebnf2ps accepts the following actions in comments: ;; +;; ;^ same as form feed. See section Form Feed above. +;; ;; ;> the next production starts in the same line as the current one. ;; It is useful when `ebnf-horizontal-orientation' is nil. ;; @@ -459,8 +492,8 @@ ;; Only the ;> will take effect, that is, A and B will be drawn in the same ;; line. ;; -;; In ISO EBNF the above actions are specified as (*>*), (*<*), (*[EPS*) and -;; (*]EPS*). The first example above should be written: +;; In ISO EBNF the above actions are specified as (*^*), (*>*), (*<*), (*[EPS*) +;; and (*]EPS*). The first example above should be written: ;; ;; A = t; ;; C = x; @@ -1687,10 +1720,14 @@ `http://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation' (\"Extensible Markup Language (XML) 1.0 (Third Edition)\") + `dtd' ebnf2ps recognizes the syntax described in the URL: + `http://www.w3.org/TR/2004/REC-xml-20040204/' + (\"Extensible Markup Language (XML) 1.0 (Third Edition)\") + Any other value is treated as `ebnf'." :type '(radio :tag "Syntax" (const ebnf) (const abnf) (const iso-ebnf) - (const yacc) (const ebnfx)) + (const yacc) (const ebnfx) (const dtd)) :group 'ebnf-syntactic) @@ -1885,6 +1922,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; To make this file smaller, some commands go in a separate file. +;; But autoload them here to make the separation invisible. +;; Autoload is here to avoid compilation gripes. + +(autoload 'ebnf-eliminate-empty-rules "ebnf-otz" + "Eliminate empty rules.") + +(autoload 'ebnf-optimize "ebnf-otz" + "Syntactic chart optimizer.") + +(autoload 'ebnf-otz-initialize "ebnf-otz" + "Initialize optimizer.") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization @@ -2406,6 +2458,10 @@ (ebnfx default (ebnf-syntax . 'ebnfx)) + ;; dtd default + (dtd + default + (ebnf-syntax . 'dtd)) ) "Style database. @@ -4664,7 +4720,8 @@ (yacc ebnf-yac-parser ebnf-yac-initialize) (abnf ebnf-abn-parser ebnf-abn-initialize) (ebnf ebnf-bnf-parser ebnf-bnf-initialize) - (ebnfx ebnf-ebx-parser ebnf-ebx-initialize)) + (ebnfx ebnf-ebx-parser ebnf-ebx-initialize) + (dtd ebnf-dtd-parser ebnf-dtd-initialize)) "Alist associating ebnf syntax with a parser and a initializer.") @@ -5661,6 +5718,20 @@ (cons seq body) body)))))))) + +(defun ebnf-token-sequence (sequence) + (cond + ;; null sequence + ((null sequence) + (ebnf-make-empty)) + ;; sequence with only one element + ((= (length sequence) 1) + (car sequence)) + ;; a real sequence + (t + (ebnf-make-sequence (nreverse sequence))) + )) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Variables used by parsers @@ -5671,6 +5742,7 @@ ;; Override special comment character: (aset table ?< 'newline) (aset table ?> 'keep-line) + (aset table ?^ 'form-feed) table) "Vector used to map characters to a special comment token.") @@ -5709,14 +5781,11 @@ (autoload 'ebnf-ebx-initialize "ebnf-ebx" "Initializations for EBNFX parser.") -(autoload 'ebnf-eliminate-empty-rules "ebnf-otz" - "Eliminate empty rules.") - -(autoload 'ebnf-optimize "ebnf-otz" - "Syntactic chart optimizer.") - -(autoload 'ebnf-otz-initialize "ebnf-otz" - "Initialize optimizer.") +(autoload 'ebnf-dtd-parser "ebnf-dtd" + "DTD parser.") + +(autoload 'ebnf-dtd-initialize "ebnf-dtd" + "Initializations for DTD parser.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff -r 7f60e040ccfc -r 1029206e72f2 lisp/progmodes/gdb-ui.el --- a/lisp/progmodes/gdb-ui.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/progmodes/gdb-ui.el Thu Apr 08 12:29:09 2004 +0000 @@ -28,10 +28,11 @@ ;; This mode acts as a graphical user interface to GDB. You can interact with ;; GDB through the GUD buffer in the usual way, but there are also further ;; buffers which control the execution and describe the state of your program. -;; It separates the input/output of your program from that of GDB and displays -;; expressions and their current values in their own buffers. It also uses -;; features of Emacs 21 such as the display margin for breakpoints, and the -;; toolbar (see the GDB Graphical Interface section in the Emacs info manual). +;; It separates the input/output of your program from that of GDB, if +;; required, and displays expressions and their current values in their own +;; buffers. It also uses features of Emacs 21 such as the display margin for +;; breakpoints, and the toolbar (see the GDB Graphical Interface section in +;; the Emacs info manual). ;; Start the debugger with M-x gdba. @@ -131,6 +132,11 @@ :type 'boolean :group 'gud) +(defcustom gdb-use-inferior-io-buffer nil + "Non-nil means display output from the inferior in a separate buffer." + :type 'boolean + :group 'gud) + (defun gdb-ann3 () (setq gdb-debug-log nil) (set (make-local-variable 'gud-minor-mode) 'gdba) @@ -181,7 +187,7 @@ (mapc 'make-local-variable gdb-variables) (setq gdb-buffer-type 'gdba) ;; - (gdb-clear-inferior-io) + (if gdb-use-inferior-io-buffer (gdb-clear-inferior-io)) ;; (if (eq window-system 'w32) (gdb-enqueue-input (list "set new-console off\n" 'ignore))) @@ -604,7 +610,9 @@ (defun gdb-send (proc string) "A comint send filter for gdb. This filter may simply queue output for a later time." - (gdb-enqueue-input (concat string "\n"))) + (if gud-running + (process-send-string proc (concat string "\n")) + (gdb-enqueue-input (concat string "\n")))) ;; Note: Stuff enqueued here will be sent to the next prompt, even if it ;; is a query, or other non-top-level prompt. @@ -742,17 +750,19 @@ ((eq sink 'user) (progn (setq gud-running t) - (gdb-set-output-sink 'inferior))) + (if gdb-use-inferior-io-buffer + (gdb-set-output-sink 'inferior)))) (t (error "Unexpected `starting' annotation"))))) (defun gdb-stopping (ignored) "An annotation handler for `exited' and other annotations which say that I/O for the subprocess is now GDB, not the program being debugged." - (let ((sink (gdb-get-output-sink))) - (cond - ((eq sink 'inferior) - (gdb-set-output-sink 'user)) - (t (error "Unexpected stopping annotation"))))) + (if gdb-use-inferior-io-buffer + (let ((sink (gdb-get-output-sink))) + (cond + ((eq sink 'inferior) + (gdb-set-output-sink 'user)) + (t (error "Unexpected stopping annotation")))))) (defun gdb-frame-begin (ignored) (let ((sink (gdb-get-output-sink))) @@ -1657,9 +1667,10 @@ (gud-find-file gdb-main-file)) (gdb-get-create-buffer 'gdb-assembler-buffer))) (setq gdb-source-window (get-buffer-window (current-buffer))) - (split-window-horizontally) - (other-window 1) - (switch-to-buffer (gdb-inferior-io-name)) + (when gdb-use-inferior-io-buffer + (split-window-horizontally) + (other-window 1) + (switch-to-buffer (gdb-inferior-io-name))) (other-window 1) (switch-to-buffer (gdb-stack-buffer-name)) (split-window-horizontally) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/term.el --- a/lisp/term.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/term.el Thu Apr 08 12:29:09 2004 +0000 @@ -658,14 +658,12 @@ (put 'term-scroll-show-maximum-output 'permanent-local t) (put 'term-ptyp 'permanent-local t) -;; True if running under XEmacs (previously Lucid Emacs). -(defmacro term-is-xemacs () '(string-match "Lucid" emacs-version)) ;; Do FORM if running under XEmacs (previously Lucid Emacs). (defmacro term-if-xemacs (&rest forms) - (if (term-is-xemacs) (cons 'progn forms))) + (if (featurep 'xemacs) (cons 'progn forms))) ;; Do FORM if NOT running under XEmacs (previously Lucid Emacs). (defmacro term-ifnot-xemacs (&rest forms) - (if (not (term-is-xemacs)) (cons 'progn forms))) + (if (not (featurep 'xemacs)) (cons 'progn forms))) (defmacro term-in-char-mode () '(eq (current-local-map) term-raw-map)) (defmacro term-in-line-mode () '(not (term-in-char-mode))) @@ -923,6 +921,14 @@ (define-key term-raw-map [next] 'term-send-next))) (term-set-escape-char ?\C-c) + +(defun term-window-width () + (if (featurep 'xemacs) + (1- (window-width)) + (if window-system + (window-width) + (1- (window-width))))) + (put 'term-mode 'mode-class 'special) @@ -980,8 +986,10 @@ (make-local-variable 'term-saved-home-marker) (make-local-variable 'term-height) (make-local-variable 'term-width) - (setq term-width (1- (window-width))) + (setq term-width (term-window-width)) (setq term-height (1- (window-height))) + (term-ifnot-xemacs + (set (make-local-variable 'overflow-newline-into-fringe) nil)) (make-local-variable 'term-terminal-parameter) (make-local-variable 'term-saved-cursor) (make-local-variable 'term-last-input-start) @@ -1116,9 +1124,9 @@ (defun term-check-size (process) (if (or (/= term-height (1- (window-height))) - (/= term-width (1- (window-width)))) + (/= term-width (term-window-width))) (progn - (term-reset-size (1- (window-height)) (1- (window-width))) + (term-reset-size (1- (window-height)) (term-window-width)) (set-process-window-size process term-height term-width)))) (defun term-send-raw-string (chars) diff -r 7f60e040ccfc -r 1029206e72f2 lisp/term/tty-colors.el --- a/lisp/term/tty-colors.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/term/tty-colors.el Thu Apr 08 12:29:09 2004 +0000 @@ -2,7 +2,7 @@ ;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc. -;; Author: Eli Zaretskii +;; Author: Eli Zaretskii ;; Maintainer: FSF ;; Keywords: terminals, faces diff -r 7f60e040ccfc -r 1029206e72f2 lisp/textmodes/fill.el --- a/lisp/textmodes/fill.el Sat Apr 03 20:24:17 2004 +0000 +++ b/lisp/textmodes/fill.el Thu Apr 08 12:29:09 2004 +0000 @@ -811,9 +811,13 @@ (save-excursion (goto-char comstart) (if has-code-and-comment - (concat (make-string (/ (current-column) tab-width) ?\t) - (make-string (% (current-column) tab-width) ?\ ) - (buffer-substring (point) comin)) + (concat + (if (not indent-tabs-mode) + (make-string (current-column) ?\ ) + (concat + (make-string (/ (current-column) tab-width) ?\t) + (make-string (% (current-column) tab-width) ?\ ))) + (buffer-substring (point) comin)) (buffer-substring (line-beginning-position) comin)))) beg end) (save-excursion diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/.cvsignore --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/.cvsignore Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,4 @@ +Makefile +auto-autoloads.el +custom-load.el +url-auto.el diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-about.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-about.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,102 @@ +;;; url-about.el --- Show internal URLs +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 2001 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(eval-when-compile + (require 'cl)) +(require 'url-util) +(require 'url-parse) + +(defun url-probe-protocols () + "Returns a list of all potential URL schemes." + (or (get 'url-extension-protocols 'probed) + (mapc (lambda (s) (url-scheme-get-property s 'name)) + (or (get 'url-extension-protocols 'schemes) + (let ((schemes '("info" "man" "rlogin" "telnet" + "tn3270" "data" "snews"))) + (mapc (lambda (d) + (mapc (lambda (f) + (if (string-match "url-\\(.*\\).el$" f) + (push (match-string 1 f) schemes))) + (directory-files d nil "^url-.*\\.el$"))) + load-path) + (put 'url-extension-protocols 'schemes schemes) + schemes))))) + +(defun url-about-protocols (url) + (url-probe-protocols) + (insert "\n" + " \n" + " Supported Protocols\n" + " \n" + " \n" + "

Supported Protocols - URL v" url-version "

\n" + " \n" + " \n" + " \n") + (mapc (lambda (k) + (if (string= k "proxy") + ;; Ignore the proxy setting... its magic! + nil + (insert " \n") + ;; The name of the protocol + (insert "
Protocol\n" + " Properties\n" + " Description\n" + "
" (or (url-scheme-get-property k 'name) k) "\n") + + ;; Now the properties. Currently just asynchronous + ;; status, default port number, and proxy status. + (insert " " + (if (url-scheme-get-property k 'asynchronous-p) "As" "S") + "ynchronous
\n" + (if (url-scheme-get-property k 'default-port) + (format "Default Port: %d
\n" + (url-scheme-get-property k 'default-port)) "") + (if (assoc k url-proxy-services) + (format "Proxy: %s
\n" (assoc k url-proxy-services)) "")) + ;; Now the description... + (insert " 		" + (or (url-scheme-get-property k 'description) "N/A")))) + (sort (let (x) (maphash (lambda (k v) (push k x)) url-scheme-registry) x) 'string-lessp)) + (insert "
\n" + " \n" + "\n")) + +(defun url-about (url) + "Show internal URLs." + (let* ((item (downcase (url-filename url))) + (func (intern (format "url-about-%s" item)))) + (if (fboundp func) + (progn + (set-buffer (generate-new-buffer " *about-data*")) + (insert "Content-type: text/html\n\n") + (funcall func url) + (current-buffer)) + (error "URL does not know about `%s'" item)))) + +(provide 'url-about) + +;;; arch-tag: 65dd7fca-db3f-4cb1-8026-7dd37d4a460e diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-auth.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-auth.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,320 @@ +;;; url-auth.el --- Uniform Resource Locator authorization modules +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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 'url-vars) +(require 'url-parse) +(autoload 'url-warn "url") + +(defsubst url-auth-user-prompt (url realm) + "String to usefully prompt for a username." + (concat "Username [for " + (or realm (url-truncate-url-for-viewing + (url-recreate-url url) + (- (window-width) 10 20))) + "]: ")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 'url-http-real-basic-auth-storage + "Where usernames and passwords are stored. + +Must be a symbol pointing to another variable that will actually store +the information. The value of this variable 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 (url-host href)) + (port (url-port href)) + (path (url-filename href)) + user pass byserv retval data) + (setq server (format "%s:%d" server port) + path (cond + (realm realm) + ((string-match "/$" path) path) + (t (url-basepath path))) + byserv (cdr-safe (assoc server + (symbol-value url-basic-auth-storage)))) + (cond + ((and prompt (not byserv)) + (setq user (read-string (url-auth-user-prompt url realm) + (user-real-login-name)) + pass (funcall url-passwd-entry-func "Password: ")) + (set url-basic-auth-storage + (cons (list server + (cons path + (setq retval + (base64-encode-string + (format "%s:%s" user pass))))) + (symbol-value 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 (url-auth-user-prompt url realm) + (user-real-login-name)) + pass (funcall url-passwd-entry-func "Password: ") + retval (base64-encode-string (format "%s:%s" user pass)) + byserv (assoc server (symbol-value 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 (url-host href)) + (port (url-port href)) + (path (url-filename href)) + user pass byserv retval data) + (setq path (cond + (realm realm) + ((string-match "/$" path) path) + (t (url-basepath path))) + server (format "%s:%d" server port) + byserv (cdr-safe (assoc server url-digest-auth-storage))) + (cond + ((and prompt (not byserv)) + (setq user (read-string (url-auth-user-prompt url realm) + (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 (url-auth-user-prompt url realm) + (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.") + +;;;###autoload +(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))))) + +;;;###autoload +(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 + (setcdr node (cons function rating)) + (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 'url-auth) + +;;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-cache.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-cache.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,205 @@ +;;; url-cache.el --- Uniform Resource Locator retrieval tool +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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 'url-parse) + +(defcustom url-cache-directory + (expand-file-name "cache" url-configuration-directory) + "*The directory where cache files should be stored." + :type 'directory + :group 'url-file) + +;; Cache manager +(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-cache-prepare (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." + (cond + ((url-cache-file-writable-p file) + t) + ((file-directory-p file) + nil) + (t + (condition-case () + (or (make-directory (file-name-directory file) t) t) + (error nil))))) + +;;;###autoload +(defun url-store-in-cache (&optional buff) + "Store buffer BUFF in the cache." + (if (not (and buff (get-buffer buff))) + nil + (save-excursion + (and buff (set-buffer buff)) + (let* ((fname (url-cache-create-filename (url-view-url t)))) + (if (url-cache-prepare fname) + (let ((coding-system-for-write 'binary)) + (write-region (point-min) (point-max) fname nil 5))))))) + +;;;###autoload +(defun url-is-cached (url) + "Return non-nil if the URL is cached." + (let* ((fname (url-cache-create-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-cache-create-filename-human-readable (url) + "Return a filename in the local cache for URL" + (if url + (let* ((url (if (vectorp url) (url-recreate-url url) url)) + (urlobj (url-generic-parse-url url)) + (protocol (url-type urlobj)) + (hostname (url-host urlobj)) + (host-components + (cons + (user-real-login-name) + (cons (or protocol "file") + (reverse (split-string (or hostname "localhost") + (eval-when-compile + (regexp-quote "."))))))) + (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 "")))) + + (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)))) + (and fname + (expand-file-name fname + (expand-file-name + (mapconcat 'identity host-components "/") + url-cache-directory)))))) + +(defun url-cache-create-filename-using-md5 (url) + "Create a cached filename using MD5. + Very fast if you are in XEmacs, suitably fast otherwise." + (require 'md5) + (if url + (let* ((url (if (vectorp url) (url-recreate-url url) url)) + (checksum (md5 url)) + (urlobj (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 + (split-string (or hostname "localhost") + (eval-when-compile + (regexp-quote ".")))))))) + (fname (url-filename urlobj))) + (and fname + (expand-file-name checksum + (expand-file-name + (mapconcat 'identity host-components "/") + url-cache-directory)))))) + +(defcustom url-cache-creation-function 'url-cache-create-filename-using-md5 + "*What function to use to create a cached filename." + :type '(choice (const :tag "MD5 of filename (low collision rate)" + :value url-cache-create-filename-using-md5) + (const :tag "Human readable filenames (higher collision rate)" + :value url-cache-create-filename-human-readable) + (function :tag "Other")) + :group 'url-cache) + +(defun url-cache-create-filename (url) + (funcall url-cache-creation-function url)) + +;;;###autoload +(defun url-cache-extract (fnam) + "Extract FNAM from the local disk cache" + (erase-buffer) + (insert-file-contents-literally fnam)) + +;;;###autoload +(defun url-cache-expired (url mod) + "Return t iff a cached file has expired." + (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url))) + (type (url-type urlobj))) + (cond + (url-standalone-mode + (not (file-exists-p (url-cache-create-filename url)))) + ((string= type "http") + t) + ((member type '("file" "ftp")) + (if (or (equal mod '(0 0)) (not mod)) + t + (or (> (nth 0 mod) (nth 0 (current-time))) + (> (nth 1 mod) (nth 1 (current-time)))))) + (t nil)))) + +(provide 'url-cache) + +;;; arch-tag: 95b050a6-8e81-4f23-8e63-191b9d1d657c diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-cid.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-cid.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,67 @@ +;;; url-cid.el --- Content-ID URL loader +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1998 - 1999 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 'url-vars) +(require 'url-parse) + +(require 'mm-decode) + +(defun url-cid-gnus (cid) + (let ((content-type nil) + (encoding nil) + (part nil) + (data nil)) + (setq part (mm-get-content-id cid)) + (if (not part) + (message "Unknown CID encountered: %s" cid) + (setq data (save-excursion + (set-buffer (mm-handle-buffer part)) + (buffer-string)) + content-type (mm-handle-type part) + encoding (symbol-name (mm-handle-encoding part))) + (if (= 0 (length content-type)) (setq content-type "text/plain")) + (if (= 0 (length encoding)) (setq encoding "8bit")) + (if (listp content-type) + (setq content-type (car content-type))) + (insert (format "Content-type: %d\r\n" (length data)) + "Content-type: " content-type "\r\n" + "Content-transfer-encoding: " encoding "\r\n" + "\r\n" + (or data ""))))) + +;;;###autoload +(defun url-cid (url) + (cond + ((fboundp 'mm-get-content-id) + ;; Using Pterodactyl Gnus or later + (save-excursion + (set-buffer (generate-new-buffer " *url-cid*")) + (url-cid-gnus (url-filename url)))) + (t + (message "Unable to handle CID URL: %s" url)))) + +;;; arch-tag: 23d9ab74-fad4-4dba-b1e7-292871e8bda5 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-cookie.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-cookie.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,469 @@ +;;; url-cookie.el --- Netscape Cookie support +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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 'timezone) +(require 'url-util) +(require 'url-parse) +(eval-when-compile (require 'cl)) + +;; 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)) + +(defun url-cookie-p (obj) + (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie))) + +(defgroup url-cookie nil + "URL cookies" + :prefix "url-" + :prefix "url-cookie-" + :group 'url) + +(defvar url-cookie-storage nil "Where cookies are stored.") +(defvar url-cookie-secure-storage nil "Where secure cookies are stored.") +(defcustom url-cookie-file nil "*Where cookies are stored on disk." + :type '(choice (const :tag "Default" :value nil) file) + :group 'url-file + :group 'url-cookie) + +(defcustom url-cookie-confirmation nil + "*If non-nil, confirmation by the user is required to accept HTTP cookies." + :type 'boolean + :group 'url-cookie) + +(defcustom url-cookie-multiple-line nil + "*If nil, HTTP requests put all cookies for the server on one line. +Some web servers, such as http://www.hotmail.com/, only accept cookies +when they are on one line. This is broken behaviour, but just try +telling Microsoft that.") + +(defvar url-cookies-changed-since-last-save nil + "Whether the cookies list has changed since the last save operation.") + +;;;###autoload +(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))) + +;;;###autoload +(defun url-cookie-write-file (&optional fname) + (setq fname (or fname url-cookie-file)) + (cond + ((not url-cookies-changed-since-last-save) nil) + ((not (file-writable-p fname)) + (message "Cookies file %s (see variable `url-cookie-file') is unwritable." fname)) + (t + (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)))))) + +;;;###autoload +(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)) + +;;;###autolaod +(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 (and url-cookie-multiple-line + (< 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.") + +(defcustom url-cookie-trusted-urls nil + "*A list of regular expressions matching URLs to always accept cookies from." + :type '(repeat regexp) + :group 'url-cookie) + +(defcustom url-cookie-untrusted-urls nil + "*A list of regular expressions matching URLs to never accept cookies from." + :type '(repeat regexp) + :group 'url-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 "\\." domain 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) ; We have enough dots in domain name + ;; Need to check and make sure the host is actually _in_ the + ;; domain it wants to set a cookie for though. + (string-match (concat (regexp-quote domain) "$") host)) + (t + nil)))) + +;;;###autoload +(defun url-cookie-handle-set-cookie (str) + (setq url-cookies-changed-since-last-save t) + (let* ((args (url-parse-args str t)) + (case-fold-search t) + (secure (and (assoc-ignore-case "secure" args) t)) + (domain (or (cdr-safe (assoc-ignore-case "domain" args)) + (url-host url-current-object))) + (current-url (url-view-url t)) + (trusted url-cookie-trusted-urls) + (untrusted url-cookie-untrusted-urls) + (expires (cdr-safe (assoc-ignore-case "expires" args))) + (path (or (cdr-safe (assoc-ignore-case "path" args)) + (file-name-directory + (url-filename url-current-object)))) + (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 (match-string 1 expires) " " + (match-string 2 expires) " " + (match-string 3 expires) " " + (match-string 4 expires) " [" + (match-string 5 expires) "]"))) + + ;; This one is for older Emacs/XEmacs variants that don't + ;; understand this format without tenths of a second in it. + ;; Wednesday, 30-Dec-2037 16:00:00 GMT + ;; - vs - + ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT + (if (and expires + (string-match + "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)" + expires)) + (setq expires (concat (match-string 1 expires) "-" ; day + (match-string 2 expires) "-" ; month + (match-string 3 expires) " " ; year + (match-string 4 expires) ".00 " ; hour:minutes:seconds + (match-string 6 expires)))) ":" ; timezone + + (while (consp trusted) + (if (string-match (car trusted) current-url) + (setq trusted (- (match-end 0) (match-beginning 0))) + (pop trusted))) + (while (consp untrusted) + (if (string-match (car untrusted) current-url) + (setq untrusted (- (match-end 0) (match-beginning 0))) + (pop untrusted))) + (if (and trusted untrusted) + ;; Choose the more specific match + (if (> trusted untrusted) + (setq untrusted nil) + (setq trusted nil))) + (cond + (untrusted + ;; The site was explicity marked as untrusted by the user + nil) + ((or (eq url-privacy-level 'paranoid) + (and (listp url-privacy-level) (memq 'cookies url-privacy-level))) + ;; user never wants cookies + nil) + ((and url-cookie-confirmation + (not trusted) + (save-window-excursion + (with-output-to-temp-buffer "*Cookie Warning*" + (mapcar + (function + (lambda (x) + (princ (format "%s - %s" (car x) (cdr x))))) rest)) + (prog1 + (not (funcall url-confirmation-func + (format "Allow %s to set these cookies? " + (url-host url-current-object)))) + (if (get-buffer "*Cookie Warning*") + (kill-buffer "*Cookie Warning*"))))) + ;; user wants to be asked, and declined. + nil) + ((url-cookie-host-can-set-p (url-host url-current-object) domain) + ;; Cookie is accepted by the user, and passes our security checks + (let ((cur nil)) + (while rest + (setq cur (pop rest)) + (url-cookie-store (car cur) (cdr cur) + expires domain path secure)))) + (t + (message "%s tried to set a cookie for domain %s - rejected." + (url-host url-current-object) domain))))) + +(defvar url-cookie-timer nil) + +(defcustom url-cookie-save-interval 3600 + "*The number of seconds between automatic saves of cookies. +Default is 1 hour. Note that if you change this variable outside of +the `customize' interface after `url-do-setup' has been run, you need +to run the `url-cookie-setup-save-timer' function manually." + :set (function (lambda (var val) + (set-default var val) + (and (featurep 'url) + (fboundp 'url-cookie-setup-save-timer) + (url-cookie-setup-save-timer)))) + :type 'integer + :group 'url) + +;;;###autoload +(defun url-cookie-setup-save-timer () + "Reset the cookie saver timer." + (interactive) + (cond + ((featurep 'itimer) + (ignore-errors (delete-itimer url-cookie-timer)) + (setq url-cookie-timer nil) + (if url-cookie-save-interval + (setq url-cookie-timer + (start-itimer "url-cookie-saver" 'url-cookie-write-file + url-cookie-save-interval + url-cookie-save-interval)))) + ((fboundp 'run-at-time) + (ignore-errors (cancel-timer url-cookie-timer)) + (setq url-cookie-timer nil) + (if url-cookie-save-interval + (setq url-cookie-timer + (run-at-time url-cookie-save-interval + url-cookie-save-interval + 'url-cookie-write-file)))) + (t nil))) + +(provide 'url-cookie) + +;;; arch-tag: 2568751b-6452-4398-aa2d-303edadb54d7 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-dav.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-dav.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,975 @@ +;;; url-dav.el --- WebDAV support + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; Author: Bill Perry +;; Maintainer: Bill Perry +;; Version: $Revision: 1.2 $ +;; Keywords: url, vc + +;; 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. + +(eval-when-compile + (require 'cl)) + +(require 'xml) +(require 'url-util) +(require 'url-handlers) + +(defvar url-dav-supported-protocols '(1 2) + "List of supported DAV versions.") + +;;;###autoload +(defun url-dav-supported-p (url) + (and (featurep 'xml) + (fboundp 'xml-expand-namespace) + (intersection url-dav-supported-protocols + (plist-get (url-http-options url) 'dav)))) + +(defun url-dav-node-text (node) + "Return the text data from the XML node NODE." + (mapconcat (lambda (txt) + (if (stringp txt) + txt + "")) (xml-node-children node) " ")) + + +;;; Parsing routines for the actual node contents. +;;; +;;; I am not incredibly happy with how this code looks/works right +;;; now, but it DOES work, and if we get the API right, our callers +;;; won't have to worry about the internal representation. + +(defconst url-dav-datatype-attribute + 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt) + +(defun url-dav-process-integer-property (node) + (truncate (string-to-number (url-dav-node-text node)))) + +(defun url-dav-process-number-property (node) + (string-to-number (url-dav-node-text node))) + +(defconst url-dav-iso8601-regexp + (let* ((dash "-?") + (colon ":?") + (4digit "\\([0-9][0-9][0-9][0-9]\\)") + (2digit "\\([0-9][0-9]\\)") + (date-fullyear 4digit) + (date-month 2digit) + (date-mday 2digit) + (time-hour 2digit) + (time-minute 2digit) + (time-second 2digit) + (time-secfrac "\\(\\.[0-9]+\\)?") + (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute)) + (time-offset (concat "Z" time-numoffset)) + (partial-time (concat time-hour colon time-minute colon time-second + time-secfrac)) + (full-date (concat date-fullyear dash date-month dash date-mday)) + (full-time (concat partial-time time-offset)) + (date-time (concat full-date "T" full-time))) + (list (concat "^" full-date) + (concat "T" partial-time) + (concat "Z" time-numoffset))) + "List of regular expressions matching iso8601 dates. +1st regular expression matches the date. +2nd regular expression matches the time. +3rd regular expression matches the (optional) timezone specification. +") + +(defun url-dav-process-date-property (node) + (require 'parse-time) + (let* ((date-re (nth 0 url-dav-iso8601-regexp)) + (time-re (nth 1 url-dav-iso8601-regexp)) + (tz-re (nth 2 url-dav-iso8601-regexp)) + (date-string (url-dav-node-text node)) + re-start + time seconds minute hour fractional-seconds + day month year day-of-week dst tz) + ;; We need to populate 'time' with + ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) + + ;; Nobody else handles iso8601 correctly, lets do it ourselves. + (when (string-match date-re date-string re-start) + (setq year (string-to-int (match-string 1 date-string)) + month (string-to-int (match-string 2 date-string)) + day (string-to-int (match-string 3 date-string)) + re-start (match-end 0)) + (when (string-match time-re date-string re-start) + (setq hour (string-to-int (match-string 1 date-string)) + minute (string-to-int (match-string 2 date-string)) + seconds (string-to-int (match-string 3 date-string)) + fractional-seconds (string-to-int (or + (match-string 4 date-string) + "0")) + re-start (match-end 0)) + (when (string-match tz-re date-string re-start) + (setq tz (match-string 1 date-string))) + (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" "")) + (setq time (list seconds minute hour day month year day-of-week dst tz)))) + + ;; Fall back to having Gnus do fancy things for us. + (when (not time) + (setq time (parse-time-string date-string))) + + (if time + (setq time (apply 'encode-time time)) + (url-debug 'dav "Unable to decode date (%S) (%s)" + (xml-node-name node) date-string)) + time)) + +(defun url-dav-process-boolean-property (node) + (/= 0 (string-to-int (url-dav-node-text node)))) + +(defun url-dav-process-uri-property (node) + ;; Returns a parsed representation of the URL... + (url-generic-parse-url (url-dav-node-text node))) + +(defun url-dav-find-parser (node) + "Find a function to parse the XML node NODE." + (or (get (xml-node-name node) 'dav-parser) + (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node))))) + (if (not (fboundp fn)) + (setq fn 'url-dav-node-text) + (put (xml-node-name node) 'dav-parser fn)) + fn))) + +(defmacro url-dav-dispatch-node (node) + `(funcall (url-dav-find-parser ,node) ,node)) + +(defun url-dav-process-DAV:prop (node) + ;; A prop node has content model of ANY + ;; + ;; Some predefined nodes have special meanings though. + ;; + ;; DAV:supportedlock - list of DAV:lockentry + ;; DAV:source + ;; DAV:iscollection - boolean + ;; DAV:getcontentlength - integer + ;; DAV:ishidden - boolean + ;; DAV:getcontenttype - string + ;; DAV:resourcetype - node who's name is the resource type + ;; DAV:getlastmodified - date + ;; DAV:creationdate - date + ;; DAV:displayname - string + ;; DAV:getetag - unknown + (let ((children (xml-node-children node)) + (node-type nil) + (props nil) + (value nil) + (handler-func nil)) + (when (not children) + (error "No child nodes in DAV:prop")) + + (while children + (setq node (car children) + node-type (intern + (or + (cdr-safe (assq url-dav-datatype-attribute + (xml-node-attributes node))) + "unknown")) + value nil) + + (case node-type + ((dateTime.iso8601tz + dateTime.iso8601 + dateTime.tz + dateTime.rfc1123 + dateTime + date) ; date is our 'special' one... + ;; Some type of date/time string. + (setq value (url-dav-process-date-property node))) + (int + ;; Integer type... + (setq value (url-dav-process-integer-property node))) + ((number float) + (setq value (url-dav-process-number-property node))) + (boolean + (setq value (url-dav-process-boolean-property node))) + (uri + (setq value (url-dav-process-uri-property node))) + (otherwise + (if (not (eq node-type 'unknown)) + (url-debug 'dav "Unknown data type in url-dav-process-prop: %s" + node-type)) + (setq value (url-dav-dispatch-node node)))) + + (setq props (plist-put props (xml-node-name node) value) + children (cdr children))) + props)) + +(defun url-dav-process-DAV:supportedlock (node) + ;; DAV:supportedlock is a list of DAV:lockentry items. + ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype. + ;; The DAV:lockscope must have a single node beneath it, ditto for + ;; DAV:locktype. + (let ((children (xml-node-children node)) + (results nil) + scope type) + (while children + (when (and (not (stringp (car children))) + (eq (xml-node-name (car children)) 'DAV:lockentry)) + (setq scope (assq 'DAV:lockscope (xml-node-children (car children))) + type (assq 'DAV:locktype (xml-node-children (car children)))) + (when (and scope type) + (setq scope (xml-node-name (car (xml-node-children scope))) + type (xml-node-name (car (xml-node-children type)))) + (push (cons type scope) results))) + (setq children (cdr children))) + results)) + +(defun url-dav-process-subnode-property (node) + ;; Returns a list of child node names. + (delq nil (mapcar 'car-safe (xml-node-children node)))) + +(defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property) +(defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property) +(defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property) +(defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property) +(defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property) +(defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property) +(defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property) +(defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property) +(defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property) + +(defun url-dav-process-DAV:locktoken (node) + ;; DAV:locktoken can have one or more DAV:href children. + (delq nil (mapcar (lambda (n) + (if (stringp n) + n + (url-dav-dispatch-node n))) + (xml-node-children node)))) + +(defun url-dav-process-DAV:owner (node) + ;; DAV:owner can contain anything. + (delq nil (mapcar (lambda (n) + (if (stringp n) + n + (url-dav-dispatch-node n))) + (xml-node-children node)))) + +(defun url-dav-process-DAV:activelock (node) + ;; DAV:activelock can contain: + ;; DAV:lockscope + ;; DAV:locktype + ;; DAV:depth + ;; DAV:owner (optional) + ;; DAV:timeout (optional) + ;; DAV:locktoken (optional) + (let ((children (xml-node-children node)) + (results nil)) + (while children + (if (listp (car children)) + (push (cons (xml-node-name (car children)) + (url-dav-dispatch-node (car children))) + results)) + (setq children (cdr children))) + results)) + +(defun url-dav-process-DAV:lockdiscovery (node) + ;; Can only contain a list of DAV:activelock objects. + (let ((children (xml-node-children node)) + (results nil)) + (while children + (cond + ((stringp (car children)) + ;; text node? why? + nil) + ((eq (xml-node-name (car children)) 'DAV:activelock) + (push (url-dav-dispatch-node (car children)) results)) + (t + ;; Ignore unknown nodes... + nil)) + (setq children (cdr children))) + results)) + +(defun url-dav-process-DAV:status (node) + ;; The node contains a standard HTTP/1.1 response line... we really + ;; only care about the numeric status code. + (let ((status (url-dav-node-text node))) + (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status) + (string-to-int (match-string 1 status)) + 500))) + +(defun url-dav-process-DAV:propstat (node) + ;; A propstate node can have the following children... + ;; + ;; DAV:prop - a list of properties and values + ;; DAV:status - An HTTP/1.1 status line + (let ((children (xml-node-children node)) + (props nil) + (status nil)) + (when (not children) + (error "No child nodes in DAV:propstat")) + + (setq props (url-dav-dispatch-node (assq 'DAV:prop children)) + status (url-dav-dispatch-node (assq 'DAV:status children))) + + ;; Need to parse out the HTTP status + (setq props (plist-put props 'DAV:status status)) + props)) + +(defun url-dav-process-DAV:response (node) + (let ((children (xml-node-children node)) + (propstat nil) + (href)) + (when (not children) + (error "No child nodes in DAV:response")) + + ;; A response node can have the following children... + ;; + ;; DAV:href - URL the response is for. + ;; DAV:propstat - see url-dav-process-propstat + ;; DAV:responsedescription - text description of the response + (setq propstat (assq 'DAV:propstat children) + href (assq 'DAV:href children)) + + (when (not href) + (error "No href in DAV:response")) + + (when (not propstat) + (error "No propstat in DAV:response")) + + (setq propstat (url-dav-dispatch-node propstat) + href (url-dav-dispatch-node href)) + (cons href propstat))) + +(defun url-dav-process-DAV:multistatus (node) + (let ((children (xml-node-children node)) + (results nil)) + (while children + (push (url-dav-dispatch-node (car children)) results) + (setq children (cdr children))) + results)) + + +;;; DAV request/response generation/processing +(defun url-dav-process-response (buffer url) + "Parses a WebDAV response from BUFFER, interpreting it relative to URL. + +The buffer must have been retrieved by HTTP or HTTPS and contain an +XML document. +" + (declare (special url-http-content-type + url-http-response-status + url-http-end-of-headers)) + (let ((tree nil) + (overall-status nil)) + (when buffer + (unwind-protect + (save-excursion + (set-buffer buffer) + (goto-char url-http-end-of-headers) + (setq overall-status url-http-response-status) + + ;; XML documents can be transferred as either text/xml or + ;; application/xml, and we are required to accept both of + ;; them. + (if (and + url-http-content-type + (or (string-match "^text/xml" url-http-content-type) + (string-match "^application/xml" url-http-content-type))) + (setq tree (xml-parse-region (point) (point-max))))) + ;; Clean up after ourselves. + '(kill-buffer buffer))) + + ;; We should now be + (if (eq (xml-node-name (car tree)) 'DAV:multistatus) + (url-dav-dispatch-node (car tree)) + (url-debug 'dav "Got back singleton response for URL(%S)" url) + (let ((properties (url-dav-dispatch-node (car tree)))) + ;; We need to make sure we have a DAV:status node in there for + ;; higher-level code; + (setq properties (plist-put properties 'DAV:status overall-status)) + ;; Make this look like a DAV:multistatus parse tree so that + ;; nobody but us needs to know the difference. + (list (cons url properties)))))) + +(defun url-dav-request (url method tag body + &optional depth headers namespaces) + "Performs WebDAV operation METHOD on URL. Returns the parsed responses. +Automatically creates an XML request body if TAG is non-nil. +BODY is the XML document fragment to be enclosed by . + +DEPTH is how deep the request should propogate. Default is 0, meaning +it should apply only to URL. A negative number means to use +`Infinity' for the depth. Not all WebDAV servers support this depth +though. + +HEADERS is an assoc list of extra headers to send in the request. + +NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are +added to the element. The DAV=DAV: namespace is automatically +added to this list, so most requests can just pass in nil. +" + ;; Take care of the default value for depth... + (setq depth (or depth 0)) + + ;; Now lets translate it into something webdav can understand. + (if (< depth 0) + (setq depth "Infinity") + (setq depth (int-to-string depth))) + (if (not (assoc "DAV" namespaces)) + (setq namespaces (cons '("DAV" . "DAV:") namespaces))) + + (let* ((url-request-extra-headers `(("Depth" . ,depth) + ("Content-type" . "text/xml") + ,@headers)) + (url-request-method method) + (url-request-data + (if tag + (concat + "\n" + "<" (symbol-name tag) " " + ;; add in the appropriate namespaces... + (mapconcat (lambda (ns) + (concat "xmlns:" (car ns) "='" (cdr ns) "'")) + namespaces "\n ") + ">\n" + body + "\n")))) + (url-dav-process-response (url-retrieve-synchronously url) url))) + +;;;###autoload +(defun url-dav-get-properties (url &optional attributes depth namespaces) + "Return properties for URL, up to DEPTH levels deep. + +Returns an assoc list, where the key is the filename (possibly a full +URI), and the value is a standard property list of DAV property +names (ie: DAV:resourcetype). +" + (url-dav-request url "PROPFIND" 'DAV:propfind + (if attributes + (mapconcat (lambda (attr) + (concat "<" + (symbol-name attr) + "/>")) + attributes "\n ") + " ") + depth nil namespaces)) + +(defmacro url-dav-http-success-p (status) + "Return whether PROPERTIES was the result of a successful DAV request." + `(= (/ (or ,status 500) 100) 2)) + + +;;; Locking support +(defvar url-dav-lock-identifier (concat "mailto:" user-mail-address) + "*URL used as contact information when creating locks in DAV. +This will be used as the contents of the DAV:owner/DAV:href tag to +identify the owner of a LOCK when requesting it. This will be shown +to other users when the DAV:lockdiscovery property is requested, so +make sure you are comfortable with it leaking to the outside world. +") + +;;;###autoload +(defun url-dav-lock-resource (url exclusive &optional depth) + "Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock. +Optional 3rd argument DEPTH says how deep the lock should go, default is 0 +\(lock only the resource and none of its children\). + +Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS). +SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken). +FAILURE-RESULTS is a list of (URL STATUS). +" + (setq exclusive (if exclusive "" "")) + (let* ((body + (concat + " " exclusive "\n" + " \n" + " \n" + " " url-dav-lock-identifier "\n" + " \n")) + (response nil) ; Responses to the LOCK request + (result nil) ; For walking thru the response list + (child-url nil) + (child-status nil) + (failures nil) ; List of failure cases (URL . STATUS) + (successes nil)) ; List of success cases (URL . STATUS) + (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body + depth '(("Timeout" . "Infinite")))) + + ;; Get the parent URL ready for expand-file-name + (if (not (vectorp url)) + (setq url (url-generic-parse-url url))) + + ;; Walk thru the response list, fully expand the URL, and grab the + ;; status code. + (while response + (setq result (pop response) + child-url (url-expand-file-name (pop result) url) + child-status (or (plist-get result 'DAV:status) 500)) + (if (url-dav-http-success-p child-status) + (push (list url child-status "huh") successes) + (push (list url child-status) failures))) + (cons successes failures))) + +;;;###autoload +(defun url-dav-active-locks (url &optional depth) + "Return an assoc list of all active locks on URL." + (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth)) + (properties nil) + (child nil) + (child-url nil) + (child-results nil) + (results nil)) + (if (not (vectorp url)) + (setq url (url-generic-parse-url url))) + + (while response + (setq child (pop response) + child-url (pop child) + child-results nil) + (when (and (url-dav-http-success-p (plist-get child 'DAV:status)) + (setq child (plist-get child 'DAV:lockdiscovery))) + ;; After our parser has had its way with it, The + ;; DAV:lockdiscovery property is a list of DAV:activelock + ;; objects, which are comprised of DAV:activelocks, which + ;; assoc lists of properties and values. + (while child + (if (assq 'DAV:locktoken (car child)) + (let ((tokens (cdr (assq 'DAV:locktoken (car child)))) + (owners (cdr (assq 'DAV:owner (car child))))) + (dolist (token tokens) + (dolist (owner owners) + (push (cons token owner) child-results))))) + (pop child))) + (if child-results + (push (cons (url-expand-file-name child-url url) child-results) + results))) + results)) + +;;;###autoload +(defun url-dav-unlock-resource (url lock-token) + "Release the lock on URL represented by LOCK-TOKEN. +Returns `t' iff the lock was successfully released. +" + (declare (special url-http-response-status)) + (let* ((url-request-extra-headers (list (cons "Lock-Token" + (concat "<" lock-token ">")))) + (url-request-method "UNLOCK") + (url-request-data nil) + (buffer (url-retrieve-synchronously url)) + (result nil)) + (when buffer + (unwind-protect + (save-excursion + (set-buffer buffer) + (setq result (url-dav-http-success-p url-http-response-status))) + (kill-buffer buffer))) + result)) + + +;;; file-name-handler stuff +(defun url-dav-file-attributes-mode-string (properties) + (let ((modes (make-string 10 ?-)) + (supported-locks (plist-get properties 'DAV:supportedlock)) + (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable) + "T")) + (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype))) + (readable t) + (lock nil)) + ;; Assume we can read this, otherwise the PROPFIND would have + ;; failed. + (when readable + (aset modes 1 ?r) + (aset modes 4 ?r) + (aset modes 7 ?r)) + + (when directory-p + (aset modes 0 ?d)) + + (when executable-p + (aset modes 3 ?x) + (aset modes 6 ?x) + (aset modes 9 ?x)) + + (while supported-locks + (setq lock (car supported-locks) + supported-locks (cdr supported-locks)) + (case (car lock) + (DAV:write + (case (cdr lock) + (DAV:shared ; group permissions (possibly world) + (aset modes 5 ?w)) + (DAV:exclusive + (aset modes 2 ?w)) ; owner permissions? + (otherwise + (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock))))) + (otherwise + (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock))))) + modes)) + +;;;###autoload +(defun url-dav-file-attributes (url) + (let ((properties (cdar (url-dav-get-properties url))) + (attributes nil)) + (if (and properties + (url-dav-http-success-p (plist-get properties 'DAV:status))) + ;; We got a good DAV response back.. + (setq attributes + (list + ;; t for directory, string for symbolic link, or nil + ;; Need to support DAV Bindings to figure out the + ;; symbolic link issues. + (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil) + + ;; Number of links to file... Needs DAV Bindings. + 1 + + ;; File uid - no way to figure out? + 0 + + ;; File gid - no way to figure out? + 0 + + ;; Last access time - ??? + nil + + ;; Last modification time + (plist-get properties 'DAV:getlastmodified) + + ;; Last status change time... just reuse last-modified + ;; for now. + (plist-get properties 'DAV:getlastmodified) + + ;; size in bytes + (or (plist-get properties 'DAV:getcontentlength) 0) + + ;; file modes as a string like `ls -l' + ;; + ;; Should be able to build this up from the + ;; DAV:supportedlock attribute pretty easily. Getting + ;; the group info could be impossible though. + (url-dav-file-attributes-mode-string properties) + + ;; t iff file's gid would change if it were deleted & + ;; recreated. No way for us to know that thru DAV. + nil + + ;; inode number - meaningless + nil + + ;; device number - meaningless + nil)) + ;; Fall back to just the normal http way of doing things. + (setq attributes (url-http-head-file-attributes url))) + attributes)) + +;;;###autoload +(defun url-dav-save-resource (url obj &optional content-type lock-token) + "Save OBJ as URL using WebDAV. +URL must be a fully qualified URL. +OBJ may be a buffer or a string." + (let ((buffer nil) + (result nil) + (url-request-extra-headers nil) + (url-request-method "PUT") + (url-request-data + (cond + ((bufferp obj) + (save-excursion + (set-buffer obj) + (buffer-string))) + ((stringp obj) + obj) + (t + (error "Invalid object to url-dav-save-resource"))))) + + (if lock-token + (push + (cons "If" (concat "(<" lock-token ">)")) + url-request-extra-headers)) + + ;; Everything must always have a content-type when we submit it. + (push + (cons "Content-type" (or content-type "application/octet-stream")) + url-request-extra-headers) + + ;; Do the save... + (setq buffer (url-retrieve-synchronously url)) + + ;; Sanity checking + (when buffer + (unwind-protect + (save-excursion + (set-buffer buffer) + (setq result (url-dav-http-success-p url-http-response-status))) + (kill-buffer buffer))) + result)) + +(eval-when-compile + (defmacro url-dav-delete-something (url lock-token &rest error-checking) + "Delete URL completely, with no sanity checking whatsoever. DO NOT USE. +This is defined as a macro that will not be visible from compiled files. +Use with care, and even then think three times. +" + `(progn + ,@error-checking + (url-dav-request ,url "DELETE" nil nil -1 + (if ,lock-token + (list + (cons "If" + (concat "(<" ,lock-token ">)")))))))) + + +;;;###autoload +(defun url-dav-delete-directory (url &optional recursive lock-token) + "Delete the WebDAV collection URL. +If optional second argument RECURSIVE is non-nil, then delete all +files in the collection as well. +" + (let ((status nil) + (props nil) + (props nil)) + (setq props (url-dav-delete-something + url lock-token + (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1)) + (if (and (not recursive) + (/= (length props) 1)) + (signal 'file-error (list "Removing directory" + "directory not empty" url))))) + + (mapc (lambda (result) + (setq status (plist-get (cdr result) 'DAV:status)) + (if (not (url-dav-http-success-p status)) + (signal 'file-error (list "Removing directory" + "Errror removing" + (car result) status)))) + props)) + nil) + +;;;###autoload +(defun url-dav-delete-file (url &optional lock-token) + "Delete file named URL." + (let ((props nil) + (status nil)) + (setq props (url-dav-delete-something + url lock-token + (setq props (url-dav-get-properties url)) + (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection) + (signal 'file-error (list "Removing old name" "is a collection" url))))) + + (mapc (lambda (result) + (setq status (plist-get (cdr result) 'DAV:status)) + (if (not (url-dav-http-success-p status)) + (signal 'file-error (list "Removing old name" + "Errror removing" + (car result) status)))) + props)) + nil) + +;;;###autoload +(defun url-dav-directory-files (url &optional full match nosort files-only) + "Return a list of names of files in DIRECTORY. +There are three optional arguments: +If FULL is non-nil, return absolute file names. Otherwise return names + that are relative to the specified directory. +If MATCH is non-nil, mention only file names that match the regexp MATCH. +If NOSORT is non-nil, the list is not sorted--its order is unpredictable. + NOSORT is useful if you plan to sort the result yourself. +" + (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1)) + (child-url nil) + (child-props nil) + (files nil) + (parsed-url (url-generic-parse-url url))) + + (if (= (length properties) 1) + (signal 'file-error (list "Opening directory" "not a directory" url))) + + (while properties + (setq child-props (pop properties) + child-url (pop child-props)) + (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection) + files-only) + ;; It is a directory, and we were told to return just files. + nil + + ;; Fully expand the URL and then rip off the beginning if we + ;; are not supposed to return fully-qualified names. + (setq child-url (url-expand-file-name child-url parsed-url)) + (if (not full) + (setq child-url (substring child-url (length url)))) + + ;; We don't want '/' as the last character in filenames... + (if (string-match "/$" child-url) + (setq child-url (substring child-url 0 -1))) + + ;; If we have a match criteria, then apply it. + (if (or (and match (not (string-match match child-url))) + (string= child-url "") + (string= child-url url)) + nil + (push child-url files)))) + + (if nosort + files + (sort files 'string-lessp)))) + +;;;###autoload +(defun url-dav-file-directory-p (url) + "Return t if URL names an existing DAV collection." + (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype))))) + (eq (plist-get properties 'DAV:resourcetype) 'DAV:collection))) + +;;;###autoload +(defun url-dav-make-directory (url &optional parents) + "Create the directory DIR and any nonexistent parent dirs." + (declare (special url-http-response-status)) + (let* ((url-request-extra-headers nil) + (url-request-method "MKCOL") + (url-request-data nil) + (buffer (url-retrieve-synchronously url)) + (result nil)) + (when buffer + (unwind-protect + (save-excursion + (set-buffer buffer) + (case url-http-response-status + (201 ; Collection created in its entirety + (setq result t)) + (403 ; Forbidden + nil) + (405 ; Method not allowed + nil) + (409 ; Conflict + nil) + (415 ; Unsupported media type (WTF?) + nil) + (507 ; Insufficient storage + nil) + (otherwise + nil))) + (kill-buffer buffer))) + result)) + +;;;###autoload +(defun url-dav-rename-file (oldname newname &optional overwrite) + (if (not (and (string-match url-handler-regexp oldname) + (string-match url-handler-regexp newname))) + (signal 'file-error "Cannot rename between different URL backends" oldname newname)) + + (let* ((headers nil) + (props nil) + (status nil) + (directory-p (url-dav-file-directory-p oldname)) + (exists-p (url-http-file-exists-p newname))) + + (if (and exists-p + (or + (null overwrite) + (and (numberp overwrite) + (not (yes-or-no-p + (format "File %s already exists; rename to it anyway? " + newname)))))) + (signal 'file-already-exists (list "File already exists" newname))) + + ;; Honor the overwrite flag... + (if overwrite (push '("Overwrite" . "T") headers)) + + ;; Have to tell them where to copy it to! + (push (cons "Destination" newname) headers) + + ;; Always send a depth of -1 in case we are moving a collection. + (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0) + headers)) + + (mapc (lambda (result) + (setq status (plist-get (cdr result) 'DAV:status)) + + (if (not (url-dav-http-success-p status)) + (signal 'file-error (list "Renaming" oldname newname status)))) + props) + t)) + +;;;###autoload +(defun url-dav-file-name-all-completions (file url) + "Return a list of all completions of file name FILE in directory DIRECTORY. +These are all file names in directory DIRECTORY which begin with FILE. +" + (url-dav-directory-files url nil (concat "^" file ".*"))) + +;;;###autoload +(defun url-dav-file-name-completion (file url) + "Complete file name FILE in directory DIRECTORY. +Returns the longest string +common to all file names in DIRECTORY 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. +" + (let ((matches (url-dav-file-name-all-completions file url)) + (result nil)) + (cond + ((null matches) + ;; No matches + nil) + ((and (= (length matches) 1) + (string= file (car matches))) + ;; Only one file and FILE matches it exactly... + t) + (t + ;; Need to figure out the longest string that they have in commmon + (setq matches (sort matches (lambda (a b) (> (length a) (length b))))) + (let ((n (length file)) + (searching t) + (regexp nil) + (failed nil)) + (while (and searching + (< n (length (car matches)))) + (setq regexp (concat "^" (substring (car matches) 0 (1+ n))) + failed nil) + (dolist (potential matches) + (if (not (string-match regexp potential)) + (setq failed t))) + (if failed + (setq searching nil) + (incf n))) + (substring (car matches) 0 n)))))) + +(defun url-dav-register-handler (op) + (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op)))) + +(mapcar 'url-dav-register-handler + '(file-name-all-completions + file-name-completion + rename-file + make-directory + file-directory-p + directory-files + delete-file + delete-directory + file-attributes)) + + +;;; Version Control backend cruft + +;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered) + +;;;###autoload +(defun url-dav-vc-registered (url) + (if (and (string-match "\\`https?" url) + (plist-get (url-http-options url) 'dav)) + (progn + (vc-file-setprop url 'vc-backend 'dav) + t))) + + +;;; Miscellaneous stuff. + +(provide 'url-dav) + +;;; arch-tag: 2b14b7b3-888a-49b8-a490-17276a40e78e diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-dired.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-dired.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,104 @@ +;;; url-dired.el --- URL Dired minor mode +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, files + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(autoload 'w3-fetch "w3") +(autoload 'w3-open-local "w3") +(autoload 'dired-get-filename "dired") + +(defvar url-dired-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'url-dired-find-file) + (if (featurep 'xemacs) + (define-key map [button2] 'url-dired-find-file-mouse) + (define-key map [mouse-2] 'url-dired-find-file-mouse)) + map) + "Keymap used when browsing directories.") + +(defvar url-dired-minor-mode nil + "Whether we are in url-dired-minor-mode") + +(make-variable-buffer-local 'url-dired-minor-mode) + +(defun url-dired-find-file () + "In dired, visit the file or directory named on this line, using Emacs-W3." + (interactive) + (let ((filename (dired-get-filename))) + (cond ((string-match "/\\(.*@.*\\):\\(/.*\\)" filename) + (w3-fetch (concat "file://" (match-string 1 filename) (match-string 2 filename)))) + (t + (w3-open-local filename))))) + +(defun url-dired-find-file-mouse (event) + "In dired, visit the file or directory name you click on, using Emacs-W3." + (interactive "@e") + (mouse-set-point event) + (url-dired-find-file)) + +(defun url-dired-minor-mode (&optional arg) + "Minor mode for directory browsing with Emacs-W3." + (interactive "P") + (cond + ((null arg) + (setq url-dired-minor-mode (not url-dired-minor-mode))) + ((equal 0 arg) + (setq url-dired-minor-mode nil)) + (t + (setq url-dired-minor-mode t)))) + +(if (not (fboundp 'add-minor-mode)) + (defun add-minor-mode (toggle name &optional keymap after toggle-fun) + "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. +TOGGLE is a symbol 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))))) + +(add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map) + +(defun url-find-file-dired (dir) + "\"Edit\" directory DIR, but with additional URL-friendly bindings." + (interactive "DURL Dired (directory): ") + (find-file dir) + (url-dired-minor-mode t)) + +(provide 'url-dired) + +;;; arch-tag: 2694f21a-43e1-4391-b3cb-cf6e5349f15f diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-expand.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-expand.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,145 @@ +;;; url-expand.el --- expand-file-name for URLs +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1999 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 'url-methods) +(require 'url-util) +(require 'url-parse) + +(defun url-expander-remove-relative-links (name) + ;; Strip . and .. from pathnames + (let ((new (if (not (string-match "^/" name)) + (concat "/" name) + name))) + + ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat + ;; the tests that follow are not too complicated in terms of + ;; looking for '..' or '../', etc. + (if (string-match "/\\.+$" new) + (setq new (concat new "/"))) + + ;; Remove '/./' first + (while (string-match "/\\(\\./\\)" new) + (setq new (concat (substring new 0 (match-beginning 1)) + (substring new (match-end 1))))) + + ;; Then remove '/../' + (while (string-match "/\\([^/]*/\\.\\./\\)" new) + (setq new (concat (substring new 0 (match-beginning 1)) + (substring new (match-end 1))))) + + ;; Remove cruft at the beginning of the string, so people that put + ;; in extraneous '..' because they are morons won't lose. + (while (string-match "^/\\.\\.\\(/\\)" new) + (setq new (substring new (match-beginning 1) nil))) + new)) + +(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 (and url (not (string-match "^#" url))) + ;; Need to nuke newlines and spaces in the URL, or we open + ;; ourselves up to potential security holes. + (setq url (mapconcat (function (lambda (x) + (if (memq x '(? ?\n ?\r)) + "" + (char-to-string x)))) + url ""))) + + ;; Need to figure out how/where to expand the fragment relative to + (setq default (cond + ((vectorp default) + ;; Default URL has already been parsed + default) + (default + ;; They gave us a default URL in non-parsed format + (url-generic-parse-url default)) + (url-current-object + ;; We are in a URL-based buffer, use the pre-parsed object + url-current-object) + ((string-match url-nonrelative-link url) + ;; The URL they gave us is absolute, go for it. + nil) + (t + ;; Hmmm - this shouldn't ever happen. + (error "url-expand-file-name confused - no default?")))) + + (cond + ((= (length url) 0) ; nil or empty string + (url-recreate-url default)) + ((string-match "^#" url) ; Offset link, use it raw + url) + ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately + url) + (t + (let* ((urlobj (url-generic-parse-url url)) + (inhibit-file-name-handlers t) + (expander (url-scheme-get-property (url-type default) 'expand-file-name))) + (if (string-match "^//" url) + (setq urlobj (url-generic-parse-url (concat (url-type default) ":" + url)))) + (funcall expander urlobj default) + (url-recreate-url urlobj))))) + +(defun url-identity-expander (urlobj defobj) + (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))) + +(defun url-default-expander (urlobj defobj) + ;; The default expansion routine - urlobj is modified by side effect! + (if (url-type urlobj) + ;; Well, they told us the scheme, let's just go with it. + nil + (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 + (let ((query nil) + (file nil) + (sepchar nil)) + (if (string-match "[?#]" (url-filename urlobj)) + (setq query (substring (url-filename urlobj) (match-end 0)) + file (substring (url-filename urlobj) 0 (match-beginning 0)) + sepchar (substring (url-filename urlobj) (match-beginning 0) (match-end 0))) + (setq file (url-filename urlobj))) + (setq file (url-expander-remove-relative-links + (concat (url-basepath (url-filename defobj)) file))) + (url-set-filename urlobj (if query (concat file sepchar query) file)))))) + +(provide 'url-expand) + +;;; arch-tag: 7b5f744b-b721-49da-be47-484631680a5a diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-file.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-file.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,241 @@ +;;; url-file.el --- File retrieval code +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile (require 'cl)) +(require 'mailcap) +(require 'url-vars) +(require 'url-parse) +(require 'url-dired) + +(defconst url-file-default-port 21 "Default FTP port.") +(defconst url-file-asynchronous-p t "FTP transfers are asynchronous.") +(defalias 'url-file-expand-file-name 'url-default-expander) + +(defun url-file-find-possibly-compressed-file (fname &rest args) + "Find the exact file referenced by `fname'. +This tries the common compression extensions, because things like +ange-ftp and efs are not quite smart enough to realize when a server +can do automatic decompression for them, and won't find 'foo' if +'foo.gz' exists, even though the ftp server would happily serve it up +to them." + (let ((scratch nil) + (compressed-extensions '("" ".gz" ".z" ".Z" ".bz2")) + (found nil)) + (while (and compressed-extensions (not found)) + (if (file-exists-p (setq scratch (concat fname (pop compressed-extensions)))) + (setq found scratch))) + found)) + +(defun url-file-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-asynch-callback (x y name buff func args &optional efs) + (if (not (featurep 'ange-ftp)) + ;; EFS passes us an extra argument + (setq name buff + buff func + func args + args efs)) + (let ((size (nth 7 (file-attributes name)))) + (save-excursion + (set-buffer buff) + (goto-char (point-max)) + (if (/= -1 size) + (insert (format "Content-length: %d\n" size))) + (insert "\n") + (insert-file-contents-literally name) + (if (not (url-file-host-is-local-p (url-host url-current-object))) + (condition-case () + (delete-file name) + (error nil))) + (apply func args)))) + +(defun url-file-build-filename (url) + (if (not (vectorp url)) + (setq url (url-generic-parse-url url))) + (let* ((user (url-user url)) + (pass (url-password url)) + (port (url-port url)) + (host (url-host url)) + (site (if (and port (/= port 21)) + (if (featurep 'ange-ftp) + (format "%s %d" host port) + ;; This works in Emacs 21's ange-ftp too. + (format "%s#%d" host port)) + host)) + (file (url-unhex-string (url-filename url))) + (filename (if (or user (not (url-file-host-is-local-p host))) + (concat "/" (or user "anonymous") "@" site ":" file) + (if (and (memq system-type + '(emx ms-dos windows-nt ms-windows)) + (string-match "^/[a-zA-Z]:/" file)) + (substring file 1) + file))) + pos-index) + + (and user pass + (cond + ((featurep 'ange-ftp) + (ange-ftp-set-passwd host user pass)) + ((or (featurep 'efs) (featurep 'efs-auto)) + (efs-set-passwd host user pass)) + (t + nil))) + + ;; This makes sure that directories have a trailing directory + ;; separator on them so URL expansion works right. + ;; + ;; FIXME? What happens if the remote system doesn't use our local + ;; directory-sep-char as its separator? Would it be safer to just + ;; use '/' unconditionally and rely on the FTP server to + ;; straighten it out for us? + (if (and (file-directory-p filename) + (not (string-match (format "%c$" directory-sep-char) filename))) + (url-set-filename url + (format "%s%c" filename directory-sep-char))) + + ;; If it is a directory, look for an index file first. + (if (and (file-directory-p filename) + url-directory-index-file + (setq pos-index (expand-file-name url-directory-index-file filename)) + (file-exists-p pos-index) + (file-readable-p pos-index)) + (setq filename pos-index)) + + ;; Find the (possibly compressed) file + (setq filename (url-file-find-possibly-compressed-file filename)) + filename)) + +;;;###autoload +(defun url-file (url callback cbargs) + "Handle file: and ftp: URLs." + (let* ((buffer nil) + (uncompressed-filename nil) + (content-type nil) + (content-encoding nil) + (coding-system-for-read 'binary)) + + (setq filename (url-file-build-filename url)) + + (if (not filename) + (error "File does not exist: %s" (url-recreate-url url))) + + ;; Need to figure out the content-type from the real extension, + ;; not the compressed one. + (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename) + (substring filename 0 (match-beginning 0)) + filename)) + (setq content-type (mailcap-extension-to-mime + (url-file-extension uncompressed-filename)) + content-encoding (case (intern (url-file-extension filename)) + ((\.z \.gz) "gzip") + (\.Z "compress") + (\.uue "x-uuencoded") + (\.hqx "x-hqx") + (\.bz2 "x-bzip2") + (otherwise nil))) + + (if (file-directory-p filename) + ;; A directory is done the same whether we are local or remote + (url-find-file-dired filename) + (save-excursion + (setq buffer (generate-new-buffer " *url-file*")) + (set-buffer buffer) + (mm-disable-multibyte) + (setq url-current-object url) + (insert "Content-type: " (or content-type "application/octet-stream") "\n") + (if content-encoding + (insert "Content-transfer-encoding: " content-encoding "\n")) + (if (url-file-host-is-local-p (url-host url)) + ;; Local files are handled slightly oddly + (if (featurep 'ange-ftp) + (url-file-asynch-callback nil nil + filename + (current-buffer) + callback cbargs) + (url-file-asynch-callback nil nil nil + filename + (current-buffer) + callback cbargs)) + ;; FTP handling + (let* ((extension (url-file-extension filename)) + (new (url-generate-unique-filename + (and (> (length extension) 0) + (concat "%s." extension))))) + (if (featurep 'ange-ftp) + (ange-ftp-copy-file-internal filename (expand-file-name new) t + nil t + (list 'url-file-asynch-callback + new (current-buffer) + callback cbargs) + t) + (autoload 'efs-copy-file-internal "efs") + (efs-copy-file-internal filename (efs-ftp-path filename) + new (efs-ftp-path new) + t nil 0 + (list 'url-file-asynch-callback + new (current-buffer) + callback cbargs) + 0 nil)))))) + buffer)) + +(defmacro url-file-create-wrapper (method args) + (` (defalias (quote (, (intern (format "url-ftp-%s" method)))) + (defun (, (intern (format "url-file-%s" method))) (, args) + (, (format "FTP/FILE URL wrapper around `%s' call." method)) + (setq url (url-file-build-filename url)) + (and url ((, method) (,@ (remove '&rest (remove '&optional args))))))))) + +(url-file-create-wrapper file-exists-p (url)) +(url-file-create-wrapper file-attributes (url)) +(url-file-create-wrapper file-symlink-p (url)) +(url-file-create-wrapper file-readable-p (url)) +(url-file-create-wrapper file-writable-p (url)) +(url-file-create-wrapper file-executable-p (url)) +(if (featurep 'xemacs) + (progn + (url-file-create-wrapper directory-files (url &optional full match nosort files-only)) + (url-file-create-wrapper file-truename (url &optional default))) + (url-file-create-wrapper directory-files (url &optional full match nosort)) + (url-file-create-wrapper file-truename (url &optional counter prev-dirs))) + +(provide 'url-file) + +;;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-ftp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-ftp.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,46 @@ +;;; url-ftp.el --- FTP wrapper +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; We knew not what we did when we overloaded 'file' to mean 'file' +;; and 'ftp' back in the dark ages of the web. +;; +;; This stub file is just here to please the auto-scheme-loading code +;; in url-methods.el and just maps everything onto the code in +;; url-file. + +(require 'url-parse) +(require 'url-file) + +(defconst url-ftp-default-port 21 "Default FTP port.") +(defconst url-ftp-asynchronous-p t "FTP transfers are asynchronous.") +(defalias 'url-ftp-expand-file-name 'url-default-expander) +(defalias 'url-ftp 'url-file) + +(provide 'url-ftp) + +;;; arch-tag: 9c3e70c4-350f-4d4a-bb51-a1e9b459e7dc diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-gw.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-gw.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,266 @@ +;;; url-gw.el --- Gateway munging for URL loading +;; Author: Bill Perry +;; Created: $Date: 2004/04/04 04:44:10 $ +;; $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1997, 1998 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(eval-when-compile (require 'cl)) +(require 'url-vars) + +;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program? + +(autoload 'socks-open-network-stream "socks") +(autoload 'open-ssl-stream "ssl") + +(defgroup url-gateway nil + "URL gateway variables" + :group 'url) + +(defcustom url-gateway-local-host-regexp nil + "*A regular expression specifying local hostnames/machines." + :type '(choice (const nil) regexp) + :group 'url-gateway) + +(defcustom url-gateway-prompt-pattern + "^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?" + "*A regular expression matching a shell prompt." + :type 'regexp + :group 'url-gateway) + +(defcustom url-gateway-rlogin-host nil + "*What hostname to actually rlog into before doing a telnet." + :type '(choice (const nil) string) + :group 'url-gateway) + +(defcustom url-gateway-rlogin-user-name nil + "*Username to log into the remote machine with when using rlogin." + :type '(choice (const nil) string) + :group 'url-gateway) + +(defcustom url-gateway-rlogin-parameters '("telnet" "-8") + "*Parameters to `url-open-rlogin'. +This list will be used as the parameter list given to rsh." + :type '(repeat string) + :group 'url-gateway) + +(defcustom url-gateway-telnet-host nil + "*What hostname to actually login to before doing a telnet." + :type '(choice (const nil) string) + :group 'url-gateway) + +(defcustom url-gateway-telnet-parameters '("exec" "telnet" "-8") + "*Parameters to `url-open-telnet'. +This list will be executed as a command after logging in via telnet." + :type '(repeat string) + :group 'url-gateway) + +(defcustom url-gateway-telnet-login-prompt "^\r*.?login:" + "*Prompt that tells us we should send our username when loggin in w/telnet." + :type 'regexp + :group 'url-gateway) + +(defcustom url-gateway-telnet-password-prompt "^\r*.?password:" + "*Prompt that tells us we should send our password when loggin in w/telnet." + :type 'regexp + :group 'url-gateway) + +(defcustom url-gateway-telnet-user-name nil + "User name to log in via telnet with." + :type '(choice (const nil) string) + :group 'url-gateway) + +(defcustom url-gateway-telnet-password nil + "Password to use to log in via telnet with." + :type '(choice (const nil) string) + :group 'url-gateway) + +(defcustom url-gateway-broken-resolution nil + "*Whether to use nslookup to resolve hostnames. +This should be used when your version of Emacs cannot correctly use DNS, +but your machine can. This usually happens if you are running a statically +linked Emacs under SunOS 4.x" + :type 'boolean + :group 'url-gateway) + +(defcustom url-gateway-nslookup-program "nslookup" + "*If non-NIL then a string naming nslookup program." + :type '(choice (const :tag "None" :value nil) string) + :group 'url-gateway) + +;; Stolen from ange-ftp +;;;###autoload +(defun url-gateway-nslookup-host (host) + "Attempt to resolve the given HOST using nslookup if possible." + (interactive "sHost: ") + (if url-gateway-nslookup-program + (let ((proc (start-process " *nslookup*" " *nslookup*" + url-gateway-nslookup-program host)) + (res host)) + (process-kill-without-query proc) + (save-excursion + (set-buffer (process-buffer proc)) + (while (memq (process-status proc) '(run open)) + (accept-process-output proc)) + (goto-char (point-min)) + (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t) + (setq res (buffer-substring (match-beginning 1) + (match-end 1)))) + (kill-buffer (current-buffer))) + res) + host)) + +;; Stolen from red gnus nntp.el +(defun url-wait-for-string (regexp proc) + "Wait until string matching REGEXP arrives in process PROC's buffer." + (let ((buf (current-buffer))) + (goto-char (point-min)) + (while (not (re-search-forward regexp nil t)) + (accept-process-output proc) + (set-buffer buf) + (goto-char (point-min))))) + +;; Stolen from red gnus nntp.el +(defun url-open-rlogin (name buffer host service) + "Open a connection using rsh." + (if (not (stringp service)) + (setq service (int-to-string service))) + (let ((proc (if url-gateway-rlogin-user-name + (start-process + name buffer "rsh" + url-gateway-rlogin-host "-l" url-gateway-rlogin-user-name + (mapconcat 'identity + (append url-gateway-rlogin-parameters + (list host service)) " ")) + (start-process + name buffer "rsh" url-gateway-rlogin-host + (mapconcat 'identity + (append url-gateway-rlogin-parameters + (list host service)) + " "))))) + (set-buffer buffer) + (url-wait-for-string "^\r*200" proc) + (beginning-of-line) + (delete-region (point-min) (point)) + proc)) + +;; Stolen from red gnus nntp.el +(defun url-open-telnet (name buffer host service) + (if (not (stringp service)) + (setq service (int-to-string service))) + (save-excursion + (set-buffer (get-buffer-create buffer)) + (erase-buffer) + (let ((proc (start-process name buffer "telnet" "-8")) + (case-fold-search t)) + (when (memq (process-status proc) '(open run)) + (process-send-string proc "set escape \^X\n") + (process-send-string proc (concat + "open " url-gateway-telnet-host "\n")) + (url-wait-for-string url-gateway-telnet-login-prompt proc) + (process-send-string + proc (concat + (or url-gateway-telnet-user-name + (setq url-gateway-telnet-user-name (read-string "login: "))) + "\n")) + (url-wait-for-string url-gateway-telnet-password-prompt proc) + (process-send-string + proc (concat + (or url-gateway-telnet-password + (setq url-gateway-telnet-password + (funcall url-passwd-entry-func "Password: "))) + "\n")) + (erase-buffer) + (url-wait-for-string url-gateway-prompt-pattern proc) + (process-send-string + proc (concat (mapconcat 'identity + (append url-gateway-telnet-parameters + (list host service)) " ") "\n")) + (url-wait-for-string "^\r*Escape character.*\r*\n+" proc) + (delete-region (point-min) (match-end 0)) + (process-send-string proc "\^]\n") + (url-wait-for-string "^telnet" proc) + (process-send-string proc "mode character\n") + (accept-process-output proc 1) + (sit-for 1) + (goto-char (point-min)) + (forward-line 1) + (delete-region (point) (point-max))) + proc))) + +;;;###autoload +(defun url-open-stream (name buffer host service) + "Open a stream to HOST, possibly via a gateway. +Args per `open-network-stream'. +Will not make a connexion if `url-gateway-unplugged' is non-nil." + (unless url-gateway-unplugged + (let ((gw-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)) +;;; ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF +;;; ;; conversions while trying to be 'helpful' +;;; (tcp-binary-process-output-services (if (stringp service) +;;; (list service) +;;; (list service +;;; (int-to-string service)))) + + ;; An attempt to deal with denied connections, and attempt + ;; to reconnect + (cur-retries 0) + (retry t) + (errobj nil) + (conn nil)) + + ;; If the user told us to do DNS for them, do it. + (if url-gateway-broken-resolution + (setq host (url-gateway-nslookup-host host))) + + (condition-case errobj + ;; This is a clean way to ensure the new process inherits the + ;; right coding systems in both Emacs and XEmacs. + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (setq conn (case gw-method + (ssl + (open-ssl-stream name buffer host service)) + ((native) + (open-network-stream name buffer host service)) + (socks + (socks-open-network-stream name buffer host service)) + (telnet + (url-open-telnet name buffer host service)) + (rlogin + (url-open-rlogin name buffer host service)) + (otherwise + (error "Bad setting of url-gateway-method: %s" + url-gateway-method))))) + (error + (setq conn nil))) + conn))) + +(provide 'url-gw) + +;;; arch-tag: 1c4c0317-6d03-45b8-b3f3-838bd8f9d838 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-handlers.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-handlers.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,254 @@ +;;; url-handlers.el --- file-name-handler stuff for URL loading +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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 'url) +(require 'url-parse) +(require 'url-util) +(require 'mm-decode) +(require 'mailcap) + +(eval-when-compile + (require 'cl)) + +;; Implementation status +;; --------------------- +;; Function Status +;; ------------------------------------------------------------ +;; add-name-to-file Needs DAV Bindings +;; copy-file Broken (assumes 1st item is URL) +;; delete-directory Finished (DAV) +;; delete-file Finished (DAV) +;; diff-latest-backup-file +;; directory-file-name unnecessary (what about VMS)? +;; directory-files Finished (DAV) +;; dired-call-process +;; dired-compress-file +;; dired-uncache +;; expand-file-name Finished +;; file-accessible-directory-p +;; file-attributes Finished, better with DAV +;; file-directory-p Needs DAV, finished +;; file-executable-p Finished +;; file-exists-p Finished +;; file-local-copy +;; file-modes +;; file-name-all-completions Finished (DAV) +;; file-name-as-directory +;; file-name-completion Finished (DAV) +;; file-name-directory +;; file-name-nondirectory +;; file-name-sans-versions why? +;; file-newer-than-file-p +;; file-ownership-preserved-p No way to know +;; file-readable-p Finished +;; file-regular-p !directory_p +;; file-symlink-p Needs DAV bindings +;; file-truename Needs DAV bindings +;; file-writable-p Check for LOCK? +;; find-backup-file-name why? +;; get-file-buffer why? +;; insert-directory Use DAV +;; insert-file-contents Finished +;; load +;; make-directory Finished (DAV) +;; make-symbolic-link Needs DAV bindings +;; rename-file Finished (DAV) +;; set-file-modes Use mod_dav specific executable flag? +;; set-visited-file-modtime Impossible? +;; shell-command Impossible? +;; unhandled-file-name-directory +;; vc-registered Finished (DAV) +;; verify-visited-file-modtime +;; write-region + +(defvar url-handler-regexp + "\\`\\(https?\\|ftp\\|file\\|nfs\\)://" + "*A regular expression for matching URLs handled by file-name-handler-alist. +Some valid URL protocols just do not make sense to visit interactively +\(about, data, info, irc, mailto, etc\). This regular expression +avoids conflicts with local files that look like URLs \(Gnus is +particularly bad at this\).") + +;;;###autoload +(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 + (t + (push (cons url-handler-regexp 'url-file-handler) + file-name-handler-alist)))) + +(defun url-run-real-handler (operation args) + (let ((inhibit-file-name-handlers (cons 'url-file-handler + (if (eq operation inhibit-file-name-operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +(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 (or (get operation 'url-file-handlers) + (intern-soft (format "url-%s" operation)))) + (val nil) + (hooked nil)) + (if (and fn (fboundp fn)) + (setq hooked t + val (apply fn args)) + (setq hooked nil + val (url-run-real-handler operation args))) + (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real") + operation args val) + val)) + +(defun url-file-handler-identity (&rest args) + ;; Identity function + (car args)) + +;; These are operations that we can fully support +(put 'file-readable-p 'url-file-handlers 'url-file-exists-p) +(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity) +(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t)) +(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name) + +;; These are operations that we do not support yet (DAV!!!) +(put 'file-writable-p 'url-file-handlers 'ignore) +(put 'file-symlink-p 'url-file-handlers 'ignore) + +(defun url-handler-expand-file-name (file &optional base) + (if (file-name-absolute-p file) + (expand-file-name file "/") + (url-expand-file-name file base))) + +;; The actual implementation +;;;###autoload +(defun url-copy-file (url newname &optional ok-if-already-exists keep-time) + "Copy URL to NEWNAME. Both args must be strings. +Signals a `file-already-exists' error if file NEWNAME already exists, +unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil. +A number as third arg means request confirmation if NEWNAME already exists. +This is what happens in interactive use with M-x. +Fourth arg KEEP-TIME non-nil means give the new file the same +last-modified time as the old one. (This works on only some systems.) +A prefix arg makes KEEP-TIME non-nil." + (if (and (file-exists-p newname) + (not ok-if-already-exists)) + (error "Opening output file: File already exists, %s" newname)) + (let ((buffer (url-retrieve-synchronously url)) + (handle nil)) + (if (not buffer) + (error "Opening input file: No such file or directory, %s" url)) + (save-excursion + (set-buffer buffer) + (setq handle (mm-dissect-buffer t))) + (mm-save-part-to-file handle newname) + (kill-buffer buffer) + (mm-destroy-parts handle))) + +;;;###autoload +(defun url-file-local-copy (url &rest ignored) + "Copy URL into a temporary file on this machine. +Returns the name of the local copy, or nil, if FILE is directly +accessible." + (let ((filename (make-temp-name "url"))) + (url-copy-file url filename) + filename)) + +;;;###autoload +(defun url-insert-file-contents (url &optional visit beg end replace) + (let ((buffer (url-retrieve-synchronously url)) + (handle nil) + (data nil)) + (if (not buffer) + (error "Opening input file: No such file or directory, %s" url)) + (if visit (setq buffer-file-name url)) + (save-excursion + (set-buffer buffer) + (setq handle (mm-dissect-buffer t)) + (set-buffer (mm-handle-buffer handle)) + (if beg + (setq data (buffer-substring beg end)) + (setq data (buffer-string)))) + (kill-buffer buffer) + (mm-destroy-parts handle) + (if replace (delete-region (point-min) (point-max))) + (save-excursion + (insert data)) + (list url (length data)))) + +(defun url-file-name-completion (url directory) + (error "Unimplemented")) + +(defun url-file-name-all-completions (file directory) + (error "Unimplemented")) + +;; All other handlers map onto their respective backends. +(defmacro url-handlers-create-wrapper (method args) + `(defun ,(intern (format "url-%s" method)) ,args + ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method + (or (documentation method t) "No original documentation.")) + (setq url (url-generic-parse-url url)) + (when (url-type url) + (funcall (url-scheme-get-property (url-type url) (quote ,method)) + ,@(remove '&rest (remove '&optional args)))))) + +(url-handlers-create-wrapper file-exists-p (url)) +(url-handlers-create-wrapper file-attributes (url)) +(url-handlers-create-wrapper file-symlink-p (url)) +(url-handlers-create-wrapper file-writable-p (url)) +(url-handlers-create-wrapper file-directory-p (url)) +(url-handlers-create-wrapper file-executable-p (url)) + +(if (featurep 'xemacs) + (progn + ;; XEmacs specific prototypes + (url-handlers-create-wrapper + directory-files (url &optional full match nosort files-only)) + (url-handlers-create-wrapper + file-truename (url &optional default))) + ;; Emacs specific prototypes + (url-handlers-create-wrapper + directory-files (url &optional full match nosort)) + (url-handlers-create-wrapper + file-truename (url &optional counter prev-dirs))) + +(add-hook 'find-file-hooks 'url-handlers-set-buffer-mode) + +(defun url-handlers-set-buffer-mode () + "Set correct modes for the current buffer if visiting a remote file." + (and (stringp buffer-file-name) + (string-match url-handler-regexp buffer-file-name) + (auto-save-mode 0))) + +(provide 'url-handlers) + +;;; arch-tag: 7300b99c-cc83-42ff-9147-79b2723c62ac diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-history.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-history.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,201 @@ +;;; url-history.el --- Global history tracking for URL package +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; This can get a recursive require. +;;(require 'url) +(eval-when-compile (require 'cl)) +(require 'url-parse) +(autoload 'url-do-setup "url") + +(defgroup url-history nil + "History variables in the URL package" + :prefix "url-history" + :group 'url) + +(defcustom url-history-track 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." + :type 'boolean + :group 'url-history) + +(defcustom url-history-file nil + "*The global history file for 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." + :type '(choice (const :tag "Default" :value nil) file) + :group 'url-history) + +(defcustom url-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 outside of +the `customize' interface after `url-do-setup' has been run, you need +to run the `url-history-setup-save-timer' function manually." + :set (function (lambda (var val) + (set-default var val) + (and (featurep 'url) + (fboundp 'url-history-setup-save-timer) + (let ((def (symbol-function + 'url-history-setup-save-timer))) + (not (and (listp def) (eq 'autoload (car def))))) + (url-history-setup-save-timer)))) + :type 'integer + :group 'url-history) + +(defvar url-history-timer nil) + +(defvar url-history-list nil + "List of urls visited this session.") + +(defvar url-history-changed-since-last-save nil + "Whether the history list has changed since the last save operation.") + +(defvar url-history-hash-table nil + "Hash table for global history completion.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;###autoload +(defun url-history-setup-save-timer () + "Reset the history list timer." + (interactive) + (cond + ((featurep 'itimer) + (ignore-errors (delete-itimer url-history-timer)) + (setq url-history-timer nil) + (if url-history-save-interval + (setq url-history-timer + (start-itimer "url-history-saver" 'url-history-save-history + url-history-save-interval + url-history-save-interval)))) + ((fboundp 'run-at-time) + (ignore-errors (cancel-timer url-history-timer)) + (setq url-history-timer nil) + (if url-history-save-interval + (setq url-history-timer + (run-at-time url-history-save-interval + url-history-save-interval + 'url-history-save-history)))) + (t nil))) + +;;;###autoload +(defun url-history-parse-history (&optional fname) + "Parse a history file stored in FNAME." + ;; Parse out the mosaic global history file for completions, etc. + (or fname (setq fname (expand-file-name url-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 nil + (load fname nil t) + (error (message "Could not load %s" fname))))) + (if (not url-history-hash-table) + (setq url-history-hash-table (make-hash-table :size 31 :test 'equal)))) + +(defun url-history-update-url (url time) + (setq url-history-changed-since-last-save t) + (puthash (if (vectorp url) (url-recreate-url url) url) time url-history-hash-table)) + +;;;###autoload +(defun url-history-save-history (&optional fname) + "Write the global history file into `url-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-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) + (let ((count 0)) + (maphash (function + (lambda (key value) + (while (string-match "[\r\n]+" key) + (setq key (concat (substring key 0 (match-beginning 0)) + (substring key (match-end 0) nil)))) + (setq count (1+ count)) + (insert "(puthash \"" key "\"" + (if (not (stringp value)) " '" "") + (prin1-to-string value) + " url-history-hash-table)\n"))) + url-history-hash-table) + (goto-char (point-min)) + (insert (format + "(setq url-history-hash-table (make-hash-table :size %d :test 'equal))\n" + (/ count 4))) + (goto-char (point-max)) + (insert "\n") + (write-file fname)) + (kill-buffer (current-buffer)))))) + (setq url-history-changed-since-last-save nil)) + +(defun url-have-visited-url (url) + (url-do-setup) + (gethash url url-history-hash-table nil)) + +(defun url-completion-function (string predicate function) + (url-do-setup) + (cond + ((eq function nil) + (let ((list nil)) + (maphash (function (lambda (key val) + (setq list (cons (cons key val) + list)))) + url-history-hash-table) + (try-completion string (nreverse list) predicate))) + ((eq function t) + (let ((stub (concat "^" (regexp-quote string))) + (retval nil)) + (maphash + (function + (lambda (url time) + (if (string-match stub url) + (setq retval (cons url retval))))) + url-history-hash-table) + retval)) + ((eq function 'lambda) + (and url-history-hash-table + (gethash string url-history-hash-table) + t)) + (t + (error "url-completion-function very confused.")))) + +(provide 'url-history) + +;;; arch-tag: fbbbaf63-db36-4e88-bc9f-2939aa93afb2 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-http.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-http.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,1224 @@ +;;; url-http.el --- HTTP retrieval routines +;; Author: Bill Perry +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1999, 2001 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile + (require 'cl) + (defvar url-http-extra-headers)) +(require 'url-gw) +(require 'url-util) +(require 'url-parse) +(require 'url-cookie) +(require 'mail-parse) +(require 'url-auth) +(autoload 'url-retrieve-synchronously "url") +(autoload 'url-retrieve "url") +(autoload 'url-cache-create-filename "url-cache") +(autoload 'url-mark-buffer-as-dead "url") + +(defconst url-http-default-port 80 "Default HTTP port.") +(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.") +(defalias 'url-http-expand-file-name 'url-default-expander) + +(defvar url-http-real-basic-auth-storage nil) +(defvar url-http-proxy-basic-auth-storage nil) + +(defvar url-http-open-connections (make-hash-table :test 'equal + :size 17) + "A hash table of all open network connections.") + +(defvar url-http-version "1.1" + "What version of HTTP we advertise, as a string. +Valid values are 1.1 and 1.0. +This is only useful when debugging the HTTP subsystem. + +Setting this to 1.0 will tell servers not to send chunked encoding, +and other HTTP/1.1 specific features. +") + +(defvar url-http-attempt-keepalives t + "Whether to use a single TCP connection multiple times in HTTP. +This is only useful when debugging the HTTP subsystem. Setting to +`nil' will explicitly close the connection to the server after every +request. +") + +;(eval-when-compile +;; These are all macros so that they are hidden from external sight +;; when the file is byte-compiled. +;; +;; This allows us to expose just the entry points we want. + +;; These routines will allow us to implement persistent HTTP +;; connections. +(defsubst url-http-debug (&rest args) + (if quit-flag + (let ((proc (get-buffer-process (current-buffer)))) + ;; The user hit C-g, honor it! Some things can get in an + ;; incredibly tight loop (chunked encoding) + (if proc + (progn + (set-process-sentinel proc nil) + (set-process-filter proc nil))) + (error "Transfer interrupted!"))) + (apply 'url-debug 'http args)) + +(defun url-http-mark-connection-as-busy (host port proc) + (url-http-debug "Marking connection as busy: %s:%d %S" host port proc) + (puthash (cons host port) + (delq proc (gethash (cons host port) url-http-open-connections)) + url-http-open-connections) + proc) + +(defun url-http-mark-connection-as-free (host port proc) + (url-http-debug "Marking connection as free: %s:%d %S" host port proc) + (set-process-buffer proc nil) + (set-process-sentinel proc 'url-http-idle-sentinel) + (puthash (cons host port) + (cons proc (gethash (cons host port) url-http-open-connections)) + url-http-open-connections) + nil) + +(defun url-http-find-free-connection (host port) + (let ((conns (gethash (cons host port) url-http-open-connections)) + (found nil)) + (while (and conns (not found)) + (if (not (memq (process-status (car conns)) '(run open))) + (progn + (url-http-debug "Cleaning up dead process: %s:%d %S" + host port (car conns)) + (url-http-idle-sentinel (car conns) nil)) + (setq found (car conns)) + (url-http-debug "Found existing connection: %s:%d %S" host port found)) + (pop conns)) + (if found + (url-http-debug "Reusing existing connection: %s:%d" host port) + (url-http-debug "Contacting host: %s:%d" host port)) + (url-lazy-message "Contacting host: %s:%d" host port) + (url-http-mark-connection-as-busy host port + (or found + (url-open-stream host nil host + port))))) + +;; Building an HTTP request +(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: %sURL/%s%s\r\n" + (if url-package-name + (concat 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-http-create-request (url &optional ref-url) + "Create an HTTP request for URL, referred to by REF-URL." + (declare (special proxy-object proxy-info)) + (let* ((extra-headers) + (request nil) + (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers))) + (proxy-obj (and (boundp 'proxy-object) proxy-object)) + (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization" + url-request-extra-headers)) + (not proxy-obj)) + nil + (let ((url-basic-auth-storage + 'url-http-proxy-basic-auth-storage)) + (url-get-authentication url nil 'any nil)))) + (real-fname (if proxy-obj (url-recreate-url proxy-obj) + (url-filename url))) + (host (url-host (or proxy-obj url))) + (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)))) + (if (equal "" real-fname) + (setq real-fname "/")) + (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"))) + + ;; Protection against stupid values in the referer + (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil") + (string= ref-url ""))) + (setq ref-url nil)) + + ;; We do not want to expose the referer if the user is paranoid. + (if (or (memq url-privacy-level '(low high paranoid)) + (and (listp url-privacy-level) + (memq 'lastloc url-privacy-level))) + (setq ref-url nil)) + + ;; url-request-extra-headers contains an assoc-list of + ;; header/value pairs that we need to put into the request. + (setq extra-headers (mapconcat + (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"))) + + ;; This was done with a call to `format'. Concatting parts has + ;; the advantage of keeping the parts of each header togther and + ;; allows us to elide null lines directly, at the cost of making + ;; the layout less clear. + (setq request + (concat + ;; The request + (or url-request-method "GET") " " real-fname " HTTP/" url-http-version "\r\n" + ;; Version of MIME we speak + "MIME-Version: 1.0\r\n" + ;; (maybe) Try to keep the connection open + "Connection: " (if (or proxy-obj + (not url-http-attempt-keepalives)) + "close" "keep-alive") "\r\n" + ;; HTTP extensions we support + (if url-extensions-header + (format + "Extension: %s\r\n" url-extensions-header)) + ;; Who we want to talk to + (if (/= (url-port (or proxy-obj url)) + (url-scheme-get-property + (url-type (or proxy-obj url)) 'default-port)) + (format + "Host: %s:%d\r\n" host (url-port (or proxy-obj url))) + (format "Host: %s\r\n" host)) + ;; Who its from + (if url-personal-mail-address + (concat + "From: " url-personal-mail-address "\r\n")) + ;; Encodings we understand + (if url-mime-encoding-string + (concat + "Accept-encoding: " url-mime-encoding-string "\r\n")) + (if url-mime-charset-string + (concat + "Accept-charset: " url-mime-charset-string "\r\n")) + ;; Languages we understand + (if url-mime-language-string + (concat + "Accept-language: " url-mime-language-string "\r\n")) + ;; Types we understand + "Accept: " (or url-mime-accept-string "*/*") "\r\n" + ;; User agent + (url-http-user-agent-string) + ;; Proxy Authorization + proxy-auth + ;; Authorization + auth + ;; Cookies + (url-cookie-generate-header-lines host real-fname + (equal "https" (url-type url))) + ;; If-modified-since + (if (and (not no-cache) + (member url-request-method '("GET" nil))) + (let ((tm (url-is-cached (or proxy-obj url)))) + (if tm + (concat "If-modified-since: " + (url-get-normalized-date tm) "\r\n")))) + ;; Whence we came + (if ref-url (concat + "Referer: " ref-url "\r\n")) + extra-headers + ;; Any data + (if url-request-data + (concat + "Content-length: " (number-to-string + (length url-request-data)) + "\r\n\r\n" + url-request-data)) + ;; End request + "\r\n")) + (url-http-debug "Request is: \n%s" request) + request)) + +;; Parsing routines +(defun url-http-clean-headers () + "Remove trailing \r from header lines. +This allows us to use `mail-fetch-field', etc." + (declare (special url-http-end-of-headers)) + (goto-char (point-min)) + (while (re-search-forward "\r$" url-http-end-of-headers t) + (replace-match ""))) + +(defun url-http-handle-authentication (proxy) + (declare (special status success url-http-method url-http-data + url-callback-function url-callback-arguments)) + (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal")) + (let ((auth (or (mail-fetch-field (if proxy "proxy-authenticate" "www-authenticate")) + "basic")) + (type nil) + (url (url-recreate-url url-current-object)) + (url-basic-auth-storage 'url-http-real-basic-auth-storage) + ) + + ;; Cheating, but who cares? :) + (if proxy + (setq url-basic-auth-storage 'url-http-proxy-basic-auth-storage)) + + (setq auth (url-eat-trailing-space (url-strip-leading-spaces auth))) + (if (string-match "[ \t]" auth) + (setq type (downcase (substring auth 0 (match-beginning 0)))) + (setq type (downcase auth))) + + (if (not (url-auth-registered type)) + (progn + (widen) + (goto-char (point-max)) + (insert "
Sorry, but I do not know how to handle " type + " authentication. If you'd like to write it," + " send it to " url-bug-address ".
") + (setq status t)) + (let* ((args auth) + (ctr (1- (length args))) + auth) + (while (/= 0 ctr) + (if (char-equal ?, (aref args ctr)) + (aset args ctr ?\;)) + (setq ctr (1- ctr))) + (setq args (url-parse-args args) + auth (url-get-authentication url (cdr-safe (assoc "realm" args)) + type t args)) + (if (not auth) + (setq success t) + (push (cons (if proxy "Proxy-Authorization" "Authorization") auth) + url-http-extra-headers) + (let ((url-request-method url-http-method) + (url-request-data url-http-data) + (url-request-extra-headers url-http-extra-headers)) + (url-retrieve url url-callback-function url-callback-arguments)))) + (kill-buffer (current-buffer))))) + +(defun url-http-parse-response () + "Parse just the response code." + (declare (special url-http-end-of-headers url-http-response-status)) + (if (not url-http-end-of-headers) + (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) + (url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) + (goto-char (point-min)) + (skip-chars-forward " \t\n") ; Skip any blank crap + (skip-chars-forward "HTTP/") ; Skip HTTP Version + (read (current-buffer)) + (setq url-http-response-status (read (current-buffer)))) + +(defun url-http-handle-cookies () + "Handle all set-cookie / set-cookie2 headers in an HTTP response. +The buffer must already be narrowed to the headers, so mail-fetch-field will +work correctly." + (let ((cookies (mail-fetch-field "Set-Cookie" nil nil t)) + (cookies2 (mail-fetch-field "Set-Cookie2" nil nil t))) + (and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies))) + (and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2))) + (while cookies + (url-cookie-handle-set-cookie (pop cookies))) +;;; (while cookies2 +;;; (url-cookie-handle-set-cookie2 (pop cookies))) + ) + ) + +(defun url-http-parse-headers () + "Parse and handle HTTP specific headers. +Return t if and only if the current buffer is still active and +should be shown to the user." + ;; The comments after each status code handled are taken from RFC + ;; 2616 (HTTP/1.1) + (declare (special url-http-end-of-headers url-http-response-status + url-http-method url-http-data url-http-process + url-callback-function url-callback-arguments)) + + (url-http-mark-connection-as-free (url-host url-current-object) + (url-port url-current-object) + url-http-process) + + (if (or (not (boundp 'url-http-end-of-headers)) + (not url-http-end-of-headers)) + (error "Trying to parse headers in odd buffer: %s" (buffer-name))) + (goto-char (point-min)) + (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name)) + (url-http-parse-response) + (mail-narrow-to-head) + ;;(narrow-to-region (point-min) url-http-end-of-headers) + (let ((version nil) + (class nil) + (success nil)) + (setq class (/ url-http-response-status 100)) + (url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status) + (url-http-handle-cookies) + + (case class + ;; Classes of response codes + ;; + ;; 5xx = Server Error + ;; 4xx = Client Error + ;; 3xx = Redirection + ;; 2xx = Successful + ;; 1xx = Informational + (1 ; Information messages + ;; 100 = Continue with request + ;; 101 = Switching protocols + ;; 102 = Processing (Added by DAV) + (url-mark-buffer-as-dead (current-buffer)) + (error "HTTP responses in class 1xx not supported (%d)" url-http-response-status)) + (2 ; Success + ;; 200 Ok + ;; 201 Created + ;; 202 Accepted + ;; 203 Non-authoritative information + ;; 204 No content + ;; 205 Reset content + ;; 206 Partial content + ;; 207 Multi-status (Added by DAV) + (case url-http-response-status + ((204 205) + ;; No new data, just stay at the same document + (url-mark-buffer-as-dead (current-buffer)) + (setq success t)) + (otherwise + ;; Generic success for all others. Store in the cache, and + ;; mark it as successful. + (widen) + (if (equal url-http-method "GET") + (url-store-in-cache (current-buffer))) + (setq success t)))) + (3 ; Redirection + ;; 300 Multiple choices + ;; 301 Moved permanently + ;; 302 Found + ;; 303 See other + ;; 304 Not modified + ;; 305 Use proxy + ;; 307 Temporary redirect + (let ((redirect-uri (or (mail-fetch-field "Location") + (mail-fetch-field "URI")))) + (case url-http-response-status + (300 + ;; Quoth the spec (section 10.3.1) + ;; ------------------------------- + ;; The requested resource corresponds to any one of a set of + ;; representations, each with its own specific location and + ;; agent-driven negotiation information is being provided so + ;; that the user can select a preferred representation and + ;; redirect its request to that location. + ;; [...] + ;; If the server has a preferred choice of representation, it + ;; SHOULD include the specific URI for that representation in + ;; the Location field; user agents MAY use the Location field + ;; value for automatic redirection. + ;; ------------------------------- + ;; We do not support agent-driven negotiation, so we just + ;; redirect to the preferred URI if one is provided. + nil) + ((301 302 307) + ;; If the 301|302 status code is received in response to a + ;; request other than GET or HEAD, the user agent MUST NOT + ;; automatically redirect the request unless it can be + ;; confirmed by the user, since this might change the + ;; conditions under which the request was issued. + (if (member url-http-method '("HEAD" "GET")) + ;; Automatic redirection is ok + nil + ;; It is just too big of a pain in the ass to get this + ;; prompt all the time. We will just silently lose our + ;; data and convert to a GET method. + (url-http-debug "Converting `%s' request to `GET' because of REDIRECT(%d)" + url-http-method url-http-response-status) + (setq url-http-method "GET" + url-request-data nil))) + (303 + ;; The response to the request can be found under a different + ;; URI and SHOULD be retrieved using a GET method on that + ;; resource. + (setq url-http-method "GET" + url-http-data nil)) + (304 + ;; The 304 response MUST NOT contain a message-body. + (url-http-debug "Extracting document from cache... (%s)" + (url-cache-create-filename (url-view-url t))) + (url-cache-extract (url-cache-create-filename (url-view-url t))) + (setq redirect-uri nil + success t)) + (305 + ;; The requested resource MUST be accessed through the + ;; proxy given by the Location field. The Location field + ;; gives the URI of the proxy. The recipient is expected + ;; to repeat this single request via the proxy. 305 + ;; responses MUST only be generated by origin servers. + (error "Redirection thru a proxy server not supported: %s" + redirect-uri)) + (otherwise + ;; Treat everything like '300' + nil)) + (when redirect-uri + ;; Clean off any whitespace and/or <...> cruft. + (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri) + (setq redirect-uri (match-string 1 redirect-uri))) + (if (string-match "^<\\(.*\\)>$" redirect-uri) + (setq redirect-uri (match-string 1 redirect-uri))) + + ;; Some stupid sites (like sourceforge) send a + ;; non-fully-qualified URL (ie: /), which royally confuses + ;; the URL library. + (if (not (string-match url-nonrelative-link redirect-uri)) + (setq redirect-uri (url-expand-file-name redirect-uri))) + (let ((url-request-method url-http-method) + (url-request-data url-http-data) + (url-request-extra-headers url-http-extra-headers)) + (url-retrieve redirect-uri url-callback-function + url-callback-arguments) + (url-mark-buffer-as-dead (current-buffer)))))) + (4 ; Client error + ;; 400 Bad Request + ;; 401 Unauthorized + ;; 402 Payment required + ;; 403 Forbidden + ;; 404 Not found + ;; 405 Method not allowed + ;; 406 Not acceptable + ;; 407 Proxy authentication required + ;; 408 Request time-out + ;; 409 Conflict + ;; 410 Gone + ;; 411 Length required + ;; 412 Precondition failed + ;; 413 Request entity too large + ;; 414 Request-URI too large + ;; 415 Unsupported media type + ;; 416 Requested range not satisfiable + ;; 417 Expectation failed + ;; 422 Unprocessable Entity (Added by DAV) + ;; 423 Locked + ;; 424 Failed Dependency + (case url-http-response-status + (401 + ;; The request requires user authentication. The response + ;; MUST include a WWW-Authenticate header field containing a + ;; challenge applicable to the requested resource. The + ;; client MAY repeat the request with a suitable + ;; Authorization header field. + (url-http-handle-authentication nil)) + (402 + ;; This code is reserved for future use + (url-mark-buffer-as-dead (current-buffer)) + (error "Somebody wants you to give them money")) + (403 + ;; The server understood the request, but is refusing to + ;; fulfill it. Authorization will not help and the request + ;; SHOULD NOT be repeated. + (setq success t)) + (404 + ;; Not found + (setq success t)) + (405 + ;; The method specified in the Request-Line is not allowed + ;; for the resource identified by the Request-URI. The + ;; response MUST include an Allow header containing a list of + ;; valid methods for the requested resource. + (setq success t)) + (406 + ;; The resource identified by the request is only capable of + ;; generating response entities which have content + ;; characteristics nota cceptable according to the accept + ;; headers sent in the request. + (setq success t)) + (407 + ;; This code is similar to 401 (Unauthorized), but indicates + ;; that the client must first authenticate itself with the + ;; proxy. The proxy MUST return a Proxy-Authenticate header + ;; field containing a challenge applicable to the proxy for + ;; the requested resource. + (url-http-handle-authentication t)) + (408 + ;; The client did not produce a request within the time that + ;; the server was prepared to wait. The client MAY repeat + ;; the request without modifications at any later time. + (setq success t)) + (409 + ;; The request could not be completed due to a conflict with + ;; the current state of the resource. This code is only + ;; allowed in situations where it is expected that the user + ;; mioght be able to resolve the conflict and resubmit the + ;; request. The response body SHOULD include enough + ;; information for the user to recognize the source of the + ;; conflict. + (setq success t)) + (410 + ;; The requested resource is no longer available at the + ;; server and no forwarding address is known. + (setq success t)) + (411 + ;; The server refuses to accept the request without a defined + ;; Content-Length. The client MAY repeat the request if it + ;; adds a valid Content-Length header field containing the + ;; length of the message-body in the request message. + ;; + ;; NOTE - this will never happen because + ;; `url-http-create-request' automatically calculates the + ;; content-length. + (setq success t)) + (412 + ;; The precondition given in one or more of the + ;; request-header fields evaluated to false when it was + ;; tested on the server. + (setq success t)) + ((413 414) + ;; The server is refusing to process a request because the + ;; request entity|URI is larger than the server is willing or + ;; able to process. + (setq success t)) + (415 + ;; The server is refusing to service the request because the + ;; entity of the request is in a format not supported by the + ;; requested resource for the requested method. + (setq success t)) + (416 + ;; A server SHOULD return a response with this status code if + ;; a request included a Range request-header field, and none + ;; of the range-specifier values in this field overlap the + ;; current extent of the selected resource, and the request + ;; did not include an If-Range request-header field. + (setq success t)) + (417 + ;; The expectation given in an Expect request-header field + ;; could not be met by this server, or, if the server is a + ;; proxy, the server has unambiguous evidence that the + ;; request could not be met by the next-hop server. + (setq success t)) + (otherwise + ;; The request could not be understood by the server due to + ;; malformed syntax. The client SHOULD NOT repeat the + ;; request without modifications. + (setq success t)))) + (5 + ;; 500 Internal server error + ;; 501 Not implemented + ;; 502 Bad gateway + ;; 503 Service unavailable + ;; 504 Gateway time-out + ;; 505 HTTP version not supported + ;; 507 Insufficient storage + (setq success t) + (case url-http-response-status + (501 + ;; The server does not support the functionality required to + ;; fulfill the request. + nil) + (502 + ;; The server, while acting as a gateway or proxy, received + ;; an invalid response from the upstream server it accessed + ;; in attempting to fulfill the request. + nil) + (503 + ;; The server is currently unable to handle the request due + ;; to a temporary overloading or maintenance of the server. + ;; The implication is that this is a temporary condition + ;; which will be alleviated after some delay. If known, the + ;; length of the delay MAY be indicated in a Retry-After + ;; header. If no Retry-After is given, the client SHOULD + ;; handle the response as it would for a 500 response. + nil) + (504 + ;; The server, while acting as a gateway or proxy, did not + ;; receive a timely response from the upstream server + ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other + ;; auxiliary server (e.g. DNS) it needed to access in + ;; attempting to complete the request. + nil) + (505 + ;; The server does not support, or refuses to support, the + ;; HTTP protocol version that was used in the request + ;; message. + nil) + (507 ; DAV + ;; The method could not be performed on the resource + ;; because the server is unable to store the representation + ;; needed to successfully complete the request. This + ;; condition is considered to be temporary. If the request + ;; which received this status code was the result of a user + ;; action, the request MUST NOT be repeated until it is + ;; requested by a separate user action. + nil))) + (otherwise + (error "Unknown class of HTTP response code: %d (%d)" + class url-http-response-status))) + (if (not success) + (url-mark-buffer-as-dead (current-buffer))) + (url-http-debug "Finished parsing HTTP headers: %S" success) + (widen) + success)) + +;; Miscellaneous +(defun url-http-activate-callback () + "Activate callback specified when this buffer was created." + (declare (special url-http-process + url-callback-function + url-callback-arguments)) + (url-http-mark-connection-as-free (url-host url-current-object) + (url-port url-current-object) + url-http-process) + (url-http-debug "Activating callback in buffer (%s)" (buffer-name)) + (apply url-callback-function url-callback-arguments)) + +;; ) + +;; These unfortunately cannot be macros... please ignore them! +(defun url-http-idle-sentinel (proc why) + "Remove this (now defunct) process PROC from the list of open connections." + (maphash (lambda (key val) + (if (memq proc val) + (puthash key (delq proc val) url-http-open-connections))) + url-http-open-connections)) + +(defun url-http-end-of-document-sentinel (proc why) + ;; Sentinel used for old HTTP/0.9 or connections we know are going + ;; to die as the 'end of document' notifier. + (url-http-debug "url-http-end-of-document-sentinel in buffer (%s)" + (process-buffer proc)) + (url-http-idle-sentinel proc why) + (save-excursion + (set-buffer (process-buffer proc)) + (goto-char (point-min)) + (if (not (looking-at "HTTP/")) + ;; HTTP/0.9 just gets passed back no matter what + (url-http-activate-callback) + (if (url-http-parse-headers) + (url-http-activate-callback))))) + +(defun url-http-simple-after-change-function (st nd length) + ;; Function used when we do NOT know how long the document is going to be + ;; Just _very_ simple 'downloaded %d' type of info. + (declare (special url-http-end-of-headers)) + (url-lazy-message "Reading %s..." (url-pretty-length nd))) + +(defun url-http-content-length-after-change-function (st nd length) + "Function used when we DO know how long the document is going to be. +More sophisticated percentage downloaded, etc. +Also does minimal parsing of HTTP headers and will actually cause +the callback to be triggered." + (declare (special url-current-object + url-http-end-of-headers + url-http-content-length + url-http-content-type + url-http-process)) + (if url-http-content-type + (url-display-percentage + "Reading [%s]... %s of %s (%d%%)" + (url-percentage (- nd url-http-end-of-headers) + url-http-content-length) + url-http-content-type + (url-pretty-length (- nd url-http-end-of-headers)) + (url-pretty-length url-http-content-length) + (url-percentage (- nd url-http-end-of-headers) + url-http-content-length)) + (url-display-percentage + "Reading... %s of %s (%d%%)" + (url-percentage (- nd url-http-end-of-headers) + url-http-content-length) + (url-pretty-length (- nd url-http-end-of-headers)) + (url-pretty-length url-http-content-length) + (url-percentage (- nd url-http-end-of-headers) + url-http-content-length))) + + (if (> (- nd url-http-end-of-headers) url-http-content-length) + (progn + ;; Found the end of the document! Wheee! + (url-display-percentage nil nil) + (message "Reading... done.") + (if (url-http-parse-headers) + (url-http-activate-callback))))) + +(defun url-http-chunked-encoding-after-change-function (st nd length) + "Function used when dealing with 'chunked' encoding. +Cannot give a sophisticated percentage, but we need a different +function to look for the special 0-length chunk that signifies +the end of the document." + (declare (special url-current-object + url-http-end-of-headers + url-http-content-type + url-http-chunked-length + url-http-chunked-counter + url-http-process url-http-chunked-start)) + (save-excursion + (goto-char st) + (let ((read-next-chunk t) + (case-fold-search t) + (regexp nil) + (no-initial-crlf nil)) + ;; We need to loop thru looking for more chunks even within + ;; one after-change-function call. + (while read-next-chunk + (setq no-initial-crlf (= 0 url-http-chunked-counter)) + (if url-http-content-type + (url-display-percentage nil + "Reading [%s]... chunk #%d" + url-http-content-type url-http-chunked-counter) + (url-display-percentage nil + "Reading... chunk #%d" + url-http-chunked-counter)) + (url-http-debug "Reading chunk %d (%d %d %d)" + url-http-chunked-counter st nd length) + (setq regexp (if no-initial-crlf + "\\([0-9a-z]+\\).*\r?\n" + "\r?\n\\([0-9a-z]+\\).*\r?\n")) + + (if url-http-chunked-start + ;; We know how long the chunk is supposed to be, skip over + ;; leading crap if possible. + (if (> nd (+ url-http-chunked-start url-http-chunked-length)) + (progn + (url-http-debug "Got to the end of chunk #%d!" + url-http-chunked-counter) + (goto-char (+ url-http-chunked-start + url-http-chunked-length))) + (url-http-debug "Still need %d bytes to hit end of chunk" + (- (+ url-http-chunked-start + url-http-chunked-length) + nd)) + (setq read-next-chunk nil))) + (if (not read-next-chunk) + (url-http-debug "Still spinning for next chunk...") + (if no-initial-crlf (skip-chars-forward "\r\n")) + (if (not (looking-at regexp)) + (progn + ;; Must not have received the entirety of the chunk header, + ;; need to spin some more. + (url-http-debug "Did not see start of chunk @ %d!" (point)) + (setq read-next-chunk nil)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'start-open t + 'end-open t + 'chunked-encoding t + 'face (if (featurep 'xemacs) + 'text-cursor + 'cursor) + 'invisible t)) + (setq url-http-chunked-length (string-to-int (buffer-substring + (match-beginning 1) + (match-end 1)) + 16) + url-http-chunked-counter (1+ url-http-chunked-counter) + url-http-chunked-start (set-marker + (or url-http-chunked-start + (make-marker)) + (match-end 0))) +; (if (not url-http-debug) + (delete-region (match-beginning 0) (match-end 0));) + (url-http-debug "Saw start of chunk %d (length=%d, start=%d" + url-http-chunked-counter url-http-chunked-length + (marker-position url-http-chunked-start)) + (if (= 0 url-http-chunked-length) + (progn + ;; Found the end of the document! Wheee! + (url-http-debug "Saw end of stream chunk!") + (setq read-next-chunk nil) + (url-display-percentage nil nil) + (goto-char (match-end 1)) + (if (re-search-forward "^\r*$" nil t) + (message "Saw end of trailers...")) + (if (url-http-parse-headers) + (url-http-activate-callback)))))))))) + +(defun url-http-wait-for-headers-change-function (st nd length) + ;; This will wait for the headers to arrive and then splice in the + ;; next appropriate after-change-function, etc. + (declare (special url-current-object + url-http-end-of-headers + url-http-content-type + url-http-content-length + url-http-transfer-encoding + url-callback-function + url-callback-arguments + url-http-process + url-http-method + url-http-after-change-function + url-http-response-status)) + (url-http-debug "url-http-wait-for-headers-change-function (%s)" + (buffer-name)) + (if (not (bobp)) + (let ((end-of-headers nil) + (old-http nil) + (content-length nil)) + (goto-char (point-min)) + (if (not (looking-at "^HTTP/[1-9]\\.[0-9]")) + ;; Not HTTP/x.y data, must be 0.9 + ;; God, I wish this could die. + (setq end-of-headers t + url-http-end-of-headers 0 + old-http t) + (if (re-search-forward "^\r*$" nil t) + ;; Saw the end of the headers + (progn + (url-http-debug "Saw end of headers... (%s)" (buffer-name)) + (setq url-http-end-of-headers (set-marker (make-marker) + (point)) + end-of-headers t) + (url-http-clean-headers)))) + + (if (not end-of-headers) + ;; Haven't seen the end of the headers yet, need to wait + ;; for more data to arrive. + nil + (if old-http + (message "HTTP/0.9 How I hate thee!") + (progn + (url-http-parse-response) + (mail-narrow-to-head) + ;;(narrow-to-region (point-min) url-http-end-of-headers) + (setq url-http-transfer-encoding (mail-fetch-field + "transfer-encoding") + url-http-content-type (mail-fetch-field "content-type")) + (if (mail-fetch-field "content-length") + (setq url-http-content-length + (string-to-int (mail-fetch-field "content-length")))) + (widen))) + (if url-http-transfer-encoding + (setq url-http-transfer-encoding + (downcase url-http-transfer-encoding))) + + (cond + ((or (= url-http-response-status 204) + (= url-http-response-status 205)) + (url-http-debug "%d response must have headers only (%s)." + url-http-response-status (buffer-name)) + (if (url-http-parse-headers) + (url-http-activate-callback))) + ((string= "HEAD" url-http-method) + ;; A HEAD request is _ALWAYS_ terminated by the header + ;; information, regardless of any entity headers, + ;; according to section 4.4 of the HTTP/1.1 draft. + (url-http-debug "HEAD request must have headers only (%s)." + (buffer-name)) + (if (url-http-parse-headers) + (url-http-activate-callback))) + ((string= "CONNECT" url-http-method) + ;; A CONNECT request is finished, but we cannot stick this + ;; back on the free connectin list + (url-http-debug "CONNECT request must have headers only.") + (if (url-http-parse-headers) + (url-http-activate-callback))) + ((equal url-http-response-status 304) + ;; Only allowed to have a header section. We have to handle + ;; this here instead of in url-http-parse-headers because if + ;; you have a cached copy of something without a known + ;; content-length, and try to retrieve it from the cache, we'd + ;; fall into the 'being dumb' section and wait for the + ;; connection to terminate, which means we'd wait for 10 + ;; seconds for the keep-alives to time out on some servers. + (if (url-http-parse-headers) + (url-http-activate-callback))) + (old-http + ;; HTTP/0.9 always signaled end-of-connection by closing the + ;; connection. + (url-http-debug + "Saw HTTP/0.9 response, connection closed means end of document.") + (setq url-http-after-change-function + 'url-http-simple-after-change-function)) + ((equal url-http-transfer-encoding "chunked") + (url-http-debug "Saw chunked encoding.") + (setq url-http-after-change-function + 'url-http-chunked-encoding-after-change-function) + (if (> nd url-http-end-of-headers) + (progn + (url-http-debug + "Calling initial chunked-encoding for extra data at end of headers") + (url-http-chunked-encoding-after-change-function + (marker-position url-http-end-of-headers) nd + (- nd url-http-end-of-headers))))) + ((integerp url-http-content-length) + (url-http-debug + "Got a content-length, being smart about document end.") + (setq url-http-after-change-function + 'url-http-content-length-after-change-function) + (cond + ((= 0 url-http-content-length) + ;; We got a NULL body! Activate the callback + ;; immediately! + (url-http-debug + "Got 0-length content-length, activating callback immediately.") + (if (url-http-parse-headers) + (url-http-activate-callback))) + ((> nd url-http-end-of-headers) + ;; Have some leftover data + (url-http-debug "Calling initial content-length for extra data at end of headers") + (url-http-content-length-after-change-function + (marker-position url-http-end-of-headers) + nd + (- nd url-http-end-of-headers))) + (t + nil))) + (t + (url-http-debug "No content-length, being dumb.") + (setq url-http-after-change-function + 'url-http-simple-after-change-function))))) + ;; We are still at the beginning of the buffer... must just be + ;; waiting for a response. + (url-http-debug "Spinning waiting for headers...")) + (goto-char (point-max))) + +;;;###autoload +(defun url-http (url callback cbargs) + "Retrieve URL via HTTP asynchronously. +URL must be a parsed URL. See `url-generic-parse-url' for details. +When retrieval is completed, the function CALLBACK is executed with +CBARGS as the arguments." + (check-type url vector "Need a pre-parsed URL.") + (declare (special url-current-object + url-http-end-of-headers + url-http-content-type + url-http-content-length + url-http-transfer-encoding + url-http-after-change-function + url-callback-function + url-callback-arguments + url-http-method + url-http-extra-headers + url-http-data + url-http-chunked-length + url-http-chunked-start + url-http-chunked-counter + url-http-process)) + (let ((connection (url-http-find-free-connection (url-host url) + (url-port url))) + (buffer (generate-new-buffer (format " *http %s:%d*" + (url-host url) + (url-port url))))) + (if (not connection) + ;; Failed to open the connection for some reason + (progn + (kill-buffer buffer) + (setq buffer nil) + (error "Could not create connection to %s:%d" (url-host url) + (url-port url))) + (save-excursion + (set-buffer buffer) + (mm-disable-multibyte) + (setq url-current-object url + mode-line-format "%b [%s]") + + (dolist (var '(url-http-end-of-headers + url-http-content-type + url-http-content-length + url-http-transfer-encoding + url-http-after-change-function + url-http-response-status + url-http-chunked-length + url-http-chunked-counter + url-http-chunked-start + url-callback-function + url-callback-arguments + url-http-process + url-http-method + url-http-extra-headers + url-http-data)) + (set (make-local-variable var) nil)) + + (setq url-http-method (or url-request-method "GET") + url-http-extra-headers url-request-extra-headers + url-http-data url-request-data + url-http-process connection + url-http-chunked-length nil + url-http-chunked-start nil + url-http-chunked-counter 0 + url-callback-function callback + url-callback-arguments cbargs + url-http-after-change-function 'url-http-wait-for-headers-change-function) + + (set-process-buffer connection buffer) + (set-process-sentinel connection 'url-http-end-of-document-sentinel) + (set-process-filter connection 'url-http-generic-filter) + (process-send-string connection (url-http-create-request url)))) + buffer)) + +;; Since Emacs 19/20 does not allow you to change the +;; `after-change-functions' hook in the midst of running them, we fake +;; an after change by hooking into the process filter and inserting +;; the data ourselves. This is slightly less efficient, but there +;; were tons of weird ways the after-change code was biting us in the +;; shorts. +(defun url-http-generic-filter (proc data) + ;; Sometimes we get a zero-length data chunk after the process has + ;; been changed to 'free', which means it has no buffer associated + ;; with it. Do nothing if there is no buffer, or 0 length data. + (declare (special url-http-after-change-function)) + (and (process-buffer proc) + (/= (length data) 0) + (save-excursion + (set-buffer (process-buffer proc)) + (url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc) + (funcall url-http-after-change-function + (point-max) + (progn + (goto-char (point-max)) + (insert data) + (point-max)) + (length data))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; file-name-handler stuff from here on out +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(if (not (fboundp 'symbol-value-in-buffer)) + (defun url-http-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)))) + (defalias 'url-http-symbol-value-in-buffer 'symbol-value-in-buffer)) + +(defun url-http-head (url) + (let ((url-request-method "HEAD") + (url-request-data nil)) + (url-retrieve-synchronously url))) + +;;;###autoload +(defun url-http-file-exists-p (url) + (let ((version nil) + (status nil) + (exists nil) + (buffer (url-http-head url))) + (if (not buffer) + (setq exists nil) + (setq status (url-http-symbol-value-in-buffer 'url-http-response-status + buffer 500) + exists (and (>= status 200) (< status 300))) + (kill-buffer buffer)) + exists)) + +;;;###autoload +(defalias 'url-http-file-readable-p 'url-http-file-exists-p) + +(defun url-http-head-file-attributes (url) + (let ((buffer (url-http-head url)) + (attributes nil)) + (when buffer + (setq attributes (make-list 11 nil)) + (setf (nth 1 attributes) 1) ; Number of links to file + (setf (nth 2 attributes) 0) ; file uid + (setf (nth 3 attributes) 0) ; file gid + (setf (nth 7 attributes) ; file size + (url-http-symbol-value-in-buffer 'url-http-content-length + buffer -1)) + (setf (nth 8 attributes) (eval-when-compile (make-string 10 ?-))) + (kill-buffer buffer)) + attributes)) + +;;;###autoload +(defun url-http-file-attributes (url) + (if (url-dav-supported-p url) + (url-dav-file-attributes url) + (url-http-head-file-attributes url))) + +;;;###autoload +(defun url-http-options (url) + "Returns a property list describing options available for URL. +This list is retrieved using the `OPTIONS' HTTP method. + +Property list members: + +methods + A list of symbols specifying what HTTP methods the resource + supports. + +dav + A list of numbers specifying what DAV protocol/schema versions are + supported. + +dasl + A list of supported DASL search types supported (string form) + +ranges + A list of the units available for use in partial document fetches. + +p3p + The `Platform For Privacy Protection' description for the resource. + Currently this is just the raw header contents. This is likely to + change once P3P is formally supported by the URL package or + Emacs/W3. +" + (let* ((url-request-method "OPTIONS") + (url-request-data nil) + (buffer (url-retrieve-synchronously url)) + (header nil) + (options nil)) + (when (and buffer (= 2 (/ (url-http-symbol-value-in-buffer + 'url-http-response-status buffer 0) 100))) + ;; Only parse the options if we got a 2xx response code! + (save-excursion + (save-restriction + (save-match-data + (set-buffer buffer) + (mail-narrow-to-head) + + ;; Figure out what methods are supported. + (when (setq header (mail-fetch-field "allow")) + (setq options (plist-put + options 'methods + (mapcar 'intern (split-string header "[ ,]+"))))) + + ;; Check for DAV + (when (setq header (mail-fetch-field "dav")) + (setq options (plist-put + options 'dav + (delq 0 + (mapcar 'string-to-number + (split-string header "[, ]+")))))) + + ;; Now for DASL + (when (setq header (mail-fetch-field "dasl")) + (setq options (plist-put + options 'dasl + (split-string header "[, ]+")))) + + ;; P3P - should get more detailed here. FIXME + (when (setq header (mail-fetch-field "p3p")) + (setq options (plist-put options 'p3p header))) + + ;; Check for whether they accept byte-range requests. + (when (setq header (mail-fetch-field "accept-ranges")) + (setq options (plist-put + options 'ranges + (delq 'none + (mapcar 'intern + (split-string header "[, ]+")))))) + )))) + (if buffer (kill-buffer buffer)) + options)) + +(provide 'url-http) + +;;; arch-tag: ba7c59ae-c0f4-4a31-9617-d85f221732ee +;;; url-http.el ends here diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-https.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-https.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,55 @@ +;;; url-https.el --- HTTP over SSL routines +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1999 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 'url-gw) +(require 'url-util) +(require 'url-parse) +(require 'url-cookie) +(require 'url-http) + +(defconst url-https-default-port 443 "Default HTTPS port.") +(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.") +(defalias 'url-https-expand-file-name 'url-http-expand-file-name) + +(defmacro url-https-create-secure-wrapper (method args) + (` (defun (, (intern (format (if method "url-https-%s" "url-https") method))) (, args) + (, (format "HTTPS wrapper around `%s' call." (or method "url-http"))) + (condition-case () + (require 'ssl) + (error + (error "HTTPS support could not find `ssl' library."))) + (let ((url-gateway-method 'ssl)) + ((, (intern (format (if method "url-http-%s" "url-http") method))) (,@ (remove '&rest (remove '&optional args)))))))) + +(url-https-create-secure-wrapper nil (url callback cbargs)) +(url-https-create-secure-wrapper file-exists-p (url)) +(url-https-create-secure-wrapper file-readable-p (url)) +(url-https-create-secure-wrapper file-attributes (url)) + +(provide 'url-https) + +;;; arch-tag: c3645ac5-c248-4d12-ad41-7c4b6f7b6d19 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-imap.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-imap.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,83 @@ +;;; url-imap.el --- IMAP retrieval routines +;; Author: Simon Josefsson +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Anyway, here's a teaser. It's quite broken in lots of regards, but at +; least it seem to work. At least a little. At least when called +; manually like this (I've no idea how it's supposed to be called): + +; (url-imap (url-generic-parse-url "imap://cyrus.andrew.cmu.edu/archive.c-client;UID=1021")) + +(eval-when-compile (require 'cl)) +(require 'url-util) +(require 'url-parse) +(require 'nnimap) +(require 'mm-util) + +(defconst url-imap-default-port 143 "Default IMAP port") + +(defun url-imap-open-host (host port user pass) + ;; xxx use user and password + (if (fboundp 'nnheader-init-server-buffer) + (nnheader-init-server-buffer)) + (let ((imap-username user) + (imap-password pass) + (authenticator (if user 'login 'anonymous))) + (if (stringp port) + (setq port (string-to-int port))) + (nnimap-open-server host + `((nnimap-server-port ,port) + (nnimap-stream 'network) + (nnimap-authenticator ,authenticator))))) + +(defun url-imap (url) + (check-type url vector "Need a pre-parsed URL.") + (save-excursion + (set-buffer (generate-new-buffer " *url-imap*")) + (mm-disable-multibyte) + (let* ((host (url-host url)) + (port (url-port url)) + ;; xxx decode mailbox (see rfc2192) + (mailbox (url-filename url)) + (coding-system-for-read 'binary)) + (and (eq (string-to-char mailbox) ?/) + (setq mailbox (substring mailbox 1))) + (url-imap-open-host host port (url-user url) (url-password url)) + (cond ((assoc "TYPE" (url-attributes url)) + ;; xxx list mailboxes (start gnus?) + ) + ((assoc "UID" (url-attributes url)) + ;; fetch message part + ;; xxx handle partial fetches + (insert "Content-type: message/rfc822\n\n") + (nnimap-request-article (cdr (assoc "UID" (url-attributes url))) + mailbox host (current-buffer))) + (t + ;; xxx list messages in mailbox (start gnus?) + ))) + (current-buffer))) + +;;; arch-tag: 034991ff-5425-48ea-b911-c96c90e6f47d diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-irc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-irc.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,80 @@ +;;; url-irc.el --- IRC URL interface +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; IRC URLs are defined in http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt + +(require 'url-vars) +(require 'url-parse) + +(defconst url-irc-default-port 6667 "Default port for IRC connections") + +(defcustom 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" + :type '(choice (const :tag "ZEN IRC" :value 'url-irc-zenirc) + (function :tag "Other")) + :group 'url) + +(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)))) + +;;;###autoload +(defun url-irc (url) + (let* ((host (url-host url)) + (port (string-to-int (url-port url))) + (pass (url-password url)) + (user (url-user url)) + (chan (url-filename url))) + (if (url-target url) + (setq chan (concat chan "#" (url-target url)))) + (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) + nil)) + +(provide 'url-irc) + +;;; arch-tag: 2e5eecf8-9eb3-436b-9fbd-c26f2fb2bf3e diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-ldap.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-ldap.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,235 @@ +;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1998 - 1999 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 'url-vars) +(require 'url-parse) +(require 'url-util) + +;; This has been implemented from RFC2255 'The LDAP URL Format' (Dec 1997) +;; +;; basic format is: ldap://host:port/dn?attributes?scope?filter?extensions +;; +;; Test URLs: +;; ldap://ldap.itd.umich.edu/cn%3Dumbflabmanager%2C%20ou%3DUser%20Groups%2C%20ou%3DGroups%2C%20o%3DUniversity%20of%20Michigan%2C%20c%3DUS +;; ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US +;; +;; For simple queries, I have verified compatibility with Netscape +;; Communicator v4.5 under linux. +;; +;; For anything _useful_ though, like specifying the attributes, +;; scope, filter, or extensions, netscape claims the URL format is +;; unrecognized. So I don't think it supports anything other than the +;; defaults (scope=base,attributes=*,filter=(objectClass=*) + +(defconst url-ldap-default-port 389 "Default LDAP port.") +(defalias 'url-ldap-expand-file-name 'url-default-expander) + +(defvar url-ldap-pretty-names + '(("l" . "City") + ("objectclass" . "Object Class") + ("o" . "Organization") + ("ou" . "Organizational Unit") + ("cn" . "Name") + ("sn" . "Last Name") + ("givenname" . "First Name") + ("mail" . "Email") + ("title" . "Title") + ("c" . "Country") + ("postalcode" . "ZIP Code") + ("telephonenumber" . "Phone Number") + ("facsimiletelephonenumber" . "Fax") + ("postaladdress" . "Mailing Address") + ("description" . "Notes")) + "*An assoc list mapping LDAP attribute names to pretty descriptions of them.") + +(defvar url-ldap-attribute-formatters + '(("mail" . (lambda (x) (format "%s" x x))) + ("owner" . url-ldap-dn-formatter) + ("creatorsname" . url-ldap-dn-formatter) + ("jpegphoto" . url-ldap-image-formatter) + ("usercertificate" . url-ldap-certificate-formatter) + ("modifiersname" . url-ldap-dn-formatter) + ("namingcontexts" . url-ldap-dn-formatter) + ("defaultnamingcontext" . url-ldap-dn-formatter) + ("member" . url-ldap-dn-formatter)) + "*An assoc list mapping LDAP attribute names to pretty formatters for them.") + +(defsubst url-ldap-attribute-pretty-name (n) + (or (cdr-safe (assoc (downcase n) url-ldap-pretty-names)) n)) + +(defsubst url-ldap-attribute-pretty-desc (n v) + (if (string-match "^\\([^;]+\\);" n) + (setq n (match-string 1 n))) + (funcall (or (cdr-safe (assoc (downcase n) url-ldap-attribute-formatters)) 'identity) v)) + +(defun url-ldap-dn-formatter (dn) + (concat "" dn "")) + +(defun url-ldap-certificate-formatter (data) + (condition-case () + (require 'ssl) + (error nil)) + (let ((vals (and (fboundp 'ssl-certificate-information) + (ssl-certificate-information data)))) + (if (not vals) + "Unable to parse certificate" + (concat "\n" + (mapconcat + (lambda (ava) + (format "\n" (car ava) (cdr ava))) + vals "\n") + "
%s%s
\n")))) + +(defun url-ldap-image-formatter (data) + (format "JPEG Photo" + (url-hexify-string (base64-encode-string data)))) + +;;;###autoload +(defun url-ldap (url) + (save-excursion + (set-buffer (generate-new-buffer " *url-ldap*")) + (setq url-current-object url) + (insert "Content-type: text/html\r\n\r\n") + (if (not (fboundp 'ldap-search-internal)) + (insert "\n" + " \n" + " LDAP Not Supported\n" + " \n" + " \n" + " \n" + "

LDAP Not Supported

\n" + "

\n" + " This version of Emacs does not support LDAP.\n" + "

\n" + " \n" + "\n") + (let* ((binddn nil) + (data (url-filename url)) + (host (url-host url)) + (port (url-port url)) + (base-object nil) + (attributes nil) + (scope nil) + (filter nil) + (extensions nil) + (connection nil) + (results nil) + (extract-dn (and (fboundp 'function-max-args) + (= (function-max-args 'ldap-search-internal) 7)))) + + ;; Get rid of leading / + (if (string-match "^/" data) + (setq data (substring data 1))) + + (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?")) + base-object (nth 0 data) + attributes (nth 1 data) + scope (nth 2 data) + filter (nth 3 data) + extensions (nth 4 data)) + + ;; fill in the defaults + (setq base-object (url-unhex-string (or base-object "")) + scope (intern (url-unhex-string (or scope "base"))) + filter (url-unhex-string (or filter "(objectClass=*)"))) + + (if (not (memq scope '(base one tree))) + (error "Malformed LDAP URL: Unknown scope: %S" scope)) + + ;; Convert to the internal LDAP support scoping names. + (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree))))) + + (if attributes + (setq attributes (mapcar 'url-unhex-string (split-string attributes ",")))) + + ;; Parse out the exentions + (if extensions + (setq extensions (mapcar (lambda (ext) + (if (string-match "\\([^=]*\\)=\\(.*\\)" ext) + (cons (match-string 1 ext) (match-string 2 ext)) + (cons ext ext))) + (split-string extensions ",")) + extensions (mapcar (lambda (ext) + (cons (url-unhex-string (car ext)) + (url-unhex-string (cdr ext)))) + extensions))) + + (setq binddn (cdr-safe (or (assoc "bindname" extensions) + (assoc "!bindname" extensions)))) + + ;; Now, let's actually do something with it. + (setq connection (ldap-open host (if binddn (list 'binddn binddn))) + results (if extract-dn + (ldap-search-internal connection filter base-object scope attributes nil t) + (ldap-search-internal connection filter base-object scope attributes nil))) + + (ldap-close connection) + (insert "\n" + " \n" + " LDAP Search Results\n" + " \n" + " \n" + " \n" + "

" (int-to-string (length results)) " matches

\n") + + (mapc (lambda (obj) + (insert "
\n" + " \n") + (if extract-dn + (insert " \n")) + (mapc (lambda (attr) + (if (= (length (cdr attr)) 1) + ;; single match, easy + (insert " \n") + ;; Multiple matches, slightly uglier + (insert " \n" + (format " " + " \n"))) + (if extract-dn (cdr obj) obj)) + (insert "
" (car obj) "
" + (url-ldap-attribute-pretty-name (car attr)) + "" + (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr))) + "
" (length (cdr attr))) + (url-ldap-attribute-pretty-name (car attr)) "" + (mapconcat (lambda (x) + (url-ldap-attribute-pretty-desc (car attr) x)) + (cdr attr) + "
\n") + "
\n")) + results) + + (insert "
\n" + " \n" + "\n"))) + (current-buffer))) + +(provide 'url-ldap) + +;;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-mailto.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-mailto.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,131 @@ +;;; url-mail.el --- Mail Uniform Resource Locator retrieval code +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile (require 'cl)) +(require 'url-vars) +(require 'url-parse) +(require 'url-util) + +;;;###autoload +(defun url-mail (&rest args) + (interactive "P") + (if (fboundp 'message-mail) + (apply 'message-mail args) + (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")))))) + +;;;###autoload +(defun url-mailto (url) + "Handle the mailto: URL syntax." + (if (url-user url) + ;; malformed mailto URL (mailto://wmperry@gnu.org instead of + ;; mailto:wmperry@gnu.org + (url-set-filename url (concat (url-user url) "@" (url-filename url)))) + (setq url (url-filename url)) + (let (to args source-url subject func headers-start) + (if (string-match (regexp-quote "?") url) + (setq headers-start (match-end 0) + to (url-unhex-string (substring url 0 (match-beginning 0))) + args (url-parse-query-string + (substring url headers-start 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))) + + (if (assoc "to" args) + (push to (cdr (assoc "to" args))) + (setq args (cons (list "to" to) args))) + (setq subject (cdr-safe (assoc "subject" args))) + (if (fboundp url-mail-command) (funcall url-mail-command) (mail)) + (while args + (if (string= (caar args) "body") + (progn + (goto-char (point-max)) + (insert (mapconcat 'identity (cdar args) "\n"))) + (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 "User-Agent") +;; (insert url-package-name "/" url-package-version " URL/" url-version) + (if (not url-request-data) + (progn + (set-buffer-modified-p nil) + (if subject + (url-mail-goto-field nil) + (url-mail-goto-field "subject"))) + (if url-request-extra-headers + (mapconcat + (lambda (x) + (url-mail-goto-field (car x)) + (insert (cdr x))) + url-request-extra-headers "")) + (goto-char (point-max)) + (insert url-request-data) + ;; It seems Microsoft-ish to send without warning. + ;; Fixme: presumably this should depend on a privacy setting. + (if (y-or-n-p "Send this auto-generated mail? ") + (cond ((eq url-mail-command 'compose-mail) + (funcall (get mail-user-agent 'sendfunc) nil)) + ;; otherwise, we can't be sure + ((fboundp 'message-mail) + (message-send-and-exit)) + (t (mail-send-and-exit nil))))) + nil)) + +(provide 'url-mailto) + +;;; arch-tag: 7b7ad52e-8760-497b-9444-75fae14e34c5 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-methods.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-methods.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,150 @@ +;;; url-methods.el --- Load URL schemes as needed +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.3 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996, 2004 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile + (require 'cl)) + +;; This loads up some of the small, silly URLs that I really don't +;; want to bother putting in their own separate files. +(require 'url-parse) + +(defvar url-scheme-registry (make-hash-table :size 7 :test 'equal)) + +(defconst url-scheme-methods + '((default-port . variable) + (asynchronous-p . variable) + (expand-file-name . function) + (file-exists-p . function) + (file-attributes . function) + (parse-url . function) + (file-symlink-p . function) + (file-writable-p . function) + (file-directory-p . function) + (file-executable-p . function) + (directory-files . function) + (file-truename . function)) + "Assoc-list of methods that each URL loader can provide.") + +(defconst url-scheme-default-properties + (list 'name "unknown" + 'loader 'url-scheme-default-loader + 'default-port 0 + 'expand-file-name 'url-identity-expander + 'parse-url 'url-generic-parse-url + 'asynchronous-p nil + 'file-directory-p 'ignore + 'file-truename (lambda (&rest args) + (url-recreate-url (car args))) + 'file-exists-p 'ignore + 'file-attributes 'ignore)) + +(defun url-scheme-default-loader (url &optional callback cbargs) + "Signal an error for an unknown URL scheme." + (error "Unkown URL scheme: %s" (url-type url))) + +(defun url-scheme-register-proxy (scheme) + "Automatically find a proxy for SCHEME and put it in `url-proxy-services'." + (let* ((env-var (concat scheme "_proxy")) + (env-proxy (or (getenv (upcase env-var)) + (getenv (downcase env-var)))) + (cur-proxy (assoc scheme url-proxy-services)) + (urlobj nil)) + + ;; 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 (match-string 1 env-proxy)) + (url-set-port urlobj (string-to-number (match-string 2 env-proxy)))) + ;; 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 scheme (format "%s:%d" (url-host urlobj) + (url-port urlobj))) + url-proxy-services)) + (message "Using a proxy for %s..." scheme))))) + +(defun url-scheme-get-property (scheme property) + "Get property of a URL SCHEME. +Will automatically try to load a backend from url-SCHEME.el if +it has not already been loaded." + (setq scheme (downcase scheme)) + (let ((desc (gethash scheme url-scheme-registry))) + (if (not desc) + (let* ((stub (concat "url-" scheme)) + (loader (intern stub))) + (condition-case () + (require loader) + (error nil)) + (if (fboundp loader) + (progn + ;; Found the module to handle URLs + (url-scheme-register-proxy scheme) + (setq desc (list 'name scheme + 'loader loader)) + (dolist (cell url-scheme-methods) + (let ((symbol (intern-soft (format "%s-%s" stub (car cell)))) + (type (cdr cell))) + (if symbol + (case type + (function + ;; Store the symbol name of a function + (if (fboundp symbol) + (setq desc (plist-put desc (car cell) symbol)))) + (variable + ;; Store the VALUE of a variable + (if (boundp symbol) + (setq desc (plist-put desc (car cell) + (symbol-value symbol))))) + (otherwise + (error "Malformed url-scheme-methods entry: %S" + cell)))))) + (puthash scheme desc url-scheme-registry))))) + (or (plist-get desc property) + (plist-get url-scheme-default-properties property)))) + +(provide 'url-methods) + +;;; arch-tag: 336863f8-5a07-4906-9be5-b3c6bcebbe67 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-misc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-misc.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,121 @@ +;;; url-misc.el --- Misc Uniform Resource Locator retrieval code +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996, 97, 98, 99, 2002 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 'url-vars) +(require 'url-parse) +(autoload 'Info-goto-node "info" "" t) +(autoload 'man "man" nil t) + +;;;###autoload +(defun url-man (url) + "Fetch a Unix manual page URL." + (man (url-filename url)) + nil) + +;;;###autoload +(defun url-info (url) + "Fetch a GNU Info URL." + ;; Fetch an info node + (let* ((fname (url-filename url)) + (node (url-unhex-string (or (url-target url) "Top")))) + (if (and fname node) + (Info-goto-node (concat "(" fname ")" node)) + (error "Malformed url: %s" (url-recreate-url url))) + nil)) + +(defun url-do-terminal-emulator (type server port user) + (terminal-emulator + (generate-new-buffer (format "%s%s" (if user (concat user "@") "") server)) + (case type + (rlogin "rlogin") + (telnet "telnet") + (tn3270 "tn3270") + (otherwise + (error "Unknown terminal emulator required: %s" type))) + (case type + (rlogin + (if user + (list server "-l" user) + (list server))) + (telnet + (if user (message "Please log in as user: %s" user)) + (if port + (list server port) + (list server))) + (tn3270 + (if user (message "Please log in as user: %s" user)) + (list server))))) + +;;;###autoload +(defun url-generic-emulator-loader (url) + (let* ((type (intern (downcase (url-type url)))) + (server (url-host url)) + (name (url-user url)) + (port (url-port url))) + (url-do-terminal-emulator type server port name)) + nil) + +;;;###autoload +(defalias 'url-rlogin 'url-generic-emulator-loader) +;;;###autoload +(defalias 'url-telnet 'url-generic-emulator-loader) +;;;###autoload +(defalias 'url-tn3270 'url-generic-emulator-loader) + +;; RFC 2397 +;;;###autoload +(defun url-data (url) + "Fetch a data URL (RFC 2397)." + (let ((mediatype nil) + ;; The mediatype may need to be hex-encoded too -- see the RFC. + (desc (url-unhex-string (url-filename url))) + (encoding "8bit") + (data nil)) + (save-excursion + (if (not (string-match "\\([^,]*\\)?," desc)) + (error "Malformed data URL: %s" desc) + (setq mediatype (match-string 1 desc)) + (if (and mediatype (string-match ";base64\\'" mediatype)) + (setq mediatype (substring mediatype 0 (match-beginning 0)) + encoding "base64")) + (if (or (null mediatype) + (eq ?\; (aref mediatype 0))) + (setq mediatype (concat "text/plain" mediatype))) + (setq data (url-unhex-string (substring desc (match-end 0))))) + (set-buffer (generate-new-buffer " *url-data*")) + (mm-disable-multibyte) + (insert (format "Content-Length: %d\n" (length data)) + "Content-Type: " mediatype "\n" + "Content-Encoding: " encoding "\n" + "\n") + (if data (insert data)) + (current-buffer)))) + +(provide 'url-misc) + +;;; arch-tag: 8c544e1b-d8bc-40a6-b319-f1f37fef65a0 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-news.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-news.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,137 @@ +;;; url-news.el --- News Uniform Resource Locator retrieval code +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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 'url-vars) +(require 'url-util) +(require 'url-parse) +(require 'nntp) +(autoload 'url-warn "url") +(autoload 'gnus-group-read-ephemeral-group "gnus-group") +(eval-when-compile (require 'cl)) + +(defgroup url-news nil + "News related options" + :group 'url) + +(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-message-id (host message-id) + (let ((buf (generate-new-buffer " *url-news*"))) + (if (eq ?> (aref message-id (1- (length message-id)))) + nil + (setq message-id (concat "<" message-id ">"))) + (if (cdr-safe (nntp-request-article message-id nil host buf)) + ;; Successfully retrieved the article + nil + (save-excursion + (set-buffer buf) + (insert "Content-type: text/html\n\n" + "\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" + ))) + buf)) + +(defun url-news-fetch-newsgroup (newsgroup host) + (declare (special gnus-group-buffer)) + (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 us from checking new news if GNUS is already running + ;; FIXME - is it relatively safe to use gnus-alive-p here? FIXME + (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 + 'nntp-open-connection-function + nntp-open-connection-function) + nil + (cons (current-buffer) 'browse))) + +;;;###autoload +(defun url-news (url) + ;; Find a news reference + (let* ((host (or (url-host url) url-news-server)) + (port (url-port url)) + (article-brackets nil) + (buf nil) + (article (url-filename url))) + (url-news-open-host host port (url-user url) (url-password url)) + (setq article (url-unhex-string article)) + (cond + ((string-match "@" article) ; Its a specific article + (setq buf (url-news-fetch-message-id host article))) + ((string= article "") ; List all newsgroups + (gnus)) + (t ; Whole newsgroup + (url-news-fetch-newsgroup article host))) + buf)) + +;;;###autoload +(defun url-snews (url) + (let ((nntp-open-connection-function 'nntp-open-ssl-stream)) + (url-news url))) + +(provide 'url-news) + +;;; arch-tag: 8975be13-04e8-4d38-bfff-47918e3ad311 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-nfs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-nfs.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,99 @@ +;;; url-nfs.el --- NFS URL interface +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile (require 'cl)) +(require 'url-parse) +(require 'url-file) + +(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-build-filename (url) + (let* ((host (url-host url)) + (port (string-to-int (url-port url))) + (pass (url-password url)) + (user (url-user url)) + (file (url-filename url))) + (url-generic-parse-url + (url-nfs-unescape url-nfs-automounter-directory-spec + host port user pass file)))) + +(defun url-nfs (url callback cbargs) + (url-file (url-nfs-build-filename url) callback cbargs)) + +(defmacro url-nfs-create-wrapper (method args) + (` (defun (, (intern (format "url-nfs-%s" method))) (, args) + (, (format "NFS URL wrapper around `%s' call." method)) + (setq url (url-nfs-build-filename url)) + (and url ((, (intern (format "url-file-%s" method))) + (,@ (remove '&rest (remove '&optional args)))))))) + +(url-nfs-create-wrapper file-exists-p (url)) +(url-nfs-create-wrapper file-attributes (url)) +(url-nfs-create-wrapper file-symlink-p (url)) +(url-nfs-create-wrapper file-readable-p (url)) +(url-nfs-create-wrapper file-writable-p (url)) +(url-nfs-create-wrapper file-executable-p (url)) +(if (featurep 'xemacs) + (progn + (url-nfs-create-wrapper directory-files (url &optional full match nosort files-only)) + (url-nfs-create-wrapper file-truename (url &optional default))) + (url-nfs-create-wrapper directory-files (url &optional full match nosort)) + (url-nfs-create-wrapper file-truename (url &optional counter prev-dirs))) + +(provide 'url-nfs) + +;;; arch-tag: cdf9c9ba-b7d2-4c29-8b48-7ae9bbc0d437 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-ns.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-ns.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,108 @@ +;;; url-ns.el --- Various netscape-ish functions for proxy definitions +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1997 - 1999 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 'url-gw) + +;;;###autoload +(defun isPlainHostName (host) + (not (string-match "\\." host))) + +;;;###autoload +(defun dnsDomainIs (host dom) + (string-match (concat (regexp-quote dom) "$") host)) + +;;;###autoload +(defun dnsResolve (host) + (url-gateway-nslookup-host host)) + +;;;###autoload +(defun isResolvable (host) + (if (string-match "^[0-9.]+$" host) + t + (not (string= host (url-gateway-nslookup-host host))))) + +;;;###autoload +(defun isInNet (ip net mask) + (let ((netc (split-string ip "\\.")) + (ipc (split-string net "\\.")) + (maskc (split-string mask "\\."))) + (if (or (/= (length netc) (length ipc)) + (/= (length ipc) (length maskc))) + nil + (setq netc (mapcar 'string-to-int netc) + ipc (mapcar 'string-to-int ipc) + maskc (mapcar 'string-to-int maskc)) + (and + (= (logand (nth 0 netc) (nth 0 maskc)) + (logand (nth 0 ipc) (nth 0 maskc))) + (= (logand (nth 1 netc) (nth 1 maskc)) + (logand (nth 1 ipc) (nth 1 maskc))) + (= (logand (nth 2 netc) (nth 2 maskc)) + (logand (nth 2 ipc) (nth 2 maskc))) + (= (logand (nth 3 netc) (nth 3 maskc)) + (logand (nth 3 ipc) (nth 3 maskc))))))) + +;; Netscape configuration file parsing +(defvar url-ns-user-prefs nil + "Internal, do not use.") + +;;;###autoload +(defun url-ns-prefs (&optional file) + (if (not file) + (setq file (expand-file-name "~/.netscape/preferences.js"))) + (if (not (and (file-exists-p file) + (file-readable-p file))) + (message "Could not open %s for reading" file) + (save-excursion + (let ((false nil) + (true t)) + (setq url-ns-user-prefs (make-hash-table :size 13 :test 'equal)) + (set-buffer (get-buffer-create " *ns-parse*")) + (erase-buffer) + (insert-file-contents file) + (goto-char (point-min)) + (while (re-search-forward "^//" nil t) + (replace-match ";;")) + (goto-char (point-min)) + (while (re-search-forward "^user_pref(" nil t) + (replace-match "(url-ns-set-user-pref ")) + (goto-char (point-min)) + (while (re-search-forward "\"," nil t) + (replace-match "\"")) + (goto-char (point-min)) + (eval-buffer))))) + +(defun url-ns-set-user-pref (key val) + (puthash key val url-ns-user-prefs)) + +;;;###autoload +(defun url-ns-user-pref (key &optional default) + (gethash key url-ns-user-prefs default)) + +(provide 'url-ns) + +;;; arch-tag: 69520992-cf97-40b4-9ad1-c866d3cae5bf diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-parse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-parse.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,208 @@ +;;; url-parse.el --- Uniform Resource Locator parser +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.3 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996, 2004 by William M. Perry +;;; Copyright (c) 1996 - 1999 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 'url-vars) + +(autoload 'url-scheme-get-property "url-methods") + +(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) + (url-scheme-get-property (url-type ,urlobj) 'default-port)))) + +(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)) + +;;;###autoload +(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) + (url-scheme-get-property (url-type urlobj) 'default-port)))) + (format ":%d" (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) ";"))))) + +;;;###autoload +(defun url-generic-parse-url (url) + "Return a vector of the parts of URL. +Format is: +\[proto username password hostname portnumber file reference attributes fullp\]" + (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-parse-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 "^/") + (setq host (buffer-substring save-pos (point))) + (if (string-match "^\\([^@]+\\)@" host) + (setq user (match-string 1 host) + host (substring host (match-end 0) nil))) + (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user)) + (setq pass (match-string 2 user) + user (match-string 1 user))) + (if (string-match ":\\([0-9+]+\\)" host) + (setq port (string-to-int (match-string 1 host)) + host (substring host 0 (match-beginning 0)))) + (if (string-match ":$" host) + (setq host (substring host 0 (match-beginning 0)))) + (setq host (downcase host) + save-pos (point)))) + + (if (not port) + (setq port (url-scheme-get-property prot 'default-port))) + + ;; Gross hack to preserve ';' in data URLs + + (setq save-pos (point)) + + (if (string= "data" prot) + (goto-char (point-max)) + ;; Now check for references + (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 (url-parse-args (buffer-substring (point) (point-max)) t) + attr (nreverse attr)))) + + (setq file (buffer-substring save-pos (point))) + (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) + +;;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-privacy.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-privacy.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,85 @@ +;;; url-privacy.el --- Global history tracking for URL package +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996 - 1999 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile (require 'cl)) +(require 'url-vars) + +(if (fboundp 'device-type) + (defalias 'url-device-type 'device-type) + (defun url-device-type (&optional device) (or window-system 'tty))) + +;;;###autoload +(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) + ;; First, we handle the inseparable OS/Windowing system + ;; combinations + ((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") + ((memq (url-device-type) '(win32 w32)) "Windows; 32bit") + ((eq (url-device-type) 'pm) "OS/2; 32bit") + (t + (case (url-device-type) + (x "X11") + (ns "OpenStep") + (tty "TTY") + (otherwise nil))))) + + (setq url-personal-mail-address (or url-personal-mail-address + user-mail-address + (format "%s@%s" (user-real-login-name) + (system-name)))) + + (if (or (memq url-privacy-level '(paranoid high)) + (and (listp url-privacy-level) + (memq 'email url-privacy-level))) + (setq url-personal-mail-address nil)) + + (setq url-os-type + (cond + ((or (eq url-privacy-level 'paranoid) + (and (listp url-privacy-level) + (memq 'os url-privacy-level))) + nil) + ((boundp 'system-configuration) + system-configuration) + ((boundp 'system-type) + (symbol-name system-type)) + (t nil)))) + +(provide 'url-privacy) + +;;; arch-tag: fdaf95e4-98f0-4680-94c3-f3eadafabe1d diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-proxy.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-proxy.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,80 @@ +;;; url-proxy.el --- Proxy server support +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1999 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 'url-parse) +(autoload 'url-warn "url") + +(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 + (if (listp proxies) + (setq proxy (car proxies)) + (setq proxy 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-proxy (url callback &optional cbargs) + ;; Retrieve URL from a proxy. + ;; Expects `url-using-proxy' to be bound to the specific proxy to use." + (setq url-using-proxy (url-generic-parse-url url-using-proxy)) + (let ((proxy-object (copy-sequence url))) + (url-set-target proxy-object nil) + (url-http url-using-proxy callback cbargs))) + +(provide 'url-proxy) + +;;; arch-tag: 4ff8882e-e498-42b7-abc5-acb449cdbc62 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-util.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-util.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,489 @@ +;;; url-util.el --- Miscellaneous helper routines for URL library +;; Author: Bill Perry +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996, 97, 98, 99, 2001 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 'url-parse) +(autoload 'timezone-parse-date "timezone") +(autoload 'timezone-make-date-arpa-standard "timezone") + +(defvar url-parse-args-syntax-table + (copy-syntax-table emacs-lisp-mode-syntax-table) + "A syntax table for parsing sgml attributes.") + +(modify-syntax-entry ?' "\"" url-parse-args-syntax-table) +(modify-syntax-entry ?` "\"" url-parse-args-syntax-table) +(modify-syntax-entry ?{ "(" url-parse-args-syntax-table) +(modify-syntax-entry ?} ")" url-parse-args-syntax-table) + +;;;###autoload +(defcustom url-debug nil + "*What types of debug messages from the URL library to show. +Debug messages are logged to the *URL-DEBUG* buffer. + +If t, all messages will be logged. +If a number, all messages will be logged, as well shown via `message'. +If a list, it is a list of the types of messages to be logged." + :type '(choice (const :tag "none" nil) + (const :tag "all" t) + (checklist :tag "custom" + (const :tag "HTTP" :value http) + (const :tag "DAV" :value dav) + (const :tag "General" :value retrieval) + (const :tag "Filename handlers" :value handlers) + (symbol :tag "Other"))) + :group 'url-hairy) + +;;;###autoload +(defun url-debug (tag &rest args) + (if quit-flag + (error "Interrupted!")) + (if (or (eq url-debug t) + (numberp url-debug) + (and (listp url-debug) (memq tag url-debug))) + (save-excursion + (set-buffer (get-buffer-create "*URL-DEBUG*")) + (goto-char (point-max)) + (insert (symbol-name tag) " -> " (apply 'format args) "\n") + (if (numberp url-debug) + (apply 'message args))))) + +;;;###autoload +(defun url-parse-args (str &optional 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 + st + nd + ) + (save-excursion + (save-restriction + (set-buffer (get-buffer-create " *urlparse-temp*")) + (set-syntax-table url-parse-args-syntax-table) + (erase-buffer) + (insert str) + (setq st (point-min) + nd (point-max)) + (set-syntax-table url-parse-args-syntax-table) + (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)))) + +;;;###autoload +(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)) + +;;;###autoload +(defun url-normalize-url (url) + "Return a 'normalized' version of URL. +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" "info")) + (setq retval url) + (url-set-target data nil) + (setq retval (url-recreate-url data))) + retval)) + +;;;###autoload +(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) + (active-minibuffer-window) + (= url-lazy-message-time + (setq url-lazy-message-time (nth 1 (current-time))))) + nil + (apply 'message args))) + +;;;###autoload +(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-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)))) + +;;;###autoload +(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))) + +;;;###autoload +(defun url-pretty-length (n) + (cond + ((< n 1024) + (format "%d bytes" n)) + ((< n (* 1024 1024)) + (format "%dk" (/ n 1024.0))) + (t + (format "%2.2fM" (/ n (* 1024 1024.0)))))) + +;;;###autoload +(defun url-display-percentage (fmt perc &rest args) + (if (null fmt) + (if (fboundp 'clear-progress-display) + (clear-progress-display)) + (if (and (fboundp 'progress-display) perc) + (apply 'progress-display fmt perc args) + (apply 'message fmt args)))) + +;;;###autoload +(defun url-percentage (x y) + (if (fboundp 'float) + (round (* 100 (/ x (float y)))) + (/ (* x 100) y))) + +;;;###autoload +(defun url-basepath (file &optional x) + "Return the base pathname of FILE, or the actual filename if X is true." + (cond + ((null file) "") + ((string-match (eval-when-compile (regexp-quote "?")) file) + (if x + (file-name-nondirectory (substring file 0 (match-beginning 0))) + (file-name-directory (substring file 0 (match-beginning 0))))) + (x (file-name-nondirectory file)) + (t (file-name-directory file)))) + +;;;###autoload +(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))) + +;;;###autoload +(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)) + +(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_ reserved in the URL spec. +This is taken from RFC 2396.") + +;;;###autoload +(defun url-hexify-string (str) + "Escape characters in a string." + (mapconcat + (lambda (char) + ;; Fixme: use a char table instead. + (if (not (memq char url-unreserved-chars)) + (if (< char 16) + (format "%%0%X" char) + (if (> char 255) + (error "Hexifying multibyte character %s" str)) + (format "%%%X" char)) + (char-to-string char))) + str "")) + +;;;###autoload +(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 + (setq fname (url-basepath fname t)) + (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 + ""))) + +;;;###autoload +(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)) + +;;;###autoload +(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. + +This uses `url-current-object', set locally to the buffer." + (interactive) + (if (not url-current-object) + nil + (if no-show + (url-recreate-url url-current-object) + (message "%s" (url-recreate-url url-current-object))))) + +(eval-and-compile + (defvar url-get-url-filename-chars "-%.?@a-zA-Z0-9()_/:~=&" + "Valid characters in a URL") + ) + +(defun url-get-url-at-point (&optional pt) + "Get the URL closest to point, but don't change 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 (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 (and (char-after (point)) + (string-match (eval-when-compile + (concat "[" url-get-url-filename-chars "]")) + (char-to-string (char-after (point))))) + (progn + (skip-chars-backward url-get-url-filename-chars) + (setq start (point)) + (skip-chars-forward url-get-url-filename-chars)) + (setq start (point))) + (setq url (buffer-substring-no-properties start (point)))) + (if (and url (string-match "^(.*)\\.?$" url)) + (setq url (match-string 1 url))) + (if (and url (string-match "^URL:" url)) + (setq url (substring url 4 nil))) + (if (and url (string-match "\\.$" url)) + (setq url (substring url 0 -1))) + (if (and url (string-match "^www\\." url)) + (setq url (concat "http://" url))) + (if (and url (not (string-match url-nonrelative-link url))) + (setq url nil)) + url))) + +(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-extract-mime-headers () + "Set `url-current-mime-headers' in current buffer." + (save-excursion + (goto-char (point-min)) + (unless url-current-mime-headers + (set (make-local-variable 'url-current-mime-headers) + (mail-header-extract))))) + +(provide 'url-util) + +;;; arch-tag: 24352abc-5a5a-412e-90cd-313b26bed5c9 diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url-vars.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url-vars.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,436 @@ +;;; url-vars.el --- Variables for Uniform Resource Locator tool +;; Author: $Author: miles $ +;; Created: $Date: 2004/04/04 04:44:10 $ +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996, 97, 98, 99, 2001 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 'mm-util) +(eval-when-compile (require 'cl)) + +(defconst url-version (let ((x "$State: Exp $")) + (if (string-match "State: \\([^ \t\n]+\\)" x) + (substring x (match-beginning 1) (match-end 1)) + x)) + "Version number of URL package.") + +(defgroup url nil + "Uniform Resource Locator tool" + :group 'hypermedia) + +(defgroup url-file nil + "URL storage" + :prefix "url-" + :group 'url) + +(defgroup url-cache nil + "URL cache" + :prefix "url-" + :prefix "url-cache-" + :group 'url) + +(defgroup url-mime nil + "MIME options of URL" + :prefix "url-" + :group 'url) + +(defgroup url-hairy nil + "Hairy options of URL" + :prefix "url-" + :group 'url) + + +(defvar url-current-object nil + "A parsed representation of the current url.") + +(defvar url-current-mime-headers nil + "A parsed representation of the MIME headers for the current url.") + +(mapcar 'make-variable-buffer-local + '( + url-current-object + url-current-referer + url-current-mime-headers + )) + +(defcustom url-honor-refresh-requests t + "*Whether to do automatic page reloads. +These are done at the request of the document author or the server via +the `Refresh' header in an HTTP 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." + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (const :tag "ask" 'ask)) + :group 'url-hairy) + +(defcustom url-automatic-caching nil + "*If non-nil, all documents will be automatically cached to the local disk." + :type 'boolean + :group 'url-cache) + +;; Fixme: sanitize this. +(defcustom url-cache-expired + (lambda (t1 t2) (>= (- (car t2) (car t1)) 5)) + "*A function determining if a cached item has expired. +It takes two times (numbers) as its arguments, and returns non-nil if +the second time is 'too old' when compared to the first time." + :type 'function + :group 'url-cache) + +(defvar url-bug-address "w3-bugs@xemacs.org" + "Where to send bug reports.") + +(defcustom url-personal-mail-address nil + "*Your full email address. +This is what is sent to HTTP servers as the FROM field in an HTTP +request." + :type '(choice (const :tag "Unspecified" nil) string) + :group 'url) + +(defcustom 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 +using `dired' to view the directory." + :type 'string + :group 'url-file) + +;; Fixme: this should have a setter which calls url-setup-privacy-info. +(defcustom url-privacy-level '(email) + "*How private you want your requests to be. +HTTP 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." + :type '(radio (const :tag "None (you believe in the basic goodness of humanity)" + :value none) + (const :tag "Low (do not reveal last location)" + :value low) + (const :tag "High (no email address or last location)" + :value high) + (const :tag "Paranoid (reveal nothing!)" + :value paranoid) + (checklist :tag "Custom" + (const :tag "Email address" :value email) + (const :tag "Operating system" :value os) + (const :tag "Last location" :value lastloc) + (const :tag "Browser identification" :value agent) + (const :tag "No cookies" :value cookie))) + :group 'url) + +(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.") + +(defcustom url-uncompressor-alist '((".z" . "x-gzip") + (".gz" . "x-gzip") + (".uue" . "x-uuencoded") + (".hqx" . "x-hqx") + (".Z" . "x-compress") + (".bz2" . "x-bzip2")) + "*An alist of file extensions and appropriate content-transfer-encodings." + :type '(repeat (cons :format "%v" + (string :tag "Extension") + (string :tag "Encoding"))) + :group 'url-mime) + +(defcustom url-mail-command (if (fboundp 'compose-mail) + 'compose-mail + '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." + :type 'function + :group 'url) + +(defcustom url-proxy-services nil + "*An alist of schemes and proxy servers that gateway them. +Looks like ((\"http\" . \"hostname:portnumber\") ...). This is set up +from the ACCESS_proxy environment variables." + :type '(repeat (cons :format "%v" + (string :tag "Protocol") + (string :tag "Proxy"))) + :group 'url) + +(defcustom url-passwd-entry-func nil + "*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." + :type '(choice (const :tag "Guess" :value nil) + (const :tag "Use Ange-FTP" :value ange-ftp-read-passwd) + (const :tag "Use EFS" :value efs-read-passwd) + (const :tag "Use Password Package" :value read-passwd) + (function :tag "Other")) + :group 'url-hairy) + +(defcustom url-standalone-mode nil + "*Rely solely on the cache?" + :type 'boolean + :group 'url-cache) + +(defvar url-mime-separator-chars (mapcar 'identity + (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz" + "0123456789'()+_,-./=?")) + "Characters allowable in a MIME multipart separator.") + +(defcustom 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." + :type '(repeat (string :tag "Port")) + :group 'url-hairy) + +(defvar url-mime-content-type-charset-regexp + ";[ \t]*charset=\"?\\([^\"]+\\)\"?" + "Regexp used in parsing `Content-Type' for a charset indication.") + +(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.") + +;; FIXME!! (RFC 2616 gives examples like `compress, gzip'.) +(defvar url-mime-encoding-string nil + "*String to send in the Accept-encoding: field in HTTP requests.") + +;; `mm-mime-mule-charset-alist' in Gnus 5.8/9 contains elements whose +;; cars aren't valid MIME charsets/coding systems, at least in Emacs. +;; This gets it correct by construction in Emacs. Fixme: DTRT for +;; XEmacs -- its `coding-system-list' doesn't have the BASE-ONLY arg. +(when (and (not (featurep 'xemacs)) + (fboundp 'coding-system-list)) + (setq mm-mime-mule-charset-alist + (apply + 'nconc + (mapcar + (lambda (cs) + (when (and (coding-system-get cs 'mime-charset) + (not (eq t (coding-system-get cs 'safe-charsets)))) + (list (cons (coding-system-get cs 'mime-charset) + (delq 'ascii + (coding-system-get cs 'safe-charsets)))))) + (coding-system-list 'base-only))))) + +;; Perhaps the first few should actually be given decreasing `q's and +;; the list should be trimmed significantly. +;; Fixme: do something sane if we don't have `sort-coding-systems' +;; (Emacs 20, XEmacs). +(defun url-mime-charset-string () + "Generate a list of preferred MIME charsets for HTTP requests. +Generated according to current coding system priorities." + (if (fboundp 'sort-coding-systems) + (let ((ordered (sort-coding-systems + (let (accum) + (dolist (elt mm-mime-mule-charset-alist) + (if (mm-coding-system-p (car elt)) + (push (car elt) accum))) + (nreverse accum))))) + (concat (format "%s;q=1, " (pop ordered)) + (mapconcat 'symbol-name ordered ";q=0.5, ") + ";q=0.5")))) + +(defvar url-mime-charset-string (url-mime-charset-string) + "*String to send in the Accept-charset: field in HTTP requests. +The MIME charset corresponding to the most preferred coding system is +given priority 1 and the rest are given priority 0.5.") + +(defun url-set-mime-charset-string () + (setq url-mime-charset-string (url-mime-charset-string))) +;; Regenerate if the language environment changes. +(add-hook 'set-language-environment-hook 'url-set-mime-charset-string) + +;; Fixme: set from the locale. +(defcustom url-mime-language-string nil + "*String to send in the Accept-language: field in HTTP requests. + +Specifies the preferred language when servers can serve documents in +several languages. Use RFC 1766 abbreviations, e.g.@: `en' for +English, `de' for German. A comma-separated specifies descending +order of preference. The ordering can be made explicit using `q' +factors defined by HTTP, e.g. `de,en-gb;q=0.8,en;q=0.7'. `*' means +get the first available language (as opposed to the default)." + :type '(radio + (const :tag "None (get default language version)" :value nil) + (const :tag "Any (get first available language version)" :value "*") + (string :tag "Other")) + :group 'url-mime + :group 'i18n) + +(defvar url-mime-accept-string nil + "String to send to the server in the Accept: field in HTTP requests.") + +(defvar url-package-version nil + "Version number of package using URL.") + +(defvar url-package-name nil "Version number 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.") + +(defcustom url-max-password-attempts 5 + "*Maximum number of times a password will be prompted for. +Applies when a protected document is denied by the server." + :type 'integer + :group 'url) + +(defcustom url-temporary-directory (or (getenv "TMPDIR") "/tmp") + "*Where temporary files go." + :type 'directory + :group 'url-file) + +(defcustom 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." + :type 'boolean + :group 'url) + +(defvar url-using-proxy nil + "Either nil or the fully qualified proxy URL in use, e.g. +http://www.domain.com/") + +(defcustom url-news-server nil + "*The default news server from which to get newsgroups/articles. +Applies if no server is specified in the URL. Defaults to the +environment variable NNTPSERVER or \"news\" if NNTPSERVER is +undefined." + :type '(choice (const :tag "None" :value nil) string) + :group 'url) + +(defvar url-nonrelative-link + "\\`\\([-a-zA-Z0-9+.]+:\\)" + "A regular expression that will match an absolute URL.") + +(defcustom 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 given." + :type '(choice (const :tag "Short (y or n)" :value y-or-n-p) + (const :tag "Long (yes or no)" :value yes-or-no-p) + (function :tag "Other")) + :group 'url-hairy) + +(defcustom url-gateway-method 'native + "*The type of gateway support to use. +Should be a symbol specifying how to get a connection from the local machine. + +Currently supported methods: +`telnet': Run telnet in a subprocess to connect; +`rlogin': Rlogin to another machine to connect; +`socks': Connect through a socks server; +`ssl': Connect with SSL; +`native': Connect directy." + :type '(radio (const :tag "Telnet to gateway host" :value telnet) + (const :tag "Rlogin to gateway host" :value rlogin) + (const :tag "Use SOCKS proxy" :value socks) + (const :tag "Use SSL for all connections" :value ssl) + (const :tag "Direct connection" :value native)) + :group 'url-hairy) + +(defvar url-setup-done nil "Has setup configuration been done?") + +(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) + +;; Fixme: We may not be able to run SSL. +(defvar url-extensions-header "Security/Digest Security/SSL") + +(defvar url-parse-syntax-table + (copy-syntax-table emacs-lisp-mode-syntax-table) + "*A syntax table for parsing URLs.") + +(modify-syntax-entry ?' "\"" url-parse-syntax-table) +(modify-syntax-entry ?` "\"" url-parse-syntax-table) +(modify-syntax-entry ?< "(>" url-parse-syntax-table) +(modify-syntax-entry ?> ")<" url-parse-syntax-table) +(modify-syntax-entry ?/ " " url-parse-syntax-table) + +(defvar url-load-hook nil + "*Hooks to be run after initalizing the URL library.") + +;;; Make OS/2 happy - yeeks +;; (defvar tcp-binary-process-input-services nil +;; "*Make OS/2 happy with our CRLF pairs...") + +(defconst url-working-buffer " *url-work") + +(defvar url-gateway-unplugged nil + "Non-nil means don't open new network connexions. +This should be set, e.g. by mail user agents rendering HTML to avoid +`bugs' which call home.") + +(defun url-vars-unload-hook () + (remove-hook 'set-language-environment-hook 'url-set-mime-charset-string)) + +(provide 'url-vars) + +;;; arch-tag: 29205e5f-c5ce-433c-8d5d-38cbaed64b49 +;;; url-vars.el ends here diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/url.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/url.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,270 @@ +;;; url.el --- Uniform Resource Locator retrieval tool +;; Author: Bill Perry +;; Version: $Revision: 1.2 $ +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993 - 1996 by William M. Perry +;;; Copyright (c) 1996, 97, 98, 99, 2001 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes + +(eval-when-compile (require 'cl)) +;; Don't require CL at runtime if we can avoid it (Emacs 21). +;; Otherwise we need it for hashing functions. `puthash' was never +;; defined in the Emacs 20 cl.el for some reason. +(if (fboundp 'puthash) + nil ; internal or CL is loaded + (defalias 'puthash 'cl-puthash) + (autoload 'cl-puthash "cl") + (autoload 'gethash "cl") + (autoload 'maphash "cl") + (autoload 'make-hash-table "cl")) + +(eval-when-compile + (require 'mm-decode) + (require 'mm-view)) + +(require 'mailcap) +(require 'url-vars) +(require 'url-cookie) +(require 'url-history) +(require 'url-expand) +(require 'url-privacy) +(require 'url-methods) +(require 'url-proxy) +(require 'url-parse) +(require 'url-util) + +;; Fixme: customize? convert-standard-filename? +;;;###autoload +(defvar url-configuration-directory "~/.url") + +(defun url-do-setup () + "Setup the url package. +This is to avoid conflict with user settings if URL is dumped with +Emacs." + (unless url-setup-done + + ;; Make OS/2 happy + ;;(push '("http" "80") tcp-binary-process-input-services) + + (mailcap-parse-mailcaps) + (mailcap-parse-mimetypes) + + ;; Register all the authentication schemes we can handle + (url-register-auth-scheme "basic" nil 4) + (url-register-auth-scheme "digest" nil 7) + + (setq url-cookie-file + (or url-cookie-file + (expand-file-name "cookies" url-configuration-directory))) + + (setq url-history-file + (or url-history-file + (expand-file-name "history" url-configuration-directory))) + + ;; Parse the global history file if it exists, so that it can be used + ;; for URL completion, etc. + (url-history-parse-history) + (url-history-setup-save-timer) + + ;; Ditto for cookies + (url-cookie-setup-save-timer) + (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 + (lambda (x) + (cond + ((= x ?,) "\\|") + ((= x ? ) "") + ((= x ?.) (regexp-quote ".")) + ((= x ?*) ".*") + ((= x ??) ".") + (t (char-to-string x)))) + noproxy "") "\\)")) + url-proxy-services)))) + + ;; 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 + ((fboundp '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 (featurep 'xemacs)))) ; ?? + (setq url-passwd-entry-func 'ange-ftp-read-passwd)) + (t + (url-warn + 'security + "(url-setup): Can't determine how to read passwords, winging it."))) + + (url-setup-privacy-info) + (run-hooks 'url-load-hook) + (setq url-setup-done t))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Retrieval functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun url-retrieve (url callback &optional cbargs) + "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished. +The callback is called when the object has been completely retrieved, with +the current buffer containing the object, and any MIME headers associated +with it. URL is either a string or a parsed URL. + +Return the buffer URL will load into, or nil if the process has +already completed." + (url-do-setup) + (url-gc-dead-buffers) + (if (stringp url) + (set-text-properties 0 (length url) nil url)) + (if (not (vectorp url)) + (setq url (url-generic-parse-url url))) + (if (not (functionp callback)) + (error "Must provide a callback function to url-retrieve")) + (unless (url-type url) + (error "Bad url: %s" (url-recreate-url url))) + (let ((loader (url-scheme-get-property (url-type url) 'loader)) + (url-using-proxy (if (url-host url) + (url-find-proxy-for-url url (url-host url)))) + (buffer nil) + (asynch (url-scheme-get-property (url-type url) 'asynchronous-p))) + (if url-using-proxy + (setq asynch t + loader 'url-proxy)) + (if asynch + (setq buffer (funcall loader url callback cbargs)) + (setq buffer (funcall loader url)) + (if buffer + (save-excursion + (set-buffer buffer) + (apply callback cbargs)))) + (url-history-update-url url (current-time)) + buffer)) + +(defun url-retrieve-synchronously (url) + "Retrieve URL synchronously. +Return the buffer containing the data, or nil if there are no data +associated with it (the case for dired, info, or mailto URLs that need +no further processing). URL is either a string or a parsed URL." + (url-do-setup) + + (lexical-let ((retrieval-done nil) + (asynch-buffer nil)) + (setq asynch-buffer + (url-retrieve url (lambda (&rest ignored) + (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) + (setq retrieval-done t + asynch-buffer (current-buffer))))) + (if (not asynch-buffer) + ;; We do not need to do anything, it was a mailto or something + ;; similar that takes processing completely outside of the URL + ;; package. + nil + (while (not retrieval-done) + (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" + retrieval-done asynch-buffer) + ;; Quoth monnier: + ;; It turns out that the problem seems to be that the (sit-for + ;; 0.1) below doesn't actually process the data: instead it + ;; returns immediately because there is keyboard input + ;; waiting, so we end up spinning endlessly waiting for the + ;; process to finish while not letting it finish. + + ;; However, raman claims that it blocks Emacs with Emacspeak + ;; for unexplained reasons. Put back for his benefit until + ;; someone can understand it. + ;; (sleep-for 0.1) + (sit-for 0.1)) + asynch-buffer))) + +(defun url-mm-callback (&rest ignored) + (let ((handle (mm-dissect-buffer t))) + (save-excursion + (url-mark-buffer-as-dead (current-buffer)) + (set-buffer (generate-new-buffer (url-recreate-url url-current-object))) + (if (eq (mm-display-part handle) 'external) + (progn + (set-process-sentinel + ;; Fixme: this shouldn't have to know the form of the + ;; undisplayer produced by `mm-display-part'. + (get-buffer-process (cdr (mm-handle-undisplayer handle))) + `(lambda (proc event) + (mm-destroy-parts (quote ,handle)))) + (message "Viewing externally") + (kill-buffer (current-buffer))) + (display-buffer (current-buffer)) + (mm-destroy-parts handle))))) + +(defun url-mm-url (url) + "Retrieve URL and pass to the appropriate viewing application." + (require 'mm-decode) + (require 'mm-view) + (url-retrieve url 'url-mm-callback nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Miscellaneous +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar url-dead-buffer-list nil) + +(defun url-mark-buffer-as-dead (buff) + (push buff url-dead-buffer-list)) + +(defun url-gc-dead-buffers () + (let ((buff)) + (while (setq buff (pop url-dead-buffer-list)) + (if (buffer-live-p buff) + (kill-buffer buff))))) + +(cond + ((fboundp 'display-warning) + (defalias 'url-warn 'display-warning)) + ((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 "*URL-WARNINGS*")) + (goto-char (point-max)) + (save-excursion + (insert (format "(%s/%s) %s\n" class (or level 'warning) message))) + (display-buffer (current-buffer)))))) + +(provide 'url) + +;;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a +;;; url.el ends here diff -r 7f60e040ccfc -r 1029206e72f2 lisp/url/vc-dav.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/url/vc-dav.el Thu Apr 08 12:29:09 2004 +0000 @@ -0,0 +1,179 @@ +;;; vc-dav.el --- vc.el support for WebDAV + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; Author: Bill Perry +;; Maintainer: Bill Perry +;; Version: $Revision: 1.2 $ +;; Keywords: url, vc + +;; 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) +(require 'url-dav) + +;;; Required functions for a vc backend +(defun vc-dav-registered (url) + "Return t iff URL is registered with a DAV aware server." + (url-dav-vc-registered url)) + +(defun vc-dav-state (url) + "Return the current version control state of URL. +For a list of possible values, see `vc-state'." + ;; Things we can support for WebDAV + ;; + ;; up-to-date - use lockdiscovery + ;; edited - check for an active lock by us + ;; USER - use lockdiscovery + owner + ;; + ;; These don't make sense for WebDAV + ;; needs-patch + ;; needs-merge + ;; unlocked-changes + (let ((locks (url-dav-active-locks url))) + (cond + ((null locks) 'up-to-date) + ((assoc url locks) + ;; SOMEBODY has a lock... let's find out who. + (setq locks (cdr (assoc url locks))) + (if (rassoc url-dav-lock-identifier locks) + ;; _WE_ have a lock + 'edited + (cdr (car locks))))))) + +(defun vc-dav-checkout-model (url) + "Indicate whether URL needs to be \"checked out\" before it can be edited. +See `vc-checkout-model' for a list of possible values." + ;; The only thing we can support with webdav is 'locking + 'locking) + +;; This should figure out the version # of the file somehow. What is +;; the most appropriate property in WebDAV to look at for this? +(defun vc-dav-workfile-version (url) + "Return the current workfile version of URL." + "Unknown") + +(defun vc-dav-register (url &optional rev comment) + "Register URL in the DAV backend." + ;; Do we need to do anything here? FIXME? + ) + +(defun vc-dav-checkin (url rev comment) + "Commit changes in URL to WebDAV. +If REV is non-nil, that should become the new revision number. +COMMENT is used as a check-in comment." + ;; This should PUT the resource and release any locks that we hold. + ) + +(defun vc-dav-checkout (url &optional editable rev destfile) + "Check out revision REV of URL into the working area. + +If EDITABLE is non-nil URL should be writable by the user and if +locking is used for URL, a lock should also be set. + +If REV is non-nil, that is the revision to check out. If REV is the +empty string, that means to check ou tht ehead of the trunk. + +If optional arg DESTFILE is given, it is an alternate filename to +write the contents to. +" + ;; This should LOCK the resource. + ) + +(defun vc-dav-revert (url &optional contents-done) + "Revert URL back to the current workfile version. + +If optional arg CONTENTS-DONE is non-nil, then the contents of FILE +have already been reverted from a version backup, and this function +only needs to update the status of URL within the backend. +" + ;; Should do a GET if !contents_done + ;; Should UNLOCK the file. + ) + +(defun vc-dav-print-log (url) + "Insert the revision log of URL into the *vc* buffer." + ) + +(defun vc-dav-diff (url &optional rev1 rev2) + "Insert the diff for URL into the *vc-diff* buffer. +If REV1 and REV2 are non-nil report differences from REV1 to REV2. +If REV1 is nil, use the current workfile version as the older version. +If REV2 is nil, use the current workfile contents as the nwer version. + +It should return a status of either 0 (no differences found), or +1 (either non-empty diff or the diff is run asynchronously). +" + ;; We should do this asynchronously... + ;; How would we do it at all, that is the question! + ) + + + +;;; Optional functions +;; Should be faster than vc-dav-state - but how? +(defun vc-dav-state-heuristic (url) + "Estimate the version control state of URL at visiting time." + (vc-dav-state url)) + +;; This should use url-dav-get-properties with a depth of `1' to get +;; all the properties. +(defun vc-dav-dir-state (url) + "find the version control state of all files in DIR in a fast way." + ) + +(defun vc-dav-workfile-unchanged-p (url) + "Return non-nil if URL is unchanged from its current workfile version." + ;; Probably impossible with webdav + ) + +(defun vc-dav-responsible-p (url) + "Return non-nil if DAV considers itself `responsible' for URL." + ;; Check for DAV support on the web server. + t) + +(defun vc-dav-could-register (url) + "Return non-nil if URL could be registered under this backend." + ;; Check for DAV support on the web server. + t) + +;;; Unimplemented functions +;; +;; vc-dav-latest-on-branch-p(URL) +;; Return non-nil if the current workfile version of FILE is the +;; latest on its branch. There are no branches in webdav yet. +;; +;; vc-dav-mode-line-string(url) +;; Return a dav-specific mode line string for URL. Are there any +;; specific states that we want exposed? +;; +;; vc-dav-dired-state-info(url) +;; Translate the `vc-state' property of URL into a string that can +;; be used in a vc-dired buffer. Are there any extra states that +;; we want exposed? +;; +;; vc-dav-receive-file(url rev) +;; Let this backend `receive' a file that is already registered +;; under another backend. The default just calls `register', which +;; should be sufficient for WebDAV. +;; +;; vc-dav-unregister(url) +;; Unregister URL. Not possible with WebDAV, other than by +;; deleting the resource. + +(provide 'vc-dav) + +;;; arch-tag: 0a0fb9fe-8190-4c0a-a179-5c291d3a467e diff -r 7f60e040ccfc -r 1029206e72f2 lispref/ChangeLog --- a/lispref/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/lispref/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,3 +1,19 @@ +2004-04-05 Jesper Harder + + * variables.texi (Variable Aliases): Mention + cyclic-variable-indirection. + + * errors.texi (Standard Errors): Ditto. + +2004-04-04 Luc Teirlinck + + * backups.texi: Various small changes in addition to: + (Making Backups): Mention return value of `backup-buffer'. + (Auto-Saving): Mention optional FORCE argument to + `delete-auto-save-file-if-necessary'. + (Reverting): Mention optional PRESERVE-MODES argument to + `revert-buffer'. Correct description of `revert-buffer-function'. + 2004-03-22 Juri Linkov * sequences.texi (Sequence Functions): Replace xref to `Vectors' @@ -578,7 +594,7 @@ * objects.texi (Integer Type): Update for extra bit of integer range. (Character Type): Ditto. -2003-10-16 Eli Zaretskii +2003-10-16 Eli Zaretskii * numbers.texi (Integer Basics): Add index entries for reading numbers in hex, octal, and binary. diff -r 7f60e040ccfc -r 1029206e72f2 lispref/backups.texi --- a/lispref/backups.texi Sat Apr 03 20:24:17 2004 +0000 +++ b/lispref/backups.texi Thu Apr 08 12:29:09 2004 +0000 @@ -55,6 +55,14 @@ This function makes a backup of the file visited by the current buffer, if appropriate. It is called by @code{save-buffer} before saving the buffer the first time. + +If a backup was made by renaming, the return value is a cons cell of +the form (@var{modes} . @var{backupname}), where @var{modes} are the +mode bits of the original file, as returned by @code{file-modes} +(@pxref{File Attributes,, Other Information about Files}), and +@var{backupname} is the name of the backup. In all other cases, that +is, if a backup was made by copying or if no backup was made, this +function returns @code{nil}. @end defun @defvar buffer-backed-up @@ -90,7 +98,7 @@ @defvar backup-enable-predicate This variable's value is a function to be called on certain occasions to decide whether a file should have backup files. The function receives -one argument, a file name to consider. If the function returns +one argument, an absolute file name to consider. If the function returns @code{nil}, backups are disabled for that file. Otherwise, the other variables in this section say whether and how to make backups. @@ -146,6 +154,7 @@ This variable's value is a function to use for making backups instead of the default @code{make-backup-file-name}. A value of @code{nil} gives the default @code{make-backup-file-name} behaviour. +@xref{Backup Names,, Naming Backup Files}. This could be buffer-local to do something special for specific files. If you define it, you may need to change @@ -184,25 +193,25 @@ if non-@code{nil}, also has this effect (as a sideline of its main significance). @xref{Saving Buffers}. -@defvar backup-by-copying +@defopt backup-by-copying If this variable is non-@code{nil}, Emacs always makes backup files by copying. -@end defvar +@end defopt The following two variables, when non-@code{nil}, cause the second method to be used in certain special cases. They have no effect on the treatment of files that don't fall into the special cases. -@defvar backup-by-copying-when-linked +@defopt backup-by-copying-when-linked If this variable is non-@code{nil}, Emacs makes backups by copying for files with multiple names (hard links). This variable is significant only if @code{backup-by-copying} is @code{nil}, since copying is always used when that variable is non-@code{nil}. -@end defvar +@end defopt -@defvar backup-by-copying-when-mismatch +@defopt backup-by-copying-when-mismatch If this variable is non-@code{nil}, Emacs makes backups by copying in cases where renaming would change either the owner or the group of the file. @@ -214,9 +223,9 @@ This variable is significant only if @code{backup-by-copying} is @code{nil}, since copying is always used when that variable is non-@code{nil}. -@end defvar +@end defopt -@defvar backup-by-copying-when-privileged-mismatch +@defopt backup-by-copying-when-privileged-mismatch This variable, if non-@code{nil}, specifies the same behavior as @code{backup-by-copying-when-mismatch}, but only for certain user-id values: namely, those less than or equal to a certain number. You set @@ -227,7 +236,7 @@ when necessary to prevent a change in the owner of the file. The default is 200. -@end defvar +@end defopt @node Numbered Backups @subsection Making and Deleting Numbered Backup Files @@ -379,7 +388,8 @@ @var{filename}. It may also propose certain existing backup files for deletion. @code{find-backup-file-name} returns a list whose @sc{car} is the name for the new backup file and whose @sc{cdr} is a list of backup -files whose deletion is proposed. +files whose deletion is proposed. The value can also be @code{nil}, +which means not to make a backup. Two variables, @code{kept-old-versions} and @code{kept-new-versions}, determine which backup versions should be kept. This function keeps @@ -518,7 +528,7 @@ change @code{auto-save-file-name-p} in a corresponding way. @end defun -@defvar auto-save-visited-file-name +@defopt auto-save-visited-file-name If this variable is non-@code{nil}, Emacs auto-saves buffers in the files they are visiting. That is, the auto-save is done in the same file that you are editing. Normally, this variable is @code{nil}, so @@ -530,7 +540,7 @@ reenabled in it. If auto-save mode is already enabled, auto-saves continue to go in the same file name until @code{auto-save-mode} is called again. -@end defvar +@end defopt @defun recent-auto-save-p This function returns @code{t} if the current buffer has been @@ -547,7 +557,8 @@ The value of this variable specifies how often to do auto-saving, in terms of number of input events. Each time this many additional input events are read, Emacs does auto-saving for all buffers in which that is -enabled. +enabled. Setting this to zero disables autosaving based on the +number of characters typed. @end defopt @defopt auto-save-timeout @@ -586,24 +597,28 @@ is auto-saved. @end deffn -@defun delete-auto-save-file-if-necessary +@defun delete-auto-save-file-if-necessary &optional force This function deletes the current buffer's auto-save file if @code{delete-auto-save-files} is non-@code{nil}. It is called every time a buffer is saved. + +Unless @var{force} is non-@code{nil}, this function only deletes the +file if it was written by the current Emacs session since the last +true save. @end defun -@defvar delete-auto-save-files +@defopt delete-auto-save-files This variable is used by the function @code{delete-auto-save-file-if-necessary}. If it is non-@code{nil}, Emacs deletes auto-save files when a true save is done (in the visited file). This saves disk space and unclutters your directory. -@end defvar +@end defopt @defun rename-auto-save-file This function adjusts the current buffer's auto-save file name if the visited file name has changed. It also renames an existing auto-save -file. If the visited file name has not changed, this function does -nothing. +file, if it was made in the current Emacs session. If the visited +file name has not changed, this function does nothing. @end defun @defvar buffer-saved-size @@ -654,7 +669,7 @@ of the file with the @code{revert-buffer} command. @xref{Reverting, , Reverting a Buffer, emacs, The GNU Emacs Manual}. -@deffn Command revert-buffer &optional ignore-auto noconfirm +@deffn Command revert-buffer &optional ignore-auto noconfirm preserve-modes This command replaces the buffer text with the text of the visited file on disk. This action undoes all changes since the file was visited or saved. @@ -670,6 +685,10 @@ the buffer; but if the argument @var{noconfirm} is non-@code{nil}, @code{revert-buffer} does not ask for confirmation. +Normally, this command reinitializes the file's major and minor modes +using @code{normal-mode}. But if @var{preserve-modes} is +non-@code{nil}, the modes remain unchanged. + Reverting tries to preserve marker positions in the buffer by using the replacement feature of @code{insert-file-contents}. If the buffer contents and the file contents are identical before the revert @@ -682,22 +701,24 @@ You can customize how @code{revert-buffer} does its work by setting the variables described in the rest of this section. -@defvar revert-without-query +@defopt revert-without-query This variable holds a list of files that should be reverted without query. The value is a list of regular expressions. If the visited file name matches one of these regular expressions, and the file has changed on disk but the buffer is not modified, then @code{revert-buffer} reverts the file without asking the user for confirmation. -@end defvar +@end defopt Some major modes customize @code{revert-buffer} by making buffer-local bindings for these variables: @defvar revert-buffer-function -The value of this variable is the function to use to revert this buffer. -If non-@code{nil}, it is called as a function with no arguments to do -the work of reverting. If the value is @code{nil}, reverting works the -usual way. +The value of this variable is the function to use to revert this +buffer. If non-@code{nil}, it should be a function with two optional +arguments to do the work of reverting. The two optional arguments, +@var{ignore-auto} and @var{noconfirm}, are the arguments that +@code{revert-buffer} received. If the value is @code{nil}, reverting +works the usual way. Modes such as Dired mode, in which the text being edited does not consist of a file's contents but can be regenerated in some other diff -r 7f60e040ccfc -r 1029206e72f2 lispref/errors.texi --- a/lispref/errors.texi Sat Apr 03 20:24:17 2004 +0000 +++ b/lispref/errors.texi Thu Apr 08 12:29:09 2004 +0000 @@ -62,6 +62,10 @@ @code{"Symbol's chain of function indirections\@* contains a loop"}@* @xref{Function Indirection}. +@item cyclic-variable-indirection +@code{"Symbol's chain of variable indirections contains a loop"}@* +@xref{Variable Aliases}. + @item end-of-buffer @code{"End of buffer"}@* @xref{Motion}. diff -r 7f60e040ccfc -r 1029206e72f2 lispref/variables.texi --- a/lispref/variables.texi Sat Apr 03 20:24:17 2004 +0000 +++ b/lispref/variables.texi Thu Apr 08 12:29:09 2004 +0000 @@ -1714,6 +1714,9 @@ This function returns the variable at the end of the chain of aliases of @var{variable}. If @var{variable} is not a symbol, or if @var{variable} is not defined as an alias, the function returns @var{variable}. + +This function signals a @code{cyclic-variable-indirection} error if +there is a loop in the chain of symbols. @end defun @example diff -r 7f60e040ccfc -r 1029206e72f2 man/ChangeLog --- a/man/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/man/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,3 +1,11 @@ +2004-04-05 Kim F. Storm + + * custom.texi (File Variables): Add safe-local-eval-forms. + +2004-04-05 Jesper Harder + + * info.texi (Info Search): Add info-apropos. + 2004-04-02 Luc Teirlinck * files.texi (Reverting): Correct description of revert-buffer's diff -r 7f60e040ccfc -r 1029206e72f2 man/custom.texi --- a/man/custom.texi Sat Apr 03 20:24:17 2004 +0000 +++ b/man/custom.texi Thu Apr 08 12:29:09 2004 +0000 @@ -1060,6 +1060,12 @@ neither @code{t} nor @code{nil}, so normally Emacs does ask for confirmation about file settings for these variables. +@findex safe-local-eval-forms + The @code{safe-local-eval-forms} is a customizable list of eval +forms which are safe to eval, so Emacs should not ask for +confirmation to evaluate these forms, even if +@code{enable-local-variables} says to ask for confirmation in general. + @node Key Bindings @section Customizing Key Bindings @cindex key bindings diff -r 7f60e040ccfc -r 1029206e72f2 man/info.texi --- a/man/info.texi Sat Apr 03 20:24:17 2004 +0000 +++ b/man/info.texi Thu Apr 08 12:29:09 2004 +0000 @@ -1076,6 +1076,12 @@ In Emacs, @kbd{i} runs the command @code{Info-index}. +@findex info-apropos +If you don't know what manual documents something, try the @kbd{M-x +info-apropos} command. It prompts for a string and then looks up that +string in all the indices of all the Info documents installed on your +system. + @kindex s @r{(Info mode)} @findex Info-search The @kbd{s} command allows you to search a whole file for a string. diff -r 7f60e040ccfc -r 1029206e72f2 msdos/ChangeLog --- a/msdos/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/msdos/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,26 +1,26 @@ -2003-09-22 Eli Zaretskii +2003-09-22 Eli Zaretskii * mainmake.v2 (man lispref lispintro): Specify an explicit target `info', like Makefile.in does. -2003-08-31 Eli Zaretskii +2003-08-31 Eli Zaretskii * sed3v2.inp (srcdir): Use "command.com /c cd" to produce an absolute file name of the current working directory. This avoids the warning from Make about circular dependencies. -2003-08-30 Eli Zaretskii +2003-08-30 Eli Zaretskii * sedlisp.inp: Set FNCASE=y for all targets in the lisp directory, so that CVS etc. file names are filtered out of the list of subdirectories. -2003-08-28 Eli Zaretskii +2003-08-28 Eli Zaretskii * sed6.inp (elisp.dvi, index.texi): Replace Unix shell commands with equivalent COMMAND.COM commands. -2003-08-24 Eli Zaretskii +2003-08-24 Eli Zaretskii * sed3v2.inp (EXEEXT): Define to an empty string. diff -r 7f60e040ccfc -r 1029206e72f2 src/ChangeLog --- a/src/ChangeLog Sat Apr 03 20:24:17 2004 +0000 +++ b/src/ChangeLog Thu Apr 08 12:29:09 2004 +0000 @@ -1,3 +1,28 @@ +2004-04-07 Stefan Monnier + + * doc.c (Fsnarf_documentation): Ignore new file name entries. + +2004-04-06 Kim F. Storm + + * msdos.c (clear_mouse_face): Only clear mouse highlight if not hidden. + (dos_rawgetc): Set mouse_face_hidden after clearing highlight. + + * w32term.c (w32_read_socket): Set mouse_face_hidden after + clearing highlight. + + * xdisp.c (clear_mouse_face): Only clear mouse highlight if not hidden. + + * xterm.c (handle_one_xevent): Set mouse_face_hidden after + clearing highlight. + + * indent.c (vmotion): Do not reserve one column for continuation + marks on window frames. + +2004-04-04 Eli Zaretskii + + * charset.h (SINGLE_BYTE_CHAR_P): Fix macro to avoid warnings + from GCC. + 2004-04-03 Stefan Monnier * .gdbinit-union: Remove. @@ -120,7 +145,7 @@ * xfns.c (x_find_image_file): Remove prototype. -2004-03-13 Eli Zaretskii +2004-03-13 Eli Zaretskii * Makefile.in (XMENU_OBJ): Include xmenu.o if HAVE_MENUS is defined. @@ -782,7 +807,7 @@ * w32term.c (w32_draw_fringe_bitmap): Draw overlaid bitmaps correctly over other bitmaps. -2004-02-21 Eli Zaretskii +2004-02-21 Eli Zaretskii * emacs.c (USAGE1): Split into two halves. (USAGE2): Second half of the old USAGE1. @@ -860,7 +885,7 @@ (read_avail_input): Use it to zero out only those slots in buf[] that were used last time we were called. -2004-02-16 Eli Zaretskii +2004-02-16 Eli Zaretskii * Makefile.in (obj): Move fringe.o from here... (XOBJ, MAC_OBJ): ...to here. @@ -1147,7 +1172,7 @@ if vector_ret_p is true. (syms_of_xfns): Sx_send_client_message moved to xselect.c. -2004-02-02 Eli Zaretskii +2004-02-02 Eli Zaretskii * fileio.c (Fcopy_file): If NEWNAME is a directory, expand the basename of FILE relative to it, not FILE itself. @@ -1166,7 +1191,7 @@ (syms_of_fileio): Adapt the docstring of insert-default-directory to the change in Fread_file_name. -2004-01-29 Eli Zaretskii +2004-01-29 Eli Zaretskii * alloca.c [!alloca]: Fix the prototype for xfree. @@ -2241,7 +2266,7 @@ * fontset.c (Finternal_char_font): Change return value to cons (FONT-NAME . GLYPH-CODE). -2003-09-28 Eli Zaretskii +2003-09-28 Eli Zaretskii * term.c (tty_setup_colors): Treat any negative argument as -1. @@ -2273,7 +2298,7 @@ * process.c (Fnetwork_interface_info): Use HAVE_STRUCT_IFREQ... macros. -2003-09-22 Eli Zaretskii +2003-09-22 Eli Zaretskii * term.c (set_tty_color_mode): Use INTEGERP to test whether a color mode is an integer number (it could be -1). @@ -2405,7 +2430,7 @@ * alloc.c: Use long instead of int when casting ABLOCKS_BUSY to avoid warning. -2003-09-07 Eli Zaretskii +2003-09-07 Eli Zaretskii * editfns.c (region_limit): Support any non-zero value of BEGINNINGP. @@ -2492,7 +2517,7 @@ * xfns.c (Vgtk_version_string): New variable. (syms_of_xfns): DEFVAR_LISP it. Provide gtk. -2003-08-24 Eli Zaretskii +2003-08-24 Eli Zaretskii * term.c (term_init): Remove `const' from buffer_size's declaration. diff -r 7f60e040ccfc -r 1029206e72f2 src/charset.h --- a/src/charset.h Sat Apr 03 20:24:17 2004 +0000 +++ b/src/charset.h Thu Apr 08 12:29:09 2004 +0000 @@ -216,7 +216,7 @@ #define MAX_CHAR (0x1F << 14) /* 1 if C is a single byte character, else 0. */ -#define SINGLE_BYTE_CHAR_P(c) ((unsigned) (c) < 0x100) +#define SINGLE_BYTE_CHAR_P(c) (((unsigned)(c) & 0xFF) == (c)) /* 1 if BYTE is an ASCII character in itself, in multibyte mode. */ #define ASCII_BYTE_P(byte) ((byte) < 0x80) @@ -535,7 +535,7 @@ #define CHAR_STRING(c, str) \ (SINGLE_BYTE_CHAR_P (c) \ - ? ((ASCII_BYTE_P (c) || c >= 0xA0) \ + ? ((ASCII_BYTE_P (c) || c >= 0xA0) \ ? (*(str) = (unsigned char)(c), 1) \ : (*(str) = LEADING_CODE_8_BIT_CONTROL, *((str)+ 1) = c + 0x20, 2)) \ : char_to_string (c, (unsigned char *) str)) diff -r 7f60e040ccfc -r 1029206e72f2 src/doc.c --- a/src/doc.c Sat Apr 03 20:24:17 2004 +0000 +++ b/src/doc.c Thu Apr 08 12:29:09 2004 +0000 @@ -1,5 +1,6 @@ /* Record indices of function doc strings stored in a file. - Copyright (C) 1985, 86,93,94,95,97,98,99, 2000 Free Software Foundation, Inc. + Copyright (C) 1985, 86,93,94,95,97,98,99,2000,04 + Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -612,8 +613,7 @@ *p = '_'; p++; } -#endif /* not VMS4_4 */ -#ifdef VMS4_4 +#else /* VMS4_4 */ strcpy (name, sys_translate_unix (name)); #endif /* VMS4_4 */ #endif /* VMS */ @@ -660,6 +660,9 @@ else if (p[1] == 'F') store_function_docstring (sym, pos + end + 1 - buf); + else if (p[1] == 'S') + ; /* Just a source file name boundary marker. Ignore it. */ + else error ("DOC file invalid at position %d", pos); } diff -r 7f60e040ccfc -r 1029206e72f2 src/indent.c --- a/src/indent.c Sat Apr 03 20:24:17 2004 +0000 +++ b/src/indent.c Thu Apr 08 12:29:09 2004 +0000 @@ -1838,9 +1838,7 @@ register int from, vtarget; struct window *w; { - /* We don't need to make room for continuation marks (we have fringes now), - so hould we really subtract 1 here if FRAME_WINDOW_P ? ++KFS */ - int width = window_box_text_cols (w) - 1; + int width = window_box_text_cols (w); int hscroll = XINT (w->hscroll); struct position pos; /* vpos is cumulative vertical position, changed as from is changed */ @@ -1861,6 +1859,12 @@ XSETWINDOW (window, w); + /* We must make room for continuation marks if we don't have fringes. */ +#ifdef HAVE_WINDOW_SYSTEM + if (!FRAME_WINDOW_P (XFRAME (w->frame))) +#endif + width -= 1; + /* If the window contains this buffer, use it for getting text properties. Otherwise use the current buffer as arg for doing that. */ if (EQ (w->buffer, Fcurrent_buffer ())) diff -r 7f60e040ccfc -r 1029206e72f2 src/msdos.c --- a/src/msdos.c Sat Apr 03 20:24:17 2004 +0000 +++ b/src/msdos.c Thu Apr 08 12:29:09 2004 +0000 @@ -1329,7 +1329,7 @@ static void clear_mouse_face (struct display_info *dpyinfo) { - if (! NILP (dpyinfo->mouse_face_window)) + if (!dpyinfo->mouse_face_hidden && ! NILP (dpyinfo->mouse_face_window)) show_mouse_face (dpyinfo, 0); dpyinfo->mouse_face_beg_row = dpyinfo->mouse_face_beg_col = -1; @@ -3131,7 +3131,7 @@ union REGS regs; struct display_info *dpyinfo = FRAME_X_DISPLAY_INFO (SELECTED_FRAME()); EVENT_INIT (event); - + #ifndef HAVE_X_WINDOWS /* Maybe put the cursor where it should be. */ IT_cmgoto (SELECTED_FRAME()); @@ -3342,8 +3342,8 @@ if (!dpyinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)) { + clear_mouse_face (dpyinfo); dpyinfo->mouse_face_hidden = 1; - clear_mouse_face (dpyinfo); } if (code >= 0x100) diff -r 7f60e040ccfc -r 1029206e72f2 src/w32term.c --- a/src/w32term.c Sat Apr 03 20:24:17 2004 +0000 +++ b/src/w32term.c Thu Apr 08 12:29:09 2004 +0000 @@ -4245,8 +4245,8 @@ { if (!dpyinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)) { + clear_mouse_face (dpyinfo); dpyinfo->mouse_face_hidden = 1; - clear_mouse_face (dpyinfo); } if (temp_index == sizeof temp_buffer / sizeof (short)) @@ -4268,8 +4268,8 @@ { if (!dpyinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)) { + clear_mouse_face (dpyinfo); dpyinfo->mouse_face_hidden = 1; - clear_mouse_face (dpyinfo); } if (temp_index == sizeof temp_buffer / sizeof (short)) @@ -4773,7 +4773,7 @@ help_echo_object = help_echo_window = Qnil; help_echo_pos = -1; } - + any_help_event_p = 1; gen_help_event (help_echo_string, frame, help_echo_window, help_echo_object, help_echo_pos); diff -r 7f60e040ccfc -r 1029206e72f2 src/xdisp.c --- a/src/xdisp.c Sat Apr 03 20:24:17 2004 +0000 +++ b/src/xdisp.c Thu Apr 08 12:29:09 2004 +0000 @@ -19831,7 +19831,7 @@ { int cleared = 0; - if (!NILP (dpyinfo->mouse_face_window)) + if (!dpyinfo->mouse_face_hidden && !NILP (dpyinfo->mouse_face_window)) { show_mouse_face (dpyinfo, DRAW_NORMAL_TEXT); cleared = 1; diff -r 7f60e040ccfc -r 1029206e72f2 src/xterm.c --- a/src/xterm.c Sat Apr 03 20:24:17 2004 +0000 +++ b/src/xterm.c Thu Apr 08 12:29:09 2004 +0000 @@ -6198,8 +6198,8 @@ if (!dpyinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)) { + clear_mouse_face (dpyinfo); dpyinfo->mouse_face_hidden = 1; - clear_mouse_face (dpyinfo); } #if defined USE_MOTIF && defined USE_TOOLKIT_SCROLL_BARS