mirrored from git://git.sv.gnu.org/emacs.git
-
Notifications
You must be signed in to change notification settings - Fork 1.3k
/
url.el
346 lines (300 loc) · 12.9 KB
/
url.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
;;; url.el --- Uniform Resource Locator retrieval tool -*- lexical-binding: t -*-
;; Copyright (C) 1996-1999, 2001, 2004-2024 Free Software Foundation,
;; Inc.
;; Author: Bill Perry <[email protected]>
;; Maintainer: [email protected]
;; Keywords: comm, data, processes, hypermedia
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Registered URI schemes: https://www.iana.org/assignments/uri-schemes
;;; Code:
(require 'mailcap)
(eval-when-compile
(require 'mm-decode)
(require 'mm-view))
(require 'url-vars)
(require 'url-cookie)
(require 'url-history)
(require 'url-expand)
(require 'url-privacy)
(require 'url-methods)
(require 'url-proxy)
(require 'url-parse)
(require 'url-util)
(defcustom url-configuration-directory
(locate-user-emacs-file "url/" ".url/")
"Directory used by the URL package for cookies, history, etc."
:type 'directory
:group 'url)
(defun url-do-setup ()
"Setup the URL package.
This is to avoid conflict with user settings if URL is dumped with
Emacs."
(unless url-setup-done
(mailcap-parse-mailcaps)
(mailcap-parse-mimetypes)
;; Register all the authentication schemes we can handle
(url-register-auth-scheme "basic" nil 4)
(url-register-auth-scheme "digest" nil 7)
(setq url-cookie-file
(or url-cookie-file
(expand-file-name "cookies" url-configuration-directory)))
(setq url-history-file
(or url-history-file
(expand-file-name "history" url-configuration-directory)))
;; Parse the global history file if it exists, so that it can be used
;; for URL completion, etc.
(url-history-parse-history)
(url-history-setup-save-timer)
;; Ditto for cookies
(url-cookie-setup-save-timer)
(url-cookie-parse-file url-cookie-file)
;; Read in proxy gateways
(let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
(or (getenv "NO_PROXY")
(getenv "no_PROXY")
(getenv "no_proxy")))))
(if noproxy
(setq url-proxy-services
(cons (cons "no_proxy"
(concat "\\("
(mapconcat
(lambda (x)
(cond
((= x ?,) "\\|")
((= x ? ) "")
((= x ?.) (regexp-quote "."))
((= x ?*) ".*")
((= x ??) ".")
(t (char-to-string x))))
noproxy "") "\\)"))
url-proxy-services))))
(url-setup-privacy-info)
(run-hooks 'url-load-hook)
(setq url-setup-done t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Retrieval functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar url-redirect-buffer nil
"New buffer into which the retrieval will take place.
Sometimes while retrieving a URL, the URL library needs to use another buffer
than the one returned initially by `url-retrieve'. In this case, it sets this
variable in the original buffer as a forwarding pointer.")
(defvar url-retrieve-number-of-calls 0)
(autoload 'url-cache-prune-cache "url-cache")
(defvar url-asynchronous t
"Bind to nil before calling `url-retrieve' to signal :nowait connections.")
;;;###autoload
(defun url-retrieve (url callback &optional cbargs silent inhibit-cookies)
"Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
URL is either a string or a parsed URL. If it is a string
containing characters that are not valid in a URI, those
characters are percent-encoded; see `url-encode-url'.
CALLBACK is called when the object has been completely retrieved, with
the current buffer containing the object, and any MIME headers associated
with it. It is called as (apply CALLBACK STATUS CBARGS).
STATUS is a plist representing what happened during the request,
with most recent events first, or an empty list if no events have
occurred. Each pair is one of:
\(:redirect REDIRECTED-TO) - the request was redirected to this URL.
\(:error (error type . DATA)) - an error occurred. TYPE is a
symbol that says something about where the error occurred, and
DATA is a list (possibly nil) that describes the error further.
Return the buffer URL will load into, or nil if the process has
already completed (i.e. URL was a mailto URL or similar; in this case
the callback is not called).
The variables `url-request-data', `url-request-method' and
`url-request-extra-headers' can be dynamically bound around the
request; dynamic binding of other variables doesn't necessarily
take effect.
If SILENT, then don't message progress reports and the like.
If INHIBIT-COOKIES, cookies will neither be stored nor sent to
the server.
If URL is a multibyte string, it will be encoded as utf-8 and
URL-encoded before it's used."
;; XXX: There is code in Emacs that does dynamic binding
;; of the following variables around url-retrieve:
;; url-standalone-mode, url-gateway-unplugged,
;; url-confirmation-func, url-cookie-multiple-line,
;; url-cookie-{{,secure-}storage,confirmation}
;; url-standalone-mode and url-gateway-unplugged should work as
;; usual. url-confirmation-func is only used in nnwarchive.el and
;; webmail.el; the latter should be updated. Is
;; url-cookie-multiple-line needed anymore? The other url-cookie-*
;; are (for now) only used in synchronous retrievals.
(url-retrieve-internal url callback (cons nil cbargs) silent
inhibit-cookies))
(defun url-retrieve-internal (url callback cbargs &optional silent
inhibit-cookies)
"Internal function; external interface is `url-retrieve'.
The callback function will receive an updated value of CBARGS as
arguments; its first element should be a plist specifying what has
happened so far during the request, as described in the docstring
of `url-retrieve' (if in doubt, specify nil).
If SILENT, don't message progress reports and the like.
If INHIBIT-COOKIES, cookies will neither be stored nor sent to
the server.
If URL is a multibyte string, it will be encoded as utf-8 and
URL-encoded before it's used."
(url-do-setup)
(url-gc-dead-buffers)
(when (stringp url)
(set-text-properties 0 (length url) nil url)
(setq url (url-encode-url url)))
(if (not (url-p url))
(setq url (url-generic-parse-url url)))
(if (not (functionp callback))
(error "Must provide a callback function to url-retrieve"))
(unless (url-type url)
(error "Bad url: %s" (url-recreate-url url)))
(setf (url-silent url) silent)
(setf (url-asynchronous url) url-asynchronous)
(setf (url-use-cookies url) (not inhibit-cookies))
;; Once in a while, remove old entries from the URL cache.
(when (zerop (% url-retrieve-number-of-calls 1000))
(condition-case error
(url-cache-prune-cache)
(file-error
(message "Error when expiring the cache: %s" error))))
(setq url-retrieve-number-of-calls (1+ url-retrieve-number-of-calls))
(let ((loader (url-scheme-get-property (url-type url) 'loader))
(url-using-proxy (if (url-host url)
(url-find-proxy-for-url url (url-host url))))
(buffer nil)
(asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
(when url-using-proxy
(setf asynch t
loader #'url-proxy
(url-asynchronous url) t))
(if asynch
(let ((url-current-object url))
(setq buffer (funcall loader url callback cbargs)))
(setq buffer (funcall loader url))
(if buffer
(with-current-buffer buffer
(apply callback cbargs))))
(if url-history-track
(url-history-update-url url (current-time)))
buffer))
;;;###autoload
(defun url-retrieve-synchronously (url &optional silent inhibit-cookies timeout)
"Retrieve URL synchronously.
Return the buffer containing the data, or nil if there are no data
associated with it (the case for Dired, info, or mailto URLs that need
no further processing). URL is either a string or a parsed URL.
If SILENT is non-nil, don't do any messaging while retrieving.
If INHIBIT-COOKIES is non-nil, refuse to store cookies. If
TIMEOUT is passed, it should be a number that says (in seconds)
how long to wait for a response before giving up."
(url-do-setup)
(let* (;; Ensure we can stop during connection setup (bug#71295).
(url-asynchronous (not (null timeout)))
data-buffer
(callback (lambda (&rest _args)
(setq data-buffer (current-buffer))
(url-debug 'retrieval
"Synchronous fetching done (%S)"
data-buffer)))
(start-time (current-time))
(proc-buffer (url-retrieve url callback nil silent
inhibit-cookies)))
(if (not proc-buffer)
(url-debug 'retrieval "Synchronous fetching unnecessary %s" url)
(unwind-protect
(catch 'done
(while (not data-buffer)
(when (and timeout (time-less-p timeout
(time-since start-time)))
(url-debug 'retrieval "Timed out %s (after %ss)" url
(float-time (time-since start-time)))
(throw 'done 'timeout))
(url-debug 'retrieval
"Spinning in url-retrieve-synchronously: nil (%S)"
proc-buffer)
(when-let* ((redirect-buffer
(buffer-local-value 'url-redirect-buffer
proc-buffer)))
(unless (eq redirect-buffer proc-buffer)
(url-debug
'retrieval "Redirect in url-retrieve-synchronously: %S -> %S"
proc-buffer redirect-buffer)
(let (kill-buffer-query-functions)
(kill-buffer proc-buffer))
;; Accommodate hack in commit 55d1d8b.
(setq proc-buffer redirect-buffer)))
(when-let* ((proc (get-buffer-process proc-buffer)))
(when (memq (process-status proc)
'(closed exit signal failed))
;; Process sentinel vagaries occasionally cause
;; url-retrieve to fail calling callback.
(unless data-buffer
(url-debug 'retrieval "Dead process %s" url)
(throw 'done 'exception))))
;; Querying over consumer internet in the US takes 100
;; ms, so split the difference.
(accept-process-output nil 0.05)))
;; Kill the process buffer on redirects.
(when (and data-buffer
(not (eq data-buffer proc-buffer)))
(let (kill-buffer-query-functions)
(kill-buffer proc-buffer)))))
data-buffer))
;; url-mm-callback called from url-mm, which requires mm-decode.
(declare-function mm-dissect-buffer "mm-decode"
(&optional no-strict-mime loose-mime from))
(declare-function mm-display-part "mm-decode"
(handle &optional no-default force))
(defun url-mm-callback (&rest _ignored)
(let ((handle (mm-dissect-buffer t)))
(url-mark-buffer-as-dead (current-buffer))
(with-current-buffer
(generate-new-buffer (url-recreate-url url-current-object))
(if (eq (mm-display-part handle) 'external)
(progn
(set-process-sentinel
;; Fixme: this shouldn't have to know the form of the
;; undisplayer produced by `mm-display-part'.
(get-buffer-process (cdr (mm-handle-undisplayer handle)))
`(lambda (proc event)
(mm-destroy-parts (quote ,handle))))
(message "Viewing externally")
(kill-buffer (current-buffer)))
(display-buffer (current-buffer))
(add-hook 'kill-buffer-hook
`(lambda () (mm-destroy-parts ',handle))
nil
t)))))
(defun url-mm-url (url)
"Retrieve URL and pass to the appropriate viewing application."
;; These requires could advantageously be moved to url-mm-callback or
;; turned into autoloads, but I suspect that it would introduce some bugs
;; because loading those files from a process sentinel or filter may
;; result in some undesirable corner cases.
(require 'mm-decode)
(require 'mm-view)
(url-retrieve url 'url-mm-callback nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar url-dead-buffer-list nil)
(defun url-mark-buffer-as-dead (buff)
(push buff url-dead-buffer-list))
(defun url-gc-dead-buffers ()
(let ((buff))
(while (setq buff (pop url-dead-buffer-list))
(if (buffer-live-p buff)
(kill-buffer buff)))))
(define-obsolete-function-alias 'url-warn #'display-warning "28.1")
(provide 'url)
;;; url.el ends here