aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog239
-rw-r--r--lisp/button.el19
-rw-r--r--lisp/calc/calc-help.el77
-rw-r--r--lisp/calc/calc-misc.el12
-rw-r--r--lisp/calc/calc.el3
-rw-r--r--lisp/calendar/cal-iso.el53
-rw-r--r--lisp/calendar/cal-menu.el5
-rw-r--r--lisp/calendar/calendar.el5
-rw-r--r--lisp/calendar/icalendar.el1299
-rw-r--r--lisp/comint.el257
-rw-r--r--lisp/diff-mode.el49
-rw-r--r--lisp/emacs-lisp/byte-opt.el2
-rw-r--r--lisp/emacs-lisp/lisp-mode.el10
-rw-r--r--lisp/emacs-lisp/lisp.el8
-rw-r--r--lisp/font-lock.el6
-rw-r--r--lisp/gnus/ChangeLog52
-rw-r--r--lisp/gnus/gnus-group.el3
-rw-r--r--lisp/gnus/gnus-msg.el3
-rw-r--r--lisp/gnus/gnus-sum.el24
-rw-r--r--lisp/gnus/gnus.el1
-rw-r--r--lisp/gnus/imap.el10
-rw-r--r--lisp/gnus/message.el8
-rw-r--r--lisp/gnus/mml.el3
-rw-r--r--lisp/gnus/nnheader.el10
-rw-r--r--lisp/gnus/pop3.el108
-rw-r--r--lisp/help-fns.el10
-rw-r--r--lisp/help.el57
-rw-r--r--lisp/imenu.el39
-rw-r--r--lisp/info-look.el2
-rw-r--r--lisp/info.el35
-rw-r--r--lisp/international/mule.el12
-rw-r--r--lisp/isearch.el25
-rw-r--r--lisp/kmacro.el31
-rw-r--r--lisp/mail/mail-extr.el14
-rw-r--r--lisp/mail/smtpmail.el32
-rw-r--r--lisp/net/ange-ftp.el5
-rw-r--r--lisp/net/tls.el31
-rw-r--r--lisp/net/tramp-smb.el9
-rw-r--r--lisp/net/tramp.el32
-rw-r--r--lisp/net/trampver.el2
-rw-r--r--lisp/pcvs-defs.el9
-rw-r--r--lisp/pcvs-parse.el8
-rw-r--r--lisp/progmodes/etags.el19
-rw-r--r--lisp/progmodes/gdb-ui.el1
-rw-r--r--lisp/progmodes/gud.el25
-rw-r--r--lisp/recentf.el3
-rw-r--r--lisp/server.el6
-rw-r--r--lisp/subr.el319
-rw-r--r--lisp/tar-mode.el14
-rw-r--r--lisp/textmodes/enriched.el4
-rw-r--r--lisp/textmodes/paragraphs.el18
-rw-r--r--lisp/textmodes/tex-mode.el29
-rw-r--r--lisp/url/ChangeLog61
-rw-r--r--lisp/url/url-auth.el316
-rw-r--r--lisp/url/url-cache.el202
-rw-r--r--lisp/url/url-cookie.el466
-rw-r--r--lisp/url/url-dired.el100
-rw-r--r--lisp/url/url-file.el1
-rw-r--r--lisp/url/url-ftp.el42
-rw-r--r--lisp/url/url-gw.el268
-rw-r--r--lisp/url/url-handlers.el3
-rw-r--r--lisp/url/url-history.el199
-rw-r--r--lisp/url/url-https.el14
-rw-r--r--lisp/url/url-irc.el76
-rw-r--r--lisp/url/url-ldap.el240
-rw-r--r--lisp/url/url-mailto.el131
-rw-r--r--lisp/url/url-methods.el150
-rw-r--r--lisp/url/url-misc.el117
-rw-r--r--lisp/url/url-news.el135
-rw-r--r--lisp/url/url-nfs.el3
-rw-r--r--lisp/url/url-parse.el210
-rw-r--r--lisp/url/url-privacy.el81
-rw-r--r--lisp/url/url-util.el3
-rw-r--r--lisp/url/url-vars.el431
-rw-r--r--lisp/url/url.el269
-rw-r--r--lisp/vc.el5
-rw-r--r--lisp/xml.el23
77 files changed, 5981 insertions, 622 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 29abaaf21b8..41606eb7e93 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,4 +1,233 @@
12004-10-03 Stefan <monnier@iro.umontreal.ca> 12004-10-13 Daniel Pfeiffer <occitan@esperanto.org>
2
3 * button.el (button-activate): Allow a marker to display as an
4 action.
5
6 * help-fns.el (describe-variable): Use it to make "below" a
7 hyperlink.
8
9 * help.el (describe-mode): Use it to make minor mode list into
10 hyperlinks.
11
122004-10-14 Masatake YAMATO <jet@gyve.org>
13
14 * progmodes/gud.el (gdb-script-beginning-of-defun): New function.
15 (gdb-script-end-of-defun): New function.
16 (gdb-script-mode): Use `gdb-script-beginning-of-defun' and
17 `gdb-script-end-of-defun' as *-of-defun-function.
18
192004-10-13 Stefan Monnier <monnier@iro.umontreal.ca>
20
21 * vc.el (vc-annotate-display-select): Fix typo.
22
23 * subr.el (substitute-key-definition-key): New function.
24 (substitute-key-definition): Use it with map-keymap.
25 (event-modifiers): Use push.
26 (mouse-movement-p, with-temp-buffer): Simplify.
27
282004-10-12 Michael Albinus <michael.albinus@gmx.de>
29
30 Sync with Tramp 2.0.45.
31
32 * net/tramp.el (top): Apply `def-edebug-spec' only if function is
33 defined. This is not the case for XEmacs without package "edebug".
34 (tramp-set-auto-save-file-modes): Set permissions of autosaved
35 remote files to the permissions of the original file. This is not
36 the case for Emacs < 21.3.50 and XEmacs < 21.5. Add function to
37 `auto-save-hook'. Reported by Thomas Prokosch <thomas@nadev.net>.
38 (tramp-perl-decode): Fix an error in Perl implementation.
39 $pending must be cleared every loop. Reported by Benjamin Place
40 <benjaminplace@sprintmail.com>
41
42 * net/tramp-smb.el (tramp-smb-advice-PC-do-completion):
43 Don't activate advice during definition. This is done later on,
44 depending on test result of `substitute-in-file-name'.
45 Suggested by Stefan Monnier <monnier@iro.umontreal.ca>.
46
472004-10-12 Stefan Monnier <monnier@iro.umontreal.ca>
48
49 * pcvs-parse.el (cvs-parse-commit): Fix parsing for new commit message.
50
51 * emacs-lisp/lisp.el (mark-sexp): Preserve direction when repeating.
52
532004-10-12 David Ponce <david@dponce.com>
54
55 * recentf.el (recentf-edit-list): Update the menu when the recentf
56 list has been modified.
57
582004-10-12 Simon Josefsson <jas@extundo.com>
59
60 * net/tls.el (tls-certtool-program): New variable.
61 (tls-certificate-information): New function, based on
62 ssl-certificate-information.
63
642004-10-12 Kenichi Handa <handa@m17n.org>
65
66 * international/mule.el (coding-system-equal): Move from mule-util.el.
67
68 * international/mule-util.el (coding-system-equal): Move to mule.el.
69
702004-10-12 Kim F. Storm <storm@cua.dk>
71
72 * kmacro.el (kmacro-insert-counter, kmacro-add-counter): Use and
73 reset kmacro-initial-counter-value if set.
74 (kmacro-set-counter): Only set kmacro-counter if defining or executing
75 macro. Set kmacro-initial-counter-value otherwise. Never set both.
76 (kmacro-display): Show macro counter if non-zero.
77
78 * subr.el (substitute-key-definition): Mention command remapping
79 in doc string.
80
812004-10-11 Stefan Monnier <monnier@iro.umontreal.ca>
82
83 * pcvs-defs.el (pcl-cvs-load-hook): Remove unused var.
84
85 * font-lock.el (font-lock-apply-highlight): Fix last change.
86
872004-10-11 Simon Josefsson <jas@extundo.com>
88
89 * mail/smtpmail.el (smtpmail-open-stream): Look for
90 starttls-gnutls-program instead of starttls-program iff
91 starttls-use-gnutls is non-nil.
92 (smtpmail-open-stream): Don't overwrite user settings of
93 starttls-extra-arguments and starttls-extra-args.
94
952004-10-10 Stefan Monnier <monnier@iro.umontreal.ca>
96
97 * comint.el (comint-mouse-insert-input): Remove.
98 (comint-insert-input): Make it work for mouse bindings.
99 (comint-mode-map): Move defs into the declaration.
100 (comint-output-filter): Typo.
101
102 * diff-mode.el (diff-current-defun): Fix 2004-06-13's change.
103
1042004-10-10 Kai Grossjohann <kai.grossjohann@gmx.net>
105
106 * net/ange-ftp.el (ange-ftp-remote-shell): Remove variable.
107 (ange-ftp-call-chmod): Reference remote-shell-program instead of
108 ange-ftp-remote-shell.
109
1102004-10-10 Andreas Schwab <schwab@suse.de>
111
112 * emacs-lisp/byte-opt.el (byte-optimize-backward-word): Optimize
113 `(backward-word)' to `(forward-word -1)', not `(forward-char -1)'.
114 Reported by <sri@asu.edu>.
115
1162004-10-10 Benjamin Rutt <brutt@bloomington.in.us>
117
118 * vc.el (vc-annotate-mode): Remove variable.
119 (vc-annotate-display-select): Only call vc-annotate-mode
120 if we're not in that mode already.
121
1222004-10-09 Stefan Monnier <monnier@iro.umontreal.ca>
123
124 * imenu.el (imenu--completion-buffer): Don't return t for rescan.
125 (imenu-choose-buffer-index): Check here for rescan instead.
126
127 * font-lock.el (font-lock-apply-highlight): Explicitly check the case
128 where the face expression evals to nil.
129
130 * textmodes/tex-mode.el (tex-font-lock-append-prop): New fun.
131 (tex-font-lock-keywords-2): Use it.
132 (tex-font-lock-syntactic-keywords): Fix the `verbatim' treatment.
133
134 * emacs-lisp/lisp-mode.el (lisp-fill-paragraph): Fix backslashes.
135
1362004-10-09 Kim F. Storm <storm@cua.dk>
137
138 * subr.el (progress-reporter-update): Define before first usage.
139 (make-progress-reporter): Doc fix.
140
1412004-10-09 Luc Teirlinck <teirllm@auburn.edu>
142
143 * textmodes/paragraphs.el (sentence-end-double-space)
144 (sentence-end-without-period, sentence-end-without-space)
145 (sentence-end): Doc fixes.
146
1472004-10-08 Peter Seibel <peter@javamonkey.com> (tiny change)
148
149 * emacs-lisp/lisp-mode.el (lisp-fill-paragraph):
150 Change paragraph-start regexp so we don't fill code starting with #'(.
151
1522004-10-08 Sebastien Kirche <seki@seki.fr> (tiny change)
153
154 * mail/mail-extr.el (mail-extr-ignore-realname-equals-mailbox-name):
155 New defcustom.
156 (extract-address-components): Use it.
157
1582004-10-08 Paul Pogonyshev <pogonyshev@gmx.net>
159
160 * subr.el (make-progress-reporter, progress-reporter-update)
161 (progress-reporter-force-update, progress-reporter-do-update)
162 (progress-reporter-done): New functions.
163
164 * tar-mode.el (tar-summarize-buffer): Use progress reporter.
165
166 * progmodes/etags.el (etags-tags-completion-table): Use progress
167 reporter.
168 (etags-tags-apropos): Likewise.
169
1702004-10-08 Alan Mackenzie <acm@muc.de>
171
172 * isearch.el (isearch-yank-line): C-y yanks to next EOL, not end
173 of current line.
174
1752004-10-08 Masatake YAMATO <jet@gyve.org>
176
177 * server.el (server-process-filter): Wrap `process-send-region'
178 by `condition-case' to guard the case when the pipe to PROC is closed.
179
1802004-10-07 Mark A. Hershberger <mah@everybody.org>
181
182 * xml.el (xml-substitute-special): Limit handling of external entities.
183
1842004-10-06 Nick Roberts <nickrob@snap.net.nz>
185
186 * progmodes/gdb-ui.el (gdb-ann3): (Re-)initialise gdb-input-queue.
187
1882004-10-06 John Paul Wallington <jpw@gnu.org>
189
190 * xml.el (xml-parse-dtd): Fix `error' call.
191
1922004-10-05 Mark A. Hershberger <mah@everybody.org>
193
194 * xml.el (xml-substitute-special): Return a single string instead
195 of a list of strings if an entity substitution is made.
196
1972004-10-05 Ulf Jasper <ulf.jasper@web.de>
198
199 * calendar/icalendar.el: New file.
200
2012004-10-05 Juri Linkov <juri@jurta.org>
202
203 * isearch.el (isearch-done): Set mark after running hook.
204 Suggested by Drew Adams <drew.adams@oracle.com>.
205
206 * info.el (Info-history, Info-toc): Fix Info headers.
207 (Info-toc): Narrow buffer before Info-fontify-node.
208 (Info-build-toc): Don't check for special Info file names.
209 Set main-file to nil if Info-find-file returns a symbol.
210
2112004-10-05 Emilio C. Lopes <eclig@gmx.net>:
212
213 * calendar/calendar.el (calendar-goto-iso-week): Add autoload.
214 (calendar-mode-map): Add binding for `calendar-goto-iso-week'.
215 * calendar/cal-menu.el (calendar-mode-map): Ditto.
216
2172004-10-05 Glenn Morris <gmorris@ast.cam.ac.uk>
218
219 * calendar/cal-iso.el (calendar-iso-read-args): New function,
220 for old interactive spec from calendar-goto-iso-date.
221 (calendar-goto-iso-date): Use it.
222 (calendar-goto-iso-week): New function. Suggested by Emilio
223 C. Lopes <eclig@gmx.net>.
224
2252004-10-04 Luc Teirlinck <teirllm@auburn.edu>
226
227 * textmodes/enriched.el (enriched-mode-map): Give `set-left-margin' and
228 `set-right-margin' bindings that follow the minor mode conventions.
229
2302004-10-03 Stefan Monnier <monnier@iro.umontreal.ca>
2 231
3 * textmodes/tex-mode.el (tex-dvi-view-command): Use `yap' on w32. 232 * textmodes/tex-mode.el (tex-dvi-view-command): Use `yap' on w32.
4 (tex-font-lock-keywords-1): Add url and nolinkurl for args with `_'. 233 (tex-font-lock-keywords-1): Add url and nolinkurl for args with `_'.
@@ -62,7 +291,7 @@
62 * diff-mode.el (diff-file-header-re): Tighten up regexp a tiny bit. 291 * diff-mode.el (diff-file-header-re): Tighten up regexp a tiny bit.
63 (diff-fixup-modifs): Catch unified-diff file-headers. 292 (diff-fixup-modifs): Catch unified-diff file-headers.
64 293
652004-09-28 Stefan <monnier@iro.umontreal.ca> 2942004-09-28 Stefan Monnier <monnier@iro.umontreal.ca>
66 295
67 * dired.el (dired-view-command-alist): Use more efficient regexps. 296 * dired.el (dired-view-command-alist): Use more efficient regexps.
68 Remove dubious arguments. 297 Remove dubious arguments.
@@ -102,7 +331,7 @@
102 (pr-delete-file): Check if file exists before deleting it. 331 (pr-delete-file): Check if file exists before deleting it.
103 Reported by Lennart Borgman <lennart.borgman.073@student.lu.se>. 332 Reported by Lennart Borgman <lennart.borgman.073@student.lu.se>.
104 333
1052004-09-26 Stefan <monnier@iro.umontreal.ca> 3342004-09-26 Stefan Monnier <monnier@iro.umontreal.ca>
106 335
107 * term.el (term-display-table): New variable. 336 * term.el (term-display-table): New variable.
108 (term-mode): Use it. 337 (term-mode): Use it.
@@ -126,7 +355,7 @@
126 (term-stop-output-log): Rename from `term-stop-photo'. 355 (term-stop-output-log): Rename from `term-stop-photo'.
127 (term-switch-to-alternate-sub-buffer): Comment out, unused. 356 (term-switch-to-alternate-sub-buffer): Comment out, unused.
128 357
1292004-09-25 Stefan <monnier@iro.umontreal.ca> 3582004-09-25 Stefan Monnier <monnier@iro.umontreal.ca>
130 359
131 * dired.el (dired-move-to-filename): Don't output a message if 360 * dired.el (dired-move-to-filename): Don't output a message if
132 raise-error is non-nil. Fix return position and value. 361 raise-error is non-nil. Fix return position and value.
@@ -270,7 +499,7 @@
270 * progmodes/sh-script.el (sh-mode-default-syntax-table): Set syntax 499 * progmodes/sh-script.el (sh-mode-default-syntax-table): Set syntax
271 of = to "." (punctuation). 500 of = to "." (punctuation).
272 501
2732004-09-19 Stefan <monnier@iro.umontreal.ca> 5022004-09-19 Stefan Monnier <monnier@iro.umontreal.ca>
274 503
275 * subr.el (event-basic-type): Fix mask (extend to 22bits). 504 * subr.el (event-basic-type): Fix mask (extend to 22bits).
276 505
diff --git a/lisp/button.el b/lisp/button.el
index 35905b9e1e4..dcd26846d10 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -78,6 +78,7 @@ Mode-specific keymaps may want to use this as their parent keymap.")
78(put 'default-button 'mouse-face 'highlight) 78(put 'default-button 'mouse-face 'highlight)
79(put 'default-button 'keymap button-map) 79(put 'default-button 'keymap button-map)
80(put 'default-button 'type 'button) 80(put 'default-button 'type 'button)
81;; action may be either a function to call, or a marker to go to
81(put 'default-button 'action 'ignore) 82(put 'default-button 'action 'ignore)
82(put 'default-button 'help-echo "mouse-2, RET: Push this button") 83(put 'default-button 'help-echo "mouse-2, RET: Push this button")
83;; Make overlay buttons go away if their underlying text is deleted. 84;; Make overlay buttons go away if their underlying text is deleted.
@@ -217,9 +218,14 @@ changes to a supertype are not reflected in its subtypes)."
217If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action 218If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
218instead of its normal action; if the button has no mouse-action, 219instead of its normal action; if the button has no mouse-action,
219the normal action is used instead." 220the normal action is used instead."
220 (funcall (or (and use-mouse-action (button-get button 'mouse-action)) 221 (let ((action (or (and use-mouse-action (button-get button 'mouse-action))
221 (button-get button 'action)) 222 (button-get button 'action))))
222 button)) 223 (if (markerp action)
224 (save-selected-window
225 (select-window (display-buffer (marker-buffer action)))
226 (goto-char action)
227 (recenter 0))
228 (funcall action button))))
223 229
224(defun button-label (button) 230(defun button-label (button)
225 "Return BUTTON's text label." 231 "Return BUTTON's text label."
@@ -373,10 +379,11 @@ instead of starting at the next button."
373 379
374(defun push-button (&optional pos use-mouse-action) 380(defun push-button (&optional pos use-mouse-action)
375 "Perform the action specified by a button at location POS. 381 "Perform the action specified by a button at location POS.
376POS may be either a buffer position or a mouse-event. 382POS may be either a buffer position or a mouse-event. If
377If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action 383USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
378instead of its normal action; if the button has no mouse-action, 384instead of its normal action; if the button has no mouse-action,
379the normal action is used instead. 385the normal action is used instead. The action may be either a
386function to call or a marker to display.
380POS defaults to point, except when `push-button' is invoked 387POS defaults to point, except when `push-button' is invoked
381interactively as the result of a mouse-event, in which case, the 388interactively as the result of a mouse-event, in which case, the
382mouse event is used. 389mouse event is used.
diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el
index e66f50bd40c..c24a13b91d7 100644
--- a/lisp/calc/calc-help.el
+++ b/lisp/calc/calc-help.el
@@ -93,18 +93,15 @@ C-w Describe how there is no warranty for Calc."
93 93
94(defun calc-describe-copying () 94(defun calc-describe-copying ()
95 (interactive) 95 (interactive)
96 (calc-info) 96 (calc-info-goto-node "Copying"))
97 (Info-goto-node "Copying"))
98 97
99(defun calc-describe-distribution () 98(defun calc-describe-distribution ()
100 (interactive) 99 (interactive)
101 (calc-info) 100 (calc-info-goto-node "Reporting Bugs"))
102 (Info-goto-node "Reporting Bugs"))
103 101
104(defun calc-describe-no-warranty () 102(defun calc-describe-no-warranty ()
105 (interactive) 103 (interactive)
106 (calc-info) 104 (calc-info-goto-node "Copying")
107 (Info-goto-node "Copying")
108 (let ((case-fold-search nil)) 105 (let ((case-fold-search nil))
109 (search-forward " NO WARRANTY")) 106 (search-forward " NO WARRANTY"))
110 (beginning-of-line) 107 (beginning-of-line)
@@ -190,13 +187,13 @@ C-w Describe how there is no warranty for Calc."
190 (message "Reading Calc summary from manual...") 187 (message "Reading Calc summary from manual...")
191 (save-window-excursion 188 (save-window-excursion
192 (save-excursion 189 (save-excursion
193 (calc-info) 190 (calc-info-goto-node "Summary")
194 (Info-goto-node "Summary")
195 (goto-char (point-min)) 191 (goto-char (point-min))
196 (forward-line 1) 192 (forward-line 1)
197 (copy-to-buffer "*Calc Summary*" 193 (copy-to-buffer "*Calc Summary*"
198 (point) (point-max)) 194 (point) (point-max))
199 (Info-last))) 195 (if Info-history
196 (Info-last))))
200 (setq case-fold-search nil) 197 (setq case-fold-search nil)
201 (re-search-forward "^\\(.*\\)\\[\\.\\. a b") 198 (re-search-forward "^\\(.*\\)\\[\\.\\. a b")
202 (setq calc-summary-indentation 199 (setq calc-summary-indentation
@@ -299,35 +296,62 @@ C-w Describe how there is no warranty for Calc."
299 (calc-describe-thing desc "Key Index" nil 296 (calc-describe-thing desc "Key Index" nil
300 (string-match "[A-Z][A-Z][A-Z]" desc)))))) 297 (string-match "[A-Z][A-Z][A-Z]" desc))))))
301 298
299(defvar calc-help-function-list nil
300 "List of functions provided by Calc.")
301
302(defvar calc-help-variable-list nil
303 "List of variables provided by Calc.")
304
305(defun calc-help-index-entries (&rest indices)
306 "Create a list of entries from the INDICES in the Calc info manual."
307 (let ((entrylist '())
308 entry)
309 (require 'info nil t)
310 (while indices
311 (condition-case nil
312 (with-temp-buffer
313 (Info-mode)
314 (Info-goto-node (concat "(Calc)" (car indices) " Index"))
315 (goto-char (point-min))
316 (while (re-search-forward "\n\\* \\(.*\\): " nil t)
317 (setq entry (match-string 1))
318 (if (and (not (string-match "<[1-9]+>" entry))
319 (not (string-match "(.*)" entry))
320 (not (string= entry "Menu")))
321 (unless (assoc entry entrylist)
322 (setq entrylist (cons entry entrylist))))))
323 (error nil))
324 (setq indices (cdr indices)))
325 entrylist))
326
302(defun calc-describe-function (&optional func) 327(defun calc-describe-function (&optional func)
303 (interactive) 328 (interactive)
329 (unless calc-help-function-list
330 (setq calc-help-function-list
331 (calc-help-index-entries "Function" "Command")))
304 (or func 332 (or func
305 (setq func (intern (completing-read "Describe function: " 333 (setq func (completing-read "Describe function: "
306 obarray nil t "calcFunc-")))) 334 calc-help-function-list
307 (setq func (symbol-name func)) 335 nil t)))
308 (if (string-match "\\`calc-." func) 336 (if (string-match "\\`calc-." func)
309 (calc-describe-thing func "Command Index") 337 (calc-describe-thing func "Command Index")
310 (calc-describe-thing (if (string-match "\\`calcFunc-." func) 338 (calc-describe-thing func "Function Index")))
311 (substring func 9)
312 func)
313 "Function Index")))
314 339
315(defun calc-describe-variable (&optional var) 340(defun calc-describe-variable (&optional var)
316 (interactive) 341 (interactive)
342 (unless calc-help-variable-list
343 (setq calc-help-variable-list
344 (calc-help-index-entries "Variable")))
317 (or var 345 (or var
318 (setq var (intern (completing-read "Describe variable: " 346 (setq var (completing-read "Describe variable: "
319 obarray nil t "var-")))) 347 calc-help-variable-list
320 (setq var (symbol-name var)) 348 nil t)))
321 (calc-describe-thing var "Variable Index" 349 (calc-describe-thing var "Variable Index"))
322 (if (string-match "\\`var-." var)
323 (substring var 4)
324 var)))
325 350
326(defun calc-describe-thing (thing where &optional target not-quoted) 351(defun calc-describe-thing (thing where &optional target not-quoted)
327 (message "Looking for `%s' in %s..." thing where) 352 (message "Looking for `%s' in %s..." thing where)
328 (let ((savewin (current-window-configuration))) 353 (let ((savewin (current-window-configuration)))
329 (calc-info) 354 (calc-info-goto-node where)
330 (Info-goto-node where)
331 (or (let ((case-fold-search nil)) 355 (or (let ((case-fold-search nil))
332 (re-search-forward (format "\n\\* +%s: \\(.*\\)\\." 356 (re-search-forward (format "\n\\* +%s: \\(.*\\)\\."
333 (regexp-quote thing)) 357 (regexp-quote thing))
@@ -338,7 +362,8 @@ C-w Describe how there is no warranty for Calc."
338 nil t) 362 nil t)
339 (setq thing (format "%s9" (substring thing 0 -1)))) 363 (setq thing (format "%s9" (substring thing 0 -1))))
340 (progn 364 (progn
341 (Info-last) 365 (if Info-history
366 (Info-last))
342 (set-window-configuration savewin) 367 (set-window-configuration savewin)
343 (error "Can't find `%s' in %s" thing where))) 368 (error "Can't find `%s' in %s" thing where)))
344 (let (Info-history) 369 (let (Info-history)
diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el
index 772b39ffed4..c01d37e6848 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -160,21 +160,25 @@ Calc user interface as before (either M-# C or M-# K; initially M-# C)."
160 (select-window (get-largest-window)) 160 (select-window (get-largest-window))
161 (info "Calc")) 161 (info "Calc"))
162 162
163(defun calc-info-goto-node (node)
164 "Go to a node in the Calculator info documentation."
165 (interactive)
166 (select-window (get-largest-window))
167 (Info-goto-node (concat "(Calc)" node)))
168
163(defun calc-tutorial () 169(defun calc-tutorial ()
164 "Run the Emacs Info system on the Calculator Tutorial." 170 "Run the Emacs Info system on the Calculator Tutorial."
165 (interactive) 171 (interactive)
166 (if (get-buffer-window "*Calculator*") 172 (if (get-buffer-window "*Calculator*")
167 (calc-quit)) 173 (calc-quit))
168 (calc-info) 174 (calc-info-goto-node "Interactive Tutorial")
169 (Info-goto-node "Interactive Tutorial")
170 (calc-other-window) 175 (calc-other-window)
171 (message "Welcome to the Calc Tutorial!")) 176 (message "Welcome to the Calc Tutorial!"))
172 177
173(defun calc-info-summary () 178(defun calc-info-summary ()
174 "Run the Emacs Info system on the Calculator Summary." 179 "Run the Emacs Info system on the Calculator Summary."
175 (interactive) 180 (interactive)
176 (calc-info) 181 (calc-info-goto-node "Summary"))
177 (Info-goto-node "Summary"))
178 182
179(defun calc-help () 183(defun calc-help ()
180 (interactive) 184 (interactive)
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index 5c7e24ed646..c17449a8450 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -942,7 +942,8 @@ If nil, selections displayed but ignored.")
942 calcDigit-algebraic calcDigit-edit) 942 calcDigit-algebraic calcDigit-edit)
943 943
944 ("calc-misc" another-calc calc-big-or-small calc-dispatch-help 944 ("calc-misc" another-calc calc-big-or-small calc-dispatch-help
945 calc-help calc-info calc-info-summary calc-inv calc-last-args-stub 945 calc-help calc-info calc-info-goto-node calc-info-summary calc-inv
946 calc-last-args-stub
946 calc-missing-key calc-mod calc-other-window calc-over calc-percent 947 calc-missing-key calc-mod calc-other-window calc-over calc-percent
947 calc-pop-above calc-power calc-roll-down calc-roll-up 948 calc-pop-above calc-power calc-roll-down calc-roll-up
948 calc-shift-Y-prefix-help calc-tutorial calcDigit-letter 949 calc-shift-Y-prefix-help calc-tutorial calcDigit-letter
diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el
index 0d9ad45c7d6..058bdf071d7 100644
--- a/lisp/calendar/cal-iso.el
+++ b/lisp/calendar/cal-iso.el
@@ -1,8 +1,9 @@
1;;; cal-iso.el --- calendar functions for the ISO calendar 1;;; cal-iso.el --- calendar functions for the ISO calendar
2 2
3;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. 3;; Copyright (C) 1995, 1997, 2004 Free Software Foundation, Inc.
4 4
5;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> 5;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
6;; Maintainer: Glenn Morris <gmorris@ast.cam.ac.uk>
6;; Keywords: calendar 7;; Keywords: calendar
7;; Human-Keywords: ISO calendar, calendar, diary 8;; Human-Keywords: ISO calendar, calendar, diary
8 9
@@ -96,27 +97,39 @@ Defaults to today's date if DATE is not given."
96 (message "ISO date: %s" 97 (message "ISO date: %s"
97 (calendar-iso-date-string (calendar-cursor-to-date t)))) 98 (calendar-iso-date-string (calendar-cursor-to-date t))))
98 99
100(defun calendar-iso-read-args (&optional dayflag)
101 "Interactively read the arguments for an iso date command."
102 (let* ((today (calendar-current-date))
103 (year (calendar-read
104 "ISO calendar year (>0): "
105 '(lambda (x) (> x 0))
106 (int-to-string (extract-calendar-year today))))
107 (no-weeks (extract-calendar-month
108 (calendar-iso-from-absolute
109 (1-
110 (calendar-dayname-on-or-before
111 1 (calendar-absolute-from-gregorian
112 (list 1 4 (1+ year))))))))
113 (week (calendar-read
114 (format "ISO calendar week (1-%d): " no-weeks)
115 '(lambda (x) (and (> x 0) (<= x no-weeks)))))
116 (day (if dayflag (calendar-read
117 "ISO day (1-7): "
118 '(lambda (x) (and (<= 1 x) (<= x 7))))
119 1)))
120 (list (list week day year))))
121
99(defun calendar-goto-iso-date (date &optional noecho) 122(defun calendar-goto-iso-date (date &optional noecho)
100 "Move cursor to ISO DATE; echo ISO date unless NOECHO is t." 123 "Move cursor to ISO DATE; echo ISO date unless NOECHO is t."
101 (interactive 124 (interactive (calendar-iso-read-args t))
102 (let* ((today (calendar-current-date)) 125 (calendar-goto-date (calendar-gregorian-from-absolute
103 (year (calendar-read 126 (calendar-absolute-from-iso date)))
104 "ISO calendar year (>0): " 127 (or noecho (calendar-print-iso-date)))
105 '(lambda (x) (> x 0)) 128
106 (int-to-string (extract-calendar-year today)))) 129(defun calendar-goto-iso-week (date &optional noecho)
107 (no-weeks (extract-calendar-month 130 "Move cursor to ISO DATE; echo ISO date unless NOECHO is t.
108 (calendar-iso-from-absolute 131Interactively, goes to the first day of the specified week."
109 (1- 132 (interactive (calendar-iso-read-args))
110 (calendar-dayname-on-or-before
111 1 (calendar-absolute-from-gregorian
112 (list 1 4 (1+ year))))))))
113 (week (calendar-read
114 (format "ISO calendar week (1-%d): " no-weeks)
115 '(lambda (x) (and (> x 0) (<= x no-weeks)))))
116 (day (calendar-read
117 "ISO day (1-7): "
118 '(lambda (x) (and (<= 1 x) (<= x 7))))))
119 (list (list week day year))))
120 (calendar-goto-date (calendar-gregorian-from-absolute 133 (calendar-goto-date (calendar-gregorian-from-absolute
121 (calendar-absolute-from-iso date))) 134 (calendar-absolute-from-iso date)))
122 (or noecho (calendar-print-iso-date))) 135 (or noecho (calendar-print-iso-date)))
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index a652e7ca768..ceb4c56f7fd 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -1,9 +1,10 @@
1;;; cal-menu.el --- calendar functions for menu bar and popup menu support 1;;; cal-menu.el --- calendar functions for menu bar and popup menu support
2 2
3;; Copyright (C) 1994, 1995, 2001, 2003 Free Software Foundation, Inc. 3;; Copyright (C) 1994, 1995, 2001, 2003, 2004 Free Software Foundation, Inc.
4 4
5;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> 5;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
6;; Lara Rios <lrios@coewl.cen.uiuc.edu> 6;; Lara Rios <lrios@coewl.cen.uiuc.edu>
7;; Maintainer: Glenn Morris <gmorris@ast.cam.ac.uk>
7;; Keywords: calendar 8;; Keywords: calendar
8;; Human-Keywords: calendar, popup menus, menu bar 9;; Human-Keywords: calendar, popup menus, menu bar
9 10
@@ -121,6 +122,8 @@
121 '("Astronomical Date" . calendar-goto-astro-day-number)) 122 '("Astronomical Date" . calendar-goto-astro-day-number))
122(define-key calendar-mode-map [menu-bar goto iso] 123(define-key calendar-mode-map [menu-bar goto iso]
123 '("ISO Date" . calendar-goto-iso-date)) 124 '("ISO Date" . calendar-goto-iso-date))
125(define-key calendar-mode-map [menu-bar goto iso-week]
126 '("ISO Week" . calendar-goto-iso-week))
124(define-key calendar-mode-map [menu-bar goto day-of-year] 127(define-key calendar-mode-map [menu-bar goto day-of-year]
125 '("Day of Year" . calendar-goto-day-of-year)) 128 '("Day of Year" . calendar-goto-day-of-year))
126(define-key calendar-mode-map [menu-bar goto gregorian] 129(define-key calendar-mode-map [menu-bar goto gregorian]
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 9d38cde21ce..aa0b3005fad 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -1769,6 +1769,10 @@ Driven by the variable `calendar-date-display-form'.")
1769 "Move cursor to ISO date." 1769 "Move cursor to ISO date."
1770 t) 1770 t)
1771 1771
1772(autoload 'calendar-goto-iso-week "cal-iso"
1773 "Move cursor to start of ISO week."
1774 t)
1775
1772(autoload 'calendar-print-iso-date "cal-iso" 1776(autoload 'calendar-print-iso-date "cal-iso"
1773 "Show the ISO date equivalents of date." 1777 "Show the ISO date equivalents of date."
1774 t) 1778 t)
@@ -2204,6 +2208,7 @@ the inserted text. Value is always t."
2204 (define-key calendar-mode-map "ge" 'calendar-goto-ethiopic-date) 2208 (define-key calendar-mode-map "ge" 'calendar-goto-ethiopic-date)
2205 (define-key calendar-mode-map "gp" 'calendar-goto-persian-date) 2209 (define-key calendar-mode-map "gp" 'calendar-goto-persian-date)
2206 (define-key calendar-mode-map "gc" 'calendar-goto-iso-date) 2210 (define-key calendar-mode-map "gc" 'calendar-goto-iso-date)
2211 (define-key calendar-mode-map "gw" 'calendar-goto-iso-week)
2207 (define-key calendar-mode-map "gf" 'calendar-goto-french-date) 2212 (define-key calendar-mode-map "gf" 'calendar-goto-french-date)
2208 (define-key calendar-mode-map "gml" 'calendar-goto-mayan-long-count-date) 2213 (define-key calendar-mode-map "gml" 'calendar-goto-mayan-long-count-date)
2209 (define-key calendar-mode-map "gmpc" 'calendar-previous-calendar-round-date) 2214 (define-key calendar-mode-map "gmpc" 'calendar-previous-calendar-round-date)
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
new file mode 100644
index 00000000000..e83e8e980b6
--- /dev/null
+++ b/lisp/calendar/icalendar.el
@@ -0,0 +1,1299 @@
1;;; icalendar.el --- iCalendar implementation
2
3;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
4
5;; Author: Ulf Jasper <ulf.jasper@web.de>
6;; Created: August 2002
7;; Keywords: calendar
8;; Human-Keywords: calendar, diary, iCalendar, vCalendar
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
27;;; Commentary:
28
29;; This package is documented in the Emacs Manual.
30
31
32;;; History:
33
34;; 0.06 Bugfixes regarding icalendar-import-format-*.
35;; Fix in icalendar-convert-diary-to-ical -- thanks to Philipp Grau.
36
37;; 0.05: New import format scheme: Replaced icalendar-import-prefix-*,
38;; icalendar-import-ignored-properties, and
39;; icalendar-import-separator with icalendar-import-format(-*).
40;; icalendar-import-file and icalendar-convert-diary-to-ical
41;; have an extra parameter which should prevent them from
42;; erasing their target files (untested!).
43;; Tested with Emacs 21.3.2
44
45;; 0.04: Bugfix: import: double quoted param values did not work
46;; Read DURATION property when importing.
47;; Added parameter icalendar-duration-correction.
48
49;; 0.03: Export takes care of european-calendar-style.
50;; Tested with Emacs 21.3.2 and XEmacs 21.4.12
51
52;; 0.02: Should work in XEmacs now. Thanks to Len Trigg for the
53;; XEmacs patches!
54;; Added exporting from Emacs diary to ical.
55;; Some bugfixes, after testing with calendars from
56;; http://icalshare.com.
57;; Tested with Emacs 21.3.2 and XEmacs 21.4.12
58
59;; 0.01: First published version. Trial version. Alpha version.
60
61;; ======================================================================
62;; To Do:
63
64;; * Import from ical:
65;; + Need more properties for icalendar-import-format
66;; + check vcalendar version
67;; + check (unknown) elements
68;; + recurring events!
69;; + works for european style calendars only! Does it?
70;; + alarm
71;; + exceptions in recurring events
72;; + the parser is too soft
73;; + error log is incomplete
74;; + nice to have: #include "webcal://foo.com/some-calendar.ics"
75
76;; * Export into ical
77;; + diary-date, diary-float, and self-made sexp entries are not
78;; understood
79;; + timezones, currently all times are local!
80
81;; * Other things
82;; + defcustom icalendar-import-ignored-properties does not work with
83;; XEmacs.
84;; + clean up all those date/time parsing functions
85;; + Handle todo items?
86;; + Check iso 8601 for datetime and period
87;; + Which chars to (un)escape?
88;; + Time to find out how the profiler works?
89
90
91;;; Code:
92
93(defconst icalendar-version 0.06
94 "Version number of icalendar.el.")
95
96;; ======================================================================
97;; Customizables
98;; ======================================================================
99(defgroup icalendar nil
100 "Icalendar support."
101 :prefix "icalendar-"
102 :group 'calendar)
103
104(defcustom icalendar-import-format
105 "%s%d%l%o"
106 "Format string for importing events from iCalendar into Emacs diary.
107This string defines how iCalendar events are inserted into diary
108file. Meaning of the specifiers:
109%d Description, see `icalendar-import-format-description'
110%l Location, see `icalendar-import-format-location'
111%o Organizer, see `icalendar-import-format-organizer'
112%s Subject, see `icalendar-import-format-subject'"
113 :type 'string
114 :group 'icalendar)
115
116(defcustom icalendar-import-format-subject
117 "%s"
118 "Format string defining how the subject element is formatted.
119This applies only if the subject is not empty! `%s' is replaced
120by the subject."
121 :type 'string
122 :group 'icalendar)
123
124(defcustom icalendar-import-format-description
125 "\n Desc: %s"
126 "Format string defining how the description element is formatted.
127This applies only if the description is not empty! `%s' is
128replaced by the description."
129 :type 'string
130 :group 'icalendar)
131
132(defcustom icalendar-import-format-location
133 "\n Location: %s"
134 "Format string defining how the location element is formatted.
135This applies only if the location is not empty! `%s' is replaced
136by the location."
137 :type 'string
138 :group 'icalendar)
139
140(defcustom icalendar-import-format-organizer
141 "\n Organizer: %s"
142 "Format string defining how the organizer element is formatted.
143This applies only if the organizer is not empty! `%s' is
144replaced by the organizer."
145 :type 'string
146 :group 'icalendar)
147
148(defcustom icalendar-duration-correction
149 t
150 "Workaround for all-day events.
151If non-nil the length=duration of iCalendar appointments that
152have a length of exactly n days is decreased by one day. This
153fixes problems with all-day events, which appear to be one day
154longer than they are."
155 :type 'boolean
156 :group 'icalendar)
157
158
159;; ======================================================================
160;; NO USER SERVICABLE PARTS BELOW THIS LINE
161;; ======================================================================
162
163(defconst icalendar-weekdayabbrev-table
164 '(("mon\\(day\\)?" . "MO")
165 ("tue\\(sday\\)?" . "TU")
166 ("wed\\(nesday\\)?" . "WE")
167 ("thu\\(rsday\\)?" . "TH")
168 ("fri\\(day\\)?" . "FR")
169 ("sat\\(urday\\)?" . "SA")
170 ("sun\\(day\\)?" . "SU"))
171 "Translation table for weekdays.")
172
173(defconst icalendar-monthnumber-table
174 '(("^jan\\(uar\\)?y?$" . 1)
175 ("^feb\\(ruar\\)?y?$" . 2)
176 ("^mar\\(ch\\)?\\|märz?$" . 3)
177 ("^apr\\(il\\)?$" . 4)
178 ("^ma[iy]$" . 5)
179 ("^jun[ie]?$" . 6)
180 ("^jul[iy]?$" . 7)
181 ("^aug\\(ust\\)?$" . 8)
182 ("^sep\\(tember\\)?$" . 9)
183 ("^o[ck]t\\(ober\\)?$" . 10)
184 ("^nov\\(ember\\)?$" . 11)
185 ("^de[cz]\\(ember\\)?$" . 12))
186 "Regular expressions for month names.
187Currently this matches only German and English.")
188
189(defvar icalendar-debug nil ".")
190
191;; ======================================================================
192;; all the other libs we need
193;; ======================================================================
194(require 'calendar)
195(require 'appt)
196
197;; ======================================================================
198;; Core functionality
199;; Functions for parsing icalendars, importing and so on
200;; ======================================================================
201
202(defun icalendar-get-unfolded-buffer (folded-ical-buffer)
203 "Return a new buffer containing the unfolded contents of a buffer.
204Folding is the iCalendar way of wrapping long lines. In the
205created buffer all occurrences of CR LF BLANK are replaced by the
206empty string. Argument FOLDED-ICAL-BUFFER is the unfolded input
207buffer."
208 (let ((unfolded-buffer (get-buffer-create " *icalendar-work*")))
209 (save-current-buffer
210 (set-buffer unfolded-buffer)
211 (erase-buffer)
212 (insert-buffer folded-ical-buffer)
213 (while (re-search-forward "\r?\n[ \t]" nil t)
214 (replace-match "" nil nil))
215 )
216 unfolded-buffer))
217
218;; Replace regexp RE with RP in string ST and return the new string.
219;; This is here for compatibility with XEmacs.
220(defsubst icalendar-rris (re rp st)
221 ;; XEmacs:
222 (if (fboundp 'replace-in-string)
223 (save-match-data ;; apparently XEmacs needs save-match-data
224 (replace-in-string st re rp))
225 ;; Emacs:
226 (replace-regexp-in-string re rp st)))
227
228(defun icalendar-read-element (invalue inparams)
229 "Recursively read the next iCalendar element in the current buffer.
230INVALUE gives the current iCalendar element we are reading.
231INPARAMS gives the current parameters.....
232This function calls itself recursively for each nested calendar element
233it finds"
234 (let (element children line name params param param-name param-value
235 value
236 (continue t))
237 (setq children '())
238 (while (and continue
239 (re-search-forward "^\\([A-Za-z0-9-]+\\)[;:]" nil t))
240 (setq name (intern (match-string 1)))
241 (backward-char 1)
242 (setq params '())
243 (setq line '())
244 (while (looking-at ";")
245 (re-search-forward ";\\([A-Za-z0-9-]+\\)=" nil nil)
246 (setq param-name (intern (match-string 1)))
247 (re-search-forward "\\(\\([^;,:\"]+\\)\\|\"\\([^\"]+\\)\"\\)[;:]"
248 nil t)
249 (backward-char 1)
250 (setq param-value (or (match-string 2) (match-string 3)))
251 (setq param (list param-name param-value))
252 (while (looking-at ",")
253 (re-search-forward "\\(\\([^;,:]+\\)\\|\"\\([^\"]+\\)\"\\)"
254 nil t)
255 (if (match-string 2)
256 (setq param-value (match-string 2))
257 (setq param-value (match-string 3)))
258 (setq param (append param param-value)))
259 (setq params (append params param)))
260 (unless (looking-at ":")
261 (error "Oops"))
262 (forward-char 1)
263 (re-search-forward "\\(.*\\)\\(\r?\n[ \t].*\\)*" nil t)
264 (setq value (icalendar-rris "\r?\n[ \t]" "" (match-string 0)))
265 (setq line (list name params value))
266 (cond ((eq name 'BEGIN)
267 (setq children
268 (append children
269 (list (icalendar-read-element (intern value)
270 params)))))
271 ((eq name 'END)
272 (setq continue nil))
273 (t
274 (setq element (append element (list line))))))
275 (if invalue
276 (list invalue inparams element children)
277 children)))
278
279;; ======================================================================
280;; helper functions for examining events
281;; ======================================================================
282
283(defsubst icalendar-get-all-event-properties (event)
284 "Return the list of properties in this EVENT."
285 (car (cddr event)))
286
287(defun icalendar-get-event-property (event prop)
288 "For the given EVENT return the value of the property PROP."
289 (catch 'found
290 (let ((props (car (cddr event))) pp)
291 (while props
292 (setq pp (car props))
293 (if (eq (car pp) prop)
294 (throw 'found (car (cddr pp))))
295 (setq props (cdr props))))
296 nil))
297
298(defun icalendar-set-event-property (event prop new-value)
299 "For the given EVENT set the property PROP to the value NEW-VALUE."
300 (catch 'found
301 (let ((props (car (cddr event))) pp)
302 (while props
303 (setq pp (car props))
304 (when (eq (car pp) prop)
305 (setcdr (cdr pp) new-value)
306 (throw 'found (car (cddr pp))))
307 (setq props (cdr props)))
308 (setq props (car (cddr event)))
309 (setcar (cddr event)
310 (append props (list (list prop nil new-value)))))))
311
312(defun icalendar-get-children (node name)
313 "Return all children of the given NODE which have a name NAME.
314For instance the VCALENDAR node can have VEVENT children as well as VTODO
315children."
316 (let ((result nil)
317 (children (cadr (cddr node))))
318 (when (eq (car node) name)
319 (setq result node))
320 ;;(message "%s" node)
321 (when children
322 (let ((subresult
323 (delq nil
324 (mapcar (lambda (n)
325 (icalendar-get-children n name))
326 children))))
327 (if subresult
328 (if result
329 (setq result (append result subresult))
330 (setq result subresult)))))
331 result))
332
333; private
334(defun icalendar-all-events (icalendar)
335 "Return the list of all existing events in the given ICALENDAR."
336 (interactive "")
337 (icalendar-get-children (car icalendar) 'VEVENT))
338
339(defun icalendar-split-value (value-string)
340 "Splits VALUE-STRING at ';='."
341 (let ((result '())
342 param-name param-value)
343 (when value-string
344 (save-current-buffer
345 (set-buffer (get-buffer-create " *ical-temp*"))
346 (set-buffer-modified-p nil)
347 (erase-buffer)
348 (insert value-string)
349 (goto-char (point-min))
350 (while
351 (re-search-forward
352 "\\([A-Za-z0-9-]+\\)=\\(\\([^;,:]+\\)\\|\"\\([^\"]+\\)\"\\);?"
353 nil t)
354 (setq param-name (intern (match-string 1)))
355 (setq param-value (match-string 2))
356 (setq result
357 (append result (list (list param-name param-value)))))))
358 result))
359
360(defun icalendar-decode-isodatetime (isodatetimestring)
361 "Return ISODATETIMESTRING in format like `decode-time'.
362Converts from ISO-8601 to Emacs representation. If ISODATETIMESTRING
363specifies UTC time (trailing letter Z) the decoded time is given in
364the local time zone! FIXME: TZID-attributes are ignored....! FIXME:
365multiple comma-separated values should be allowed!"
366 (icalendar-dmsg isodatetimestring)
367 (if isodatetimestring
368 ;; day/month/year must be present
369 (let ((year (read (substring isodatetimestring 0 4)))
370 (month (read (substring isodatetimestring 4 6)))
371 (day (read (substring isodatetimestring 6 8)))
372 (hour 0)
373 (minute 0)
374 (second 0))
375 (when (> (length isodatetimestring) 12)
376 ;; hour/minute present
377 (setq hour (read (substring isodatetimestring 9 11)))
378 (setq minute (read (substring isodatetimestring 11 13))))
379 (when (> (length isodatetimestring) 14)
380 ;; seconds present
381 (setq second (read (substring isodatetimestring 13 15))))
382 (when (and (> (length isodatetimestring) 15)
383 ;; UTC specifier present
384 (char-equal ?Z (aref isodatetimestring 15)))
385 ;; if not UTC add current-time-zone offset
386 (setq second (+ (car (current-time-zone)) second)))
387 ;; create the decoded date-time
388 ;; FIXME!?!
389 (condition-case nil
390 (decode-time (encode-time second minute hour day month year))
391 (error
392 (message "Cannot decode \"%s\"" isodatetimestring)
393 ;; hope for the best...
394 (list second minute hour day month year 0 nil 0))))
395 ;; isodatetimestring == nil
396 nil))
397
398(defun icalendar-decode-isoduration (isodurationstring)
399 "Return ISODURATIONSTRING in format like `decode-time'.
400Converts from ISO-8601 to Emacs representation. If ISODURATIONSTRING
401specifies UTC time (trailing letter Z) the decoded time is given in
402the local time zone! FIXME: TZID-attributes are ignored....! FIXME:
403multiple comma-separated values should be allowed!"
404 (if isodurationstring
405 (save-match-data
406 (string-match
407 (concat
408 "^P[+-]?\\("
409 "\\(\\([0-9]+\\)D\\)" ; days only
410 "\\|"
411 "\\(\\(\\([0-9]+\\)D\\)?T\\(\\([0-9]+\\)H\\)?" ; opt days
412 "\\(\\([0-9]+\\)M\\)?\\(\\([0-9]+\\)S\\)?\\)" ; mand. time
413 "\\|"
414 "\\(\\([0-9]+\\)W\\)" ; weeks only
415 "\\)$") isodurationstring)
416 (let ((seconds 0)
417 (minutes 0)
418 (hours 0)
419 (days 0)
420 (months 0)
421 (years 0))
422 (cond
423 ((match-beginning 2) ;days only
424 (setq days (read (substring isodurationstring
425 (match-beginning 3)
426 (match-end 3))))
427 (when icalendar-duration-correction
428 (setq days (1- days))))
429 ((match-beginning 4) ;days and time
430 (if (match-beginning 5)
431 (setq days (* 7 (read (substring isodurationstring
432 (match-beginning 6)
433 (match-end 6))))))
434 (if (match-beginning 7)
435 (setq hours (read (substring isodurationstring
436 (match-beginning 8)
437 (match-end 8)))))
438 (if (match-beginning 9)
439 (setq minutes (read (substring isodurationstring
440 (match-beginning 10)
441 (match-end 10)))))
442 (if (match-beginning 11)
443 (setq seconds (read (substring isodurationstring
444 (match-beginning 12)
445 (match-end 12)))))
446 )
447 ((match-beginning 13) ;weeks only
448 (setq days (* 7 (read (substring isodurationstring
449 (match-beginning 14)
450 (match-end 14))))))
451 )
452 (list seconds minutes hours days months years)))
453 ;; isodatetimestring == nil
454 nil))
455
456(defun icalendar-add-decoded-times (time1 time2)
457 "Add TIME1 to TIME2.
458Both times must be given in decoded form. One of these times must be
459valid (year > 1900 or something)."
460 ;; FIXME: does this function exist already?
461 (decode-time (encode-time
462 (+ (nth 0 time1) (nth 0 time2))
463 (+ (nth 1 time1) (nth 1 time2))
464 (+ (nth 2 time1) (nth 2 time2))
465 (+ (nth 3 time1) (nth 3 time2))
466 (+ (nth 4 time1) (nth 4 time2))
467 (+ (nth 5 time1) (nth 5 time2))
468 nil
469 nil
470 ;;(or (nth 6 time1) (nth 6 time2)) ;; FIXME?
471 )))
472
473(defun icalendar-datetime-to-noneuropean-date (datetime)
474 "Convert the decoded DATETIME to non-european-style format.
475Non-European format: (month day year)."
476 (if datetime
477 (list (nth 4 datetime) ;month
478 (nth 3 datetime) ;day
479 (nth 5 datetime));year
480 ;; datetime == nil
481 nil))
482
483(defun icalendar-datetime-to-european-date (datetime)
484 "Convert the decoded DATETIME to European format.
485European format: (day month year).
486FIXME"
487 (if datetime
488 (format "%d %d %d" (nth 3 datetime); day
489 (nth 4 datetime) ;month
490 (nth 5 datetime));year
491 ;; datetime == nil
492 nil))
493
494(defun icalendar-datetime-to-colontime (datetime)
495 "Extract the time part of a decoded DATETIME into 24-hour format.
496Note that this silently ignores seconds."
497 (format "%02d:%02d" (nth 2 datetime) (nth 1 datetime)))
498
499(defun icalendar-get-month-number (monthname)
500 "Return the month number for the given MONTHNAME."
501 (save-match-data
502 (let ((case-fold-search t))
503 (assoc-default monthname icalendar-monthnumber-table
504 'string-match))))
505
506(defun icalendar-get-weekday-abbrev (weekday)
507 "Return the abbreviated WEEKDAY."
508 ;;FIXME: ISO-like(?).
509 (save-match-data
510 (let ((case-fold-search t))
511 (assoc-default weekday icalendar-weekdayabbrev-table
512 'string-match))))
513
514(defun icalendar-datestring-to-isodate (datestring &optional day-shift)
515 "Convert diary-style DATESTRING to iso-style date.
516If DAY-SHIFT is non-nil, the result is shifted by DAY-SHIFT days
517-- DAY-SHIFT must be either nil or an integer. This function
518takes care of european-style."
519 (let ((day -1) month year)
520 (save-match-data
521 (cond (;; numeric date
522 (string-match (concat "\\s-*"
523 "0?\\([1-9][0-9]?\\)[ \t/]\\s-*"
524 "0?\\([1-9][0-9]?\\),?[ \t/]\\s-*"
525 "\\([0-9]\\{4\\}\\)")
526 datestring)
527 (setq day (read (substring datestring (match-beginning 1)
528 (match-end 1))))
529 (setq month (read (substring datestring (match-beginning 2)
530 (match-end 2))))
531 (setq year (read (substring datestring (match-beginning 3)
532 (match-end 3))))
533 (unless european-calendar-style
534 (let ((x month))
535 (setq month day)
536 (setq day x))))
537 (;; date contains month names -- european-style
538 (and european-calendar-style
539 (string-match (concat "\\s-*"
540 "0?\\([123]?[0-9]\\)[ \t/]\\s-*"
541 "\\([A-Za-z][^ ]+\\)[ \t/]\\s-*"
542 "\\([0-9]\\{4\\}\\)")
543 datestring))
544 (setq day (read (substring datestring (match-beginning 1)
545 (match-end 1))))
546 (setq month (icalendar-get-month-number
547 (substring datestring (match-beginning 2)
548 (match-end 2))))
549 (setq year (read (substring datestring (match-beginning 3)
550 (match-end 3)))))
551 (;; date contains month names -- non-european-style
552 (and (not european-calendar-style)
553 (string-match (concat "\\s-*"
554 "\\([A-Za-z][^ ]+\\)[ \t/]\\s-*"
555 "0?\\([123]?[0-9]\\),?[ \t/]\\s-*"
556 "\\([0-9]\\{4\\}\\)")
557 datestring))
558 (setq day (read (substring datestring (match-beginning 2)
559 (match-end 2))))
560 (setq month (icalendar-get-month-number
561 (substring datestring (match-beginning 1)
562 (match-end 1))))
563 (setq year (read (substring datestring (match-beginning 3)
564 (match-end 3)))))
565 (t
566 nil)))
567 (if (> day 0)
568 (let ((mdy (calendar-gregorian-from-absolute
569 (+ (calendar-absolute-from-gregorian (list month day year))
570 (or day-shift 0)))))
571 (format "%04d%02d%02d" (nth 2 mdy) (nth 0 mdy) (nth 1 mdy)))
572 nil)))
573
574(defun icalendar-dmsg (&rest args)
575 "Print message ARGS if `icalendar-debug' is non-nil."
576 (if icalendar-debug
577 (apply 'message args)))
578
579(defun icalendar-diarytime-to-isotime (timestring ampmstring)
580 "Convert a a time like 9:30pm to an iso-conform string like T213000.
581In this example the TIMESTRING would be \"9:30\" and the AMPMSTRING
582would be \"pm\"."
583 (if timestring
584 (let ((starttimenum (read (icalendar-rris ":" "" timestring))))
585 ;; take care of am/pm style
586 (if (and ampmstring (string= "pm" ampmstring))
587 (setq starttimenum (+ starttimenum 1200)))
588 (format "T%04d00" starttimenum))
589 nil))
590
591(defun icalendar-convert-string-for-export (s)
592 "Escape comma and other critical characters in string S."
593 (icalendar-rris "," "\\\\," s))
594
595(defun icalendar-convert-for-import (string)
596 "Remove escape chars for comma, semicolon etc. from STRING."
597 (icalendar-rris
598 "\\\\n" "\n " (icalendar-rris
599 "\\\\\"" "\"" (icalendar-rris
600 "\\\\;" ";" (icalendar-rris
601 "\\\\," "," string)))))
602
603;; ======================================================================
604;; export -- convert emacs-diary to icalendar
605;; ======================================================================
606
607(defun icalendar-convert-diary-to-ical (diary-filename ical-filename
608 &optional do-not-clear-diary-file)
609 "Export diary file to iCalendar format -- erases ical-filename!!!.
610Argument DIARY-FILENAME is the input `diary-file'.
611Argument ICAL-FILENAME is the output iCalendar file.
612If DO-NOT-CLEAR-DIARY-FILE is not nil the target iCalendar file
613is not erased."
614 (interactive "FExport diary data from file:
615Finto iCalendar file: ")
616 (let ((result "")
617 (start 0)
618 (entry-main "")
619 (entry-rest "")
620 (header "")
621 (contents)
622 (oops nil)
623 (nonmarker (concat "^" (regexp-quote diary-nonmarking-symbol)
624 "?")))
625 (save-current-buffer
626 (set-buffer (find-file diary-filename))
627 (goto-char (point-min))
628 (while (re-search-forward
629 "^\\([^ \t\n].*\\)\\(\n[ \t].*\\)*" nil t)
630 (setq entry-main (match-string 1))
631 (if (match-beginning 2)
632 (setq entry-rest (match-string 2))
633 (setq entry-rest ""))
634 (setq header (format "\nBEGIN:VEVENT\nUID:emacs%d%d%d"
635 (car (current-time))
636 (cadr (current-time))
637 (car (cddr (current-time)))))
638 (setq oops nil)
639 (cond
640 ;; anniversaries
641 ((string-match
642 (concat nonmarker
643 "%%(diary-anniversary \\([^)]+\\))\\s-*\\(.*\\)")
644 entry-main)
645 (icalendar-dmsg "diary-anniversary %s" entry-main)
646 (let* ((datetime (substring entry-main (match-beginning 1)
647 (match-end 1)))
648 (summary (icalendar-convert-string-for-export
649 (substring entry-main (match-beginning 2)
650 (match-end 2))))
651 (startisostring (icalendar-datestring-to-isodate
652 datetime))
653 (endisostring (icalendar-datestring-to-isodate
654 datetime 1)))
655 (setq contents
656 (concat "\nDTSTART;VALUE=DATE:" startisostring
657 "\nDTEND;VALUE=DATE:" endisostring
658 "\nSUMMARY:" summary
659 "\nRRULE:FREQ=YEARLY;INTERVAL=1"
660 ;; the following is redundant,
661 ;; but korganizer seems to expect this... ;(
662 ;; and evolution doesn't understand it... :(
663 ;; so... who is wrong?!
664 ";BYMONTH=" (substring startisostring 4 6)
665 ";BYMONTHDAY=" (substring startisostring 6 8)
666 )))
667 (unless (string= entry-rest "")
668 (setq contents (concat contents "\nDESCRIPTION:"
669 (icalendar-convert-string-for-export
670 entry-rest)))))
671 ;; cyclic events
672 ;; %%(diary-cyclic )
673 ((string-match
674 (concat nonmarker
675 "%%(diary-cyclic \\([^ ]+\\) +"
676 "\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\))\\s-*\\(.*\\)")
677 entry-main)
678 (icalendar-dmsg "diary-cyclic %s" entry-main)
679 (let* ((frequency (substring entry-main (match-beginning 1)
680 (match-end 1)))
681 (datetime (substring entry-main (match-beginning 2)
682 (match-end 2)))
683 (summary (icalendar-convert-string-for-export
684 (substring entry-main (match-beginning 3)
685 (match-end 3))))
686 (startisostring (icalendar-datestring-to-isodate
687 datetime))
688 (endisostring (icalendar-datestring-to-isodate
689 datetime 1)))
690 (setq contents
691 (concat "\nDTSTART;VALUE=DATE:" startisostring
692 "\nDTEND;VALUE=DATE:" endisostring
693 "\nSUMMARY:" summary
694 "\nRRULE:FREQ=DAILY;INTERVAL=" frequency
695 ;; strange: korganizer does not expect
696 ;; BYSOMETHING here...
697 )))
698 (unless (string= entry-rest "")
699 (setq contents (concat contents "\nDESCRIPTION:"
700 (icalendar-convert-string-for-export
701 entry-rest)))))
702 ;; diary-date -- FIXME
703 ((string-match
704 (concat nonmarker
705 "%%(diary-date \\([^)]+\\))\\s-*\\(.*\\)")
706 entry-main)
707 (icalendar-dmsg "diary-date %s" entry-main)
708 (setq oops t))
709 ;; float events -- FIXME
710 ((string-match
711 (concat nonmarker
712 "%%(diary-float \\([^)]+\\))\\s-*\\(.*\\)")
713 entry-main)
714 (icalendar-dmsg "diary-float %s" entry-main)
715 (setq oops t))
716 ;; block events
717 ((string-match
718 (concat nonmarker
719 "%%(diary-block \\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\) +"
720 "\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\))\\s-*\\(.*\\)")
721 entry-main)
722 (icalendar-dmsg "diary-block %s" entry-main)
723 (let* ((startstring (substring entry-main (match-beginning 1)
724 (match-end 1)))
725 (endstring (substring entry-main (match-beginning 2)
726 (match-end 2)))
727 (summary (icalendar-convert-string-for-export
728 (substring entry-main (match-beginning 3)
729 (match-end 3))))
730 (startisostring (icalendar-datestring-to-isodate
731 startstring))
732 (endisostring (icalendar-datestring-to-isodate
733 endstring 1)))
734 (setq contents
735 (concat "\nDTSTART;VALUE=DATE:" startisostring
736 "\nDTEND;VALUE=DATE:" endisostring
737 "\nSUMMARY:" summary
738 ))
739 (unless (string= entry-rest "")
740 (setq contents (concat contents "\nDESCRIPTION:"
741 (icalendar-convert-string-for-export
742 entry-rest))))))
743 ;; other sexp diary entries -- FIXME
744 ((string-match
745 (concat nonmarker
746 "%%(\\([^)]+\\))\\s-*\\(.*\\)")
747 entry-main)
748 (icalendar-dmsg "diary-sexp %s" entry-main)
749 (setq oops t))
750 ;; weekly by day
751 ;; Monday 8:30 Team meeting
752 ((and (string-match
753 (concat nonmarker
754 "\\([a-z]+\\)\\s-+"
755 "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?"
756 "\\(-0?"
757 "\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?"
758 "\\)?"
759 "\\s-*\\(.*\\)$")
760 entry-main)
761 (icalendar-get-weekday-abbrev
762 (substring entry-main (match-beginning 1) (match-end 1))))
763 (icalendar-dmsg "weekly %s" entry-main)
764 (let* ((day (icalendar-get-weekday-abbrev
765 (substring entry-main (match-beginning 1)
766 (match-end 1))))
767 (starttimestring (icalendar-diarytime-to-isotime
768 (if (match-beginning 3)
769 (substring entry-main
770 (match-beginning 3)
771 (match-end 3))
772 nil)
773 (if (match-beginning 4)
774 (substring entry-main
775 (match-beginning 4)
776 (match-end 4))
777 nil)))
778 (endtimestring (icalendar-diarytime-to-isotime
779 (if (match-beginning 6)
780 (substring entry-main
781 (match-beginning 6)
782 (match-end 6))
783 nil)
784 (if (match-beginning 7)
785 (substring entry-main
786 (match-beginning 7)
787 (match-end 7))
788 nil)))
789 (summary (icalendar-convert-string-for-export
790 (substring entry-main (match-beginning 8)
791 (match-end 8)))))
792 (when starttimestring
793 (unless endtimestring
794 (let ((time (read (icalendar-rris "^T0?" ""
795 starttimestring))))
796 (setq endtimestring (format "T%06d" (+ 10000 time))))))
797 (setq contents
798 (concat "\nDTSTART"
799 (if starttimestring "" ";VALUE=DATE")
800 ":19000101" ;; FIXME? Probability that this
801 ;; is the right day is 1/7
802 (or starttimestring "")
803 "\nDTEND"
804 (if endtimestring "" ";VALUE=DATE")
805 ":19000101" ;; FIXME?
806 (or endtimestring "")
807 "\nSUMMARY:" summary
808 "\nRRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=" day
809 )))
810 (unless (string= entry-rest "")
811 (setq contents (concat contents "\nDESCRIPTION:"
812 (icalendar-convert-string-for-export
813 entry-rest)))))
814 ;; yearly by day
815 ;; 1 May Tag der Arbeit
816 ((string-match
817 (concat nonmarker
818 (if european-calendar-style
819 "0?\\([1-9]+[0-9]?\\)\\s-+\\([a-z]+\\)\\s-+"
820 "\\([a-z]+\\)\\s-+0?\\([1-9]+[0-9]?\\)\\s-+")
821 "\\*?\\s-*"
822 "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?"
823 "\\("
824 "-0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?"
825 "\\)?"
826 "\\s-*\\([^0-9]+.*\\)$"; must not match years
827 )
828 entry-main)
829 (icalendar-dmsg "yearly %s" entry-main)
830 (let* ((daypos (if european-calendar-style 1 2))
831 (monpos (if european-calendar-style 2 1))
832 (day (read (substring entry-main (match-beginning daypos)
833 (match-end daypos))))
834 (month (icalendar-get-month-number
835 (substring entry-main (match-beginning monpos)
836 (match-end monpos))))
837 (starttimestring (icalendar-diarytime-to-isotime
838 (if (match-beginning 4)
839 (substring entry-main
840 (match-beginning 4)
841 (match-end 4))
842 nil)
843 (if (match-beginning 5)
844 (substring entry-main
845 (match-beginning 5)
846 (match-end 5))
847 nil)))
848 (endtimestring (icalendar-diarytime-to-isotime
849 (if (match-beginning 7)
850 (substring entry-main
851 (match-beginning 7)
852 (match-end 7))
853 nil)
854 (if (match-beginning 8)
855 (substring entry-main
856 (match-beginning 8)
857 (match-end 8))
858 nil)))
859 (summary (icalendar-convert-string-for-export
860 (substring entry-main (match-beginning 9)
861 (match-end 9)))))
862 (when starttimestring
863 (unless endtimestring
864 (let ((time (read (icalendar-rris "^T0?" ""
865 starttimestring))))
866 (setq endtimestring (format "T%06d" (+ 10000 time))))))
867 (setq contents
868 (concat "\nDTSTART"
869 (if starttimestring "" ";VALUE=DATE")
870 (format ":1900%02d%02d" month day)
871 (or starttimestring "")
872 "\nDTEND"
873 (if endtimestring "" ";VALUE=DATE")
874 (format ":1900%02d%02d" month day)
875 (or endtimestring "")
876 "\nSUMMARY:" summary
877 "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH="
878 (format "%2d" month)
879 ";BYMONTHDAY="
880 (format "%2d" day)
881 )))
882 (unless (string= entry-rest "")
883 (setq contents (concat contents "\nDESCRIPTION:"
884 (icalendar-convert-string-for-export
885 entry-rest)))))
886 ;; "ordinary" events, start and end time given
887 ;; 1 Feb 2003 Hs Hochzeitsfeier, Dreieich
888 ((string-match
889 (concat nonmarker
890 "\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\)\\s-+"
891 "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?"
892 "\\("
893 "-0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?"
894 "\\)?"
895 "\\s-*\\(.*\\)")
896 entry-main)
897 (icalendar-dmsg "ordinary %s" entry-main)
898 (let* ((datestring (icalendar-datestring-to-isodate
899 (substring entry-main (match-beginning 1)
900 (match-end 1))))
901 (starttimestring (icalendar-diarytime-to-isotime
902 (if (match-beginning 3)
903 (substring entry-main
904 (match-beginning 3)
905 (match-end 3))
906 nil)
907 (if (match-beginning 4)
908 (substring entry-main
909 (match-beginning 4)
910 (match-end 4))
911 nil)))
912 (endtimestring (icalendar-diarytime-to-isotime
913 (if (match-beginning 6)
914 (substring entry-main
915 (match-beginning 6)
916 (match-end 6))
917 nil)
918 (if (match-beginning 7)
919 (substring entry-main
920 (match-beginning 7)
921 (match-end 7))
922 nil)))
923 (summary (icalendar-convert-string-for-export
924 (substring entry-main (match-beginning 8)
925 (match-end 8)))))
926 (when starttimestring
927 (unless endtimestring
928 (let ((time (read (icalendar-rris "^T0?" ""
929 starttimestring))))
930 (setq endtimestring (format "T%06d" (+ 10000 time))))))
931 (setq contents (format
932 "\nDTSTART%s:%s%s\nDTEND%s:%s%s\nSUMMARY:%s"
933 (if starttimestring "" ";VALUE=DATE")
934 datestring
935 (or starttimestring "")
936 (if endtimestring ""
937 ";VALUE=DATE")
938 datestring
939 (or endtimestring "")
940 summary))
941 (unless (string= entry-rest "")
942 (setq contents (concat contents "\nDESCRIPTION:"
943 (icalendar-convert-string-for-export
944 entry-rest))))))
945 ;; everything else
946 (t
947 ;; Oops! what's that?
948 (setq oops t)))
949 (if oops
950 (message "Cannot export entry on line %d"
951 (count-lines (point-min) (point)))
952 (setq result (concat result header contents "\nEND:VEVENT"))))
953 ;; we're done, insert everything into the file
954 (let ((coding-system-for-write 'utf8))
955 (set-buffer (find-file ical-filename))
956 (unless do-not-clear-diary-file
957 (erase-buffer))
958 (insert
959 "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN")
960 (insert "\nVERSION:2.0")
961 (insert result)
962 (insert "\nEND:VCALENDAR\n")))))
963
964
965;; ======================================================================
966;; import -- convert icalendar to emacs-diary
967;; ======================================================================
968
969;; user function
970(defun icalendar-import-file (ical-filename diary-filename
971 &optional non-marking
972 do-not-clear-diary-file)
973 "Import a iCalendar file and save to a diary file -- erases diary-file!
974Argument ICAL-FILENAME output iCalendar file.
975Argument DIARY-FILENAME input `diary-file'.
976Optional argument NON-MARKING determines whether events are created as
977non-marking or not.
978If DO-NOT-CLEAR-DIARY-FILE is not nil the target diary file is
979not erased."
980 (interactive "fImport iCalendar data from file:
981Finto diary file (will be erased!):
982p")
983 ;; clean up the diary file
984 (save-current-buffer
985 (unless do-not-clear-diary-file
986 ;; clear the target diary file
987 (set-buffer (find-file diary-filename))
988 (erase-buffer))
989 ;; now load and convert from the ical file
990 (set-buffer (find-file ical-filename))
991 (icalendar-extract-ical-from-buffer diary-filename t non-marking)))
992
993; user function
994(defun icalendar-extract-ical-from-buffer (&optional
995 diary-file do-not-ask
996 non-marking)
997 "Extract iCalendar events from current buffer.
998
999This function searches the current buffer for the first iCalendar
1000object, reads it and adds all VEVENT elements to the diary
1001DIARY-FILE.
1002
1003It will ask for each appointment whether to add it to the diary
1004when DO-NOT-ASK is non-nil. When called interactively,
1005DO-NOT-ASK is set to t, so that you are asked fore each event.
1006
1007NON-MARKING determines whether diary events are created as
1008non-marking.
1009
1010This function attempts to notify about problems that occur when
1011reading, parsing, or converting iCalendar data!"
1012 (interactive)
1013 (save-current-buffer
1014 ;; prepare ical
1015 (message "Preparing icalendar...")
1016 (set-buffer (icalendar-get-unfolded-buffer (current-buffer)))
1017 (goto-char (point-min))
1018 (message "Preparing icalendar...done")
1019 (if (re-search-forward "^BEGIN:VCALENDAR\\s-*$" nil t)
1020 (let (ical-contents ical-errors)
1021 ;; read ical
1022 (message "Reading icalendar...")
1023 (beginning-of-line)
1024 (setq ical-contents (icalendar-read-element nil nil))
1025 (message "Reading icalendar...done")
1026 ;; convert ical
1027 (message "Converting icalendar...")
1028 (setq ical-errors (icalendar-convert-ical-to-diary
1029 ical-contents
1030 diary-file do-not-ask non-marking))
1031 (when diary-file
1032 ;; save the diary file
1033 (save-current-buffer
1034 (set-buffer (find-buffer-visiting diary-file))
1035 (save-buffer)))
1036 (message "Converting icalendar...done")
1037 (if (and ical-errors (y-or-n-p
1038 (concat "Something went wrong -- "
1039 "do you want to see the "
1040 "error log? ")))
1041 (switch-to-buffer " *icalendar-errors*")))
1042 (message
1043 "Current buffer does not contain icalendar contents!"))))
1044
1045;; ----------------------------------------------------------------------
1046;; private area
1047;; ----------------------------------------------------------------------
1048(defun icalendar-format-ical-event (event)
1049 "Create a string representation of an iCalendar EVENT."
1050 (let ((string icalendar-import-format)
1051 (conversion-list
1052 '(("%d" DESCRIPTION icalendar-import-format-description)
1053 ("%s" SUMMARY icalendar-import-format-subject)
1054 ("%l" LOCATION icalendar-import-format-location)
1055 ("%o" ORGANIZER icalendar-import-format-organizer))))
1056 ;; convert the specifiers in the format string
1057 (mapcar (lambda (i)
1058 (let* ((spec (car i))
1059 (prop (cadr i))
1060 (format (car (cddr i)))
1061 (contents (icalendar-get-event-property event prop))
1062 (formatted-contents ""))
1063 ;;(message "%s" event)
1064 ;;(message "contents%s = %s" prop contents)
1065 (when (and contents (> (length contents) 0))
1066 (setq formatted-contents
1067 (icalendar-rris "%s"
1068 (icalendar-convert-for-import
1069 contents)
1070 (symbol-value format))))
1071 (setq string (icalendar-rris spec
1072 formatted-contents
1073 string))))
1074 conversion-list)
1075 string))
1076
1077(defun icalendar-convert-ical-to-diary (ical-list diary-file
1078 &optional do-not-ask
1079 non-marking)
1080 "Convert an iCalendar file to an Emacs diary file.
1081Import VEVENTS from the iCalendar object ICAL-LIST and saves them to a
1082DIARY-FILE. If DO-NOT-ASK is nil the user is asked for each event
1083whether to actually import it. NON-MARKING determines whether diary
1084events are created as non-marking.
1085This function attempts to return t if something goes wrong. In this
1086case an error string which describes all the errors and problems is
1087written into the buffer ` *icalendar-errors*'."
1088 (let* ((ev (icalendar-all-events ical-list))
1089 (error-string "")
1090 (event-ok t)
1091 (found-error nil)
1092 e diary-string)
1093 ;; step through all events/appointments
1094 (while ev
1095 (setq e (car ev))
1096 (setq ev (cdr ev))
1097 (setq event-ok nil)
1098 (condition-case error-val
1099 (let* ((dtstart (icalendar-decode-isodatetime
1100 (icalendar-get-event-property e 'DTSTART)))
1101 (start-d (calendar-date-string
1102 (icalendar-datetime-to-noneuropean-date
1103 dtstart)
1104 t t))
1105 (start-t (icalendar-datetime-to-colontime dtstart))
1106 (dtend (icalendar-decode-isodatetime
1107 (icalendar-get-event-property e 'DTEND)))
1108 end-d
1109 end-t
1110 (subject (icalendar-convert-for-import
1111 (or (icalendar-get-event-property e 'SUMMARY)
1112 "No Subject")))
1113 (rrule (icalendar-get-event-property e 'RRULE))
1114 (rdate (icalendar-get-event-property e 'RDATE))
1115 (duration (icalendar-get-event-property e 'DURATION)))
1116 (icalendar-dmsg "%s: %s" start-d subject)
1117 (when duration
1118 (let ((dtend2 (icalendar-add-decoded-times
1119 dtstart
1120 (icalendar-decode-isoduration duration))))
1121 (if (and dtend (not (eq dtend dtend2)))
1122 (message "Inconsistent endtime and duration for %s"
1123 subject))
1124 (setq dtend dtend2)))
1125 (setq end-d (if dtend
1126 (calendar-date-string
1127 (icalendar-datetime-to-noneuropean-date
1128 dtend)
1129 t t)
1130 start-d))
1131 (setq end-t (if dtend
1132 (icalendar-datetime-to-colontime dtend)
1133 start-t))
1134 (icalendar-dmsg "start-d: %s, end-d: %s" start-d end-d)
1135 (cond
1136 ;; recurring event
1137 (rrule
1138 (icalendar-dmsg "recurring event")
1139 (let* ((rrule-props (icalendar-split-value rrule))
1140 (frequency (car (cdr (assoc 'FREQ rrule-props))))
1141 (until (car (cdr (assoc 'UNTIL rrule-props))))
1142 (interval (read (car (cdr (assoc 'INTERVAL
1143 rrule-props))))))
1144 (cond ((string-equal frequency "WEEKLY")
1145 (if (not start-t)
1146 (progn
1147 ;; weekly and all-day
1148 (icalendar-dmsg "weekly all-day")
1149 (setq diary-string
1150 (format
1151 "%%%%(diary-cyclic %d %s)"
1152 (* interval 7)
1153 (icalendar-datetime-to-european-date
1154 dtstart))))
1155 ;; weekly and not all-day
1156 (let* ((byday (cadr (assoc 'BYDAY rrule-props)))
1157 (weekday
1158 (cdr (rassoc
1159 byday
1160 icalendar-weekdayabbrev-table))))
1161 (icalendar-dmsg "weekly not-all-day")
1162 (if weekday
1163 (setq diary-string
1164 (format "%s %s%s%s" weekday
1165 start-t (if end-t "-" "")
1166 (or end-t "")))
1167 ;; FIXME!!!!
1168 ;; DTSTART;VALUE=DATE-TIME:20030919T090000
1169 ;; DTEND;VALUE=DATE-TIME:20030919T113000
1170 (setq diary-string
1171 (format
1172 "%%%%(diary-cyclic %s %s) %s%s%s"
1173 (* interval 7)
1174 (icalendar-datetime-to-european-date
1175 dtstart)
1176 start-t (if end-t "-" "") (or end-t ""))))
1177 (setq event-ok t))))
1178 ;; yearly
1179 ((string-equal frequency "YEARLY")
1180 (icalendar-dmsg "yearly")
1181 (setq diary-string
1182 (format
1183 "%%%%(diary-anniversary %s)"
1184 (icalendar-datetime-to-european-date dtstart)))
1185 (setq event-ok t))
1186 ;; FIXME: war auskommentiert:
1187 ((and (string-equal frequency "DAILY")
1188 ;;(not (string= start-d end-d))
1189 ;;(not start-t)
1190 ;;(not end-t)
1191 )
1192 (let ((ds (icalendar-datetime-to-noneuropean-date
1193 (icalendar-decode-isodatetime
1194 (icalendar-get-event-property e
1195 'DTSTART))))
1196 (de (icalendar-datetime-to-noneuropean-date
1197 (icalendar-decode-isodatetime
1198 until))))
1199 (setq diary-string
1200 (format
1201 "%%%%(diary-block %d %d %d %d %d %d)"
1202 (nth 1 ds) (nth 0 ds) (nth 2 ds)
1203 (nth 1 de) (nth 0 de) (nth 2 de))))
1204 (setq event-ok t)))
1205 ))
1206 (rdate
1207 (icalendar-dmsg "rdate event")
1208 (setq diary-string "")
1209 (mapcar (lambda (datestring)
1210 (setq diary-string
1211 (concat diary-string
1212 (format "......"))))
1213 (icalendar-split-value rdate)))
1214 ;; non-recurring event
1215 ;; long event
1216 ((not (string= start-d end-d))
1217 (icalendar-dmsg "non-recurring event")
1218 (let ((ds (icalendar-datetime-to-noneuropean-date dtstart))
1219 (de (icalendar-datetime-to-noneuropean-date dtend)))
1220 (setq diary-string
1221 (format "%%%%(diary-block %d %d %d %d %d %d)"
1222 (nth 1 ds) (nth 0 ds) (nth 2 ds)
1223 (nth 1 de) (nth 0 de) (nth 2 de))))
1224 (setq event-ok t))
1225 ;; not all-day
1226 ((and start-t (or (not end-t)
1227 (not (string= start-t end-t))))
1228 (icalendar-dmsg "not all day event")
1229 (cond (end-t
1230 (setq diary-string (format "%s %s-%s" start-d
1231 start-t end-t)))
1232 (t
1233 (setq diary-string (format "%s %s" start-d
1234 start-t))))
1235 (setq event-ok t))
1236 ;; all-day event
1237 (t
1238 (icalendar-dmsg "all day event")
1239 (setq diary-string start-d)
1240 (setq event-ok t)))
1241 ;; add all other elements unless the user doesn't want to have
1242 ;; them
1243 (if event-ok
1244 (progn
1245 (setq diary-string
1246 (concat diary-string " "
1247 (icalendar-format-ical-event e)))
1248 (if do-not-ask (setq subject nil))
1249 (icalendar-add-diary-entry diary-string diary-file
1250 non-marking subject))
1251 ;; event was not ok
1252 (setq found-error t)
1253 (setq error-string
1254 (format "%s\nCannot handle this event:%s"
1255 error-string e))))
1256 ;; handle errors
1257 (error
1258 (message "Ignoring event \"%s\"" e)
1259 (setq found-error t)
1260 (setq error-string (format "%s\nCannot handle this event: %s"
1261 error-string e)))))
1262 (if found-error
1263 (save-current-buffer
1264 (set-buffer (get-buffer-create " *icalendar-errors*"))
1265 (erase-buffer)
1266 (insert error-string)))
1267 (message "Converting icalendar...done")
1268 found-error))
1269
1270(defun icalendar-add-diary-entry (string diary-file non-marking
1271 &optional subject)
1272 "Add STRING to the diary file DIARY-FILE.
1273STRING must be a properly formatted valid diary entry. NON-MARKING
1274determines whether diary events are created as non-marking. If
1275SUBJECT is not nil it must be a string that gives the subject of the
1276entry. In this case the user will be asked whether he wants to insert
1277the entry."
1278 (when (or (not subject) ;
1279 (y-or-n-p (format "Add appointment for `%s' to diary? "
1280 subject)))
1281 (when subject
1282 (setq non-marking
1283 (y-or-n-p (format "Make appointment non-marking? "))))
1284 (save-window-excursion
1285 (unless diary-file
1286 (setq diary-file
1287 (read-file-name "Add appointment to this diary file: ")))
1288 (make-diary-entry string non-marking diary-file))))
1289
1290;; ======================================================================
1291;; (add-hook 'list-diary-entries-hook 'include-icalendar-files)
1292;; ======================================================================
1293(defun include-icalendar-files ()
1294 "Not yet implemented.")
1295
1296(provide 'icalendar)
1297
1298;; arch-tag: 74fdbe8e-0451-4e38-bb61-4416e822f4fc
1299;;; icalendar.el ends here
diff --git a/lisp/comint.el b/lisp/comint.el
index 8b5a107c7d7..8b2c779ecd3 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -1,7 +1,7 @@
1;;; comint.el --- general command interpreter in a window stuff 1;;; comint.el --- general command interpreter in a window stuff
2 2
3;; Copyright (C) 1988,90,92,93,94,95,96,97,98,99,2000,01,02,03,2004 3;; Copyright (C) 1988, 1990, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4;; Free Software Foundation, Inc. 4;; 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
5 5
6;; Author: Olin Shivers <shivers@cs.cmu.edu> 6;; Author: Olin Shivers <shivers@cs.cmu.edu>
7;; Simon Marshall <simon@gnu.org> 7;; Simon Marshall <simon@gnu.org>
@@ -185,10 +185,10 @@ the remaining prompts will be accidentally messed up. You may
185wish to put something like the following in your `.emacs' file: 185wish to put something like the following in your `.emacs' file:
186 186
187\(add-hook 'comint-mode-hook 187\(add-hook 'comint-mode-hook
188 '(lambda () 188 (lambda ()
189 (define-key comint-mode-map \"\C-w\" 'comint-kill-region) 189 (define-key comint-mode-map \"\C-w\" 'comint-kill-region)
190 (define-key comint-mode-map [C-S-backspace] 190 (define-key comint-mode-map [C-S-backspace]
191 'comint-kill-whole-line))) 191 'comint-kill-whole-line)))
192 192
193If you sometimes use comint-mode on text-only terminals or with `emacs-nw', 193If you sometimes use comint-mode on text-only terminals or with `emacs-nw',
194you might wish to use another binding for `comint-kill-whole-line'." 194you might wish to use another binding for `comint-kill-whole-line'."
@@ -369,11 +369,8 @@ Takes one argument, the input. If non-nil, the input may be saved on the input
369history list. Default is to save anything that isn't all whitespace.") 369history list. Default is to save anything that isn't all whitespace.")
370 370
371(defvar comint-input-filter-functions '() 371(defvar comint-input-filter-functions '()
372 "Functions to call before input is sent to the process. 372 "Special hook run before input is sent to the process.
373These functions get one argument, a string containing the text to send. 373These functions get one argument, a string containing the text to send.")
374
375You can use `add-hook' to add functions to this list
376either globally or locally.")
377 374
378(defvar comint-output-filter-functions '(comint-postoutput-scroll-to-bottom) 375(defvar comint-output-filter-functions '(comint-postoutput-scroll-to-bottom)
379 "Functions to call after output is inserted into the buffer. 376 "Functions to call after output is inserted into the buffer.
@@ -411,7 +408,7 @@ See `comint-send-input'."
411(defcustom comint-use-prompt-regexp-instead-of-fields nil 408(defcustom comint-use-prompt-regexp-instead-of-fields nil
412 "*If non-nil, use `comint-prompt-regexp' to distinguish prompts from user-input. 409 "*If non-nil, use `comint-prompt-regexp' to distinguish prompts from user-input.
413If nil, then program output and user-input are given different `field' 410If nil, then program output and user-input are given different `field'
414properties, which emacs commands can use to distinguish them (in 411properties, which Emacs commands can use to distinguish them (in
415particular, common movement commands such as begining-of-line respect 412particular, common movement commands such as begining-of-line respect
416field boundaries in a natural way)." 413field boundaries in a natural way)."
417 :type 'boolean 414 :type 'boolean
@@ -432,7 +429,106 @@ executed once when the buffer is created."
432 :type 'hook 429 :type 'hook
433 :group 'comint) 430 :group 'comint)
434 431
435(defvar comint-mode-map nil) 432(defvar comint-mode-map
433 (let ((map (make-sparse-keymap)))
434 ;; Keys:
435 (define-key map "\ep" 'comint-previous-input)
436 (define-key map "\en" 'comint-next-input)
437 (define-key map [C-up] 'comint-previous-input)
438 (define-key map [C-down] 'comint-next-input)
439 (define-key map "\er" 'comint-previous-matching-input)
440 (define-key map "\es" 'comint-next-matching-input)
441 (define-key map [?\C-c ?\M-r] 'comint-previous-matching-input-from-input)
442 (define-key map [?\C-c ?\M-s] 'comint-next-matching-input-from-input)
443 (define-key map "\e\C-l" 'comint-show-output)
444 (define-key map "\C-m" 'comint-send-input)
445 (define-key map "\C-d" 'comint-delchar-or-maybe-eof)
446 (define-key map "\C-c " 'comint-accumulate)
447 (define-key map "\C-c\C-x" 'comint-get-next-from-history)
448 (define-key map "\C-c\C-a" 'comint-bol-or-process-mark)
449 (define-key map "\C-c\C-u" 'comint-kill-input)
450 (define-key map "\C-c\C-w" 'backward-kill-word)
451 (define-key map "\C-c\C-c" 'comint-interrupt-subjob)
452 (define-key map "\C-c\C-z" 'comint-stop-subjob)
453 (define-key map "\C-c\C-\\" 'comint-quit-subjob)
454 (define-key map "\C-c\C-m" 'comint-insert-input)
455 (define-key map "\C-c\C-o" 'comint-delete-output)
456 (define-key map "\C-c\C-r" 'comint-show-output)
457 (define-key map "\C-c\C-e" 'comint-show-maximum-output)
458 (define-key map "\C-c\C-l" 'comint-dynamic-list-input-ring)
459 (define-key map "\C-c\C-n" 'comint-next-prompt)
460 (define-key map "\C-c\C-p" 'comint-previous-prompt)
461 (define-key map "\C-c\C-d" 'comint-send-eof)
462 (define-key map "\C-c\C-s" 'comint-write-output)
463 (define-key map "\C-c." 'comint-insert-previous-argument)
464 ;; Mouse Buttons:
465 (define-key map [mouse-2] 'comint-insert-input)
466 ;; Menu bars:
467 ;; completion:
468 (define-key map [menu-bar completion]
469 (cons "Complete" (make-sparse-keymap "Complete")))
470 (define-key map [menu-bar completion complete-expand]
471 '("Expand File Name" . comint-replace-by-expanded-filename))
472 (define-key map [menu-bar completion complete-listing]
473 '("File Completion Listing" . comint-dynamic-list-filename-completions))
474 (define-key map [menu-bar completion complete-file]
475 '("Complete File Name" . comint-dynamic-complete-filename))
476 (define-key map [menu-bar completion complete]
477 '("Complete Before Point" . comint-dynamic-complete))
478 ;; Input history:
479 (define-key map [menu-bar inout]
480 (cons "In/Out" (make-sparse-keymap "In/Out")))
481 (define-key map [menu-bar inout delete-output]
482 '("Delete Current Output Group" . comint-delete-output))
483 (define-key map [menu-bar inout append-output-to-file]
484 '("Append Current Output Group to File" . comint-append-output-to-file))
485 (define-key map [menu-bar inout write-output]
486 '("Write Current Output Group to File" . comint-write-output))
487 (define-key map [menu-bar inout next-prompt]
488 '("Forward Output Group" . comint-next-prompt))
489 (define-key map [menu-bar inout previous-prompt]
490 '("Backward Output Group" . comint-previous-prompt))
491 (define-key map [menu-bar inout show-maximum-output]
492 '("Show Maximum Output" . comint-show-maximum-output))
493 (define-key map [menu-bar inout show-output]
494 '("Show Current Output Group" . comint-show-output))
495 (define-key map [menu-bar inout kill-input]
496 '("Kill Current Input" . comint-kill-input))
497 (define-key map [menu-bar inout copy-input]
498 '("Copy Old Input" . comint-insert-input))
499 (define-key map [menu-bar inout forward-matching-history]
500 '("Forward Matching Input..." . comint-forward-matching-input))
501 (define-key map [menu-bar inout backward-matching-history]
502 '("Backward Matching Input..." . comint-backward-matching-input))
503 (define-key map [menu-bar inout next-matching-history]
504 '("Next Matching Input..." . comint-next-matching-input))
505 (define-key map [menu-bar inout previous-matching-history]
506 '("Previous Matching Input..." . comint-previous-matching-input))
507 (define-key map [menu-bar inout next-matching-history-from-input]
508 '("Next Matching Current Input" . comint-next-matching-input-from-input))
509 (define-key map [menu-bar inout previous-matching-history-from-input]
510 '("Previous Matching Current Input" . comint-previous-matching-input-from-input))
511 (define-key map [menu-bar inout next-history]
512 '("Next Input" . comint-next-input))
513 (define-key map [menu-bar inout previous-history]
514 '("Previous Input" . comint-previous-input))
515 (define-key map [menu-bar inout list-history]
516 '("List Input History" . comint-dynamic-list-input-ring))
517 (define-key map [menu-bar inout expand-history]
518 '("Expand History Before Point" . comint-replace-by-expanded-history))
519 ;; Signals
520 (let ((signals-map (make-sparse-keymap "Signals")))
521 (define-key map [menu-bar signals] (cons "Signals" signals-map))
522 (define-key signals-map [eof] '("EOF" . comint-send-eof))
523 (define-key signals-map [kill] '("KILL" . comint-kill-subjob))
524 (define-key signals-map [quit] '("QUIT" . comint-quit-subjob))
525 (define-key signals-map [cont] '("CONT" . comint-continue-subjob))
526 (define-key signals-map [stop] '("STOP" . comint-stop-subjob))
527 (define-key signals-map [break] '("BREAK" . comint-interrupt-subjob)))
528 ;; Put them in the menu bar:
529 (setq menu-bar-final-items (append '(completion inout signals)
530 menu-bar-final-items))
531 map))
436 532
437;; Fixme: Is this still relevant? 533;; Fixme: Is this still relevant?
438(defvar comint-ptyp t 534(defvar comint-ptyp t
@@ -548,114 +644,6 @@ Entry to this mode runs the hooks on `comint-mode-hook'."
548 ;; This behavior is not useful in comint buffers, and is annoying 644 ;; This behavior is not useful in comint buffers, and is annoying
549 (set (make-local-variable 'next-line-add-newlines) nil)) 645 (set (make-local-variable 'next-line-add-newlines) nil))
550 646
551(if comint-mode-map
552 nil
553 ;; Keys:
554 (setq comint-mode-map (make-sparse-keymap))
555 (define-key comint-mode-map "\ep" 'comint-previous-input)
556 (define-key comint-mode-map "\en" 'comint-next-input)
557 (define-key comint-mode-map [C-up] 'comint-previous-input)
558 (define-key comint-mode-map [C-down] 'comint-next-input)
559 (define-key comint-mode-map "\er" 'comint-previous-matching-input)
560 (define-key comint-mode-map "\es" 'comint-next-matching-input)
561 (define-key comint-mode-map [?\C-c ?\M-r] 'comint-previous-matching-input-from-input)
562 (define-key comint-mode-map [?\C-c ?\M-s] 'comint-next-matching-input-from-input)
563 (define-key comint-mode-map "\e\C-l" 'comint-show-output)
564 (define-key comint-mode-map "\C-m" 'comint-send-input)
565 (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof)
566 (define-key comint-mode-map "\C-c " 'comint-accumulate)
567 (define-key comint-mode-map "\C-c\C-x" 'comint-get-next-from-history)
568 (define-key comint-mode-map "\C-c\C-a" 'comint-bol-or-process-mark)
569 (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input)
570 (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word)
571 (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob)
572 (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob)
573 (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob)
574 (define-key comint-mode-map "\C-c\C-m" 'comint-insert-input)
575 (define-key comint-mode-map "\C-c\C-o" 'comint-delete-output)
576 (define-key comint-mode-map "\C-c\C-r" 'comint-show-output)
577 (define-key comint-mode-map "\C-c\C-e" 'comint-show-maximum-output)
578 (define-key comint-mode-map "\C-c\C-l" 'comint-dynamic-list-input-ring)
579 (define-key comint-mode-map "\C-c\C-n" 'comint-next-prompt)
580 (define-key comint-mode-map "\C-c\C-p" 'comint-previous-prompt)
581 (define-key comint-mode-map "\C-c\C-d" 'comint-send-eof)
582 (define-key comint-mode-map "\C-c\C-s" 'comint-write-output)
583 (define-key comint-mode-map "\C-c." 'comint-insert-previous-argument)
584 ;; Mouse Buttons:
585 (define-key comint-mode-map [mouse-2] 'comint-mouse-insert-input)
586 ;; Menu bars:
587 ;; completion:
588 (define-key comint-mode-map [menu-bar completion]
589 (cons "Complete" (make-sparse-keymap "Complete")))
590 (define-key comint-mode-map [menu-bar completion complete-expand]
591 '("Expand File Name" . comint-replace-by-expanded-filename))
592 (define-key comint-mode-map [menu-bar completion complete-listing]
593 '("File Completion Listing" . comint-dynamic-list-filename-completions))
594 (define-key comint-mode-map [menu-bar completion complete-file]
595 '("Complete File Name" . comint-dynamic-complete-filename))
596 (define-key comint-mode-map [menu-bar completion complete]
597 '("Complete Before Point" . comint-dynamic-complete))
598 ;; Input history:
599 (define-key comint-mode-map [menu-bar inout]
600 (cons "In/Out" (make-sparse-keymap "In/Out")))
601 (define-key comint-mode-map [menu-bar inout delete-output]
602 '("Delete Current Output Group" . comint-delete-output))
603 (define-key comint-mode-map [menu-bar inout append-output-to-file]
604 '("Append Current Output Group to File" . comint-append-output-to-file))
605 (define-key comint-mode-map [menu-bar inout write-output]
606 '("Write Current Output Group to File" . comint-write-output))
607 (define-key comint-mode-map [menu-bar inout next-prompt]
608 '("Forward Output Group" . comint-next-prompt))
609 (define-key comint-mode-map [menu-bar inout previous-prompt]
610 '("Backward Output Group" . comint-previous-prompt))
611 (define-key comint-mode-map [menu-bar inout show-maximum-output]
612 '("Show Maximum Output" . comint-show-maximum-output))
613 (define-key comint-mode-map [menu-bar inout show-output]
614 '("Show Current Output Group" . comint-show-output))
615 (define-key comint-mode-map [menu-bar inout kill-input]
616 '("Kill Current Input" . comint-kill-input))
617 (define-key comint-mode-map [menu-bar inout copy-input]
618 '("Copy Old Input" . comint-insert-input))
619 (define-key comint-mode-map [menu-bar inout forward-matching-history]
620 '("Forward Matching Input..." . comint-forward-matching-input))
621 (define-key comint-mode-map [menu-bar inout backward-matching-history]
622 '("Backward Matching Input..." . comint-backward-matching-input))
623 (define-key comint-mode-map [menu-bar inout next-matching-history]
624 '("Next Matching Input..." . comint-next-matching-input))
625 (define-key comint-mode-map [menu-bar inout previous-matching-history]
626 '("Previous Matching Input..." . comint-previous-matching-input))
627 (define-key comint-mode-map [menu-bar inout next-matching-history-from-input]
628 '("Next Matching Current Input" . comint-next-matching-input-from-input))
629 (define-key comint-mode-map [menu-bar inout previous-matching-history-from-input]
630 '("Previous Matching Current Input" . comint-previous-matching-input-from-input))
631 (define-key comint-mode-map [menu-bar inout next-history]
632 '("Next Input" . comint-next-input))
633 (define-key comint-mode-map [menu-bar inout previous-history]
634 '("Previous Input" . comint-previous-input))
635 (define-key comint-mode-map [menu-bar inout list-history]
636 '("List Input History" . comint-dynamic-list-input-ring))
637 (define-key comint-mode-map [menu-bar inout expand-history]
638 '("Expand History Before Point" . comint-replace-by-expanded-history))
639 ;; Signals
640 (define-key comint-mode-map [menu-bar signals]
641 (cons "Signals" (make-sparse-keymap "Signals")))
642 (define-key comint-mode-map [menu-bar signals eof]
643 '("EOF" . comint-send-eof))
644 (define-key comint-mode-map [menu-bar signals kill]
645 '("KILL" . comint-kill-subjob))
646 (define-key comint-mode-map [menu-bar signals quit]
647 '("QUIT" . comint-quit-subjob))
648 (define-key comint-mode-map [menu-bar signals cont]
649 '("CONT" . comint-continue-subjob))
650 (define-key comint-mode-map [menu-bar signals stop]
651 '("STOP" . comint-stop-subjob))
652 (define-key comint-mode-map [menu-bar signals break]
653 '("BREAK" . comint-interrupt-subjob))
654 ;; Put them in the menu bar:
655 (setq menu-bar-final-items (append '(completion inout signals)
656 menu-bar-final-items))
657 )
658
659(defun comint-check-proc (buffer) 647(defun comint-check-proc (buffer)
660 "Return t if there is a living process associated w/buffer BUFFER. 648 "Return t if there is a living process associated w/buffer BUFFER.
661Living means the status is `open', `run', or `stop'. 649Living means the status is `open', `run', or `stop'.
@@ -798,9 +786,10 @@ buffer. The hook `comint-exec-hook' is run after each exec."
798 (set-process-coding-system proc decoding encoding)) 786 (set-process-coding-system proc decoding encoding))
799 proc)) 787 proc))
800 788
801(defun comint-insert-input () 789(defun comint-insert-input (&optional event)
802 "In a Comint buffer, set the current input to the previous input at point." 790 "In a Comint buffer, set the current input to the previous input at point."
803 (interactive) 791 (interactive (list last-input-event))
792 (if event (mouse-set-point event))
804 (let ((pos (point))) 793 (let ((pos (point)))
805 (if (not (eq (get-char-property pos 'field) 'input)) 794 (if (not (eq (get-char-property pos 'field) 'input))
806 ;; No input at POS, fall back to the global definition. 795 ;; No input at POS, fall back to the global definition.
@@ -818,13 +807,7 @@ buffer. The hook `comint-exec-hook' is run after each exec."
818 ;; Insert the input at point 807 ;; Insert the input at point
819 (insert (buffer-substring-no-properties 808 (insert (buffer-substring-no-properties
820 (previous-single-char-property-change (1+ pos) 'field) 809 (previous-single-char-property-change (1+ pos) 'field)
821 (next-single-char-property-change pos 'field)))))) 810 (next-single-char-property-change pos 'field))))))
822
823(defun comint-mouse-insert-input (event)
824 "In a Comint buffer, set the current input to the previous input you click on."
825 (interactive "e")
826 (mouse-set-point event)
827 (comint-insert-input))
828 811
829 812
830;; Input history processing in a buffer 813;; Input history processing in a buffer
@@ -1734,7 +1717,7 @@ Make backspaces delete the previous character."
1734 (1- prompt-start) prompt-start 'read-only 'fence)) 1717 (1- prompt-start) prompt-start 'read-only 'fence))
1735 (add-text-properties 1718 (add-text-properties
1736 prompt-start (point) 1719 prompt-start (point)
1737 '(read-only t rear-non-sticky t front-sticky (read-only)))) 1720 '(read-only t rear-nonsticky t front-sticky (read-only))))
1738 (unless (and (bolp) (null comint-last-prompt-overlay)) 1721 (unless (and (bolp) (null comint-last-prompt-overlay))
1739 ;; Need to create or move the prompt overlay (in the case 1722 ;; Need to create or move the prompt overlay (in the case
1740 ;; where there is no prompt ((bolp) == t), we still do 1723 ;; where there is no prompt ((bolp) == t), we still do
@@ -2136,8 +2119,8 @@ This command also kills the pending input
2136between the process mark and point. 2119between the process mark and point.
2137 2120
2138WARNING: if there is no current subjob, you can end up suspending 2121WARNING: if there is no current subjob, you can end up suspending
2139the top-level process running in the buffer. If you accidentally do 2122the top-level process running in the buffer. If you accidentally do
2140this, use \\[comint-continue-subjob] to resume the process. (This 2123this, use \\[comint-continue-subjob] to resume the process. (This
2141is not a problem with most shells, since they ignore this signal.)" 2124is not a problem with most shells, since they ignore this signal.)"
2142 (interactive) 2125 (interactive)
2143 (comint-skip-input) 2126 (comint-skip-input)
@@ -2357,9 +2340,9 @@ preceding newline is removed."
2357 2340
2358(defun comint-kill-whole-line (&optional arg) 2341(defun comint-kill-whole-line (&optional arg)
2359 "Kill current line, ignoring read-only and field properties. 2342 "Kill current line, ignoring read-only and field properties.
2360With prefix arg, kill that many lines starting from the current line. 2343With prefix ARG, kill that many lines starting from the current line.
2361If arg is negative, kill backward. Also kill the preceding newline, 2344If arg is negative, kill backward. Also kill the preceding newline,
2362instead of the trailing one. \(This is meant to make C-x z work well 2345instead of the trailing one. \(This is meant to make \\[repeat] work well
2363with negative arguments.) 2346with negative arguments.)
2364If arg is zero, kill current line but exclude the trailing newline. 2347If arg is zero, kill current line but exclude the trailing newline.
2365The read-only status of newlines is updated with `comint-update-fence', 2348The read-only status of newlines is updated with `comint-update-fence',
@@ -2505,7 +2488,7 @@ Provides a default, if there is one, and returns the result filename.
2505 2488
2506See `comint-source-default' for more on determining defaults. 2489See `comint-source-default' for more on determining defaults.
2507 2490
2508PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair 2491PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair
2509from the last source processing command. SOURCE-MODES is a list of major 2492from the last source processing command. SOURCE-MODES is a list of major
2510modes used to determine what file buffers contain source files. (These 2493modes used to determine what file buffers contain source files. (These
2511two arguments are used for determining defaults). If MUSTMATCH-P is true, 2494two arguments are used for determining defaults). If MUSTMATCH-P is true,
@@ -3503,5 +3486,5 @@ REGEXP-GROUP is the regular expression group in REGEXP to use."
3503 3486
3504(provide 'comint) 3487(provide 'comint)
3505 3488
3506;;; arch-tag: 1793314c-09db-40be-9549-9aeae3e75164 3489;; arch-tag: 1793314c-09db-40be-9549-9aeae3e75164
3507;;; comint.el ends here 3490;;; comint.el ends here
diff --git a/lisp/diff-mode.el b/lisp/diff-mode.el
index 0a7f1a1950a..c945a6a7221 100644
--- a/lisp/diff-mode.el
+++ b/lisp/diff-mode.el
@@ -1,6 +1,7 @@
1;;; diff-mode.el --- a mode for viewing/editing context diffs 1;;; diff-mode.el --- a mode for viewing/editing context diffs
2 2
3;; Copyright (C) 1998,1999,2000,01,02,03,2004 Free Software Foundation, Inc. 3;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
4;; Free Software Foundation, Inc.
4 5
5;; Author: Stefan Monnier <monnier@cs.yale.edu> 6;; Author: Stefan Monnier <monnier@cs.yale.edu>
6;; Keywords: convenience patch diff 7;; Keywords: convenience patch diff
@@ -171,75 +172,73 @@ when editing big diffs)."
171 172
172(defface diff-header-face 173(defface diff-header-face
173 '((((class color) (min-colors 88) (background light)) 174 '((((class color) (min-colors 88) (background light))
174 (:background "grey85")) 175 :background "grey85")
175 (((class color) (min-colors 88) (background dark)) 176 (((class color) (min-colors 88) (background dark))
176 (:background "grey45")) 177 :background "grey45")
177 (((class color) (background light)) 178 (((class color) (background light))
178 (:foreground "blue1" :weight bold)) 179 :foreground "blue1" :weight bold)
179 (((class color) (background dark)) 180 (((class color) (background dark))
180 (:foreground "green" :weight bold)) 181 :foreground "green" :weight bold)
181 (t (:weight bold))) 182 (t :weight bold))
182 "`diff-mode' face inherited by hunk and index header faces.") 183 "`diff-mode' face inherited by hunk and index header faces.")
183(defvar diff-header-face 'diff-header-face) 184(defvar diff-header-face 'diff-header-face)
184 185
185(defface diff-file-header-face 186(defface diff-file-header-face
186 '((((class color) (min-colors 88) (background light)) 187 '((((class color) (min-colors 88) (background light))
187 (:background "grey70" :weight bold)) 188 :background "grey70" :weight bold)
188 (((class color) (min-colors 88) (background dark)) 189 (((class color) (min-colors 88) (background dark))
189 (:background "grey60" :weight bold)) 190 :background "grey60" :weight bold)
190 (((class color) (background light)) 191 (((class color) (background light))
191 (:foreground "yellow" :weight bold)) 192 :foreground "yellow" :weight bold)
192 (((class color) (background dark)) 193 (((class color) (background dark))
193 (:foreground "cyan" :weight bold)) 194 :foreground "cyan" :weight bold)
194 (t (:weight bold))) ; :height 1.3 195 (t :weight bold)) ; :height 1.3
195 "`diff-mode' face used to highlight file header lines.") 196 "`diff-mode' face used to highlight file header lines.")
196(defvar diff-file-header-face 'diff-file-header-face) 197(defvar diff-file-header-face 'diff-file-header-face)
197 198
198(defface diff-index-face 199(defface diff-index-face
199 '((t (:inherit diff-file-header-face))) 200 '((t :inherit diff-file-header-face))
200 "`diff-mode' face used to highlight index header lines.") 201 "`diff-mode' face used to highlight index header lines.")
201(defvar diff-index-face 'diff-index-face) 202(defvar diff-index-face 'diff-index-face)
202 203
203(defface diff-hunk-header-face 204(defface diff-hunk-header-face
204 '((t (:inherit diff-header-face))) 205 '((t :inherit diff-header-face))
205 "`diff-mode' face used to highlight hunk header lines.") 206 "`diff-mode' face used to highlight hunk header lines.")
206(defvar diff-hunk-header-face 'diff-hunk-header-face) 207(defvar diff-hunk-header-face 'diff-hunk-header-face)
207 208
208(defface diff-removed-face 209(defface diff-removed-face
209 '((t (:inherit diff-changed-face))) 210 '((t :inherit diff-changed-face))
210 "`diff-mode' face used to highlight removed lines.") 211 "`diff-mode' face used to highlight removed lines.")
211(defvar diff-removed-face 'diff-removed-face) 212(defvar diff-removed-face 'diff-removed-face)
212 213
213(defface diff-added-face 214(defface diff-added-face
214 '((t (:inherit diff-changed-face))) 215 '((t :inherit diff-changed-face))
215 "`diff-mode' face used to highlight added lines.") 216 "`diff-mode' face used to highlight added lines.")
216(defvar diff-added-face 'diff-added-face) 217(defvar diff-added-face 'diff-added-face)
217 218
218(defface diff-changed-face 219(defface diff-changed-face
219 '((((type tty pc) (class color) (background light)) 220 '((((type tty pc) (class color) (background light))
220 (:foreground "magenta" :weight bold :slant italic)) 221 :foreground "magenta" :weight bold :slant italic)
221 (((type tty pc) (class color) (background dark)) 222 (((type tty pc) (class color) (background dark))
222 (:foreground "yellow" :weight bold :slant italic)) 223 :foreground "yellow" :weight bold :slant italic))
223 (t ()))
224 "`diff-mode' face used to highlight changed lines.") 224 "`diff-mode' face used to highlight changed lines.")
225(defvar diff-changed-face 'diff-changed-face) 225(defvar diff-changed-face 'diff-changed-face)
226 226
227(defface diff-function-face 227(defface diff-function-face
228 '((t (:inherit diff-context-face))) 228 '((t :inherit diff-context-face))
229 "`diff-mode' face used to highlight function names produced by \"diff -p\".") 229 "`diff-mode' face used to highlight function names produced by \"diff -p\".")
230(defvar diff-function-face 'diff-function-face) 230(defvar diff-function-face 'diff-function-face)
231 231
232(defface diff-context-face 232(defface diff-context-face
233 '((((class color) (background light)) 233 '((((class color) (background light))
234 (:foreground "grey50")) 234 :foreground "grey50")
235 (((class color) (background dark)) 235 (((class color) (background dark))
236 (:foreground "grey70")) 236 :foreground "grey70"))
237 (t ))
238 "`diff-mode' face used to highlight context and other side-information.") 237 "`diff-mode' face used to highlight context and other side-information.")
239(defvar diff-context-face 'diff-context-face) 238(defvar diff-context-face 'diff-context-face)
240 239
241(defface diff-nonexistent-face 240(defface diff-nonexistent-face
242 '((t (:inherit diff-file-header-face))) 241 '((t :inherit diff-file-header-face))
243 "`diff-mode' face used to highlight nonexistent files in recursive diffs.") 242 "`diff-mode' face used to highlight nonexistent files in recursive diffs.")
244(defvar diff-nonexistent-face 'diff-nonexistent-face) 243(defvar diff-nonexistent-face 'diff-nonexistent-face)
245 244
@@ -1255,7 +1254,7 @@ For use in `add-log-current-defun-function'."
1255 (save-excursion 1254 (save-excursion
1256 (when (looking-at diff-hunk-header-re) 1255 (when (looking-at diff-hunk-header-re)
1257 (forward-line 1) 1256 (forward-line 1)
1258 (while (and (looking-at " ") (not (zerop (forward-line 1)))))) 1257 (re-search-forward "^[^ ]" nil t))
1259 (destructuring-bind (buf line-offset pos src dst &optional switched) 1258 (destructuring-bind (buf line-offset pos src dst &optional switched)
1260 (diff-find-source-location) 1259 (diff-find-source-location)
1261 (beginning-of-line) 1260 (beginning-of-line)
@@ -1355,5 +1354,5 @@ For use in `add-log-current-defun-function'."
1355;; use `combine-after-change-calls' to minimize the slowdown of font-lock. 1354;; use `combine-after-change-calls' to minimize the slowdown of font-lock.
1356;; 1355;;
1357 1356
1358;;; arch-tag: 2571d7ff-bc28-4cf9-8585-42e21890be66 1357;; arch-tag: 2571d7ff-bc28-4cf9-8585-42e21890be66
1359;;; diff-mode.el ends here 1358;;; diff-mode.el ends here
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 825df2526c0..18913893642 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1152,7 +1152,7 @@ of FORM by signalling the error at compile-time."
1152 (numberp (nth 1 form))) 1152 (numberp (nth 1 form)))
1153 (list 'forward-word (eval (- (nth 1 form))))) 1153 (list 'forward-word (eval (- (nth 1 form)))))
1154 ((= 1 (safe-length form)) 1154 ((= 1 (safe-length form))
1155 '(forward-char -1)) 1155 '(forward-word -1))
1156 (t form))) 1156 (t form)))
1157 1157
1158(put 'char-before 'byte-optimizer 'byte-optimize-char-before) 1158(put 'char-before 'byte-optimizer 'byte-optimize-char-before)
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 700fc5f80a8..f4364c38e8d 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -1,6 +1,7 @@
1;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands 1;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands
2 2
3;; Copyright (C) 1985,86,1999,2000,01,03,2004 Free Software Foundation, Inc. 3;; Copyright (C) 1985, 1986, 1999, 2000, 2001, 2003, 2004
4;; Free Software Foundation, Inc.
4 5
5;; Maintainer: FSF 6;; Maintainer: FSF
6;; Keywords: lisp, languages 7;; Keywords: lisp, languages
@@ -1153,7 +1154,8 @@ paragraph of it that point is in, preserving the comment's indentation
1153and initial semicolons." 1154and initial semicolons."
1154 (interactive "P") 1155 (interactive "P")
1155 (or (fill-comment-paragraph justify) 1156 (or (fill-comment-paragraph justify)
1156 ;; Point is on a program line (a line no comment); we are interested 1157 ;; Since fill-comment-paragraph returned nil, that means we're not in
1158 ;; a comment: Point is on a program line; we are interested
1157 ;; particularly in docstring lines. 1159 ;; particularly in docstring lines.
1158 ;; 1160 ;;
1159 ;; We bind `paragraph-start' and `paragraph-separate' temporarily. They 1161 ;; We bind `paragraph-start' and `paragraph-separate' temporarily. They
@@ -1182,7 +1184,7 @@ and initial semicolons."
1182 ;; The `fill-column' is temporarily bound to 1184 ;; The `fill-column' is temporarily bound to
1183 ;; `emacs-lisp-docstring-fill-column' if that value is an integer. 1185 ;; `emacs-lisp-docstring-fill-column' if that value is an integer.
1184 (let ((paragraph-start (concat paragraph-start 1186 (let ((paragraph-start (concat paragraph-start
1185 "\\|\\s-*\\([\(;:\"]\\|`\(\\)")) 1187 "\\|\\s-*\\([(;:\"]\\|`(\\|#'(\\)"))
1186 (paragraph-separate 1188 (paragraph-separate
1187 (concat paragraph-separate "\\|\\s-*\".*[,\\.]$")) 1189 (concat paragraph-separate "\\|\\s-*\".*[,\\.]$"))
1188 (fill-column (if (integerp emacs-lisp-docstring-fill-column) 1190 (fill-column (if (integerp emacs-lisp-docstring-fill-column)
@@ -1227,5 +1229,5 @@ means don't indent that line."
1227 1229
1228(provide 'lisp-mode) 1230(provide 'lisp-mode)
1229 1231
1230;;; arch-tag: 414c7f93-c245-4b77-8ed5-ed05ef7ff1bf 1232;; arch-tag: 414c7f93-c245-4b77-8ed5-ed05ef7ff1bf
1231;;; lisp-mode.el ends here 1233;;; lisp-mode.el ends here
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 63d9f759ceb..87b3fcff96c 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -75,17 +75,19 @@ The place mark goes is the same place \\[forward-sexp] would
75move to with the same argument. 75move to with the same argument.
76If this command is repeated, it marks the next ARG sexps after the ones 76If this command is repeated, it marks the next ARG sexps after the ones
77already marked." 77already marked."
78 (interactive "p") 78 (interactive "P")
79 (cond ((and (eq last-command this-command) (mark t)) 79 (cond ((and (eq last-command this-command) (mark t))
80 (setq arg (if arg (prefix-numeric-value arg)
81 (if (> (mark) (point)) 1 -1)))
80 (set-mark 82 (set-mark
81 (save-excursion 83 (save-excursion
82 (goto-char (mark)) 84 (goto-char (mark))
83 (forward-sexp (or arg 1)) 85 (forward-sexp arg)
84 (point)))) 86 (point))))
85 (t 87 (t
86 (push-mark 88 (push-mark
87 (save-excursion 89 (save-excursion
88 (forward-sexp (or arg 1)) 90 (forward-sexp (prefix-numeric-value arg))
89 (point)) 91 (point))
90 nil t)))) 92 nil t))))
91 93
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index f5b68a3c243..2a2777d102b 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1324,6 +1324,12 @@ HIGHLIGHT should be of the form MATCH-HIGHLIGHT, see `font-lock-keywords'."
1324 (add-text-properties start end (cddr val)) 1324 (add-text-properties start end (cddr val))
1325 (setq val (cadr val))) 1325 (setq val (cadr val)))
1326 (cond 1326 (cond
1327 ((not (or val (eq override t)))
1328 ;; If `val' is nil, don't do anything. It is important to do it
1329 ;; explicitly, because when adding nil via things like
1330 ;; font-lock-append-text-property, the property is actually
1331 ;; changed from <face> to (<face>) which is undesirable. --Stef
1332 nil)
1327 ((not override) 1333 ((not override)
1328 ;; Cannot override existing fontification. 1334 ;; Cannot override existing fontification.
1329 (or (text-property-not-all start end 'face nil) 1335 (or (text-property-not-all start end 'face nil)
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 907ad5f3411..292d36ce9e1 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,55 @@
12004-10-13 Katsumi Yamaoka <yamaoka@jpl.org>
2
3 * message.el (message-tokenize-header): Fix 2004-09-06 change
4 which used point-min in the wrong place.
5
62004-10-12 Simon Josefsson <jas@extundo.com>
7
8 * net/tls.el (tls-certtool-program): New variable.
9 (tls-certificate-information): New function, based on
10 ssl-certificate-information.
11
122004-10-10 Reiner Steib <Reiner.Steib@gmx.de>
13
14 * gnus-sum.el: Mention that multibyte characters don't work as marks.
15
16 * gnus.el (message-y-or-n-p): Autoload.
17
18 * pop3.el (pop3-maildrop, pop3-mailhost, pop3-port)
19 (pop3-password-required, pop3-authentication-scheme)
20 (pop3-leave-mail-on-server): Made customizable.
21 (pop3): New custom group.
22 (pop3-retr): Remove `sleep-for' statements.
23 Suggested by Dave Love <fx@gnu.org>.
24
25 * nnheader.el (nnheader-read-timeout): Explain 1.0 timeout for
26 Windows/DOS.
27
28 * imap.el (imap-parse-flag-list, imap-parse-body-extension)
29 (imap-parse-body): Fix incorrect use of `assert'. Suggested by
30 Dave Love <fx@gnu.org>.
31
32 * mml.el (mml-minibuffer-read-disposition): Require match.
33 Suggested by Dave Love <fx@gnu.org>.
34
352004-10-06 Katsumi Yamaoka <yamaoka@jpl.org>
36
37 * gnus-group.el (gnus-update-group-mark-positions):
38 * gnus-sum.el (gnus-update-summary-mark-positions):
39 * message.el (message-check-news-body-syntax):
40 * gnus-msg.el (gnus-debug): Use mm-string-as-multibyte instead
41 of string-as-multibyte.
42
43 * gnus-sum.el (gnus-summary-insert-subject): Remove redundant setq.
44
452004-10-05 Juri Linkov <juri@jurta.org>
46
47 * gnus-group.el (gnus-update-group-mark-positions):
48 * gnus-sum.el (gnus-update-summary-mark-positions):
49 * message.el (message-check-news-body-syntax):
50 * gnus-msg.el (gnus-debug): Use `string-as-multibyte' to convert
51 8-bit unibyte values to a multibyte string for search functions.
52
12004-10-01 Katsumi Yamaoka <yamaoka@jpl.org> 532004-10-01 Katsumi Yamaoka <yamaoka@jpl.org>
2 54
3 * gnus-sum.el (gnus-summary-toggle-header): Make it work even if 55 * gnus-sum.el (gnus-summary-toggle-header): Make it work even if
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 9f7b259e066..435acb1d6c2 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -1046,7 +1046,8 @@ The following commands are available:
1046 (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) 1046 (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil)
1047 (goto-char (point-min)) 1047 (goto-char (point-min))
1048 (setq gnus-group-mark-positions 1048 (setq gnus-group-mark-positions
1049 (list (cons 'process (and (search-forward "\200" nil t) 1049 (list (cons 'process (and (search-forward
1050 (mm-string-as-multibyte "\200") nil t)
1050 (- (point) 2)))))))) 1051 (- (point) 2))))))))
1051 1052
1052(defun gnus-mouse-pick-group (e) 1053(defun gnus-mouse-pick-group (e)
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index 33531e7f8a4..7dcef4b813b 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1534,7 +1534,8 @@ The source file has to be in the Emacs load path."
1534 ;; Remove any control chars - they seem to cause trouble for some 1534 ;; Remove any control chars - they seem to cause trouble for some
1535 ;; mailers. (Byte-compiled output from the stuff above.) 1535 ;; mailers. (Byte-compiled output from the stuff above.)
1536 (goto-char point) 1536 (goto-char point)
1537 (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t) 1537 (while (re-search-forward (mm-string-as-multibyte
1538 "[\000-\010\013-\037\200-\237]") nil t)
1538 (replace-match (format "\\%03o" (string-to-char (match-string 0))) 1539 (replace-match (format "\\%03o" (string-to-char (match-string 0)))
1539 t t)))) 1540 t t))))
1540 1541
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 40278da4716..42c699ef552 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -428,6 +428,9 @@ this variable specifies group names."
428 (cons :value ("" "") regexp (repeat string)) 428 (cons :value ("" "") regexp (repeat string))
429 (sexp :value nil)))) 429 (sexp :value nil))))
430 430
431;; FIXME: Although the custom type is `character' for the following variables,
432;; using multibyte characters (Latin-1, UTF-8) doesn't work. -- rs
433
431(defcustom gnus-unread-mark ? ;Whitespace 434(defcustom gnus-unread-mark ? ;Whitespace
432 "*Mark used for unread articles." 435 "*Mark used for unread articles."
433 :group 'gnus-summary-marks 436 :group 'gnus-summary-marks
@@ -3231,20 +3234,24 @@ buffer that was in action when the last article was fetched."
3231 [0 "" "" "05 Apr 2001 23:33:09 +0400" "" "" 0 0 "" nil] 3234 [0 "" "" "05 Apr 2001 23:33:09 +0400" "" "" 0 0 "" nil]
3232 0 nil t 128 t nil "" nil 1) 3235 0 nil t 128 t nil "" nil 1)
3233 (goto-char (point-min)) 3236 (goto-char (point-min))
3234 (setq pos (list (cons 'unread (and (search-forward "\200" nil t) 3237 (setq pos (list (cons 'unread
3235 (- (point) (point-min) 1))))) 3238 (and (search-forward
3239 (mm-string-as-multibyte "\200") nil t)
3240 (- (point) (point-min) 1)))))
3236 (goto-char (point-min)) 3241 (goto-char (point-min))
3237 (push (cons 'replied (and (search-forward "\201" nil t) 3242 (push (cons 'replied (and (search-forward
3243 (mm-string-as-multibyte "\201") nil t)
3238 (- (point) (point-min) 1))) 3244 (- (point) (point-min) 1)))
3239 pos) 3245 pos)
3240 (goto-char (point-min)) 3246 (goto-char (point-min))
3241 (push (cons 'score (and (search-forward "\202" nil t) 3247 (push (cons 'score (and (search-forward
3248 (mm-string-as-multibyte "\202") nil t)
3242 (- (point) (point-min) 1))) 3249 (- (point) (point-min) 1)))
3243 pos) 3250 pos)
3244 (goto-char (point-min)) 3251 (goto-char (point-min))
3245 (push (cons 'download 3252 (push (cons 'download (and (search-forward
3246 (and (search-forward "\203" nil t) 3253 (mm-string-as-multibyte "\203") nil t)
3247 (- (point) (point-min) 1))) 3254 (- (point) (point-min) 1)))
3248 pos))) 3255 pos)))
3249 (setq gnus-summary-mark-positions pos)))) 3256 (setq gnus-summary-mark-positions pos))))
3250 3257
@@ -6009,8 +6016,7 @@ the subject line on."
6009 ;; Remove list identifiers from subject. 6016 ;; Remove list identifiers from subject.
6010 (when gnus-list-identifiers 6017 (when gnus-list-identifiers
6011 (let ((gnus-newsgroup-headers (list header))) 6018 (let ((gnus-newsgroup-headers (list header)))
6012 (gnus-summary-remove-list-identifiers) 6019 (gnus-summary-remove-list-identifiers)))
6013 (setq header (car gnus-newsgroup-headers))))
6014 (when old-header 6020 (when old-header
6015 (mail-header-set-number header (mail-header-number old-header))) 6021 (mail-header-set-number header (mail-header-number old-header)))
6016 (setq gnus-newsgroup-sparse 6022 (setq gnus-newsgroup-sparse
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 979ee2a7c24..bff1c3bba2f 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -34,6 +34,7 @@
34(require 'wid-edit) 34(require 'wid-edit)
35(require 'mm-util) 35(require 'mm-util)
36(require 'nnheader) 36(require 'nnheader)
37(autoload 'message-y-or-n-p "message" nil nil 'macro)
37 38
38(defgroup gnus nil 39(defgroup gnus nil
39 "The coffee-brewing, all singing, all dancing, kitchen sink newsreader." 40 "The coffee-brewing, all singing, all dancing, kitchen sink newsreader."
diff --git a/lisp/gnus/imap.el b/lisp/gnus/imap.el
index 754473fa8ec..326c998c5d9 100644
--- a/lisp/gnus/imap.el
+++ b/lisp/gnus/imap.el
@@ -2421,7 +2421,7 @@ Return nil if no complete line has arrived."
2421 2421
2422(defun imap-parse-flag-list () 2422(defun imap-parse-flag-list ()
2423 (let (flag-list start) 2423 (let (flag-list start)
2424 (assert (eq (char-after) ?\() t "In imap-parse-flag-list") 2424 (assert (eq (char-after) ?\() nil "In imap-parse-flag-list")
2425 (while (and (not (eq (char-after) ?\))) 2425 (while (and (not (eq (char-after) ?\)))
2426 (setq start (progn 2426 (setq start (progn
2427 (imap-forward) 2427 (imap-forward)
@@ -2430,7 +2430,7 @@ Return nil if no complete line has arrived."
2430 (point))) 2430 (point)))
2431 (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) 2431 (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
2432 (push (buffer-substring start (point)) flag-list)) 2432 (push (buffer-substring start (point)) flag-list))
2433 (assert (eq (char-after) ?\)) t "In imap-parse-flag-list") 2433 (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list")
2434 (imap-forward) 2434 (imap-forward)
2435 (nreverse flag-list))) 2435 (nreverse flag-list)))
2436 2436
@@ -2515,7 +2515,7 @@ Return nil if no complete line has arrived."
2515 (while (eq (char-after) ?\ ) 2515 (while (eq (char-after) ?\ )
2516 (imap-forward) 2516 (imap-forward)
2517 (push (imap-parse-body-extension) b-e)) 2517 (push (imap-parse-body-extension) b-e))
2518 (assert (eq (char-after) ?\)) t "In imap-parse-body-extension") 2518 (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
2519 (imap-forward) 2519 (imap-forward)
2520 (nreverse b-e)) 2520 (nreverse b-e))
2521 (or (imap-parse-number) 2521 (or (imap-parse-number)
@@ -2641,7 +2641,7 @@ Return nil if no complete line has arrived."
2641 (push (and (imap-parse-nil) nil) body)) 2641 (push (and (imap-parse-nil) nil) body))
2642 (setq body 2642 (setq body
2643 (append (imap-parse-body-ext) body))) ;; body-ext-... 2643 (append (imap-parse-body-ext) body))) ;; body-ext-...
2644 (assert (eq (char-after) ?\)) t "In imap-parse-body") 2644 (assert (eq (char-after) ?\)) nil "In imap-parse-body")
2645 (imap-forward) 2645 (imap-forward)
2646 (nreverse body)) 2646 (nreverse body))
2647 2647
@@ -2701,7 +2701,7 @@ Return nil if no complete line has arrived."
2701 (push (imap-parse-nstring) body) ;; body-fld-md5 2701 (push (imap-parse-nstring) body) ;; body-fld-md5
2702 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. 2702 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
2703 2703
2704 (assert (eq (char-after) ?\)) t "In imap-parse-body 2") 2704 (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
2705 (imap-forward) 2705 (imap-forward)
2706 (nreverse body))))) 2706 (nreverse body)))))
2707 2707
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 8e5edbc048a..c9d05d1a0fe 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -1615,11 +1615,11 @@ is used by default."
1615 (if (not header) 1615 (if (not header)
1616 nil 1616 nil
1617 (let ((regexp (format "[%s]+" (or separator ","))) 1617 (let ((regexp (format "[%s]+" (or separator ",")))
1618 (beg (point-min))
1619 (first t) 1618 (first t)
1620 quoted elems paren) 1619 beg quoted elems paren)
1621 (with-temp-buffer 1620 (with-temp-buffer
1622 (mm-enable-multibyte) 1621 (mm-enable-multibyte)
1622 (setq beg (point-min))
1623 (insert header) 1623 (insert header)
1624 (goto-char (point-min)) 1624 (goto-char (point-min))
1625 (while (not (eobp)) 1625 (while (not (eobp))
@@ -4399,7 +4399,9 @@ Otherwise, generate and save a value for `canlock-password' first."
4399 nil)))) 4399 nil))))
4400 ;; Check for control characters. 4400 ;; Check for control characters.
4401 (message-check 'control-chars 4401 (message-check 'control-chars
4402 (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t) 4402 (if (re-search-forward
4403 (mm-string-as-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]")
4404 nil t)
4403 (y-or-n-p 4405 (y-or-n-p
4404 "The article contains control characters. Really post? ") 4406 "The article contains control characters. Really post? ")
4405 t)) 4407 t))
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 1843cf2068d..221e1712611 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -945,8 +945,7 @@ See Info node `(emacs-mime)Composing'.
945 "attachment"))) 945 "attachment")))
946 (disposition (completing-read "Disposition: " 946 (disposition (completing-read "Disposition: "
947 '(("attachment") ("inline") ("")) 947 '(("attachment") ("inline") (""))
948 nil 948 nil t)))
949 nil)))
950 (if (not (equal disposition "")) 949 (if (not (equal disposition ""))
951 disposition 950 disposition
952 default))) 951 default)))
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 1b6ec636734..7df5ecae205 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -74,7 +74,15 @@ Integer values will in effect be rounded up to the nearest multiple of
74(defvar nnheader-read-timeout 74(defvar nnheader-read-timeout
75 (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin" 75 (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
76 (symbol-name system-type)) 76 (symbol-name system-type))
77 1.0 ; why? 77 ;; http://thread.gmane.org/v9655t3pjo.fsf@marauder.physik.uni-ulm.de
78 ;;
79 ;; IIRC, values lower than 1.0 didn't/don't work on Windows/DOS.
80 ;;
81 ;; There should probably be a runtime test to determine the timing
82 ;; resolution, or a primitive to report it. I don't know off-hand
83 ;; what's possible. Perhaps better, maybe the Windows/DOS primitive
84 ;; could round up non-zero timeouts to a minimum of 1.0?
85 1.0
78 0.1) 86 0.1)
79 "How long nntp should wait between checking for the end of output. 87 "How long nntp should wait between checking for the end of output.
80Shorter values mean quicker response, but are more CPU intensive.") 88Shorter values mean quicker response, but are more CPU intensive.")
diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el
index 567ab24e004..e288f6cace2 100644
--- a/lisp/gnus/pop3.el
+++ b/lisp/gnus/pop3.el
@@ -37,25 +37,56 @@
37 37
38(require 'mail-utils) 38(require 'mail-utils)
39 39
40(defvar pop3-maildrop (or (user-login-name) (getenv "LOGNAME") (getenv "USER") nil) 40(defgroup pop3 nil
41 "*POP3 maildrop.") 41 "Post Office Protocol"
42(defvar pop3-mailhost (or (getenv "MAILHOST") nil) 42 :group 'mail
43 "*POP3 mailhost.") 43 :group 'mail-source)
44(defvar pop3-port 110 44
45 "*POP3 port.") 45(defcustom pop3-maildrop (or (user-login-name)
46 46 (getenv "LOGNAME")
47(defvar pop3-password-required t 47 (getenv "USER"))
48 "*Non-nil if a password is required when connecting to POP server.") 48 "*POP3 maildrop."
49 :version "21.4" ;; Oort Gnus
50 :type 'string
51 :group 'pop3)
52
53(defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch
54 "pop3")
55 "*POP3 mailhost."
56 :version "21.4" ;; Oort Gnus
57 :type 'string
58 :group 'pop3)
59
60(defcustom pop3-port 110
61 "*POP3 port."
62 :version "21.4" ;; Oort Gnus
63 :type 'number
64 :group 'pop3)
65
66(defcustom pop3-password-required t
67 "*Non-nil if a password is required when connecting to POP server."
68 :version "21.4" ;; Oort Gnus
69 :type 'boolean
70 :group 'pop3)
71
72;; Should this be customizable?
49(defvar pop3-password nil 73(defvar pop3-password nil
50 "*Password to use when connecting to POP server.") 74 "*Password to use when connecting to POP server.")
51 75
52(defvar pop3-authentication-scheme 'pass 76(defcustom pop3-authentication-scheme 'pass
53 "*POP3 authentication scheme. 77 "*POP3 authentication scheme.
54Defaults to 'pass, for the standard USER/PASS authentication. Other valid 78Defaults to 'pass, for the standard USER/PASS authentication. Other valid
55values are 'apop.") 79values are 'apop."
56 80 :version "21.4" ;; Oort Gnus
57(defvar pop3-leave-mail-on-server nil 81 :type '(choice (const :tag "USER/PASS" pass)
58 "*Non-nil if the mail is to be left on the POP server after fetching.") 82 (const :tag "APOP" apop))
83 :group 'pop3)
84
85(defcustom pop3-leave-mail-on-server nil
86 "*Non-nil if the mail is to be left on the POP server after fetching."
87 :version "21.4" ;; Oort Gnus
88 :type 'boolean
89 :group 'pop3)
59 90
60(defvar pop3-timestamp nil 91(defvar pop3-timestamp nil
61 "Timestamp returned when initially connected to the POP server. 92 "Timestamp returned when initially connected to the POP server.
@@ -71,8 +102,7 @@ Used for APOP authentication.")
71 (crashbuf (get-buffer-create " *pop3-retr*")) 102 (crashbuf (get-buffer-create " *pop3-retr*"))
72 (n 1) 103 (n 1)
73 message-count 104 message-count
74 (pop3-password pop3-password) 105 (pop3-password pop3-password))
75 )
76 ;; for debugging only 106 ;; for debugging only
77 (if pop3-debug (switch-to-buffer (process-buffer process))) 107 (if pop3-debug (switch-to-buffer (process-buffer process)))
78 ;; query for password 108 ;; query for password
@@ -114,8 +144,7 @@ Used for APOP authentication.")
114 "Return the number of messages in the maildrop." 144 "Return the number of messages in the maildrop."
115 (let* ((process (pop3-open-server pop3-mailhost pop3-port)) 145 (let* ((process (pop3-open-server pop3-mailhost pop3-port))
116 message-count 146 message-count
117 (pop3-password pop3-password) 147 (pop3-password pop3-password))
118 )
119 ;; for debugging only 148 ;; for debugging only
120 (if pop3-debug (switch-to-buffer (process-buffer process))) 149 (if pop3-debug (switch-to-buffer (process-buffer process)))
121 ;; query for password 150 ;; query for password
@@ -159,15 +188,14 @@ Returns the process associated with the connection."
159 (insert output))) 188 (insert output)))
160 189
161(defun pop3-send-command (process command) 190(defun pop3-send-command (process command)
162 (set-buffer (process-buffer process)) 191 (set-buffer (process-buffer process))
163 (goto-char (point-max)) 192 (goto-char (point-max))
164;; (if (= (aref command 0) ?P) 193 ;; (if (= (aref command 0) ?P)
165;; (insert "PASS <omitted>\r\n") 194 ;; (insert "PASS <omitted>\r\n")
166;; (insert command "\r\n")) 195 ;; (insert command "\r\n"))
167 (setq pop3-read-point (point)) 196 (setq pop3-read-point (point))
168 (goto-char (point-max)) 197 (goto-char (point-max))
169 (process-send-string process (concat command "\r\n")) 198 (process-send-string process (concat command "\r\n")))
170 )
171 199
172(defun pop3-read-response (process &optional return) 200(defun pop3-read-response (process &optional return)
173 "Read the response from the server. 201 "Read the response from the server.
@@ -355,27 +383,15 @@ This function currently does nothing.")
355 (while (not (re-search-forward "^\\.\r\n" nil t)) 383 (while (not (re-search-forward "^\\.\r\n" nil t))
356 ;; Fixme: Shouldn't depend on nnheader. 384 ;; Fixme: Shouldn't depend on nnheader.
357 (nnheader-accept-process-output process) 385 (nnheader-accept-process-output process)
358 ;; bill@att.com ... to save wear and tear on the heap
359 ;; uncommented because the condensed version below is a problem for
360 ;; some.
361 (if (> (buffer-size) 20000) (sleep-for 1))
362 (if (> (buffer-size) 50000) (sleep-for 1))
363 (if (> (buffer-size) 100000) (sleep-for 1))
364 (if (> (buffer-size) 200000) (sleep-for 1))
365 (if (> (buffer-size) 500000) (sleep-for 1))
366 ;; bill@att.com
367 ;; condensed into:
368 ;; (sometimes causes problems for really large messages.)
369; (if (> (buffer-size) 20000) (sleep-for (/ (buffer-size) 20000)))
370 (goto-char start)) 386 (goto-char start))
371 (setq pop3-read-point (point-marker)) 387 (setq pop3-read-point (point-marker))
372;; this code does not seem to work for some POP servers... 388 ;; this code does not seem to work for some POP servers...
373;; and I cannot figure out why not. 389 ;; and I cannot figure out why not.
374; (goto-char (match-beginning 0)) 390 ;; (goto-char (match-beginning 0))
375; (backward-char 2) 391 ;; (backward-char 2)
376; (if (not (looking-at "\r\n")) 392 ;; (if (not (looking-at "\r\n"))
377; (insert "\r\n")) 393 ;; (insert "\r\n"))
378; (re-search-forward "\\.\r\n") 394 ;; (re-search-forward "\\.\r\n")
379 (goto-char (match-beginning 0)) 395 (goto-char (match-beginning 0))
380 (setq end (point-marker)) 396 (setq end (point-marker))
381 (pop3-clean-region start end) 397 (pop3-clean-region start end)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index d193ad344f5..57b0b39767e 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -552,9 +552,15 @@ it is displayed along with the global value."
552 (forward-line 1) 552 (forward-line 1)
553 (forward-sexp 1) 553 (forward-sexp 1)
554 (delete-region (point) (progn (end-of-line) (point))) 554 (delete-region (point) (progn (end-of-line) (point)))
555 (insert " value is shown below.\n\n")
556 (save-excursion 555 (save-excursion
557 (insert "\n\nValue:")))) 556 (insert "\n\nValue:")
557 (set (make-local-variable 'help-button-cache)
558 (point-marker)))
559 (insert " value is shown ")
560 (insert-button "below"
561 'action help-button-cache
562 'help-echo "mouse-2, RET: show value")
563 (insert ".\n\n")))
558 ;; Add a note for variables that have been make-var-buffer-local. 564 ;; Add a note for variables that have been make-var-buffer-local.
559 (when (and (local-variable-if-set-p variable) 565 (when (and (local-variable-if-set-p variable)
560 (or (not (local-variable-p variable)) 566 (or (not (local-variable-p variable))
diff --git a/lisp/help.el b/lisp/help.el
index bf0df4358a7..5a2867bdc18 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -111,6 +111,9 @@
111 111
112(define-key help-map "q" 'help-quit) 112(define-key help-map "q" 'help-quit)
113 113
114;; insert-button makes the action nil if it is not store somewhere
115(defvar help-button-cache nil)
116
114 117
115(defun help-quit () 118(defun help-quit ()
116 "Just exit from the Help command's command loop." 119 "Just exit from the Help command's command loop."
@@ -655,32 +658,42 @@ whose documentation describes the minor mode."
655 (lambda (a b) (string-lessp (car a) (car b))))) 658 (lambda (a b) (string-lessp (car a) (car b)))))
656 (when minor-modes 659 (when minor-modes
657 (princ "Summary of minor modes:\n") 660 (princ "Summary of minor modes:\n")
658 (dolist (mode minor-modes) 661 (make-local-variable 'help-button-cache)
659 (let ((pretty-minor-mode (nth 0 mode)) 662 (with-current-buffer standard-output
660 (indicator (nth 2 mode))) 663 (dolist (mode minor-modes)
661 (princ (format " %s minor mode (%s):\n" 664 (let ((pretty-minor-mode (nth 0 mode))
662 pretty-minor-mode 665 (mode-function (nth 1 mode))
663 (if indicator 666 (indicator (nth 2 mode)))
664 (format "indicator%s" indicator) 667 (add-text-properties 0 (length pretty-minor-mode)
665 "no indicator"))))) 668 '(face bold) pretty-minor-mode)
669 (save-excursion
670 (goto-char (point-max))
671 (princ "\n\f\n")
672 (push (point-marker) help-button-cache)
673 ;; Document the minor modes fully.
674 (insert pretty-minor-mode)
675 (princ (format " minor mode (%s):\n"
676 (if indicator
677 (format "indicator%s" indicator)
678 "no indicator")))
679 (princ (documentation mode-function)))
680 (princ " ")
681 (insert-button pretty-minor-mode
682 'action (car help-button-cache)
683 'help-echo "mouse-2, RET: show full information")
684 (princ (format " minor mode (%s):\n"
685 (if indicator
686 (format "indicator%s" indicator)
687 "no indicator"))))))
666 (princ "\n(Full information about these minor modes 688 (princ "\n(Full information about these minor modes
667follows the description of the major mode.)\n\n")) 689follows the description of the major mode.)\n\n"))
668 ;; Document the major mode. 690 ;; Document the major mode.
669 (princ mode-name) 691 (let ((mode mode-name))
692 (with-current-buffer standard-output
693 (insert mode)
694 (add-text-properties (- (point) (length mode)) (point) '(face bold))))
670 (princ " mode:\n") 695 (princ " mode:\n")
671 (princ (documentation major-mode)) 696 (princ (documentation major-mode)))
672 ;; Document the minor modes fully.
673 (dolist (mode minor-modes)
674 (let ((pretty-minor-mode (nth 0 mode))
675 (mode-function (nth 1 mode))
676 (indicator (nth 2 mode)))
677 (princ "\n\f\n")
678 (princ (format "%s minor mode (%s):\n"
679 pretty-minor-mode
680 (if indicator
681 (format "indicator%s" indicator)
682 "no indicator")))
683 (princ (documentation mode-function)))))
684 (print-help-return-message)))) 697 (print-help-return-message))))
685 698
686 699
diff --git a/lisp/imenu.el b/lisp/imenu.el
index 1c82fcacf34..6859c0c74c7 100644
--- a/lisp/imenu.el
+++ b/lisp/imenu.el
@@ -317,9 +317,12 @@ The function in this variable is called when selecting a normal index-item.")
317;;;; 317;;;;
318;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 318;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319 319
320;; Return the current/previous sexp and the location of the sexp (its 320;; FIXME: This is the only imenu-example-* definition that's actually used,
321;; beginning) without moving the point. 321;; and it seems to only be used by cperl-mode.el. We should just move it to
322;; cperl-mode.el and remove the rest.
322(defun imenu-example--name-and-position () 323(defun imenu-example--name-and-position ()
324 "Return the current/previous sexp and its (beginning) location.
325Don't move point."
323 (save-excursion 326 (save-excursion
324 (forward-sexp -1) 327 (forward-sexp -1)
325 ;; [ydi] modified for imenu-use-markers 328 ;; [ydi] modified for imenu-use-markers
@@ -549,12 +552,10 @@ A nested sub-alist element looks like (INDEX-NAME SUB-ALIST).")
549 (cond 552 (cond
550 ((consp (cdr item)) 553 ((consp (cdr item))
551 (imenu--truncate-items (cdr item))) 554 (imenu--truncate-items (cdr item)))
552 (t 555 ;; truncate if necessary
553 ;; truncate if necessary 556 ((and (numberp imenu-max-item-length)
554 (if (and (numberp imenu-max-item-length) 557 (> (length (car item)) imenu-max-item-length))
555 (> (length (car item)) imenu-max-item-length)) 558 (setcar item (substring (car item) 0 imenu-max-item-length))))))
556 (setcar item (substring (car item) 0
557 imenu-max-item-length)))))))
558 menulist)) 559 menulist))
559 560
560 561
@@ -854,7 +855,7 @@ depending on PATTERNS."
854(defun imenu--completion-buffer (index-alist &optional prompt) 855(defun imenu--completion-buffer (index-alist &optional prompt)
855 "Let the user select from INDEX-ALIST in a completion buffer with PROMPT. 856 "Let the user select from INDEX-ALIST in a completion buffer with PROMPT.
856 857
857Returns t for rescan and otherwise a position number." 858Return one of the entries in index-alist or nil."
858 ;; Create a list for this buffer only when needed. 859 ;; Create a list for this buffer only when needed.
859 (let ((name (thing-at-point 'symbol)) 860 (let ((name (thing-at-point 'symbol))
860 choice 861 choice
@@ -880,13 +881,11 @@ Returns t for rescan and otherwise a position number."
880 prepared-index-alist 881 prepared-index-alist
881 nil t nil 'imenu--history-list name))) 882 nil t nil 'imenu--history-list name)))
882 883
883 (cond ((not (stringp name)) nil) 884 (when (stringp name)
884 ((string= name (car imenu--rescan-item)) t) 885 (setq choice (assoc name prepared-index-alist))
885 (t 886 (if (imenu--subalist-p choice)
886 (setq choice (assoc name prepared-index-alist)) 887 (imenu--completion-buffer (cdr choice) prompt)
887 (if (imenu--subalist-p choice) 888 choice))))
888 (imenu--completion-buffer (cdr choice) prompt)
889 choice)))))
890 889
891(defun imenu--mouse-menu (index-alist event &optional title) 890(defun imenu--mouse-menu (index-alist event &optional title)
892 "Let the user select from a buffer index from a mouse menu. 891 "Let the user select from a buffer index from a mouse menu.
@@ -937,9 +936,9 @@ The returned value is of the form (INDEX-NAME . INDEX-POSITION)."
937 (or (eq imenu-use-popup-menu t) mouse-triggered)) 936 (or (eq imenu-use-popup-menu t) mouse-triggered))
938 (imenu--mouse-menu index-alist last-nonmenu-event) 937 (imenu--mouse-menu index-alist last-nonmenu-event)
939 (imenu--completion-buffer index-alist prompt))) 938 (imenu--completion-buffer index-alist prompt)))
940 (and (eq result t) 939 (and (equal result imenu--rescan-item)
941 (imenu--cleanup) 940 (imenu--cleanup)
942 (setq imenu--index-alist nil))) 941 (setq result t imenu--index-alist nil)))
943 result)) 942 result))
944 943
945;;;###autoload 944;;;###autoload
@@ -1014,7 +1013,7 @@ A trivial interface to `imenu-add-to-menubar' suitable for use in a hook."
1014 nil)) 1013 nil))
1015 1014
1016(defun imenu-default-goto-function (name position &optional rest) 1015(defun imenu-default-goto-function (name position &optional rest)
1017 "Move the point to the given position. 1016 "Move to the given position.
1018 1017
1019NAME is ignored. POSITION is where to move. REST is also ignored. 1018NAME is ignored. POSITION is where to move. REST is also ignored.
1020The ignored args just make this function have the same interface as a 1019The ignored args just make this function have the same interface as a
@@ -1054,5 +1053,5 @@ for more information."
1054 1053
1055(provide 'imenu) 1054(provide 'imenu)
1056 1055
1057;;; arch-tag: 98a2f5f5-4b91-4704-b18c-3aacf77d77a7 1056;; arch-tag: 98a2f5f5-4b91-4704-b18c-3aacf77d77a7
1058;;; imenu.el ends here 1057;;; imenu.el ends here
diff --git a/lisp/info-look.el b/lisp/info-look.el
index 644ee3d6c20..3f3ea7c2fd4 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -245,6 +245,7 @@ system."
245 (interactive) 245 (interactive)
246 (setq info-lookup-cache nil)) 246 (setq info-lookup-cache nil))
247 247
248;;;###autoload (put 'info-lookup-symbol 'info-file "emacs")
248;;;###autoload 249;;;###autoload
249(defun info-lookup-symbol (symbol &optional mode) 250(defun info-lookup-symbol (symbol &optional mode)
250 "Display the definition of SYMBOL, as found in the relevant manual. 251 "Display the definition of SYMBOL, as found in the relevant manual.
@@ -258,6 +259,7 @@ With prefix arg a query for the symbol help mode is offered."
258 (info-lookup-interactive-arguments 'symbol current-prefix-arg)) 259 (info-lookup-interactive-arguments 'symbol current-prefix-arg))
259 (info-lookup 'symbol symbol mode)) 260 (info-lookup 'symbol symbol mode))
260 261
262;;;###autoload (put 'info-lookup-file 'info-file "emacs")
261;;;###autoload 263;;;###autoload
262(defun info-lookup-file (file &optional mode) 264(defun info-lookup-file (file &optional mode)
263 "Display the documentation of a file. 265 "Display the documentation of a file.
diff --git a/lisp/info.el b/lisp/info.el
index b779bb41ca6..386f5b612ec 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -79,8 +79,8 @@ The Lisp code is executed when the node is selected.")
79 :group 'info) 79 :group 'info)
80 80
81(defface info-xref 81(defface info-xref
82 '((((class color) (background light)) :foreground "blue") 82 '((((class color) (background light)) :foreground "blue" :underline t)
83 (((class color) (background dark)) :foreground "cyan") 83 (((class color) (background dark)) :foreground "cyan" :underline t)
84 (t :underline t)) 84 (t :underline t))
85 "Face for Info cross-references." 85 "Face for Info cross-references."
86 :group 'info) 86 :group 'info)
@@ -455,6 +455,7 @@ Do the right thing if the file has been compressed or zipped."
455 455
456;;;###autoload (add-hook 'same-window-regexps "\\*info\\*\\(\\|<[0-9]+>\\)") 456;;;###autoload (add-hook 'same-window-regexps "\\*info\\*\\(\\|<[0-9]+>\\)")
457 457
458;;;###autoload (put 'info 'info-file "emacs")
458;;;###autoload 459;;;###autoload
459(defun info (&optional file buffer) 460(defun info (&optional file buffer)
460 "Enter Info, the documentation browser. 461 "Enter Info, the documentation browser.
@@ -1729,7 +1730,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
1729 (let ((inhibit-read-only t)) 1730 (let ((inhibit-read-only t))
1730 (erase-buffer) 1731 (erase-buffer)
1731 (goto-char (point-min)) 1732 (goto-char (point-min))
1732 (insert "\n\^_\nFile: history Node: Top, Up: (dir)\n\n") 1733 (insert "\n\^_\nFile: history, Node: Top, Up: (dir)\n\n")
1733 (insert "Recently Visited Nodes\n**********************\n\n") 1734 (insert "Recently Visited Nodes\n**********************\n\n")
1734 (insert "* Menu:\n\n") 1735 (insert "* Menu:\n\n")
1735 (let ((hl (delete '("history" "Top") Info-history-list))) 1736 (let ((hl (delete '("history" "Top") Info-history-list)))
@@ -1749,26 +1750,31 @@ If SAME-FILE is non-nil, do not move to a different Info file."
1749 "Go to a node with table of contents of the current Info file. 1750 "Go to a node with table of contents of the current Info file.
1750Table of contents is created from the tree structure of menus." 1751Table of contents is created from the tree structure of menus."
1751 (interactive) 1752 (interactive)
1752 (let ((curr-file Info-current-file) 1753 (let ((curr-file (substring-no-properties Info-current-file))
1753 (curr-node Info-current-node) 1754 (curr-node (substring-no-properties Info-current-node))
1754 p) 1755 p)
1755 (with-current-buffer (get-buffer-create " *info-toc*") 1756 (with-current-buffer (get-buffer-create " *info-toc*")
1756 (let ((inhibit-read-only t) 1757 (let ((inhibit-read-only t)
1757 (node-list (Info-build-toc curr-file))) 1758 (node-list (Info-build-toc curr-file)))
1758 (erase-buffer) 1759 (erase-buffer)
1759 (goto-char (point-min)) 1760 (goto-char (point-min))
1760 (insert "\n\^_\nFile: toc Node: Top, Up: (dir)\n\n") 1761 (insert "\n\^_\nFile: toc, Node: Top, Up: (dir)\n\n")
1761 (insert "Table of Contents\n*****************\n\n") 1762 (insert "Table of Contents\n*****************\n\n")
1762 (insert "*Note Top::\n") 1763 (insert "*Note Top: (" curr-file ")Top.\n")
1763 (Info-insert-toc 1764 (Info-insert-toc
1764 (nth 2 (assoc "Top" node-list)) ; get Top nodes 1765 (nth 2 (assoc "Top" node-list)) ; get Top nodes
1765 node-list 0 (substring-no-properties curr-file))) 1766 node-list 0 curr-file))
1766 (if (not (bobp)) 1767 (if (not (bobp))
1767 (let ((Info-hide-note-references 'hide) 1768 (let ((Info-hide-note-references 'hide)
1768 (Info-fontify-visited-nodes nil)) 1769 (Info-fontify-visited-nodes nil))
1769 (Info-mode) 1770 (Info-mode)
1770 (setq Info-current-file "toc" Info-current-node "Top") 1771 (setq Info-current-file "toc" Info-current-node "Top")
1771 (Info-fontify-node))) 1772 (goto-char (point-min))
1773 (narrow-to-region (or (re-search-forward "\n[\^_\f]\n" nil t)
1774 (point-min))
1775 (point-max))
1776 (Info-fontify-node)
1777 (widen)))
1772 (goto-char (point-min)) 1778 (goto-char (point-min))
1773 (if (setq p (search-forward (concat "*Note " curr-node ":") nil t)) 1779 (if (setq p (search-forward (concat "*Note " curr-node ":") nil t))
1774 (setq p (- p (length curr-node) 2)))) 1780 (setq p (- p (length curr-node) 2))))
@@ -1789,14 +1795,12 @@ Table of contents is created from the tree structure of menus."
1789 1795
1790(defun Info-build-toc (file) 1796(defun Info-build-toc (file)
1791 "Build table of contents from menus of Info FILE and its subfiles." 1797 "Build table of contents from menus of Info FILE and its subfiles."
1792 (if (equal file "dir")
1793 (error "Table of contents for Info directory is not supported yet"))
1794 (with-temp-buffer 1798 (with-temp-buffer
1795 (let* ((default-directory (or (and (stringp file) 1799 (let* ((file (and (stringp file) (Info-find-file file)))
1796 (file-name-directory 1800 (default-directory (or (and (stringp file)
1797 (setq file (Info-find-file file)))) 1801 (file-name-directory file))
1798 default-directory)) 1802 default-directory))
1799 (main-file file) 1803 (main-file (and (stringp file) file))
1800 (sections '(("Top" "Top"))) 1804 (sections '(("Top" "Top")))
1801 nodes subfiles) 1805 nodes subfiles)
1802 (while (or main-file subfiles) 1806 (while (or main-file subfiles)
@@ -3258,6 +3262,7 @@ The locations are of the format used in `Info-history', i.e.
3258 (car elt) 3262 (car elt)
3259 elt)) 3263 elt))
3260 (file (if (consp elt) (cdr elt) elt)) 3264 (file (if (consp elt) (cdr elt) elt))
3265 (case-fold-search nil)
3261 (regexp (concat "\\`" (regexp-quote name) 3266 (regexp (concat "\\`" (regexp-quote name)
3262 "\\(\\'\\|-\\)"))) 3267 "\\(\\'\\|-\\)")))
3263 (if (string-match regexp (symbol-name command)) 3268 (if (string-match regexp (symbol-name command))
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 6fc3477fd34..2199420fd3c 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -870,6 +870,18 @@ like `mime-charset' as well as the current style like `:mime-charset'."
870 (and (not (> (downcase c1) (downcase c2))) 870 (and (not (> (downcase c1) (downcase c2)))
871 (< c1 c2))))))) 871 (< c1 c2)))))))
872 872
873(defun coding-system-equal (coding-system-1 coding-system-2)
874 "Return t if and only if CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
875Two coding systems are identical if two symbols are equal
876or one is an alias of the other."
877 (or (eq coding-system-1 coding-system-2)
878 (and (equal (coding-system-spec coding-system-1)
879 (coding-system-spec coding-system-2))
880 (let ((eol-type-1 (coding-system-eol-type coding-system-1))
881 (eol-type-2 (coding-system-eol-type coding-system-2)))
882 (or (eq eol-type-1 eol-type-2)
883 (and (vectorp eol-type-1) (vectorp eol-type-2)))))))
884
873(defun add-to-coding-system-list (coding-system) 885(defun add-to-coding-system-list (coding-system)
874 "Add CODING-SYSTEM to `coding-system-list' while keeping it sorted." 886 "Add CODING-SYSTEM to `coding-system-list' while keeping it sorted."
875 (if (or (null coding-system-list) 887 (if (or (null coding-system-list)
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 1e8e0f6586e..0d1d7e32cde 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -676,16 +676,7 @@ is treated as a regexp. See \\[isearch-forward] for more info."
676 (if isearch-small-window 676 (if isearch-small-window
677 (goto-char found-point) 677 (goto-char found-point)
678 ;; Exiting the save-window-excursion clobbers window-start; restore it. 678 ;; Exiting the save-window-excursion clobbers window-start; restore it.
679 (set-window-start (selected-window) found-start t)) 679 (set-window-start (selected-window) found-start t)))
680
681 ;; If there was movement, mark the starting position.
682 ;; Maybe should test difference between and set mark iff > threshold.
683 (if (/= (point) isearch-opoint)
684 (or (and transient-mark-mode mark-active)
685 (progn
686 (push-mark isearch-opoint t)
687 (or executing-kbd-macro (> (minibuffer-depth) 0)
688 (message "Mark saved where search started"))))))
689 680
690 (setq isearch-mode nil) 681 (setq isearch-mode nil)
691 (if isearch-input-method-local-p 682 (if isearch-input-method-local-p
@@ -710,6 +701,16 @@ is treated as a regexp. See \\[isearch-forward] for more info."
710 (isearch-update-ring isearch-string isearch-regexp)) 701 (isearch-update-ring isearch-string isearch-regexp))
711 702
712 (run-hooks 'isearch-mode-end-hook) 703 (run-hooks 'isearch-mode-end-hook)
704
705 ;; If there was movement, mark the starting position.
706 ;; Maybe should test difference between and set mark iff > threshold.
707 (if (/= (point) isearch-opoint)
708 (or (and transient-mark-mode mark-active)
709 (progn
710 (push-mark isearch-opoint t)
711 (or executing-kbd-macro (> (minibuffer-depth) 0)
712 (message "Mark saved where search started")))))
713
713 (and (not edit) isearch-recursive-edit (exit-recursive-edit))) 714 (and (not edit) isearch-recursive-edit (exit-recursive-edit)))
714 715
715(defun isearch-update-ring (string &optional regexp) 716(defun isearch-update-ring (string &optional regexp)
@@ -1249,8 +1250,8 @@ might return the position of the end of the line."
1249(defun isearch-yank-line () 1250(defun isearch-yank-line ()
1250 "Pull rest of line from buffer into search string." 1251 "Pull rest of line from buffer into search string."
1251 (interactive) 1252 (interactive)
1252 (isearch-yank-internal 'line-end-position)) 1253 (isearch-yank-internal
1253 1254 (lambda () (line-end-position (if (eolp) 2 1)))))
1254 1255
1255(defun isearch-search-and-update () 1256(defun isearch-search-and-update ()
1256 ;; Do the search and update the display. 1257 ;; Do the search and update the display.
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index b2226d4a895..2b4cbcaf323 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -248,7 +248,9 @@ macro to be executed before appending to it."
248 "Insert macro counter and increment with ARG or 1 if missing. 248 "Insert macro counter and increment with ARG or 1 if missing.
249With \\[universal-argument], insert previous kmacro-counter (but do not modify counter)." 249With \\[universal-argument], insert previous kmacro-counter (but do not modify counter)."
250 (interactive "P") 250 (interactive "P")
251 (setq kmacro-initial-counter-value nil) 251 (if kmacro-initial-counter-value
252 (setq kmacro-counter kmacro-initial-counter-value
253 kmacro-initial-counter-value nil))
252 (if (and arg (listp arg)) 254 (if (and arg (listp arg))
253 (insert (format kmacro-counter-format kmacro-last-counter)) 255 (insert (format kmacro-counter-format kmacro-last-counter))
254 (insert (format kmacro-counter-format kmacro-counter)) 256 (insert (format kmacro-counter-format kmacro-counter))
@@ -275,23 +277,23 @@ With \\[universal-argument], insert previous kmacro-counter (but do not modify c
275 "Set kmacro-counter to ARG or prompt if missing. 277 "Set kmacro-counter to ARG or prompt if missing.
276With \\[universal-argument] prefix, reset counter to its value prior to this iteration of the macro." 278With \\[universal-argument] prefix, reset counter to its value prior to this iteration of the macro."
277 (interactive "NMacro counter value: ") 279 (interactive "NMacro counter value: ")
278 (setq kmacro-last-counter kmacro-counter 280 (if (not (or defining-kbd-macro executing-kbd-macro))
279 kmacro-counter (if (and current-prefix-arg (listp current-prefix-arg)) 281 (kmacro-display-counter (setq kmacro-initial-counter-value arg))
280 kmacro-counter-value-start 282 (setq kmacro-last-counter kmacro-counter
281 arg)) 283 kmacro-counter (if (and current-prefix-arg (listp current-prefix-arg))
282 ;; setup initial macro counter value if we are not executing a macro. 284 kmacro-counter-value-start
283 (setq kmacro-initial-counter-value 285 arg))
284 (and (not (or defining-kbd-macro executing-kbd-macro)) 286 (unless executing-kbd-macro
285 kmacro-counter)) 287 (kmacro-display-counter))))
286 (unless executing-kbd-macro
287 (kmacro-display-counter)))
288 288
289 289
290(defun kmacro-add-counter (arg) 290(defun kmacro-add-counter (arg)
291 "Add numeric prefix arg (prompt if missing) to macro counter. 291 "Add numeric prefix arg (prompt if missing) to macro counter.
292With \\[universal-argument], restore previous counter value." 292With \\[universal-argument], restore previous counter value."
293 (interactive "NAdd to macro counter: ") 293 (interactive "NAdd to macro counter: ")
294 (setq kmacro-initial-counter-value nil) 294 (if kmacro-initial-counter-value
295 (setq kmacro-counter kmacro-initial-counter-value
296 kmacro-initial-counter-value nil))
295 (let ((last kmacro-last-counter)) 297 (let ((last kmacro-last-counter))
296 (setq kmacro-last-counter kmacro-counter 298 (setq kmacro-last-counter kmacro-counter
297 kmacro-counter (if (and current-prefix-arg (listp current-prefix-arg)) 299 kmacro-counter (if (and current-prefix-arg (listp current-prefix-arg))
@@ -394,7 +396,10 @@ Optional arg EMPTY is message to print if no macros are defined."
394 (m (format-kbd-macro macro)) 396 (m (format-kbd-macro macro))
395 (l (length m)) 397 (l (length m))
396 (z (and nil trunc (> l x)))) 398 (z (and nil trunc (> l x))))
397 (message (format "%s: %s%s" (or descr "Macro") 399 (message (format "%s%s: %s%s" (or descr "Macro")
400 (if (= kmacro-counter 0) ""
401 (format " [%s]"
402 (format kmacro-counter-format-start kmacro-counter)))
398 (if z (substring m 0 (1- x)) m) (if z "..." "")))) 403 (if z (substring m 0 (1- x)) m) (if z "..." ""))))
399 (message (or empty "No keyboard macros defined")))) 404 (message (or empty "No keyboard macros defined"))))
400 405
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 675444d7ba4..b7521ad8e91 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -234,6 +234,13 @@ we will act as though we couldn't find a full name in the address."
234 :version "21.4" 234 :version "21.4"
235 :group 'mail-extr) 235 :group 'mail-extr)
236 236
237(defcustom mail-extr-ignore-realname-equals-mailbox-name t
238"*Whether to ignore a name that is equal to the mailbox name.
239If true, then when the address is like \"Single <single@address.com>\"
240we will act as though we couldn't find a full name in the address."
241 :type 'boolean
242 :group 'mail-extr)
243
237;; Matches a leading title that is not part of the name (does not 244;; Matches a leading title that is not part of the name (does not
238;; contribute to uniquely identifying the person). 245;; contribute to uniquely identifying the person).
239(defcustom mail-extr-full-name-prefixes 246(defcustom mail-extr-full-name-prefixes
@@ -694,7 +701,7 @@ Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL
694 "Given an RFC-822 address ADDRESS, extract full name and canonical address. 701 "Given an RFC-822 address ADDRESS, extract full name and canonical address.
695Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). 702Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
696If no name can be extracted, FULL-NAME will be nil. Also see 703If no name can be extracted, FULL-NAME will be nil. Also see
697`mail-extr-ignore-single-names'. 704`mail-extr-ignore-single-names' and `mail-extr-ignore-realname-equals-mailbox-name'.
698 705
699If the optional argument ALL is non-nil, then ADDRESS can contain zero 706If the optional argument ALL is non-nil, then ADDRESS can contain zero
700or more recipients, separated by commas, and we return a list of 707or more recipients, separated by commas, and we return a list of
@@ -1404,8 +1411,9 @@ consing a string.)"
1404 (setq names-match-flag nil)) 1411 (setq names-match-flag nil))
1405 (setq i (1+ i))) 1412 (setq i (1+ i)))
1406 (delete-region (+ (point-min) buffer-length) (point-max)) 1413 (delete-region (+ (point-min) buffer-length) (point-max))
1407 (if names-match-flag 1414 (and names-match-flag
1408 (narrow-to-region (point) (point))))) 1415 mail-extr-ignore-realname-equals-mailbox-name
1416 (narrow-to-region (point) (point)))))
1409 1417
1410 ;; Nuke name if it's just one word. 1418 ;; Nuke name if it's just one word.
1411 (goto-char (point-min)) 1419 (goto-char (point-min))
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index 84a61350145..d356979ea26 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -471,26 +471,32 @@ This is relative to `smtpmail-queue-dir'.")
471 (if (null (and cred (condition-case () 471 (if (null (and cred (condition-case ()
472 (progn 472 (progn
473 (require 'starttls) 473 (require 'starttls)
474 (call-process starttls-program)) 474 (call-process (if starttls-use-gnutls
475 starttls-gnutls-program
476 starttls-program)))
475 (error nil)))) 477 (error nil))))
476 ;; The normal case. 478 ;; The normal case.
477 (open-network-stream "SMTP" process-buffer host port) 479 (open-network-stream "SMTP" process-buffer host port)
478 (let* ((cred-key (smtpmail-cred-key cred)) 480 (let* ((cred-key (smtpmail-cred-key cred))
479 (cred-cert (smtpmail-cred-cert cred)) 481 (cred-cert (smtpmail-cred-cert cred))
480 (starttls-extra-args 482 (starttls-extra-args
481 (when (and (stringp cred-key) (stringp cred-cert) 483 (append
482 (file-regular-p 484 starttls-extra-args
483 (setq cred-key (expand-file-name cred-key))) 485 (when (and (stringp cred-key) (stringp cred-cert)
484 (file-regular-p 486 (file-regular-p
485 (setq cred-cert (expand-file-name cred-cert)))) 487 (setq cred-key (expand-file-name cred-key)))
486 (list "--key-file" cred-key "--cert-file" cred-cert))) 488 (file-regular-p
489 (setq cred-cert (expand-file-name cred-cert))))
490 (list "--key-file" cred-key "--cert-file" cred-cert))))
487 (starttls-extra-arguments 491 (starttls-extra-arguments
488 (when (and (stringp cred-key) (stringp cred-cert) 492 (append
489 (file-regular-p 493 starttls-extra-arguments
490 (setq cred-key (expand-file-name cred-key))) 494 (when (and (stringp cred-key) (stringp cred-cert)
491 (file-regular-p 495 (file-regular-p
492 (setq cred-cert (expand-file-name cred-cert)))) 496 (setq cred-key (expand-file-name cred-key)))
493 (list "--x509keyfile" cred-key "--x509certfile" cred-cert)))) 497 (file-regular-p
498 (setq cred-cert (expand-file-name cred-cert))))
499 (list "--x509keyfile" cred-key "--x509certfile" cred-cert)))))
494 (starttls-open-stream "SMTP" process-buffer host port))))) 500 (starttls-open-stream "SMTP" process-buffer host port)))))
495 501
496(defun smtpmail-try-auth-methods (process supported-extensions host port) 502(defun smtpmail-try-auth-methods (process supported-extensions host port)
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index c1f3c0a8d52..16a4826b8ae 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -4514,9 +4514,6 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
4514 1)) 4514 1))
4515 (apply 'call-process program nil (not discard) nil arguments))) 4515 (apply 'call-process program nil (not discard) nil arguments)))
4516 4516
4517(defvar ange-ftp-remote-shell "rsh"
4518 "Remote shell to use for chmod, if FTP server rejects the `chmod' command.")
4519
4520;; Handle an attempt to run chmod on a remote file 4517;; Handle an attempt to run chmod on a remote file
4521;; by using the ftp chmod command. 4518;; by using the ftp chmod command.
4522(defun ange-ftp-call-chmod (args) 4519(defun ange-ftp-call-chmod (args)
@@ -4541,7 +4538,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
4541 abbr)))) 4538 abbr))))
4542 (or (car result) 4539 (or (car result)
4543 (call-process 4540 (call-process
4544 ange-ftp-remote-shell 4541 remote-shell-program
4545 nil t nil host dired-chmod-program mode name)))))) 4542 nil t nil host dired-chmod-program mode name))))))
4546 rest)) 4543 rest))
4547 (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired. 4544 (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired.
diff --git a/lisp/net/tls.el b/lisp/net/tls.el
index d7c8a47a2c0..5f57c084f9b 100644
--- a/lisp/net/tls.el
+++ b/lisp/net/tls.el
@@ -1,6 +1,6 @@
1;;; tls.el --- TLS/SSL support via wrapper around GnuTLS 1;;; tls.el --- TLS/SSL support via wrapper around GnuTLS
2 2
3;; Copyright (C) 2003 Free Software Foundation, Inc. 3;; Copyright (C) 1996-1999, 2003, 2004 Free Software Foundation, Inc.
4 4
5;; Author: Simon Josefsson <simon@josefsson.org> 5;; Author: Simon Josefsson <simon@josefsson.org>
6;; Keywords: comm, tls, gnutls, ssl 6;; Keywords: comm, tls, gnutls, ssl
@@ -76,6 +76,35 @@ The default is what GNUTLS's \"gnutls-cli\" outputs."
76 :type 'regexp 76 :type 'regexp
77 :group 'tls) 77 :group 'tls)
78 78
79(defcustom tls-certtool-program (executable-find "certtool")
80 "Name of GnuTLS certtool.
81Used by `tls-certificate-information'."
82 :type '(repeat string)
83 :group 'tls)
84
85(defun tls-certificate-information (der)
86 "Parse X.509 certificate in DER format into an assoc list."
87 (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n"
88 (base64-encode-string der)
89 "\n-----END CERTIFICATE-----\n"))
90 (exit-code 0))
91 (with-current-buffer (get-buffer-create " *certtool*")
92 (erase-buffer)
93 (insert certificate)
94 (setq exit-code (condition-case ()
95 (call-process-region (point-min) (point-max)
96 tls-certtool-program
97 t (list (current-buffer) nil) t
98 "--certificate-info")
99 (error -1)))
100 (if (/= exit-code 0)
101 nil
102 (let ((vals nil))
103 (goto-char (point-min))
104 (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t)
105 (push (cons (match-string 1) (match-string 2)) vals))
106 (nreverse vals))))))
107
79(defun open-tls-stream (name buffer host service) 108(defun open-tls-stream (name buffer host service)
80 "Open a TLS connection for a service to a host. 109 "Open a TLS connection for a service to a host.
81Returns a subprocess-object to represent the connection. 110Returns a subprocess-object to represent the connection.
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 6a888d9d75d..4628af88178 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -1087,7 +1087,7 @@ Return the difference in the format of a time value."
1087;; `PC-do-completion' touches the returning "$$" by `substitute-in-file-name'. 1087;; `PC-do-completion' touches the returning "$$" by `substitute-in-file-name'.
1088;; Must be corrected. 1088;; Must be corrected.
1089 1089
1090(defadvice PC-do-completion (around tramp-smb-advice-PC-do-completion activate) 1090(defadvice PC-do-completion (around tramp-smb-advice-PC-do-completion)
1091 "Changes \"$\" back to \"$$\" in minibuffer." 1091 "Changes \"$\" back to \"$$\" in minibuffer."
1092 (if (funcall PC-completion-as-file-name-predicate) 1092 (if (funcall PC-completion-as-file-name-predicate)
1093 1093
@@ -1123,6 +1123,13 @@ Return the difference in the format of a time value."
1123 ;; No file names. Behave unchanged. 1123 ;; No file names. Behave unchanged.
1124 ad-do-it)) 1124 ad-do-it))
1125 1125
1126;; Activate advice. Recent Emacsen don't need that.
1127(when (functionp 'PC-do-completion)
1128 (condition-case nil
1129 (substitute-in-file-name "C$/")
1130 (error
1131 (ad-activate 'PC-do-completion))))
1132
1126(provide 'tramp-smb) 1133(provide 'tramp-smb)
1127 1134
1128;;; TODO: 1135;;; TODO:
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index cda0d41fd8d..a30280dbd4f 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1668,6 +1668,7 @@ while (my $data = <STDIN>) {
1668 1668
1669 my $len = length($pending); 1669 my $len = length($pending);
1670 my $chunk = substr($pending, 0, $len & ~3); 1670 my $chunk = substr($pending, 0, $len & ~3);
1671 $pending = substr($pending, $len & ~3 + 1);
1671 1672
1672 # Easy method: translate from chars to (pregenerated) six-bit packets, join, 1673 # Easy method: translate from chars to (pregenerated) six-bit packets, join,
1673 # split in 8-bit chunks and convert back to char. 1674 # split in 8-bit chunks and convert back to char.
@@ -1883,7 +1884,11 @@ If VAR is nil, then we bind `v' to the structure and `multi-method',
1883 1884
1884(put 'with-parsed-tramp-file-name 'lisp-indent-function 2) 1885(put 'with-parsed-tramp-file-name 'lisp-indent-function 2)
1885;; To be activated for debugging containing this macro 1886;; To be activated for debugging containing this macro
1886(def-edebug-spec with-parsed-tramp-file-name t) 1887;; It works only when VAR is nil. Otherwise, it can be deactivated by
1888;; (def-edebug-spec with-parsed-tramp-file-name 0)
1889;; I'm too stupid to write a precise SPEC for it.
1890(if (functionp 'def-edebug-spec)
1891 (def-edebug-spec with-parsed-tramp-file-name t))
1887 1892
1888(defmacro tramp-let-maybe (variable value &rest body) 1893(defmacro tramp-let-maybe (variable value &rest body)
1889 "Let-bind VARIABLE to VALUE in BODY, but only if VARIABLE is not obsolete. 1894 "Let-bind VARIABLE to VALUE in BODY, but only if VARIABLE is not obsolete.
@@ -6731,6 +6736,31 @@ as default."
6731 (tramp-make-auto-save-file-name (buffer-file-name))) 6736 (tramp-make-auto-save-file-name (buffer-file-name)))
6732 ad-do-it)) 6737 ad-do-it))
6733 6738
6739;; In Emacs < 21.4 and XEmacs < 21.5 autosaved remote files have
6740;; permission 666 minus umask. This is a security threat.
6741
6742(defun tramp-set-auto-save-file-modes ()
6743 "Set permissions of autosaved remote files to the original permissions."
6744 (let ((bfn (buffer-file-name)))
6745 (when (and (stringp bfn)
6746 (tramp-tramp-file-p bfn)
6747 (stringp buffer-auto-save-file-name)
6748 (not (equal bfn buffer-auto-save-file-name))
6749 (not (file-exists-p buffer-auto-save-file-name)))
6750 (write-region "" nil buffer-auto-save-file-name)
6751 (set-file-modes buffer-auto-save-file-name (file-modes bfn)))))
6752
6753(unless (or (> emacs-major-version 21)
6754 (and (featurep 'xemacs)
6755 (= emacs-major-version 21)
6756 (> emacs-minor-version 4))
6757 (and (not (featurep 'xemacs))
6758 (= emacs-major-version 21)
6759 (or (> emacs-minor-version 3)
6760 (and (string-match "^21\\.3\\.\\([0-9]+\\)" emacs-version)
6761 (>= (string-to-int (match-string 1 emacs-version)) 50)))))
6762 (add-hook 'auto-save-hook 'tramp-set-auto-save-file-modes))
6763
6734(defun tramp-subst-strs-in-string (alist string) 6764(defun tramp-subst-strs-in-string (alist string)
6735 "Replace all occurrences of the string FROM with TO in STRING. 6765 "Replace all occurrences of the string FROM with TO in STRING.
6736ALIST is of the form ((FROM . TO) ...)." 6766ALIST is of the form ((FROM . TO) ...)."
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 46b33b2d50f..7456bc1660f 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -30,7 +30,7 @@
30;; are auto-frobbed from configure.ac, so you should edit that file and run 30;; are auto-frobbed from configure.ac, so you should edit that file and run
31;; "autoconf && ./configure" to change them. 31;; "autoconf && ./configure" to change them.
32 32
33(defconst tramp-version "2.0.44" 33(defconst tramp-version "2.0.45"
34 "This version of Tramp.") 34 "This version of Tramp.")
35 35
36(defconst tramp-bug-report-address "tramp-devel@mail.freesoftware.fsf.org" 36(defconst tramp-bug-report-address "tramp-devel@mail.freesoftware.fsf.org"
diff --git a/lisp/pcvs-defs.el b/lisp/pcvs-defs.el
index 16e2ff82553..cd379afab77 100644
--- a/lisp/pcvs-defs.el
+++ b/lisp/pcvs-defs.el
@@ -1,7 +1,7 @@
1;;; pcvs-defs.el --- variable definitions for PCL-CVS 1;;; pcvs-defs.el --- variable definitions for PCL-CVS
2 2
3;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 03, 2004 3;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4;; Free Software Foundation, Inc. 4;; 2000, 2003, 2004 Free Software Foundation, Inc.
5 5
6;; Author: Stefan Monnier <monnier@cs.yale.edu> 6;; Author: Stefan Monnier <monnier@cs.yale.edu>
7;; Keywords: pcl-cvs 7;; Keywords: pcl-cvs
@@ -249,9 +249,6 @@ Output from cvs is placed here for asynchronous commands.")
249 :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge)) 249 :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge))
250 (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge)))) 250 (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge))))
251 251
252(defvar pcl-cvs-load-hook nil
253 "Run after loading pcl-cvs.")
254
255(defvar cvs-mode-hook nil 252(defvar cvs-mode-hook nil
256 "Run after `cvs-mode' was setup.") 253 "Run after `cvs-mode' was setup.")
257 254
@@ -510,5 +507,5 @@ message and replace it with a message tell you to change this variable.")
510;; 507;;
511(provide 'pcvs-defs) 508(provide 'pcvs-defs)
512 509
513;;; arch-tag: c7c701d0-d1d4-4aa9-a302-007bb03aca5e 510;; arch-tag: c7c701d0-d1d4-4aa9-a302-007bb03aca5e
514;;; pcvs-defs.el ends here 511;;; pcvs-defs.el ends here
diff --git a/lisp/pcvs-parse.el b/lisp/pcvs-parse.el
index 84dbf218581..7ab6c53b4a0 100644
--- a/lisp/pcvs-parse.el
+++ b/lisp/pcvs-parse.el
@@ -511,15 +511,19 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'."
511 (cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$" 511 (cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$"
512 (subtype 'COMMITTED) (base-rev 1))) 512 (subtype 'COMMITTED) (base-rev 1)))
513 (cvs-or (cvs-match "done$") t) 513 (cvs-or (cvs-match "done$") t)
514 ;; In cvs-1.12.9 commit messages have been changed and became
515 ;; ambiguous. More specifically, the `path' above is not given.
516 ;; We assume here that in future releases the corresponding info will
517 ;; be put into `file'.
514 (progn 518 (progn
515 ;; Try to remove the temp files used by VC. 519 ;; Try to remove the temp files used by VC.
516 (vc-delete-automatic-version-backups (expand-file-name path)) 520 (vc-delete-automatic-version-backups (expand-file-name (or path file)))
517 ;; it's important here not to rely on the default directory management 521 ;; it's important here not to rely on the default directory management
518 ;; because `cvs commit' might begin by a series of Examining messages 522 ;; because `cvs commit' might begin by a series of Examining messages
519 ;; so the processing of the actual checkin messages might begin with 523 ;; so the processing of the actual checkin messages might begin with
520 ;; a `current-dir' set to something different from "" 524 ;; a `current-dir' set to something different from ""
521 (cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype) 525 (cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype)
522 (or path file) (if path 'trust) 526 (or path file) 'trust
523 :base-rev base-rev))) 527 :base-rev base-rev)))
524 528
525 ;; useless message added before the actual addition: ignored 529 ;; useless message added before the actual addition: ignored
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index ddbd2ce6f35..0569d26db61 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -1229,10 +1229,10 @@ where they were found."
1229 1229
1230(defun etags-tags-completion-table () 1230(defun etags-tags-completion-table ()
1231 (let ((table (make-vector 511 0)) 1231 (let ((table (make-vector 511 0))
1232 (point-max (/ (float (point-max)) 100.0)) 1232 (progress-reporter
1233 (msg-fmt (format 1233 (make-progress-reporter
1234 "Making tags completion table for %s...%%d%%%%" 1234 (format "Making tags completion table for %s..." buffer-file-name)
1235 buffer-file-name))) 1235 (point-min) (point-max))))
1236 (save-excursion 1236 (save-excursion
1237 (goto-char (point-min)) 1237 (goto-char (point-min))
1238 ;; This monster regexp matches an etags tag line. 1238 ;; This monster regexp matches an etags tag line.
@@ -1253,7 +1253,7 @@ where they were found."
1253 (buffer-substring (match-beginning 5) (match-end 5)) 1253 (buffer-substring (match-beginning 5) (match-end 5))
1254 ;; No explicit tag name. Best guess. 1254 ;; No explicit tag name. Best guess.
1255 (buffer-substring (match-beginning 3) (match-end 3))) 1255 (buffer-substring (match-beginning 3) (match-end 3)))
1256 (message msg-fmt (/ (point) point-max))) 1256 (progress-reporter-update progress-reporter (point)))
1257 table))) 1257 table)))
1258 table)) 1258 table))
1259 1259
@@ -1433,11 +1433,12 @@ where they were found."
1433 (tags-with-face 'highlight (princ buffer-file-name)) 1433 (tags-with-face 'highlight (princ buffer-file-name))
1434 (princ "':\n\n")) 1434 (princ "':\n\n"))
1435 (goto-char (point-min)) 1435 (goto-char (point-min))
1436 (let ((point-max (/ (float (point-max)) 100.0))) 1436 (let ((progress-reporter (make-progress-reporter
1437 (format "Making tags apropos buffer for `%s'..."
1438 string)
1439 (point-min) (point-max))))
1437 (while (re-search-forward string nil t) 1440 (while (re-search-forward string nil t)
1438 (message "Making tags apropos buffer for `%s'...%d%%" 1441 (progress-reporter-update progress-reporter (point))
1439 string
1440 (/ (point) point-max))
1441 (beginning-of-line) 1442 (beginning-of-line)
1442 1443
1443 (let* ( ;; Get the local value in the tags table 1444 (let* ( ;; Get the local value in the tags table
diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el
index 612a2034e00..d8f2cf34867 100644
--- a/lisp/progmodes/gdb-ui.el
+++ b/lisp/progmodes/gdb-ui.el
@@ -188,6 +188,7 @@ detailed description of this mode.
188 (setq gdb-var-changed nil) 188 (setq gdb-var-changed nil)
189 (setq gdb-first-prompt nil) 189 (setq gdb-first-prompt nil)
190 (setq gdb-prompting nil) 190 (setq gdb-prompting nil)
191 (setq gdb-input-queue nil)
191 (setq gdb-current-item nil) 192 (setq gdb-current-item nil)
192 (setq gdb-pending-triggers nil) 193 (setq gdb-pending-triggers nil)
193 (setq gdb-output-sink 'user) 194 (setq gdb-output-sink 'user)
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index 4ea4fcb6ea2..37fe13ce585 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -3027,6 +3027,27 @@ class of the file (using s to separate nested class ids)."
3027 (save-excursion (indent-line-to indent)) 3027 (save-excursion (indent-line-to indent))
3028 (indent-line-to indent))))) 3028 (indent-line-to indent)))))
3029 3029
3030;; Derived from cfengine.el.
3031(defun gdb-script-beginning-of-defun ()
3032 "`beginning-of-defun' function for Gdb script mode.
3033Treats actions as defuns."
3034 (unless (<= (current-column) (current-indentation))
3035 (end-of-line))
3036 (if (re-search-backward "^define \\|^document " nil t)
3037 (beginning-of-line)
3038 (goto-char (point-min)))
3039 t)
3040
3041;; Derived from cfengine.el.
3042(defun gdb-script-end-of-defun ()
3043 "`end-of-defun' function for Gdb script mode.
3044Treats actions as defuns."
3045 (end-of-line)
3046 (if (re-search-forward "^end" nil t)
3047 (beginning-of-line)
3048 (goto-char (point-max)))
3049 t)
3050
3030;;;###autoload 3051;;;###autoload
3031(add-to-list 'auto-mode-alist '("/\\.gdbinit" . gdb-script-mode)) 3052(add-to-list 'auto-mode-alist '("/\\.gdbinit" . gdb-script-mode))
3032 3053
@@ -3039,6 +3060,10 @@ class of the file (using s to separate nested class ids)."
3039 (set (make-local-variable 'imenu-generic-expression) 3060 (set (make-local-variable 'imenu-generic-expression)
3040 '((nil "^define[ \t]+\\(\\w+\\)" 1))) 3061 '((nil "^define[ \t]+\\(\\w+\\)" 1)))
3041 (set (make-local-variable 'indent-line-function) 'gdb-script-indent-line) 3062 (set (make-local-variable 'indent-line-function) 'gdb-script-indent-line)
3063 (set (make-local-variable 'beginning-of-defun-function)
3064 #'gdb-script-beginning-of-defun)
3065 (set (make-local-variable 'end-of-defun-function)
3066 #'gdb-script-end-of-defun)
3042 (set (make-local-variable 'font-lock-defaults) 3067 (set (make-local-variable 'font-lock-defaults)
3043 '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil 3068 '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil
3044 (font-lock-syntactic-keywords 3069 (font-lock-syntactic-keywords
diff --git a/lisp/recentf.el b/lisp/recentf.el
index efe4ebc63a4..4ef55d4e1bf 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -1032,7 +1032,8 @@ Click on Cancel or type \"q\" to quit.\n")
1032 (dolist (e recentf-edit-selected-items) 1032 (dolist (e recentf-edit-selected-items)
1033 (setq recentf-list (delq e recentf-list) 1033 (setq recentf-list (delq e recentf-list)
1034 i (1+ i))) 1034 i (1+ i)))
1035 (message "%S file(s) removed from the list" i)) 1035 (message "%S file(s) removed from the list" i)
1036 (recentf-clear-data))
1036 (message "No file selected"))) 1037 (message "No file selected")))
1037 "Ok") 1038 "Ok")
1038 (widget-insert " ") 1039 (widget-insert " ")
diff --git a/lisp/server.el b/lisp/server.el
index fe2fc0f59f4..3a330f07a3c 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -343,7 +343,11 @@ PROC is the server process. Format of STRING is \"PATH PATH PATH... \\n\"."
343 (with-temp-buffer 343 (with-temp-buffer
344 (let ((standard-output (current-buffer))) 344 (let ((standard-output (current-buffer)))
345 (pp v) 345 (pp v)
346 (process-send-region proc (point-min) (point-max)))))) 346 ;; Suppress the error rose when the pipe to PROC is closed.
347 (condition-case err
348 (process-send-region proc (point-min) (point-max))
349 (file-error nil))
350 ))))
347 ;; ARG is a file name. 351 ;; ARG is a file name.
348 ;; Collapse multiple slashes to single slashes. 352 ;; Collapse multiple slashes to single slashes.
349 (setq arg (command-line-normalize-file-name arg)) 353 (setq arg (command-line-normalize-file-name arg))
diff --git a/lisp/subr.el b/lisp/subr.el
index e5a967310d5..eb4577b1a8d 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -367,15 +367,6 @@ but optional second arg NODIGITS non-nil treats them like other chars."
367 (define-key map (char-to-string loop) 'digit-argument) 367 (define-key map (char-to-string loop) 'digit-argument)
368 (setq loop (1+ loop)))))) 368 (setq loop (1+ loop))))))
369 369
370;Moved to keymap.c
371;(defun copy-keymap (keymap)
372; "Return a copy of KEYMAP"
373; (while (not (keymapp keymap))
374; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
375; (if (vectorp keymap)
376; (copy-sequence keymap)
377; (copy-alist keymap)))
378
379(defvar key-substitution-in-progress nil 370(defvar key-substitution-in-progress nil
380 "Used internally by substitute-key-definition.") 371 "Used internally by substitute-key-definition.")
381 372
@@ -383,7 +374,10 @@ but optional second arg NODIGITS non-nil treats them like other chars."
383 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. 374 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
384In other words, OLDDEF is replaced with NEWDEF where ever it appears. 375In other words, OLDDEF is replaced with NEWDEF where ever it appears.
385Alternatively, if optional fourth argument OLDMAP is specified, we redefine 376Alternatively, if optional fourth argument OLDMAP is specified, we redefine
386in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP." 377in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
378
379For most uses, it is simpler and safer to use command remappping like this:
380 \(define-key KEYMAP [remap OLDDEF] NEWDEF)"
387 ;; Don't document PREFIX in the doc string because we don't want to 381 ;; Don't document PREFIX in the doc string because we don't want to
388 ;; advertise it. It's meant for recursive calls only. Here's its 382 ;; advertise it. It's meant for recursive calls only. Here's its
389 ;; meaning 383 ;; meaning
@@ -393,126 +387,54 @@ in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
393 ;; original key, with PREFIX added at the front. 387 ;; original key, with PREFIX added at the front.
394 (or prefix (setq prefix "")) 388 (or prefix (setq prefix ""))
395 (let* ((scan (or oldmap keymap)) 389 (let* ((scan (or oldmap keymap))
396 (vec1 (vector nil)) 390 (prefix1 (vconcat prefix [nil]))
397 (prefix1 (vconcat prefix vec1))
398 (key-substitution-in-progress 391 (key-substitution-in-progress
399 (cons scan key-substitution-in-progress))) 392 (cons scan key-substitution-in-progress)))
400 ;; Scan OLDMAP, finding each char or event-symbol that 393 ;; Scan OLDMAP, finding each char or event-symbol that
401 ;; has any definition, and act on it with hack-key. 394 ;; has any definition, and act on it with hack-key.
402 (while (consp scan) 395 (map-keymap
403 (if (consp (car scan)) 396 (lambda (char defn)
404 (let ((char (car (car scan))) 397 (aset prefix1 (length prefix) char)
405 (defn (cdr (car scan)))) 398 (substitute-key-definition-key defn olddef newdef prefix1 keymap))
406 ;; The inside of this let duplicates exactly 399 scan)))
407 ;; the inside of the following let that handles array elements. 400
408 (aset vec1 0 char) 401(defun substitute-key-definition-key (defn olddef newdef prefix keymap)
409 (aset prefix1 (length prefix) char) 402 (let (inner-def skipped menu-item)
410 (let (inner-def skipped) 403 ;; Find the actual command name within the binding.
411 ;; Skip past menu-prompt. 404 (if (eq (car-safe defn) 'menu-item)
412 (while (stringp (car-safe defn)) 405 (setq menu-item defn defn (nth 2 defn))
413 (setq skipped (cons (car defn) skipped)) 406 ;; Skip past menu-prompt.
414 (setq defn (cdr defn))) 407 (while (stringp (car-safe defn))
415 ;; Skip past cached key-equivalence data for menu items. 408 (push (pop defn) skipped))
416 (and (consp defn) (consp (car defn)) 409 ;; Skip past cached key-equivalence data for menu items.
417 (setq defn (cdr defn))) 410 (if (consp (car-safe defn))
418 (setq inner-def defn) 411 (setq defn (cdr defn))))
419 ;; Look past a symbol that names a keymap. 412 (if (or (eq defn olddef)
420 (while (and (symbolp inner-def) 413 ;; Compare with equal if definition is a key sequence.
421 (fboundp inner-def)) 414 ;; That is useful for operating on function-key-map.
422 (setq inner-def (symbol-function inner-def))) 415 (and (or (stringp defn) (vectorp defn))
423 (if (or (eq defn olddef) 416 (equal defn olddef)))
424 ;; Compare with equal if definition is a key sequence. 417 (define-key keymap prefix
425 ;; That is useful for operating on function-key-map. 418 (if menu-item
426 (and (or (stringp defn) (vectorp defn)) 419 (let ((copy (copy-sequence menu-item)))
427 (equal defn olddef))) 420 (setcar (nthcdr 2 copy) newdef)
428 (define-key keymap prefix1 (nconc (nreverse skipped) newdef)) 421 copy)
429 (if (and (keymapp defn) 422 (nconc (nreverse skipped) newdef)))
430 ;; Avoid recursively scanning 423 ;; Look past a symbol that names a keymap.
431 ;; where KEYMAP does not have a submap. 424 (setq inner-def
432 (let ((elt (lookup-key keymap prefix1))) 425 (condition-case nil (indirect-function defn) (error defn)))
433 (or (null elt) 426 ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
434 (keymapp elt))) 427 ;; avoid autoloading a keymap. This is mostly done to preserve the
435 ;; Avoid recursively rescanning keymap being scanned. 428 ;; original non-autoloading behavior of pre-map-keymap times.
436 (not (memq inner-def 429 (if (and (keymapp inner-def)
437 key-substitution-in-progress))) 430 ;; Avoid recursively scanning
438 ;; If this one isn't being scanned already, 431 ;; where KEYMAP does not have a submap.
439 ;; scan it now. 432 (let ((elt (lookup-key keymap prefix)))
440 (substitute-key-definition olddef newdef keymap 433 (or (null elt) (natnump elt) (keymapp elt)))
441 inner-def 434 ;; Avoid recursively rescanning keymap being scanned.
442 prefix1))))) 435 (not (memq inner-def key-substitution-in-progress)))
443 (if (vectorp (car scan)) 436 ;; If this one isn't being scanned already, scan it now.
444 (let* ((array (car scan)) 437 (substitute-key-definition olddef newdef keymap inner-def prefix)))))
445 (len (length array))
446 (i 0))
447 (while (< i len)
448 (let ((char i) (defn (aref array i)))
449 ;; The inside of this let duplicates exactly
450 ;; the inside of the previous let.
451 (aset vec1 0 char)
452 (aset prefix1 (length prefix) char)
453 (let (inner-def skipped)
454 ;; Skip past menu-prompt.
455 (while (stringp (car-safe defn))
456 (setq skipped (cons (car defn) skipped))
457 (setq defn (cdr defn)))
458 (and (consp defn) (consp (car defn))
459 (setq defn (cdr defn)))
460 (setq inner-def defn)
461 (while (and (symbolp inner-def)
462 (fboundp inner-def))
463 (setq inner-def (symbol-function inner-def)))
464 (if (or (eq defn olddef)
465 (and (or (stringp defn) (vectorp defn))
466 (equal defn olddef)))
467 (define-key keymap prefix1
468 (nconc (nreverse skipped) newdef))
469 (if (and (keymapp defn)
470 (let ((elt (lookup-key keymap prefix1)))
471 (or (null elt)
472 (keymapp elt)))
473 (not (memq inner-def
474 key-substitution-in-progress)))
475 (substitute-key-definition olddef newdef keymap
476 inner-def
477 prefix1)))))
478 (setq i (1+ i))))
479 (if (char-table-p (car scan))
480 (map-char-table
481 (function (lambda (char defn)
482 (let ()
483 ;; The inside of this let duplicates exactly
484 ;; the inside of the previous let,
485 ;; except that it uses set-char-table-range
486 ;; instead of define-key.
487 (aset vec1 0 char)
488 (aset prefix1 (length prefix) char)
489 (let (inner-def skipped)
490 ;; Skip past menu-prompt.
491 (while (stringp (car-safe defn))
492 (setq skipped (cons (car defn) skipped))
493 (setq defn (cdr defn)))
494 (and (consp defn) (consp (car defn))
495 (setq defn (cdr defn)))
496 (setq inner-def defn)
497 (while (and (symbolp inner-def)
498 (fboundp inner-def))
499 (setq inner-def (symbol-function inner-def)))
500 (if (or (eq defn olddef)
501 (and (or (stringp defn) (vectorp defn))
502 (equal defn olddef)))
503 (define-key keymap prefix1
504 (nconc (nreverse skipped) newdef))
505 (if (and (keymapp defn)
506 (let ((elt (lookup-key keymap prefix1)))
507 (or (null elt)
508 (keymapp elt)))
509 (not (memq inner-def
510 key-substitution-in-progress)))
511 (substitute-key-definition olddef newdef keymap
512 inner-def
513 prefix1)))))))
514 (car scan)))))
515 (setq scan (cdr scan)))))
516 438
517(defun define-key-after (keymap key definition &optional after) 439(defun define-key-after (keymap key definition &optional after)
518 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. 440 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
@@ -658,19 +580,19 @@ even when EVENT actually has modifiers."
658 (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ 580 (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
659 ?\H-\^@ ?\s-\^@ ?\A-\^@))))) 581 ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
660 (if (not (zerop (logand type ?\M-\^@))) 582 (if (not (zerop (logand type ?\M-\^@)))
661 (setq list (cons 'meta list))) 583 (push 'meta list))
662 (if (or (not (zerop (logand type ?\C-\^@))) 584 (if (or (not (zerop (logand type ?\C-\^@)))
663 (< char 32)) 585 (< char 32))
664 (setq list (cons 'control list))) 586 (push 'control list))
665 (if (or (not (zerop (logand type ?\S-\^@))) 587 (if (or (not (zerop (logand type ?\S-\^@)))
666 (/= char (downcase char))) 588 (/= char (downcase char)))
667 (setq list (cons 'shift list))) 589 (push 'shift list))
668 (or (zerop (logand type ?\H-\^@)) 590 (or (zerop (logand type ?\H-\^@))
669 (setq list (cons 'hyper list))) 591 (push 'hyper list))
670 (or (zerop (logand type ?\s-\^@)) 592 (or (zerop (logand type ?\s-\^@))
671 (setq list (cons 'super list))) 593 (push 'super list))
672 (or (zerop (logand type ?\A-\^@)) 594 (or (zerop (logand type ?\A-\^@))
673 (setq list (cons 'alt list))) 595 (push 'alt list))
674 list)))) 596 list))))
675 597
676(defun event-basic-type (event) 598(defun event-basic-type (event)
@@ -688,8 +610,7 @@ in the current Emacs session, then this function may return nil."
688 610
689(defsubst mouse-movement-p (object) 611(defsubst mouse-movement-p (object)
690 "Return non-nil if OBJECT is a mouse movement event." 612 "Return non-nil if OBJECT is a mouse movement event."
691 (and (consp object) 613 (eq (car-safe object) 'mouse-movement))
692 (eq (car object) 'mouse-movement)))
693 614
694(defsubst event-start (event) 615(defsubst event-start (event)
695 "Return the starting position of EVENT. 616 "Return the starting position of EVENT.
@@ -1880,8 +1801,7 @@ Use a MESSAGE of \"\" to temporarily clear the echo area."
1880See also `with-temp-file' and `with-output-to-string'." 1801See also `with-temp-file' and `with-output-to-string'."
1881 (declare (indent 0) (debug t)) 1802 (declare (indent 0) (debug t))
1882 (let ((temp-buffer (make-symbol "temp-buffer"))) 1803 (let ((temp-buffer (make-symbol "temp-buffer")))
1883 `(let ((,temp-buffer 1804 `(let ((,temp-buffer (generate-new-buffer " *temp*")))
1884 (get-buffer-create (generate-new-buffer-name " *temp*"))))
1885 (unwind-protect 1805 (unwind-protect
1886 (with-current-buffer ,temp-buffer 1806 (with-current-buffer ,temp-buffer
1887 ,@body) 1807 ,@body)
@@ -2652,5 +2572,132 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
2652 (put symbol 'abortfunc (or abortfunc 'kill-buffer)) 2572 (put symbol 'abortfunc (or abortfunc 'kill-buffer))
2653 (put symbol 'hookvar (or hookvar 'mail-send-hook))) 2573 (put symbol 'hookvar (or hookvar 'mail-send-hook)))
2654 2574
2575;; Standardized progress reporting
2576
2577;; Progress reporter has the following structure:
2578;;
2579;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
2580;; MIN-VALUE
2581;; MAX-VALUE
2582;; MESSAGE
2583;; MIN-CHANGE
2584;; MIN-TIME])
2585;;
2586;; This weirdeness is for optimization reasons: we want
2587;; `progress-reporter-update' to be as fast as possible, so
2588;; `(car reporter)' is better than `(aref reporter 0)'.
2589;;
2590;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple
2591;; digits of precision, it doesn't really matter here. On the other
2592;; hand, it greatly simplifies the code.
2593
2594(defsubst progress-reporter-update (reporter value)
2595 "Report progress of an operation in the echo area.
2596However, if the change since last echo area update is too small
2597or not enough time has passed, then do nothing (see
2598`make-progress-reporter' for details).
2599
2600First parameter, REPORTER, should be the result of a call to
2601`make-progress-reporter'. Second, VALUE, determines the actual
2602progress of operation; it must be between MIN-VALUE and MAX-VALUE
2603as passed to `make-progress-reporter'.
2604
2605This function is very inexpensive, you may not bother how often
2606you call it."
2607 (when (>= value (car reporter))
2608 (progress-reporter-do-update reporter value)))
2609
2610(defun make-progress-reporter (message min-value max-value
2611 &optional current-value
2612 min-change min-time)
2613 "Return progress reporter object usage with `progress-reporter-update'.
2614
2615MESSAGE is shown in the echo area. When at least 1% of operation
2616is complete, the exact percentage will be appended to the
2617MESSAGE. When you call `progress-reporter-done', word \"done\"
2618is printed after the MESSAGE. You can change MESSAGE of an
2619existing progress reporter with `progress-reporter-force-update'.
2620
2621MIN-VALUE and MAX-VALUE designate starting (0% complete) and
2622final (100% complete) states of operation. The latter should be
2623larger; if this is not the case, then simply negate all values.
2624Optional CURRENT-VALUE specifies the progress by the moment you
2625call this function. You should omit it or set it to nil in most
2626cases since it defaults to MIN-VALUE.
2627
2628Optional MIN-CHANGE determines the minimal change in percents to
2629report (default is 1%.) Optional MIN-TIME specifies the minimal
2630time before echo area updates (default is 0.2 seconds.) If
2631`float-time' function is not present, then time is not tracked
2632at all. If OS is not capable of measuring fractions of seconds,
2633then this parameter is effectively rounded up."
2634
2635 (unless min-time
2636 (setq min-time 0.2))
2637 (let ((reporter
2638 (cons min-value ;; Force a call to `message' now
2639 (vector (if (and (fboundp 'float-time)
2640 (>= min-time 0.02))
2641 (float-time) nil)
2642 min-value
2643 max-value
2644 message
2645 (if min-change (max (min min-change 50) 1) 1)
2646 min-time))))
2647 (progress-reporter-update reporter (or current-value min-value))
2648 reporter))
2649
2650(defun progress-reporter-force-update (reporter value &optional new-message)
2651 "Report progress of an operation in the echo area unconditionally.
2652
2653First two parameters are the same as for
2654`progress-reporter-update'. Optional NEW-MESSAGE allows you to
2655change the displayed message."
2656 (let ((parameters (cdr reporter)))
2657 (when new-message
2658 (aset parameters 3 new-message))
2659 (when (aref parameters 0)
2660 (aset parameters 0 (float-time)))
2661 (progress-reporter-do-update reporter value)))
2662
2663(defun progress-reporter-do-update (reporter value)
2664 (let* ((parameters (cdr reporter))
2665 (min-value (aref parameters 1))
2666 (max-value (aref parameters 2))
2667 (one-percent (/ (- max-value min-value) 100.0))
2668 (percentage (truncate (/ (- value min-value) one-percent)))
2669 (update-time (aref parameters 0))
2670 (current-time (float-time))
2671 (enough-time-passed
2672 ;; See if enough time has passed since the last update.
2673 (or (not update-time)
2674 (when (>= current-time update-time)
2675 ;; Calculate time for the next update
2676 (aset parameters 0 (+ update-time (aref parameters 5)))))))
2677 ;;
2678 ;; Calculate NEXT-UPDATE-VALUE. If we are not going to print
2679 ;; message this time because not enough time has passed, then use
2680 ;; 1 instead of MIN-CHANGE. This makes delays between echo area
2681 ;; updates closer to MIN-TIME.
2682 (setcar reporter
2683 (min (+ min-value (* (+ percentage
2684 (if enough-time-passed
2685 (aref parameters 4) ;; MIN-CHANGE
2686 1))
2687 one-percent))
2688 max-value))
2689 (when (integerp value)
2690 (setcar reporter (ceiling (car reporter))))
2691 ;;
2692 ;; Only print message if enough time has passed
2693 (when enough-time-passed
2694 (if (> percentage 0)
2695 (message "%s%d%%" (aref parameters 3) percentage)
2696 (message "%s" (aref parameters 3))))))
2697
2698(defun progress-reporter-done (reporter)
2699 "Print reporter's message followed by word \"done\" in echo area."
2700 (message "%sdone" (aref (cdr reporter) 3)))
2701
2655;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc 2702;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
2656;;; subr.el ends here 2703;;; subr.el ends here
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index a2e9ac8fff6..181fc9baca5 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -405,11 +405,12 @@ MODE should be an integer which is a file mode value."
405Place a dired-like listing on the front; 405Place a dired-like listing on the front;
406then narrow to it, so that only that listing 406then narrow to it, so that only that listing
407is visible (and the real data of the buffer is hidden)." 407is visible (and the real data of the buffer is hidden)."
408 (message "Parsing tar file...") 408 (set-buffer-multibyte nil)
409 (let* ((result '()) 409 (let* ((result '())
410 (pos (point-min)) 410 (pos (point-min))
411 (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end. 411 (progress-reporter
412 (bs100 (max 1 (/ bs 100))) 412 (make-progress-reporter "Parsing tar file..."
413 (point-min) (max 1 (- (buffer-size) 1024))))
413 tokens) 414 tokens)
414 (while (and (<= (+ pos 512) (point-max)) 415 (while (and (<= (+ pos 512) (point-max))
415 (not (eq 'empty-tar-block 416 (not (eq 'empty-tar-block
@@ -417,10 +418,7 @@ is visible (and the real data of the buffer is hidden)."
417 (tar-header-block-tokenize 418 (tar-header-block-tokenize
418 (buffer-substring pos (+ pos 512))))))) 419 (buffer-substring pos (+ pos 512)))))))
419 (setq pos (+ pos 512)) 420 (setq pos (+ pos 512))
420 (message "Parsing tar file...%d%%" 421 (progress-reporter-update progress-reporter pos)
421 ;(/ (* pos 100) bs) ; this gets round-off lossage
422 (/ pos bs100) ; this doesn't
423 )
424 (if (eq (tar-header-link-type tokens) 20) 422 (if (eq (tar-header-link-type tokens) 20)
425 ;; Foo. There's an extra empty block after these. 423 ;; Foo. There's an extra empty block after these.
426 (setq pos (+ pos 512))) 424 (setq pos (+ pos 512)))
@@ -447,7 +445,7 @@ is visible (and the real data of the buffer is hidden)."
447 ;; A tar file should end with a block or two of nulls, 445 ;; A tar file should end with a block or two of nulls,
448 ;; but let's not get a fatal error if it doesn't. 446 ;; but let's not get a fatal error if it doesn't.
449 (if (eq tokens 'empty-tar-block) 447 (if (eq tokens 'empty-tar-block)
450 (message "Parsing tar file...done") 448 (progress-reporter-done progress-reporter)
451 (message "Warning: premature EOF parsing tar file"))) 449 (message "Warning: premature EOF parsing tar file")))
452 (save-excursion 450 (save-excursion
453 (goto-char (point-min)) 451 (goto-char (point-min))
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
index c2ed47cb48d..71bb6cf137d 100644
--- a/lisp/textmodes/enriched.el
+++ b/lisp/textmodes/enriched.el
@@ -258,8 +258,8 @@ Commands:
258(define-key enriched-mode-map "\M-j" 'facemenu-justification-menu) 258(define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
259(define-key enriched-mode-map "\M-S" 'set-justification-center) 259(define-key enriched-mode-map "\M-S" 'set-justification-center)
260(define-key enriched-mode-map "\C-x\t" 'increase-left-margin) 260(define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
261(define-key enriched-mode-map "\C-c\C-l" 'set-left-margin) 261(define-key enriched-mode-map "\C-c[" 'set-left-margin)
262(define-key enriched-mode-map "\C-c\C-r" 'set-right-margin) 262(define-key enriched-mode-map "\C-c]" 'set-right-margin)
263 263
264;;; 264;;;
265;;; Some functions dealing with text-properties, especially indentation 265;;; Some functions dealing with text-properties, especially indentation
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index 868dcb2d107..206f7a42f78 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -1,6 +1,6 @@
1;;; paragraphs.el --- paragraph and sentence parsing 1;;; paragraphs.el --- paragraph and sentence parsing
2 2
3;; Copyright (C) 1985, 86, 87, 91, 94, 95, 96, 1997, 1999, 2000, 2001 3;; Copyright (C) 1985, 86, 87, 91, 94, 95, 96, 1997, 1999, 2000, 2001, 2004
4;; Free Software Foundation, Inc. 4;; Free Software Foundation, Inc.
5 5
6;; Maintainer: FSF 6;; Maintainer: FSF
@@ -122,8 +122,8 @@ This is relevant for filling. See also `sentence-end-without-period'
122and `colon-double-space'. 122and `colon-double-space'.
123 123
124This value is used by the function `sentence-end' to construct the 124This value is used by the function `sentence-end' to construct the
125regexp describing the end of a sentence, in case when the value of 125regexp describing the end of a sentence, when the value of the variable
126the variable `sentence-end' is nil. See Info node `Sentences'." 126`sentence-end' is nil. See Info node `(elisp)Standard Regexps'."
127 :type 'boolean 127 :type 'boolean
128 :group 'fill) 128 :group 'fill)
129 129
@@ -133,18 +133,18 @@ For example, a sentence in Thai text ends with double space but
133without a period. 133without a period.
134 134
135This value is used by the function `sentence-end' to construct the 135This value is used by the function `sentence-end' to construct the
136regexp describing the end of a sentence, in case when the value of 136regexp describing the end of a sentence, when the value of the variable
137the variable `sentence-end' is nil. See Info node `Sentences'." 137`sentence-end' is nil. See Info node `(elisp)Standard Regexps'."
138 :type 'boolean 138 :type 'boolean
139 :group 'fill) 139 :group 'fill)
140 140
141(defcustom sentence-end-without-space 141(defcustom sentence-end-without-space
142 "$B!#!%!)!*$A!##.#?#!$(0!$!%!)!*$(G!$!%!)!*(B" 142 "$B!#!%!)!*$A!##.#?#!$(0!$!%!)!*$(G!$!%!)!*(B"
143 "*String containing characters that end sentence without following spaces. 143 "*String of characters that end sentence without following spaces.
144 144
145This value is used by the function `sentence-end' to construct the 145This value is used by the function `sentence-end' to construct the
146regexp describing the end of a sentence, in case when the value of 146regexp describing the end of a sentence, when the value of the variable
147the variable `sentence-end' is nil. See Info node `Sentences'." 147`sentence-end' is nil. See Info node `(elisp)Standard Regexps'."
148 :group 'paragraphs 148 :group 'paragraphs
149 :type 'string) 149 :type 'string)
150 150
@@ -169,7 +169,7 @@ and `sentence-end-without-space'. The default value specifies
169that in order to be recognized as the end of a sentence, the 169that in order to be recognized as the end of a sentence, the
170ending period, question mark, or exclamation point must be 170ending period, question mark, or exclamation point must be
171followed by two spaces, unless it's inside some sort of quotes or 171followed by two spaces, unless it's inside some sort of quotes or
172parenthesis. See Info node `Sentences'." 172parenthesis. See Info node `(elisp)Standard Regexps'."
173 (or sentence-end 173 (or sentence-end
174 (concat (if sentence-end-without-period "\\w \\|") 174 (concat (if sentence-end-without-period "\\w \\|")
175 "\\([.?!][]\"'\xd0c9\x5397d)}]*" 175 "\\([.?!][]\"'\xd0c9\x5397d)}]*"
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 24347479e57..5a8d0df40d1 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -500,6 +500,11 @@ An alternative value is \" . \", if you use a font with a narrow period."
500 1 font-lock-function-name-face)))) 500 1 font-lock-function-name-face))))
501 "Subdued expressions to highlight in TeX modes.") 501 "Subdued expressions to highlight in TeX modes.")
502 502
503(defun tex-font-lock-append-prop (prop)
504 (unless (memq (get-text-property (match-end 1) 'face)
505 '(font-lock-comment-face tex-verbatim-face))
506 prop))
507
503(defconst tex-font-lock-keywords-2 508(defconst tex-font-lock-keywords-2
504 (append tex-font-lock-keywords-1 509 (append tex-font-lock-keywords-1
505 (eval-when-compile 510 (eval-when-compile
@@ -553,16 +558,19 @@ An alternative value is \" . \", if you use a font with a narrow period."
553 ;; 558 ;;
554 ;; Font environments. It seems a bit dubious to use `bold' etc. faces 559 ;; Font environments. It seems a bit dubious to use `bold' etc. faces
555 ;; since we might not be able to display those fonts. 560 ;; since we might not be able to display those fonts.
556 (list (concat slash bold " *" arg) 2 '(quote bold) 'append) 561 (list (concat slash bold " *" arg) 2
557 (list (concat slash italic " *" arg) 2 '(quote italic) 'append) 562 '(tex-font-lock-append-prop 'bold) 'append)
563 (list (concat slash italic " *" arg) 2
564 '(tex-font-lock-append-prop 'italic) 'append)
558 ;; (list (concat slash type arg) 2 '(quote bold-italic) 'append) 565 ;; (list (concat slash type arg) 2 '(quote bold-italic) 'append)
559 ;; 566 ;;
560 ;; Old-style bf/em/it/sl. Stop at `\\' and un-escaped `&', for tables. 567 ;; Old-style bf/em/it/sl. Stop at `\\' and un-escaped `&', for tables.
561 (list (concat "\\\\\\(em\\|it\\|sl\\)\\>" args) 568 (list (concat "\\\\\\(em\\|it\\|sl\\)\\>" args)
562 2 '(quote italic) 'append) 569 2 '(tex-font-lock-append-prop 'italic) 'append)
563 ;; This is separate from the previous one because of cases like 570 ;; This is separate from the previous one because of cases like
564 ;; {\em foo {\bf bar} bla} where both match. 571 ;; {\em foo {\bf bar} bla} where both match.
565 (list (concat "\\\\bf\\>" args) 1 '(quote bold) 'append))))) 572 (list (concat "\\\\\\(bf\\)\\>" args)
573 2 '(tex-font-lock-append-prop 'bold) 'append)))))
566 "Gaudy expressions to highlight in TeX modes.") 574 "Gaudy expressions to highlight in TeX modes.")
567 575
568(defun tex-font-lock-suscript (pos) 576(defun tex-font-lock-suscript (pos)
@@ -604,11 +612,14 @@ An alternative value is \" . \", if you use a font with a narrow period."
604(defvar tex-font-lock-syntactic-keywords 612(defvar tex-font-lock-syntactic-keywords
605 (let ((verbs (regexp-opt tex-verbatim-environments t))) 613 (let ((verbs (regexp-opt tex-verbatim-environments t)))
606 `((,(concat "^\\\\begin *{" verbs "}.*\\(\n\\)") 2 "|") 614 `((,(concat "^\\\\begin *{" verbs "}.*\\(\n\\)") 2 "|")
607 (,(concat "^\\\\end *{" verbs "}\\(.?\\)") 2 615 ;; Technically, we'd like to put the "|" property on the \n preceding
608 (unless (<= (match-beginning 0) (point-min)) 616 ;; the \end, but this would have 2 disadvantages:
609 (put-text-property (1- (match-beginning 0)) (match-beginning 0) 617 ;; 1 - it's wrong if the verbatim env is empty (the same \n is used to
610 'syntax-table (string-to-syntax "|")) 618 ;; start and end the fenced-string).
611 "<")) 619 ;; 2 - font-lock considers the preceding \n as being part of the
620 ;; preceding line, so things gets screwed every time the previous
621 ;; line is re-font-locked on its own.
622 (,(concat "^\\(\\\\\\)end *{" verbs "}\\(.?\\)") (1 "|") (3 "<"))
612 ;; ("^\\(\\\\\\)begin *{comment}" 1 "< b") 623 ;; ("^\\(\\\\\\)begin *{comment}" 1 "< b")
613 ;; ("^\\\\end *{comment}.*\\(\n\\)" 1 "> b") 624 ;; ("^\\\\end *{comment}.*\\(\n\\)" 1 "> b")
614 ("\\\\verb\\**\\([^a-z@*]\\)" 1 "\"")))) 625 ("\\\\verb\\**\\([^a-z@*]\\)" 1 "\""))))
diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog
index 69851ac5046..91a6c869a21 100644
--- a/lisp/url/ChangeLog
+++ b/lisp/url/ChangeLog
@@ -1,3 +1,64 @@
12004-10-12 Simon Josefsson <jas@extundo.com>
2
3 * url-vars.el (url-gateway-method): Add new method `tls'.
4
5 * url-news.el (url-snews): Use nntp-open-tls-stream if
6 url-gateway-method is tls.
7
8 * url-ldap.el (url-ldap-certificate-formatter): Use
9 tls-certificate-information if ssl.el is not available.
10
11 * url-https.el (url-https-create-secure-wrapper): Use tls if ssl
12 is not available.
13
14 * url-gw.el (url-open-stream): Support tls url-gateway-method.
15 (url-open-stream): Likewise.
16
172004-10-10 Lars Hansen <larsh@math.ku.dk>
18
19 * url-auth.el: Fix copyright notice.
20
21 * url-cache.el: Fix copyright notice.
22
23 * url-cookie.el: Fix copyright notice.
24
25 * url-dired.el: Fix copyright notice.
26
27 * url-file.el: Fix copyright notice.
28
29 * url-ftp.el: Fix copyright notice.
30
31 * url-handlers.el: Fix copyright notice.
32
33 * url-history.el: Fix copyright notice.
34
35 * url-irc.el: Fix copyright notice.
36
37 * url-mailto.el: Fix copyright notice.
38
39 * url-methods.el: Fix copyright notice.
40
41 * url-misc.el: Fix copyright notice.
42
43 * url-news.el: Fix copyright notice.
44
45 * url-nfs.el: Fix copyright notice.
46
47 * url-parse.el: Fix copyright notice.
48
49 * url-privacy.el: Fix copyright notice.
50
51 * url-vars.el: Fix copyright notice.
52
53 * url.el: Fix copyright notice.
54
55 * url-util.el: Fix copyright notice.
56
572004-10-06 Stefan Monnier <monnier@iro.umontreal.ca>
58
59 * url-handlers.el (url-insert-file-contents): Use the URL to decide the
60 encoding, not the buffer-file-name (which might not even exist).
61
12004-09-20 Stefan Monnier <monnier@iro.umontreal.ca> 622004-09-20 Stefan Monnier <monnier@iro.umontreal.ca>
2 63
3 * url-handlers.el (url-insert-file-contents): Decode contents. 64 * url-handlers.el (url-insert-file-contents): Decode contents.
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
new file mode 100644
index 00000000000..39bb730bebc
--- /dev/null
+++ b/lisp/url/url-auth.el
@@ -0,0 +1,316 @@
1;;; url-auth.el --- Uniform Resource Locator authorization modules
2;; Keywords: comm, data, processes, hypermedia
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25(require 'url-vars)
26(require 'url-parse)
27(autoload 'url-warn "url")
28
29(defsubst url-auth-user-prompt (url realm)
30 "String to usefully prompt for a username."
31 (concat "Username [for "
32 (or realm (url-truncate-url-for-viewing
33 (url-recreate-url url)
34 (- (window-width) 10 20)))
35 "]: "))
36
37;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38;;; Basic authorization code
39;;; ------------------------
40;;; This implements the BASIC authorization type. See the online
41;;; documentation at
42;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
43;;; for the complete documentation on this type.
44;;;
45;;; This is very insecure, but it works as a proof-of-concept
46;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47(defvar url-basic-auth-storage 'url-http-real-basic-auth-storage
48 "Where usernames and passwords are stored.
49
50Must be a symbol pointing to another variable that will actually store
51the information. The value of this variable is an assoc list of assoc
52lists. The first assoc list is keyed by the server name. The cdr of
53this is an assoc list based on the 'directory' specified by the url we
54are looking up.")
55
56(defun url-basic-auth (url &optional prompt overwrite realm args)
57 "Get the username/password for the specified URL.
58If optional argument PROMPT is non-nil, ask for the username/password
59to use for the url and its descendants. If optional third argument
60OVERWRITE is non-nil, overwrite the old username/password pair if it
61is found in the assoc list. If REALM is specified, use that as the realm
62instead of the pathname inheritance method."
63 (let* ((href (if (stringp url)
64 (url-generic-parse-url url)
65 url))
66 (server (url-host href))
67 (port (url-port href))
68 (path (url-filename href))
69 user pass byserv retval data)
70 (setq server (format "%s:%d" server port)
71 path (cond
72 (realm realm)
73 ((string-match "/$" path) path)
74 (t (url-basepath path)))
75 byserv (cdr-safe (assoc server
76 (symbol-value url-basic-auth-storage))))
77 (cond
78 ((and prompt (not byserv))
79 (setq user (read-string (url-auth-user-prompt url realm)
80 (user-real-login-name))
81 pass (funcall url-passwd-entry-func "Password: "))
82 (set url-basic-auth-storage
83 (cons (list server
84 (cons path
85 (setq retval
86 (base64-encode-string
87 (format "%s:%s" user pass)))))
88 (symbol-value url-basic-auth-storage))))
89 (byserv
90 (setq retval (cdr-safe (assoc path byserv)))
91 (if (and (not retval)
92 (string-match "/" path))
93 (while (and byserv (not retval))
94 (setq data (car (car byserv)))
95 (if (or (not (string-match "/" data)) ; Its a realm - take it!
96 (and
97 (>= (length path) (length data))
98 (string= data (substring path 0 (length data)))))
99 (setq retval (cdr (car byserv))))
100 (setq byserv (cdr byserv))))
101 (if (or (and (not retval) prompt) overwrite)
102 (progn
103 (setq user (read-string (url-auth-user-prompt url realm)
104 (user-real-login-name))
105 pass (funcall url-passwd-entry-func "Password: ")
106 retval (base64-encode-string (format "%s:%s" user pass))
107 byserv (assoc server (symbol-value url-basic-auth-storage)))
108 (setcdr byserv
109 (cons (cons path retval) (cdr byserv))))))
110 (t (setq retval nil)))
111 (if retval (setq retval (concat "Basic " retval)))
112 retval))
113
114;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
115;;; Digest authorization code
116;;; ------------------------
117;;; This implements the DIGEST authorization type. See the internet draft
118;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
119;;; for the complete documentation on this type.
120;;;
121;;; This is very secure
122;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
123(defvar url-digest-auth-storage nil
124 "Where usernames and passwords are stored. Its value is an assoc list of
125assoc lists. The first assoc list is keyed by the server name. The cdr of
126this is an assoc list based on the 'directory' specified by the url we are
127looking up.")
128
129(defun url-digest-auth-create-key (username password realm method uri)
130 "Create a key for digest authentication method"
131 (let* ((info (if (stringp uri)
132 (url-generic-parse-url uri)
133 uri))
134 (a1 (md5 (concat username ":" realm ":" password)))
135 (a2 (md5 (concat method ":" (url-filename info)))))
136 (list a1 a2)))
137
138(defun url-digest-auth (url &optional prompt overwrite realm args)
139 "Get the username/password for the specified URL.
140If optional argument PROMPT is non-nil, ask for the username/password
141to use for the url and its descendants. If optional third argument
142OVERWRITE is non-nil, overwrite the old username/password pair if it
143is found in the assoc list. If REALM is specified, use that as the realm
144instead of hostname:portnum."
145 (if args
146 (let* ((href (if (stringp url)
147 (url-generic-parse-url url)
148 url))
149 (server (url-host href))
150 (port (url-port href))
151 (path (url-filename href))
152 user pass byserv retval data)
153 (setq path (cond
154 (realm realm)
155 ((string-match "/$" path) path)
156 (t (url-basepath path)))
157 server (format "%s:%d" server port)
158 byserv (cdr-safe (assoc server url-digest-auth-storage)))
159 (cond
160 ((and prompt (not byserv))
161 (setq user (read-string (url-auth-user-prompt url realm)
162 (user-real-login-name))
163 pass (funcall url-passwd-entry-func "Password: ")
164 url-digest-auth-storage
165 (cons (list server
166 (cons path
167 (setq retval
168 (cons user
169 (url-digest-auth-create-key
170 user pass realm
171 (or url-request-method "GET")
172 url)))))
173 url-digest-auth-storage)))
174 (byserv
175 (setq retval (cdr-safe (assoc path byserv)))
176 (if (and (not retval) ; no exact match, check directories
177 (string-match "/" path)) ; not looking for a realm
178 (while (and byserv (not retval))
179 (setq data (car (car byserv)))
180 (if (or (not (string-match "/" data))
181 (and
182 (>= (length path) (length data))
183 (string= data (substring path 0 (length data)))))
184 (setq retval (cdr (car byserv))))
185 (setq byserv (cdr byserv))))
186 (if (or (and (not retval) prompt) overwrite)
187 (progn
188 (setq user (read-string (url-auth-user-prompt url realm)
189 (user-real-login-name))
190 pass (funcall url-passwd-entry-func "Password: ")
191 retval (setq retval
192 (cons user
193 (url-digest-auth-create-key
194 user pass realm
195 (or url-request-method "GET")
196 url)))
197 byserv (assoc server url-digest-auth-storage))
198 (setcdr byserv
199 (cons (cons path retval) (cdr byserv))))))
200 (t (setq retval nil)))
201 (if retval
202 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
203 (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
204 (format
205 (concat "Digest username=\"%s\", realm=\"%s\","
206 "nonce=\"%s\", uri=\"%s\","
207 "response=\"%s\", opaque=\"%s\"")
208 (nth 0 retval) realm nonce (url-filename href)
209 (md5 (concat (nth 1 retval) ":" nonce ":"
210 (nth 2 retval))) opaque))))))
211
212(defvar url-registered-auth-schemes nil
213 "A list of the registered authorization schemes and various and sundry
214information associated with them.")
215
216;;;###autoload
217(defun url-get-authentication (url realm type prompt &optional args)
218 "Return an authorization string suitable for use in the WWW-Authenticate
219header in an HTTP/1.0 request.
220
221URL is the url you are requesting authorization to. This can be either a
222 string representing the URL, or the parsed representation returned by
223 `url-generic-parse-url'
224REALM is the realm at a specific site we are looking for. This should be a
225 string specifying the exact realm, or nil or the symbol 'any' to
226 specify that the filename portion of the URL should be used as the
227 realm
228TYPE is the type of authentication to be returned. This is either a string
229 representing the type (basic, digest, etc), or nil or the symbol 'any'
230 to specify that any authentication is acceptable. If requesting 'any'
231 the strongest matching authentication will be returned. If this is
232 wrong, its no big deal, the error from the server will specify exactly
233 what type of auth to use
234PROMPT is boolean - specifies whether to ask the user for a username/password
235 if one cannot be found in the cache"
236 (if (not realm)
237 (setq realm (cdr-safe (assoc "realm" args))))
238 (if (stringp url)
239 (setq url (url-generic-parse-url url)))
240 (if (or (null type) (eq type 'any))
241 ;; Whooo doogies!
242 ;; Go through and get _all_ the authorization strings that could apply
243 ;; to this URL, store them along with the 'rating' we have in the list
244 ;; of schemes, then sort them so that the 'best' is at the front of the
245 ;; list, then get the car, then get the cdr.
246 ;; Zooom zooom zoooooom
247 (cdr-safe
248 (car-safe
249 (sort
250 (mapcar
251 (function
252 (lambda (scheme)
253 (if (fboundp (car (cdr scheme)))
254 (cons (cdr (cdr scheme))
255 (funcall (car (cdr scheme)) url nil nil realm))
256 (cons 0 nil))))
257 url-registered-auth-schemes)
258 (function
259 (lambda (x y)
260 (cond
261 ((null (cdr x)) nil)
262 ((and (cdr x) (null (cdr y))) t)
263 ((and (cdr x) (cdr y))
264 (>= (car x) (car y)))
265 (t nil)))))))
266 (if (symbolp type) (setq type (symbol-name type)))
267 (let* ((scheme (car-safe
268 (cdr-safe (assoc (downcase type)
269 url-registered-auth-schemes)))))
270 (if (and scheme (fboundp scheme))
271 (funcall scheme url prompt
272 (and prompt
273 (funcall scheme url nil nil realm args))
274 realm args)))))
275
276;;;###autoload
277(defun url-register-auth-scheme (type &optional function rating)
278 "Register an HTTP authentication method.
279
280TYPE is a string or symbol specifying the name of the method. This
281 should be the same thing you expect to get returned in an Authenticate
282 header in HTTP/1.0 - it will be downcased.
283FUNCTION is the function to call to get the authorization information. This
284 defaults to `url-?-auth', where ? is TYPE
285RATING a rating between 1 and 10 of the strength of the authentication.
286 This is used when asking for the best authentication for a specific
287 URL. The item with the highest rating is returned."
288 (let* ((type (cond
289 ((stringp type) (downcase type))
290 ((symbolp type) (downcase (symbol-name type)))
291 (t (error "Bad call to `url-register-auth-scheme'"))))
292 (function (or function (intern (concat "url-" type "-auth"))))
293 (rating (cond
294 ((null rating) 2)
295 ((stringp rating) (string-to-int rating))
296 (t rating)))
297 (node (assoc type url-registered-auth-schemes)))
298 (if (not (fboundp function))
299 (url-warn 'security
300 (format (concat
301 "Tried to register `%s' as an auth scheme"
302 ", but it is not a function!") function)))
303
304 (if node
305 (setcdr node (cons function rating))
306 (setq url-registered-auth-schemes
307 (cons (cons type (cons function rating))
308 url-registered-auth-schemes)))))
309
310(defun url-auth-registered (scheme)
311 ;; Return non-nil iff SCHEME is registered as an auth type
312 (assoc scheme url-registered-auth-schemes))
313
314(provide 'url-auth)
315
316;;; arch-tag: 04058625-616d-44e4-9dbf-4b46b00b2a91
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
new file mode 100644
index 00000000000..1e3374639e1
--- /dev/null
+++ b/lisp/url/url-cache.el
@@ -0,0 +1,202 @@
1;;; url-cache.el --- Uniform Resource Locator retrieval tool
2;; Keywords: comm, data, processes, hypermedia
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24(require 'url-parse)
25(require 'url-util)
26
27(defcustom url-cache-directory
28 (expand-file-name "cache" url-configuration-directory)
29 "*The directory where cache files should be stored."
30 :type 'directory
31 :group 'url-file)
32
33;; Cache manager
34(defun url-cache-file-writable-p (file)
35 "Follows the documentation of `file-writable-p', unlike `file-writable-p'."
36 (and (file-writable-p file)
37 (if (file-exists-p file)
38 (not (file-directory-p file))
39 (file-directory-p (file-name-directory file)))))
40
41(defun url-cache-prepare (file)
42 "Makes it possible to cache data in FILE.
43Creates any necessary parent directories, deleting any non-directory files
44that would stop this. Returns nil if parent directories can not be
45created. If FILE already exists as a non-directory, it changes
46permissions of FILE or deletes FILE to make it possible to write a new
47version of FILE. Returns nil if this can not be done. Returns nil if
48FILE already exists as a directory. Otherwise, returns t, indicating that
49FILE can be created or overwritten."
50 (cond
51 ((url-cache-file-writable-p file)
52 t)
53 ((file-directory-p file)
54 nil)
55 (t
56 (condition-case ()
57 (or (make-directory (file-name-directory file) t) t)
58 (error nil)))))
59
60;;;###autoload
61(defun url-store-in-cache (&optional buff)
62 "Store buffer BUFF in the cache."
63 (if (not (and buff (get-buffer buff)))
64 nil
65 (save-excursion
66 (and buff (set-buffer buff))
67 (let* ((fname (url-cache-create-filename (url-view-url t))))
68 (if (url-cache-prepare fname)
69 (let ((coding-system-for-write 'binary))
70 (write-region (point-min) (point-max) fname nil 5)))))))
71
72;;;###autoload
73(defun url-is-cached (url)
74 "Return non-nil if the URL is cached."
75 (let* ((fname (url-cache-create-filename url))
76 (attribs (file-attributes fname)))
77 (and fname ; got a filename
78 (file-exists-p fname) ; file exists
79 (not (eq (nth 0 attribs) t)) ; Its not a directory
80 (nth 5 attribs)))) ; Can get last mod-time
81
82(defun url-cache-create-filename-human-readable (url)
83 "Return a filename in the local cache for URL"
84 (if url
85 (let* ((url (if (vectorp url) (url-recreate-url url) url))
86 (urlobj (url-generic-parse-url url))
87 (protocol (url-type urlobj))
88 (hostname (url-host urlobj))
89 (host-components
90 (cons
91 (user-real-login-name)
92 (cons (or protocol "file")
93 (reverse (split-string (or hostname "localhost")
94 (eval-when-compile
95 (regexp-quote ".")))))))
96 (fname (url-filename urlobj)))
97 (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
98 (setq fname (substring fname 1 nil)))
99 (if fname
100 (let ((slash nil))
101 (setq fname
102 (mapconcat
103 (function
104 (lambda (x)
105 (cond
106 ((and (= ?/ x) slash)
107 (setq slash nil)
108 "%2F")
109 ((= ?/ x)
110 (setq slash t)
111 "/")
112 (t
113 (setq slash nil)
114 (char-to-string x))))) fname ""))))
115
116 (setq fname (and fname
117 (mapconcat
118 (function (lambda (x)
119 (if (= x ?~) "" (char-to-string x))))
120 fname ""))
121 fname (cond
122 ((null fname) nil)
123 ((or (string= "" fname) (string= "/" fname))
124 url-directory-index-file)
125 ((= (string-to-char fname) ?/)
126 (if (string= (substring fname -1 nil) "/")
127 (concat fname url-directory-index-file)
128 (substring fname 1 nil)))
129 (t
130 (if (string= (substring fname -1 nil) "/")
131 (concat fname url-directory-index-file)
132 fname))))
133 (and fname
134 (expand-file-name fname
135 (expand-file-name
136 (mapconcat 'identity host-components "/")
137 url-cache-directory))))))
138
139(defun url-cache-create-filename-using-md5 (url)
140 "Create a cached filename using MD5.
141Very fast if you have an `md5' primitive function, suitably fast otherwise."
142 (require 'md5)
143 (if url
144 (let* ((url (if (vectorp url) (url-recreate-url url) url))
145 (checksum (md5 url))
146 (urlobj (url-generic-parse-url url))
147 (protocol (url-type urlobj))
148 (hostname (url-host urlobj))
149 (host-components
150 (cons
151 (user-real-login-name)
152 (cons (or protocol "file")
153 (nreverse
154 (delq nil
155 (split-string (or hostname "localhost")
156 (eval-when-compile
157 (regexp-quote "."))))))))
158 (fname (url-filename urlobj)))
159 (and fname
160 (expand-file-name checksum
161 (expand-file-name
162 (mapconcat 'identity host-components "/")
163 url-cache-directory))))))
164
165(defcustom url-cache-creation-function 'url-cache-create-filename-using-md5
166 "*What function to use to create a cached filename."
167 :type '(choice (const :tag "MD5 of filename (low collision rate)"
168 :value url-cache-create-filename-using-md5)
169 (const :tag "Human readable filenames (higher collision rate)"
170 :value url-cache-create-filename-human-readable)
171 (function :tag "Other"))
172 :group 'url-cache)
173
174(defun url-cache-create-filename (url)
175 (funcall url-cache-creation-function url))
176
177;;;###autoload
178(defun url-cache-extract (fnam)
179 "Extract FNAM from the local disk cache"
180 (erase-buffer)
181 (insert-file-contents-literally fnam))
182
183;;;###autoload
184(defun url-cache-expired (url mod)
185 "Return t iff a cached file has expired."
186 (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
187 (type (url-type urlobj)))
188 (cond
189 (url-standalone-mode
190 (not (file-exists-p (url-cache-create-filename url))))
191 ((string= type "http")
192 t)
193 ((member type '("file" "ftp"))
194 (if (or (equal mod '(0 0)) (not mod))
195 t
196 (or (> (nth 0 mod) (nth 0 (current-time)))
197 (> (nth 1 mod) (nth 1 (current-time))))))
198 (t nil))))
199
200(provide 'url-cache)
201
202;;; arch-tag: 95b050a6-8e81-4f23-8e63-191b9d1d657c
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
new file mode 100644
index 00000000000..9f7db867597
--- /dev/null
+++ b/lisp/url/url-cookie.el
@@ -0,0 +1,466 @@
1;;; url-cookie.el --- Netscape Cookie support
2
3;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc.
4
5;; Keywords: comm, data, processes, hypermedia
6
7;; This file is part of GNU Emacs.
8;;
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13;;
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to the
21;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;; Boston, MA 02111-1307, USA.
23
24;;; Commentary:
25
26;;; Code:
27
28(require 'timezone)
29(require 'url-util)
30(require 'url-parse)
31(eval-when-compile (require 'cl))
32
33;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
34;; 'open standard' defining this crap.
35;;
36;; A cookie is stored internally as a vector of 7 slots
37;; [ 'cookie name value expires path domain secure ]
38
39(defsubst url-cookie-name (cookie) (aref cookie 1))
40(defsubst url-cookie-value (cookie) (aref cookie 2))
41(defsubst url-cookie-expires (cookie) (aref cookie 3))
42(defsubst url-cookie-path (cookie) (aref cookie 4))
43(defsubst url-cookie-domain (cookie) (aref cookie 5))
44(defsubst url-cookie-secure (cookie) (aref cookie 6))
45
46(defsubst url-cookie-set-name (cookie val) (aset cookie 1 val))
47(defsubst url-cookie-set-value (cookie val) (aset cookie 2 val))
48(defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))
49(defsubst url-cookie-set-path (cookie val) (aset cookie 4 val))
50(defsubst url-cookie-set-domain (cookie val) (aset cookie 5 val))
51(defsubst url-cookie-set-secure (cookie val) (aset cookie 6 val))
52(defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))
53
54(defsubst url-cookie-create (&rest args)
55 (let ((retval (make-vector 7 nil)))
56 (aset retval 0 'cookie)
57 (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))
58 (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))
59 (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
60 (url-cookie-set-path retval (url-cookie-retrieve-arg :path args))
61 (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
62 (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
63 retval))
64
65(defun url-cookie-p (obj)
66 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
67
68(defgroup url-cookie nil
69 "URL cookies"
70 :prefix "url-"
71 :prefix "url-cookie-"
72 :group 'url)
73
74(defvar url-cookie-storage nil "Where cookies are stored.")
75(defvar url-cookie-secure-storage nil "Where secure cookies are stored.")
76(defcustom url-cookie-file nil "*Where cookies are stored on disk."
77 :type '(choice (const :tag "Default" :value nil) file)
78 :group 'url-file
79 :group 'url-cookie)
80
81(defcustom url-cookie-confirmation nil
82 "*If non-nil, confirmation by the user is required to accept HTTP cookies."
83 :type 'boolean
84 :group 'url-cookie)
85
86(defcustom url-cookie-multiple-line nil
87 "*If nil, HTTP requests put all cookies for the server on one line.
88Some web servers, such as http://www.hotmail.com/, only accept cookies
89when they are on one line. This is broken behaviour, but just try
90telling Microsoft that.")
91
92(defvar url-cookies-changed-since-last-save nil
93 "Whether the cookies list has changed since the last save operation.")
94
95;;;###autoload
96(defun url-cookie-parse-file (&optional fname)
97 (setq fname (or fname url-cookie-file))
98 (condition-case ()
99 (load fname nil t)
100 (error (message "Could not load cookie file %s" fname))))
101
102(defun url-cookie-clean-up (&optional secure)
103 (let* (
104 (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
105 (val (symbol-value var))
106 (cur nil)
107 (new nil)
108 (cookies nil)
109 (cur-cookie nil)
110 (new-cookies nil)
111 )
112 (while val
113 (setq cur (car val)
114 val (cdr val)
115 new-cookies nil
116 cookies (cdr cur))
117 (while cookies
118 (setq cur-cookie (car cookies)
119 cookies (cdr cookies))
120 (if (or (not (url-cookie-p cur-cookie))
121 (url-cookie-expired-p cur-cookie)
122 (null (url-cookie-expires cur-cookie)))
123 nil
124 (setq new-cookies (cons cur-cookie new-cookies))))
125 (if (not new-cookies)
126 nil
127 (setcdr cur new-cookies)
128 (setq new (cons cur new))))
129 (set var new)))
130
131;;;###autoload
132(defun url-cookie-write-file (&optional fname)
133 (setq fname (or fname url-cookie-file))
134 (cond
135 ((not url-cookies-changed-since-last-save) nil)
136 ((not (file-writable-p fname))
137 (message "Cookies file %s (see variable `url-cookie-file') is unwritable." fname))
138 (t
139 (url-cookie-clean-up)
140 (url-cookie-clean-up t)
141 (save-excursion
142 (set-buffer (get-buffer-create " *cookies*"))
143 (erase-buffer)
144 (fundamental-mode)
145 (insert ";; Emacs-W3 HTTP cookies file\n"
146 ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
147 "(setq url-cookie-storage\n '")
148 (pp url-cookie-storage (current-buffer))
149 (insert ")\n(setq url-cookie-secure-storage\n '")
150 (pp url-cookie-secure-storage (current-buffer))
151 (insert ")\n")
152 (write-file fname)
153 (kill-buffer (current-buffer))))))
154
155(defun url-cookie-store (name value &optional expires domain path secure)
156 "Store a netscape-style cookie."
157 (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
158 (tmp storage)
159 (cur nil)
160 (found-domain nil))
161
162 ;; First, look for a matching domain
163 (setq found-domain (assoc domain storage))
164
165 (if found-domain
166 ;; Need to either stick the new cookie in existing domain storage
167 ;; or possibly replace an existing cookie if the names match.
168 (progn
169 (setq storage (cdr found-domain)
170 tmp nil)
171 (while storage
172 (setq cur (car storage)
173 storage (cdr storage))
174 (if (and (equal path (url-cookie-path cur))
175 (equal name (url-cookie-name cur)))
176 (progn
177 (url-cookie-set-expires cur expires)
178 (url-cookie-set-value cur value)
179 (setq tmp t))))
180 (if (not tmp)
181 ;; New cookie
182 (setcdr found-domain (cons
183 (url-cookie-create :name name
184 :value value
185 :expires expires
186 :domain domain
187 :path path
188 :secure secure)
189 (cdr found-domain)))))
190 ;; Need to add a new top-level domain
191 (setq tmp (url-cookie-create :name name
192 :value value
193 :expires expires
194 :domain domain
195 :path path
196 :secure secure))
197 (cond
198 (storage
199 (setcdr storage (cons (list domain tmp) (cdr storage))))
200 (secure
201 (setq url-cookie-secure-storage (list (list domain tmp))))
202 (t
203 (setq url-cookie-storage (list (list domain tmp))))))))
204
205(defun url-cookie-expired-p (cookie)
206 (let* (
207 (exp (url-cookie-expires cookie))
208 (cur-date (and exp (timezone-parse-date (current-time-string))))
209 (exp-date (and exp (timezone-parse-date exp)))
210 (cur-greg (and cur-date (timezone-absolute-from-gregorian
211 (string-to-int (aref cur-date 1))
212 (string-to-int (aref cur-date 2))
213 (string-to-int (aref cur-date 0)))))
214 (exp-greg (and exp (timezone-absolute-from-gregorian
215 (string-to-int (aref exp-date 1))
216 (string-to-int (aref exp-date 2))
217 (string-to-int (aref exp-date 0)))))
218 (diff-in-days (and exp (- cur-greg exp-greg)))
219 )
220 (cond
221 ((not exp) nil) ; No expiry == expires at browser quit
222 ((< diff-in-days 0) nil) ; Expires sometime after today
223 ((> diff-in-days 0) t) ; Expired before today
224 (t ; Expires sometime today, check times
225 (let* ((cur-time (timezone-parse-time (aref cur-date 3)))
226 (exp-time (timezone-parse-time (aref exp-date 3)))
227 (cur-norm (+ (* 360 (string-to-int (aref cur-time 2)))
228 (* 60 (string-to-int (aref cur-time 1)))
229 (* 1 (string-to-int (aref cur-time 0)))))
230 (exp-norm (+ (* 360 (string-to-int (aref exp-time 2)))
231 (* 60 (string-to-int (aref exp-time 1)))
232 (* 1 (string-to-int (aref exp-time 0))))))
233 (> (- cur-norm exp-norm) 1))))))
234
235;;;###autoload
236(defun url-cookie-retrieve (host path &optional secure)
237 "Retrieve all the netscape-style cookies for a specified HOST and PATH."
238 (let ((storage (if secure
239 (append url-cookie-secure-storage url-cookie-storage)
240 url-cookie-storage))
241 (case-fold-search t)
242 (cookies nil)
243 (cur nil)
244 (retval nil)
245 (path-regexp nil))
246 (while storage
247 (setq cur (car storage)
248 storage (cdr storage)
249 cookies (cdr cur))
250 (if (and (car cur)
251 (string-match (concat "^.*" (regexp-quote (car cur)) "$") host))
252 ;; The domains match - a possible hit!
253 (while cookies
254 (setq cur (car cookies)
255 cookies (cdr cookies)
256 path-regexp (concat "^" (regexp-quote
257 (url-cookie-path cur))))
258 (if (and (string-match path-regexp path)
259 (not (url-cookie-expired-p cur)))
260 (setq retval (cons cur retval))))))
261 retval))
262
263;;;###autolaod
264(defun url-cookie-generate-header-lines (host path secure)
265 (let* ((cookies (url-cookie-retrieve host path secure))
266 (retval nil)
267 (cur nil)
268 (chunk nil))
269 ;; Have to sort this for sending most specific cookies first
270 (setq cookies (and cookies
271 (sort cookies
272 (function
273 (lambda (x y)
274 (> (length (url-cookie-path x))
275 (length (url-cookie-path y))))))))
276 (while cookies
277 (setq cur (car cookies)
278 cookies (cdr cookies)
279 chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
280 retval (if (and url-cookie-multiple-line
281 (< 80 (+ (length retval) (length chunk) 4)))
282 (concat retval "\r\nCookie: " chunk)
283 (if retval
284 (concat retval "; " chunk)
285 (concat "Cookie: " chunk)))))
286 (if retval
287 (concat retval "\r\n")
288 "")))
289
290(defvar url-cookie-two-dot-domains
291 (concat "\\.\\("
292 (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
293 "\\|")
294 "\\)$")
295 "A regexp of top level domains that only require two matching
296'.'s in the domain name in order to set a cookie.")
297
298(defcustom url-cookie-trusted-urls nil
299 "*A list of regular expressions matching URLs to always accept cookies from."
300 :type '(repeat regexp)
301 :group 'url-cookie)
302
303(defcustom url-cookie-untrusted-urls nil
304 "*A list of regular expressions matching URLs to never accept cookies from."
305 :type '(repeat regexp)
306 :group 'url-cookie)
307
308(defun url-cookie-host-can-set-p (host domain)
309 (let ((numdots 0)
310 (tmp domain)
311 (last nil)
312 (case-fold-search t)
313 (mindots 3))
314 (while (setq last (string-match "\\." domain last))
315 (setq numdots (1+ numdots)
316 last (1+ last)))
317 (if (string-match url-cookie-two-dot-domains domain)
318 (setq mindots 2))
319 (cond
320 ((string= host domain) ; Apparently netscape lets you do this
321 t)
322 ((>= numdots mindots) ; We have enough dots in domain name
323 ;; Need to check and make sure the host is actually _in_ the
324 ;; domain it wants to set a cookie for though.
325 (string-match (concat (regexp-quote domain) "$") host))
326 (t
327 nil))))
328
329;;;###autoload
330(defun url-cookie-handle-set-cookie (str)
331 (setq url-cookies-changed-since-last-save t)
332 (let* ((args (url-parse-args str t))
333 (case-fold-search t)
334 (secure (and (assoc-string "secure" args t) t))
335 (domain (or (cdr-safe (assoc-string "domain" args t))
336 (url-host url-current-object)))
337 (current-url (url-view-url t))
338 (trusted url-cookie-trusted-urls)
339 (untrusted url-cookie-untrusted-urls)
340 (expires (cdr-safe (assoc-string "expires" args t)))
341 (path (or (cdr-safe (assoc-string "path" args t))
342 (file-name-directory
343 (url-filename url-current-object))))
344 (rest nil))
345 (while args
346 (if (not (member (downcase (car (car args)))
347 '("secure" "domain" "expires" "path")))
348 (setq rest (cons (car args) rest)))
349 (setq args (cdr args)))
350
351 ;; Sometimes we get dates that the timezone package cannot handle very
352 ;; gracefully - take care of this here, instead of in url-cookie-expired-p
353 ;; to speed things up.
354 (if (and expires
355 (string-match
356 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
357 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
358 expires))
359 (setq expires (concat (match-string 1 expires) " "
360 (match-string 2 expires) " "
361 (match-string 3 expires) " "
362 (match-string 4 expires) " ["
363 (match-string 5 expires) "]")))
364
365 ;; This one is for older Emacs/XEmacs variants that don't
366 ;; understand this format without tenths of a second in it.
367 ;; Wednesday, 30-Dec-2037 16:00:00 GMT
368 ;; - vs -
369 ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT
370 (if (and expires
371 (string-match
372 "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
373 expires))
374 (setq expires (concat (match-string 1 expires) "-" ; day
375 (match-string 2 expires) "-" ; month
376 (match-string 3 expires) " " ; year
377 (match-string 4 expires) ".00 " ; hour:minutes:seconds
378 (match-string 6 expires)))) ":" ; timezone
379
380 (while (consp trusted)
381 (if (string-match (car trusted) current-url)
382 (setq trusted (- (match-end 0) (match-beginning 0)))
383 (pop trusted)))
384 (while (consp untrusted)
385 (if (string-match (car untrusted) current-url)
386 (setq untrusted (- (match-end 0) (match-beginning 0)))
387 (pop untrusted)))
388 (if (and trusted untrusted)
389 ;; Choose the more specific match
390 (if (> trusted untrusted)
391 (setq untrusted nil)
392 (setq trusted nil)))
393 (cond
394 (untrusted
395 ;; The site was explicity marked as untrusted by the user
396 nil)
397 ((or (eq url-privacy-level 'paranoid)
398 (and (listp url-privacy-level) (memq 'cookies url-privacy-level)))
399 ;; user never wants cookies
400 nil)
401 ((and url-cookie-confirmation
402 (not trusted)
403 (save-window-excursion
404 (with-output-to-temp-buffer "*Cookie Warning*"
405 (mapcar
406 (function
407 (lambda (x)
408 (princ (format "%s - %s" (car x) (cdr x))))) rest))
409 (prog1
410 (not (funcall url-confirmation-func
411 (format "Allow %s to set these cookies? "
412 (url-host url-current-object))))
413 (if (get-buffer "*Cookie Warning*")
414 (kill-buffer "*Cookie Warning*")))))
415 ;; user wants to be asked, and declined.
416 nil)
417 ((url-cookie-host-can-set-p (url-host url-current-object) domain)
418 ;; Cookie is accepted by the user, and passes our security checks
419 (let ((cur nil))
420 (while rest
421 (setq cur (pop rest))
422 (url-cookie-store (car cur) (cdr cur)
423 expires domain path secure))))
424 (t
425 (message "%s tried to set a cookie for domain %s - rejected."
426 (url-host url-current-object) domain)))))
427
428(defvar url-cookie-timer nil)
429
430(defcustom url-cookie-save-interval 3600
431 "*The number of seconds between automatic saves of cookies.
432Default is 1 hour. Note that if you change this variable outside of
433the `customize' interface after `url-do-setup' has been run, you need
434to run the `url-cookie-setup-save-timer' function manually."
435 :set (function (lambda (var val)
436 (set-default var val)
437 (and (featurep 'url)
438 (fboundp 'url-cookie-setup-save-timer)
439 (url-cookie-setup-save-timer))))
440 :type 'integer
441 :group 'url)
442
443;;;###autoload
444(defun url-cookie-setup-save-timer ()
445 "Reset the cookie saver timer."
446 (interactive)
447 (ignore-errors
448 (cond ((fboundp 'cancel-timer) (cancel-timer url-cookie-timer))
449 ((fboundp 'delete-itimer) (delete-itimer url-cookie-timer))))
450 (setq url-cookie-timer nil)
451 (if url-cookie-save-interval
452 (setq url-cookie-timer
453 (cond
454 ((fboundp 'run-at-time)
455 (run-at-time url-cookie-save-interval
456 url-cookie-save-interval
457 'url-cookie-write-file))
458 ((fboundp 'start-itimer)
459 (start-itimer "url-cookie-saver" 'url-cookie-write-file
460 url-cookie-save-interval
461 url-cookie-save-interval))))))
462
463(provide 'url-cookie)
464
465;; arch-tag: 2568751b-6452-4398-aa2d-303edadb54d7
466;;; url-cookie.el ends here
diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el
new file mode 100644
index 00000000000..73307412e1e
--- /dev/null
+++ b/lisp/url/url-dired.el
@@ -0,0 +1,100 @@
1;;; url-dired.el --- URL Dired minor mode
2;; Keywords: comm, files
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25(autoload 'w3-fetch "w3")
26(autoload 'w3-open-local "w3")
27(autoload 'dired-get-filename "dired")
28
29(defvar url-dired-minor-mode-map
30 (let ((map (make-sparse-keymap)))
31 (define-key map "\C-m" 'url-dired-find-file)
32 (if (featurep 'xemacs)
33 (define-key map [button2] 'url-dired-find-file-mouse)
34 (define-key map [mouse-2] 'url-dired-find-file-mouse))
35 map)
36 "Keymap used when browsing directories.")
37
38(defvar url-dired-minor-mode nil
39 "Whether we are in url-dired-minor-mode")
40
41(make-variable-buffer-local 'url-dired-minor-mode)
42
43(defun url-dired-find-file ()
44 "In dired, visit the file or directory named on this line, using Emacs-W3."
45 (interactive)
46 (let ((filename (dired-get-filename)))
47 (cond ((string-match "/\\(.*@.*\\):\\(/.*\\)" filename)
48 (w3-fetch (concat "file://" (match-string 1 filename) (match-string 2 filename))))
49 (t
50 (w3-open-local filename)))))
51
52(defun url-dired-find-file-mouse (event)
53 "In dired, visit the file or directory name you click on, using Emacs-W3."
54 (interactive "@e")
55 (mouse-set-point event)
56 (url-dired-find-file))
57
58(defun url-dired-minor-mode (&optional arg)
59 "Minor mode for directory browsing with Emacs-W3."
60 (interactive "P")
61 (cond
62 ((null arg)
63 (setq url-dired-minor-mode (not url-dired-minor-mode)))
64 ((equal 0 arg)
65 (setq url-dired-minor-mode nil))
66 (t
67 (setq url-dired-minor-mode t))))
68
69(if (not (fboundp 'add-minor-mode))
70 (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
71 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
72TOGGLE is a symbol which is used as the variable which toggle the minor mode,
73NAME is the name that should appear in the modeline (it should be a string
74beginning with a space), KEYMAP is a keymap to make active when the minor
75mode is active, and AFTER is the toggling symbol used for another minor
76mode. If AFTER is non-nil, then it is used to position the new mode in the
77minor-mode alists. TOGGLE-FUN specifies an interactive function that
78is called to toggle the mode on and off; this affects what appens when
79button2 is pressed on the mode, and when button3 is pressed somewhere
80in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an
81interactive function, TOGGLE is used as the toggle function.
82
83Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
84 (if (not (assq toggle minor-mode-alist))
85 (setq minor-mode-alist (cons (list toggle name) minor-mode-alist)))
86 (if (and keymap (not (assq toggle minor-mode-map-alist)))
87 (setq minor-mode-map-alist (cons (cons toggle keymap)
88 minor-mode-map-alist)))))
89
90(add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map)
91
92(defun url-find-file-dired (dir)
93 "\"Edit\" directory DIR, but with additional URL-friendly bindings."
94 (interactive "DURL Dired (directory): ")
95 (find-file dir)
96 (url-dired-minor-mode t))
97
98(provide 'url-dired)
99
100;;; arch-tag: 2694f21a-43e1-4391-b3cb-cf6e5349f15f
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
index 77c2e74555f..0aa23acc0ec 100644
--- a/lisp/url/url-file.el
+++ b/lisp/url/url-file.el
@@ -1,7 +1,6 @@
1;;; url-file.el --- File retrieval code 1;;; url-file.el --- File retrieval code
2 2
3;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc. 3;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc.
4;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
5 4
6;; Keywords: comm, data, processes 5;; Keywords: comm, data, processes
7 6
diff --git a/lisp/url/url-ftp.el b/lisp/url/url-ftp.el
new file mode 100644
index 00000000000..4346f3910b1
--- /dev/null
+++ b/lisp/url/url-ftp.el
@@ -0,0 +1,42 @@
1;;; url-ftp.el --- FTP wrapper
2;; Keywords: comm, data, processes
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25;; We knew not what we did when we overloaded 'file' to mean 'file'
26;; and 'ftp' back in the dark ages of the web.
27;;
28;; This stub file is just here to please the auto-scheme-loading code
29;; in url-methods.el and just maps everything onto the code in
30;; url-file.
31
32(require 'url-parse)
33(require 'url-file)
34
35(defconst url-ftp-default-port 21 "Default FTP port.")
36(defconst url-ftp-asynchronous-p t "FTP transfers are asynchronous.")
37(defalias 'url-ftp-expand-file-name 'url-default-expander)
38(defalias 'url-ftp 'url-file)
39
40(provide 'url-ftp)
41
42;;; arch-tag: 9c3e70c4-350f-4d4a-bb51-a1e9b459e7dc
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
new file mode 100644
index 00000000000..608827d7cee
--- /dev/null
+++ b/lisp/url/url-gw.el
@@ -0,0 +1,268 @@
1;;; url-gw.el --- Gateway munging for URL loading
2;; Author: Bill Perry <wmperry@gnu.org>
3;; Keywords: comm, data, processes
4
5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6;;; Copyright (c) 1997, 1998, 2004 Free Software Foundation, Inc.
7;;;
8;;; This file is part of GNU Emacs.
9;;;
10;;; GNU Emacs is free software; you can redistribute it and/or modify
11;;; it under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 2, or (at your option)
13;;; any later version.
14;;;
15;;; GNU Emacs is distributed in the hope that it will be useful,
16;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Emacs; see the file COPYING. If not, write to the
22;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;;; Boston, MA 02111-1307, USA.
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25(eval-when-compile (require 'cl))
26(require 'url-vars)
27
28;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program?
29
30(autoload 'socks-open-network-stream "socks")
31(autoload 'open-ssl-stream "ssl")
32(autoload 'open-tls-stream "tls")
33
34(defgroup url-gateway nil
35 "URL gateway variables"
36 :group 'url)
37
38(defcustom url-gateway-local-host-regexp nil
39 "*A regular expression specifying local hostnames/machines."
40 :type '(choice (const nil) regexp)
41 :group 'url-gateway)
42
43(defcustom url-gateway-prompt-pattern
44 "^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?"
45 "*A regular expression matching a shell prompt."
46 :type 'regexp
47 :group 'url-gateway)
48
49(defcustom url-gateway-rlogin-host nil
50 "*What hostname to actually rlog into before doing a telnet."
51 :type '(choice (const nil) string)
52 :group 'url-gateway)
53
54(defcustom url-gateway-rlogin-user-name nil
55 "*Username to log into the remote machine with when using rlogin."
56 :type '(choice (const nil) string)
57 :group 'url-gateway)
58
59(defcustom url-gateway-rlogin-parameters '("telnet" "-8")
60 "*Parameters to `url-open-rlogin'.
61This list will be used as the parameter list given to rsh."
62 :type '(repeat string)
63 :group 'url-gateway)
64
65(defcustom url-gateway-telnet-host nil
66 "*What hostname to actually login to before doing a telnet."
67 :type '(choice (const nil) string)
68 :group 'url-gateway)
69
70(defcustom url-gateway-telnet-parameters '("exec" "telnet" "-8")
71 "*Parameters to `url-open-telnet'.
72This list will be executed as a command after logging in via telnet."
73 :type '(repeat string)
74 :group 'url-gateway)
75
76(defcustom url-gateway-telnet-login-prompt "^\r*.?login:"
77 "*Prompt that tells us we should send our username when loggin in w/telnet."
78 :type 'regexp
79 :group 'url-gateway)
80
81(defcustom url-gateway-telnet-password-prompt "^\r*.?password:"
82 "*Prompt that tells us we should send our password when loggin in w/telnet."
83 :type 'regexp
84 :group 'url-gateway)
85
86(defcustom url-gateway-telnet-user-name nil
87 "User name to log in via telnet with."
88 :type '(choice (const nil) string)
89 :group 'url-gateway)
90
91(defcustom url-gateway-telnet-password nil
92 "Password to use to log in via telnet with."
93 :type '(choice (const nil) string)
94 :group 'url-gateway)
95
96(defcustom url-gateway-broken-resolution nil
97 "*Whether to use nslookup to resolve hostnames.
98This should be used when your version of Emacs cannot correctly use DNS,
99but your machine can. This usually happens if you are running a statically
100linked Emacs under SunOS 4.x"
101 :type 'boolean
102 :group 'url-gateway)
103
104(defcustom url-gateway-nslookup-program "nslookup"
105 "*If non-NIL then a string naming nslookup program."
106 :type '(choice (const :tag "None" :value nil) string)
107 :group 'url-gateway)
108
109;; Stolen from ange-ftp
110;;;###autoload
111(defun url-gateway-nslookup-host (host)
112 "Attempt to resolve the given HOST using nslookup if possible."
113 (interactive "sHost: ")
114 (if url-gateway-nslookup-program
115 (let ((proc (start-process " *nslookup*" " *nslookup*"
116 url-gateway-nslookup-program host))
117 (res host))
118 (process-kill-without-query proc)
119 (save-excursion
120 (set-buffer (process-buffer proc))
121 (while (memq (process-status proc) '(run open))
122 (accept-process-output proc))
123 (goto-char (point-min))
124 (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
125 (setq res (buffer-substring (match-beginning 1)
126 (match-end 1))))
127 (kill-buffer (current-buffer)))
128 res)
129 host))
130
131;; Stolen from red gnus nntp.el
132(defun url-wait-for-string (regexp proc)
133 "Wait until string matching REGEXP arrives in process PROC's buffer."
134 (let ((buf (current-buffer)))
135 (goto-char (point-min))
136 (while (not (re-search-forward regexp nil t))
137 (accept-process-output proc)
138 (set-buffer buf)
139 (goto-char (point-min)))))
140
141;; Stolen from red gnus nntp.el
142(defun url-open-rlogin (name buffer host service)
143 "Open a connection using rsh."
144 (if (not (stringp service))
145 (setq service (int-to-string service)))
146 (let ((proc (if url-gateway-rlogin-user-name
147 (start-process
148 name buffer "rsh"
149 url-gateway-rlogin-host "-l" url-gateway-rlogin-user-name
150 (mapconcat 'identity
151 (append url-gateway-rlogin-parameters
152 (list host service)) " "))
153 (start-process
154 name buffer "rsh" url-gateway-rlogin-host
155 (mapconcat 'identity
156 (append url-gateway-rlogin-parameters
157 (list host service))
158 " ")))))
159 (set-buffer buffer)
160 (url-wait-for-string "^\r*200" proc)
161 (beginning-of-line)
162 (delete-region (point-min) (point))
163 proc))
164
165;; Stolen from red gnus nntp.el
166(defun url-open-telnet (name buffer host service)
167 (if (not (stringp service))
168 (setq service (int-to-string service)))
169 (save-excursion
170 (set-buffer (get-buffer-create buffer))
171 (erase-buffer)
172 (let ((proc (start-process name buffer "telnet" "-8"))
173 (case-fold-search t))
174 (when (memq (process-status proc) '(open run))
175 (process-send-string proc "set escape \^X\n")
176 (process-send-string proc (concat
177 "open " url-gateway-telnet-host "\n"))
178 (url-wait-for-string url-gateway-telnet-login-prompt proc)
179 (process-send-string
180 proc (concat
181 (or url-gateway-telnet-user-name
182 (setq url-gateway-telnet-user-name (read-string "login: ")))
183 "\n"))
184 (url-wait-for-string url-gateway-telnet-password-prompt proc)
185 (process-send-string
186 proc (concat
187 (or url-gateway-telnet-password
188 (setq url-gateway-telnet-password
189 (funcall url-passwd-entry-func "Password: ")))
190 "\n"))
191 (erase-buffer)
192 (url-wait-for-string url-gateway-prompt-pattern proc)
193 (process-send-string
194 proc (concat (mapconcat 'identity
195 (append url-gateway-telnet-parameters
196 (list host service)) " ") "\n"))
197 (url-wait-for-string "^\r*Escape character.*\r*\n+" proc)
198 (delete-region (point-min) (match-end 0))
199 (process-send-string proc "\^]\n")
200 (url-wait-for-string "^telnet" proc)
201 (process-send-string proc "mode character\n")
202 (accept-process-output proc 1)
203 (sit-for 1)
204 (goto-char (point-min))
205 (forward-line 1)
206 (delete-region (point) (point-max)))
207 proc)))
208
209;;;###autoload
210(defun url-open-stream (name buffer host service)
211 "Open a stream to HOST, possibly via a gateway.
212Args per `open-network-stream'.
213Will not make a connexion if `url-gateway-unplugged' is non-nil."
214 (unless url-gateway-unplugged
215 (let ((gw-method (if (and url-gateway-local-host-regexp
216 (not (eq 'tls url-gateway-method))
217 (not (eq 'ssl url-gateway-method))
218 (string-match
219 url-gateway-local-host-regexp
220 host))
221 'native
222 url-gateway-method))
223;;; ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF
224;;; ;; conversions while trying to be 'helpful'
225;;; (tcp-binary-process-output-services (if (stringp service)
226;;; (list service)
227;;; (list service
228;;; (int-to-string service))))
229
230 ;; An attempt to deal with denied connections, and attempt
231 ;; to reconnect
232 (cur-retries 0)
233 (retry t)
234 (errobj nil)
235 (conn nil))
236
237 ;; If the user told us to do DNS for them, do it.
238 (if url-gateway-broken-resolution
239 (setq host (url-gateway-nslookup-host host)))
240
241 (condition-case errobj
242 ;; This is a clean way to ensure the new process inherits the
243 ;; right coding systems in both Emacs and XEmacs.
244 (let ((coding-system-for-read 'binary)
245 (coding-system-for-write 'binary))
246 (setq conn (case gw-method
247 (tls
248 (open-tls-stream name buffer host service))
249 (ssl
250 (open-ssl-stream name buffer host service))
251 ((native)
252 (open-network-stream name buffer host service))
253 (socks
254 (socks-open-network-stream name buffer host service))
255 (telnet
256 (url-open-telnet name buffer host service))
257 (rlogin
258 (url-open-rlogin name buffer host service))
259 (otherwise
260 (error "Bad setting of url-gateway-method: %s"
261 url-gateway-method)))))
262 (error
263 (setq conn nil)))
264 conn)))
265
266(provide 'url-gw)
267
268;;; arch-tag: 1c4c0317-6d03-45b8-b3f3-838bd8f9d838
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
index 56497b00119..db961b9c27e 100644
--- a/lisp/url/url-handlers.el
+++ b/lisp/url/url-handlers.el
@@ -1,7 +1,6 @@
1;;; url-handlers.el --- file-name-handler stuff for URL loading 1;;; url-handlers.el --- file-name-handler stuff for URL loading
2 2
3;; Copyright (c) 1996, 1997, 1998, 1999, 2004 Free Software Foundation, Inc. 3;; Copyright (c) 1996, 1997, 1998, 1999, 2004 Free Software Foundation, Inc.
4;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
5 4
6;; Keywords: comm, data, processes, hypermedia 5;; Keywords: comm, data, processes, hypermedia
7 6
@@ -208,7 +207,7 @@ accessible."
208 ;; annotation which we could use as a hint of the locale in use 207 ;; annotation which we could use as a hint of the locale in use
209 ;; at the remote site. Not sure how/if that should be done. --Stef 208 ;; at the remote site. Not sure how/if that should be done. --Stef
210 (decode-coding-inserted-region 209 (decode-coding-inserted-region
211 start (point) buffer-file-name visit beg end replace))) 210 start (point) url visit beg end replace)))
212 (list url (length data)))) 211 (list url (length data))))
213 212
214(defun url-file-name-completion (url directory) 213(defun url-file-name-completion (url directory)
diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el
new file mode 100644
index 00000000000..6a2d87cfbc1
--- /dev/null
+++ b/lisp/url/url-history.el
@@ -0,0 +1,199 @@
1;;; url-history.el --- Global history tracking for URL package
2
3;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc.
4
5;; Keywords: comm, data, processes, hypermedia
6
7;; This file is part of GNU Emacs.
8;;
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13;;
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to the
21;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;; Boston, MA 02111-1307, USA.
23
24;;; Commentary:
25
26;;; Code:
27
28;; This can get a recursive require.
29;;(require 'url)
30(eval-when-compile (require 'cl))
31(require 'url-parse)
32(autoload 'url-do-setup "url")
33
34(defgroup url-history nil
35 "History variables in the URL package"
36 :prefix "url-history"
37 :group 'url)
38
39(defcustom url-history-track nil
40 "*Controls whether to keep a list of all the URLS being visited.
41If non-nil, url will keep track of all the URLS visited.
42If eq to `t', then the list is saved to disk at the end of each emacs
43session."
44 :type 'boolean
45 :group 'url-history)
46
47(defcustom url-history-file nil
48 "*The global history file for the URL package.
49This file contains a list of all the URLs you have visited. This file
50is parsed at startup and used to provide URL completion."
51 :type '(choice (const :tag "Default" :value nil) file)
52 :group 'url-history)
53
54(defcustom url-history-save-interval 3600
55 "*The number of seconds between automatic saves of the history list.
56Default is 1 hour. Note that if you change this variable outside of
57the `customize' interface after `url-do-setup' has been run, you need
58to run the `url-history-setup-save-timer' function manually."
59 :set (function (lambda (var val)
60 (set-default var val)
61 (and (featurep 'url)
62 (fboundp 'url-history-setup-save-timer)
63 (let ((def (symbol-function
64 'url-history-setup-save-timer)))
65 (not (and (listp def) (eq 'autoload (car def)))))
66 (url-history-setup-save-timer))))
67 :type 'integer
68 :group 'url-history)
69
70(defvar url-history-timer nil)
71
72(defvar url-history-list nil
73 "List of urls visited this session.")
74
75(defvar url-history-changed-since-last-save nil
76 "Whether the history list has changed since the last save operation.")
77
78(defvar url-history-hash-table nil
79 "Hash table for global history completion.")
80
81;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
82
83;;;###autoload
84(defun url-history-setup-save-timer ()
85 "Reset the history list timer."
86 (interactive)
87 (ignore-errors
88 (cond ((fboundp 'cancel-timer) (cancel-timer url-history-timer))
89 ((fboundp 'delete-itimer) (delete-itimer url-history-timer))))
90 (setq url-history-timer nil)
91 (if url-history-save-interval
92 (setq url-history-timer
93 (cond
94 ((fboundp 'run-at-time)
95 (run-at-time url-history-save-interval
96 url-history-save-interval
97 'url-history-save-history))
98 ((fboundp 'start-itimer)
99 (start-itimer "url-history-saver" 'url-history-save-history
100 url-history-save-interval
101 url-history-save-interval))))))
102
103;;;###autoload
104(defun url-history-parse-history (&optional fname)
105 "Parse a history file stored in FNAME."
106 ;; Parse out the mosaic global history file for completions, etc.
107 (or fname (setq fname (expand-file-name url-history-file)))
108 (cond
109 ((not (file-exists-p fname))
110 (message "%s does not exist." fname))
111 ((not (file-readable-p fname))
112 (message "%s is unreadable." fname))
113 (t
114 (condition-case nil
115 (load fname nil t)
116 (error (message "Could not load %s" fname)))))
117 (if (not url-history-hash-table)
118 (setq url-history-hash-table (make-hash-table :size 31 :test 'equal))))
119
120(defun url-history-update-url (url time)
121 (setq url-history-changed-since-last-save t)
122 (puthash (if (vectorp url) (url-recreate-url url) url) time url-history-hash-table))
123
124;;;###autoload
125(defun url-history-save-history (&optional fname)
126 "Write the global history file into `url-history-file'.
127The type of data written is determined by what is in the file to begin
128with. If the type of storage cannot be determined, then prompt the
129user for what type to save as."
130 (interactive)
131 (or fname (setq fname (expand-file-name url-history-file)))
132 (cond
133 ((not url-history-changed-since-last-save) nil)
134 ((not (file-writable-p fname))
135 (message "%s is unwritable." fname))
136 (t
137 (let ((make-backup-files nil)
138 (version-control nil)
139 (require-final-newline t))
140 (save-excursion
141 (set-buffer (get-buffer-create " *url-tmp*"))
142 (erase-buffer)
143 (let ((count 0))
144 (maphash (function
145 (lambda (key value)
146 (while (string-match "[\r\n]+" key)
147 (setq key (concat (substring key 0 (match-beginning 0))
148 (substring key (match-end 0) nil))))
149 (setq count (1+ count))
150 (insert "(puthash \"" key "\""
151 (if (not (stringp value)) " '" "")
152 (prin1-to-string value)
153 " url-history-hash-table)\n")))
154 url-history-hash-table)
155 (goto-char (point-min))
156 (insert (format
157 "(setq url-history-hash-table (make-hash-table :size %d :test 'equal))\n"
158 (/ count 4)))
159 (goto-char (point-max))
160 (insert "\n")
161 (write-file fname))
162 (kill-buffer (current-buffer))))))
163 (setq url-history-changed-since-last-save nil))
164
165(defun url-have-visited-url (url)
166 (url-do-setup)
167 (gethash url url-history-hash-table nil))
168
169(defun url-completion-function (string predicate function)
170 (url-do-setup)
171 (cond
172 ((eq function nil)
173 (let ((list nil))
174 (maphash (function (lambda (key val)
175 (setq list (cons (cons key val)
176 list))))
177 url-history-hash-table)
178 (try-completion string (nreverse list) predicate)))
179 ((eq function t)
180 (let ((stub (concat "^" (regexp-quote string)))
181 (retval nil))
182 (maphash
183 (function
184 (lambda (url time)
185 (if (string-match stub url)
186 (setq retval (cons url retval)))))
187 url-history-hash-table)
188 retval))
189 ((eq function 'lambda)
190 (and url-history-hash-table
191 (gethash string url-history-hash-table)
192 t))
193 (t
194 (error "url-completion-function very confused."))))
195
196(provide 'url-history)
197
198;; arch-tag: fbbbaf63-db36-4e88-bc9f-2939aa93afb2
199;;; url-history.el ends here
diff --git a/lisp/url/url-https.el b/lisp/url/url-https.el
index 11b2593ea80..9631aeb18e4 100644
--- a/lisp/url/url-https.el
+++ b/lisp/url/url-https.el
@@ -1,4 +1,4 @@
1;;; url-https.el --- HTTP over SSL routines 1;;; url-https.el --- HTTP over SSL/TLS routines
2 2
3;; Copyright (c) 1999, 2004 Free Software Foundation, Inc. 3;; Copyright (c) 1999, 2004 Free Software Foundation, Inc.
4 4
@@ -30,6 +30,7 @@
30(require 'url-parse) 30(require 'url-parse)
31(require 'url-cookie) 31(require 'url-cookie)
32(require 'url-http) 32(require 'url-http)
33(require 'tls)
33 34
34(defconst url-https-default-port 443 "Default HTTPS port.") 35(defconst url-https-default-port 443 "Default HTTPS port.")
35(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.") 36(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
@@ -38,12 +39,11 @@
38(defmacro url-https-create-secure-wrapper (method args) 39(defmacro url-https-create-secure-wrapper (method args)
39 `(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args 40 `(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args
40 ,(format "HTTPS wrapper around `%s' call." (or method "url-http")) 41 ,(format "HTTPS wrapper around `%s' call." (or method "url-http"))
41 (condition-case () 42 (let ((url-gateway-method (condition-case ()
42 (require 'ssl) 43 (require 'ssl)
43 (error 44 (error 'tls))))
44 (error "HTTPS support could not find `ssl' library"))) 45 (,(intern (format (if method "url-http-%s" "url-http") method))
45 (let ((url-gateway-method 'ssl)) 46 ,@(remove '&rest (remove '&optional args))))))
46 ( ,(intern (format (if method "url-http-%s" "url-http") method)) ,@(remove '&rest (remove '&optional args))))))
47 47
48(url-https-create-secure-wrapper nil (url callback cbargs)) 48(url-https-create-secure-wrapper nil (url callback cbargs))
49(url-https-create-secure-wrapper file-exists-p (url)) 49(url-https-create-secure-wrapper file-exists-p (url))
diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el
new file mode 100644
index 00000000000..a4b195f253f
--- /dev/null
+++ b/lisp/url/url-irc.el
@@ -0,0 +1,76 @@
1;;; url-irc.el --- IRC URL interface
2;; Keywords: comm, data, processes
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25;;; IRC URLs are defined in http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt
26
27(require 'url-vars)
28(require 'url-parse)
29
30(defconst url-irc-default-port 6667 "Default port for IRC connections")
31
32(defcustom url-irc-function 'url-irc-zenirc
33 "*Function to actually open an IRC connection.
34Should be a function that takes several argument:
35 HOST - the hostname of the IRC server to contact
36 PORT - the port number of the IRC server to contact
37 CHANNEL - What channel on the server to visit right away (can be nil)
38 USER - What username to use
39PASSWORD - What password to use"
40 :type '(choice (const :tag "ZEN IRC" :value 'url-irc-zenirc)
41 (function :tag "Other"))
42 :group 'url)
43
44(defun url-irc-zenirc (host port channel user password)
45 (let ((zenirc-buffer-name (if (and user host port)
46 (format "%s@%s:%d" user host port)
47 (format "%s:%d" host port)))
48 (zenirc-server-alist
49 (list
50 (list host port password nil user))))
51 (zenirc)
52 (goto-char (point-max))
53 (if (not channel)
54 nil
55 (insert "/join " channel)
56 (zenirc-send-line))))
57
58;;;###autoload
59(defun url-irc (url)
60 (let* ((host (url-host url))
61 (port (string-to-int (url-port url)))
62 (pass (url-password url))
63 (user (url-user url))
64 (chan (url-filename url)))
65 (if (url-target url)
66 (setq chan (concat chan "#" (url-target url))))
67 (if (string-match "^/" chan)
68 (setq chan (substring chan 1 nil)))
69 (if (= (length chan) 0)
70 (setq chan nil))
71 (funcall url-irc-function host port chan user pass)
72 nil))
73
74(provide 'url-irc)
75
76;;; arch-tag: 2e5eecf8-9eb3-436b-9fbd-c26f2fb2bf3e
diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el
new file mode 100644
index 00000000000..24a3ade4922
--- /dev/null
+++ b/lisp/url/url-ldap.el
@@ -0,0 +1,240 @@
1;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
2;; Copyright (c) 1998 - 1999, 2004 Free Software Foundation, Inc.
3
4;; Keywords: comm, data, processes
5
6;; This file is part of GNU Emacs.
7;;
8;; GNU Emacs is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation; either version 2, or (at your option)
11;; any later version.
12;;
13;; GNU Emacs is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17;;
18;; You should have received a copy of the GNU General Public License
19;; along with GNU Emacs; see the file COPYING. If not, write to the
20;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21;; Boston, MA 02111-1307, USA.
22
23;;; Commentary:
24
25;;; Code:
26
27(require 'url-vars)
28(require 'url-parse)
29(require 'url-util)
30(require 'ldap)
31(autoload 'tls-certificate-information "tls")
32
33;; This has been implemented from RFC2255 'The LDAP URL Format' (Dec 1997)
34;;
35;; basic format is: ldap://host:port/dn?attributes?scope?filter?extensions
36;;
37;; Test URLs:
38;; ldap://ldap.itd.umich.edu/cn%3Dumbflabmanager%2C%20ou%3DUser%20Groups%2C%20ou%3DGroups%2C%20o%3DUniversity%20of%20Michigan%2C%20c%3DUS
39;; ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US
40;;
41;; For simple queries, I have verified compatibility with Netscape
42;; Communicator v4.5 under GNU/Linux.
43;;
44;; For anything _useful_ though, like specifying the attributes,
45;; scope, filter, or extensions, netscape claims the URL format is
46;; unrecognized. So I don't think it supports anything other than the
47;; defaults (scope=base,attributes=*,filter=(objectClass=*)
48
49(defconst url-ldap-default-port 389 "Default LDAP port.")
50(defalias 'url-ldap-expand-file-name 'url-default-expander)
51
52(defvar url-ldap-pretty-names
53 '(("l" . "City")
54 ("objectclass" . "Object Class")
55 ("o" . "Organization")
56 ("ou" . "Organizational Unit")
57 ("cn" . "Name")
58 ("sn" . "Last Name")
59 ("givenname" . "First Name")
60 ("mail" . "Email")
61 ("title" . "Title")
62 ("c" . "Country")
63 ("postalcode" . "ZIP Code")
64 ("telephonenumber" . "Phone Number")
65 ("facsimiletelephonenumber" . "Fax")
66 ("postaladdress" . "Mailing Address")
67 ("description" . "Notes"))
68 "*An assoc list mapping LDAP attribute names to pretty descriptions of them.")
69
70(defvar url-ldap-attribute-formatters
71 '(("mail" . (lambda (x) (format "<a href='mailto:%s'>%s</a>" x x)))
72 ("owner" . url-ldap-dn-formatter)
73 ("creatorsname" . url-ldap-dn-formatter)
74 ("jpegphoto" . url-ldap-image-formatter)
75 ("usercertificate" . url-ldap-certificate-formatter)
76 ("modifiersname" . url-ldap-dn-formatter)
77 ("namingcontexts" . url-ldap-dn-formatter)
78 ("defaultnamingcontext" . url-ldap-dn-formatter)
79 ("member" . url-ldap-dn-formatter))
80 "*An assoc list mapping LDAP attribute names to pretty formatters for them.")
81
82(defsubst url-ldap-attribute-pretty-name (n)
83 (or (cdr-safe (assoc (downcase n) url-ldap-pretty-names)) n))
84
85(defsubst url-ldap-attribute-pretty-desc (n v)
86 (if (string-match "^\\([^;]+\\);" n)
87 (setq n (match-string 1 n)))
88 (funcall (or (cdr-safe (assoc (downcase n) url-ldap-attribute-formatters)) 'identity) v))
89
90(defun url-ldap-dn-formatter (dn)
91 (concat "<a href='/"
92 (url-hexify-string dn)
93 "'>" dn "</a>"))
94
95(defun url-ldap-certificate-formatter (data)
96 (condition-case ()
97 (require 'ssl)
98 (error nil))
99 (let ((vals (if (fboundp 'ssl-certificate-information)
100 (ssl-certificate-information data)
101 (tls-certificate-information data))))
102 (if (not vals)
103 "<b>Unable to parse certificate</b>"
104 (concat "<table border=0>\n"
105 (mapconcat
106 (lambda (ava)
107 (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava) (cdr ava)))
108 vals "\n")
109 "</table>\n"))))
110
111(defun url-ldap-image-formatter (data)
112 (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>"
113 (url-hexify-string (base64-encode-string data))))
114
115;; FIXME: This needs sorting out for the Emacs LDAP functions, specifically
116;; calls of ldap-open, ldap-close, ldap-search-internal
117;;;###autoload
118(defun url-ldap (url)
119 (save-excursion
120 (set-buffer (generate-new-buffer " *url-ldap*"))
121 (setq url-current-object url)
122 (insert "Content-type: text/html\r\n\r\n")
123 (if (not (fboundp 'ldap-search-internal))
124 (insert "<html>\n"
125 " <head>\n"
126 " <title>LDAP Not Supported</title>\n"
127 " <base href='" (url-recreate-url url) "'>\n"
128 " </head>\n"
129 " <body>\n"
130 " <h1>LDAP Not Supported</h1>\n"
131 " <p>\n"
132 " This version of Emacs does not support LDAP.\n"
133 " </p>\n"
134 " </body>\n"
135 "</html>\n")
136 (let* ((binddn nil)
137 (data (url-filename url))
138 (host (url-host url))
139 (port (url-port url))
140 (base-object nil)
141 (attributes nil)
142 (scope nil)
143 (filter nil)
144 (extensions nil)
145 (connection nil)
146 (results nil)
147 (extract-dn (and (fboundp 'function-max-args)
148 (= (function-max-args 'ldap-search-internal) 7))))
149
150 ;; Get rid of leading /
151 (if (string-match "^/" data)
152 (setq data (substring data 1)))
153
154 (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?"))
155 base-object (nth 0 data)
156 attributes (nth 1 data)
157 scope (nth 2 data)
158 filter (nth 3 data)
159 extensions (nth 4 data))
160
161 ;; fill in the defaults
162 (setq base-object (url-unhex-string (or base-object ""))
163 scope (intern (url-unhex-string (or scope "base")))
164 filter (url-unhex-string (or filter "(objectClass=*)")))
165
166 (if (not (memq scope '(base one tree)))
167 (error "Malformed LDAP URL: Unknown scope: %S" scope))
168
169 ;; Convert to the internal LDAP support scoping names.
170 (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))
171
172 (if attributes
173 (setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))
174
175 ;; Parse out the exentions
176 (if extensions
177 (setq extensions (mapcar (lambda (ext)
178 (if (string-match "\\([^=]*\\)=\\(.*\\)" ext)
179 (cons (match-string 1 ext) (match-string 2 ext))
180 (cons ext ext)))
181 (split-string extensions ","))
182 extensions (mapcar (lambda (ext)
183 (cons (url-unhex-string (car ext))
184 (url-unhex-string (cdr ext))))
185 extensions)))
186
187 (setq binddn (cdr-safe (or (assoc "bindname" extensions)
188 (assoc "!bindname" extensions))))
189
190 ;; Now, let's actually do something with it.
191 (setq connection (ldap-open host (if binddn (list 'binddn binddn)))
192 results (if extract-dn
193 (ldap-search-internal connection filter base-object scope attributes nil t)
194 (ldap-search-internal connection filter base-object scope attributes nil)))
195
196 (ldap-close connection)
197 (insert "<html>\n"
198 " <head>\n"
199 " <title>LDAP Search Results</title>\n"
200 " <base href='" (url-recreate-url url) "'>\n"
201 " </head>\n"
202 " <body>\n"
203 " <h1>" (int-to-string (length results)) " matches</h1>\n")
204
205 (mapc (lambda (obj)
206 (insert " <hr>\n"
207 " <table border=1>\n")
208 (if extract-dn
209 (insert " <tr><th colspan=2>" (car obj) "</th></tr>\n"))
210 (mapc (lambda (attr)
211 (if (= (length (cdr attr)) 1)
212 ;; single match, easy
213 (insert " <tr><td>"
214 (url-ldap-attribute-pretty-name (car attr))
215 "</td><td>"
216 (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
217 "</td></tr>\n")
218 ;; Multiple matches, slightly uglier
219 (insert " <tr>\n"
220 (format " <td valign=top>")
221 (url-ldap-attribute-pretty-name (car attr)) "</td><td>"
222 (mapconcat (lambda (x)
223 (url-ldap-attribute-pretty-desc (car attr) x))
224 (cdr attr)
225 "<br>\n")
226 "</td>"
227 " </tr>\n")))
228 (if extract-dn (cdr obj) obj))
229 (insert " </table>\n"))
230 results)
231
232 (insert " <hr>\n"
233 " </body>\n"
234 "</html>\n")))
235 (current-buffer)))
236
237(provide 'url-ldap)
238
239;; arch-tag: 6230e21c-41ae-4174-bd83-82c835676fc8
240;;; url-ldap.el ends here
diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el
new file mode 100644
index 00000000000..bcb6bad4179
--- /dev/null
+++ b/lisp/url/url-mailto.el
@@ -0,0 +1,131 @@
1;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
2
3;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
4
5;; Keywords: comm, data, processes
6
7;; This file is part of GNU Emacs.
8;;
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13;;
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to the
21;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;; Boston, MA 02111-1307, USA.
23
24;;; Commentary:
25
26;;; Code:
27
28(eval-when-compile (require 'cl))
29(require 'url-vars)
30(require 'url-parse)
31(require 'url-util)
32
33;;;###autoload
34(defun url-mail (&rest args)
35 (interactive "P")
36 (if (fboundp 'message-mail)
37 (apply 'message-mail args)
38 (or (apply 'mail args)
39 (error "Mail aborted"))))
40
41(defun url-mail-goto-field (field)
42 (if (not field)
43 (goto-char (point-max))
44 (let ((dest nil)
45 (lim nil)
46 (case-fold-search t))
47 (save-excursion
48 (goto-char (point-min))
49 (if (re-search-forward (regexp-quote mail-header-separator) nil t)
50 (setq lim (match-beginning 0)))
51 (goto-char (point-min))
52 (if (re-search-forward (concat "^" (regexp-quote field) ":") lim t)
53 (setq dest (match-beginning 0))))
54 (if dest
55 (progn
56 (goto-char dest)
57 (end-of-line))
58 (goto-char lim)
59 (insert (capitalize field) ": ")
60 (save-excursion
61 (insert "\n"))))))
62
63;;;###autoload
64(defun url-mailto (url)
65 "Handle the mailto: URL syntax."
66 (if (url-user url)
67 ;; malformed mailto URL (mailto://wmperry@gnu.org instead of
68 ;; mailto:wmperry@gnu.org
69 (url-set-filename url (concat (url-user url) "@" (url-filename url))))
70 (setq url (url-filename url))
71 (let (to args source-url subject func headers-start)
72 (if (string-match (regexp-quote "?") url)
73 (setq headers-start (match-end 0)
74 to (url-unhex-string (substring url 0 (match-beginning 0)))
75 args (url-parse-query-string
76 (substring url headers-start nil) t))
77 (setq to (url-unhex-string url)))
78 (setq source-url (url-view-url t))
79 (if (and url-request-data (not (assoc "subject" args)))
80 (setq args (cons (list "subject"
81 (concat "Automatic submission from "
82 url-package-name "/"
83 url-package-version)) args)))
84 (if (and source-url (not (assoc "x-url-from" args)))
85 (setq args (cons (list "x-url-from" source-url) args)))
86
87 (if (assoc "to" args)
88 (push to (cdr (assoc "to" args)))
89 (setq args (cons (list "to" to) args)))
90 (setq subject (cdr-safe (assoc "subject" args)))
91 (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
92 (while args
93 (if (string= (caar args) "body")
94 (progn
95 (goto-char (point-max))
96 (insert (mapconcat 'identity (cdar args) "\n")))
97 (url-mail-goto-field (caar args))
98 (setq func (intern-soft (concat "mail-" (caar args))))
99 (insert (mapconcat 'identity (cdar args) ", ")))
100 (setq args (cdr args)))
101 ;; (url-mail-goto-field "User-Agent")
102;; (insert url-package-name "/" url-package-version " URL/" url-version)
103 (if (not url-request-data)
104 (progn
105 (set-buffer-modified-p nil)
106 (if subject
107 (url-mail-goto-field nil)
108 (url-mail-goto-field "subject")))
109 (if url-request-extra-headers
110 (mapconcat
111 (lambda (x)
112 (url-mail-goto-field (car x))
113 (insert (cdr x)))
114 url-request-extra-headers ""))
115 (goto-char (point-max))
116 (insert url-request-data)
117 ;; It seems Microsoft-ish to send without warning.
118 ;; Fixme: presumably this should depend on a privacy setting.
119 (if (y-or-n-p "Send this auto-generated mail? ")
120 (cond ((eq url-mail-command 'compose-mail)
121 (funcall (get mail-user-agent 'sendfunc) nil))
122 ;; otherwise, we can't be sure
123 ((fboundp 'message-send-and-exit)
124 (message-send-and-exit))
125 (t (mail-send-and-exit nil)))))
126 nil))
127
128(provide 'url-mailto)
129
130;; arch-tag: 7b7ad52e-8760-497b-9444-75fae14e34c5
131;;; url-mailto.el ends here
diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el
new file mode 100644
index 00000000000..75d746f3e3f
--- /dev/null
+++ b/lisp/url/url-methods.el
@@ -0,0 +1,150 @@
1;;; url-methods.el --- Load URL schemes as needed
2
3;; Copyright (c) 1996,1997,1998,1999,2004 Free Software Foundation, Inc.
4
5;; Keywords: comm, data, processes, hypermedia
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13;;
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to the
21;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;; Boston, MA 02111-1307, USA.
23
24;;; Commentary:
25
26;;; Code:
27
28(eval-when-compile
29 (require 'cl))
30
31;; This loads up some of the small, silly URLs that I really don't
32;; want to bother putting in their own separate files.
33(require 'url-parse)
34
35(defvar url-scheme-registry (make-hash-table :size 7 :test 'equal))
36
37(defconst url-scheme-methods
38 '((default-port . variable)
39 (asynchronous-p . variable)
40 (expand-file-name . function)
41 (file-exists-p . function)
42 (file-attributes . function)
43 (parse-url . function)
44 (file-symlink-p . function)
45 (file-writable-p . function)
46 (file-directory-p . function)
47 (file-executable-p . function)
48 (directory-files . function)
49 (file-truename . function))
50 "Assoc-list of methods that each URL loader can provide.")
51
52(defconst url-scheme-default-properties
53 (list 'name "unknown"
54 'loader 'url-scheme-default-loader
55 'default-port 0
56 'expand-file-name 'url-identity-expander
57 'parse-url 'url-generic-parse-url
58 'asynchronous-p nil
59 'file-directory-p 'ignore
60 'file-truename (lambda (&rest args)
61 (url-recreate-url (car args)))
62 'file-exists-p 'ignore
63 'file-attributes 'ignore))
64
65(defun url-scheme-default-loader (url &optional callback cbargs)
66 "Signal an error for an unknown URL scheme."
67 (error "Unkown URL scheme: %s" (url-type url)))
68
69(defun url-scheme-register-proxy (scheme)
70 "Automatically find a proxy for SCHEME and put it in `url-proxy-services'."
71 (let* ((env-var (concat scheme "_proxy"))
72 (env-proxy (or (getenv (upcase env-var))
73 (getenv (downcase env-var))))
74 (cur-proxy (assoc scheme url-proxy-services))
75 (urlobj nil))
76
77 ;; Store any proxying information - this will not overwrite an old
78 ;; entry, so that people can still set this information in their
79 ;; .emacs file
80 (cond
81 (cur-proxy nil) ; Keep their old settings
82 ((null env-proxy) nil) ; No proxy setup
83 ;; First check if its something like hostname:port
84 ((string-match "^\\([^:]+\\):\\([0-9]+\\)$" env-proxy)
85 (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
86 (url-set-type urlobj "http")
87 (url-set-host urlobj (match-string 1 env-proxy))
88 (url-set-port urlobj (string-to-number (match-string 2 env-proxy))))
89 ;; Then check if its a fully specified URL
90 ((string-match url-nonrelative-link env-proxy)
91 (setq urlobj (url-generic-parse-url env-proxy))
92 (url-set-type urlobj "http")
93 (url-set-target urlobj nil))
94 ;; Finally, fall back on the assumption that its just a hostname
95 (t
96 (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
97 (url-set-type urlobj "http")
98 (url-set-host urlobj env-proxy)))
99
100 (if (and (not cur-proxy) urlobj)
101 (progn
102 (setq url-proxy-services
103 (cons (cons scheme (format "%s:%d" (url-host urlobj)
104 (url-port urlobj)))
105 url-proxy-services))
106 (message "Using a proxy for %s..." scheme)))))
107
108(defun url-scheme-get-property (scheme property)
109 "Get property of a URL SCHEME.
110Will automatically try to load a backend from url-SCHEME.el if
111it has not already been loaded."
112 (setq scheme (downcase scheme))
113 (let ((desc (gethash scheme url-scheme-registry)))
114 (if (not desc)
115 (let* ((stub (concat "url-" scheme))
116 (loader (intern stub)))
117 (condition-case ()
118 (require loader)
119 (error nil))
120 (if (fboundp loader)
121 (progn
122 ;; Found the module to handle <scheme> URLs
123 (url-scheme-register-proxy scheme)
124 (setq desc (list 'name scheme
125 'loader loader))
126 (dolist (cell url-scheme-methods)
127 (let ((symbol (intern-soft (format "%s-%s" stub (car cell))))
128 (type (cdr cell)))
129 (if symbol
130 (case type
131 (function
132 ;; Store the symbol name of a function
133 (if (fboundp symbol)
134 (setq desc (plist-put desc (car cell) symbol))))
135 (variable
136 ;; Store the VALUE of a variable
137 (if (boundp symbol)
138 (setq desc (plist-put desc (car cell)
139 (symbol-value symbol)))))
140 (otherwise
141 (error "Malformed url-scheme-methods entry: %S"
142 cell))))))
143 (puthash scheme desc url-scheme-registry)))))
144 (or (plist-get desc property)
145 (plist-get url-scheme-default-properties property))))
146
147(provide 'url-methods)
148
149;; arch-tag: 336863f8-5a07-4906-9be5-b3c6bcebbe67
150;;; url-methods.el ends here
diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el
new file mode 100644
index 00000000000..ff2f1282137
--- /dev/null
+++ b/lisp/url/url-misc.el
@@ -0,0 +1,117 @@
1;;; url-misc.el --- Misc Uniform Resource Locator retrieval code
2;; Keywords: comm, data, processes
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996,1997,1998,1999,2002 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25(require 'url-vars)
26(require 'url-parse)
27(autoload 'Info-goto-node "info" "" t)
28(autoload 'man "man" nil t)
29
30;;;###autoload
31(defun url-man (url)
32 "Fetch a Unix manual page URL."
33 (man (url-filename url))
34 nil)
35
36;;;###autoload
37(defun url-info (url)
38 "Fetch a GNU Info URL."
39 ;; Fetch an info node
40 (let* ((fname (url-filename url))
41 (node (url-unhex-string (or (url-target url) "Top"))))
42 (if (and fname node)
43 (Info-goto-node (concat "(" fname ")" node))
44 (error "Malformed url: %s" (url-recreate-url url)))
45 nil))
46
47(defun url-do-terminal-emulator (type server port user)
48 (terminal-emulator
49 (generate-new-buffer (format "%s%s" (if user (concat user "@") "") server))
50 (case type
51 (rlogin "rlogin")
52 (telnet "telnet")
53 (tn3270 "tn3270")
54 (otherwise
55 (error "Unknown terminal emulator required: %s" type)))
56 (case type
57 (rlogin
58 (if user
59 (list server "-l" user)
60 (list server)))
61 (telnet
62 (if user (message "Please log in as user: %s" user))
63 (if port
64 (list server port)
65 (list server)))
66 (tn3270
67 (if user (message "Please log in as user: %s" user))
68 (list server)))))
69
70;;;###autoload
71(defun url-generic-emulator-loader (url)
72 (let* ((type (intern (downcase (url-type url))))
73 (server (url-host url))
74 (name (url-user url))
75 (port (url-port url)))
76 (url-do-terminal-emulator type server port name))
77 nil)
78
79;;;###autoload
80(defalias 'url-rlogin 'url-generic-emulator-loader)
81;;;###autoload
82(defalias 'url-telnet 'url-generic-emulator-loader)
83;;;###autoload
84(defalias 'url-tn3270 'url-generic-emulator-loader)
85
86;; RFC 2397
87;;;###autoload
88(defun url-data (url)
89 "Fetch a data URL (RFC 2397)."
90 (let ((mediatype nil)
91 ;; The mediatype may need to be hex-encoded too -- see the RFC.
92 (desc (url-unhex-string (url-filename url)))
93 (encoding "8bit")
94 (data nil))
95 (save-excursion
96 (if (not (string-match "\\([^,]*\\)?," desc))
97 (error "Malformed data URL: %s" desc)
98 (setq mediatype (match-string 1 desc))
99 (if (and mediatype (string-match ";base64\\'" mediatype))
100 (setq mediatype (substring mediatype 0 (match-beginning 0))
101 encoding "base64"))
102 (if (or (null mediatype)
103 (eq ?\; (aref mediatype 0)))
104 (setq mediatype (concat "text/plain" mediatype)))
105 (setq data (url-unhex-string (substring desc (match-end 0)))))
106 (set-buffer (generate-new-buffer " *url-data*"))
107 (mm-disable-multibyte)
108 (insert (format "Content-Length: %d\n" (length data))
109 "Content-Type: " mediatype "\n"
110 "Content-Encoding: " encoding "\n"
111 "\n")
112 (if data (insert data))
113 (current-buffer))))
114
115(provide 'url-misc)
116
117;;; arch-tag: 8c544e1b-d8bc-40a6-b319-f1f37fef65a0
diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el
new file mode 100644
index 00000000000..59364c9ccd0
--- /dev/null
+++ b/lisp/url/url-news.el
@@ -0,0 +1,135 @@
1;;; url-news.el --- News Uniform Resource Locator retrieval code
2;; Keywords: comm, data, processes
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996 - 1999, 2004 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24(require 'url-vars)
25(require 'url-util)
26(require 'url-parse)
27(require 'nntp)
28(autoload 'url-warn "url")
29(autoload 'gnus-group-read-ephemeral-group "gnus-group")
30(eval-when-compile (require 'cl))
31
32(defgroup url-news nil
33 "News related options"
34 :group 'url)
35
36(defun url-news-open-host (host port user pass)
37 (if (fboundp 'nnheader-init-server-buffer)
38 (nnheader-init-server-buffer))
39 (nntp-open-server host (list (string-to-int port)))
40 (if (and user pass)
41 (progn
42 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user)
43 (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass)
44 (if (not (nntp-server-opened host))
45 (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed"
46 host user))))))
47
48(defun url-news-fetch-message-id (host message-id)
49 (let ((buf (generate-new-buffer " *url-news*")))
50 (if (eq ?> (aref message-id (1- (length message-id))))
51 nil
52 (setq message-id (concat "<" message-id ">")))
53 (if (cdr-safe (nntp-request-article message-id nil host buf))
54 ;; Successfully retrieved the article
55 nil
56 (save-excursion
57 (set-buffer buf)
58 (insert "Content-type: text/html\n\n"
59 "<html>\n"
60 " <head>\n"
61 " <title>Error</title>\n"
62 " </head>\n"
63 " <body>\n"
64 " <div>\n"
65 " <h1>Error requesting article...</h1>\n"
66 " <p>\n"
67 " The status message returned by the NNTP server was:"
68 "<br><hr>\n"
69 " <xmp>\n"
70 (nntp-status-message)
71 " </xmp>\n"
72 " </p>\n"
73 " <p>\n"
74 " If you If you feel this is an error, <a href=\""
75 "mailto:" url-bug-address "\">send mail</a>\n"
76 " </p>\n"
77 " </div>\n"
78 " </body>\n"
79 "</html>\n"
80 "<!-- Automatically generated by URL v" url-version " -->\n"
81 )))
82 buf))
83
84(defun url-news-fetch-newsgroup (newsgroup host)
85 (declare (special gnus-group-buffer))
86 (if (string-match "^/+" newsgroup)
87 (setq newsgroup (substring newsgroup (match-end 0))))
88 (if (string-match "/+$" newsgroup)
89 (setq newsgroup (substring newsgroup 0 (match-beginning 0))))
90
91 ;; This saves us from checking new news if Gnus is already running
92 ;; FIXME - is it relatively safe to use gnus-alive-p here? FIXME
93 (if (or (not (get-buffer gnus-group-buffer))
94 (save-excursion
95 (set-buffer gnus-group-buffer)
96 (not (eq major-mode 'gnus-group-mode))))
97 (gnus))
98 (set-buffer gnus-group-buffer)
99 (goto-char (point-min))
100 (gnus-group-read-ephemeral-group newsgroup
101 (list 'nntp host
102 'nntp-open-connection-function
103 nntp-open-connection-function)
104 nil
105 (cons (current-buffer) 'browse)))
106
107;;;###autoload
108(defun url-news (url)
109 ;; Find a news reference
110 (let* ((host (or (url-host url) url-news-server))
111 (port (url-port url))
112 (article-brackets nil)
113 (buf nil)
114 (article (url-filename url)))
115 (url-news-open-host host port (url-user url) (url-password url))
116 (setq article (url-unhex-string article))
117 (cond
118 ((string-match "@" article) ; Its a specific article
119 (setq buf (url-news-fetch-message-id host article)))
120 ((string= article "") ; List all newsgroups
121 (gnus))
122 (t ; Whole newsgroup
123 (url-news-fetch-newsgroup article host)))
124 buf))
125
126;;;###autoload
127(defun url-snews (url)
128 (let ((nntp-open-connection-function (if (eq 'tls url-gateway-method)
129 nntp-open-tls-stream
130 nntp-open-ssl-stream)))
131 (url-news url)))
132
133(provide 'url-news)
134
135;;; arch-tag: 8975be13-04e8-4d38-bfff-47918e3ad311
diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el
index d068341b1c2..3b834bba75f 100644
--- a/lisp/url/url-nfs.el
+++ b/lisp/url/url-nfs.el
@@ -1,7 +1,6 @@
1;;; url-nfs.el --- NFS URL interface 1;;; url-nfs.el --- NFS URL interface
2 2
3;; Copyright (c) 1996,97,98,1999,2004 Free Software Foundation, Inc. 3;; Copyright (c) 1996,1997,1998,1999,2004 Free Software Foundation, Inc.
4;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
5 4
6;; Keywords: comm, data, processes 5;; Keywords: comm, data, processes
7 6
diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el
new file mode 100644
index 00000000000..97348ab5db2
--- /dev/null
+++ b/lisp/url/url-parse.el
@@ -0,0 +1,210 @@
1;;; url-parse.el --- Uniform Resource Locator parser
2
3;; Copyright (c) 1996,1997,1998,1999,2004 Free Software Foundation, Inc.
4
5;; Keywords: comm, data, processes
6
7;; This file is part of GNU Emacs.
8;;
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13;;
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to the
21;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;; Boston, MA 02111-1307, USA.
23
24;;; Commentary:
25
26;;; Code:
27
28(require 'url-vars)
29
30(autoload 'url-scheme-get-property "url-methods")
31
32(defmacro url-type (urlobj)
33 `(aref ,urlobj 0))
34
35(defmacro url-user (urlobj)
36 `(aref ,urlobj 1))
37
38(defmacro url-password (urlobj)
39 `(aref ,urlobj 2))
40
41(defmacro url-host (urlobj)
42 `(aref ,urlobj 3))
43
44(defmacro url-port (urlobj)
45 `(or (aref ,urlobj 4)
46 (if (url-fullness ,urlobj)
47 (url-scheme-get-property (url-type ,urlobj) 'default-port))))
48
49(defmacro url-filename (urlobj)
50 `(aref ,urlobj 5))
51
52(defmacro url-target (urlobj)
53 `(aref ,urlobj 6))
54
55(defmacro url-attributes (urlobj)
56 `(aref ,urlobj 7))
57
58(defmacro url-fullness (urlobj)
59 `(aref ,urlobj 8))
60
61(defmacro url-set-type (urlobj type)
62 `(aset ,urlobj 0 ,type))
63
64(defmacro url-set-user (urlobj user)
65 `(aset ,urlobj 1 ,user))
66
67(defmacro url-set-password (urlobj pass)
68 `(aset ,urlobj 2 ,pass))
69
70(defmacro url-set-host (urlobj host)
71 `(aset ,urlobj 3 ,host))
72
73(defmacro url-set-port (urlobj port)
74 `(aset ,urlobj 4 ,port))
75
76(defmacro url-set-filename (urlobj file)
77 `(aset ,urlobj 5 ,file))
78
79(defmacro url-set-target (urlobj targ)
80 `(aset ,urlobj 6 ,targ))
81
82(defmacro url-set-attributes (urlobj targ)
83 `(aset ,urlobj 7 ,targ))
84
85(defmacro url-set-full (urlobj val)
86 `(aset ,urlobj 8 ,val))
87
88;;;###autoload
89(defun url-recreate-url (urlobj)
90 "Recreate a URL string from the parsed URLOBJ."
91 (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
92 (if (url-user urlobj)
93 (concat (url-user urlobj)
94 (if (url-password urlobj)
95 (concat ":" (url-password urlobj)))
96 "@"))
97 (url-host urlobj)
98 (if (and (url-port urlobj)
99 (not (equal (url-port urlobj)
100 (url-scheme-get-property (url-type urlobj) 'default-port))))
101 (format ":%d" (url-port urlobj)))
102 (or (url-filename urlobj) "/")
103 (if (url-target urlobj)
104 (concat "#" (url-target urlobj)))
105 (if (url-attributes urlobj)
106 (concat ";"
107 (mapconcat
108 (function
109 (lambda (x)
110 (if (cdr x)
111 (concat (car x) "=" (cdr x))
112 (car x)))) (url-attributes urlobj) ";")))))
113
114;;;###autoload
115(defun url-generic-parse-url (url)
116 "Return a vector of the parts of URL.
117Format is:
118\[TYPE USER PASSWORD HOST PORT FILE TARGET ATTRIBUTES FULL\]"
119 (cond
120 ((null url)
121 (make-vector 9 nil))
122 ((or (not (string-match url-nonrelative-link url))
123 (= ?/ (string-to-char url)))
124 (let ((retval (make-vector 9 nil)))
125 (url-set-filename retval url)
126 (url-set-full retval nil)
127 retval))
128 (t
129 (save-excursion
130 (set-buffer (get-buffer-create " *urlparse*"))
131 (set-syntax-table url-parse-syntax-table)
132 (let ((save-pos nil)
133 (prot nil)
134 (user nil)
135 (pass nil)
136 (host nil)
137 (port nil)
138 (file nil)
139 (refs nil)
140 (attr nil)
141 (full nil)
142 (inhibit-read-only t))
143 (erase-buffer)
144 (insert url)
145 (goto-char (point-min))
146 (setq save-pos (point))
147 (if (not (looking-at "//"))
148 (progn
149 (skip-chars-forward "a-zA-Z+.\\-")
150 (downcase-region save-pos (point))
151 (setq prot (buffer-substring save-pos (point)))
152 (skip-chars-forward ":")
153 (setq save-pos (point))))
154
155 ;; We are doing a fully specified URL, with hostname and all
156 (if (looking-at "//")
157 (progn
158 (setq full t)
159 (forward-char 2)
160 (setq save-pos (point))
161 (skip-chars-forward "^/")
162 (setq host (buffer-substring save-pos (point)))
163 (if (string-match "^\\([^@]+\\)@" host)
164 (setq user (match-string 1 host)
165 host (substring host (match-end 0) nil)))
166 (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
167 (setq pass (match-string 2 user)
168 user (match-string 1 user)))
169 (if (string-match ":\\([0-9+]+\\)" host)
170 (setq port (string-to-int (match-string 1 host))
171 host (substring host 0 (match-beginning 0))))
172 (if (string-match ":$" host)
173 (setq host (substring host 0 (match-beginning 0))))
174 (setq host (downcase host)
175 save-pos (point))))
176
177 (if (not port)
178 (setq port (url-scheme-get-property prot 'default-port)))
179
180 ;; Gross hack to preserve ';' in data URLs
181
182 (setq save-pos (point))
183
184 (if (string= "data" prot)
185 (goto-char (point-max))
186 ;; Now check for references
187 (skip-chars-forward "^#")
188 (if (eobp)
189 nil
190 (delete-region
191 (point)
192 (progn
193 (skip-chars-forward "#")
194 (setq refs (buffer-substring (point) (point-max)))
195 (point-max))))
196 (goto-char save-pos)
197 (skip-chars-forward "^;")
198 (if (not (eobp))
199 (setq attr (url-parse-args (buffer-substring (point) (point-max)) t)
200 attr (nreverse attr))))
201
202 (setq file (buffer-substring save-pos (point)))
203 (if (and host (string-match "%[0-9][0-9]" host))
204 (setq host (url-unhex-string host)))
205 (vector prot user pass host port file refs attr full))))))
206
207(provide 'url-parse)
208
209;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403
210;;; url-parse.el ends here
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
new file mode 100644
index 00000000000..cb64cfbd4fc
--- /dev/null
+++ b/lisp/url/url-privacy.el
@@ -0,0 +1,81 @@
1;;; url-privacy.el --- Global history tracking for URL package
2;; Keywords: comm, data, processes, hypermedia
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25(eval-when-compile (require 'cl))
26(require 'url-vars)
27
28(if (fboundp 'device-type)
29 (defalias 'url-device-type 'device-type)
30 (defun url-device-type (&optional device) (or window-system 'tty)))
31
32;;;###autoload
33(defun url-setup-privacy-info ()
34 (interactive)
35 (setq url-system-type
36 (cond
37 ((or (eq url-privacy-level 'paranoid)
38 (and (listp url-privacy-level)
39 (memq 'os url-privacy-level)))
40 nil)
41 ;; First, we handle the inseparable OS/Windowing system
42 ;; combinations
43 ((eq system-type 'Apple-Macintosh) "Macintosh")
44 ((eq system-type 'next-mach) "NeXT")
45 ((eq system-type 'windows-nt) "Windows-NT; 32bit")
46 ((eq system-type 'ms-windows) "Windows; 16bit")
47 ((eq system-type 'ms-dos) "MS-DOS; 32bit")
48 ((memq (url-device-type) '(win32 w32)) "Windows; 32bit")
49 ((eq (url-device-type) 'pm) "OS/2; 32bit")
50 (t
51 (case (url-device-type)
52 (x "X11")
53 (ns "OpenStep")
54 (tty "TTY")
55 (otherwise nil)))))
56
57 (setq url-personal-mail-address (or url-personal-mail-address
58 user-mail-address
59 (format "%s@%s" (user-real-login-name)
60 (system-name))))
61
62 (if (or (memq url-privacy-level '(paranoid high))
63 (and (listp url-privacy-level)
64 (memq 'email url-privacy-level)))
65 (setq url-personal-mail-address nil))
66
67 (setq url-os-type
68 (cond
69 ((or (eq url-privacy-level 'paranoid)
70 (and (listp url-privacy-level)
71 (memq 'os url-privacy-level)))
72 nil)
73 ((boundp 'system-configuration)
74 system-configuration)
75 ((boundp 'system-type)
76 (symbol-name system-type))
77 (t nil))))
78
79(provide 'url-privacy)
80
81;;; arch-tag: fdaf95e4-98f0-4680-94c3-f3eadafabe1d
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index d4a3733eab5..5d1f73e0d5d 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -1,7 +1,6 @@
1;;; url-util.el --- Miscellaneous helper routines for URL library 1;;; url-util.el --- Miscellaneous helper routines for URL library
2 2
3;; Copyright (c) 1996,97,98,99,2001,2004 Free Software Foundation, Inc. 3;; Copyright (c) 1996,1997,1998,1999,2001,2004 Free Software Foundation, Inc.
4;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
5 4
6;; Author: Bill Perry <wmperry@gnu.org> 5;; Author: Bill Perry <wmperry@gnu.org>
7;; Keywords: comm, data, processes 6;; Keywords: comm, data, processes
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
new file mode 100644
index 00000000000..a33d8ba43e3
--- /dev/null
+++ b/lisp/url/url-vars.el
@@ -0,0 +1,431 @@
1;;; url-vars.el --- Variables for Uniform Resource Locator tool
2;; Keywords: comm, data, processes, hypermedia
3
4;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;; Copyright (c) 1996,1997,1998,1999,2001,2004 Free Software Foundation, Inc.
6;;;
7;;; This file is part of GNU Emacs.
8;;;
9;;; GNU Emacs is free software; you can redistribute it and/or modify
10;;; it under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 2, or (at your option)
12;;; any later version.
13;;;
14;;; GNU Emacs is distributed in the hope that it will be useful,
15;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Emacs; see the file COPYING. If not, write to the
21;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;;; Boston, MA 02111-1307, USA.
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24
25(require 'mm-util)
26
27(defconst url-version "Emacs"
28 "Version number of URL package.")
29
30(defgroup url nil
31 "Uniform Resource Locator tool"
32 :version "21.4"
33 :group 'hypermedia)
34
35(defgroup url-file nil
36 "URL storage"
37 :prefix "url-"
38 :group 'url)
39
40(defgroup url-cache nil
41 "URL cache"
42 :prefix "url-"
43 :prefix "url-cache-"
44 :group 'url)
45
46(defgroup url-mime nil
47 "MIME options of URL"
48 :prefix "url-"
49 :group 'url)
50
51(defgroup url-hairy nil
52 "Hairy options of URL"
53 :prefix "url-"
54 :group 'url)
55
56
57(defvar url-current-object nil
58 "A parsed representation of the current url.")
59
60(defvar url-current-mime-headers nil
61 "A parsed representation of the MIME headers for the current url.")
62
63(mapcar 'make-variable-buffer-local
64 '(
65 url-current-object
66 url-current-referer
67 url-current-mime-headers
68 ))
69
70(defcustom url-honor-refresh-requests t
71 "*Whether to do automatic page reloads.
72These are done at the request of the document author or the server via
73the `Refresh' header in an HTTP response. If nil, no refresh
74requests will be honored. If t, all refresh requests will be honored.
75If non-nil and not t, the user will be asked for each refresh
76request."
77 :type '(choice (const :tag "off" nil)
78 (const :tag "on" t)
79 (const :tag "ask" 'ask))
80 :group 'url-hairy)
81
82(defcustom url-automatic-caching nil
83 "*If non-nil, all documents will be automatically cached to the local disk."
84 :type 'boolean
85 :group 'url-cache)
86
87;; Fixme: sanitize this.
88(defcustom url-cache-expired
89 (lambda (t1 t2) (>= (- (car t2) (car t1)) 5))
90 "*A function determining if a cached item has expired.
91It takes two times (numbers) as its arguments, and returns non-nil if
92the second time is 'too old' when compared to the first time."
93 :type 'function
94 :group 'url-cache)
95
96(defconst url-bug-address "bug-gnu-emacs@gnu.org"
97 "Where to send bug reports.")
98
99(defcustom url-personal-mail-address nil
100 "*Your full email address.
101This is what is sent to HTTP servers as the FROM field in an HTTP
102request."
103 :type '(choice (const :tag "Unspecified" nil) string)
104 :group 'url)
105
106(defcustom url-directory-index-file "index.html"
107 "*The filename to look for when indexing a directory.
108If this file exists, and is readable, then it will be viewed instead of
109using `dired' to view the directory."
110 :type 'string
111 :group 'url-file)
112
113;; Fixme: this should have a setter which calls url-setup-privacy-info.
114(defcustom url-privacy-level '(email)
115 "*How private you want your requests to be.
116HTTP has header fields for various information about the user, including
117operating system information, email addresses, the last page you visited, etc.
118This variable controls how much of this information is sent.
119
120This should a symbol or a list.
121Valid values if a symbol are:
122none -- Send all information
123low -- Don't send the last location
124high -- Don't send the email address or last location
125paranoid -- Don't send anything
126
127If a list, this should be a list of symbols of what NOT to send.
128Valid symbols are:
129email -- the email address
130os -- the operating system info
131lastloc -- the last location
132agent -- Do not send the User-Agent string
133cookie -- never accept HTTP cookies
134
135Samples:
136
137 (setq url-privacy-level 'high)
138 (setq url-privacy-level '(email lastloc)) ;; equivalent to 'high
139 (setq url-privacy-level '(os))
140
141::NOTE::
142This variable controls several other variables and is _NOT_ automatically
143updated. Call the function `url-setup-privacy-info' after modifying this
144variable."
145 :type '(radio (const :tag "None (you believe in the basic goodness of humanity)"
146 :value none)
147 (const :tag "Low (do not reveal last location)"
148 :value low)
149 (const :tag "High (no email address or last location)"
150 :value high)
151 (const :tag "Paranoid (reveal nothing!)"
152 :value paranoid)
153 (checklist :tag "Custom"
154 (const :tag "Email address" :value email)
155 (const :tag "Operating system" :value os)
156 (const :tag "Last location" :value lastloc)
157 (const :tag "Browser identification" :value agent)
158 (const :tag "No cookies" :value cookie)))
159 :group 'url)
160
161(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.")
162
163(defcustom url-uncompressor-alist '((".z" . "x-gzip")
164 (".gz" . "x-gzip")
165 (".uue" . "x-uuencoded")
166 (".hqx" . "x-hqx")
167 (".Z" . "x-compress")
168 (".bz2" . "x-bzip2"))
169 "*An alist of file extensions and appropriate content-transfer-encodings."
170 :type '(repeat (cons :format "%v"
171 (string :tag "Extension")
172 (string :tag "Encoding")))
173 :group 'url-mime)
174
175(defcustom url-mail-command (if (fboundp 'compose-mail)
176 'compose-mail
177 'url-mail)
178 "*This function will be called whenever url needs to send mail.
179It should enter a mail-mode-like buffer in the current window.
180The commands `mail-to' and `mail-subject' should still work in this
181buffer, and it should use `mail-header-separator' if possible."
182 :type 'function
183 :group 'url)
184
185(defcustom url-proxy-services nil
186 "*An alist of schemes and proxy servers that gateway them.
187Looks like ((\"http\" . \"hostname:portnumber\") ...). This is set up
188from the ACCESS_proxy environment variables."
189 :type '(repeat (cons :format "%v"
190 (string :tag "Protocol")
191 (string :tag "Proxy")))
192 :group 'url)
193
194(defcustom url-passwd-entry-func nil
195 "*Symbol indicating which function to call to read in a password.
196It will be set up depending on whether you are running EFS or ange-ftp
197at startup if it is nil. This function should accept the prompt
198string as its first argument, and the default value as its second
199argument."
200 :type '(choice (const :tag "Guess" :value nil)
201 (const :tag "Use Ange-FTP" :value ange-ftp-read-passwd)
202 (const :tag "Use EFS" :value efs-read-passwd)
203 (const :tag "Use Password Package" :value read-passwd)
204 (function :tag "Other"))
205 :group 'url-hairy)
206
207(defcustom url-standalone-mode nil
208 "*Rely solely on the cache?"
209 :type 'boolean
210 :group 'url-cache)
211
212(defvar url-mime-separator-chars (mapcar 'identity
213 (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
214 "abcdefghijklmnopqrstuvwxyz"
215 "0123456789'()+_,-./=?"))
216 "Characters allowable in a MIME multipart separator.")
217
218(defcustom url-bad-port-list
219 '("25" "119" "19")
220 "*List of ports to warn the user about connecting to.
221Defaults to just the mail, chargen, and NNTP ports so you cannot be
222tricked into sending fake mail or forging messages by a malicious HTML
223document."
224 :type '(repeat (string :tag "Port"))
225 :group 'url-hairy)
226
227(defvar url-mime-content-type-charset-regexp
228 ";[ \t]*charset=\"?\\([^\"]+\\)\"?"
229 "Regexp used in parsing `Content-Type' for a charset indication.")
230
231(defvar url-request-data nil "Any data to send with the next request.")
232
233(defvar url-request-extra-headers nil
234 "A list of extra headers to send with the next request.
235Should be an assoc list of headers/contents.")
236
237(defvar url-request-method nil "The method to use for the next request.")
238
239;; FIXME!! (RFC 2616 gives examples like `compress, gzip'.)
240(defvar url-mime-encoding-string nil
241 "*String to send in the Accept-encoding: field in HTTP requests.")
242
243;; `mm-mime-mule-charset-alist' in Gnus 5.8/9 contains elements whose
244;; cars aren't valid MIME charsets/coding systems, at least in Emacs.
245;; This gets it correct by construction in Emacs. Fixme: DTRT for
246;; XEmacs -- its `coding-system-list' doesn't have the BASE-ONLY arg.
247(when (and (not (featurep 'xemacs))
248 (fboundp 'coding-system-list))
249 (setq mm-mime-mule-charset-alist
250 (apply
251 'nconc
252 (mapcar
253 (lambda (cs)
254 (when (and (coding-system-get cs 'mime-charset)
255 (not (eq t (coding-system-get cs 'safe-charsets))))
256 (list (cons (coding-system-get cs 'mime-charset)
257 (delq 'ascii
258 (coding-system-get cs 'safe-charsets))))))
259 (coding-system-list 'base-only)))))
260
261;; Perhaps the first few should actually be given decreasing `q's and
262;; the list should be trimmed significantly.
263;; Fixme: do something sane if we don't have `sort-coding-systems'
264;; (Emacs 20, XEmacs).
265(defun url-mime-charset-string ()
266 "Generate a list of preferred MIME charsets for HTTP requests.
267Generated according to current coding system priorities."
268 (if (fboundp 'sort-coding-systems)
269 (let ((ordered (sort-coding-systems
270 (let (accum)
271 (dolist (elt mm-mime-mule-charset-alist)
272 (if (mm-coding-system-p (car elt))
273 (push (car elt) accum)))
274 (nreverse accum)))))
275 (concat (format "%s;q=1, " (pop ordered))
276 (mapconcat 'symbol-name ordered ";q=0.5, ")
277 ";q=0.5"))))
278
279(defvar url-mime-charset-string (url-mime-charset-string)
280 "*String to send in the Accept-charset: field in HTTP requests.
281The MIME charset corresponding to the most preferred coding system is
282given priority 1 and the rest are given priority 0.5.")
283
284(defun url-set-mime-charset-string ()
285 (setq url-mime-charset-string (url-mime-charset-string)))
286;; Regenerate if the language environment changes.
287(add-hook 'set-language-environment-hook 'url-set-mime-charset-string)
288
289;; Fixme: set from the locale.
290(defcustom url-mime-language-string nil
291 "*String to send in the Accept-language: field in HTTP requests.
292
293Specifies the preferred language when servers can serve documents in
294several languages. Use RFC 1766 abbreviations, e.g.@: `en' for
295English, `de' for German. A comma-separated specifies descending
296order of preference. The ordering can be made explicit using `q'
297factors defined by HTTP, e.g. `de,en-gb;q=0.8,en;q=0.7'. `*' means
298get the first available language (as opposed to the default)."
299 :type '(radio
300 (const :tag "None (get default language version)" :value nil)
301 (const :tag "Any (get first available language version)" :value "*")
302 (string :tag "Other"))
303 :group 'url-mime
304 :group 'i18n)
305
306(defvar url-mime-accept-string nil
307 "String to send to the server in the Accept: field in HTTP requests.")
308
309(defvar url-package-version nil
310 "Version number of package using URL.")
311
312(defvar url-package-name nil "Version number of package using URL.")
313
314(defvar url-system-type nil
315 "What type of system we are on.")
316(defvar url-os-type nil
317 "What OS we are on.")
318
319(defcustom url-max-password-attempts 5
320 "*Maximum number of times a password will be prompted for.
321Applies when a protected document is denied by the server."
322 :type 'integer
323 :group 'url)
324
325(defcustom url-temporary-directory (or (getenv "TMPDIR") "/tmp")
326 "*Where temporary files go."
327 :type 'directory
328 :group 'url-file)
329
330(defcustom url-show-status t
331 "*Whether to show a running total of bytes transferred.
332Can cause a large hit if using a remote X display over a slow link, or
333a terminal with a slow modem."
334 :type 'boolean
335 :group 'url)
336
337(defvar url-using-proxy nil
338 "Either nil or the fully qualified proxy URL in use, e.g.
339http://www.domain.com/")
340
341(defcustom url-news-server nil
342 "*The default news server from which to get newsgroups/articles.
343Applies if no server is specified in the URL. Defaults to the
344environment variable NNTPSERVER or \"news\" if NNTPSERVER is
345undefined."
346 :type '(choice (const :tag "None" :value nil) string)
347 :group 'url)
348
349(defvar url-nonrelative-link
350 "\\`\\([-a-zA-Z0-9+.]+:\\)"
351 "A regular expression that will match an absolute URL.")
352
353(defcustom url-confirmation-func 'y-or-n-p
354 "*What function to use for asking yes or no functions.
355Possible values are `yes-or-no-p' or `y-or-n-p', or any function that
356takes a single argument (the prompt), and returns t only if a positive
357answer is given."
358 :type '(choice (const :tag "Short (y or n)" :value y-or-n-p)
359 (const :tag "Long (yes or no)" :value yes-or-no-p)
360 (function :tag "Other"))
361 :group 'url-hairy)
362
363(defcustom url-gateway-method 'native
364 "*The type of gateway support to use.
365Should be a symbol specifying how to get a connection from the local machine.
366
367Currently supported methods:
368`telnet': Run telnet in a subprocess to connect;
369`rlogin': Rlogin to another machine to connect;
370`socks': Connect through a socks server;
371`tls': Connect with TLS;
372`ssl': Connect with SSL (deprecated, use `tls' instead);
373`native': Connect directy."
374 :type '(radio (const :tag "Telnet to gateway host" :value telnet)
375 (const :tag "Rlogin to gateway host" :value rlogin)
376 (const :tag "Use SOCKS proxy" :value socks)
377 (const :tag "Use SSL/TLS for all connections" :value tls)
378 (const :tag "Use SSL for all connections (obsolete)" :value ssl)
379 (const :tag "Direct connection" :value native))
380 :group 'url-hairy)
381
382(defvar url-setup-done nil "Has setup configuration been done?")
383
384(defconst weekday-alist
385 '(("Sunday" . 0) ("Monday" . 1) ("Tuesday" . 2) ("Wednesday" . 3)
386 ("Thursday" . 4) ("Friday" . 5) ("Saturday" . 6)
387 ("Tues" . 2) ("Thurs" . 4)
388 ("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3)
389 ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))
390
391(defconst monthabbrev-alist
392 '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
393 ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11)
394 ("Dec" . 12)))
395
396(defvar url-lazy-message-time 0)
397
398;; Fixme: We may not be able to run SSL.
399(defvar url-extensions-header "Security/Digest Security/SSL")
400
401(defvar url-parse-syntax-table
402 (copy-syntax-table emacs-lisp-mode-syntax-table)
403 "*A syntax table for parsing URLs.")
404
405(modify-syntax-entry ?' "\"" url-parse-syntax-table)
406(modify-syntax-entry ?` "\"" url-parse-syntax-table)
407(modify-syntax-entry ?< "(>" url-parse-syntax-table)
408(modify-syntax-entry ?> ")<" url-parse-syntax-table)
409(modify-syntax-entry ?/ " " url-parse-syntax-table)
410
411(defvar url-load-hook nil
412 "*Hooks to be run after initalizing the URL library.")
413
414;;; Make OS/2 happy - yeeks
415;; (defvar tcp-binary-process-input-services nil
416;; "*Make OS/2 happy with our CRLF pairs...")
417
418(defconst url-working-buffer " *url-work")
419
420(defvar url-gateway-unplugged nil
421 "Non-nil means don't open new network connexions.
422This should be set, e.g. by mail user agents rendering HTML to avoid
423`bugs' which call home.")
424
425(defun url-vars-unload-hook ()
426 (remove-hook 'set-language-environment-hook 'url-set-mime-charset-string))
427
428(provide 'url-vars)
429
430;;; arch-tag: 29205e5f-c5ce-433c-8d5d-38cbaed64b49
431;;; url-vars.el ends here
diff --git a/lisp/url/url.el b/lisp/url/url.el
new file mode 100644
index 00000000000..f7b1b717681
--- /dev/null
+++ b/lisp/url/url.el
@@ -0,0 +1,269 @@
1;;; url.el --- Uniform Resource Locator retrieval tool
2
3;; Copyright (c) 1996,1997,1998,1999,2001,2004 Free Software Foundation, Inc.
4
5;; Author: Bill Perry <wmperry@gnu.org>
6;; Keywords: comm, data, processes, hypermedia
7
8;; This file is part of GNU Emacs.
9;;
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14;;
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19;;
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
28
29;;; Code:
30
31(eval-when-compile (require 'cl))
32;; Don't require CL at runtime if we can avoid it (Emacs 21).
33;; Otherwise we need it for hashing functions. `puthash' was never
34;; defined in the Emacs 20 cl.el for some reason.
35(if (fboundp 'puthash)
36 nil ; internal or CL is loaded
37 (defalias 'puthash 'cl-puthash)
38 (autoload 'cl-puthash "cl")
39 (autoload 'gethash "cl")
40 (autoload 'maphash "cl")
41 (autoload 'make-hash-table "cl"))
42
43(eval-when-compile
44 (require 'mm-decode)
45 (require 'mm-view))
46
47(require 'mailcap)
48(require 'url-vars)
49(require 'url-cookie)
50(require 'url-history)
51(require 'url-expand)
52(require 'url-privacy)
53(require 'url-methods)
54(require 'url-proxy)
55(require 'url-parse)
56(require 'url-util)
57
58;; Fixme: customize? convert-standard-filename?
59;;;###autoload
60(defvar url-configuration-directory "~/.url")
61
62(defun url-do-setup ()
63 "Setup the url package.
64This is to avoid conflict with user settings if URL is dumped with
65Emacs."
66 (unless url-setup-done
67
68 ;; Make OS/2 happy
69 ;;(push '("http" "80") tcp-binary-process-input-services)
70
71 (mailcap-parse-mailcaps)
72 (mailcap-parse-mimetypes)
73
74 ;; Register all the authentication schemes we can handle
75 (url-register-auth-scheme "basic" nil 4)
76 (url-register-auth-scheme "digest" nil 7)
77
78 (setq url-cookie-file
79 (or url-cookie-file
80 (expand-file-name "cookies" url-configuration-directory)))
81
82 (setq url-history-file
83 (or url-history-file
84 (expand-file-name "history" url-configuration-directory)))
85
86 ;; Parse the global history file if it exists, so that it can be used
87 ;; for URL completion, etc.
88 (url-history-parse-history)
89 (url-history-setup-save-timer)
90
91 ;; Ditto for cookies
92 (url-cookie-setup-save-timer)
93 (url-cookie-parse-file url-cookie-file)
94
95 ;; Read in proxy gateways
96 (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
97 (or (getenv "NO_PROXY")
98 (getenv "no_PROXY")
99 (getenv "no_proxy")))))
100 (if noproxy
101 (setq url-proxy-services
102 (cons (cons "no_proxy"
103 (concat "\\("
104 (mapconcat
105 (lambda (x)
106 (cond
107 ((= x ?,) "\\|")
108 ((= x ? ) "")
109 ((= x ?.) (regexp-quote "."))
110 ((= x ?*) ".*")
111 ((= x ??) ".")
112 (t (char-to-string x))))
113 noproxy "") "\\)"))
114 url-proxy-services))))
115
116 ;; Set the password entry funtion based on user defaults or guess
117 ;; based on which remote-file-access package they are using.
118 (cond
119 (url-passwd-entry-func nil) ; Already been set
120 ((fboundp 'read-passwd) ; Use secure password if available
121 (setq url-passwd-entry-func 'read-passwd))
122 ((or (featurep 'efs) ; Using EFS
123 (featurep 'efs-auto)) ; or autoloading efs
124 (if (not (fboundp 'read-passwd))
125 (autoload 'read-passwd "passwd" "Read in a password" nil))
126 (setq url-passwd-entry-func 'read-passwd))
127 ((or (featurep 'ange-ftp) ; Using ange-ftp
128 (and (boundp 'file-name-handler-alist)
129 (not (featurep 'xemacs)))) ; ??
130 (setq url-passwd-entry-func 'ange-ftp-read-passwd))
131 (t
132 (url-warn
133 'security
134 "(url-setup): Can't determine how to read passwords, winging it.")))
135
136 (url-setup-privacy-info)
137 (run-hooks 'url-load-hook)
138 (setq url-setup-done t)))
139
140;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
141;;; Retrieval functions
142;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
143(defun url-retrieve (url callback &optional cbargs)
144 "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
145The callback is called when the object has been completely retrieved, with
146the current buffer containing the object, and any MIME headers associated
147with it. URL is either a string or a parsed URL.
148
149Return the buffer URL will load into, or nil if the process has
150already completed."
151 (url-do-setup)
152 (url-gc-dead-buffers)
153 (if (stringp url)
154 (set-text-properties 0 (length url) nil url))
155 (if (not (vectorp url))
156 (setq url (url-generic-parse-url url)))
157 (if (not (functionp callback))
158 (error "Must provide a callback function to url-retrieve"))
159 (unless (url-type url)
160 (error "Bad url: %s" (url-recreate-url url)))
161 (let ((loader (url-scheme-get-property (url-type url) 'loader))
162 (url-using-proxy (if (url-host url)
163 (url-find-proxy-for-url url (url-host url))))
164 (buffer nil)
165 (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
166 (if url-using-proxy
167 (setq asynch t
168 loader 'url-proxy))
169 (if asynch
170 (setq buffer (funcall loader url callback cbargs))
171 (setq buffer (funcall loader url))
172 (if buffer
173 (with-current-buffer buffer
174 (apply callback cbargs))))
175 (url-history-update-url url (current-time))
176 buffer))
177
178(defun url-retrieve-synchronously (url)
179 "Retrieve URL synchronously.
180Return the buffer containing the data, or nil if there are no data
181associated with it (the case for dired, info, or mailto URLs that need
182no further processing). URL is either a string or a parsed URL."
183 (url-do-setup)
184
185 (lexical-let ((retrieval-done nil)
186 (asynch-buffer nil))
187 (setq asynch-buffer
188 (url-retrieve url (lambda (&rest ignored)
189 (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
190 (setq retrieval-done t
191 asynch-buffer (current-buffer)))))
192 (if (not asynch-buffer)
193 ;; We do not need to do anything, it was a mailto or something
194 ;; similar that takes processing completely outside of the URL
195 ;; package.
196 nil
197 (while (not retrieval-done)
198 (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)"
199 retrieval-done asynch-buffer)
200 ;; Quoth Stef:
201 ;; It turns out that the problem seems to be that the (sit-for
202 ;; 0.1) below doesn't actually process the data: instead it
203 ;; returns immediately because there is keyboard input
204 ;; waiting, so we end up spinning endlessly waiting for the
205 ;; process to finish while not letting it finish.
206
207 ;; However, raman claims that it blocks Emacs with Emacspeak
208 ;; for unexplained reasons. Put back for his benefit until
209 ;; someone can understand it.
210 ;; (sleep-for 0.1)
211 (sit-for 0.1))
212 asynch-buffer)))
213
214(defun url-mm-callback (&rest ignored)
215 (let ((handle (mm-dissect-buffer t)))
216 (save-excursion
217 (url-mark-buffer-as-dead (current-buffer))
218 (set-buffer (generate-new-buffer (url-recreate-url url-current-object)))
219 (if (eq (mm-display-part handle) 'external)
220 (progn
221 (set-process-sentinel
222 ;; Fixme: this shouldn't have to know the form of the
223 ;; undisplayer produced by `mm-display-part'.
224 (get-buffer-process (cdr (mm-handle-undisplayer handle)))
225 `(lambda (proc event)
226 (mm-destroy-parts (quote ,handle))))
227 (message "Viewing externally")
228 (kill-buffer (current-buffer)))
229 (display-buffer (current-buffer))
230 (mm-destroy-parts handle)))))
231
232(defun url-mm-url (url)
233 "Retrieve URL and pass to the appropriate viewing application."
234 (require 'mm-decode)
235 (require 'mm-view)
236 (url-retrieve url 'url-mm-callback nil))
237
238;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
239;;; Miscellaneous
240;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241(defvar url-dead-buffer-list nil)
242
243(defun url-mark-buffer-as-dead (buff)
244 (push buff url-dead-buffer-list))
245
246(defun url-gc-dead-buffers ()
247 (let ((buff))
248 (while (setq buff (pop url-dead-buffer-list))
249 (if (buffer-live-p buff)
250 (kill-buffer buff)))))
251
252(cond
253 ((fboundp 'display-warning)
254 (defalias 'url-warn 'display-warning))
255 ((fboundp 'warn)
256 (defun url-warn (class message &optional level)
257 (warn "(%s/%s) %s" class (or level 'warning) message)))
258 (t
259 (defun url-warn (class message &optional level)
260 (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
261 (goto-char (point-max))
262 (save-excursion
263 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
264 (display-buffer (current-buffer))))))
265
266(provide 'url)
267
268;; arch-tag: bc182f1f-d187-4f10-b961-47af2066579a
269;;; url.el ends here
diff --git a/lisp/vc.el b/lisp/vc.el
index 663c45fd466..a0d3d1cd4be 100644
--- a/lisp/vc.el
+++ b/lisp/vc.el
@@ -646,9 +646,6 @@ List of factors, used to expand/compress the time scale. See `vc-annotate'."
646 :group 'vc) 646 :group 'vc)
647 647
648;; vc-annotate functionality (CVS only). 648;; vc-annotate functionality (CVS only).
649(defvar vc-annotate-mode nil
650 "Variable indicating if VC-Annotate mode is active.")
651
652(defvar vc-annotate-mode-map 649(defvar vc-annotate-mode-map
653 (let ((m (make-sparse-keymap))) 650 (let ((m (make-sparse-keymap)))
654 (define-key m [menu-bar] (make-sparse-keymap "VC-Annotate")) 651 (define-key m [menu-bar] (make-sparse-keymap "VC-Annotate"))
@@ -3004,7 +3001,7 @@ use; you may override this using the second optional arg MODE."
3004 (when buffer 3001 (when buffer
3005 (set-buffer buffer) 3002 (set-buffer buffer)
3006 (display-buffer buffer)) 3003 (display-buffer buffer))
3007 (if (not vc-annotate-mode) ; Turn on vc-annotate-mode if not done 3004 (if (not vc-annotate-parent-rev)
3008 (vc-annotate-mode)) 3005 (vc-annotate-mode))
3009 (cond ((null vc-annotate-display-mode) 3006 (cond ((null vc-annotate-display-mode)
3010 (vc-annotate-display-default vc-annotate-ratio)) 3007 (vc-annotate-display-default vc-annotate-ratio))
diff --git a/lisp/xml.el b/lisp/xml.el
index 993ef59b276..b0d5d45f98d 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -598,8 +598,8 @@ This follows the rule [28] in the XML specifications."
598 nil) 598 nil)
599 (t 599 (t
600 (if xml-validating-parser 600 (if xml-validating-parser
601 error "XML: (Validity) Invalid element type in the DTD"))) 601 (error "XML: (Validity) Invalid element type in the DTD"))))
602 602
603 ;; rule [45]: the element declaration must be unique 603 ;; rule [45]: the element declaration must be unique
604 (if (and (assoc element dtd) 604 (if (and (assoc element dtd)
605 xml-validating-parser) 605 xml-validating-parser)
@@ -727,14 +727,9 @@ This follows the rule [28] in the XML specifications."
727 (match-string 1 this-part))))))) 727 (match-string 1 this-part)))))))
728 728
729 (cond ((null children) 729 (cond ((null children)
730 (if (stringp expansion) 730 ;; FIXME: If we have an entity that expands into XML, this won't work.
731 (setq children (concat prev-part expansion)) 731 (setq children
732 (if (stringp (car (last expansion))) 732 (concat prev-part expansion)))
733 (progn
734 (setq children
735 (list (concat prev-part (car expansion))
736 (cdr expansion))))
737 (setq children (append expansion prev-part)))))
738 ((stringp children) 733 ((stringp children)
739 (if (stringp expansion) 734 (if (stringp expansion)
740 (setq children (concat children prev-part expansion)) 735 (setq children (concat children prev-part expansion))
@@ -756,11 +751,15 @@ This follows the rule [28] in the XML specifications."
756 (cond ((stringp children) 751 (cond ((stringp children)
757 (concat children (substring string point))) 752 (concat children (substring string point)))
758 ((stringp (car (last children))) 753 ((stringp (car (last children)))
759 (concat (car children) (substring string point))) 754 (concat (car (last children)) (substring string point)))
760 ((null children) 755 ((null children)
761 string) 756 string)
762 (t 757 (t
763 (nreverse children))))) 758 (concat (mapconcat 'identity
759 (nreverse children)
760 "")
761 (substring string point))))))
762
764;;******************************************************************* 763;;*******************************************************************
765;;** 764;;**
766;;** Printing a tree. 765;;** Printing a tree.