Merge from emacs-24; up to 2014-07-21T01:34:03Z!monnier@iro.umontreal.ca

[gnu-emacs] / lisp / url / url-gw.el

diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index 7d80f2f672561f1fc215a2e1559a788f78c3a00a..4a6189dcfeab3c032e2779e65b55a9ec32122a58 100644 (file)
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -1,8 +1,9 @@
 ;;; url-gw.el --- Gateway munging for URL loading
 
-;; Copyright (C) 1997-1998, 2004-2011  Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2004-2014 Free Software Foundation, Inc.
 
 ;; Author: Bill Perry <wmperry@gnu.org>
+;; Maintainer: emacs-devel@gnu.org
 ;; Keywords: comm, data, processes
 
 ;; This file is part of GNU Emacs.
@@ -22,7 +23,6 @@
 
 ;;; Code:
 
-(eval-when-compile (require 'cl))
 (require 'url-vars)
 
 ;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program?
@@ -72,12 +72,12 @@ This list will be executed as a command after logging in via telnet."
   :group 'url-gateway)
 
 (defcustom url-gateway-telnet-login-prompt "^\r*.?login:"
-  "Prompt that tells us we should send our username when loggin in w/telnet."
+  "Prompt that tells us we should send our username when logging in w/telnet."
   :type 'regexp
   :group 'url-gateway)
 
 (defcustom url-gateway-telnet-password-prompt "^\r*.?password:"
-  "Prompt that tells us we should send our password when loggin in w/telnet."
+  "Prompt that tells us we should send our password when logging in w/telnet."
   :type 'regexp
   :group 'url-gateway)
 
@@ -203,20 +203,24 @@ linked Emacs under SunOS 4.x."
       proc)))
 
 ;;;###autoload
-(defun url-open-stream (name buffer host service)
+(defun url-open-stream (name buffer host service &optional gateway-method)
   "Open a stream to HOST, possibly via a gateway.
 Args per `open-network-stream'.
 Will not make a connection if `url-gateway-unplugged' is non-nil.
-Might do a non-blocking connection; use `process-status' to check."
+Might do a non-blocking connection; use `process-status' to check.
+
+Optional arg GATEWAY-METHOD specifies the gateway to be used,
+overriding the value of `url-gateway-method'."
   (unless url-gateway-unplugged
-    (let ((gw-method (if (and url-gateway-local-host-regexp
-                             (not (eq 'tls url-gateway-method))
-                             (not (eq 'ssl url-gateway-method))
-                             (string-match
-                              url-gateway-local-host-regexp
-                              host))
-                        'native
-                      url-gateway-method))
+    (let* ((gwm (or gateway-method url-gateway-method))
+           (gw-method (if (and url-gateway-local-host-regexp
+                               (not (eq 'tls gwm))
+                               (not (eq 'ssl gwm))
+                               (string-match
+                                url-gateway-local-host-regexp
+                                host))
+                          'native
+                        gwm))
          ;; An attempt to deal with denied connections, and attempt
          ;; to reconnect
          (cur-retries 0)
@@ -233,8 +237,8 @@ Might do a non-blocking connection; use `process-status' to check."
          ;; right coding systems in both Emacs and XEmacs.
          (let ((coding-system-for-read 'binary)
                (coding-system-for-write 'binary))
-           (setq conn (case gw-method
-                        ((tls ssl native)
+           (setq conn (pcase gw-method
+                        ((or `tls `ssl `native)
                          (if (eq gw-method 'native)
                              (setq gw-method 'plain))
                          (open-network-stream
@@ -243,13 +247,13 @@ Might do a non-blocking connection; use `process-status' to check."
                           ;; Use non-blocking socket if we can.
                           :nowait (featurep 'make-network-process
                                             '(:nowait t))))
-                        (socks
+                        (`socks
                          (socks-open-network-stream name buffer host service))
-                        (telnet
+                        (`telnet
                          (url-open-telnet name buffer host service))
-                        (rlogin
+                        (`rlogin
                          (url-open-rlogin name buffer host service))
-                        (otherwise
+                        (_
                          (error "Bad setting of url-gateway-method: %s"
                                 url-gateway-method))))))
       conn)))