diff options
Diffstat (limited to 'lisp/url')
| -rw-r--r-- | lisp/url/url-about.el | 2 | ||||
| -rw-r--r-- | lisp/url/url-expand.el | 11 | ||||
| -rw-r--r-- | lisp/url/url-gw.el | 2 | ||||
| -rw-r--r-- | lisp/url/url-http.el | 35 | ||||
| -rw-r--r-- | lisp/url/url-news.el | 2 | ||||
| -rw-r--r-- | lisp/url/url-queue.el | 29 | ||||
| -rw-r--r-- | lisp/url/url-util.el | 4 | ||||
| -rw-r--r-- | lisp/url/url-vars.el | 3 | ||||
| -rw-r--r-- | lisp/url/url.el | 19 |
9 files changed, 67 insertions, 40 deletions
diff --git a/lisp/url/url-about.el b/lisp/url/url-about.el index dde47e94de5..5fe817cc0e8 100644 --- a/lisp/url/url-about.el +++ b/lisp/url/url-about.el @@ -51,7 +51,7 @@ " <title>Supported Protocols</title>\n" " </head>\n" " <body>\n" - " <h1>Supported Protocols - URL v" url-version "</h1>\n" + " <h1>Supported Protocols - URL package in Emacs " emacs-version "</h1>\n" " <table width='100%' border='1'>\n" " <tr>\n" " <td>Protocol\n" diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el index 47964b081f4..f34ef810c4a 100644 --- a/lisp/url/url-expand.el +++ b/lisp/url/url-expand.el @@ -92,12 +92,19 @@ path components followed by `..' are removed, along with the `..' itself." (cond ((= (length url) 0) ; nil or empty string (url-recreate-url default)) - ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately + ((string-match url-nonrelative-link url) ; Fully-qualified URL, + ; return it immediately url) (t (let* ((urlobj (url-generic-parse-url url)) (inhibit-file-name-handlers t) - (expander (url-scheme-get-property (url-type default) 'expand-file-name))) + (expander (if (url-type default) + (url-scheme-get-property (url-type default) + 'expand-file-name) + ;; If neither the default nor the URL to be + ;; expanded have a protocol, then just use the + ;; identity expander as a fallback. + 'url-identity-expander))) (if (string-match "^//" url) (setq urlobj (url-generic-parse-url (concat (url-type default) ":" url)))) diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index bcb67431aa8..f16fc234025 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -191,7 +191,7 @@ linked Emacs under SunOS 4.x." proc (concat (mapconcat 'identity (append url-gateway-telnet-parameters (list host service)) " ") "\n")) - (url-wait-for-string "^\r*Escape character.*\r*\n+" proc) + (url-wait-for-string "^\r*Escape character.*\n+" proc) (delete-region (point-min) (match-end 0)) (process-send-string proc "\^]\n") (url-wait-for-string "^telnet" proc) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 55953c83c04..8532da1d1fb 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -225,7 +225,7 @@ request.") (os-info (unless (and (listp url-privacy-level) (memq 'os url-privacy-level)) (format "(%s; %s)" url-system-type url-os-type))) - (url-info (format "URL/%s" url-version))) + (url-info (format "URL/Emacs"))) (string-join (delq nil (list package-info url-info emacs-info os-info)) " "))) @@ -702,15 +702,7 @@ should be shown to the user." ;; Treat everything like '300' nil)) (when redirect-uri - ;; Clean off any whitespace and/or <...> cruft. - (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - (if (string-match "^<\\(.*\\)>$" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - - ;; Some stupid sites (like sourceforge) send a - ;; non-fully-qualified URL (ie: /), which royally confuses - ;; the URL library. + ;; Handle relative redirect URIs. (if (not (string-match url-nonrelative-link redirect-uri)) ;; Be careful to use the real target URL, otherwise we may ;; compute the redirection relative to the URL of the proxy. @@ -1404,13 +1396,22 @@ The return value of this function is the retrieval buffer." (defun url-https-proxy-connect (connection) (setq url-http-after-change-function 'url-https-proxy-after-change-function) - (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n" - "Host: %s\r\n" - "\r\n") - (url-host url-current-object) - (or (url-port url-current-object) - url-https-default-port) - (url-host url-current-object)))) + (process-send-string + connection + (format + (concat "CONNECT %s:%d HTTP/1.1\r\n" + "Host: %s\r\n" + (let ((proxy-auth (let ((url-basic-auth-storage + 'url-http-proxy-basic-auth-storage)) + (url-get-authentication url-http-proxy nil + 'any nil)))) + (and proxy-auth + (concat "Proxy-Authorization: " proxy-auth "\r\n"))) + "\r\n") + (url-host url-current-object) + (or (url-port url-current-object) + url-https-default-port) + (url-host url-current-object)))) (defun url-https-proxy-after-change-function (_st _nd _length) (let* ((process-buffer (current-buffer)) diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el index d47eb02db68..9ef17cccd77 100644 --- a/lisp/url/url-news.el +++ b/lisp/url/url-news.el @@ -75,7 +75,7 @@ " </div>\n" " </body>\n" "</html>\n" - "<!-- Automatically generated by URL v" url-version " -->\n" + "<!-- Automatically generated by URL in Emacs " emacs-version " -->\n" ))) buf)) diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index ff18cf1fe40..46cdff0f724 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -123,17 +123,24 @@ The variable `url-queue-timeout' sets a timeout." (setq url-queue-progress-timer nil)))) (defun url-queue-callback-function (status job) - (setq url-queue (delq job url-queue)) - (when (and (eq (car status) :error) - (eq (cadr (cadr status)) 'connection-failed)) - ;; If we get a connection error, then flush all other jobs from - ;; the host from the queue. This particularly makes sense if the - ;; error really is a DNS resolver issue, which happens - ;; synchronously and totally halts Emacs. - (url-queue-remove-jobs-from-host - (plist-get (nthcdr 3 (cadr status)) :host))) - (url-queue-run-queue) - (apply (url-queue-callback job) (cons status (url-queue-cbargs job)))) + (let ((buffer (current-buffer))) + (setq url-queue (delq job url-queue)) + (when (and (eq (car status) :error) + (eq (cadr (cadr status)) 'connection-failed)) + ;; If we get a connection error, then flush all other jobs from + ;; the host from the queue. This particularly makes sense if the + ;; error really is a DNS resolver issue, which happens + ;; synchronously and totally halts Emacs. + (url-queue-remove-jobs-from-host + (plist-get (nthcdr 3 (cadr status)) :host))) + (url-queue-run-queue) + ;; Somehow something deep in the bowels in the URL library may + ;; have killed off the current buffer. So check that it's still + ;; alive before doing anything, and if not, just create a dummy + ;; buffer and do the callback anyway. + (unless (buffer-live-p buffer) + (set-buffer (generate-new-buffer " *temp*"))) + (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))) (defun url-queue-remove-jobs-from-host (host) (let ((jobs nil)) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 645011a5783..6dd7a9c2aac 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -615,9 +615,7 @@ Creates FILE and its parent directories if they do not exist." (with-temp-buffer (write-region (point-min) (point-max) file nil 'silent nil 'excl))) (file-already-exists - (if (file-symlink-p file) - (error "Danger: `%s' is a symbolic link" file)) - (set-file-modes file #o0600)))) + (set-file-modes file #o0600 'nofollow)))) (autoload 'puny-encode-domain "puny") (autoload 'url-domsuf-cookie-allowed-p "url-domsuf") diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 82617b76a71..d9277cf6f42 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -24,6 +24,7 @@ (defconst url-version "Emacs" "Version number of URL package.") +(make-obsolete-variable 'url-version nil "28.1") (defgroup url nil "Uniform Resource Locator tool." @@ -430,6 +431,8 @@ Should be one of: "Hook run after initializing the URL library." :group 'url :type 'hook) +(make-obsolete-variable 'url-load-hook + "use `with-eval-after-load' instead." "28.1") (defconst url-working-buffer " *url-work") diff --git a/lisp/url/url.el b/lisp/url/url.el index 12a8a9c2e21..321e79c019f 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -238,7 +238,8 @@ how long to wait for a response before giving up." (let ((retrieval-done nil) (start-time (current-time)) (url-asynchronous nil) - (asynch-buffer nil)) + (asynch-buffer nil) + (timed-out nil)) (setq asynch-buffer (url-retrieve url (lambda (&rest ignored) (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) @@ -261,7 +262,9 @@ how long to wait for a response before giving up." ;; process output. (while (and (not retrieval-done) (or (not timeout) - (time-less-p (time-since start-time) timeout))) + (not (setq timed-out + (time-less-p timeout + (time-since start-time)))))) (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" retrieval-done asynch-buffer) @@ -300,8 +303,16 @@ how long to wait for a response before giving up." (when quit-flag (delete-process proc)) (setq proc (and (not quit-flag) - (get-buffer-process asynch-buffer))))))) - asynch-buffer))) + (get-buffer-process asynch-buffer)))))) + ;; On timeouts, make sure we kill any pending processes. + ;; There may be more than one if we had a redirect. + (when timed-out + (when (process-live-p proc) + (delete-process proc)) + (when-let ((aproc (get-buffer-process asynch-buffer))) + (when (process-live-p aproc) + (delete-process aproc)))))) + asynch-buffer)) ;; url-mm-callback called from url-mm, which requires mm-decode. (declare-function mm-dissect-buffer "mm-decode" |